nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add initial prototype.

Browse Source
This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

325
3-mid/opengl/source/lean/io/opengl-io-collada.adb Normal file
View File

@@ -0,0 +1,325 @@
with
collada.Document,
collada.Library.geometries,
collada.Library.controllers,
ada.Text_IO;
package body openGL.IO.collada
is
package std_Collada renames Standard.Collada;
function to_Model (model_Path : in String) return IO.Model
is
use std_Collada.Library,
std_Collada.Library.geometries,
ada.Text_IO;
use type std_Collada.Library.controllers.Controller_array_view;
which_Geometry : constant := 1; -- Select which gemometry, just for testing.
the_Document : constant std_Collada.Document.item := std_Collada.Document.to_Document (model_Path);
the_Mesh : constant geometries.Mesh := the_Document.Libraries.Geometries.Contents (which_Geometry).Mesh;
the_Primitive : constant geometries.Primitive := the_Mesh.Primitives (1);
collada_Positions : constant access std_Collada.Float_array := Positions_of (the_Mesh);
collada_Normals : constant access std_Collada.Float_array := Normals_of (the_Mesh, the_Primitive);
collada_Coords : constant access std_Collada.Float_array := Coords_of (the_Mesh, the_Primitive);
function get_coord_Count return long_Index_t
is
begin
if collada_Coords = null
then
return 0;
else
return collada_Coords'Length / 2;
end if;
end get_coord_Count;
site_Count : constant long_Index_t := collada_Positions'Length / 3;
normal_Count : constant long_Index_t := collada_Normals 'Length / 3;
coord_Count : constant long_Index_t := get_coord_Count;
the_Sites : constant many_Sites_view := new many_Sites (1 .. site_Count);
the_Normals : constant many_Normals_view := new many_Normals (1 .. normal_Count);
the_Coords : many_Coords_view;
the_Weights : bone_Weights_array_view;
the_Faces : IO.Faces_view := new IO.Faces (1 .. 50_000);
face_Count : long_Index_t := 0;
begin
if coord_Count > 0
then
the_Coords := new many_Coordinates_2D (1 .. coord_Count);
end if;
for i in 1 .. Integer (site_Count)
loop
the_Sites (long_Index_t (i)) := [collada_Positions (3 * (i - 1) + 1),
collada_Positions (3 * (i - 1) + 2),
collada_Positions (3 * (i - 1) + 3)];
end loop;
for i in 1 .. Integer (normal_Count)
loop
the_Normals (long_Index_t (i)) := [collada_Normals (3 * (i - 1) + 1),
collada_Normals (3 * (i - 1) + 2),
collada_Normals (3 * (i - 1) + 3)];
end loop;
if collada_Coords /= null
then
for i in 1 .. Integer (coord_Count)
loop
the_Coords (long_Index_t (i)) := (collada_Coords (2 * (i - 1) + 1),
collada_Coords (2 * (i - 1) + 2));
end loop;
end if;
-- Skinning
--
if the_Document.Libraries.Controllers.Contents /= null
and then the_Document.Libraries.Controllers.Contents'Length > 0
then
declare
use std_Collada.Library.controllers;
the_Controller : constant controllers.Controller := the_Document.Libraries.Controllers.Contents (which_Geometry);
the_Skin : constant controllers.Skin := the_Controller.Skin;
collada_Weights : constant access std_Collada.Float_array := Weights_of (the_Skin);
V : std_Collada.Int_array renames the_Skin.vertex_Weights.V .all;
v_Count : std_Collada.Int_array renames the_Skin.vertex_Weights.v_Count.all;
v_Cursor : math.Index := 0;
inputs_Count : constant math.Index := the_Skin.vertex_Weights.Inputs'Length;
begin
the_Weights := new bone_Weights_array (1 .. long_Index_t (the_Skin.vertex_Weights.Count));
for each_Vertex in v_Count'Range
loop
declare
the_Count : constant long_Index_t := long_Index_t (v_Count (each_Vertex));
these_Weights : bone_Weights_view renames the_Weights (long_Index_t (each_Vertex));
Base : Math.Index;
begin
these_Weights := new bone_Weights (1 .. the_Count);
for i in 1 .. the_Count
loop
v_Cursor := v_Cursor + 1;
Base := (v_Cursor - 1) * inputs_Count + 1;
these_Weights (i).Bone := bone_Id ( 1
+ V (Base + joint_Offset_of (the_Skin.vertex_weights)));
these_Weights (i).Weight := Real (collada_Weights ( 1
+ math.Index (V ( Base
+ weight_Offset_of (the_Skin.vertex_Weights)))));
end loop;
end;
end loop;
end;
end if;
-- Primitives
--
case the_Primitive.Kind
is
when polyList =>
parse_polyList :
declare
P : std_Collada.Int_array renames the_Primitive.P_List (1).all;
inputs_Count : constant Natural := the_Primitive.Inputs'Length;
p_First : math.Index := 1;
p_Last : math.Index;
vertex_Count : Natural;
begin
for Each in the_Primitive.vCount'Range
loop
vertex_Count := the_Primitive.vCount (Each);
p_Last := p_First
+ math.Index (inputs_Count * vertex_Count)
- 1;
declare
the_Vertices : Vertices (1 .. long_Index_t (vertex_Count));
P_Indices : constant std_Collada.Int_array (1 .. p_Last - p_First + 1) := P (p_First .. p_Last);
the_Face : IO.Face;
Base : math.Index;
begin
for vertex_Id in the_Vertices'Range
loop
Base := math.Index (vertex_Id - 1)
* math.Index (inputs_Count)
+ 1;
the_Vertices (vertex_Id).site_Id := 1
+ long_Index_t (P_Indices ( Base
+ vertex_Offset_of (the_Primitive)));
the_Vertices (vertex_Id).normal_Id := 1
+ long_Index_t (P_Indices ( Base
+ normal_Offset_of (the_Primitive)));
if collada_Coords /= null
then
the_Vertices (vertex_Id).coord_Id := 1
+ long_Index_t ( P_Indices (Base
+ coord_Offset_of (the_Primitive)));
else
the_Vertices (vertex_Id).coord_Id := null_Id;
end if;
the_Vertices (vertex_Id).weights_Id := the_Vertices (vertex_Id).site_Id;
end loop;
case vertex_Count
is
when 3 => the_Face := (Triangle, the_Vertices);
when 4 => the_Face := (Quad, the_Vertices);
when others => put_Line ("parse_polyList ~ unhandled vertex count:" & vertex_Count'Image);
end case;
face_Count := face_Count + 1;
the_Faces (face_Count) := the_Face;
end;
p_First := p_Last + 1;
end loop;
end parse_polyList;
when Polygons =>
parse_Polygons:
declare
inputs_Count : constant Natural := the_Primitive.Inputs'Length;
begin
for Each in the_Primitive.P_List'Range
loop
declare
P_Indices : std_Collada.Int_array renames the_Primitive.P_List (Each).all;
vertex_Count : constant Natural := P_Indices'Length / inputs_Count;
the_Vertices : Vertices (1 .. long_Index_t (vertex_Count));
the_Face : IO.Face;
Base : math.Index;
begin
for vertex_Id in the_Vertices'Range
loop
Base := math.Index ( (Integer (vertex_Id) - 1)
* inputs_Count
+ 1);
the_Vertices (vertex_Id).site_Id := 1
+ long_Index_t (P_Indices ( Base
+ vertex_Offset_of (the_Primitive)));
the_Vertices (vertex_Id).normal_Id := 1
+ long_Index_t (P_Indices ( Base
+ normal_Offset_of (the_Primitive)));
if collada_Coords /= null
then
the_Vertices (vertex_Id).coord_Id := 1
+ long_Index_t (P_Indices ( Base
+ coord_Offset_of (the_Primitive)));
else
the_Vertices (vertex_Id).coord_Id := null_Id;
end if;
the_Vertices (vertex_Id).weights_Id := the_Vertices (vertex_Id).site_Id;
end loop;
case vertex_Count
is
when 3 => the_Face := (Triangle, the_Vertices);
when 4 => the_Face := (Quad, the_Vertices);
when others => put_Line ("parse_Polygons ~ unhandled vertex count:" & vertex_Count'Image);
end case;
face_Count := face_Count + 1;
the_Faces (face_Count) := the_Face;
end;
end loop;
end parse_Polygons;
when Triangles =>
parse_Triangles:
declare
inputs_Count : constant Natural := the_Primitive.Inputs'Length;
P_Indices : std_Collada.Int_array renames the_Primitive.P_List (1).all;
Base : math.Index := 1;
begin
for each_Tri in 1 .. the_Primitive.Count
loop
declare
vertex_Count : constant := 3;
the_Vertices : Vertices (1 .. vertex_Count);
the_Face : IO.Face;
begin
for vertex_Id in the_Vertices'Range
loop
the_Vertices (vertex_Id).site_Id := 1
+ long_Index_t (P_Indices ( Base
+ vertex_Offset_of (the_Primitive)));
the_Vertices (vertex_Id).normal_Id := 1
+ long_Index_t (P_Indices ( Base
+ normal_Offset_of (the_Primitive)));
if collada_Coords /= null
then
the_Vertices (vertex_Id).coord_Id := 1
+ long_Index_t (P_Indices ( Base
+ coord_Offset_of (the_Primitive)));
else
the_Vertices (vertex_Id).coord_Id := null_Id;
end if;
the_Vertices (vertex_Id).weights_Id := the_Vertices (vertex_Id).site_Id;
Base := Base + inputs_Count;
end loop;
the_Face := (Triangle, the_Vertices);
face_Count := face_Count + 1;
the_Faces (face_Count) := the_Face;
end;
end loop;
end parse_Triangles;
when others =>
put_Line ("Warning: ignoring unimplemented primitive kind: " & the_Primitive.Kind'Image);
end case;
declare
used_Faces : constant IO.Faces_view := new IO.Faces' (the_Faces (1 .. face_Count));
begin
free (the_Faces);
return (Sites => the_Sites,
Coords => the_Coords,
Normals => the_Normals,
Weights => the_Weights,
Faces => used_Faces);
end;
end to_Model;
end openGL.IO.collada;

9
3-mid/opengl/source/lean/io/opengl-io-collada.ads Normal file
View File

@@ -0,0 +1,9 @@
package openGL.IO.collada
--
-- Provides a function to convert a Collada model file to an openGL IO model.
--
is
function to_Model (model_Path : in String) return IO.Model;
end openGL.IO.collada;

80
3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.adb Normal file
View File

@@ -0,0 +1,80 @@
with
float_Math.Geometry.d3.Modeller.Forge;
package body openGL.IO.lat_long_Radius
is
function to_Model (math_Model : access Geometry_3d.a_Model) return IO.Model
is
site_Count : constant long_Index_t := long_Index_t (math_Model.site_Count);
coord_Count : constant long_Index_t := 0; --get_coord_Count; -- TODO: Add texturing.
normal_Count : constant long_Index_t := 0; --collada_Normals'Length / 3; -- TODO: Add lighting.
the_Sites : constant many_Sites_view := new many_Sites (1 .. site_Count);
the_Normals : constant many_Normals_view := new many_Normals (1 .. normal_Count);
the_Coords : many_Coords_view;
the_Faces : IO.Faces_view := new IO.Faces (1 .. 50_000);
face_Count : long_Index_t := 0;
begin
if coord_Count > 0
then
the_Coords := new many_Coordinates_2D (1 .. coord_Count);
end if;
for i in 1 .. Integer (site_Count)
loop
the_Sites (long_Index_t (i)) := math_Model.Sites (i);
end loop;
-- Primitives
--
declare
the_Vertices : Vertices (1 .. long_Index_t (math_Model.tri_Count * 3));
Start : long_Index_t;
the_Face : IO.Face;
begin
for i in math_Model.Triangles'Range
loop
Start := long_Index_t ((i - 1) * 3 + 1);
the_Vertices (Start ) := (site_Id => long_Index_t (math_Model.Triangles (i) (1)), others => 0);
the_Vertices (Start + 1) := (site_Id => long_Index_t (math_Model.Triangles (i) (2)), others => 0);
the_Vertices (Start + 2) := (site_Id => long_Index_t (math_Model.Triangles (i) (3)), others => 0);
the_Face := (Triangle,
the_Vertices (Start .. Start + 2));
face_Count := face_Count + 1;
the_Faces (face_Count) := the_Face;
end loop;
end;
declare
used_Faces : constant IO.Faces_view := new IO.Faces' (the_Faces (1 .. face_Count));
begin
free (the_Faces);
return (Sites => the_Sites,
Coords => the_Coords,
Normals => the_Normals,
Weights => null,
Faces => used_Faces);
end;
end to_Model;
function to_Model (model_File : in String) return IO.Model
is
use float_Math.Geometry.d3.Modeller.Forge;
the_math_Model : aliased Geometry_3d.a_Model := mesh_Model_from (Model => polar_Model_from (model_File));
begin
return to_Model (the_math_Model'Access);
end to_Model;
end openGL.IO.lat_long_Radius;

11
3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.ads Normal file
View File

@@ -0,0 +1,11 @@
package openGL.IO.lat_long_Radius
--
-- Provides a function to convert a model file containing longitude, latitude
-- and radius triplets (one triplet per line) to an openGL IO model.
--
is
function to_Model (model_File : in String) return IO.Model;
function to_Model (math_Model : access Geometry_3d.a_Model) return IO.Model;
end openGL.IO.lat_long_Radius;

519
3-mid/opengl/source/lean/io/opengl-io-wavefront.adb Normal file
View File

@@ -0,0 +1,519 @@
with
ada.Text_IO,
ada.Integer_Text_IO,
ada.Strings.fixed,
ada.Strings.unbounded;
package body openGL.IO.wavefront
is
package real_Text_IO is new Ada.Text_IO.Float_IO (openGL.Real);
function to_Text (Self : in String) return Text
is
begin
return ada.Strings.unbounded.to_unbounded_String (Self);
end to_Text;
function to_Vector_3 (Self : in String) return Vector_3
is
use real_Text_IO;
X, Y, Z : Real;
Last : Natural;
begin
get (Self, X, Last);
get (Self (Last + 1 .. Self'Last), Y, Last);
get (Self (Last + 1 .. Self'Last), Z, Last);
return [X, Y, Z];
end to_Vector_3;
function to_Coordinate (Self : in String) return Coordinate_2D
is
use real_Text_IO;
U, V : Real;
Last : Natural;
begin
get (Self, U, Last);
get (Self (Last + 1 .. Self'Last), V, Last);
return (U, V);
end to_Coordinate;
function to_Facet (Self : in String) return IO.Face
is
use ada.Integer_Text_IO;
site_Id,
coord_Id,
normal_Id : Integer;
the_Vertices : Vertices (1 .. 5_000);
vertex_Count : long_Index_t := 0;
Last : Natural := Self'First - 1;
begin
loop
get (Self (Last + 1 .. Self'Last),
site_Id,
Last);
if Last = Self'Last
or else Self (Last + 1) = ' '
then -- Both texture coord and normal are absent.
coord_Id := Integer (null_Id);
normal_Id := Integer (null_Id);
elsif Self (Last + 1) = '/'
then
if Self (Last + 2) = '/'
then -- Texture coord is absent.
coord_Id := Integer (null_Id);
get (Self (Last + 3 .. Self'Last),
normal_Id,
Last);
else
get (Self (Last + 2 .. Self'Last),
coord_Id,
Last);
if Last = Self'Last
or else Self (Last + 1) = ' '
then -- Lighting normal is absent.
normal_Id := Integer (null_Id);
elsif Self (Last + 1) = '/'
then
get (Self (Last + 2 .. Self'Last),
normal_Id,
Last);
else
raise Constraint_Error with "Invalid indices: " & Self & ".";
end if;
end if;
else
raise Constraint_Error with "Invalid indices: " & Self & ".";
end if;
if site_Id < 0
or else coord_Id < 0
or else normal_Id < 0
then
raise Constraint_Error with "Negative indices not implemented: " & Self & ".";
end if;
vertex_Count := vertex_Count + 1;
the_Vertices (vertex_Count) := (long_Index_t ( site_Id),
long_Index_t ( coord_Id),
long_Index_t (normal_Id),
null_Id);
exit when Last + 1 >= Self'Last;
end loop;
case vertex_Count
is
when 3 => return (Triangle, the_Vertices (1 .. 3));
when 4 => return (Quad, the_Vertices (1 .. 4));
when others => return (Polygon, new Vertices' (the_Vertices (1 .. vertex_Count)));
end case;
end to_Facet;
function to_Model (model_File : in String) return IO.Model
is
use ada.Strings.fixed,
ada.Text_IO;
the_File : File_Type;
max_Elements : constant := 200_000;
the_Sites : many_Sites_view := new many_Sites (1 .. max_Elements);
the_Coords : many_Coords_view := new many_Coordinates_2D (1 .. max_Elements);
the_Normals : many_Normals_view := new many_Normals (1 .. max_Elements);
the_Faces : IO.Faces_view := new IO.Faces' (1 .. max_Elements => <>);
site_Count : long_Index_t := 0;
coord_Count : long_Index_t := 0;
normal_Count : long_Index_t := 0;
face_Count : long_Index_t := 0;
begin
open (the_File, In_File, model_File);
while not end_of_File (the_File)
loop
declare
the_Line : constant String := get_Line (the_File);
begin
if the_Line'Length = 0 or else the_Line (1) = '#'
then
null;
elsif Head (the_Line, 6) = "mtllib"
then
null; -- TODO
elsif Head (the_Line, 2) = "f "
then
face_Count := face_Count + 1;
the_Faces (face_Count) := to_Facet (the_Line (3 .. the_Line'Last));
elsif Head (the_Line, 2) = "v "
then
site_Count := site_Count + 1;
the_Sites (site_Count) := to_Vector_3 (the_Line (3 .. the_Line'Last));
elsif Head (the_Line, 3) = "vt "
then
coord_Count := coord_Count + 1;
the_Coords (coord_Count) := to_Coordinate (the_Line (4 .. the_Line'Last));
elsif Head (the_Line, 3) = "vn "
then
normal_Count := normal_Count + 1;
the_Normals (normal_Count) := to_Vector_3 (the_Line (4 .. the_Line'Last));
elsif Head (the_Line, 2) = "o "
then
null; -- Currently ignored. TODO
elsif Head (the_Line, 2) = "g "
then
null; -- Currently ignored. TODO
elsif Head (the_Line, 2) = "s "
then
null; -- Currently ignored. TODO
else
null; -- Currently ignored. TODO
end if;
end;
end loop;
close (the_File);
declare
used_Sites : constant IO. many_Sites_view := new many_Sites' (the_Sites (1 .. site_Count));
used_Coords : constant IO. many_Coords_view := new many_Coordinates_2D' (the_Coords (1 .. coord_Count));
used_Normals : constant IO.many_Normals_view := new many_Normals' (the_Normals (1 .. normal_Count));
used_Faces : constant IO. Faces_view := new IO.Faces' (the_Faces (1 .. face_Count));
begin
free (the_Sites);
free (the_Coords);
free (the_Normals);
free (the_Faces);
return (Sites => used_Sites,
Coords => used_Coords,
Normals => used_Normals,
Weights => null,
Faces => used_Faces);
end;
end to_Model;
----------
--- Images
--
function Image (Self : in IO.Face) return String
is
use ada.Strings.unbounded;
the_Vertices : Vertices renames Vertices_of (Self);
the_Image : unbounded_String := to_unbounded_String ("f ");
function id_Image (Self : in long_Index_t) return String
is
use ada.Strings.fixed;
begin
return Trim (long_Index_t'Image (Self),
ada.Strings.left);
end id_Image;
begin
for i in the_Vertices'Range
loop
append (the_Image,
id_Image (the_Vertices (i).site_Id));
if the_Vertices (i).coord_Id = null_Id
then
if the_Vertices (i).normal_Id /= null_Id
then
append (the_Image, "/");
end if;
else
append (the_Image, "/" & id_Image (the_Vertices (i).coord_Id));
end if;
-- if the_Vertices (i).normal_Id /= null_Id
-- then
-- append (the_Image,
-- "/" & id_Image (the_Vertices (i).normal_Id));
-- end if;
append (the_Image, " ");
end loop;
return to_String (the_Image);
end Image;
function Image (Self : in wavefront.Group) return String
is
use ada.Strings.unbounded;
begin
case Self.Kind
is
when object_Name => return "o " & to_String (Self.object_Name);
when group_Name => return "g " & to_String (Self. group_Name);
when smoothing_Group => return "s" & Self.smooth_group_Id'Image;
when merging_Group => return ""; -- TODO
end case;
end Image;
function Image (Self : in wavefront.Face) return String
is
begin
case Self.Kind
is
when a_Group => return Image (Self.Group);
when a_Facet => return Image (Self.Facet);
end case;
end Image;
type wf_Faces_view is access all wavefront.Faces;
function to_Model (model_Path : in String) return wavefront.Model
is
use ada.Strings.fixed,
ada.Text_IO;
the_material_Library : Text;
the_material_Name : Text;
the_object_Name : Text;
the_group_Name : Text;
the_Sites : Sites (1 .. 50_000);
site_Count : Index_t := 0;
the_Coords : Coordinates_2D (1 .. 50_000);
coord_Count : Index_t := 0;
the_Normals : Normals (1 .. 50_000);
normal_Count : Index_t := 0;
the_Faces : wf_Faces_view := new Faces' (1 .. 100_000 => <>);
face_Count : long_Index_t := 0;
the_File : File_Type;
begin
Open (the_File, In_File, model_Path);
while not End_Of_File (the_File)
loop
declare
use ada.Strings.unbounded;
the_Line : constant String := Get_Line (the_File);
begin
if the_Line'Length = 0 or else the_Line (1) = '#' then
null;
elsif Head (the_Line, 6) = "mtllib" then
the_material_Library := to_unbounded_String (the_Line (8 .. the_Line'Last));
elsif Head (the_Line, 6) = "usemtl" then
the_material_Name := to_unbounded_String (the_Line (8 .. the_Line'Last));
elsif Head (the_Line, 2) = "f " then
face_Count := face_Count + 1;
the_Faces (face_Count) := (a_Facet,
to_Facet (the_Line (3 .. the_Line'Last)));
elsif Head (the_Line, 2) = "v " then
site_Count := site_Count + 1;
the_Sites (site_Count) := to_Vector_3 (the_Line (3 .. the_Line'Last));
elsif Head (the_Line, 3) = "vt " then
coord_Count := coord_Count + 1;
the_Coords (coord_Count) := to_Coordinate (the_Line (4 .. the_Line'Last));
elsif Head (the_Line, 3) = "vn " then
normal_Count := normal_Count + 1;
the_Normals (normal_Count) := to_Vector_3 (the_Line (4 .. the_Line'Last));
elsif Head (the_Line, 2) = "o " then
the_object_Name := to_unbounded_String (the_Line (3 .. the_Line'Last));
-- face_Count := face_Count + 1;
-- the_Faces (face_Count) := (a_Group,
-- (object_Name,
-- object_Name => to_Text (the_Line (3 .. the_Line'Last))));
elsif Head (the_Line, 2) = "g " then
the_group_Name := to_unbounded_String (the_Line (3 .. the_Line'Last));
-- face_Count := face_Count + 1;
-- the_Faces (face_Count) := (a_Group,
-- (group_Name,
-- group_Name => to_Text (the_Line (3 .. the_Line'Last))));
elsif Head (the_Line, 2) = "s " then
declare
use Ada.Integer_Text_IO;
the_Id : Natural;
Last : Natural;
begin
if Head (the_Line, 5) = "s off" then
the_Id := 0;
else
Get (the_Line (3 .. the_Line'Last), the_Id, Last);
end if;
face_Count := face_Count + 1;
the_Faces (face_Count) := (a_Group,
(smoothing_Group,
smooth_group_Id => the_Id));
end;
else
put_Line ("openGL.io.wavefront ~ Unhandled line in " & model_Path & ": '" & the_Line & "'");
end if;
end;
end loop;
Close (the_File);
declare
procedure free is new Ada.Unchecked_Deallocation (Faces, wf_Faces_view);
used_Faces : constant wf_Faces_view := new wavefront.Faces'(the_Faces (1 .. face_Count));
begin
free (the_Faces);
return (material_Library => the_material_Library,
material_Name => the_material_Name,
object_Name => the_object_Name,
group_Name => the_group_Name,
Sites => new openGL.Sites' (the_Sites (1 .. site_Count)),
Coords => new Coordinates_2D' (the_Coords (1 .. coord_Count)),
Normals => new openGL.Normals' (the_Normals (1 .. normal_Count)),
Faces => used_Faces);
end;
end to_Model;
procedure write (the_Model : in wavefront.Model; to_File : in String)
is
use ada.Strings.unbounded,
ada.Text_IO;
the_File : File_type;
use Real_text_IO;
begin
Create (the_File, Out_File, Name => to_File);
if the_Model.material_Library /= ""
then
put_Line (the_File, "mtllib " & to_String (the_Model.material_Library));
new_Line (the_File);
end if;
if the_Model.object_Name /= ""
then
put_Line (the_File, "o " & to_String (the_Model.object_Name));
new_Line (the_File);
end if;
-- Write sites.
--
for Each in the_Model.Sites'Range
loop
Put (the_File, "v ");
Put (the_File, the_Model.Sites (Each) (1), Aft => 19, Exp => 0);
Put (the_File, " ");
Put (the_File, the_Model.Sites (Each) (2), Aft => 19, Exp => 0);
Put (the_File, " ");
Put (the_File, the_Model.Sites (Each) (3), Aft => 19, Exp => 0);
New_Line (the_File);
end loop;
New_Line (the_File);
-- Write texture coords.
--
for Each in the_Model.Coords'Range
loop
Put (the_File, "vt ");
Put (the_File, the_Model.Coords (Each).S, Aft => 19, Exp => 0);
Put (the_File, " ");
Put (the_File, the_Model.Coords (Each).T, Aft => 19, Exp => 0);
New_Line (the_File);
end loop;
-- New_Line (the_File);
-- Write normals.
--
-- for Each in the_Model.Normals'Range
-- loop
-- Put (the_File, "vn ");
-- Put (the_File, the_Model.Normals (Each) (1), Aft => 19, Exp => 0);
-- Put (the_File, " ");
-- Put (the_File, the_Model.Normals (Each) (2), Aft => 19, Exp => 0);
-- Put (the_File, " ");
-- Put (the_File, the_Model.Normals (Each) (3), Aft => 19, Exp => 0);
--
-- New_Line (the_File);
-- end loop;
New_Line (the_File);
-- Write faces.
--
if the_Model.group_Name /= ""
then
put_Line (the_File, "g " & to_String (the_Model.group_Name));
new_Line (the_File);
end if;
if the_Model.material_Name /= ""
then
put_Line (the_File, "usemtl " & to_String (the_Model.material_Name));
new_Line (the_File);
end if;
for Each in the_Model.Faces'Range
loop
Put_Line (the_File, Image (the_Model.Faces (Each)));
end loop;
Close (the_File);
end write;
end openGL.IO.wavefront;

80
3-mid/opengl/source/lean/io/opengl-io-wavefront.ads Normal file
View File

@@ -0,0 +1,80 @@
package openGL.IO.wavefront
--
-- Provides a function to convert a Wavefront model file (*.obj) to an openGL IO model.
--
is
---------
-- Group
--
type group_Kind is (object_Name, group_Name,
smoothing_Group, merging_Group);
type Group (Kind : group_Kind := group_Name) is
record
case Kind
is
when object_Name => object_Name : Text;
when group_Name => group_Name : Text;
when smoothing_Group => smooth_group_Id : Natural;
when merging_Group => null;
end case;
end record;
function Image (Self : in Group) return String;
--------
-- Face
--
type face_Kind is (a_Group, a_Facet);
type Face (Kind : face_Kind := a_Facet) is
record
case Kind
is
when a_Group => Group : wavefront.Group;
when a_Facet => Facet : openGL.IO.Face;
end case;
end record;
type Faces is array (long_Index_t range <>) of Face;
function Image (Self : in wavefront.Face) return String;
function to_Model (model_File : in String) return IO.Model;
type Sites_view is access openGL.Sites;
type Coordinates_2D_view is access openGL.Coordinates_2D;
type Normals_view is access openGL.Normals;
type Model is
record
material_Library : Text;
material_Name : Text;
object_Name : Text;
group_Name : Text;
Sites : Sites_view;
Coords : Coordinates_2D_view;
Normals : Normals_view;
Faces : access wavefront.Faces;
end record;
function to_Model (model_Path : in String) return wavefront.Model;
procedure write (the_Model : in wavefront.Model;
to_File : in String);
-----------
-- Utility
--
function to_Vector_3 (Self : in String) return Vector_3;
function to_Coordinate (Self : in String) return Coordinate_2D;
function to_Text (Self : in String) return Text;
end openGL.IO.wavefront;

917
3-mid/opengl/source/lean/io/opengl-io.adb Normal file
View File

@@ -0,0 +1,917 @@
with
openGL.Images,
openGL.Viewport,
openGL.Tasks,
openGL.Errors,
GID,
GL.Binding,
GL.safe,
GL.Pointers,
ada.unchecked_Conversion,
ada.Calendar,
ada.Characters.handling,
System;
package body openGL.IO
is
use ada.Characters.handling,
ada.Streams.Stream_IO;
use type Index_t;
--------
-- Face
--
function Vertices_of (Self : in Face) return Vertices
is
begin
case Self.Kind
is
when Triangle => return Self.Tri;
when Quad => return Self.Quad;
when Polygon => return Self.Poly.all;
end case;
end Vertices_of;
procedure set_Vertex_in (Self : in out Face; Which : in long_Index_t;
To : in Vertex)
is
begin
case Self.Kind
is
when Triangle => Self.Tri (Which) := To;
when Quad => Self.Quad (Which) := To;
when Polygon => Self.Poly (Which) := To;
end case;
end set_Vertex_in;
procedure destroy (Self : in out Face)
is
procedure free is new ada.unchecked_Deallocation (Vertices, Vertices_view);
begin
if Self.Kind = Polygon
then
free (Self.Poly);
end if;
end destroy;
-------------
-- Operations
--
function current_Frame return Image
is
use GL,
GL.Binding,
GL.Pointers,
Texture;
Extent : constant Extent_2d := openGL.Viewport.Extent;
Frame : Image (1 .. Index_t (Extent.Width),
1 .. Index_t (Extent.Height));
begin
glReadPixels (0, 0,
GLsizei (Extent.Width),
GLsizei (Extent.Height),
to_GL (Format' (Texture.RGB)),
GL_UNSIGNED_BYTE,
to_GLvoid_access (Frame (1, 1).Red'Access));
return Frame;
end current_Frame;
---------
-- Forge
--
function to_height_Map (image_Filename : in asset_Name;
Scale : in Real := 1.0) return height_Map_view
is
File : Ada.Streams.Stream_IO.File_Type;
Image : GID.Image_Descriptor;
up_Name : constant String := To_Upper (to_String (image_Filename));
next_Frame : ada.Calendar.Day_Duration := 0.0;
begin
open (File, in_File, to_String (image_Filename));
GID.load_Image_Header (Image,
Stream (File).all,
try_tga => image_Filename'Length >= 4
and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
declare
image_Width : constant Positive := GID.Pixel_Width (Image);
image_Height : constant Positive := GID.Pixel_Height (Image);
the_Heights : constant access height_Map := new height_Map' (1 .. Index_t (image_height) =>
(1 .. Index_t (image_width) => <>));
procedure load_raw_Image
is
subtype primary_Color_range is GL.GLubyte;
Row, Col : Index_t;
procedure set_X_Y (x, y : Natural)
is
begin
Col := Index_t (X + 1);
Row := Index_t (Y + 1);
end Set_X_Y;
procedure put_Pixel (Red, Green, Blue : primary_Color_range;
Alpha : primary_Color_range)
is
pragma Warnings (Off, alpha); -- Alpha is just ignored.
use type GL.GLubyte, Real;
begin
the_Heights (Row, Col) := (Real (Red) + Real (Green) + Real (Blue))
/ (3.0 * 255.0)
* Scale;
if Col = Index_t (image_Width)
then
Row := Row + 1;
Col := 1;
else
Col := Col + 1;
end if;
-- ^ GID requires us to look to next pixel on the right for next time.
end put_Pixel;
procedure Feedback (Percents : Natural) is null;
procedure load_Image is new GID.load_Image_contents (primary_Color_range,
set_X_Y,
put_Pixel,
Feedback,
GID.fast);
begin
load_Image (Image, next_Frame);
end load_Raw_image;
begin
load_raw_Image;
close (File);
return the_Heights.all'unchecked_Access;
end;
end to_height_Map;
function fetch_Image (Stream : in ada.Streams.Stream_IO.Stream_access;
try_TGA : in Boolean) return Image
is
begin
return Images.fetch_Image (Stream, try_TGA);
end fetch_Image;
function to_Image (image_Filename : in asset_Name) return Image
is
File : ada.Streams.Stream_IO.File_type;
up_Name : constant String := to_Upper (to_String (image_Filename));
begin
open (File, In_File, to_String (image_Filename));
declare
the_Image : constant Image
:= fetch_Image (Stream (File),
try_TGA => image_Filename'Length >= 4
and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
begin
close (File);
return the_Image;
end;
end to_Image;
function to_lucid_Image (image_Filename : in asset_Name) return lucid_Image
is
Unused : aliased Boolean;
begin
return to_lucid_Image (image_Filename, Unused'Access);
end to_lucid_Image;
function to_lucid_Image (image_Filename : in asset_Name;
is_Lucid : access Boolean) return lucid_Image
is
File : ada.Streams.Stream_IO.File_type;
the_Image : GID.Image_Descriptor;
up_Name : constant String := to_Upper (to_String (image_Filename));
next_Frame : ada.Calendar.Day_Duration := 0.0;
begin
open (File, in_File, to_String (image_Filename));
GID.load_Image_Header (the_Image,
Stream (File).all,
try_TGA => image_Filename'Length >= 4
and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
declare
image_Width : constant Positive := GID.Pixel_Width (the_Image);
image_Height : constant Positive := GID.Pixel_Height (the_Image);
Frame : lucid_Image (1 .. Index_t (image_Height),
1 .. Index_t (image_Width));
procedure load_raw_Image
is
subtype primary_Color_range is GL.GLubyte;
Row, Col : Index_t;
procedure set_X_Y (X, Y : Natural)
is
begin
Col := Index_t (X + 1);
Row := Index_t (Y + 1);
end set_X_Y;
procedure put_Pixel (Red, Green, Blue : primary_Color_range;
Alpha : primary_Color_range)
is
use type GL.GLubyte, Real;
begin
Frame (Row, Col) := ((Red, Green, Blue), Alpha);
if Col = Index_t (image_Width)
then -- GID requires us to look to next pixel on the right for next time.
Row := Row + 1;
Col := 1;
else
Col := Col + 1;
end if;
if Alpha /= opaque_Value
then
is_Lucid.all := True;
end if;
end put_Pixel;
procedure Feedback (Percents : Natural) is null;
procedure load_Image is new GID.load_Image_contents (primary_Color_range,
set_X_Y,
put_Pixel,
Feedback,
GID.fast);
begin
load_Image (the_Image, next_Frame);
end Load_raw_image;
begin
is_Lucid.all := False;
load_raw_Image;
close (File);
return Frame;
end;
end to_lucid_Image;
function to_Texture (image_Filename : in asset_Name) return Texture.Object
is
use Texture;
is_Lucid : aliased Boolean;
the_lucid_Image : constant lucid_Image := to_lucid_Image (image_Filename, is_Lucid'Access);
the_Texture : Texture.Object := Forge.to_Texture (Texture.Dimensions' (the_lucid_Image'Length (2),
the_lucid_Image'Length (1)));
begin
if is_Lucid
then
set_Image (the_Texture, the_lucid_Image);
else
declare
the_opaque_Image : constant Image := to_Image (the_lucid_Image);
begin
set_Image (the_Texture, the_opaque_Image);
end;
end if;
return the_Texture;
end to_Texture;
procedure destroy (Self : in out Model)
is
procedure free is new ada.unchecked_Deallocation (bone_Weights, bone_Weights_view);
procedure free is new ada.unchecked_Deallocation (bone_Weights_array, bone_Weights_array_view);
begin
free (Self.Sites);
free (Self.Coords);
free (Self.Normals);
if Self.Weights /= null
then
for Each in Self.Weights'Range
loop
free (Self.Weights (Each));
end loop;
free (Self.Weights);
end if;
for Each in Self.Faces'Range
loop
destroy (Self.Faces (Each));
end loop;
free (Self.Faces);
end destroy;
--------------------
--- Raw Image Frames
--
procedure write_raw_Frame (to_Stream : in Stream_access;
Width, Height : in Natural;
with_Alpha : in Boolean)
is
use GL,
GL.Binding,
Texture;
-- 4-byte padding for .bmp/.avi formats is the same as GL's default
-- padding: see glPixelStore, GL_[UN]PACK_ALIGNMENT = 4 as initial value.
-- http://www.openGL.org/sdk/docs/man/xhtml/glPixelStore.xml
--
padded_row_Size : constant Positive := (if with_Alpha then 4 * Integer (Float'Ceiling (Float (Width)))
else 4 * Integer (Float'Ceiling (Float (Width) * 3.0 / 4.0)));
-- (in bytes)
type temp_Bitmap_type is array (Natural range <>) of aliased gl.GLUbyte;
PicData : temp_Bitmap_type (0 .. (padded_row_size + 4) * (height + 4) - 1);
--
-- No dynamic allocation needed!
-- The "+4" are there to avoid parity address problems when GL writes
-- to the buffer.
type Loc_pointer is new gl.safe.GLvoid_Pointer;
function convert is new ada.unchecked_Conversion (System.Address, Loc_pointer);
--
-- This method is functionally identical as GNAT's Unrestricted_Access
-- but has no type safety (cf GNAT Docs).
pragma no_strict_Aliasing (Loc_pointer); -- Recommended by GNAT 2005+.
pPicData : Loc_pointer;
data_Max : constant Integer := padded_row_Size * Height - 1;
-- Workaround for the severe xxx'Read xxx'Write performance
-- problems in the GNAT and ObjectAda compilers (as in 2009)
-- This is possible if and only if Byte = Stream_Element and
-- arrays types are both packed the same way.
--
type Byte_array is array (Integer range <>) of aliased GLUByte;
subtype Size_Test_a is Byte_Array (1..19);
subtype Size_Test_b is ada.Streams.Stream_Element_array (1 .. 19);
Workaround_possible: constant Boolean := Size_Test_a'Size = Size_Test_b'Size
and then Size_Test_a'Alignment = Size_Test_b'Alignment;
begin
Tasks.check;
pPicData:= convert (PicData (0)'Address);
GLReadPixels (0, 0,
GLSizei (width),
GLSizei (height),
(if with_Alpha then to_GL (openGL.Texture.BGRA)
else to_GL (openGL.Texture.BGR)),
GL.GL_UNSIGNED_BYTE,
pPicData);
Errors.log;
if Workaround_possible
then
declare
use ada.Streams;
SE_Buffer : Stream_Element_array (0 .. Stream_Element_Offset (PicData'Last));
for SE_Buffer'Address use PicData'Address;
pragma Import (Ada, SE_Buffer);
begin
ada.Streams.write (to_Stream.all, SE_Buffer (0 .. Stream_Element_Offset (data_Max)));
end;
else
temp_Bitmap_type'write (to_Stream, PicData (0 .. data_Max));
end if;
end write_raw_Frame;
--------------
-- Bitmap File
--
type U8 is mod 2 ** 8; for U8 'Size use 8;
type U16 is mod 2 ** 16; for U16'Size use 16;
type U32 is mod 2 ** 32; for U32'Size use 32;
type I32 is range -2 ** 31 .. 2 ** 31 - 1;
for I32'Size use 32;
generic
type Number is mod <>;
S : Stream_Access;
procedure write_Intel_x86_Number (N : in Number);
procedure write_Intel_x86_Number (N : in Number)
is
M : Number := N;
Bytes : constant Integer := Number'Size / 8;
begin
for i in 1 .. bytes
loop
U8'write (S, U8 (M mod 256));
M := M / 256;
end loop;
end write_Intel_x86_Number;
subtype FxPt2dot30 is U32;
type CIExyz is
record
ciexyzX : FxPt2dot30;
ciexyzY : FxPt2dot30;
ciexyzZ : FxPt2dot30;
end record;
type CIExyzTriple is
record
ciexyzRed : CIExyz;
ciexyzGreen : CIExyz;
ciexyzBlue : CIExyz;
end record;
type BitMapFileHeader is
record
bfType : U16;
bfSize : U32;
bfReserved1 : U16 := 0;
bfReserved2 : U16 := 0;
bfOffBits : U32;
end record;
pragma pack (BitMapFileHeader);
for BitMapFileHeader'Size use 8 * 14;
type BitMapInfoHeader is
record
biSize : U32;
biWidth : I32;
biHeight : I32;
biPlanes : U16;
biBitCount : U16;
biCompression : U32;
biSizeImage : U32;
biXPelsPerMeter : I32 := 0;
biYPelsPerMeter : I32 := 0;
biClrUsed : U32 := 0;
biClrImportant : U32 := 0;
end record;
pragma pack (BitMapInfoHeader);
for BitMapInfoHeader'Size use 8 * 40;
type BitMapV4Header is
record
Core : BitMapInfoHeader;
bV4RedMask : U32;
bV4GreenMask : U32;
bV4BlueMask : U32;
bV4AlphaMask : U32;
bV4CSType : U32;
bV4Endpoints : CIExyzTriple;
bV4GammaRed : U32;
bV4GammaGreen : U32;
bV4GammaBlue : U32;
end record;
pragma pack (BitMapV4Header);
for BitMapV4Header'Size use 8 * 108;
procedure write_BMP_Header (to_Stream : in Stream_Access;
Width, Height : in GL.GLint;
with_Alpha : in Boolean)
is
use GL,
GL.Binding,
Texture;
FileHeader : BitMapFileHeader;
FileInfo : BitMapV4Header;
begin
FileHeader.bfType := 16#4D42#; -- 'BM'
FileInfo.Core.biWidth := I32 (Width);
FileInfo.Core.biHeight := I32 (Height);
FileInfo.Core.biPlanes := 1;
if with_Alpha
then
FileHeader.bfOffBits := BitMapFileHeader'Size / 8
+ BitMapV4Header 'Size / 8;
FileInfo.Core.biSize := BitMapV4Header'Size / 8;
FileInfo.Core.biBitCount := 32;
FileInfo.Core.biCompression := 3;
FileInfo.Core.biSizeImage := U32 ( 4 -- 4-byte padding for '.bmp/.avi' formats.
* Integer (Float'Ceiling (Float (FileInfo.Core.biWidth)))
* Integer (FileInfo.Core.biHeight));
FileInfo.bV4RedMask := 16#00FF0000#;
FileInfo.bV4GreenMask := 16#0000FF00#;
FileInfo.bV4BlueMask := 16#000000FF#;
FileInfo.bV4AlphaMask := 16#FF000000#;
FileInfo.bV4CSType := 0;
FileInfo.bV4Endpoints := (others => (others => 0));
FileInfo.bV4GammaRed := 0;
FileInfo.bV4GammaGreen := 0;
FileInfo.bV4GammaBlue := 0;
else
FileHeader.bfOffBits := BitMapFileHeader'Size / 8
+ BitMapInfoHeader'Size / 8;
FileInfo.Core.biSize := BitMapInfoHeader'Size / 8;
FileInfo.Core.biBitCount := 24;
FileInfo.Core.biCompression := 0;
FileInfo.Core.biSizeImage := U32 ( 4 -- 4-byte padding for '.bmp/.avi' formats.
* Integer (Float'Ceiling (Float (FileInfo.Core.biWidth) * 3.0 / 4.0))
* Integer (FileInfo.Core.biHeight));
end if;
FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.Core.biSizeImage;
declare
procedure write_Intel is new write_Intel_x86_Number (U16, to_Stream);
procedure write_Intel is new write_Intel_x86_Number (U32, to_Stream);
function convert is new ada.unchecked_Conversion (I32, U32);
begin
-- ** Endian-safe: ** --
write_Intel (FileHeader.bfType);
write_Intel (FileHeader.bfSize);
write_Intel (FileHeader.bfReserved1);
write_Intel (FileHeader.bfReserved2);
write_Intel (FileHeader.bfOffBits);
--
write_Intel ( FileInfo.Core.biSize);
write_Intel (convert (FileInfo.Core.biWidth));
write_Intel (convert (FileInfo.Core.biHeight));
write_Intel ( FileInfo.Core.biPlanes);
write_Intel ( FileInfo.Core.biBitCount);
write_Intel ( FileInfo.Core.biCompression);
write_Intel ( FileInfo.Core.biSizeImage);
write_Intel (convert (FileInfo.Core.biXPelsPerMeter));
write_Intel (convert (FileInfo.Core.biYPelsPerMeter));
write_Intel ( FileInfo.Core.biClrUsed);
write_Intel ( FileInfo.Core.biClrImportant);
if with_Alpha
then
write_Intel (FileInfo.bV4RedMask);
write_Intel (FileInfo.bV4GreenMask);
write_Intel (FileInfo.bV4BlueMask);
write_Intel (FileInfo.bV4AlphaMask);
write_Intel (FileInfo.bV4CSType);
write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzX);
write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzY);
write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzZ);
write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzX);
write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzY);
write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzZ);
write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzX);
write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzY);
write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzZ);
write_Intel (FileInfo.bV4GammaRed);
write_Intel (FileInfo.bV4GammaGreen);
write_Intel (FileInfo.bV4GammaBlue);
end if;
end;
end write_BMP_Header;
-------------
-- Save Image
--
procedure save (image_Filename : in String;
the_Image : in Image)
is
use GL,
GL.Binding,
ada.Streams.Stream_IO;
File : ada.Streams.Stream_IO.File_type;
S : ada.Streams.Stream_IO.Stream_access;
Size : Extent_2D := (Width => the_Image'Length (2),
Height => the_Image'Length (1));
begin
create (File, out_File, image_Filename);
S := Stream (File);
write_BMP_Header (to_Stream => S,
Width => GLint (Size.Width),
Height => GLint (Size.Height),
with_Alpha => True);
for r in 1 .. Index_t (Size.Height)
loop
for c in 1 .. Index_t (Size.Width)
loop
color_Value'write (S, the_Image (r, c).Blue);
color_Value'write (S, the_Image (r, c).Green);
color_Value'write (S, the_Image (r, c).Red);
color_Value'write (S, 255);
end loop;
end loop;
close (File);
exception
when others =>
if is_Open (File)
then
close (File);
end if;
raise;
end Save;
-------------
-- Screenshot
--
procedure Screenshot (Filename : in String;
with_Alpha : in Boolean := False)
is
use GL,
GL.Binding,
ada.Streams.Stream_IO;
File : ada.Streams.Stream_IO.File_type;
S : ada.Streams.Stream_IO.Stream_access;
Viewport : array (0 .. 3) of aliased GLint;
begin
Tasks.check;
glGetIntegerv (GL_VIEWPORT,
Viewport (0)'unchecked_Access);
Errors.log;
create (File, out_File, Filename);
S := Stream (File);
write_BMP_Header (to_Stream => S,
Width => Viewport (2),
Height => Viewport (3),
with_Alpha => with_Alpha);
write_raw_Frame (to_Stream => S,
Width => Integer (Viewport (2)),
Height => Integer (Viewport (3)),
with_Alpha => with_Alpha);
close (File);
exception
when others =>
if is_Open (File)
then
close (File);
end if;
raise;
end Screenshot;
----------------
-- Video Capture
--
-- We define global variables since it is not expected
-- that more that one capture is taken at the same time.
--
avi : ada.Streams.Stream_IO.File_type;
frames : Natural;
rate : Positive;
width, height : Positive;
bmp_size : U32;
procedure write_RIFF_Headers
is
-- Written 1st time to take place (but # of frames unknown)
-- Written 2nd time for setting # of frames, sizes, etc.
--
calc_bmp_size : constant U32 := U32 (((width)) * height * 3);
-- !! stuff to multiple of 4 !!
index_size : constant U32 := U32 (frames) * 16;
movie_size : constant U32 := 4 + U32 (frames) * (calc_bmp_size + 8);
second_list_size : constant U32 := 4 + 64 + 48;
first_list_size : constant U32 := (4 + 64) + (8 + second_list_size);
file_size : constant U32 := 8 + (8 + first_list_size) + (4 + movie_size) + (8 + index_size);
Stream : constant Stream_access := ada.Streams.Stream_IO.Stream (avi);
procedure write_Intel is new write_Intel_x86_Number (U16, Stream);
procedure write_Intel is new write_Intel_x86_Number (U32, Stream);
microseconds_per_frame : constant U32 := U32 (1_000_000.0 / long_Float (rate));
begin
bmp_size := calc_bmp_size;
String'write (Stream, "RIFF");
U32 'write (Stream, file_size);
String'write (Stream, "AVI ");
String'write (Stream, "LIST");
write_Intel (first_list_size);
String'write (Stream, "hdrl");
String'write (Stream, "avih");
write_Intel (U32' (56));
-- Begin of AVI Header
write_Intel (microseconds_per_frame);
write_Intel (U32'(0)); -- MaxBytesPerSec
write_Intel (U32'(0)); -- Reserved1
write_Intel (U32'(16)); -- Flags (16 = has an index)
write_Intel (U32 (frames));
write_Intel (U32'(0)); -- InitialFrames
write_Intel (U32'(1)); -- Streams
write_Intel (bmp_size);
write_Intel (U32 (width));
write_Intel (U32 (height));
write_Intel (U32'(0)); -- Scale
write_Intel (U32'(0)); -- Rate
write_Intel (U32'(0)); -- Start
write_Intel (U32'(0)); -- Length
-- End of AVI Header
String'write (Stream, "LIST");
write_Intel (second_list_size);
String'write (Stream, "strl");
-- Begin of Str
String'write (Stream, "strh");
write_Intel (U32'(56));
String'write (Stream, "vids");
String'write (Stream, "DIB ");
write_Intel (U32'(0)); -- flags
write_Intel (U32'(0)); -- priority
write_Intel (U32'(0)); -- initial frames
write_Intel (microseconds_per_frame); -- Scale
write_Intel (U32'(1_000_000)); -- Rate
write_Intel (U32'(0)); -- Start
write_Intel (U32 (frames)); -- Length
write_Intel (bmp_size); -- SuggestedBufferSize
write_Intel (U32'(0)); -- Quality
write_Intel (U32'(0)); -- SampleSize
write_Intel (U32'(0));
write_Intel (U16 (width));
write_Intel (U16 (height));
-- End of Str
String'write (Stream, "strf");
write_Intel (U32'(40));
-- Begin of BMI
write_Intel (U32'(40)); -- BM header size (like BMP)
write_Intel (U32 (width));
write_Intel (U32 (height));
write_Intel (U16'(1)); -- Planes
write_Intel (U16'(24)); -- BitCount
write_Intel (U32'(0)); -- Compression
write_Intel (bmp_size); -- SizeImage
write_Intel (U32'(3780)); -- XPelsPerMeter
write_Intel (U32'(3780)); -- YPelsPerMeter
write_Intel (U32'(0)); -- ClrUsed
write_Intel (U32'(0)); -- ClrImportant
-- End of BMI
String'write (Stream, "LIST");
write_Intel (movie_size);
String'write (Stream, "movi");
end Write_RIFF_headers;
procedure start_Capture (AVI_Name : String;
frame_Rate : Positive)
is
use GL,
GL.Binding;
Viewport : array (0 .. 3) of aliased GLint;
begin
Tasks.check;
create (Avi, out_File, AVI_Name);
Frames := 0;
Rate := frame_Rate;
glGetIntegerv (GL_VIEWPORT,
Viewport (0)'unchecked_Access);
Errors.log;
Width := Positive (Viewport (2));
Height := Positive (Viewport (3));
-- NB: GL viewport resizing should be blocked during the video capture !
write_RIFF_Headers;
end start_Capture;
procedure capture_Frame
is
S : constant Stream_Access := Stream (Avi);
procedure Write_Intel is new Write_Intel_x86_number (U32, s);
begin
String'write (S, "00db");
write_Intel (bmp_Size);
write_raw_Frame (S, Width, Height, with_Alpha => False);
Frames := Frames + 1;
end capture_Frame;
procedure stop_Capture
is
index_Size : constant U32 := U32 (Frames) * 16;
S : constant Stream_Access := Stream (Avi);
ChunkOffset : U32 := 4;
procedure write_Intel is new write_Intel_x86_Number (U32, S);
begin
-- Write the index section
--
String'write (S, "idx1");
write_Intel (index_Size);
for f in 1 .. Frames
loop
String'write (S, "00db");
write_Intel (U32'(16)); -- Keyframe.
write_Intel (ChunkOffset);
ChunkOffset := ChunkOffset + bmp_Size + 8;
write_Intel (bmp_Size);
end loop;
Set_Index (avi, 1); -- Go back to file beginning.
write_RIFF_Headers; -- Rewrite headers with correct data.
close (Avi);
end stop_Capture;
end openGL.IO;

171
3-mid/opengl/source/lean/io/opengl-io.ads Normal file
View File

@@ -0,0 +1,171 @@
with
openGL.Texture,
ada.Strings.unbounded,
ada.Streams.Stream_IO,
ada.unchecked_Deallocation;
package openGL.IO
--
-- Provides I/O functions for openGL.
--
is
subtype Text is ada.Strings.unbounded.unbounded_String;
------------------
-- General Vertex
--
null_Id : constant long_Index_t;
type Vertex is
record
site_Id,
coord_Id,
normal_Id,
weights_Id : long_Index_t;
end record;
type Vertices is array (long_Index_t range <>) of aliased Vertex;
type Vertices_view is access all Vertices;
--------
-- Face
--
type facet_Kind is (Triangle, Quad, Polygon);
type Face (Kind : facet_Kind := Triangle) is
record
case Kind
is
when Triangle => Tri : Vertices (1 .. 3);
when Quad => Quad : Vertices (1 .. 4);
when Polygon => Poly : Vertices_view;
end case;
end record;
type Faces is array (long_Index_t range <>) of Face;
procedure destroy (Self : in out Face);
function Vertices_of (Self : in Face) return Vertices;
procedure set_Vertex_in (Self : in out Face; Which : in long_Index_t;
To : in Vertex);
--------------------
-- Rigging/Skinning
--
type bone_Id is range 0 .. 200;
type bone_Weight is
record
Bone : bone_Id;
Weight : Real;
end record;
type bone_Weights is array (long_Index_t range <>) of bone_Weight;
type bone_Weights_view is access bone_Weights;
type bone_Weights_array is array (long_Index_t range <>) of bone_Weights_view;
---------
-- Views
--
type many_Sites_view is access all openGL.many_Sites;
type many_Coords_view is access all openGL.many_Coordinates_2D;
type many_Normals_view is access all openGL.many_Normals;
type bone_Weights_array_view is access all bone_Weights_array;
type Faces_view is access all IO.Faces;
procedure free is new ada.unchecked_Deallocation (many_Sites, IO.many_Sites_view);
procedure free is new ada.unchecked_Deallocation (many_Coordinates_2D, IO.many_Coords_view);
procedure free is new ada.unchecked_Deallocation (many_Normals, IO.many_Normals_view);
procedure free is new ada.unchecked_Deallocation (IO.Faces, IO.Faces_view);
-----------------
--- General Model
--
type Model is
record
Sites : many_Sites_view;
Coords : many_Coords_view;
Normals : many_Normals_view;
Weights : bone_Weights_array_view;
Faces : Faces_view;
end record;
procedure destroy (Self : in out Model);
--------------
-- Heightmaps
--
type height_Map_view is access all height_Map;
function to_height_Map (image_Filename : in asset_Name;
Scale : in Real := 1.0) return height_Map_view;
----------
-- Images
--
function fetch_Image (Stream : in ada.Streams.Stream_IO.Stream_access;
try_TGA : in Boolean) return openGL.Image;
pragma Obsolescent (fetch_Image, "use 'openGL.Images.fetch_Image' instead");
function to_Image (image_Filename : in asset_Name) return Image;
function to_lucid_Image (image_Filename : in asset_Name) return lucid_Image;
function to_lucid_Image (image_Filename : in asset_Name;
is_Lucid : access Boolean) return lucid_Image;
procedure save (image_Filename : in String;
the_Image : in Image);
------------
-- Textures
--
function to_Texture (image_Filename : in asset_Name) return Texture.Object;
---------------
-- Screenshots
--
function current_Frame return Image;
procedure Screenshot (Filename : in String; with_Alpha : in Boolean := False);
--
-- Stores the image of the current, active viewport (in RGB or RGBA Bitmap format).
-----------------
-- Video Capture
--
procedure start_capture (AVI_Name : in String;
frame_Rate : in Positive);
--
-- Prepare for video capture (RGB uncompressed, AVI format).
procedure capture_Frame;
--
-- Captures the current active viewport.
procedure stop_capture;
private
null_Id : constant long_Index_t := 0;
end openGL.IO;