opengl.model: Add a lit and textured circle model.

3-mid/opengl/source/demo/opengl-demo.adb

@@ -11,6 +11,7 @@ with
      openGL.Model.box      .lit_textured,
 
      openGL.Model.capsule  .lit_textured,
+     openGL.Model.circle   .lit_textured,
      openGL.Model.grid,
 
      openGL.Model.hexagon       .lit_colored,
@@ -188,6 +189,14 @@ is
         := Model.capsule.lit_textured.new_Capsule (Radius => 0.5,
                                                    Height => 2.0,
                                                    Image  => the_Texture);
+
+      the_lit_textured_circle_Model : constant Model.circle.lit_textured.view
+        := Model.circle.lit_textured.new_Circle (Radius => 1.5,
+                                                 Face   => (Fades         => (1 => 0.0,         others => <>),
+                                                            Textures      => (1 => the_Texture, others => <>),
+                                                            texture_Count => 1),
+                                                 Sides  => 24);
+
       the_grid_Model    : constant Model.grid.view
         := Model.grid.new_grid_Model (Color  => Red,
                                       Width  => 3,
@@ -297,6 +306,7 @@ is
                                the_box_3_Model.all'Access,
 
                              the_capsule_Model.all'Access,
+                 the_lit_textured_circle_Model.all'Access,
                                 the_grid_Model.all'Access,
 
                              the_hexagon_Model.all'Access,

3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb

@@ -0,0 +1,180 @@
+with
+     openGL.Geometry.lit_textured,
+     openGL.Primitive.indexed,
+     openGL.Texture.Coordinates;
+
+
+package body openGL.Model.circle.lit_textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_circle (Radius : in Real;
+                        Face   : in lit_textured.Face;
+                        Sides  : in Positive         := 24) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Face   := Face;
+      Self.Sides  := Sides;
+
+      return Self;
+   end new_circle;
+
+
+
+   ------------------
+   --- Attributes ---
+   ------------------
+
+
+   ------------
+   -- Texturing
+   --
+
+   overriding
+   procedure Fade_is (Self : in out Item;   Which : in texture_Set.texture_Id;
+                                            Now   : in texture_Set.fade_Level)
+   is
+   begin
+      Self.Face.Fades (which) := Now;
+   end Fade_is;
+
+
+
+   overriding
+   function Fade (Self : in Item;   Which : in texture_Set.texture_Id) return texture_Set.fade_Level
+   is
+   begin
+      return Self.Face.Fades (which);
+   end Fade;
+
+
+
+   procedure Texture_is (Self : in out Item;   Which : in texture_Set.texture_Id;
+                                               Now   : in openGL.asset_Name)
+   is
+   begin
+      Self.Face.Textures (Positive (which)) := Now;
+   end Texture_is;
+
+
+
+
+   overriding
+   function texture_Count (Self : in Item) return Natural
+   is
+   begin
+      return Self.Face.texture_Count;
+   end texture_Count;
+
+
+
+
+   ---------------------
+   --- openGL Geometries
+   --
+
+   overriding
+   function to_GL_Geometries (Self : access Item;   Textures : access Texture.name_Map_of_texture'Class;
+                                                    Fonts    : in     Font.font_id_Map_of_font) return Geometry.views
+   is
+      pragma unreferenced (Fonts);
+
+      use Geometry,
+          Geometry.lit_textured,
+          Texture;
+
+
+      function to_Indices return Indices
+      is
+         Result : Indices (1 .. long_Index_t (Self.Sides) + 2);
+      begin
+         for i in 1 .. Index_t (Self.Sides) + 1
+         loop
+            Result (long_Index_t (i)) := i; -- Index_t (Self.Sides) + 1 - i;
+         end loop;
+
+         Result (Result'Last) := 2;
+
+         return Result;
+      end to_Indices;
+
+
+      the_Indices : aliased constant Indices        := to_Indices;
+      the_Sites   :         constant Vector_2_array := vertex_Sites (Self.Radius,
+                                                                     Self.Sides);
+
+
+      function new_Face (Vertices : in geometry.lit_textured.Vertex_array) return Geometry.lit_textured.view
+      is
+         use Primitive,
+             texture_Set;
+
+         the_Geometry  : constant Geometry.lit_textured.view
+           := Geometry.lit_textured.new_Geometry;
+
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
+
+         Id : texture_Set.texture_Id;
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (Primitive.view (the_Primitive));
+
+         for i in 1 .. Self.Face.texture_Count
+         loop
+            Id := texture_Id (i);
+
+            the_Geometry.Fade_is (which => Id,
+                                  now   => Self.Face.Fades (Id));
+
+            the_Geometry.Texture_is     (which => Id,
+                                         now   => Textures.fetch (Self.Face.Textures (i)));
+            the_Geometry.is_Transparent (now   => the_Geometry.Texture.is_Transparent);
+         end loop;
+
+         the_Geometry.is_Transparent (True);     -- TODO: Do transparency properly.
+         the_Geometry.Model_is       (Self.all'unchecked_Access);
+
+         return the_Geometry;
+      end new_Face;
+
+
+      upper_Face : Geometry.lit_textured.view;
+
+   begin
+      --  Upper Face
+      --
+      declare
+         use Texture.Coordinates;
+
+         the_Coords   : constant Texture.Coordinates.Coords_2D_and_Centroid := to_Coordinates (the_Sites);
+         the_Vertices :          Geometry.lit_textured.Vertex_array (1 .. Index_t (Self.Sides + 1));
+      begin
+         -- Center.
+         --
+         the_Vertices (1) := (Site   => [0.0, 0.0, 0.0],
+                              Normal => Normal,
+                              Coords => (0.50, 0.50),
+                              Shine  => default_Shine);
+         -- Circumference
+         --
+         for i in 2 .. the_Vertices'Last
+         loop
+            the_Vertices (i) := (Site   => Vector_3 (the_Sites (Positive (i - 1)) & 0.0),
+                                 Normal => Normal,
+                                 Coords => the_Coords.Coords (i - 1),
+                                 Shine  => default_Shine);
+         end loop;
+
+         upper_Face := new_Face (Vertices => the_Vertices);
+      end;
+
+      return [1 => upper_Face.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.circle.lit_textured;

3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads

@@ -0,0 +1,66 @@
+with
+     openGL.texture_Set,
+     openGL.Texture;
+
+
+package openGL.Model.circle.lit_textured
+--
+--  Models a lit, colored and textured hexagon.
+--
+is
+   type Item is new Model.item with private;
+   type View is access all Item'Class;
+
+
+   type Face is
+      record
+         Fades         : texture_Set.fade_Levels           (texture_Set.texture_Id)       := [others => 0.0];
+         Textures      : openGL.asset_Names (1 .. Positive (texture_Set.texture_Id'Last)) := [others => null_Asset];     -- The textures to be applied to the hex.
+         texture_Count : Natural := 0;
+      end record;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_circle (Radius : in Real;
+                        Face   : in lit_textured.Face;
+                        Sides  : in Positive         := 24) return View;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function to_GL_Geometries (Self : access Item;   Textures : access Texture.name_Map_of_texture'Class;
+                                                    Fonts    : in     Font.font_id_Map_of_font) return Geometry.views;
+
+   ------------
+   -- Texturing
+   --
+
+   overriding
+   function  Fade       (Self : in     Item;   Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
+
+   overriding
+   procedure Fade_is    (Self : in out Item;   Which : in texture_Set.texture_Id;
+                                               Now   : in texture_Set.fade_Level);
+
+   procedure Texture_is (Self : in out Item;   Which : in texture_Set.texture_Id;
+                                               Now   : in asset_Name);
+
+   overriding
+   function  texture_Count (Self : in Item) return Natural;
+
+
+
+private
+
+   type Item is new Model.circle.item with
+      record
+         Face  : lit_textured.Face;
+      end record;
+
+end openGL.Model.circle.lit_textured;

3-mid/opengl/source/lean/model/opengl-model-circle.adb

@@ -0,0 +1,24 @@
+package body openGL.Model.circle
+is
+
+   function vertex_Sites (Radius : in Real;
+                          Sides  : in Positive := 24) return Vector_2_array
+   is
+      use linear_Algebra_2d;
+
+      the_Site :          Vector_2                   := [Radius, 0.0];
+      Rotation : constant Matrix_2x2                 := to_rotation_Matrix (to_Radians (360.0 / Degrees (Sides)));
+      Result   :          Vector_2_array (1 .. Sides);
+
+   begin
+      for i in Result'Range
+      loop
+         Result (i) := the_Site;
+         the_Site   := the_Site * Rotation;
+      end loop;
+
+      return Result;
+   end vertex_Sites;
+
+
+end openGL.Model.circle;

3-mid/opengl/source/lean/model/opengl-model-circle.ads

@@ -0,0 +1,25 @@
+package openGL.Model.circle
+--
+--  Provides an abstract model of a circle.
+--
+is
+   type Item is abstract new Model.item with private;
+
+
+   -- Sites begin at 'middle right' and proceed in an anti-clockwise direction.
+   --
+   function vertex_Sites (Radius : in Real;
+                          Sides  : in Positive := 24) return Vector_2_array;
+
+
+private
+
+   type Item is abstract new Model.item with
+      record
+         Radius : Real := 1.0;
+         Sides  : Positive range 3 .. 360;
+      end record;
+
+   Normal : constant Vector_3 := [0.0, 0.0, 1.0];
+
+end openGL.Model.circle;

3-mid/opengl/source/lean/opengl-texture-coordinates.adb

@@ -53,6 +53,7 @@ is
 
 
 
+
    overriding
    function to_Coordinates (Self : in xz_Generator;   the_Vertices : access Sites) return Coordinates_2D
    is
@@ -88,6 +89,7 @@ is
 
 
 
+
    overriding
    function to_Coordinates (Self : in xy_Generator;   the_Vertices : access Sites) return Coordinates_2D
    is
@@ -123,6 +125,7 @@ is
 
 
 
+
    overriding
    function to_Coordinates (Self : in zy_Generator;   the_Vertices : access Sites) return Coordinates_2D
    is

3-mid/opengl/source/lean/opengl-texture-coordinates.ads

@@ -3,9 +3,8 @@ package openGL.Texture.Coordinates
 -- Provides openGL texture co-ordinates.
 --
 is
-
+   ---------------
-   ------
+   --- 2D Textures
-   --- 2D
    --
 
    type Coords_2D_and_Centroid (coords_Count : Index_t) is
@@ -21,7 +20,7 @@ is
 
 
 
-   --- Generator
+   --- Generators
    --
 
    type coordinate_Generator is abstract tagged null record;
@@ -66,7 +65,4 @@ is
    function to_Coordinates (Self : in mercator_Generator;   the_Vertices : access Sites) return Coordinates_2D;
 
 
-
-
-
 end openGL.Texture.Coordinates;

3-mid/opengl/source/lean/opengl-texture.adb

@@ -9,6 +9,9 @@ with
 
      ada.unchecked_Deallocation;
 
+with ada.Text_IO;
+
+
 package body openGL.Texture
 is
    use GL,
@@ -84,7 +87,7 @@ is
 
 
       function to_Texture (the_Image   : in Image;
-                           use_Mipmaps : in Boolean     := True) return Object
+                           use_Mipmaps : in Boolean := True) return Object
       is
          Self : aliased Texture.Object;
       begin
@@ -96,7 +99,7 @@ is
 
 
       function to_Texture (the_Image   : in lucid_Image;
-                           use_Mipmaps : in Boolean           := True) return Object
+                           use_Mipmaps : in Boolean    := True) return Object
       is
          Self : aliased Texture.Object;
       begin
@@ -153,7 +156,9 @@ is
    procedure set_Image (Self : in out Object;   To          : in Image;
                                                 use_Mipmaps : in Boolean := True)
    is
-      use GL.Binding;
+      use GL.Binding,
+          ada.Text_IO;
+
       the_Image  :          Image renames To;
       min_Width  : constant Positive := the_Image'Length (2);
       min_Height : constant Positive := the_Image'Length (1);
@@ -163,17 +168,23 @@ is
       Self.is_Transparent    := False;
       Self.Dimensions.Width  := min_Width;
       Self.Dimensions.Height := min_Height;
+
+      new_Line (3);
+      put_Line ("openGL.Texture.set_Image ~ GLsizei (Self.Dimensions.Width)  =>" & GLsizei (Self.Dimensions.Width) 'Image);
+      put_Line ("                         ~ GLsizei (Self.Dimensions.Height) =>" & GLsizei (Self.Dimensions.Height)'Image);
+      put_Line ("                         ~ the_Image                        =>");
+      put_Line (the_Image'Image);
+      new_Line (3);
+
       Self.enable;
 
-      glPixelStorei   (GL_UNPACK_ALIGNMENT, 1);
+      glPixelStorei   (GL_UNPACK_ALIGNMENT, 1);                                 Errors.log;
 
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);     Errors.log;
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);     Errors.log;
 
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);        Errors.log;
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);        Errors.log;
-
-      Errors.log;
 
       glTexImage2D (GL_TEXTURE_2D,
                     0,
@@ -212,15 +223,13 @@ is
       Self.Dimensions.Height := min_Height;
       Self.enable;
 
-      glPixelStorei   (GL_UNPACK_ALIGNMENT, 1);
+      glPixelStorei   (GL_UNPACK_ALIGNMENT, 1);                                 Errors.log;
 
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);     Errors.log;
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);     Errors.log;
 
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);        Errors.log;
-      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
+      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);        Errors.log;
-
-      Errors.log;
 
       glTexImage2D (GL_TEXTURE_2D,
                     0,
@@ -258,6 +267,7 @@ is
    begin
       Tasks.check;
       glBindTexture (GL.GL_TEXTURE_2D, Self.Name);
+      Errors.log;
    end enable;