with openGL.Primitive.indexed, openGL.Primitive.long_indexed, openGL.Variable.uniform, openGL.Tasks, GL.Binding, GL.lean, GL.Pointers, ada.Strings.fixed, ada.unchecked_Deallocation, ada.unchecked_Conversion, interfaces.C.Strings; package body openGL.Geometry is --------- -- Forge -- procedure destroy (Self : in out Item) is use openGL.Buffer; begin free (Self.Vertices); Self.free_Primitives; end destroy; procedure free (Self : in out View) is procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View); begin if Self = null then return; end if; Self.destroy; deallocate (Self); end free; procedure free_Primitives (Self : in out Item) is begin for Each in 1 .. Self.primitive_Count loop Primitive.free (Self.Primitives (Each)); end loop; Self.primitive_Count := 0; end free_Primitives; -------------- -- Attributes -- function Label (Self : in Item'Class) return String is begin return to_String (Self.Label); end Label; procedure Label_is (Self : in out Item'Class; Now : in String) is begin overwrite (Self.Label, 1, Now); end Label_is; procedure Indices_are (Self : in out Item; Now : in Indices; for_Facia : in Positive) is the_Primitive : constant Primitive.indexed.view := Primitive.indexed.view (Self.Primitives (Index_t (for_Facia))); begin the_Primitive.Indices_are (Now); end Indices_are; procedure Indices_are (Self : in out Item; Now : in long_Indices; for_Facia : in Positive) is the_Primitive : constant Primitive.long_indexed.view := Primitive.long_indexed.view (Self.Primitives (Index_t (for_Facia))); begin the_Primitive.Indices_are (Now); end Indices_are; function Primitives (Self : in Item'Class) return Primitive.views is begin return Self.Primitives (1 .. Self.primitive_Count); end Primitives; -- procedure Texture_is (Self : in out Item'Class; Which : texture_ID; Now : in openGL.Texture.Object) -- is -- begin -- Self.Textures.Textures (Which) := (0.0, Now); -- Self.is_Transparent := Self.is_Transparent -- or Now .is_Transparent; -- -- if Natural (Which) > Self.Textures.Count -- then -- Self.Textures.Count := Natural (Which); -- end if; -- end Texture_is; -- -- -- function Texture (Self : in Item'Class; Which : texture_ID) return openGL.Texture.Object -- is -- begin -- return Self.Textures.Textures (Which).Object; -- end Texture; function Texture (Self : in Item) return openGL.Texture.Object is begin raise program_Error with "Geometry has no texture."; return openGL.Texture.null_Object; end Texture; -- procedure Texture_is (Self : in out Item'Class; Now : in openGL.Texture.Object) -- is -- begin -- Self.Textures.Textures (1).Object := Now; -- Self.is_Transparent := Self.is_Transparent -- or Now .is_Transparent; -- -- if Self.Textures.Count = 0 -- then -- Self.Textures.Count := 1; -- end if; -- end Texture_is; -- procedure Texture_is (in_Set : in out texture_Set; Which : texture_ID; Now : in openGL.Texture.Object) is begin in_Set.Textures (Which) := (0.0, Now); in_Set.is_Transparent := in_Set.is_Transparent or Now .is_Transparent; if Natural (Which) > in_Set.Count then in_Set.Count := Natural (Which); end if; end Texture_is; function Texture (in_Set : in texture_Set; Which : texture_ID) return openGL.Texture.Object is begin return in_Set.Textures (Which).Object; end Texture; function Texture (in_Set : in texture_Set) return openGL.Texture.Object is begin return in_Set.Textures (1).Object; end Texture; procedure Texture_is (in_Set : in out texture_Set; Now : in openGL.Texture.Object) is begin in_Set.Textures (1).Object := Now; in_Set.is_Transparent := in_Set.is_Transparent or Now .is_Transparent; if in_Set.Count = 0 then in_Set.Count := 1; end if; end Texture_is; procedure Program_is (Self : in out Item; Now : in openGL.Program.view) is begin Self.Program := Now; end Program_is; function Program (Self : in Item) return openGL.Program.view is begin return Self.Program; end Program; function Bounds (self : in Item'Class) return openGL.Bounds is begin return Self.Bounds; end Bounds; procedure Bounds_are (Self : in out Item'Class; Now : in openGL.Bounds) is begin Self.Bounds := Now; end Bounds_are; function is_Transparent (Self : in Item) return Boolean is begin return Self.is_Transparent; -- or Self.Textures.Textures (1).Object.is_Transparent -- or Self.Textures.Textures (2).Object.is_Transparent; -- TODO: Loop over all textures. -- -- return Self.is_Transparent -- -- or Self.Texture_1.is_Transparent -- -- or Self.Texture_2.is_Transparent; end is_Transparent; procedure is_Transparent (Self : in out Item; Now : in Boolean := True) is begin Self.is_Transparent := Now; end is_Transparent; -------------- -- Operations -- procedure add (Self : in out Item'Class; the_Primitive : in Primitive.view) is begin Self.primitive_Count := Self.primitive_Count + 1; Self.Primitives (self.primitive_Count) := the_Primitive; end add; procedure render (Self : in out Item'Class) is begin if Self.primitive_Count = 0 then raise Error with "Unable to render geometry with no primitives."; end if; Self .enable_Texture; Self.Program .set_Uniforms; Self.Vertices.enable; Self.Program .enable_Attributes; for Each in 1 .. self.primitive_Count -- Render each primitive. loop Self.Primitives (Each).render; end loop; end render; ----------- -- Normals -- generic type any_Index_t is range <>; type any_Indices is array (long_Index_t range <>) of any_Index_t; function any_vertex_Id_in (face_Kind : in primitive.facet_Kind; Indices : in any_Indices; for_Facet : in long_Index_t; for_Point : in long_Index_t) return any_Index_t; function any_vertex_Id_in (face_Kind : in Primitive.facet_Kind; Indices : in any_Indices; for_Facet : in long_Index_t; for_Point : in long_Index_t) return any_Index_t is use openGL.Primitive; begin case face_Kind is when Triangles => return Indices (3 * (for_Facet - 1) + for_Point); when triangle_Strip => return Indices (for_Facet - 1 + for_Point); when triangle_Fan => if for_Point = 1 then return 1; else return Indices (for_Facet - 1 + for_Point); end if; when others => raise Error with "openGL primitive " & face_Kind'Image & " not yet supported."; end case; end any_vertex_Id_in; generic type any_Index_t is range <>; type any_Indices is array (long_Index_t range <>) of any_Index_t; function any_facet_Count_in (face_Kind : in primitive.facet_Kind; Indices : in any_Indices) return long_Index_t; -- -- Returns the maximum possible facet count, which includes redundant facets. function any_facet_Count_in (face_Kind : in primitive.facet_Kind; Indices : in any_Indices) return long_Index_t is use Primitive; begin case face_Kind is when Triangles => return Indices'Length / 3; when triangle_Strip | triangle_Fan => return Indices'Length - 2; when others => raise Error with "openGL primitive " & face_Kind'Image & " not yet supported."; end case; end any_facet_Count_in; function facet_Count_in is new any_facet_Count_in (any_Index_t => Index_t, any_Indices => Indices); pragma Unreferenced (facet_Count_in); ---------- -- Facets -- type Facet is array ( Index_t range 1 .. 3) of Index_t; -- An 'indexed' triangle. type Facets is array (long_Index_t range <> ) of Facet; type Facets_view is access all Facets; procedure free is new ada.unchecked_Deallocation (Facets, Facets_view); generic type any_Index_t is range <>; type any_Indices is array (long_Index_t range <>) of any_Index_t; function any_Facets_of (face_Kind : in primitive.facet_Kind; Indices : in any_Indices) return access Facets; -- -- 'Facets_of' returns all non-redundant facets. function any_Facets_of (face_Kind : in primitive.facet_Kind; Indices : in any_Indices) return access Facets is use openGL.Primitive; function facet_Count_in is new any_facet_Count_in (any_Index_t => any_Index_t, any_Indices => any_Indices); function vertex_Id_in is new any_vertex_Id_in (any_Index_t => any_Index_t, any_Indices => any_Indices); the_Facets : Facets_view := new Facets (1 .. facet_Count_in (face_Kind, Indices)); Count : long_Index_t := 0; begin for Each in the_Facets'Range loop declare P1 : constant Index_t := Index_t (vertex_Id_in (face_Kind, Indices, Each, 1)); P2 : constant Index_t := Index_t (vertex_Id_in (face_Kind, Indices, Each, 2)); P3 : constant Index_t := Index_t (vertex_Id_in (face_Kind, Indices, Each, 3)); begin if not ( P1 = P2 or P1 = P3 or P2 = P3) then Count := Count + 1; case face_Kind is when Triangles | triangle_Fan => the_Facets (Count) := [P1, P2, P3]; when triangle_Strip => if Each mod 2 = 0 then -- Is an even facet. the_Facets (Count) := [P1, P3, P2]; else the_Facets (Count) := [P1, P2, P3]; end if; when others => raise Error with "openGL primitive " & face_Kind'Image & " not yet supported."; end case; end if; end; end loop; declare Result : constant Facets_view := new Facets' (the_Facets (1 .. Count)); begin free (the_Facets); return Result; end; end any_Facets_of; function Facets_of is new any_Facets_of (Index_t, Indices); pragma Unreferenced (Facets_of); ----------- -- Normals -- type Normals_view is access Normals; generic type any_Index_t is range <>; type any_Indices is array (long_Index_t range <>) of any_Index_t; function any_Normals_of (face_Kind : in primitive.facet_Kind; Indices : in any_Indices; Sites : in openGL.Sites) return access Normals; function any_Normals_of (face_Kind : in primitive.facet_Kind; Indices : in any_Indices; Sites : in openGL.Sites) return access Normals is function Facets_of is new any_Facets_of (any_Index_t, any_Indices); the_Normals : constant Normals_view := new Normals (Sites'Range); the_Facets : Facets_view := Facets_of (face_Kind, Indices).all'unchecked_Access; type facet_Normals is array (long_Index_t range 1 .. the_Facets'Length) of Normal; type facet_Normals_view is access all facet_Normals; procedure free is new ada.unchecked_Deallocation (facet_Normals, facet_Normals_view); -- TODO: Should not be needed since freeing will occur when 'facet_Normals_view' goes out of scope ? the_facet_Normals : facet_Normals_view := new facet_Normals; N : Vector_3; length_N : Real; begin -- Calculate normal at each facet. -- for Each in the_Facets'Range loop N := (Sites (the_Facets (Each)(2)) - Sites (the_Facets (Each)(1))) * (Sites (the_Facets (Each)(3)) - Sites (the_Facets (Each)(1))); length_N := abs (N); if almost_Zero (length_N) then the_facet_Normals (Each) := N; -- 0 vector ! else the_facet_Normals (Each) := (1.0 / length_N) * N; end if; end loop; -- Calculate normal at each vertex. -- declare Id : Index_t; Length : Real; begin for Each in the_Normals'Range loop the_Normals (Each) := Origin_3D; end loop; for f in the_Facets'Range loop for p in Index_t' (1) .. 3 loop Id := the_Facets (f) (p); the_Normals (Id) := the_Normals (Id) + the_facet_Normals (f); end loop; end loop; for p in the_Normals'Range loop Length := abs (the_Normals (p)); if almost_Zero (Length) then the_Normals (p) := [0.0, -1.0, 0.0]; else the_Normals (p) := (1.0 / Length) * the_Normals (p); end if; end loop; end; free (the_Facets); free (the_facet_Normals); return the_Normals.all'Unchecked_Access; end any_Normals_of; function Normals_of (face_Kind : in primitive.facet_Kind; Indices : in openGL.Indices; Sites : in openGL.Sites) return access Normals is function my_Normals_of is new any_Normals_of (any_Index_t => Index_t, any_Indices => openGL.Indices); begin return my_Normals_of (face_Kind, Indices, Sites).all'unchecked_Access; end Normals_of; function Normals_of (face_Kind : in primitive.facet_Kind; Indices : in openGL.long_Indices; Sites : in openGL.Sites) return access Normals is function my_Normals_of is new any_Normals_of (any_Index_t => long_Index_t, any_Indices => openGL.long_Indices); begin return my_Normals_of (face_Kind, Indices, Sites).all'unchecked_Access; end Normals_of; ----------- -- Textures -- procedure enable (the_Textures : in texture_Set; Program : in openGL.Program.view) is use GL, GL.Binding, openGL.Texture; -- check_is_OK : constant Boolean := openGL.Tasks.Check -- with unreferenced; begin Tasks.check; for i in 1 .. the_Textures.Count loop declare use GL.lean, GL.Pointers, ada.Strings, ada.Strings.fixed, Interfaces; use type GL.GLint; type texture_Units is array (texture_Id) of GLenum; all_texture_Units : constant texture_Units := (GL_TEXTURE0, GL_TEXTURE1, GL_TEXTURE2, GL_TEXTURE3, GL_TEXTURE4, GL_TEXTURE5, GL_TEXTURE6, GL_TEXTURE7, GL_TEXTURE8, GL_TEXTURE9, GL_TEXTURE10, GL_TEXTURE11, GL_TEXTURE12, GL_TEXTURE13, GL_TEXTURE14, GL_TEXTURE15, GL_TEXTURE16, GL_TEXTURE17, GL_TEXTURE18, GL_TEXTURE19, GL_TEXTURE20, GL_TEXTURE21, GL_TEXTURE22, GL_TEXTURE23, GL_TEXTURE24, GL_TEXTURE25, GL_TEXTURE26, GL_TEXTURE27, GL_TEXTURE28, GL_TEXTURE29, GL_TEXTURE30, GL_TEXTURE31); uniform_Name : aliased C.char_array := C.to_C ("Textures[" & Trim (Natural'Image (i - 1), Left) & "]"); uniform_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (uniform_Name'unchecked_Access); loc : constant GL.GLint := glGetUniformLocation (Program.gl_Program, +uniform_Name_ptr); Id : constant texture_Id := texture_Id (i); begin -- put_Line ("1-openGL.Program.lit.set_Uniforms:" & loc'Image); glUniform1i (loc, GLint (i) - 1); glActiveTexture (all_texture_Units (Id)); glBindTexture (GL_TEXTURE_2D, the_Textures.Textures (Id).Object.Name); end; declare use ada.Strings, ada.Strings.fixed; uniform_Name : constant String := "Fade[" & Trim (Natural'Image (i - 1), Left) & "]"; Uniform : constant openGL.Variable.uniform.float := Program.uniform_Variable (uniform_Name); begin Uniform.Value_is (Real (the_Textures.Textures (texture_Id (i)).Fade)); end; end loop; declare the_texture_count_Uniform : constant openGL.Variable.uniform.int := Program.uniform_Variable ("texture_Count"); begin the_texture_count_Uniform.Value_is (the_Textures.Count); end; end enable; --------- -- Bounds -- function get_Bounds (Count : in Natural) return openGL.Bounds is use Geometry_3D; the_Bounds : openGL.Bounds := null_Bounds; begin for i in 1 .. any_Index_t (Count) loop the_Bounds.Box := the_Bounds.Box or get_Site (i); the_Bounds.Ball := Real'Max (the_Bounds.Ball, abs (get_Site (i))); end loop; return the_Bounds; end get_Bounds; --------------- -- Transparency -- function get_Transparency (Count : in Natural) return Boolean is use type color_Value; begin for i in 1 .. any_Index_t (Count) loop if get_Color (i).Alpha /= opaque_Value then return True; end if; end loop; return False; end get_Transparency; end openGL.Geometry;