Add initial prototype.

3-mid/opengl/source/lean/buffer/opengl-buffer-general.adb

@@ -0,0 +1,107 @@
+with
+     openGL.Errors,
+     openGL.Tasks,
+
+     GL.Pointers;
+
+package body openGL.Buffer.general
+is
+   --------------------------
+   --  'vertex buffer' Object
+   --
+
+   package body Forge
+   is
+      function to_Buffer (From  : access constant Element_Array;
+                          Usage : in              Buffer.Usage) return  Object
+      is
+         use GL.Pointers;
+      begin
+         Tasks.check;
+
+         return new_Buffer : Object
+         do
+            new_Buffer.Usage  := Usage;
+            new_Buffer.Length := From'Length;
+            new_Buffer.verify_Name;
+            new_Buffer.enable;
+
+            glBufferData (to_GL_Enum (new_Buffer.Kind),
+                          From.all'Size / 8,
+                         +From (From'First)'Address,
+                          to_GL_Enum (Usage));
+            Errors.log;
+         end return;
+      end to_Buffer;
+
+
+      function to_Buffer (From  : in Element_Array;
+                          Usage : in Buffer.Usage) return  Object
+      is
+         use GL.Pointers;
+      begin
+         Tasks.check;
+
+         return new_Buffer : Object
+         do
+            new_Buffer.Usage  := Usage;
+            new_Buffer.Length := From'Length;
+            new_Buffer.verify_Name;
+            new_Buffer.enable;
+
+            glBufferData (to_GL_Enum (new_Buffer.Kind),
+                          From'Size / 8,
+                         +From (From'First)'Address,
+                          to_GL_Enum (Usage));
+         end return;
+      end to_Buffer;
+
+   end Forge;
+
+
+
+   procedure set (Self : in out Object;   Position : in Positive := 1;
+                                          To       : in Element_Array)
+   is
+      use GL.Pointers;
+
+      new_Vertices        : aliased  Element_Array := To;
+      Vertex_Size_in_bits : constant Natural       := To (To'First)'Size;
+
+   begin
+      Tasks.check;
+
+      if Self.Length = To'Length
+      then
+         Self.enable;
+         glBufferSubData (Target =>  to_GL_Enum (Self.Kind),
+                          Offset =>  GLintptr ((Position - 1) * Vertex_Size_in_bits / 8),
+                          Size   =>  new_Vertices'Size / 8,
+                          Data   => +new_Vertices (new_Vertices'First)'Address);
+      else
+         Self.destroy;
+
+         Self.verify_Name;
+         Self.Length := To'Length;
+         Self.enable;
+
+         glBufferData (to_GL_Enum (Self.Kind),
+                       To'Size / 8,
+                      +To (To'First)'Address,
+                       to_GL_Enum (Self.Usage));
+      end if;
+
+      Errors.log;
+   end set;
+
+
+
+   procedure set (Self : in out Object;   Position : in              Positive := 1;
+                                          To       : access constant Element_Array)
+   is
+   begin
+      Self.set (Position, To.all);
+   end set;
+
+
+end openGL.Buffer.general;

3-mid/opengl/source/lean/buffer/opengl-buffer-general.ads

@@ -0,0 +1,53 @@
+generic
+   type base_Object   is new openGL.Buffer.Object with private;
+
+   type Index         is range <>;
+   type Element       is private;
+   type Element_Array is array (Index range <>) of Element;
+
+package openGL.Buffer.general
+--
+--  A generic for producing various types of openGL vertex buffer objects.
+--
+is
+   type Object is new base_Object with private;
+   type View   is access all Object'Class;
+
+
+   ---------
+   --  Forge
+   --
+
+   package Forge
+   is
+      function to_Buffer (From  : access constant Element_Array;
+                          Usage : in              Buffer.Usage) return Object;
+
+      function to_Buffer (From  : in              Element_Array;
+                          Usage : in              Buffer.Usage) return  Object;
+   end Forge;
+
+
+   --------------
+   --  Operations
+   --
+
+   procedure set (Self : in out Object;   Position : in              Positive     := 1;
+                                          To       : in              Element_Array);
+
+   procedure set (Self : in out Object;   Position : in              Positive     := 1;
+                                          To       : access constant Element_Array);
+
+
+
+private
+
+   type Object is new base_Object with
+      record
+         Usage : Buffer.Usage;
+      end record;
+
+   default_Terminator : Element;       -- No 'Interfaces.C.Pointers' subprogram is called which uses the default terminator, so
+                                       -- a default 'Element' should suffice.
+
+end openGL.Buffer.general;

3-mid/opengl/source/lean/buffer/opengl-buffer-indices.ads

@@ -0,0 +1,7 @@
+with
+     openGL.Buffer.general;
+
+package openGL.Buffer.indices is new openGL.Buffer.general (base_Object   => Buffer.element_array_Object,
+                                                            Index         => long_Index_t,
+                                                            Element       => Index_t,
+                                                            Element_Array => Indices);

3-mid/opengl/source/lean/buffer/opengl-buffer-long_indices.ads

@@ -0,0 +1,7 @@
+with
+     openGL.Buffer.general;
+
+package openGL.Buffer.long_indices is new openGL.Buffer.general (base_Object   => Buffer.element_array_Object,
+                                                                 Index         => long_Index_t,
+                                                                 Element       => long_Index_t,
+                                                                 Element_Array => long_Indices);

3-mid/opengl/source/lean/buffer/opengl-buffer-normals.ads

@@ -0,0 +1,7 @@
+with
+     openGL.Buffer.general;
+
+package openGL.Buffer.normals is new openGL.Buffer.general (base_Object   => Buffer.array_Object,
+                                                            Index         => Index_t,
+                                                            Element       => Normal,
+                                                            Element_Array => Normals);

3-mid/opengl/source/lean/buffer/opengl-buffer-short_indices.ads

@@ -0,0 +1,7 @@
+with
+     openGL.Buffer.general;
+
+package openGL.Buffer.short_indices is new openGL.Buffer.general (base_Object   => Buffer.element_array_Object,
+                                                                  Index         => long_Index_t,
+                                                                  Element       => short_Index_t,
+                                                                  Element_Array => short_Indices);

3-mid/opengl/source/lean/buffer/opengl-buffer-texture_coords.ads

@@ -0,0 +1,7 @@
+with
+     openGL.Buffer.general;
+
+package openGL.Buffer.texture_coords is new openGL.Buffer.general (base_Object   => Buffer.array_Object,
+                                                                   Index         => Index_t,
+                                                                   Element       => Coordinate_2D,
+                                                                   Element_Array => Coordinates_2D);

3-mid/opengl/source/lean/buffer/opengl-buffer-vertex.ads

@@ -0,0 +1,7 @@
+with
+     openGL.Buffer.general;
+
+package openGL.Buffer.vertex is new openGL.Buffer.general (base_Object   => Buffer.array_Object,
+                                                           Index         => Index_t,
+                                                           Element       => Site,
+                                                           Element_Array => Sites);

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

@@ -0,0 +1,134 @@
+with
+     openGL.Errors,
+     openGL.Tasks,
+     ada.unchecked_Deallocation;
+
+package body openGL.Buffer
+is
+   use type a_Name;
+
+
+   ---------------
+   --  Buffer Name
+   --
+
+   function new_vbo_Name return a_Name
+   is
+      Name : aliased a_Name;
+   begin
+      Tasks.check;
+      glGenBuffers (1, Name'unchecked_Access);
+      return Name;
+   end new_vbo_Name;
+
+
+
+   procedure free (vbo_Name : in a_Name)
+   is
+      Name : aliased a_Name := vbo_Name;
+   begin
+      Tasks.check;
+      glDeleteBuffers (1, Name'unchecked_Access);
+   end free;
+   pragma Unreferenced (free);
+
+
+   ----------
+   --  Object
+   --
+
+   procedure verify_Name (Self : in out Object'Class)
+   is
+   begin
+      if Self.Name = 0 then
+         Self.Name := new_vbo_Name;
+      end if;
+   end verify_Name;
+
+
+
+   function Name (Self : in Object) return Buffer.a_Name
+   is
+   begin
+      return Self.Name;
+   end Name;
+
+
+
+   procedure enable (Self : in Object'Class)
+   is
+      pragma assert (Self.Name > 0);
+   begin
+      Tasks.check;
+      glBindBuffer (to_GL_Enum (Self.Kind),
+                    Self.Name);
+      openGL.Errors.log;
+   end enable;
+
+
+
+   procedure destroy (Self : in out Object'Class)
+   is
+   begin
+      Tasks.check;
+
+      glBindBuffer (to_GL_Enum (Self.Kind), 0);
+      openGL.Errors.log;
+
+      glDeleteBuffers (1,  Self.Name'Access);
+      openGL.Errors.log;
+
+      Self.Name := 0;
+   end destroy;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Buffer.Object'Class,
+                                                              Buffer.view);
+   begin
+      if Self /= null
+      then
+         Self.destroy;
+         deallocate (Self);
+      end if;
+   end free;
+
+
+
+   function Length (Self : in Object) return Positive
+   is
+   begin
+      return Self.Length;
+   end Length;
+
+
+   -------------------------
+   --  'array' Buffer Object
+   --
+
+   overriding
+   function Kind (Self : in array_Object) return Buffer.a_Kind
+   is
+      pragma Unreferenced (Self);
+   begin
+      return array_Buffer;
+   end Kind;
+
+
+
+   ---------------------------------
+   --  'element array' Buffer object
+   --
+
+   overriding
+   function Kind (Self : in element_array_Object) return Buffer.a_Kind
+   is
+      pragma Unreferenced (Self);
+   begin
+      return element_array_Buffer;
+   end Kind;
+
+
+end openGL.Buffer;

3-mid/opengl/source/lean/buffer/opengl-buffer.ads

@@ -0,0 +1,124 @@
+private
+with
+     GL.lean,
+     ada.unchecked_Conversion;
+
+package openGL.Buffer
+--
+--  Models a buffer object.
+--
+is
+   --------------
+   --- Core Types
+   --
+   subtype a_Name is GL.GLuint;                                    -- An openGL vertex buffer 'Name', which is a natural integer.
+   type    a_Kind is (array_Buffer, element_array_Buffer);
+   type     Usage is (stream_Draw, static_Draw, dynamic_Draw);
+
+
+   -----------------
+   --  Buffer Object
+   --
+   type Object is abstract tagged limited private;
+   type View   is access all Object'Class;
+
+   procedure destroy (Self : in out Object'Class);
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --  Attributes
+   --
+
+   function Name   (Self : in Object) return Buffer.a_Name;
+   function Kind   (Self : in Object) return Buffer.a_Kind is abstract;
+   function Length (Self : in Object) return Positive;
+
+
+   --------------
+   --  Operations
+   --
+
+   procedure enable (Self : in Object'Class);
+
+
+   -----------------------------------------------
+   --  Derived 'array' and 'element array' Classes
+   --
+
+   type         array_Object is new Object with private;
+   type element_array_Object is new Object with private;
+
+   --
+   --  Refer to child packages, for specific buffers:
+   --
+   --  - gl.Buffer.vertex
+   --  - gl.Buffer.texture_coords
+   --  - gl.Buffer.normals
+   --  - gl.Buffer.indices
+   --
+   --  (TODO: pixel pack/unpack buffers)
+
+
+   ----------
+   --  Errors
+   --
+
+   no_platform_Support : exception;
+   --
+   --  Raised by buffer 'Map' functions when OS platform does not
+   --  support GL Buffer objects.
+
+
+
+private
+   use GL.lean;
+
+
+   --  Buffer Kinds
+   --
+
+   for a_Kind use (array_Buffer         => GL_ARRAY_BUFFER,
+                   element_array_Buffer => GL_ELEMENT_ARRAY_BUFFER);
+
+   for a_Kind'Size use gl.GLenum'Size;
+
+   function to_GL_Enum is new ada.unchecked_Conversion (a_Kind, gl.GLenum);
+
+
+   --  Usage
+   --
+   for Usage use (stream_Draw  => GL_STREAM_DRAW,
+                  static_Draw  => GL_STATIC_DRAW,
+                  dynamic_Draw => GL_DYNAMIC_DRAW);
+
+   for Usage'Size use GL.GLenum'Size;
+
+   function to_GL_Enum is new ada.unchecked_Conversion (Usage, gl.GLenum);
+
+
+   ----------
+   --  Object
+   --
+
+   type Object is abstract tagged limited
+      record
+         Name   : aliased Buffer.a_Name := 0;
+         Length :         Positive;
+      end record;
+
+   overriding
+   function Kind (Self : in         array_Object) return Buffer.a_Kind;
+
+   overriding
+   function Kind (Self : in element_array_Object) return Buffer.a_Kind;
+
+   type         array_Object is new Object with null record;
+   type element_array_Object is new Object with null record;
+
+
+   --  Support
+   --
+   procedure verify_Name (Self : in out Object'Class);
+
+end openGL.Buffer;

3-mid/opengl/source/lean/geometry/opengl-geometry-colored.adb

@@ -0,0 +1,152 @@
+with
+     openGL.Shader,
+     openGL.Program,
+     openGL.Buffer.general,
+     openGL.Tasks,
+     openGL.Attribute,
+     openGL.Errors,
+
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+package body openGL.Geometry.colored
+is
+   use GL.lean, GL.Pointers;
+   use Interfaces;
+
+   -----------
+   --  Globals
+   --
+
+   vertex_Shader   : aliased Shader.item;
+   fragment_Shader : aliased Shader.item;
+   the_Program     :         openGL.Program.view;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Color";
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+
+
+   ---------
+   --  Forge
+   --
+
+   function new_Geometry return Geometry.colored.view
+   is
+      use      System.storage_Elements;
+      use type openGL.Program.view;
+
+      Self : constant Geometry.colored.view := new Geometry.colored.item;
+   begin
+      Tasks.check;
+
+      if the_Program = null
+      then   -- Define the shaders and program.
+         declare
+            use openGL.Attribute.Forge;
+
+            sample_Vertex : Vertex;
+            Attribute_1   : Attribute.view;
+            Attribute_2   : Attribute.view;
+         begin
+            vertex_Shader  .define (Shader.Vertex,   "assets/opengl/shader/colored.vert");
+            fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/colored.frag");
+
+            the_Program := new openGL.Program.item;
+            the_Program.define (vertex_Shader  'Access,
+                                fragment_Shader'Access);
+
+            Attribute_1 := new_Attribute (Name        => Name_1,
+                                          gl_Location => the_Program.attribute_Location (Name_1),
+                                          Size        => 3,
+                                          data_Kind   => Attribute.GL_FLOAT,
+                                          Stride      => colored.Vertex'Size / 8,
+                                          Offset      => 0,
+                                          Normalized  => False);
+
+            Attribute_2 := new_Attribute (Name        => Name_2,
+                                          gl_Location => the_Program.attribute_Location (Name_2),
+                                          Size        => 4,
+                                          data_Kind   => Attribute.GL_UNSIGNED_BYTE,
+                                          Stride      => colored.Vertex'Size / 8,
+                                          Offset      =>   sample_Vertex.Color.primary.Red'Address
+                                                         - sample_Vertex.Site (1)         'Address,
+                                          Normalized  => True);
+            the_Program.add (Attribute_1);
+            the_Program.add (Attribute_2);
+
+            glBindAttribLocation (Program =>  the_Program.gl_Program,
+                                  Index   =>  the_Program.Attribute (named => Name_1).gl_Location,
+                                  Name    => +Attribute_1_Name_ptr);
+            Errors.log;
+
+            glBindAttribLocation (Program =>  the_Program.gl_Program,
+                                  Index   =>  the_Program.Attribute (named => Name_2).gl_Location,
+                                  Name    => +Attribute_2_Name_ptr);
+            Errors.log;
+         end;
+      end if;
+
+      Self.Program_is (the_Program);
+
+      return Self;
+   end new_Geometry;
+
+
+   ------------
+   --  Vertices
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean
+   is
+      function get_Color (Index : in Index_t) return rgba_Color
+      is (Self (Index).Color);
+
+      function my_Transparency is new get_Transparency (any_Index_t => Index_t,
+                                                        get_Color   => get_Color);
+   begin
+      return my_Transparency (Count => Self'Length);
+   end is_Transparent;
+
+
+   --------------
+   --  Attributes
+   --
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL.Buffer,
+          openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      free (Self.Vertices);
+      Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
+                                                                                  usage => Buffer.static_Draw));
+      Self.is_Transparent := is_Transparent (Now);
+
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+end openGL.Geometry.colored;

3-mid/opengl/source/lean/geometry/opengl-geometry-colored.ads

@@ -0,0 +1,43 @@
+package openGL.Geometry.colored
+--
+--  Supports per-vertex site and color.
+--
+is
+   type Item is new Geometry.item with private;
+   type View is access Item'Class;
+
+
+
+   function new_Geometry return Geometry.colored.view;
+
+
+   ------------
+   --  Vertices
+   --
+
+   type Vertex is
+      record
+         Site  : Vector_3;
+         Color : rgba_Color;
+      end record;
+
+   type Vertex_array      is array (Index_t range <>) of aliased Vertex;
+   type Vertex_array_view is access Vertex_array;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array);
+
+
+
+private
+
+   type Item is new Geometry.item with
+      record
+         null;
+      end record;
+
+end openGL.Geometry.colored;

3-mid/opengl/source/lean/geometry/opengl-geometry-colored_textured.adb

@@ -0,0 +1,213 @@
+with
+     openGL.Shader,
+     openGL.Buffer.general,
+     openGL.Program,
+     openGL.Attribute,
+     openGL.Texture,
+     openGL.Palette,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.Binding,
+     GL.lean,
+     GL.Pointers,
+
+     System,
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+package body openGL.Geometry.colored_textured
+is
+   use GL.lean,
+       GL.Pointers,
+       Interfaces;
+
+   -----------
+   --  Globals
+   --
+
+   vertex_Shader        : aliased Shader.item;
+   fragment_Shader      : aliased Shader.item;
+   the_Program          :         openGL.Program.view;
+   white_Texture        :         openGL.Texture.Object;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Color";
+   Name_3 : constant String := "Coords";
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+
+
+   ---------
+   --  Forge
+   --
+
+   type Geometry_view is access all Geometry.colored_textured.item'Class;
+
+   function new_Geometry return access Geometry.colored_textured.item'Class
+   is
+      use      System,
+               System.storage_Elements;
+      use type openGL.Program.view;
+
+      Self : constant Geometry_view := new Geometry.colored_textured.item;
+
+   begin
+      Tasks.check;
+
+      if the_Program = null
+      then   -- Define the shaders and program.
+         declare
+            use Palette,
+                Attribute.Forge;
+
+            Sample : Vertex;
+
+            Attribute_1 : Attribute.view;
+            Attribute_2 : Attribute.view;
+            Attribute_3 : Attribute.view;
+
+            white_Image : constant Image := [1 .. 2 => [1 .. 2 => +White]];
+         begin
+            white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+
+            vertex_Shader  .define (Shader.Vertex,   "assets/opengl/shader/colored_textured.vert");
+            fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/colored_textured.frag");
+
+            the_Program := new openGL.Program.item;
+            the_Program.define (vertex_Shader  'Access,
+                                fragment_Shader'Access);
+            the_Program.enable;
+
+            Attribute_1 := new_Attribute (Name => Name_1,
+                                          gl_Location => the_Program.attribute_Location (Name_1),
+                                          Size        => 3,
+                                          data_Kind   => Attribute.GL_FLOAT,
+                                          Stride      => colored_textured.Vertex'Size / 8,
+                                          Offset      => 0,
+                                          Normalized  => False);
+
+            Attribute_2 := new_Attribute (Name        => Name_2,
+                                          gl_Location => the_Program.attribute_Location (Name_2),
+                                          Size        => 4,
+                                          data_Kind   => Attribute.GL_UNSIGNED_BYTE,
+                                          Stride      => colored_textured.Vertex'Size / 8,
+                                          Offset      =>   Sample.Color.Primary.Red'Address
+                                                         - Sample.Site (1)         'Address,
+                                          Normalized  => True);
+
+            Attribute_3 := new_Attribute (Name        => Name_3,
+                                          gl_Location => the_Program.attribute_Location (Name_3),
+                                          Size        => 2,
+                                          data_Kind   => attribute.GL_FLOAT,
+                                          Stride      => Colored_textured.Vertex'Size / 8,
+                                          Offset      =>   Sample.Coords.S'Address
+                                                         - Sample.Site (1)'Address,
+                                          Normalized  => False);
+            the_Program.add (Attribute_1);
+            the_Program.add (Attribute_2);
+            the_Program.add (Attribute_3);
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_1).gl_Location,
+                                  name    => +Attribute_1_Name_ptr);
+            Errors.log;
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_2).gl_Location,
+                                  name    => +Attribute_2_Name_ptr);
+            Errors.log;
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_3).gl_Location,
+                                  name    => +Attribute_3_Name_ptr);
+            Errors.log;
+         end;
+      end if;
+
+      Self.Program_is (the_Program.all'Access);
+      return Self;
+   end new_Geometry;
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean
+   is
+      function get_Color (Index : in long_Index_t) return rgba_Color
+      is (Self (Index).Color);
+
+      function my_Transparency is new get_Transparency (any_Index_t => long_Index_t,
+                                                        get_Color   => get_Color);
+   begin
+      return my_Transparency (Count => Self'Length);
+   end is_Transparent;
+
+
+   --------------
+   --  Attributes
+   --
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => long_Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
+                                                                                  usage => Buffer.static_Draw));
+      Self.is_Transparent := is_Transparent (Now);
+
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in long_Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (long_Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "TODO";
+   end Indices_are;
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+      use GL,
+          GL.Binding,
+          openGL.Texture;
+   begin
+      Tasks.check;
+
+      glActiveTexture (gl.GL_TEXTURE0);
+      Errors.log;
+
+      if Self.Texture = openGL.Texture.null_Object
+      then   enable (white_Texture);
+      else   enable (Self.Texture);
+      end if;
+   end enable_Texture;
+
+
+end openGL.Geometry.colored_textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-colored_textured.ads

@@ -0,0 +1,47 @@
+package openGL.Geometry.colored_textured
+--
+--  Supports per-vertex site, color and texture.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+
+   function new_Geometry return access Geometry.colored_textured.item'Class;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Color  : rgba_Color;
+         Coords : Coordinate_2D;
+      end record;
+
+   type Vertex_array      is array (long_Index_t range <>) of aliased Vertex;
+   type Vertex_array_view is access Vertex_array;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are (Self : in out Item;   Now       : in Vertex_array);
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive);
+
+
+private
+
+   type Item is new Geometry.item with
+      record
+         null;
+      end record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.colored_textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored.adb

@@ -0,0 +1,211 @@
+with
+     openGL.Program.lit,
+     openGL.Buffer.general,
+     openGL.Shader,
+     openGL.Attribute,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+
+package body openGL.Geometry.lit_colored
+is
+   use GL.lean,
+       GL.Pointers,
+       Interfaces,
+       System;
+
+   ------------------
+   --  Shader Program
+   --
+
+   type Program is
+      record
+         vertex_Shader   : aliased Shader.item;
+         fragment_Shader : aliased Shader.item;
+         Program         :         openGL.Program.lit.view;
+      end record;
+
+
+   -----------
+   --- Globals
+   --
+
+   the_Program : aliased Program;
+
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Normal";
+   Name_3 : constant String := "Color";
+   Name_4 : constant String := "Shine";
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+   Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+   Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
+
+
+   ---------
+   --  Forge
+   --
+
+   function new_Geometry return View
+   is
+      use      System.storage_Elements;
+      use type openGL.Program.lit.view;
+
+      procedure define (the_Program : access Program)
+      is
+         use Attribute.Forge;
+
+         Sample : Vertex;
+
+         Attribute_1,
+         Attribute_2,
+         Attribute_3,
+         Attribute_4 : Attribute.view;
+      begin
+         the_Program.Program := new openGL.Program.lit.item;
+
+         the_Program.  vertex_Shader.define (Shader.Vertex,    "assets/opengl/shader/lit_colored.vert");
+         the_Program.fragment_Shader.define (Shader.Fragment,  "assets/opengl/shader/lit_colored.frag");
+
+         the_Program.Program.define (the_Program.  vertex_Shader'Access,
+                                     the_Program.fragment_Shader'Access);
+
+         Attribute_1 := new_Attribute (Name        => Name_1,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_1),
+                                       Size        => 3,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored.Vertex'Size / 8,
+                                       Offset      => 0,
+                                       Normalized  => False);
+
+         Attribute_2 := new_Attribute (Name        => Name_2,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_2),
+                                       Size        => 3,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored.Vertex'Size / 8,
+                                       Offset      =>   Sample.Normal (1)'Address
+                                                      - Sample.Site   (1)'Address,
+                                       Normalized  => False);
+
+         Attribute_3 := new_Attribute (Name        => Name_3,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_3),
+                                       Size        => 4,
+                                       data_Kind   => attribute.GL_UNSIGNED_BYTE,
+                                       Stride      => lit_colored.Vertex'Size / 8,
+                                       Offset      =>   Sample.Color.Primary.Red'Address
+                                                      - Sample.Site (1)         'Address,
+                                       Normalized  => True);
+
+         Attribute_4 := new_Attribute (Name        => Name_4,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_4),
+                                       Size        => 1,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored.Vertex'Size / 8,
+                                       Offset      =>   Sample.Shine    'Address
+                                                      - Sample.Site (1) 'Address,
+                                       Normalized  => True);
+
+         the_Program.Program.add (Attribute_1);
+         the_Program.Program.add (Attribute_2);
+         the_Program.Program.add (Attribute_3);
+         the_Program.Program.add (Attribute_4);
+
+         glBindAttribLocation (program =>  the_Program.Program.gl_Program,
+                               index   =>  the_Program.Program.Attribute (named => Name_1).gl_Location,
+                               name    => +Attribute_1_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (program =>  the_Program.Program.gl_Program,
+                               index   =>  the_Program.Program.Attribute (named => Name_2).gl_Location,
+                               name    => +Attribute_2_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (program =>  the_Program.Program.gl_Program,
+                               index   =>  the_Program.Program.Attribute (named => Name_3).gl_Location,
+                               name    => +Attribute_3_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (program =>  the_Program.Program.gl_Program,
+                               index   =>  the_Program.Program.Attribute (named => Name_4).gl_Location,
+                               name    => +Attribute_4_Name_ptr);
+         Errors.log;
+      end define;
+
+      Self : constant View := new Geometry.lit_colored.item;
+
+   begin
+      Tasks.check;
+
+      if the_Program.Program = null     --  Define the shaders and program, if required.
+      then
+         define (the_Program'Access);
+      end if;
+
+      Self.Program_is (openGL.Program.view (the_Program.Program));
+      return Self;
+   end new_Geometry;
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean
+   is
+      function get_Color (Index : in Index_t) return rgba_Color
+      is (Self (Index).Color);
+
+      function my_Transparency is new get_Transparency (any_Index_t => Index_t,
+                                                        get_Color   => get_Color);
+   begin
+      return my_Transparency (Count => Self'Length);
+   end is_Transparent;
+
+
+   --------------
+   --  Attributes
+   --
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Buffer.free (Self.Vertices);
+
+      Self.is_Transparent := False;
+      self.Vertices       := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
+                                                                                        usage => Buffer.static_Draw));
+      Self.is_Transparent := is_Transparent (Now);
+
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+end openGL.Geometry.lit_colored;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored.ads

@@ -0,0 +1,40 @@
+package openGL.Geometry.lit_colored
+--
+--  Supports per-vertex color and lighting.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+   type View is access all Item'Class;
+
+
+   function new_Geometry return View;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Color  : rgba_Color;
+         Shine  : Real;
+      end record;
+
+   type Vertex_array is array (Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are   (Self : in out Item;   Now : in Vertex_array);
+
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+end openGL.Geometry.lit_colored;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored_skinned.adb

@@ -0,0 +1,268 @@
+with
+     openGL.Shader,
+     openGL.Attribute,
+     openGL.Buffer.general,
+     openGL.Texture,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+
+package body openGL.Geometry.lit_colored_skinned
+is
+   --  Globals
+   --
+   vertex_Shader   : aliased Shader.item;
+   fragment_Shader : aliased Shader.item;
+
+   the_Program     : aliased openGL.Program.lit.colored_skinned.item;
+   is_Defined      :         Boolean := False;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Normal";
+   Name_3 : constant String := "Color";
+   Name_4 : constant String := "Shine";
+   Name_5 : constant String := "bone_Ids";
+   Name_6 : constant String := "bone_Weights";
+
+   use Interfaces;
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+   Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
+   Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
+   Attribute_6_Name : aliased C.char_array := C.to_C (Name_6);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+   Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
+   Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
+   Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Access);
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean   -- TODO: Replace this with the generic (check that all similar functions use the generic).
+   is
+      use type color_Value;
+   begin
+      for Each in Self'Range
+      loop
+         if Self (Each).Color.Alpha /= opaque_Value
+         then
+            return True;
+         end if;
+      end loop;
+
+      return False;
+   end is_Transparent;
+
+
+   ---------
+   --  Forge
+   --
+
+   function new_Geometry return Geometry.lit_colored_skinned.view
+   is
+      Self : constant Geometry.lit_colored_skinned.view := new Geometry.lit_colored_skinned.item;
+   begin
+      Self.Program_is (the_Program'Access);
+      return Self;
+   end new_Geometry;
+
+
+
+   procedure define_Program
+   is
+      use Attribute.Forge,
+          GL.lean,
+          GL.Pointers,
+          System.storage_Elements;
+
+      Sample : Vertex;
+
+      Attribute_1 : openGL.Attribute.view;
+      Attribute_2 : openGL.Attribute.view;
+      Attribute_3 : openGL.Attribute.view;
+      Attribute_4 : openGL.Attribute.view;
+      Attribute_5 : openGL.Attribute.view;
+      Attribute_6 : openGL.Attribute.view;
+
+   begin
+      Tasks.check;
+
+      if is_Defined
+      then
+         raise Error with "The lit_colored_textured_skinned program has already been defined.";
+      end if;
+
+      is_Defined := True;
+
+      -- Define the shaders and program.
+      --
+      vertex_Shader  .define (Shader.Vertex,   "assets/opengl/shader/lit_colored_skinned.vert");
+      fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_colored_skinned.frag");
+
+      the_Program.define (  vertex_Shader'Access,
+                          fragment_Shader'Access);
+      the_Program.enable;
+
+      Attribute_1 := new_Attribute (Name        => Name_1,
+                                    gl_Location => the_Program.attribute_Location (Name_1),
+                                    Size        => 3,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_skinned.Vertex'Size / 8,
+                                    Offset      => 0,
+                                    Normalized  => False);
+
+      Attribute_2 := new_Attribute (Name        => Name_2,
+                                    gl_Location => the_Program.attribute_Location (Name_2),
+                                    Size        => 3,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Normal (1)'Address
+                                                   - Sample.Site   (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_3 := new_Attribute (Name        => Name_3,
+                                    gl_Location => the_Program.attribute_Location (Name_3),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_UNSIGNED_BYTE,
+                                    Stride      => lit_colored_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Color.Primary.Red'Address
+                                                   - Sample.Site (1)         'Address,
+                                    Normalized  => True);
+
+      Attribute_4 := new_Attribute (Name        => Name_4,
+                                    gl_Location => the_Program.attribute_Location (Name_4),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Ids (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_5 := new_Attribute (Name        => Name_5,
+                                    gl_Location => the_Program.attribute_Location (Name_5),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Ids (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_6 := new_Attribute (Name        => Name_6,
+                                    gl_Location => the_Program.attribute_Location (Name_6),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Weights (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+      the_Program.add (Attribute_1);
+      the_Program.add (Attribute_2);
+      the_Program.add (Attribute_3);
+      the_Program.add (Attribute_4);
+      the_Program.add (Attribute_5);
+      the_Program.add (Attribute_6);
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_1).gl_Location,
+                            name    => +Attribute_1_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_2).gl_Location,
+                            name    => +Attribute_2_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_3).gl_Location,
+                            name    => +Attribute_3_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_4).gl_Location,
+                            name    => +Attribute_4_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_5).gl_Location,
+                            name    => +Attribute_5_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_6).gl_Location,
+                            name    => +Attribute_6_Name_ptr);
+      Errors.log;
+
+   end define_Program;
+
+
+   --------------
+   --  Attributes
+   --
+
+   function Program return openGL.Program.lit.colored_skinned.view
+   is
+   begin
+      return the_Program'Access;
+   end Program;
+
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "openGL.Geometry.lit_coloured_textured_skinned - 'Indices_are' ~ TODO";
+   end Indices_are;
+
+
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => long_Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices       := new openGL_Buffer_of_geometry_Vertices.object' (to_Buffer (Now,
+                                                                                        usage => Buffer.static_Draw));
+      Self.is_Transparent :=    Self.is_Transparent
+                             or is_Transparent (Now);
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in long_Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (long_Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+   begin
+      null;
+   end enable_Texture;
+
+
+end openGL.Geometry.lit_colored_skinned;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored_skinned.ads

@@ -0,0 +1,57 @@
+with
+     openGL.Program.lit.colored_skinned;
+
+package openGL.Geometry.lit_colored_skinned
+--
+--  Supports per-vertex site color, texture, lighting and skinning.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+   type View is access all Item'Class;
+
+   function new_Geometry return View;
+
+   procedure define_Program;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Color  : rgba_Color;
+         Shine  : Real;
+
+         bone_Ids     : Vector_4;
+         bone_Weights : Vector_4;
+      end record;
+   pragma Convention (C, Vertex);
+
+   type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array);
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive);
+
+   function  Program return openGL.Program.lit.colored_skinned.view;
+
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.lit_colored_skinned;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored_textured.adb

@@ -0,0 +1,295 @@
+with
+     openGL.Program.lit,
+     openGL.Palette,
+     openGL.Shader,
+     openGL.Buffer.general,
+     openGL.Attribute,
+     openGL.Texture,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.Binding,
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+package body openGL.Geometry.lit_colored_textured
+is
+   use GL.lean,
+       GL.Pointers,
+       Interfaces,
+       System;
+
+   ------------------
+   --  Shader Program
+   --
+
+   type program_Id is (rgba_Texture, alpha_Texture);
+
+   type Program is
+      record
+         vertex_Shader   : aliased Shader.item;
+         fragment_Shader : aliased Shader.item;
+         Program         :         openGL.Program.lit.view;
+      end record;
+
+   type Programs is array (program_Id) of aliased Program;
+
+
+   -----------
+   --- Globals
+   --
+
+   the_Programs : Programs;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Normal";
+   Name_3 : constant String := "Color";
+   Name_4 : constant String := "Coords";
+   Name_5 : constant String := "Shine";
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+   Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
+   Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+   Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
+   Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
+
+   white_Texture : openGL.Texture.Object;
+
+
+   ---------
+   --  Forge
+   --
+
+   type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
+
+   function new_Geometry (texture_is_Alpha : in Boolean) return access Geometry.lit_colored_textured.item'Class
+   is
+      use type openGL.Program.lit.view;
+
+
+      procedure define (the_Program         : access Program;
+                        use_fragment_Shader : in     String)
+      is
+         use openGL.Palette,
+             Attribute.Forge,
+             system.Storage_Elements;
+
+         Sample : Vertex;
+
+         Attribute_1 : openGL.Attribute.view;
+         Attribute_2 : openGL.Attribute.view;
+         Attribute_3 : openGL.Attribute.view;
+         Attribute_4 : openGL.Attribute.view;
+         Attribute_5 : openGL.Attribute.view;
+
+         white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
+
+      begin
+         white_Texture       := openGL.Texture.Forge.to_Texture (white_Image);
+         the_Program.Program := new openGL.Program.lit.item;
+
+         the_Program.  vertex_Shader.define (Shader.Vertex,   "assets/opengl/shader/lit_colored_textured.vert");
+         the_Program.fragment_Shader.define (Shader.Fragment, use_fragment_Shader);
+
+         the_Program.Program.define (the_Program.  vertex_Shader'Access,
+                                     the_Program.fragment_Shader'Access);
+         the_Program.Program.enable;
+
+         Attribute_1 := new_Attribute (Name        => Name_1,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_1),
+                                       Size        => 3,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored_textured.Vertex'Size / 8,
+                                       Offset      => 0,
+                                       Normalized  => False);
+
+         Attribute_2 := new_Attribute (Name        => Name_2,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_2),
+                                       Size        => 3,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored_textured.Vertex'Size / 8,
+                                       Offset      =>   Sample.Normal (1)'Address
+                                                      - Sample.Site   (1)'Address,
+                                       Normalized  => False);
+
+         Attribute_3 := new_Attribute (Name        => Name_3,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_3),
+                                       Size        => 4,
+                                       data_Kind   => attribute.GL_UNSIGNED_BYTE,
+                                       Stride      => lit_colored_textured.Vertex'Size / 8,
+                                       Offset      =>   Sample.Color.Primary.Red'Address
+                                                      - Sample.Site (1)         'Address,
+                                       Normalized  => True);
+
+         Attribute_4 := new_Attribute (Name        => Name_4,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_4),
+                                       Size        => 2,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored_textured.Vertex'Size / 8,
+                                       Offset      =>   Sample.Coords.S'Address
+                                                      - Sample.Site (1)'Address,
+                                       Normalized  => False);
+
+         Attribute_5 := new_Attribute (Name        => Name_5,
+                                       gl_Location => the_Program.Program.attribute_Location (Name_5),
+                                       Size        => 1,
+                                       data_Kind   => attribute.GL_FLOAT,
+                                       Stride      => lit_colored_textured.Vertex'Size / 8,
+                                       Offset      =>   Sample.Shine   'Address
+                                                      - Sample.Site (1)'Address,
+                                       Normalized  => False);
+
+         the_Program.Program.add (Attribute_1);
+         the_Program.Program.add (Attribute_2);
+         the_Program.Program.add (Attribute_3);
+         the_Program.Program.add (Attribute_4);
+         the_Program.Program.add (Attribute_5);
+
+         glBindAttribLocation (Program =>  the_Program.Program.gl_Program,
+                               Index   =>  the_Program.Program.Attribute (named => Name_1).gl_Location,
+                               Name    => +Attribute_1_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (Program =>  the_Program.Program.gl_Program,
+                               Index   =>  the_Program.Program.Attribute (named => Name_2).gl_Location,
+                               Name    => +Attribute_2_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (Program =>  the_Program.Program.gl_Program,
+                               Index   =>  the_Program.Program.Attribute (named => Name_3).gl_Location,
+                               Name    => +Attribute_3_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (Program =>  the_Program.Program.gl_Program,
+                               Index   =>  the_Program.Program.Attribute (named => Name_4).gl_Location,
+                               Name    => +Attribute_4_Name_ptr);
+         Errors.log;
+
+         glBindAttribLocation (Program =>  the_Program.Program.gl_Program,
+                               Index   =>  the_Program.Program.Attribute (named => Name_5).gl_Location,
+                               Name    => +Attribute_5_Name_ptr);
+         Errors.log;
+      end define;
+
+      Self : constant Geometry_view := new Geometry.lit_colored_textured.item;
+
+   begin
+      Tasks.check;
+
+      if texture_is_Alpha     --  Define the shaders and program, if required.
+      then
+         if the_Programs (alpha_Texture).Program = null
+         then
+            define (the_Programs (alpha_Texture)'Access,
+                    use_fragment_Shader => "assets/opengl/shader/lit_colored_text.frag");
+         end if;
+      else
+         if the_Programs (rgba_Texture).Program = null
+         then
+            define (the_Programs (rgba_Texture)'Access,
+                    use_fragment_Shader => "assets/opengl/shader/lit_colored_textured.frag");
+         end if;
+      end if;
+
+      if texture_is_Alpha
+      then   Self.is_Transparent := True;
+             Self.Program_is (the_Programs (alpha_Texture).Program.all'Access);
+      else   Self.Program_is (the_Programs ( rgba_Texture).Program.all'Access);
+      end if;
+
+      return Self;
+   end new_Geometry;
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean
+   is
+      function get_Color (Index : in Index_t) return rgba_Color
+      is (Self (Index).Color);
+
+      function my_Transparency is new get_Transparency (any_Index_t => Index_t,
+                                                        get_Color   => get_Color);
+   begin
+      return my_Transparency (Count => Self'Length);
+   end is_Transparent;
+
+
+   --------------
+   --  Attributes
+   --
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use      openGL_Buffer_of_geometry_Vertices;
+      use type Buffer.view;
+   begin
+      if Self.Vertices = null
+      then
+         self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (Forge.to_Buffer (Now,
+                                                                                           usage => Buffer.static_Draw));
+      else
+         set (openGL_Buffer_of_geometry_Vertices.Object (Self.Vertices.all),
+              to => Now);
+      end if;
+
+      Self.is_Transparent := is_Transparent (Now);
+
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "TODO";
+   end Indices_are;
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+      use GL,
+          GL.Binding,
+          openGL.Texture;
+   begin
+      Tasks.check;
+
+      glActiveTexture (gl.GL_TEXTURE0);
+      Errors.log;
+
+      if Self.Texture = openGL.Texture.null_Object
+      then   enable (white_Texture);
+      else   enable (Self.Texture);
+      end if;
+   end enable_Texture;
+
+
+end openGL.Geometry.lit_colored_textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored_textured.ads

@@ -0,0 +1,47 @@
+package openGL.Geometry.lit_colored_textured
+--
+--  Supports per-vertex site color, texture and lighting.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+   type View is access all Item'Class;
+
+   function new_Geometry (texture_is_Alpha : in Boolean) return access Geometry.lit_colored_textured.item'Class;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Color  : rgba_Color;
+         Coords : Coordinate_2D;
+         Shine  : Real;
+      end record;
+
+   type Vertex_array is array (Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are   (Self : in out Item;   Now       : in Vertex_array);
+
+   overriding
+   procedure Indices_are    (Self : in out Item;   Now       : in Indices;
+                                                   for_Facia : in Positive);
+
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.lit_colored_textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored_textured_skinned.adb

@@ -0,0 +1,321 @@
+with
+     openGL.Shader,
+     openGL.Attribute,
+     openGL.Buffer.general,
+     openGL.Texture,
+     openGL.Palette,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.Binding,
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+
+package body openGL.Geometry.lit_colored_textured_skinned
+is
+   --  Globals
+   --
+   vertex_Shader   : aliased Shader.item;
+   fragment_Shader : aliased Shader.item;
+
+   the_Program     : aliased openGL.Program.lit.colored_textured_skinned.item;
+   is_Defined      :         Boolean := False;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Normal";
+   Name_3 : constant String := "Color";
+   Name_4 : constant String := "Coords";
+   Name_5 : constant String := "Shine";
+   Name_6 : constant String := "bone_Ids";
+   Name_7 : constant String := "bone_Weights";
+
+   use Interfaces;
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+   Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
+   Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
+   Attribute_6_Name : aliased C.char_array := C.to_C (Name_6);
+   Attribute_7_Name : aliased C.char_array := C.to_C (Name_7);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+   Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
+   Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
+   Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Access);
+   Attribute_7_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_7_Name'Access);
+
+   white_Texture   : openGL.Texture.Object;
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean   -- TODO: Replace this with the generic (check that all similar functions use the generic).
+   is
+      use type color_Value;
+   begin
+      for Each in Self'Range
+      loop
+         if Self (Each).Color.Alpha /= opaque_Value
+         then
+            return True;
+         end if;
+      end loop;
+
+      return False;
+   end is_Transparent;
+
+
+   ---------
+   --  Forge
+   --
+
+   type Geometry_view is access all Geometry.lit_colored_textured_skinned.item'Class;
+
+
+   function new_Geometry return access Geometry.lit_colored_textured_skinned.item'Class
+   is
+      Self : constant Geometry_view := new Geometry.lit_colored_textured_skinned.item;
+   begin
+      Self.Program_is (the_Program'Access);
+      return Self;
+   end new_Geometry;
+
+
+
+   procedure define_Program
+   is
+      use Palette,
+          Attribute.Forge,
+          GL.lean,
+          GL.Pointers,
+          System.storage_Elements;
+
+      Sample : Vertex;
+
+      Attribute_1 : openGL.Attribute.view;
+      Attribute_2 : openGL.Attribute.view;
+      Attribute_3 : openGL.Attribute.view;
+      Attribute_4 : openGL.Attribute.view;
+      Attribute_5 : openGL.Attribute.view;
+      Attribute_6 : openGL.Attribute.view;
+      Attribute_7 : openGL.Attribute.view;
+
+      white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
+
+   begin
+      Tasks.check;
+
+      if is_Defined
+      then
+         raise Error with "The lit_colored_textured_skinned program has already been defined.";
+      end if;
+
+      is_Defined := True;
+
+      -- Define the shaders and program.
+      --
+      white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+
+      vertex_Shader  .define (Shader.Vertex,   "assets/opengl/shader/lit_colored_textured_skinned.vert");
+      fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_colored_textured_skinned.frag");
+
+      the_Program.define (  vertex_Shader'Access,
+                          fragment_Shader'Access);
+      the_Program.enable;
+
+      Attribute_1 := new_Attribute (Name        => Name_1,
+                                    gl_Location => the_Program.attribute_Location (Name_1),
+                                    Size        => 3,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      => 0,
+                                    Normalized  => False);
+
+      Attribute_2 := new_Attribute (Name        => Name_2,
+                                    gl_Location => the_Program.attribute_Location (Name_2),
+                                    Size        => 3,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Normal (1)'Address
+                                                   - Sample.Site   (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_3 := new_Attribute (Name        => Name_3,
+                                    gl_Location => the_Program.attribute_Location (Name_3),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_UNSIGNED_BYTE,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Color.Primary.Red'Address
+                                                   - Sample.Site (1)         'Address,
+                                    Normalized  => True);
+
+      Attribute_4 := new_Attribute (Name        => Name_4,
+                                    gl_Location => the_Program.attribute_Location (Name_4),
+                                    Size        => 2,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Coords.S'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_5 := new_Attribute (Name        => Name_5,
+                                    gl_Location => the_Program.attribute_Location (Name_5),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Ids (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_6 := new_Attribute (Name        => Name_6,
+                                    gl_Location => the_Program.attribute_Location (Name_6),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Ids (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_7 := new_Attribute (Name        => Name_7,
+                                    gl_Location => the_Program.attribute_Location (Name_7),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_colored_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Weights (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+      the_Program.add (Attribute_1);
+      the_Program.add (Attribute_2);
+      the_Program.add (Attribute_3);
+      the_Program.add (Attribute_4);
+      the_Program.add (Attribute_5);
+      the_Program.add (Attribute_6);
+      the_Program.add (Attribute_7);
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_1).gl_Location,
+                            name    => +Attribute_1_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_2).gl_Location,
+                            name    => +Attribute_2_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_3).gl_Location,
+                            name    => +Attribute_3_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_4).gl_Location,
+                            name    => +Attribute_4_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_5).gl_Location,
+                            name    => +Attribute_5_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_6).gl_Location,
+                            name    => +Attribute_6_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_7).gl_Location,
+                            name    => +Attribute_7_Name_ptr);
+      Errors.log;
+   end define_Program;
+
+
+   --------------
+   --  Attributes
+   --
+
+   function Program return openGL.Program.lit.colored_textured_skinned.view
+   is
+   begin
+      return the_Program'Access;
+   end Program;
+
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "openGL.Geometry.lit_coloured_textured_skinned - 'Indices_are' ~ TODO";
+   end Indices_are;
+
+
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => long_Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices       := new openGL_Buffer_of_geometry_Vertices.object' (to_Buffer (Now,
+                                                                                        usage => Buffer.static_Draw));
+      Self.is_Transparent :=    Self.is_Transparent
+                             or is_Transparent (Now);
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in long_Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (long_Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+      use GL,
+          GL.Binding,
+          openGL.Texture;
+   begin
+      Tasks.check;
+
+      glActiveTexture (gl.GL_TEXTURE0);
+      Errors.log;
+
+      if Self.Texture = openGL.Texture.null_Object
+      then
+         if not white_Texture.is_Defined
+         then
+            declare
+               use Palette;
+               white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
+            begin
+               white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+            end;
+         end if;
+
+         white_Texture.enable;
+      else
+         Self.Texture.enable;
+      end if;
+   end enable_Texture;
+
+
+end openGL.Geometry.lit_colored_textured_skinned;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_colored_textured_skinned.ads

@@ -0,0 +1,58 @@
+with
+     openGL.Program.lit.colored_textured_skinned;
+
+
+package openGL.Geometry.lit_colored_textured_skinned
+--
+--  Supports per-vertex site color, texture, lighting and skinning.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+
+   function new_Geometry return access Geometry.lit_colored_textured_skinned.item'Class;
+
+   procedure define_Program;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Color  : rgba_Color;
+         Coords : Coordinate_2D;
+         Shine  : Real;
+
+         bone_Ids     : Vector_4;
+         bone_Weights : Vector_4;
+      end record;
+   pragma Convention (C, Vertex);
+
+   type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array);
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive);
+
+   function  Program return openGL.Program.lit.colored_textured_skinned.view;
+
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.lit_colored_textured_skinned;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.adb

@@ -0,0 +1,270 @@
+with
+     openGL.Buffer.general,
+     openGL.Shader,
+     openGL.Program.lit,
+     openGL.Attribute,
+     openGL.Texture,
+     openGL.Palette,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.Binding,
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+
+package body openGL.Geometry.lit_textured
+is
+   use GL.lean,
+       GL.Pointers,
+       Interfaces;
+
+   -----------
+   --  Globals
+   --
+
+   vertex_Shader   : aliased Shader.item;
+   fragment_Shader : aliased Shader.item;
+
+   the_Program     : openGL.Program.lit.view;
+   white_Texture   : openGL.Texture.Object;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Normal";
+   Name_3 : constant String := "Coords";
+   Name_4 : constant String := "Shine";
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+   Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+   Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
+
+
+   ---------
+   --  Forge
+   --
+
+   function new_Geometry return View
+   is
+      use      System,
+               System.storage_Elements;
+      use type openGL.Program.lit.view;
+
+      Self : constant View := new Geometry.lit_textured.item;
+
+   begin
+      Tasks.check;
+
+      if the_Program = null
+      then   -- Define the shaders and program.
+         declare
+            use Palette,
+                Attribute.Forge;
+
+            Sample : Vertex;
+
+            Attribute_1 : Attribute.view;
+            Attribute_2 : Attribute.view;
+            Attribute_3 : Attribute.view;
+            Attribute_4 : Attribute.view;
+
+            white_Image : constant Image := [1 .. 2 => [1 .. 2 => +White]];
+
+         begin
+            white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+
+            vertex_Shader  .define (Shader.Vertex,   "assets/opengl/shader/lit_textured.vert");
+            fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_textured.frag");
+
+            the_Program := new openGL.Program.lit.item;
+            the_Program.define (  vertex_Shader'Access,
+                                fragment_Shader'Access);
+            the_Program.enable;
+
+            Attribute_1 := new_Attribute (Name        => Name_1,
+                                          gl_Location => the_Program.attribute_Location (Name_1),
+                                          Size        => 3,
+                                          data_Kind   => attribute.GL_FLOAT,
+                                          Stride      => lit_textured.Vertex'Size / 8,
+                                          Offset      => 0,
+                                          Normalized  => False);
+
+            Attribute_2 := new_Attribute (Name        => Name_2,
+                                          gl_Location => the_Program.attribute_Location (Name_2),
+                                          Size        => 3,
+                                          data_Kind   => attribute.GL_FLOAT,
+                                          Stride      => lit_textured.Vertex'Size / 8,
+                                          Offset      =>   Sample.Normal (1)'Address
+                                                         - Sample.Site   (1)'Address,
+                                          Normalized  => False);
+
+            Attribute_3 := new_Attribute (Name        => Name_3,
+                                          gl_Location => the_Program.attribute_Location (Name_3),
+                                          Size        => 2,
+                                          data_Kind   => attribute.GL_FLOAT,
+                                          Stride      => lit_textured.Vertex'Size / 8,
+                                          Offset      =>   Sample.Coords.S'Address
+                                                         - Sample.Site (1)'Address,
+                                          Normalized  => False);
+
+            Attribute_4 := new_Attribute (Name        => Name_4,
+                                          gl_Location => the_Program.attribute_Location (Name_4),
+                                          Size        => 1,
+                                          data_Kind   => attribute.GL_FLOAT,
+                                          Stride      => lit_textured.Vertex'Size / 8,
+                                          Offset      =>   Sample.Shine   'Address
+                                                         - Sample.Site (1)'Address,
+                                          Normalized  => False);
+
+            the_Program.add (Attribute_1);
+            the_Program.add (Attribute_2);
+            the_Program.add (Attribute_3);
+            the_Program.add (Attribute_4);
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_1).gl_Location,
+                                  name    => +Attribute_1_Name_ptr);
+            Errors.log;
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_2).gl_Location,
+                                  name    => +Attribute_2_Name_ptr);
+            Errors.log;
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_3).gl_Location,
+                                  name    => +Attribute_3_Name_ptr);
+            Errors.log;
+
+            glBindAttribLocation (program =>  the_Program.gl_Program,
+                                  index   =>  the_Program.Attribute (named => Name_4).gl_Location,
+                                  name    => +Attribute_4_Name_ptr);
+            Errors.log;
+         end;
+      end if;
+
+      Self.Program_is (the_Program.all'Access);
+      return Self;
+   end new_Geometry;
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean     -- TODO: Do these properly.
+   is
+      pragma Unreferenced (Self);
+   begin
+      return False;
+   end is_Transparent;
+
+
+
+   function is_Transparent (Self : in Vertex_large_array) return Boolean
+   is
+      pragma Unreferenced (Self);
+   begin
+      return False;
+   end is_Transparent;
+
+
+   --------------
+   --  Attributes
+   --
+
+   package openGL_Buffer_of_geometry_Vertices       is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                           Index         => Index_t,
+                                                                           Element       => Vertex,
+                                                                           Element_Array => Vertex_array);
+
+   package openGL_large_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                           Index         => long_Index_t,
+                                                                           Element       => Vertex,
+                                                                           Element_Array => Vertex_large_array);
+
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices       := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
+                                                                                        usage => Buffer.static_Draw));
+      Self.is_Transparent := is_Transparent (Now);
+
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_large_array)
+   is
+      use openGL_large_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices       := new openGL_large_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
+                                                                                   usage => Buffer.static_Draw));
+      Self.is_Transparent := is_Transparent (Now);
+
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in long_Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (long_Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "TODO";
+   end Indices_are;
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+      use GL,
+          GL.Binding,
+          openGL.Texture;
+
+      check_is_OK : constant Boolean := openGL.Tasks.Check;     pragma Unreferenced (check_is_OK);
+
+   begin
+      Tasks.check;
+
+      glActiveTexture (gl.GL_TEXTURE0);
+      Errors.log;
+
+      if Self.Texture = openGL.Texture.null_Object
+      then   enable (white_Texture);
+      else   enable (Self.Texture);
+      end if;
+   end enable_Texture;
+
+
+end openGL.Geometry.lit_textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.ads

@@ -0,0 +1,48 @@
+package openGL.Geometry.lit_textured
+--
+--  Supports per-vertex site texture and lighting.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+   type View is access all Item'Class;
+
+
+   function new_Geometry return View;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Coords : Coordinate_2D;
+         Shine  : Real;
+      end record;
+
+   type Vertex_array       is array (     Index_t range <>) of aliased Vertex;
+   type Vertex_large_array is array (long_Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are (Self : in out Item;   Now       : in Vertex_array);
+   procedure Vertices_are (Self : in out Item;   Now       : in Vertex_large_array);
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive);
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.lit_textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured_skinned.adb

@@ -0,0 +1,295 @@
+with
+     openGL.Shader,
+     openGL.Attribute,
+     openGL.Buffer.general,
+     openGL.Texture,
+     openGL.Palette,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.Binding,
+     GL.lean,
+     GL.Pointers,
+
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+
+package body openGL.Geometry.lit_textured_skinned
+is
+   -----------
+   --  Globals
+   --
+   vertex_Shader   : aliased Shader.item;
+   fragment_Shader : aliased Shader.item;
+
+   the_Program     : aliased openGL.Program.lit.textured_skinned.item;
+   is_Defined      :         Boolean := False;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Normal";
+   Name_3 : constant String := "Coords";
+   Name_4 : constant String := "Shine";
+   Name_5 : constant String := "bone_Ids";
+   Name_6 : constant String := "bone_Weights";
+
+   use Interfaces;
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+   Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
+   Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
+   Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
+   Attribute_6_Name : aliased C.char_array := C.to_C (Name_6);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+   Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
+   Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
+   Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
+   Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Access);
+
+   white_Texture   : openGL.Texture.Object;
+
+
+   ----------
+   --  Vertex
+   --
+
+   function is_Transparent (Self : in Vertex_array) return Boolean   -- TODO: Replace this with the generic (check that all similar functions use the generic).
+   is
+      pragma Unreferenced (Self);
+   begin
+      return False;
+   end is_Transparent;
+
+
+   ---------
+   --  Forge
+   --
+
+   type Geometry_view is access all Geometry.lit_textured_skinned.item'Class;
+
+
+   function new_Geometry return access Geometry.lit_textured_skinned.item'Class
+   is
+      Self : constant Geometry_view := new Geometry.lit_textured_skinned.item;
+   begin
+      Self.Program_is (the_Program'Access);
+      return Self;
+   end new_Geometry;
+
+
+
+   procedure define_Program
+   is
+      use Palette,
+          Attribute.Forge,
+          GL.lean,
+          GL.Pointers,
+          System.storage_Elements;
+
+      Sample : Vertex;
+
+      Attribute_1 : openGL.Attribute.view;
+      Attribute_2 : openGL.Attribute.view;
+      Attribute_3 : openGL.Attribute.view;
+      Attribute_4 : openGL.Attribute.view;
+      Attribute_5 : openGL.Attribute.view;
+      Attribute_6 : openGL.Attribute.view;
+
+      white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
+
+   begin
+      Tasks.check;
+
+      if is_Defined
+      then
+         raise Error with "The 'lit_textured_skinned' program has already been defined.";
+      end if;
+
+      is_Defined := True;
+
+      -- Define the shaders and program.
+      --
+      white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+
+      vertex_Shader  .define (Shader.Vertex,   "assets/opengl/shader/lit_textured_skinned.vert");
+      fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_textured_skinned.frag");
+
+      the_Program.define (  vertex_Shader'Access,
+                          fragment_Shader'Access);
+      the_Program.enable;
+
+      Attribute_1 := new_Attribute (Name        => Name_1,
+                                    gl_Location => the_Program.attribute_Location (Name_1),
+                                    Size        => 3,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_textured_skinned.Vertex'Size / 8,
+                                    Offset      => 0,
+                                    Normalized  => False);
+
+      Attribute_2 := new_Attribute (Name        => Name_2,
+                                    gl_Location => the_Program.attribute_Location (Name_2),
+                                    Size        => 3,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Normal (1)'Address
+                                                   - Sample.Site   (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_3 := new_Attribute (Name        => Name_3,
+                                    gl_Location => the_Program.attribute_Location (Name_3),
+                                    Size        => 2,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Coords.S'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_4 := new_Attribute (Name        => Name_4,
+                                    gl_Location => the_Program.attribute_Location (Name_4),
+                                    Size        => 1,
+                                    data_Kind   => attribute.GL_FLOAT,
+                                    Stride      => lit_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.Shine   'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_5 := new_Attribute (Name        => Name_5,
+                                    gl_Location => the_Program.attribute_Location (Name_5),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Ids (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+
+      Attribute_6 := new_Attribute (Name        => Name_6,
+                                    gl_Location => the_Program.attribute_Location (Name_6),
+                                    Size        => 4,
+                                    data_Kind   => Attribute.GL_FLOAT,
+                                    Stride      => lit_textured_skinned.Vertex'Size / 8,
+                                    Offset      =>   Sample.bone_Weights (1)'Address
+                                                   - Sample.Site (1)'Address,
+                                    Normalized  => False);
+      the_Program.add (Attribute_1);
+      the_Program.add (Attribute_2);
+      the_Program.add (Attribute_3);
+      the_Program.add (Attribute_4);
+      the_Program.add (Attribute_5);
+      the_Program.add (Attribute_6);
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_1).gl_Location,
+                            name    => +Attribute_1_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_2).gl_Location,
+                            name    => +Attribute_2_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_3).gl_Location,
+                            name    => +Attribute_3_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_4).gl_Location,
+                            name    => +Attribute_4_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_5).gl_Location,
+                            name    => +Attribute_5_Name_ptr);
+      Errors.log;
+
+      glBindAttribLocation (program => the_Program.gl_Program,
+                            index   => the_Program.Attribute (named => Name_6).gl_Location,
+                            name    => +Attribute_6_Name_ptr);
+      Errors.log;
+   end define_Program;
+
+
+   --------------
+   --  Attributes
+   --
+
+   function Program return openGL.Program.lit.textured_skinned.view
+   is
+   begin
+      return the_Program'Access;
+   end Program;
+
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "openGL.Geometry.lit_textured_skinned - 'Indices_are' ~ TODO";
+   end Indices_are;
+
+
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => long_Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices       := new openGL_Buffer_of_geometry_Vertices.object' (to_Buffer (Now,
+                                                                                        usage => Buffer.static_Draw));
+      Self.is_Transparent :=    Self.is_Transparent
+                             or is_Transparent (Now);
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in long_Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (long_Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+      use GL,
+          GL.Binding,
+          openGL.Texture;
+   begin
+      Tasks.check;
+
+      glActiveTexture (gl.GL_TEXTURE0);
+      Errors.log;
+
+      if Self.Texture = openGL.Texture.null_Object
+      then
+         if not white_Texture.is_Defined
+         then
+            declare
+               use Palette;
+               white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
+            begin
+               white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+            end;
+         end if;
+
+         white_Texture.enable;
+      else
+         Self.Texture.enable;
+      end if;
+   end enable_Texture;
+
+
+end openGL.Geometry.lit_textured_skinned;

3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured_skinned.ads

@@ -0,0 +1,57 @@
+with
+     openGL.Program.lit.textured_skinned;
+
+
+package openGL.Geometry.lit_textured_skinned
+--
+--  Supports per-vertex site, texture, lighting and skinning.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+
+   function new_Geometry return access Geometry.lit_textured_skinned.item'Class;
+
+   procedure define_Program;
+
+
+   ----------
+   --  Vertex
+   --
+
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Coords : Coordinate_2D;
+         Shine  : Real;
+
+         bone_Ids     : Vector_4;
+         bone_Weights : Vector_4;
+      end record;
+   pragma Convention (C, Vertex);
+
+   type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array);
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive);
+
+   function  Program return openGL.Program.lit.textured_skinned.view;
+
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.lit_textured_skinned;

3-mid/opengl/source/lean/geometry/opengl-geometry-textured.adb

@@ -0,0 +1,185 @@
+with
+     openGL.Buffer.general,
+     openGL.Shader,
+     openGL.Program,
+     openGL.Palette,
+     openGL.Attribute,
+     openGL.Texture,
+     openGL.Tasks,
+     openGL.Errors,
+
+     GL.Binding,
+     GL.lean,
+     GL.Pointers,
+
+     System,
+     Interfaces.C.Strings,
+     System.storage_Elements;
+
+
+package body openGL.Geometry.textured
+is
+   use GL.lean,
+       GL.Pointers,
+
+       Interfaces,
+       System;
+
+   -----------
+   --  Globals
+   --
+
+   vertex_Shader   : aliased Shader.item;
+   fragment_Shader : aliased Shader.item;
+
+   the_Program     : openGL.Program.view;
+   white_Texture   : openGL.Texture.Object;
+
+   Name_1 : constant String := "Site";
+   Name_2 : constant String := "Coords";
+
+   Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
+   Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
+
+   Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
+   Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
+
+
+   ---------
+   --  Forge
+   --
+
+   function new_Geometry return View
+   is
+      use type openGL.Program.view;
+
+      Self : constant View := new Geometry.textured.item;
+
+   begin
+      Tasks.check;
+
+      if the_Program = null
+      then   -- Define the shaders and program.
+         declare
+            use Palette,
+                Attribute.Forge,
+                system.Storage_Elements;
+
+            Sample : Vertex;
+
+            Attribute_1 : Attribute.view;
+            Attribute_2 : Attribute.view;
+
+            white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
+
+         begin
+            white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
+
+            vertex_Shader  .define (openGL.Shader.vertex,   "assets/opengl/shader/textured.vert");
+            fragment_Shader.define (openGL.Shader.fragment, "assets/opengl/shader/textured.frag");
+
+            the_Program := new openGL.Program.item;
+
+            the_Program.define (  vertex_Shader'Access,
+                                fragment_Shader'Access);
+            the_Program.enable;
+
+            Attribute_1 := new_Attribute (Name        => Name_1,
+                                          gl_Location => the_Program.attribute_Location (Name_1),
+                                          Size        => 3,
+                                          data_Kind   => Attribute.GL_FLOAT,
+                                          Stride      => textured.Vertex'Size / 8,
+                                          Offset      => 0,
+                                          Normalized  => False);
+
+            Attribute_2 := new_Attribute (Name        => Name_2,
+                                          gl_Location => the_Program.attribute_Location (Name_2),
+                                          Size        => 2,
+                                          data_Kind   => attribute.GL_FLOAT,
+                                          Stride      => textured.Vertex'Size / 8,
+                                          Offset      =>   Sample.Coords.S'Address
+                                                         - Sample.Site (1)'Address,
+                                          Normalized  => False);
+            the_Program.add (Attribute_1);
+            the_Program.add (Attribute_2);
+
+            glBindAttribLocation (program => the_Program.gl_Program,
+                                  index   => the_Program.Attribute (named => Name_1).gl_Location,
+                                  name    => +Attribute_1_Name_ptr);
+
+            glBindAttribLocation (program => the_Program.gl_Program,
+                                  index   => the_Program.Attribute (named => Name_2).gl_Location,
+                                  name    => +Attribute_2_Name_ptr);
+         end;
+      end if;
+
+      Self.Program_is (the_Program.all'Access);
+      return Self;
+   end new_Geometry;
+
+
+   --------------
+   --  Attributes
+   --
+
+   overriding
+   function is_Transparent (Self : in Item) return Boolean
+   is
+   begin
+      return Self.is_Transparent;
+   end is_Transparent;
+
+
+   package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object   => Buffer.array_Object,
+                                                                     Index         => Index_t,
+                                                                     Element       => Vertex,
+                                                                     Element_Array => Vertex_array);
+
+   procedure Vertices_are (Self : in out Item;   Now : in Vertex_array)
+   is
+      use openGL_Buffer_of_geometry_Vertices.Forge;
+   begin
+      Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
+                                                                                  usage => Buffer.static_Draw));
+      -- Set the bounds.
+      --
+      declare
+         function get_Site (Index : in Index_t) return Vector_3
+         is (Now (Index).Site);
+
+         function bounding_Box is new get_Bounds (Index_t, get_Site);
+      begin
+         Self.Bounds_are (bounding_Box (Count => Now'Length));
+      end;
+   end Vertices_are;
+
+
+   overriding
+   procedure Indices_are  (Self : in out Item;   Now       : in Indices;
+                                                 for_Facia : in Positive)
+   is
+   begin
+      raise Error with "opengl gemoetry textured - 'Indices_are' ~ TODO";
+   end Indices_are;
+
+
+   overriding
+   procedure enable_Texture (Self : in Item)
+   is
+      use GL,
+          GL.Binding,
+          openGL.Texture;
+   begin
+      Tasks.check;
+
+      glActiveTexture (gl.GL_TEXTURE0);
+      Errors.log;
+
+      if Self.Texture = openGL.Texture.null_Object
+      then   white_Texture.enable;
+      else   Self.Texture .enable;
+      end if;
+   end enable_Texture;
+
+
+end openGL.Geometry.textured;

3-mid/opengl/source/lean/geometry/opengl-geometry-textured.ads

@@ -0,0 +1,45 @@
+package openGL.Geometry.textured
+--
+--  Supports per-vertex site and texture.
+--
+is
+   type Item is new openGL.Geometry.item with private;
+   type View is access all Item'Class;
+
+   function new_Geometry return View;
+
+
+   ----------
+   --  Vertex
+   --
+   type Vertex is
+      record
+         Site   : Vector_3;
+         Coords : Coordinate_2D;
+      end record;
+
+   type Vertex_array is array (Index_t range <>) of aliased Vertex;
+
+
+   --------------
+   --  Attributes
+   --
+
+   overriding
+   function  is_Transparent (Self : in     Item) return Boolean;
+
+   procedure Vertices_are   (Self : in out Item;   Now       : in Vertex_array);
+
+   overriding
+   procedure Indices_are    (Self : in out Item;   Now       : in Indices;
+                                                   for_Facia : in Positive);
+
+
+private
+
+   type Item is new Geometry.item with null record;
+
+   overriding
+   procedure enable_Texture (Self : in Item);
+
+end openGL.Geometry.textured;

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

@@ -0,0 +1,510 @@
+with
+     openGL.Primitive.indexed,
+     openGL.Primitive.long_indexed,
+
+     ada.unchecked_Deallocation,
+     ada.unchecked_Conversion;
+
+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;
+
+
+
+   function Texture (Self : in Item'Class) return openGL.Texture.Object
+   is
+   begin
+      return Self.Texture;
+   end Texture;
+
+
+   procedure Texture_is (Self : in out Item'Class;   Now : in openGL.Texture.Object)
+   is
+   begin
+      Self.Texture        := Now;
+      Self.is_Transparent :=    Self.is_Transparent
+                             or Now .is_Transparent;
+   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.Texture.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;
+
+
+   ---------
+   -- 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;

3-mid/opengl/source/lean/geometry/opengl-geometry.ads

@@ -0,0 +1,113 @@
+with
+     openGL.Primitive,
+     openGL.Buffer,
+     openGL.Program,
+     openGL.Texture;
+
+private
+with
+     ada.Strings.unbounded;
+
+package openGL.Geometry
+--
+--  Provides a base class for openGL geometry.
+--  A Geometry is composed of up to 5 primitives.
+--  Each primitive has its own set of GL indices and a facet kind.
+--  All primitives share a common set of vertices.
+--  Subclasses may be created to provide for the various possible variants of an openGL vertex.
+--
+is
+   type    Item  is abstract tagged limited private;
+   subtype Class is Item'Class;
+
+   type    View  is access all Item'class;
+   type    Views is array (Index_t range <>) of View;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Label_is        (Self : in out Item'Class;   Now : in String);
+   function  Label           (Self : in     Item'Class)     return String;
+
+   procedure Texture_is      (Self : in out Item'Class;   Now : in Texture.Object);
+   function  Texture         (Self : in     Item'Class)     return Texture.Object;
+
+   procedure Bounds_are      (Self : in out Item'Class;   Now : in Bounds);
+   function  Bounds          (self : in     Item'Class)     return Bounds;   -- Returns the bounds in object space.
+
+   procedure is_Transparent  (Self : in out Item;         Now : in Boolean := True);
+   function  is_Transparent  (Self : in     Item)           return Boolean;
+
+   procedure Program_is      (Self : in out Item;         Now : in Program.view);
+   function  Program         (Self : in     Item)           return Program.view;
+
+   procedure add             (Self : in out Item'Class;   the_Primitive : in Primitive.view);
+   function  Primitives      (Self : in     Item'Class)     return Primitive.views;
+   procedure free_Primitives (Self : in out Item);
+
+   procedure Indices_are     (Self : in out Item;   Now       : in Indices;
+                                                    for_Facia : in Positive);
+   procedure Indices_are     (Self : in out Item;   Now       : in long_Indices;
+                                                    for_Facia : in Positive);
+
+   --------------
+   --  Operations
+   --
+
+   procedure render         (Self : in out Item'Class);
+   procedure enable_Texture (Self : in     Item) is null;
+
+
+   -----------
+   --  Normals
+   --
+
+   function Normals_of (face_Kind : in primitive.facet_Kind;
+                        Indices   : in openGL.Indices;
+                        Sites     : in openGL.Sites) return access Normals;
+
+   function Normals_of (face_Kind : in primitive.facet_Kind;
+                        Indices   : in openGL.long_Indices;
+                        Sites     : in openGL.Sites) return access Normals;
+
+
+private
+   use ada.Strings.unbounded;
+
+   type Item is abstract tagged limited
+      record
+         Label           : unbounded_String;
+         Texture         : openGL.Texture.Object := openGL.Texture.null_Object;
+
+         Program         : openGL.Program.view;
+         Vertices        : Buffer.view;
+
+         Primitives      : Primitive.views (1 .. 5);
+         primitive_Count : Index_t := 0;
+
+         is_Transparent  : Boolean := False;     -- Geometry contains lucid colors.
+         Bounds          : openGL.Bounds;
+      end record;
+
+
+   generic
+      type any_Index_t is range <>;
+      with function get_Site (Index : in any_Index_t) return Vector_3;
+   function get_Bounds (Count : in Natural) return openGL.Bounds;
+
+   generic
+      type any_Index_t is range <>;
+      with function get_Color (Index : in any_Index_t) return rgba_Color;
+   function get_Transparency (Count : in Natural) return Boolean;
+
+end openGL.Geometry;

3-mid/opengl/source/lean/geometry/opengl-primitive-indexed.adb

@@ -0,0 +1,148 @@
+with
+     openGL.Errors,
+     openGL.Buffer,
+     openGL.Tasks,
+
+     GL.Binding,
+     GL.lean;
+
+package body openGL.Primitive.indexed
+is
+   ---------
+   --- Forge
+   --
+
+   procedure define (Self : in out Item;   Kind       : in facet_Kind;
+                                           Indices    : in openGL.Indices;
+                                           line_Width : in Real)
+   is
+      use openGL.Buffer.indices.Forge;
+      buffer_Indices : aliased openGL.Indices := [Indices'Range => <>];
+
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Indices (Each) - 1;   -- Adjust indices to zero-based indexing for GL.
+      end loop;
+
+      Self.facet_Kind := Kind;
+      Self.Indices    := new Buffer.indices.Object' (to_Buffer (buffer_Indices'Access,
+                                                                usage => Buffer.static_Draw));
+      Self.line_Width := line_Width;
+   end define;
+
+
+
+   procedure define (Self : in out Item;   Kind       : in facet_Kind;
+                                           Indices    : in long_Indices;
+                                           line_Width : in Real)
+   is
+      use openGL.Buffer.indices.Forge;
+      buffer_Indices : aliased openGL.Indices := [Indices'Range => <>];
+
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Index_t (Indices (Each) - 1);   -- Adjust indices to zero-based indexing for GL.
+      end loop;
+
+      Self.facet_Kind := Kind;
+      Self.Indices    := new openGL.Buffer.indices.Object' (to_Buffer (buffer_Indices'Access,
+                                                                       usage => Buffer.static_Draw));
+      Self.line_Width := line_Width;
+   end define;
+
+
+
+   function new_Primitive (Kind       : in facet_Kind;
+                           Indices    : in openGL.Indices;
+                           line_Width : in Real := unused_line_Width) return Primitive.indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind, Indices, line_Width);
+      return Self;
+   end new_Primitive;
+
+
+
+   function new_Primitive (Kind       : in facet_Kind;
+                           Indices    : in long_Indices;
+                           line_Width : in Real               := unused_line_Width) return Primitive.indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind, Indices, line_Width);
+      return Self;
+   end new_Primitive;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      the_Indices : Buffer.view := Buffer.view (Self.Indices);
+   begin
+      Buffer.free (the_Indices);
+      Self.Indices := null;
+   end destroy;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Indices_are  (Self : in out Item;   Now : in Indices)
+   is
+      use Buffer.indices;
+      buffer_Indices : aliased Indices := [Now'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Now (Each) - 1;     -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.Indices.set (to => buffer_Indices);
+   end Indices_are;
+
+
+
+   procedure Indices_are  (Self : in out Item;   Now : in long_Indices)
+   is
+      use Buffer.indices;
+      buffer_Indices : aliased Indices := [Now'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Index_t (Now (Each) - 1);     -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.Indices.set (to => buffer_Indices);
+   end Indices_are;
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item)
+   is
+      use GL,
+          GL.Binding,
+          GL.lean;
+   begin
+      Tasks.check;
+
+      Primitive.item (Self).render;   -- Do base class render.
+      Self.Indices.enable;
+
+      glDrawElements (Thin     (Self.facet_Kind),
+                      gl.GLint (Self.Indices.Length),
+                      GL_UNSIGNED_SHORT,
+                      null);
+      Errors.log;
+   end render;
+
+
+end openGL.Primitive.indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-indexed.ads

@@ -0,0 +1,64 @@
+private
+with
+     openGL.Buffer.indices;
+
+package openGL.Primitive.indexed
+--
+--  Provides a class for indexed openGL primitives.
+--
+is
+   type    Item  is limited new Primitive.item with private;
+   subtype Class is Item'Class;
+
+   type    View  is access all Item'class;
+   type    Views is array (Index_t range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   function  new_Primitive (Kind       : in facet_Kind;
+                            Indices    : in openGL.Indices;
+                            line_Width : in Real := unused_line_Width) return Primitive.indexed.view;
+
+   function  new_Primitive (Kind       : in facet_Kind;
+                            Indices    : in openGL.long_Indices;
+                            line_Width : in Real := unused_line_Width) return Primitive.indexed.view;
+
+   procedure define  (Self : in out Item;   Kind       : in facet_Kind;
+                                            Indices    : in openGL.Indices;
+                                            line_Width : in Real);
+
+   procedure define  (Self : in out Item;   Kind       : in facet_Kind;
+                                            Indices    : in openGL.long_Indices;
+                                            line_Width : in Real);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Indices_are (Self : in out Item;   Now : in      Indices);
+   procedure Indices_are (Self : in out Item;   Now : in long_Indices);
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item);
+
+
+
+private
+
+   type Item is limited new Primitive.item with
+      record
+         Indices : Buffer.indices.view;
+      end record;
+
+end openGL.Primitive.indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-long_indexed.adb

@@ -0,0 +1,95 @@
+with
+     openGL.Errors,
+     openGL.Buffer,
+     openGL.Tasks,
+     GL.Binding,
+
+     ada.unchecked_Deallocation;
+
+package body openGL.Primitive.long_indexed
+is
+   ---------
+   --- Forge
+   --
+
+   procedure define (Self : in out Item;   Kind    : in facet_Kind;
+                                           Indices : in long_Indices)
+   is
+      use Buffer.long_indices.Forge;
+      buffer_Indices : aliased long_Indices := [Indices'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Indices (Each) - 1;     -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.facet_Kind := Kind;
+      Self.Indices    := new Buffer.long_indices.Object' (to_Buffer (buffer_Indices'Access,
+                                                                     usage => Buffer.static_Draw));
+   end define;
+
+
+
+   function new_Primitive (Kind    : in facet_Kind;
+                           Indices : in long_Indices) return Primitive.long_indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind, Indices);
+      return Self;
+   end new_Primitive;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      procedure free is new ada.unchecked_Deallocation (Buffer.long_indices.Object'Class,
+                                                        Buffer.long_indices.view);
+   begin
+      Buffer.destroy (Self.Indices.all);
+      free (Self.Indices);
+   end destroy;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Indices_are  (Self : in out Item;   Now : in long_Indices)
+   is
+      use Buffer.long_indices;
+      buffer_Indices : aliased long_Indices := [Now'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Now (Each) - 1;   -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.Indices.set (to => buffer_Indices);
+   end Indices_are;
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item)
+   is
+      use GL,
+          GL.Binding;
+   begin
+      Tasks.check;
+      openGL.Primitive.item (Self).render;   -- Do base class render.
+
+      Self.Indices.enable;
+      glDrawElements (Thin     (Self.facet_Kind),
+                      gl.GLint (Self.Indices.Length),
+                      GL_UNSIGNED_INT,
+                      null);
+      Errors.log;
+   end render;
+
+
+end openGL.Primitive.long_indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-long_indexed.ads

@@ -0,0 +1,53 @@
+private
+with
+     openGL.Buffer.long_indices;
+
+package openGL.Primitive.long_indexed
+--
+--  Provides a class for long indexed openGL primitives.
+--
+is
+   type    Item  is limited new Primitive.item with private;
+   subtype Class is Item'Class;
+
+   type    View  is access all Item'class;
+   type    Views is array (Index_t range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   function  new_Primitive (Kind    : in facet_Kind;
+                            Indices : in long_Indices) return Primitive.long_indexed.view;
+
+   procedure define  (Self : in out Item;   Kind    : in facet_Kind;
+                                            Indices : in long_Indices);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Indices_are (Self : in out Item;   Now : in long_Indices);
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item);
+
+
+
+private
+
+   type Item  is limited new Primitive.item with
+      record
+         Indices : Buffer.long_indices.view;
+      end record;
+
+end openGL.Primitive.long_indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-non_indexed.adb

@@ -0,0 +1,54 @@
+with
+     openGL.Errors,
+     openGL.Tasks,
+     GL.Binding;
+
+package body openGL.Primitive.non_indexed
+is
+   ---------
+   --  Forge
+   --
+
+   overriding
+   procedure define (Self : in out Item;   Kind : in facet_Kind)
+   is
+   begin
+      Self.facet_Kind := Kind;
+   end define;
+
+
+   function new_Primitive (Kind         : in facet_Kind;
+                           vertex_Count : in Natural) return Primitive.non_indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind);
+      Self.vertex_Count := vertex_Count;
+
+      return Self;
+   end new_Primitive;
+
+
+   overriding
+   procedure destroy (Self : in out Item) is null;
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item)
+   is
+      use GL,
+          GL.Binding;
+   begin
+      Tasks.check;
+      glDrawArrays (Thin (Self.facet_Kind),
+                    0,
+                    gl.GLint (Self.vertex_Count));
+      Errors.log;
+   end render;
+
+
+end openGL.Primitive.non_indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-non_indexed.ads

@@ -0,0 +1,42 @@
+package openGL.Primitive.non_indexed
+--
+--  Provides a class for non-indexed openGL primitives.
+--
+is
+   type    Item  is limited new Primitive.item with private;
+   subtype Class is Item'Class;
+
+   type    View  is access all Item'Class;
+   type    Views is array (Index_t range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   overriding
+   procedure define  (Self : in out Item;   Kind : in facet_Kind);
+
+   overriding
+   procedure destroy (Self : in out Item);
+
+   function  new_Primitive (Kind         : in facet_Kind;
+                            vertex_Count : in Natural) return Primitive.non_indexed.view;
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item);
+
+
+
+private
+
+   type Item  is limited new Primitive.item with
+      record
+         vertex_Count : Natural := 0;
+      end record;
+
+end openGL.Primitive.non_indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-short_indexed.adb

@@ -0,0 +1,185 @@
+with
+     openGL.Errors,
+     openGL.Buffer,
+     openGL.Tasks,
+     GL.Binding,
+
+     ada.unchecked_Deallocation;
+
+package body openGL.Primitive.short_indexed
+is
+   ---------
+   --- Forge
+   --
+
+   procedure define (Self : in out Item;   Kind    : in facet_Kind;
+                                           Indices : in short_Indices)
+   is
+      use Buffer.short_indices.Forge;
+      buffer_Indices : aliased short_Indices := [Indices'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Indices (Each) - 1;     -- Adjust indices to zero-based indexing for GL.
+      end loop;
+
+      Self.facet_Kind := Kind;
+      Self.Indices    := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
+                                                                      usage => Buffer.static_Draw));
+   end define;
+
+
+
+   procedure define (Self : in out Item;   Kind    : in facet_Kind;
+                                           Indices : in openGL.Indices)
+   is
+      use Buffer.short_indices.Forge;
+      buffer_Indices : aliased short_Indices := [Indices'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := short_Index_t (Indices (Each) - 1);     -- Adjust indices to zero-based indexing for GL.
+      end loop;
+
+      Self.facet_Kind := Kind;
+      Self.Indices    := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
+                                                                      usage => Buffer.static_Draw));
+   end define;
+
+
+
+   procedure define (Self : in out Item;   Kind    : in facet_Kind;
+                                           Indices : in long_Indices)
+   is
+      use Buffer.short_indices.Forge;
+      buffer_Indices : aliased short_indices := [Indices'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := short_Index_t (Indices (Each) - 1);     -- Adjust indices to zero-based indexing for GL.
+      end loop;
+
+      Self.facet_Kind := Kind;
+      Self.Indices    := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
+                                                                      usage => Buffer.static_Draw));
+   end define;
+
+
+
+   function new_Primitive (Kind    : in facet_Kind;
+                           Indices : in short_Indices) return Primitive.short_indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind, Indices);
+      return Self;
+   end new_Primitive;
+
+
+
+   function new_Primitive (Kind    : in facet_Kind;
+                           Indices : in openGL.Indices) return Primitive.short_indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind, Indices);
+      return Self;
+   end new_Primitive;
+
+
+
+   function new_Primitive (Kind    : in facet_Kind;
+                           Indices : in openGL.long_Indices) return Primitive.short_indexed.view
+   is
+      Self : constant View := new Item;
+   begin
+      define (Self.all, Kind, Indices);
+      return Self;
+   end new_Primitive;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      procedure free is new ada.unchecked_Deallocation (Buffer.short_Indices.Object'Class,
+                                                        Buffer.short_Indices.view);
+   begin
+      Buffer.destroy (Self.Indices.all);
+      free (Self.Indices);
+   end destroy;
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Indices_are (Self : in out Item;   Now : in short_Indices)
+   is
+      use Buffer.short_indices;
+      buffer_Indices : aliased short_Indices := [Now'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := Now (Each) - 1;     -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.Indices.set (to => buffer_Indices);
+   end Indices_are;
+
+
+
+   procedure Indices_are (Self : in out Item;   Now : in Indices)
+   is
+      use Buffer.short_indices;
+      buffer_Indices : aliased short_Indices := [Now'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := short_Index_t (Now (Each) - 1);     -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.Indices.set (to => buffer_Indices);
+   end Indices_are;
+
+
+
+   procedure Indices_are (Self : in out Item;   Now : in  long_Indices)
+   is
+      use Buffer.short_indices;
+      buffer_Indices : aliased short_Indices := [Now'Range => <>];
+   begin
+      for Each in buffer_Indices'Range
+      loop
+         buffer_Indices (Each) := short_Index_t (Now (Each) - 1);     -- Adjust indices to zero-based-indexing for GL.
+      end loop;
+
+      Self.Indices.set (to => buffer_Indices);
+   end Indices_are;
+
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item)
+   is
+      use GL,
+          GL.Binding;
+   begin
+      Tasks.check;
+
+      openGL.Primitive.item (Self).render;   -- Do base class render.
+      Self.Indices.enable;
+
+      glDrawElements (Thin     (Self.facet_Kind),
+                      gl.GLint (Self.Indices.Length),
+                      GL_UNSIGNED_BYTE,
+                      null);
+      Errors.log;
+   end render;
+
+
+end openGL.Primitive.short_indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive-short_indexed.ads

@@ -0,0 +1,65 @@
+private
+with
+     openGL.Buffer.short_indices;
+
+package openGL.Primitive.short_indexed
+--
+--  Provides a class for short indexed openGL primitives.
+--
+is
+   type    Item  is limited new Primitive.item with private;
+   subtype Class is Item'Class;
+
+   type    View  is access all Item'Class;
+   type    Views is array (Index_t range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   function  new_Primitive (Kind    : in facet_Kind;
+                            Indices : in openGL.short_Indices) return Primitive.short_indexed.view;
+
+   function  new_Primitive (Kind    : in facet_Kind;
+                            Indices : in openGL.Indices)       return Primitive.short_indexed.view;
+
+   function  new_Primitive (Kind    : in facet_Kind;
+                            Indices : in openGL.long_Indices)  return Primitive.short_indexed.view;
+
+   procedure define  (Self : in out Item;   Kind    : in facet_Kind;
+                                            Indices : in openGL.short_Indices);
+   procedure define  (Self : in out Item;   Kind    : in facet_Kind;
+                                            Indices : in openGL.Indices);
+   procedure define  (Self : in out Item;   Kind    : in facet_Kind;
+                                            Indices : in openGL.long_Indices);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --  Attributes
+   --
+
+   procedure Indices_are (Self : in out Item;   Now : in short_Indices);
+   procedure Indices_are (Self : in out Item;   Now : in       Indices);
+   procedure Indices_are (Self : in out Item;   Now : in  long_Indices);
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure render (Self : in out Item);
+
+
+
+private
+
+   type Item  is limited new Primitive.item with
+      record
+         Indices : Buffer.short_indices.view;
+      end record;
+
+end openGL.Primitive.short_indexed;

3-mid/opengl/source/lean/geometry/opengl-primitive.adb

@@ -0,0 +1,95 @@
+with
+     openGL.Tasks,
+     GL.Binding,
+     ada.unchecked_Deallocation;
+
+package body openGL.Primitive
+is
+   ---------
+   --  Forge
+   --
+
+   procedure define (Self : in out Item;   Kind : in facet_Kind)
+   is
+   begin
+      Self.facet_Kind := Kind;
+   end define;
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.Unchecked_Deallocation (Primitive.item'Class,
+                                                              Primitive.view);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+   --------------
+   --  Attributes
+   --
+
+   function Texture (Self : in Item) return openGL.Texture.Object
+   is
+   begin
+      return Self.Texture;
+   end Texture;
+
+
+   procedure Texture_is (Self : in out Item;   Now : in openGL.Texture.Object)
+   is
+   begin
+      Self.Texture := Now;
+   end Texture_is;
+
+
+
+   function Bounds (self : in Item) return openGL.Bounds
+   is
+   begin
+      return Self.Bounds;
+   end Bounds;
+
+
+   procedure Bounds_are (Self : in out Item;   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;
+   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 render (Self : in out Item)
+   is
+      use GL,
+          GL.Binding;
+   begin
+      Tasks.check;
+
+      if Self.line_Width /= unused_line_Width
+      then
+         glLineWidth (glFloat (Self.line_Width));
+      end if;
+   end render;
+
+
+end openGL.Primitive;

3-mid/opengl/source/lean/geometry/opengl-primitive.ads

@@ -0,0 +1,96 @@
+with
+     openGL.Texture;
+
+private
+with
+     ada.unchecked_Conversion;
+
+package openGL.Primitive
+--
+--  Provides a base class for openGL primitives.
+--
+is
+   type    Item  is abstract tagged limited private;
+   subtype Class is Item'Class;
+
+   type    View  is access all Item'class;
+   type    Views is array (Index_t range <>) of View;
+
+
+   ----------
+   --  Facets
+   --
+   type facet_Kind is (Points,
+                       Lines,     line_Loop,      line_Strip,
+                       Triangles, triangle_Strip, triangle_Fan);
+
+   ---------
+   --  Forge
+   --
+
+   procedure define  (Self : in out Item;   Kind    : in facet_Kind);
+   procedure destroy (Self : in out Item) is abstract;
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --  Attributes
+   --
+
+   function  Texture        (Self : in     Item)     return openGL.Texture.Object;
+   procedure Texture_is     (Self : in out Item;   Now : in openGL.Texture.Object);
+
+   procedure Bounds_are     (Self : in out Item;   Now : in openGL.Bounds);
+   function  Bounds         (self : in     Item)     return openGL.Bounds;
+   --
+   -- Returns the bounds in object space.
+
+   procedure is_Transparent (Self : in out Item;   Now : in Boolean := True);
+   function  is_Transparent (Self : in     Item)     return Boolean;
+
+
+   ---------------
+   --- Operations
+   --
+
+   procedure render (Self : in out Item);
+
+   unused_line_Width : constant := -1.0;
+
+
+
+private
+
+   type Item is abstract tagged limited
+      record
+         facet_Kind     : primitive.facet_Kind;
+         Texture        : openGL.Texture.Object := openGL.Texture.null_Object;
+         is_Transparent : Boolean;
+         Bounds         : openGL.Bounds;
+         line_Width     : Real := unused_line_Width;
+      end record;
+
+
+   ----------
+   --  Facets
+   --
+
+   function Thin (Self : in facet_Kind) return gl.GLenum;
+
+   for facet_Kind use (Points         => gl.GL_POINTS,
+                       Lines          => gl.GL_LINES,
+                       line_Loop      => gl.GL_LINE_LOOP,
+                       line_Strip     => gl.GL_LINE_STRIP,
+                       Triangles      => gl.GL_TRIANGLES,
+                       triangle_Strip => gl.GL_TRIANGLE_STRIP,
+                       triangle_Fan   => gl.GL_TRIANGLE_FAN);
+
+   for facet_Kind'Size use gl.GLenum'Size;
+
+   function Convert is new ada.Unchecked_Conversion (facet_Kind, gl.GLenum);
+
+   function Thin (Self : in facet_Kind) return gl.GLenum
+                  renames Convert;
+
+
+end openGL.Primitive;

3-mid/opengl/source/lean/io/opengl-io-collada.adb

@@ -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;

3-mid/opengl/source/lean/io/opengl-io-collada.ads

@@ -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;

3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.adb

@@ -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;

3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.ads

@@ -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;

3-mid/opengl/source/lean/io/opengl-io-wavefront.adb

@@ -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;

3-mid/opengl/source/lean/io/opengl-io-wavefront.ads

@@ -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;

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

@@ -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;

3-mid/opengl/source/lean/io/opengl-io.ads

@@ -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;

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

@@ -0,0 +1,133 @@
+package body openGL.Light
+is
+
+   function Id (Self : in Item) return light.Id_t
+   is
+   begin
+      return Self.Id;
+   end Id;
+
+
+   procedure Id_is (Self : in out Item;   Now : in light.Id_t)
+   is
+   begin
+      Self.Id := Now;
+   end Id_is;
+
+
+   function Kind (Self : in Item) return light.Kind_t
+   is
+   begin
+      return Self.Kind;
+   end Kind;
+
+
+   procedure Kind_is (Self : in out Item;   Now : in light.Kind_t)
+   is
+   begin
+      Self.Kind := Now;
+   end Kind_is;
+
+
+   function is_On (Self : in Item) return Boolean
+   is
+   begin
+      return Self.On;
+   end is_On;
+
+
+   procedure is_On (Self : in out Item;   Now : in Boolean := True)
+   is
+   begin
+      Self.On := Now;
+   end is_On;
+
+
+
+   function Site (Self : in Item) return openGL.Site
+   is
+   begin
+      return Self.Site;
+   end Site;
+
+
+   procedure Site_is (Self : in out Item;   Now : in openGL.Site)
+   is
+   begin
+      Self.Site := Now;
+   end Site_is;
+
+
+   function Color (Self : in Item) return openGL.Color
+   is
+   begin
+      return Self.Color;
+   end Color;
+
+
+   function Attenuation (Self : in Item) return Real
+   is
+   begin
+      return Self.Attenuation;
+   end Attenuation;
+
+
+   function ambient_Coefficient (Self : in Item) return Real
+   is
+   begin
+      return Self.ambient_Coefficient;
+   end ambient_Coefficient;
+
+
+   function cone_Angle (Self : in Item) return Degrees
+   is
+   begin
+      return Self.cone_Angle;
+   end cone_Angle;
+
+
+   function cone_Direction (Self : in Item) return Vector_3
+   is
+   begin
+      return Self.cone_Direction;
+   end cone_Direction;
+
+
+
+   procedure Color_is (Self : in out Item;   Now : in openGL.Color)
+   is
+   begin
+      Self.Color := Now;
+   end Color_is;
+
+
+   procedure Attenuation_is (Self : in out Item;   Now : in Real)
+   is
+   begin
+      Self.Attenuation := Now;
+   end Attenuation_is;
+
+
+   procedure ambient_Coefficient_is (Self : in out Item;   Now : in Real)
+   is
+   begin
+      Self.ambient_Coefficient := Now;
+   end ambient_Coefficient_is;
+
+
+
+   procedure cone_Angle_is (Self : in out Item;   Now : in Degrees)
+   is
+   begin
+      Self.cone_Angle := Now;
+   end cone_Angle_is;
+
+
+   procedure cone_Direction_is (Self : in out Item;   Now : in Vector_3)
+   is
+   begin
+      Self.cone_Direction := Now;
+   end cone_Direction_is;
+
+
+end openGL.Light;

3-mid/opengl/source/lean/light/opengl-light.ads

@@ -0,0 +1,66 @@
+with
+     openGL.Palette;
+
+
+package openGL.Light
+--
+--  Models a light.
+--
+is
+   type Item  is tagged private;
+   type Items is array (Positive range <>) of Item;
+
+
+   --------------
+   --- Attributes
+   --
+   type Id_t   is new Natural;
+   type Kind_t is (Diffuse, Direct);
+
+   null_Id : constant Id_t;
+
+   function  Id      (Self : in     Item)     return light.Id_t;
+   procedure Id_is   (Self : in out Item;   Now : in light.Id_t);
+
+   function  Kind    (Self : in     Item)     return light.Kind_t;
+   procedure Kind_is (Self : in out Item;   Now : in light.Kind_t);
+
+   function  is_On   (Self : in     Item)     return Boolean;
+   procedure is_On   (Self : in out Item;   Now : in Boolean := True);
+
+   function  Site    (Self : in     Item)     return openGL.Site;
+   procedure Site_is (Self : in out Item;   Now : in openGL.Site);
+
+   function  Color               (Self : in     Item) return Color;
+   function  Attenuation         (Self : in     Item) return Real;
+   function  ambient_Coefficient (Self : in     Item) return Real;
+   function  cone_Angle          (Self : in     Item) return Degrees;
+   function  cone_Direction      (Self : in     Item) return Vector_3;
+
+   procedure Color_is               (Self : in out Item;   Now : in openGL.Color);
+   procedure Attenuation_is         (Self : in out Item;   Now : in Real);
+   procedure ambient_Coefficient_is (Self : in out Item;   Now : in Real);
+   procedure cone_Angle_is          (Self : in out Item;   Now : in Degrees);
+   procedure cone_Direction_is      (Self : in out Item;   Now : in Vector_3);
+
+
+
+private
+
+   null_Id : constant Id_t := Id_t'First;
+
+   type Item is tagged
+      record
+         Id   : light.Id_t   := null_Id;
+         Kind : light.Kind_t := Direct;
+         On   : Boolean      := True;
+         Site : openGL.Site  := [0.0, 0.0, 1.0];     -- The GL default.
+
+         Color               : openGL.Color := Palette.White;
+         Attenuation         : Real         :=  0.1;
+         ambient_Coefficient : Real         :=  0.1;
+         cone_Angle          : Degrees      :=  2.0;
+         cone_Direction      : Vector_3     := [0.0, 0.0, -1.0];
+      end record;
+
+end openGL.Light;

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

@@ -0,0 +1,495 @@
+with
+     openGL.Primitive.short_indexed,
+     openGL.Primitive.      indexed,
+     openGL.Primitive.long_indexed,
+
+     openGL.Geometry.lit_textured,
+     openGL.Geometry.lit_colored_textured_skinned,
+
+     openGL.Texture,
+     openGL.Palette,
+
+     openGL.IO.wavefront,
+     openGL.IO.collada,
+     openGL.IO.lat_long_Radius,
+
+     ada.Strings.fixed,
+     ada.Containers.hashed_Maps,
+
+     ada.unchecked_Deallocation;
+
+
+package body openGL.Model.any
+is
+
+   type lit_textured_skinned_Geometry_view is access all openGL.Geometry.lit_colored_textured_skinned.item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function to_Model (Model            : in asset_Name;
+                      Texture          : in asset_Name;
+                      Texture_is_lucid : in Boolean) return openGL.Model.any.item
+   is
+   begin
+      return Self : openGL.Model.any.item := (openGL.Model.item with
+                                              Model,
+                                              Texture,
+                                              Texture_is_lucid,
+                                              Geometry => null)
+      do
+         Self.Bounds.Ball := 1.0;
+      end return;
+   end to_Model;
+
+
+   function new_Model (Model            : in asset_Name;
+                       Texture          : in asset_Name;
+                       Texture_is_lucid : in Boolean) return openGL.Model.any.view
+   is
+   begin
+      return new openGL.Model.any.item' (to_Model (Model, Texture, Texture_is_lucid));
+   end new_Model;
+
+
+   --------------
+   --- Attributes
+   --
+
+   function model_Name (Self : in Item) return asset_Name
+   is
+   begin
+      return Self.Model;
+   end model_Name;
+
+
+   use openGL.IO;
+
+   function Hash (Self : in io.Vertex) return ada.Containers.Hash_type
+   is
+   begin
+      return ada.Containers.Hash_type (Self.site_Id + 3 * Self.coord_Id + 5 * Self.normal_Id + 7 * Self.weights_Id);
+   end Hash;
+
+   package io_vertex_Maps_of_gl_vertex_id is new ada.containers.Hashed_Maps (io.Vertex,
+                                                                             long_Index_t,
+                                                                             Hash,
+                                                                             "=");
+   subtype io_vertex_Map_of_gl_vertex_id is io_vertex_Maps_of_gl_vertex_id.Map;
+
+   type any_Vertex is
+      record
+         Site   : Vector_3;
+         Normal : Vector_3;
+         Coords : Coordinate_2D;
+         Shine  : Real;
+         Bones  : bone_Weights (1 .. 4);
+      end record;
+
+   type any_Vertex_array      is array (long_Index_t range <>) of aliased any_Vertex;
+   type any_Vertex_array_view is access all any_Vertex_array;
+
+   procedure deallocate is new ada.unchecked_Deallocation (any_Vertex_array,
+                                                           any_Vertex_array_view);
+
+
+   function to_lit_textured_Vertices (From : in any_Vertex_array) return Geometry.lit_textured.Vertex_large_array
+   is
+      Result : Geometry.lit_textured.Vertex_large_array (From'Range);
+   begin
+      for i in From'Range
+      loop
+         Result (i) := (Site   => From (i).Site,
+                        Normal => From (i).Normal,
+                        Coords => From (i).Coords,
+                        Shine  => From (i).Shine);
+      end loop;
+
+      return Result;
+   end to_lit_textured_Vertices;
+
+
+
+   function to_lit_textured_skinned_Vertices (From : in any_Vertex_array) return Geometry.lit_colored_textured_skinned.Vertex_array
+   is
+      use Palette;
+      Result : Geometry.lit_colored_textured_skinned.Vertex_array (From'Range);
+   begin
+      for i in From'Range
+      loop
+         Result (i) := (Site         => From (i).Site,
+                        Normal       => From (i).Normal,
+                        Coords       => From (i).Coords,
+                        Shine        => From (i).Shine,
+                        Color        => (+White, opaque_Value),
+                        bone_Ids     => [1 => Real (From (i).Bones (1).Bone),
+                                         2 => Real (From (i).Bones (2).Bone),
+                                         3 => Real (From (i).Bones (3).Bone),
+                                         4 => Real (From (i).Bones (4).Bone)],
+                        bone_Weights => [1 =>       From (i).Bones (1).Weight,
+                                         2 =>       From (i).Bones (2).Weight,
+                                         3 =>       From (i).Bones (3).Weight,
+                                         4 =>       From (i).Bones (4).Weight]);
+      end loop;
+
+      return Result;
+   end to_lit_textured_skinned_Vertices;
+
+
+
+   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 (Textures, Fonts);
+   begin
+      Self.build_GL_Geometries;
+      return [1 => Self.Geometry];
+   end to_GL_Geometries;
+
+
+
+   procedure build_GL_Geometries (Self : in out Item)
+   is
+      use Geometry;
+
+      model_Name : constant String := to_String (Self.Model);
+
+      function load_Model return io.Model
+      is
+         use ada.Strings.fixed;
+      begin
+         if    Tail (model_Name, 4) = ".obj" then   return wavefront      .to_Model (model_Name);
+         elsif Tail (model_Name, 4) = ".dae" then   return collada        .to_Model (model_Name);
+         elsif Tail (model_Name, 4) = ".tab" then   return lat_long_Radius.to_Model (model_Name);
+         else                                       raise  unsupported_model_Format with "Model => '" & model_Name & "'";
+         end if;
+      end load_Model;
+
+      the_Model     : openGL.io.Model := load_Model;
+      the_Map       : io_vertex_Map_of_gl_vertex_id;
+
+      the_Vertices  : any_Vertex_array_view := new any_Vertex_array' (1 .. 100_000 => <>);
+      vertex_Count  : openGL.long_Index_t   := 0;
+
+      tri_Count     : Index_t := 0;
+      Normals_known : Boolean := False;
+
+      --  TODO: Use one set of gl face vertices and 2 sets of indices (1 for tris and 1 for quads).
+
+   begin
+      Self.Bounds := null_Bounds;
+
+      --  1st pass: - Set our openGL face vertices.
+      --            - Build 'io vertex' to 'openGL face vertex_Id' map.
+      --
+      for f in the_Model.Faces'Range
+      loop
+         declare
+            use io_vertex_Maps_of_gl_vertex_id;
+
+            the_model_Face : io.Face renames the_Model.Faces (f);
+
+         begin
+            if    the_model_Face.Kind = Triangle
+               or the_model_Face.Kind = Quad
+            then
+               declare
+                  the_io_Vertices : constant io.Vertices := Vertices_of (the_model_Face);
+                  Cursor          :          io_vertex_Maps_of_gl_vertex_id.Cursor;
+               begin
+                  case the_model_Face.Kind
+                  is
+                     when Triangle =>   tri_Count := tri_Count + 1;
+                     when Quad     =>   tri_Count := tri_Count + 2;
+                     when Polygon  =>   null;
+                  end case;
+
+                  for v in the_io_Vertices'Range
+                  loop
+                     Cursor := the_Map.find (the_io_Vertices (v));
+
+                     if not has_Element (Cursor)
+                     then   -- We do not know about this vertex yet, so add it.
+                        vertex_Count := vertex_Count + 1;
+
+                        declare
+                           the_io_Vertex :  io.Vertex renames the_io_Vertices (v);
+                           the_gl_Vertex : any_Vertex renames the_Vertices (vertex_Count);
+                        begin
+                           the_gl_Vertex.Site := the_Model.Sites (the_io_Vertex.site_Id);
+
+                           Self.Bounds.Box  := Self.Bounds.Box or the_gl_Vertex.Site;
+                           Self.Bounds.Ball := Real'Max (Self.Bounds.Ball,
+                                                         abs (the_gl_Vertex.Site));
+
+                           if the_io_Vertex.coord_Id /= null_Id
+                           then   the_gl_Vertex.Coords := the_Model.Coords (the_io_Vertex.coord_Id);
+                           else   the_gl_Vertex.Coords := (0.0, 0.0);
+                           end if;
+
+                           if the_io_Vertex.normal_Id /= null_Id
+                           then   the_gl_Vertex.Normal := the_Model.Normals (the_io_Vertex.normal_Id);
+                                  the_gl_Vertex.Shine  := default_Shine;
+                                  normals_Known        := True;
+                           else   the_gl_Vertex.Normal := [0.0, 0.0, 0.0];
+                           end if;
+
+                           if    the_Model.Weights        /= null
+                             and the_io_Vertex.weights_Id /= null_Id
+                           then
+                              declare
+                                 the_Weights : bone_Weights renames the_Model.Weights (the_io_Vertex.weights_Id).all;
+                              begin
+                                 if the_Weights'Length > 0
+                                 then
+                                    the_gl_Vertex.Bones (1) := the_Weights (1);
+                                    --
+                                    --  nb: Only using the first 4 bones atm.
+
+                                    if the_Weights'Length >= 2
+                                    then   the_gl_Vertex.Bones (2) := the_Weights (2);
+                                    else   the_gl_Vertex.Bones (2) := (0, 0.0);
+                                    end if;
+
+                                    if the_Weights'Length >= 3
+                                    then   the_gl_Vertex.Bones (3) := the_Weights (3);
+                                    else   the_gl_Vertex.Bones (3) := (0, 0.0);
+                                    end if;
+
+                                    if the_Weights'Length >= 4
+                                    then   the_gl_Vertex.Bones (4) := the_Weights (4);
+                                    else   the_gl_Vertex.Bones (4) := (0, 0.0);
+                                    end if;
+
+                                 else
+                                    the_gl_Vertex.Bones := [1 => (0, 0.0),
+                                                            2 => (0, 0.0),
+                                                            3 => (0, 0.0),
+                                                            4 => (0, 0.0)];
+                                 end if;
+                              end;
+
+                           else
+                              the_gl_Vertex.Bones := [1 => (0, 0.0),
+                                                      2 => (0, 0.0),
+                                                      3 => (0, 0.0),
+                                                      4 => (0, 0.0)];
+                           end if;
+
+                           the_Map.insert (the_io_Vertex, vertex_Count);   --  'vertex_Count' provides the index of the current vertex.
+                        end;
+                     end if;
+
+                  end loop;
+               end;
+
+            end if;
+         end;
+      end loop;
+
+      --  We now have our gl face vertices built and mapped to each model vertex.
+
+
+      --  2nd pass: - Set the triangle faceted indices.
+      --            - Set the quad     faceted indices.
+      --
+      declare
+         tri_indices_Count :          long_Index_t := 0;
+         tri_indices_Last  : constant long_Index_t := long_Index_t (tri_Count) * 3;
+         tri_Indices       : aliased  long_Indices (1 .. tri_indices_Last);
+
+         procedure add_to_Tri (the_Vertex : in io.Vertex)
+         is
+         begin
+            tri_indices_Count               := tri_indices_Count + 1;
+            tri_Indices (tri_indices_Count) := the_Map.Element (the_Vertex);
+         end add_to_Tri;
+
+      begin
+         for f in the_Model.Faces'Range
+         loop
+            declare
+               the_model_Face  :          io.Face     renames the_Model.Faces (f);
+               the_io_Vertices : constant io.Vertices :=      Vertices_of (the_model_Face);
+            begin
+               case the_model_Face.Kind
+               is
+                  when Triangle =>
+                     for v in the_io_Vertices'Range
+                     loop
+                        add_to_Tri (the_io_Vertices (v));
+                     end loop;
+
+                  when Quad     =>
+                     add_to_Tri (the_io_Vertices (1));
+                     add_to_Tri (the_io_Vertices (2));
+                     add_to_Tri (the_io_Vertices (3));
+
+                     add_to_Tri (the_io_Vertices (3));
+                     add_to_Tri (the_io_Vertices (4));
+                     add_to_Tri (the_io_Vertices (1));
+
+                  when Polygon  =>
+                     null;
+               end case;
+            end;
+         end loop;
+
+         pragma assert (tri_indices_Count = tri_indices_Last);
+
+
+         --  Determine which geometry class is required and create the geometry.
+         --
+         if the_Model.Weights = null
+         then
+            declare
+               use Geometry.lit_textured;
+
+               my_Vertices : aliased  lit_textured.Vertex_large_array
+                 := to_lit_textured_Vertices (the_Vertices (1 .. vertex_Count));
+
+               my_Geometry : constant Geometry.lit_textured.view
+                 := lit_textured.new_Geometry;
+            begin
+               if not normals_Known
+               then
+                  set_Normals:
+                  declare
+                     type Normals_view is access all Normals;
+
+                     function get_Sites return Sites
+                     is
+                        Result : Sites := [1 .. my_Vertices'Length => <>];
+                     begin
+                        for i in Result'Range
+                        loop
+                           Result (i) := my_Vertices (long_Index_t (i)).Site;
+                        end loop;
+
+                        return Result;
+                     end get_Sites;
+
+                     the_Sites   : constant openGL.Sites := get_Sites;
+                     the_Normals :          Normals_view := Geometry.Normals_of (Primitive.Triangles,
+                                                                                 tri_Indices,
+                                                                                 the_Sites);
+                     procedure deallocate is new ada.unchecked_Deallocation (Normals, Normals_view);
+
+                  begin
+                     for i in my_Vertices'Range
+                     loop
+                        my_Vertices (i).Normal := the_Normals (Index_t (i));
+                        my_Vertices (i).Shine  := default_Shine;
+                     end loop;
+
+                     deallocate (the_Normals);
+                  end set_Normals;
+               end if;
+
+               my_Geometry.Vertices_are (now => my_Vertices);
+               Self.Geometry := Geometry.view (my_Geometry);
+            end;
+
+         else   -- Is skinned.
+            declare
+               use Geometry.lit_colored_textured_skinned;
+
+               my_Vertices : aliased constant lit_colored_textured_skinned.Vertex_array
+                 := to_lit_textured_skinned_Vertices (the_Vertices (1 .. vertex_Count));
+
+               my_Geometry : constant lit_textured_skinned_Geometry_view
+                 := lit_colored_textured_skinned.new_Geometry;
+            begin
+               my_Geometry.Vertices_are (now => my_Vertices);
+               Self.Geometry := Geometry.view (my_Geometry);
+            end;
+         end if;
+
+         deallocate (the_Vertices);
+         destroy    (the_Model);
+
+         --  Set the geometry texture.
+         --
+         if Self.Texture /= null_Asset
+         then
+            if Self.has_lucid_Texture
+            then
+               declare
+                  use Texture;
+                  the_Image   : constant lucid_Image
+                    := io.to_lucid_Image (Self.Texture);
+
+                  the_Texture : constant Texture.object
+                    := Forge.to_Texture (the_Image);
+
+               begin
+                  Self.Geometry.Texture_is (the_Texture);
+               end;
+            else
+               declare
+                  use Texture;
+                  the_Image   : constant Image          := io.to_Image (Self.Texture);
+                  the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+               begin
+                  Self.Geometry.Texture_is (the_Texture);
+               end;
+            end if;
+         end if;
+
+         --  Add any facia to the geometry.
+         --
+         if tri_Indices'Length > 0
+         then
+            if vertex_Count <= long_Index_t (short_Index_t'Last)
+            then
+               declare
+                  the_Primitive : constant Primitive.short_indexed.view
+                    := Primitive.short_indexed.new_Primitive (Primitive.Triangles,
+                                                              tri_Indices);
+               begin
+                  Self.Geometry.add (Primitive.view (the_Primitive));
+               end;
+
+            elsif vertex_Count <= long_Index_t (Index_t'Last)
+            then
+               declare
+                  the_Primitive : constant Primitive.indexed.view
+                    := Primitive.indexed.new_Primitive (primitive.Triangles,
+                                                        tri_Indices);
+               begin
+                  Self.Geometry.add (Primitive.view (the_Primitive));
+               end;
+
+            else
+               if openGL.Profile /= Desk
+               then
+                  raise Model_too_complex with "Only the 'Desk' openGL profile allows models with more than 2**16 - 1 vertices.";
+               end if;
+
+               declare
+                  the_Primitive : constant Primitive.long_indexed.view
+                    := Primitive.long_indexed.new_Primitive (primitive.Triangles,
+                                                             tri_Indices);
+               begin
+                  Self.Geometry.add (Primitive.view (the_Primitive));
+               end;
+            end if;
+         end if;
+
+
+         if Geometry_3d.Extent (Self.Bounds.Box, 3) = 0.0
+         then
+            Self.Bounds.Box.Lower (3) := Self.Bounds.Box.Lower (3) - 0.2;     -- TODO: This is dubious at best.
+         end if;
+
+         Self.Geometry.is_Transparent (now => False);
+         Self.Geometry.Label_is (to_String (Self.Model) & "-" & to_String (Self.Texture));
+      end;
+
+   end build_GL_Geometries;
+
+
+end openGL.Model.any;

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

@@ -0,0 +1,58 @@
+with
+     openGL.Geometry;
+
+
+package openGL.Model.any
+--
+--  Provides a general 3D model.
+--
+--  This model is largely used by the IO importers of various model formats (ie collada, wavefront, etc).
+--
+is
+   type Item is new Model.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Model (Model            : in asset_Name;
+                       Texture          : in asset_Name;
+                       Texture_is_lucid : in Boolean) return openGL.Model.any.view;
+
+   --------------
+   --- Attributes
+   --
+
+   function model_Name (Self : in Item) return asset_Name;
+
+   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;
+   --
+   --  Raises unsupported_model_Format when the model is not a :
+   --     - wavefront       '.obj'
+   --     - collada         '.dae'
+   --     - lat_long_radius '.tab'
+
+   unsupported_model_Format : exception;
+
+
+
+private
+
+   type Item is new Model.item with
+      record
+         Model             : asset_Name := null_Asset;   -- A wavefront '.obj' or collada '.dae' file.   -- TODO: Rename to 'model_Name'.
+
+         Texture           : asset_Name := null_Asset;   -- The models texture image.
+         has_lucid_Texture : Boolean    := False;
+
+         Geometry          : openGL.Geometry.view;
+      end record;
+
+   procedure build_GL_Geometries (Self : in out Item);
+
+
+end openGL.Model.any;

3-mid/opengl/source/lean/model/opengl-model-arrow-colored.adb

@@ -0,0 +1,162 @@
+with
+     openGL.Primitive.indexed;
+
+package body openGL.Model.arrow.colored
+is
+   ---------
+   --- Forge
+   --
+
+   function to_Arrow (Color      : in openGL.Color := Palette.White;
+                      line_Width : in Real         := 1.0;
+                      End_1,
+                      End_2      : in Vector_3     := Origin_3D) return Item
+   is
+      Self : Model.arrow.colored.item;
+   begin
+      Self.Color      := Color;
+      Self.line_Width := line_Width;
+
+      Self.Vertices (1).Site := End_1;   -- Main line.
+      Self.Vertices (2).Site := End_2;   --
+
+      Self.Vertices (3).Site := End_2;   -- Side bits.
+      Self.Vertices (4).Site := End_2;   --
+
+      Self.set_side_Bits;
+
+      return Self;
+   end to_Arrow;
+
+
+   function new_Arrow (Color      : in openGL.Color := Palette.White;
+                       line_Width : in Real         := 1.0;
+                       End_1,
+                       End_2      : in Vector_3     := Origin_3D) return View
+   is
+   begin
+      return new Arrow.colored.item' (to_Arrow (Color, line_Width, End_1, End_2));
+   end new_Arrow;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use openGL.Geometry.colored;
+
+      Color         : constant openGL.rgb_Color := +Self.Color;
+      indices_Count : constant long_Index_t     := 2;
+      the_Indices   : aliased  Indices          := [1 .. indices_Count => <>];
+      the_Primitive :          Primitive.indexed.view;
+   begin
+      Geometry.free (Self.Geometry);
+      Self.Geometry := Geometry.colored.new_Geometry;
+
+      set_Colors:
+      begin
+         Self.Vertices (1).Color := (primary => Color,  Alpha => opaque_Value);
+         Self.Vertices (2).Color := (primary => Color,  Alpha => opaque_Value);
+         Self.Vertices (3).Color := (primary => Color,  Alpha => opaque_Value);
+         Self.Vertices (4).Color := (primary => Color,  Alpha => opaque_Value);
+      end set_Colors;
+
+      Self.Geometry.is_Transparent (False);
+      Self.Geometry.Vertices_are   (Self.Vertices);
+
+      -- Main line.
+      --
+      Self.Geometry.free_Primitives;
+
+      the_Indices   := [1, 2];
+      the_Primitive := Primitive.indexed.new_Primitive (Primitive.Lines, the_Indices, line_Width => Self.line_Width);
+      Self.Geometry.add (Primitive.view (the_Primitive));
+
+      -- Left bit.
+      --
+      the_Indices   := [2, 3];
+      the_Primitive := Primitive.indexed.new_Primitive (Primitive.Lines, the_Indices, line_Width => Self.line_Width);
+      Self.Geometry.add (Primitive.view (the_Primitive));
+
+      -- Right bit.
+      --
+      the_Indices   := [2, 4];
+      the_Primitive := Primitive.indexed.new_Primitive (Primitive.Lines, the_Indices, line_Width => Self.line_Width);
+      Self.Geometry.add (Primitive.view (the_Primitive));
+
+      Self.set_side_Bits;
+
+      return [1 => Self.Geometry];
+   end to_GL_Geometries;
+
+
+
+   procedure set_side_Bits (Self : in out Item)
+   is
+      use linear_Algebra_3d;
+
+      End_1 : Vector_3    renames Self.Vertices (1).Site;
+      End_2 : Vector_3    renames Self.Vertices (2).Site;
+
+      polar_Coords     : constant Geometry_2d.polar_Site := Geometry_2d.to_Polar (to_Vector_2 (End_2 - End_1));
+
+      the_Angle        : constant Radians          := polar_Coords.Angle;
+      bit_Length       : constant Real             := abs (End_2 - End_1) * 0.1;
+
+      left_bit_Offset  : constant Geometry_2d.Site := Geometry_2d.to_Site ((Angle  => the_Angle + to_Radians (135.0),
+                                                                            Extent => bit_Length));
+      right_bit_Offset : constant Geometry_2d.Site := Geometry_2d.to_Site ((Angle  => the_Angle + to_Radians (135.0 + 90.0),
+                                                                            Extent => bit_Length));
+
+      left_bit_End     : constant Vector_3         := End_2 + to_Vector_3 ( left_bit_Offset);
+      right_bit_End    : constant Vector_3         := End_2 + to_Vector_3 (right_bit_Offset);
+   begin
+      Self.Vertices (3).Site :=  left_bit_End;   -- Left bit.
+      Self.Vertices (4).Site := right_bit_End;   -- Right bit.
+   end set_side_Bits;
+
+
+
+   function End_Site (Self : in  Item;   for_End : in Integer) return Vector_3
+   is
+   begin
+      return Self.Vertices (Index_t (for_End)).Site;
+   end End_Site;
+
+
+   procedure End_Site_is (Self : in out Item;   Now     : in Vector_3;
+                                                for_End : in Integer)
+   is
+   begin
+      Self.Vertices (Index_t (for_End)).Site := Now;
+      Self.set_side_Bits;
+      Self.is_Modified := True;
+   end End_Site_is;
+
+
+
+   overriding
+   procedure modify (Self : in out Item)
+   is
+   begin
+      Self.Geometry.Vertices_are (Self.Vertices);
+      Self.set_Bounds;
+      Self.is_Modified := False;
+   end modify;
+
+
+   overriding
+   function is_Modified (Self : in Item) return Boolean
+   is
+   begin
+      return Self.is_Modified;
+   end is_Modified;
+
+
+end openGL.Model.arrow.colored;

3-mid/opengl/source/lean/model/opengl-model-arrow-colored.ads

@@ -0,0 +1,61 @@
+with
+     openGL.geometry.colored,
+     openGL.Font,
+     openGL.Palette;
+
+
+package openGL.Model.arrow.colored
+--
+--  Models a colored arrow.
+--
+is
+   type Item is new openGL.Model.arrow.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Arrow (Color      : in openGL.Color := Palette.White;
+                       line_Width : in Real         := 1.0;
+                       End_1,
+                       End_2      : in Vector_3     := Origin_3D) 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;
+
+   procedure end_Site_is (Self : in out Item;   Now     : in Vector_3;
+                                                for_End : in Integer);
+   function  end_Site    (Self : in     Item;   for_End : in Integer) return Vector_3;
+
+   overriding
+   procedure modify      (Self : in out Item);
+
+   overriding
+   function  is_Modified (Self : in     Item) return Boolean;
+
+
+
+private
+
+   type Item is new openGL.Model.arrow.item with
+      record
+         Color       :         openGL.Color;
+         line_Width  :         Real;
+
+         Vertices    : aliased Geometry.colored.Vertex_array (1 .. 4);
+         Geometry    : access  Geometry.colored.item'Class;
+
+         is_Modified :         Boolean := False;
+      end record;
+
+   procedure set_side_Bits (Self : in out Item);
+
+
+end openGL.Model.arrow.colored;

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

@@ -0,0 +1,14 @@
+package openGL.Model.arrow
+--
+--  Models an arrow.
+--
+is
+   type Item is abstract new Model.item with private;
+
+
+
+private
+
+   type Item is abstract new Model.item with null record;
+
+end openGL.Model.arrow;

3-mid/opengl/source/lean/model/opengl-model-billboard-colored.adb

@@ -0,0 +1,137 @@
+with
+     openGL.Primitive.indexed,
+     openGL.IO;
+
+
+package body openGL.Model.billboard.colored
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Billboard (Size    : in Size_t         := default_Size;
+                           Plane   : in billboard.Plane;
+                           Color   : in lucid_Color;
+                           Texture : in asset_Name) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.define (Size);
+
+      Self.Plane        := Plane;
+      Self.Color        := Color;
+      Self.Texture_Name := Texture;
+
+      return Self;
+   end new_Billboard;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry,
+          Geometry.colored,
+          Texture;
+
+      the_Indices  : aliased constant Indices         := (1, 2, 3, 4);
+      the_Sites    :         constant billboard.Sites := vertex_Sites (Self.Plane,
+                                                                       Self.Width,
+                                                                       Self.Height);
+
+      function new_Face (Vertices : access Geometry.colored.Vertex_array) return Geometry.colored.view
+      is
+         use openGL.Primitive;
+
+         the_Geometry  : constant Geometry.colored.view := Geometry.colored.new_Geometry;
+         the_Primitive : constant Primitive.view        := Primitive.indexed.new_Primitive (triangle_Fan,
+                                                                                            the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices.all);
+         the_Geometry.add (the_Primitive);
+         the_Geometry.is_Transparent;
+
+         return the_Geometry;
+      end new_Face;
+
+      Color    : constant rgba_Color  := +Self.Color;
+      the_Face : Geometry.colored.view;
+
+   begin
+      declare
+         the_Vertices : constant access Geometry.colored.Vertex_array := Self.Vertices;
+      begin
+         the_Vertices.all := Geometry.colored.Vertex_array'
+                               (1 => (site => the_Sites (1),  color => Color),
+                                2 => (site => the_Sites (2),  color => Color),
+                                3 => (site => the_Sites (3),  color => Color),
+                                4 => (site => the_Sites (4),  color => Color));
+
+         the_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.texture_Name /= null_Asset
+         then
+            Self.Texture := IO.to_Texture (Self.texture_Name);
+         end if;
+
+         if Self.Texture /= null_Object
+         then
+            the_Face.Texture_is (Self.Texture);
+         end if;
+      end;
+
+      Self.Geometry := the_Face;
+
+      return (1 => Geometry.view (the_Face));
+   end to_GL_Geometries;
+
+
+
+   procedure Color_is (Self : in out Item;   Now : in lucid_Color)
+   is
+   begin
+      Self.Color := Now;
+
+      for i in Self.Vertices'Range
+      loop
+         Self.Vertices (i).Color := +Now;
+      end loop;
+
+      Self.is_Modified := True;
+   end Color_is;
+
+
+
+   procedure Texture_Coords_are (Self : in out Item;   Now : in Coordinates)
+   is
+   begin
+      Self.texture_Coords := Now;
+      Self.needs_Rebuild  := True;
+   end Texture_Coords_are;
+
+
+
+   overriding
+   procedure modify (Self : in out Item)
+   is
+   begin
+      Self.Geometry.Vertices_are (Self.Vertices.all);
+      Self.is_Modified := False;
+   end modify;
+
+
+   overriding
+   function is_Modified (Self : in Item) return Boolean
+   is
+   begin
+      return Self.is_Modified;
+   end is_Modified;
+
+
+end openGL.Model.billboard.colored;

3-mid/opengl/source/lean/model/opengl-model-billboard-colored.ads

@@ -0,0 +1,61 @@
+with
+     openGL.Geometry.colored,
+     openGL.Texture,
+     openGL.Font,
+     openGL.Palette;
+
+
+package openGL.Model.billboard.colored
+--
+--  Models a colored, textured billboard.
+--
+is
+   type Item is new Model.billboard.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Billboard (Size    : in Size_t         := default_Size;
+                           Plane   : in billboard.Plane;
+                           Color   : in lucid_Color;
+                           Texture : in asset_Name) 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;
+
+   procedure Color_is           (Self : in out Item;   Now : in lucid_Color);
+   procedure Texture_Coords_are (Self : in out Item;   Now : in Coordinates);
+
+   overriding
+   procedure modify      (Self : in out Item);
+
+   overriding
+   function  is_Modified (Self : in     Item) return Boolean;
+
+
+
+private
+
+   type Item is new Model.billboard.item with
+      record
+         Color          : lucid_Color           := (Palette.White, Opaque);
+
+         texture_Name   : asset_Name            := null_Asset;
+         Texture        : openGL.Texture.Object := openGL.Texture.null_Object;      -- The texture to be applied to the billboard face.
+         texture_Coords : Coordinates           := ((0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0));
+
+         is_Modified    : Boolean               := False;
+
+         Vertices : access Geometry.colored.Vertex_array := new geometry.colored.Vertex_array (1 .. 4);
+         Geometry : access Geometry.colored.item'Class;
+      end record;
+
+end openGL.Model.billboard.colored;

3-mid/opengl/source/lean/model/opengl-model-billboard-colored_textured.adb

@@ -0,0 +1,139 @@
+with
+     openGL.Primitive.indexed,
+     openGL.IO;
+
+
+package body openGL.Model.billboard.colored_textured
+is
+   type Geometry_view is access all Geometry.colored_textured.item'Class;
+
+   ---------
+   --- Forge
+   --
+
+   function new_Billboard (Size    : in Size_t         := default_Size;
+                           Plane   : in billboard.Plane;
+                           Color   : in lucid_Color;
+                           Texture : in asset_Name) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.define (Size);
+
+      Self.Plane        := Plane;
+      Self.Color        := Color;
+      Self.Texture_Name := Texture;
+
+      return Self;
+   end new_Billboard;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry,
+          Geometry.colored_textured,
+          Texture;
+
+      the_Indices  : aliased constant Indices         := [1, 2, 3, 4];
+      the_Sites    :         constant billboard.Sites := vertex_Sites (Self.Plane,
+                                                                       Self.Width,
+                                                                       Self.Height);
+
+      function new_Face (Vertices : access Geometry.colored_textured.Vertex_array) return Geometry_view
+      is
+         use openGL.Primitive;
+
+         the_Geometry  : constant Geometry_view  := Geometry.colored_textured.new_Geometry;
+         the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive (triangle_Fan,
+                                                                                     the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices.all);
+         the_Geometry.add (the_Primitive);
+         the_Geometry.is_Transparent;
+
+         return the_Geometry;
+      end new_Face;
+
+      Color    : constant rgba_Color := +Self.Color;
+      the_Face : Geometry_view;
+
+   begin
+      declare
+         the_Vertices : constant access Geometry.colored_textured.Vertex_array := Self.Vertices;
+      begin
+         the_Vertices.all := Geometry.colored_textured.Vertex_array'
+                               (1 => (site => the_Sites (1),    color => Color,  coords => (Self.texture_Coords (1))),
+                                2 => (site => the_Sites (2),    color => Color,  coords => (Self.texture_Coords (2))),
+                                3 => (site => the_Sites (3),    color => Color,  coords => (Self.texture_Coords (3))),
+                                4 => (site => the_Sites (4),    color => Color,  coords => (Self.texture_Coords (4))));
+
+         the_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.texture_Name /= null_Asset
+         then
+            Self.Texture := IO.to_Texture (Self.texture_Name);
+         end if;
+
+         if Self.Texture /= null_Object
+         then
+            the_Face.Texture_is (Self.Texture);
+         end if;
+      end;
+
+      Self.Geometry := the_Face;
+
+      return [1 => Geometry.view (the_Face)];
+   end to_GL_Geometries;
+
+
+
+   procedure Color_is (Self : in out Item;   Now : in lucid_Color)
+   is
+   begin
+      Self.Color := Now;
+
+      for i in Self.Vertices'Range
+      loop
+         Self.Vertices (i).Color := +Now;
+      end loop;
+
+      Self.is_Modified := True;
+   end Color_is;
+
+
+
+   procedure Texture_Coords_are (Self : in out Item;   Now : in Coordinates)
+   is
+   begin
+      Self.texture_Coords := Now;
+      Self.needs_Rebuild  := True;
+   end Texture_Coords_are;
+
+
+
+   overriding
+   procedure modify (Self : in out Item)
+   is
+   begin
+      Self.Geometry.Vertices_are (Self.Vertices.all);
+      Self.is_Modified := False;
+   end modify;
+
+
+   overriding
+   function is_Modified (Self : in Item) return Boolean
+   is
+   begin
+      return Self.is_Modified;
+   end is_Modified;
+
+
+end openGL.Model.billboard.colored_textured;

3-mid/opengl/source/lean/model/opengl-model-billboard-colored_textured.ads

@@ -0,0 +1,61 @@
+with
+     openGL.Geometry.colored_textured,
+     openGL.Texture,
+     openGL.Font,
+     openGL.Palette;
+
+
+package openGL.Model.billboard.colored_textured
+--
+--  Models a colored, textured billboard.
+--
+is
+   type Item is new Model.billboard.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Billboard (Size    : in Size_t         := default_Size;
+                           Plane   : in billboard.Plane;
+                           Color   : in lucid_Color;
+                           Texture : in asset_Name) 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;
+
+   procedure Color_is           (Self : in out Item;   Now : in lucid_Color);
+   procedure Texture_Coords_are (Self : in out Item;   Now : in Coordinates);
+
+   overriding
+   procedure modify      (Self : in out Item);
+
+   overriding
+   function  is_Modified (Self : in     Item) return Boolean;
+
+
+
+private
+
+   type Item is new Model.billboard.item with
+      record
+         Color          : lucid_Color           := (Palette.White, Opaque);
+
+         texture_Name   : asset_Name            := null_Asset;
+         Texture        : openGL.Texture.Object := openGL.Texture.null_Object;      -- The texture to be applied to the billboard face.
+         texture_Coords : Coordinates           := [(0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0)];
+
+         is_Modified    : Boolean               := False;
+
+         Vertices : Geometry.colored_textured.Vertex_array_view := new geometry.colored_textured.Vertex_array (1 .. 4);
+         Geometry : access Geometry.colored_textured.item'Class;
+      end record;
+
+end openGL.Model.billboard.colored_textured;

3-mid/opengl/source/lean/model/opengl-model-billboard-textured.adb

@@ -0,0 +1,198 @@
+with
+     openGL.Primitive.indexed,
+     openGL.Geometry.textured,
+     openGL.io,
+
+     ada.unchecked_Deallocation;
+
+
+package body openGL.Model.billboard.textured
+is
+   ---------
+   --- Forge
+   --
+
+   package body Forge
+   is
+      function new_Billboard (Size    : in Size_t         := default_Size;
+                              Plane   : in billboard.Plane;
+                              Texture : in asset_Name;
+                              Lucid   : in Boolean        := False) return View
+      is
+         Self : constant View := new Item (Lucid);
+      begin
+         Self.Plane        := Plane;
+         Self.Texture_Name := Texture;
+         Self.define (Size);
+
+         return Self;
+      end new_Billboard;
+   end Forge;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function to_GL_Geometries (Self : access Item;   Textures : access openGL.Texture.name_Map_of_texture'Class;
+                                                    Fonts    : in     Font.font_id_Map_of_font) return Geometry.views
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry,
+          Geometry.textured,
+          openGL.Texture;
+
+      the_Indices  : aliased constant Indices         := [1, 2, 3, 4];
+      the_Sites    :         constant billboard.Sites := vertex_Sites (Self.Plane,
+                                                                       Self.Width,
+                                                                       Self.Height);
+
+      function new_Face (Vertices : in Geometry.textured.Vertex_array) return Geometry.textured.view
+      is
+         use Primitive;
+
+         the_Geometry  : constant Geometry.textured.view := Geometry.textured.new_Geometry;
+         the_Primitive : constant Primitive.view         := Primitive.indexed.new_Primitive (triangle_Fan,
+                                                                                             the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add (the_Primitive);
+         the_Geometry.is_Transparent;
+
+         return the_Geometry;
+      end new_Face;
+
+      the_Face : Geometry.textured.view;
+
+   begin
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (site => the_Sites (1),  coords => Self.texture_Coords (1)),
+               2 => (site => the_Sites (2),  coords => Self.texture_Coords (2)),
+               3 => (site => the_Sites (3),  coords => Self.texture_Coords (3)),
+               4 => (site => the_Sites (4),  coords => Self.texture_Coords (4))];
+      begin
+         the_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.texture_Name /= null_Asset
+         then
+            Self.Texture := IO.to_Texture (Self.texture_Name);
+         end if;
+
+         if Self.Lucid
+         then
+            if Self.lucid_Image /= null
+            then
+               if Self.Texture /= null_Object
+               then
+                  set_Image (Self.Texture, Self.lucid_Image.all);
+               else
+                  Self.Texture := openGL.Texture.Forge.to_Texture (Self.lucid_Image.all);
+               end if;
+            end if;
+         else
+            if Self.Image /= null
+            then
+               if Self.Texture /= null_Object
+               then
+                  Self.Texture.set_Image (Self.Image.all);
+               else
+                  Self.Texture := openGL.Texture.Forge.to_Texture (Self.Image.all);
+               end if;
+            end if;
+         end if;
+
+         if Self.Texture /= null_Object
+         then
+            the_Face.Texture_is (Self.Texture);
+         end if;
+      end;
+
+      return [1 => the_Face.all'Access];
+   end to_GL_Geometries;
+
+
+
+   procedure Texture_is (Self : in out Item;   Now : in openGL.Texture.Object)
+   is
+   begin
+      Self.Texture := Now;
+   end Texture_is;
+
+
+   function Texture (Self : in Item) return openGL.Texture.Object
+   is
+   begin
+      return Self.Texture;
+   end Texture;
+
+
+
+   procedure Texture_Coords_are (Self : in out Item;   Now : in Coordinates)
+   is
+   begin
+      Self.texture_Coords := Now;
+      Self.needs_Rebuild  := True;
+   end Texture_Coords_are;
+
+
+
+   procedure Size_is (Self : in out Item;   Now : in Size_t)
+   is
+   begin
+      Self.Size          := Now;
+      Self.needs_Rebuild := True;
+   end Size_is;
+
+
+
+   procedure Image_is (Self : in out Item;   Now : in Image)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Image,
+                                                              Image_view);
+   begin
+      if Self.Image = null
+      then
+         Self.Image := new Image' (Now);
+
+      elsif Self.Image'Length (1) = Now'Length (1)
+        and Self.Image'Length (2) = Now'Length (2)
+      then
+         Self.Image.all := Now;
+
+      else
+         deallocate (Self.Image);
+         Self.Image := new Image' (Now);
+      end if;
+
+      Self.needs_Rebuild := True;
+   end Image_is;
+
+
+
+   procedure Image_is (Self : in out Item;   Now : in lucid_Image)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (lucid_Image,
+                                                              lucid_Image_view);
+   begin
+      if Self.lucid_Image = null
+      then
+         Self.lucid_Image := new lucid_Image' (Now);
+
+      elsif Self.lucid_Image'Length (1) = Now'Length (1)
+        and Self.lucid_Image'Length (2) = Now'Length (2)
+      then
+         Self.lucid_Image.all := Now;
+
+      else
+         deallocate (Self.lucid_Image);
+         Self.lucid_Image := new lucid_Image' (Now);
+      end if;
+
+      Self.needs_Rebuild := True;
+   end Image_is;
+
+
+end openGL.Model.billboard.textured;

3-mid/opengl/source/lean/model/opengl-model-billboard-textured.ads

@@ -0,0 +1,64 @@
+with
+     openGL.Geometry,
+     openGL.Texture;
+
+
+package openGL.Model.billboard.textured
+--
+--  Models a textured billboard.
+--
+is
+   type Item (Lucid : Boolean) is new Model.billboard.item with private;
+   type View                   is access all Item'Class;
+
+   type       Image_view  is access       Image;
+   type lucid_Image_view  is access lucid_Image;
+
+
+   ---------
+   --- Forge
+   --
+
+   package Forge
+   is
+      function new_Billboard (Size    : in Size_t         := default_Size;
+                              Plane   : in billboard.Plane;
+                              Texture : in asset_Name;
+                              Lucid   : in Boolean        := False) return View;
+   end Forge;
+
+
+   --------------
+   --- 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;
+
+   procedure Texture_is         (Self : in out Item;   Now : in Texture.Object);
+   function  Texture            (Self : in     Item)     return Texture.Object;
+
+   procedure Texture_Coords_are (Self : in out Item;   Now : in Coordinates);
+   procedure Size_is            (Self : in out Item;   Now : in Size_t);
+
+   procedure Image_is           (Self : in out Item;   Now : in       Image);
+   procedure Image_is           (Self : in out Item;   Now : in lucid_Image);
+
+
+
+private
+
+   type Item (Lucid : Boolean) is new Model.billboard.item with
+      record
+         texture_Name   : asset_Name            := null_Asset;
+         Texture        : openGL.Texture.Object := openGL.Texture.null_Object;      -- The texture to be applied to the billboard face.
+         texture_Coords : Coordinates           := [(0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0)];     -- TODO: Should be constant/static ?
+
+         case Lucid is
+            when True  => lucid_Image : lucid_Image_view;
+            when False =>       Image :       Image_view;
+         end case;
+      end record;
+
+end openGL.Model.billboard.textured;

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

@@ -0,0 +1,67 @@
+package body openGL.Model.billboard
+is
+
+   ---------
+   --- Forge
+   --
+
+   procedure define (Self : out Item;   Size : Size_t := default_Size)
+   is
+   begin
+      Self.Size := Size;
+   end define;
+
+
+
+   --------------
+   --- Attributes
+   --
+
+   function Size (Self : in Item) return Size_t
+   is
+   begin
+      return Self.Size;
+   end Size;
+
+
+
+   function Width (Self : in Item) return Real
+   is
+   begin
+      return Self.Size.Width;
+   end Width;
+
+
+
+   function Height (Self : in Item) return Real
+   is
+   begin
+      return Self.Size.Height;
+   end Height;
+
+
+
+   function vertex_Sites (for_Plane     : in Plane;
+                          Width, Height : in Real) return Sites
+   is
+      half_Width  : constant Real := Width  / 2.0;
+      half_Height : constant Real := Height / 2.0;
+
+      the_Sites   : constant array (Plane) of Sites := [xy => [[-half_Width, -half_Height,         0.0],
+                                                               [ half_Width, -half_Height,         0.0],
+                                                               [ half_Width,  half_Height,         0.0],
+                                                               [-half_Width,  half_Height,         0.0]],
+                                                        xz => [[-half_Width,          0.0,         1.0],
+                                                               [ half_Width,          0.0,         1.0],
+                                                               [ half_Width,          0.0,        -1.0],
+                                                               [-half_Width,          0.0,        -1.0]],
+                                                        yz => [[        0.0, -half_Height,  half_Width],
+                                                               [        0.0, -half_Height, -half_Width],
+                                                               [        0.0,  half_Height, -half_Width],
+                                                               [        0.0,  half_Height,  half_Width]]];
+   begin
+      return the_Sites (for_Plane);
+   end vertex_Sites;
+
+
+end openGL.Model.billboard;

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

@@ -0,0 +1,57 @@
+package openGL.Model.billboard
+--
+--  Models a rectangle capable of displaying an image.
+--
+is
+   type Item   is abstract new Model.item with private;
+
+   type Plane  is (xy, xz, yz);
+
+   type Size_t is
+      record
+         Width  : Real;
+         Height : Real;
+      end record;
+
+   type Coordinates is array (1 .. 4) of Coordinate_2D;
+
+
+   ---------
+   --- Forge
+   --
+
+   default_Size : constant Size_t;
+
+   procedure define (Self : out Item;   Size : Size_t := default_Size);
+
+
+   --------------
+   --- Attributes
+   --
+
+   function Size   (Self : in Item) return Size_t;
+   function Width  (Self : in Item) return Real;
+   function Height (Self : in Item) return Real;
+
+
+
+private
+
+   type Item is abstract new Model.item with
+      record
+         Plane  : billboard.Plane := xy;
+         Size   : Size_t;
+      end record;
+
+
+   subtype site_Id is Index_t range 1 .. 4;
+   subtype Sites   is Vector_3_array (site_Id'Range);
+
+   function vertex_Sites (for_Plane     : in Plane;
+                          Width, Height : in Real) return Sites;
+
+   Normal       : constant Vector_3 := [0.0,  0.0,  1.0];
+   default_Size : constant Size_t   := (Width  => 1.0,
+                                        Height => 1.0);
+
+end openGL.Model.billboard;

3-mid/opengl/source/lean/model/opengl-model-box-colored.adb

@@ -0,0 +1,145 @@
+with
+     openGL.Primitive.indexed,
+     openGL.Geometry.colored;
+
+
+package body openGL.Model.box.colored
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in colored.Faces) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Faces := Faces;
+      Self.Size  := Size;
+
+      return Self;
+   end new_Box;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+      use Geometry;
+
+      the_Sites    :         constant box.Sites := Self.vertex_Sites;
+      the_Indices  : aliased constant Indices   := [1, 2, 3, 4];
+
+
+      function new_Face (Vertices : access Geometry.colored.Vertex_array) return Geometry.colored.view
+      is
+         use Geometry.colored,
+             Primitive;
+
+         the_Geometry  : constant Geometry.colored .view := Geometry.colored.new_Geometry;
+         the_Primitive : constant Primitive.indexed.view := Primitive.indexed.new_Primitive (triangle_Fan,
+                                                                                             the_Indices);
+      begin
+         the_Geometry.Vertices_are   (Vertices.all);
+         the_Geometry.add            (Primitive.view (the_Primitive));
+         the_Geometry.is_Transparent (now => False);
+
+         return the_Geometry;
+      end new_Face;
+
+
+      front_Face : Geometry.colored.view;
+      rear_Face  : Geometry.colored.view;
+      upper_Face : Geometry.colored.view;
+      lower_Face : Geometry.colored.view;
+      left_Face  : Geometry.colored.view;
+      right_Face : Geometry.colored.view;
+
+   begin
+      --  Front
+      --
+      declare
+         the_Vertices : aliased Geometry.colored.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Lower_Front),  Color => +Self.Faces (Front).Colors (1)),
+               2 => (Site => the_Sites (Right_Lower_Front),  Color => +Self.Faces (Front).Colors (2)),
+               3 => (Site => the_Sites (Right_Upper_Front),  Color => +Self.Faces (Front).Colors (3)),
+               4 => (Site => the_Sites ( Left_Upper_Front),  Color => +Self.Faces (Front).Colors (4))];
+      begin
+         front_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+      --  Rear
+      --
+      declare
+         the_Vertices : aliased Geometry.colored.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Rear),   Color => +Self.Faces (Rear).Colors (1)),
+               2 => (Site => the_Sites ( Left_Lower_Rear),   Color => +Self.Faces (Rear).Colors (2)),
+               3 => (Site => the_Sites ( Left_Upper_Rear),   Color => +Self.Faces (Rear).Colors (3)),
+               4 => (Site => the_Sites (Right_Upper_Rear),   Color => +Self.Faces (Rear).Colors (4))];
+      begin
+         rear_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+      --  Upper
+      --
+      declare
+         the_Vertices : aliased Geometry.colored.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Upper_Front),  Color => +Self.Faces (Upper).Colors (1)),
+               2 => (Site => the_Sites (Right_Upper_Front),  Color => +Self.Faces (Upper).Colors (2)),
+               3 => (Site => the_Sites (Right_Upper_Rear),   Color => +Self.Faces (Upper).Colors (3)),
+               4 => (Site => the_Sites ( Left_Upper_Rear),   Color => +Self.Faces (Upper).Colors (4))];
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+      --  Lower
+      --
+      declare
+         the_Vertices : aliased Geometry.colored.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),  Color => +Self.Faces (Lower).Colors (1)),
+               2 => (Site => the_Sites ( Left_Lower_Front),  Color => +Self.Faces (Lower).Colors (2)),
+               3 => (Site => the_Sites ( Left_Lower_Rear),   Color => +Self.Faces (Lower).Colors (3)),
+               4 => (Site => the_Sites (Right_Lower_Rear),   Color => +Self.Faces (Lower).Colors (4))];
+      begin
+         lower_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+      --  Left
+      --
+      declare
+         the_Vertices : aliased Geometry.colored.Vertex_array
+           := [1 => (Site => the_Sites (Left_Lower_Rear),    Color => +Self.Faces (Left).Colors (1)),
+               2 => (Site => the_Sites (Left_Lower_Front),   Color => +Self.Faces (Left).Colors (2)),
+               3 => (Site => the_Sites (Left_Upper_Front),   Color => +Self.Faces (Left).Colors (3)),
+               4 => (Site => the_Sites (Left_Upper_Rear),    Color => +Self.Faces (Left).Colors (4))];
+      begin
+         left_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+      --  Right
+      --
+      declare
+         the_Vertices : aliased Geometry.colored.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),  Color => +Self.Faces (Right).Colors (1)),
+               2 => (Site => the_Sites (Right_Lower_Rear),   Color => +Self.Faces (Right).Colors (2)),
+               3 => (Site => the_Sites (Right_Upper_Rear),   Color => +Self.Faces (Right).Colors (3)),
+               4 => (Site => the_Sites (Right_Upper_Front),  Color => +Self.Faces (Right).Colors (4))];
+      begin
+         right_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+      return [Geometry.view (front_Face),
+              Geometry.view ( rear_Face),
+              Geometry.view (upper_Face),
+              Geometry.view (lower_Face),
+              Geometry.view ( left_Face),
+              Geometry.view (right_Face)];
+   end to_GL_Geometries;
+
+
+end openGL.Model.box.colored;

3-mid/opengl/source/lean/model/opengl-model-box-colored.ads

@@ -0,0 +1,49 @@
+with
+     openGL.Font,
+     openGL.Geometry;
+
+
+package openGL.Model.box.colored
+--
+--  Models a colored box.
+--
+--  Each face may be separately colored via each of its 4 vertices.
+--
+is
+   type Item is new Model.box.item with private;
+   type View is access all Item'Class;
+
+
+   type Face is
+      record
+         Colors : lucid_Colors (1 .. 4);     -- The color of each of the faces 4 vertices.
+      end record;
+
+   type Faces is array (Side) of Face;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in colored.Faces) 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;
+
+
+private
+
+   type Item is new Model.box.item with
+      record
+         Faces : colored.Faces;
+      end record;
+
+end openGL.Model.box.colored;

3-mid/opengl/source/lean/model/opengl-model-box-lit_colored.adb

@@ -0,0 +1,151 @@
+with
+     openGL.Geometry.lit_colored,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.box.lit_colored
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in lit_colored.Faces) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Faces := Faces;
+      Self.Size  := Size;
+
+      return Self;
+   end new_Box;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Fonts, Textures);
+
+      use Geometry.lit_colored;
+
+      the_Sites    :         constant box.Sites := Self.vertex_Sites;
+      the_Indices  : aliased constant Indices   := (1, 2, 3, 4);
+
+
+      function new_Face (Vertices : access geometry.lit_colored.Vertex_array) return Geometry.lit_colored.view
+      is
+         use openGL.Primitive;
+
+         the_Geometry  : constant Geometry.lit_colored.view := Geometry.lit_colored.new_Geometry;
+         the_Primitive : constant Primitive.view            := Primitive.indexed.new_Primitive
+                                                                 (triangle_Fan,
+                                                                  the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices.all);
+         the_Geometry.add          (the_Primitive);
+
+         return the_Geometry;
+      end new_Face;
+
+
+      front_Face : Geometry.lit_colored.view;
+      rear_Face  : Geometry.lit_colored.view;
+      upper_Face : Geometry.lit_colored.view;
+      lower_Face : Geometry.lit_colored.view;
+      left_Face  : Geometry.lit_colored.view;
+      right_Face : Geometry.lit_colored.view;
+
+   begin
+      --  Front
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := (1 => (Site => the_Sites ( Left_Lower_Front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (1),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Lower_Front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (2),   Shine => default_Shine),
+               3 => (Site => the_Sites (right_upper_front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (3),   Shine => default_Shine),
+               4 => (Site => the_Sites ( Left_Upper_Front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (4),   Shine => default_Shine));
+      begin
+         front_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+
+      --  Rear
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := (1 => (Site => the_Sites (Right_Lower_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (1),   Shine => default_Shine),
+               2 => (Site => the_Sites ( Left_Lower_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (2),   Shine => default_Shine),
+               3 => (Site => the_Sites ( Left_Upper_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (3),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Upper_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (4),   Shine => default_Shine));
+      begin
+         rear_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+
+      --  Upper
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := (1 => (Site => the_Sites ( Left_Upper_Front),   Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (1),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Upper_Front),   Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (2),   Shine => default_Shine),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (3),   Shine => default_Shine),
+               4 => (Site => the_Sites ( Left_Upper_Rear),    Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (4),   Shine => default_Shine));
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+
+      --  Lower
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := (1 => (Site => the_Sites (Right_Lower_Front),   Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (1),   Shine => default_Shine),
+               2 => (Site => the_Sites ( Left_Lower_Front),   Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (2),   Shine => default_Shine),
+               3 => (Site => the_Sites ( Left_Lower_Rear),    Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (3),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Lower_Rear),    Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (4),   Shine => default_Shine));
+      begin
+         lower_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+
+      --  Left
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := (1 => (Site => the_Sites (Left_Lower_Rear),    Normal => left_Normal,   Color => +Self.Faces (Left).Colors (1),   Shine => default_Shine),
+               2 => (Site => the_Sites (Left_Lower_Front),   Normal => left_Normal,   Color => +Self.Faces (Left).Colors (2),   Shine => default_Shine),
+               3 => (Site => the_Sites (Left_Upper_Front),   Normal => left_Normal,   Color => +Self.Faces (Left).Colors (3),   Shine => default_Shine),
+               4 => (Site => the_Sites (Left_Upper_Rear),    Normal => left_Normal,   Color => +Self.Faces (Left).Colors (4),   Shine => default_Shine));
+      begin
+         left_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+
+      --  Right
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := (1 => (Site => the_Sites (Right_Lower_Front),   Normal => right_Normal,   Color => +Self.Faces (Right).Colors (1),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Lower_Rear),    Normal => right_Normal,   Color => +Self.Faces (Right).Colors (2),   Shine => default_Shine),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Normal => right_Normal,   Color => +Self.Faces (Right).Colors (3),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Upper_Front),   Normal => right_Normal,   Color => +Self.Faces (Right).Colors (4),   Shine => default_Shine));
+      begin
+         right_Face := new_Face (Vertices => the_Vertices'Access);
+      end;
+
+
+      return (1 => front_Face.all'Access,
+              2 =>  rear_Face.all'Access,
+              3 => upper_Face.all'Access,
+              4 => lower_Face.all'Access,
+              5 =>  left_Face.all'Access,
+              6 => right_Face.all'Access);
+   end to_GL_Geometries;
+
+
+end openGL.Model.box.lit_colored;

3-mid/opengl/source/lean/model/opengl-model-box-lit_colored.ads

@@ -0,0 +1,50 @@
+with
+     openGL.Geometry,
+     openGL.Font,
+     openGL.Texture;
+
+
+package openGL.Model.Box.lit_colored
+--
+--  Models a lit and colored box.
+--
+--  Each face may be separately colored via each of its 4 vertices.
+--
+is
+   type Item is new Model.box.item with private;
+   type View is access all Item'Class;
+
+
+   type Face is
+      record
+         Colors : lucid_Colors (1 .. 4);      -- The color of each faces 4 vertices.
+      end record;
+
+   type Faces is array (Side) of Face;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in lit_colored.Faces) 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;
+
+
+private
+
+   type Item is new Model.box.item with
+      record
+         Faces : lit_colored.Faces;
+      end record;
+
+end openGL.Model.Box.lit_colored;

3-mid/opengl/source/lean/model/opengl-model-box-lit_colored_textured.adb

@@ -0,0 +1,192 @@
+with
+     openGL.Geometry.lit_colored_textured,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.box.lit_colored_textured
+is
+   type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in lit_colored_textured.Faces) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Faces := Faces;
+      Self.Size  := Size;
+
+      return Self;
+   end new_Box;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Fonts);
+
+      use Geometry.lit_colored_textured,
+          Texture;
+
+      the_Sites    :         constant box.Sites := Self.vertex_Sites;
+      the_Indices  : aliased constant Indices   := [1, 2, 3, 4];
+
+
+      function new_Face (Vertices : access geometry.lit_colored_textured.Vertex_array) return Geometry_view
+      is
+         use openGL.Primitive;
+
+         the_Geometry  : constant Geometry_view  := Geometry.lit_colored_textured.new_Geometry
+                                                      (texture_is_Alpha => False);
+         the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive
+                                                      (triangle_Fan,
+                                                       the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices.all);
+         the_Geometry.add          (the_Primitive);
+
+         return the_Geometry;
+      end new_Face;
+
+
+      front_Face : Geometry_view;
+      rear_Face  : Geometry_view;
+      upper_Face : Geometry_view;
+      lower_Face : Geometry_view;
+      left_Face  : Geometry_view;
+      right_Face : Geometry_view;
+
+   begin
+      --  Front
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Lower_Front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Lower_Front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (right_upper_front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites ( Left_Upper_Front),   Normal => front_Normal,   Color => +Self.Faces (Front).Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         front_Face := new_Face (Vertices => the_Vertices'Access);
+
+         if Self.Faces (Front).texture_Name /= null_Asset
+         then
+            front_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
+            front_Face.is_Transparent (now => front_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Rear
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites ( Left_Lower_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites ( Left_Upper_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Upper_Rear),   Normal => rear_Normal,   Color => +Self.Faces (Rear).Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         rear_Face := new_Face (Vertices => the_Vertices'Access);
+
+         if Self.Faces (Rear).texture_Name /= null_Asset
+         then
+            rear_Face.Texture_is (Textures.fetch (Self.Faces (Rear).texture_Name));
+            rear_Face.is_Transparent (now => rear_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Upper
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Upper_Front),   Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Upper_Front),   Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites ( Left_Upper_Rear),    Normal => upper_Normal,   Color => +Self.Faces (Upper).Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices'Access);
+
+         if Self.Faces (Upper).texture_Name /= null_Asset
+         then
+            upper_Face.Texture_is (Textures.fetch (Self.Faces (Upper).texture_Name));
+            upper_Face.is_Transparent (now => upper_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Lower
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),   Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites ( Left_Lower_Front),   Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites ( Left_Lower_Rear),    Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Lower_Rear),    Normal => lower_Normal,   Color => +Self.Faces (Lower).Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         lower_Face := new_Face (Vertices => the_Vertices'Access);
+
+         if Self.Faces (Lower).texture_Name /= null_Asset
+         then
+            lower_Face.Texture_is (Textures.fetch (Self.Faces (Lower).texture_Name));
+            lower_Face.is_Transparent (now => lower_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Left
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
+           := [1 => (Site => the_Sites (Left_Lower_Rear),    Normal => left_Normal,   Color => +Self.Faces (Left).Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Left_Lower_Front),   Normal => left_Normal,   Color => +Self.Faces (Left).Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (Left_Upper_Front),   Normal => left_Normal,   Color => +Self.Faces (Left).Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Left_Upper_Rear),    Normal => left_Normal,   Color => +Self.Faces (Left).Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         left_Face := new_Face (Vertices => the_Vertices'Access);
+
+         if Self.Faces (Left).texture_Name /= null_Asset
+         then
+            left_Face.Texture_is (Textures.fetch (Self.Faces (Left).texture_Name));
+            left_Face.is_Transparent (now => left_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Right
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),   Normal => right_Normal,   Color => +Self.Faces (Right).Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Lower_Rear),    Normal => right_Normal,   Color => +Self.Faces (Right).Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Normal => right_Normal,   Color => +Self.Faces (Right).Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Upper_Front),   Normal => right_Normal,   Color => +Self.Faces (Right).Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         right_Face := new_Face (Vertices => the_Vertices'Access);
+
+         if Self.Faces (Right).texture_Name /= null_Asset
+         then
+            right_Face.Texture_is (Textures.fetch (Self.Faces (Right).texture_Name));
+            right_Face.is_Transparent (now => right_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      return [1 => front_Face.all'Access,
+              2 =>  rear_Face.all'Access,
+              3 => upper_Face.all'Access,
+              4 => lower_Face.all'Access,
+              5 =>  left_Face.all'Access,
+              6 => right_Face.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.box.lit_colored_textured;

3-mid/opengl/source/lean/model/opengl-model-box-lit_colored_textured.ads

@@ -0,0 +1,52 @@
+with
+     openGL.Geometry,
+     openGL.Font,
+     openGL.Texture;
+
+
+package openGL.Model.Box.lit_colored_textured
+--
+--  Models a lit, colored and textured box.
+--
+--  Each face may be separately colored via each of its 4 vertices.
+--  Each face may have a separate texture.
+--
+is
+   type Item is new Model.box.item with private;
+   type View is access all Item'Class;
+
+
+   type Face is
+      record
+         Colors       : lucid_Colors (1 .. 4);      -- The color of each faces 4 vertices.
+         texture_Name : asset_Name := null_Asset;   -- The texture applied to the face.
+      end record;
+
+   type Faces is array (Side) of Face;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in lit_colored_textured.Faces) 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;
+
+
+private
+
+   type Item is new Model.box.item with
+      record
+         Faces : lit_colored_textured.Faces;
+      end record;
+
+end openGL.Model.Box.lit_colored_textured;

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

@@ -0,0 +1,187 @@
+with
+     openGL.Geometry.lit_textured,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.box.lit_textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in lit_textured.Faces) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Faces := Faces;
+      Self.Size  := Size;
+
+      return Self;
+   end new_Box;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Fonts);
+
+      use Geometry.lit_textured;
+
+      the_Sites    :         constant box.Sites := Self.vertex_Sites;
+      the_Indices  : aliased constant Indices   := [1, 2, 3, 4];
+
+
+      function new_Face (Vertices : in geometry.lit_textured.Vertex_array) return Geometry.lit_textured.view
+      is
+         use openGL.Primitive;
+
+         the_Geometry  : constant Geometry.lit_textured.view  := Geometry.lit_textured.new_Geometry;
+         the_Primitive : constant Primitive.view              := Primitive.indexed.new_Primitive
+                                                                   (triangle_Fan,
+                                                                    the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (the_Primitive);
+
+         return the_Geometry;
+      end new_Face;
+
+
+      front_Face : Geometry.lit_textured.view;
+      rear_Face  : Geometry.lit_textured.view;
+      upper_Face : Geometry.lit_textured.view;
+      lower_Face : Geometry.lit_textured.view;
+      left_Face  : Geometry.lit_textured.view;
+      right_Face : Geometry.lit_textured.view;
+
+   begin
+      --  Front
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Lower_Front),   Normal => front_Normal,   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Lower_Front),   Normal => front_Normal,   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (right_upper_front),   Normal => front_Normal,   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites ( Left_Upper_Front),   Normal => front_Normal,   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         front_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Front).texture_Name /= null_Asset
+         then
+            front_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
+            front_Face.is_Transparent (now => front_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Rear
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Rear),   Normal => rear_Normal,   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites ( Left_Lower_Rear),   Normal => rear_Normal,   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites ( Left_Upper_Rear),   Normal => rear_Normal,   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Upper_Rear),   Normal => rear_Normal,   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         rear_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Rear).texture_Name /= null_Asset
+         then
+            rear_Face.Texture_is (Textures.fetch (Self.Faces (Rear).texture_Name));
+            rear_Face.is_Transparent (now => rear_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Upper
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Upper_Front),   Normal => upper_Normal,   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Upper_Front),   Normal => upper_Normal,   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Normal => upper_Normal,   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites ( Left_Upper_Rear),    Normal => upper_Normal,   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Upper).texture_Name /= null_Asset
+         then
+            upper_Face.Texture_is (Textures.fetch (Self.Faces (Upper).texture_Name));
+            upper_Face.is_Transparent (now => upper_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Lower
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),   Normal => lower_Normal,   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites ( Left_Lower_Front),   Normal => lower_Normal,   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites ( Left_Lower_Rear),    Normal => lower_Normal,   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Lower_Rear),    Normal => lower_Normal,   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         lower_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Lower).texture_Name /= null_Asset
+         then
+            lower_Face.Texture_is (Textures.fetch (Self.Faces (Lower).texture_Name));
+            lower_Face.is_Transparent (now => lower_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Left
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := [1 => (Site => the_Sites (Left_Lower_Rear),    Normal => left_Normal,   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Left_Lower_Front),   Normal => left_Normal,   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (Left_Upper_Front),   Normal => left_Normal,   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Left_Upper_Rear),    Normal => left_Normal,   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         left_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Left).texture_Name /= null_Asset
+         then
+            left_Face.Texture_is (Textures.fetch (Self.Faces (Left).texture_Name));
+            left_Face.is_Transparent (now => left_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Right
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),   Normal => right_Normal,   Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site => the_Sites (Right_Lower_Rear),    Normal => right_Normal,   Coords => (1.0, 0.0),   Shine => default_Shine),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Normal => right_Normal,   Coords => (1.0, 1.0),   Shine => default_Shine),
+               4 => (Site => the_Sites (Right_Upper_Front),   Normal => right_Normal,   Coords => (0.0, 1.0),   Shine => default_Shine)];
+      begin
+         right_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Right).texture_Name /= null_Asset
+         then
+            right_Face.Texture_is (Textures.fetch (Self.Faces (Right).texture_Name));
+            right_Face.is_Transparent (now => right_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      return [1 => front_Face.all'Access,
+              2 =>  rear_Face.all'Access,
+              3 => upper_Face.all'Access,
+              4 => lower_Face.all'Access,
+              5 =>  left_Face.all'Access,
+              6 => right_Face.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.box.lit_textured;

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

@@ -0,0 +1,49 @@
+with
+     openGL.Geometry,
+     openGL.Font;
+
+
+package openGL.Model.Box.lit_textured
+--
+--  Models a lit and textured box.
+--
+--  Each face may have a separate texture.
+--
+is
+   type Item is new Model.box.item with private;
+   type View is access all Item'Class;
+
+
+   type Face is
+      record
+         texture_Name : asset_Name := null_Asset;   -- The texture applied to the face.
+      end record;
+
+   type Faces is array (Side) of Face;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size  : in Vector_3;
+                     Faces : in lit_textured.Faces) 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;
+
+
+private
+
+   type Item is new Model.box.item with
+      record
+         Faces : lit_textured.Faces;
+      end record;
+
+end openGL.Model.Box.lit_textured;

3-mid/opengl/source/lean/model/opengl-model-box-textured.adb

@@ -0,0 +1,194 @@
+with
+     openGL.Geometry.textured,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.box.textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size      : in Vector_3;
+                     Faces     : in textured.Faces;
+                     is_Skybox : in Boolean := False) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Faces     := Faces;
+      Self.is_Skybox := is_Skybox;
+      Self.Size      := Size;
+
+      return Self;
+   end new_Box;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Fonts);
+
+      use Geometry.textured,
+          Texture;
+
+      the_Sites    : constant box.Sites := Self.vertex_Sites;
+      the_Indices  : aliased  Indices   := [1, 2, 3, 4];
+
+
+      function new_Face (Vertices : in Geometry.textured.Vertex_array) return Geometry.textured.view
+      is
+         use Primitive;
+
+         the_Geometry  : constant Geometry.textured.view := Geometry.textured.new_Geometry;
+         the_Primitive : constant Primitive.view         := Primitive.indexed.new_Primitive (triangle_Fan,
+                                                                                             the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (the_Primitive);
+
+         return the_Geometry;
+      end new_Face;
+
+
+      front_Face : Geometry.textured.view;
+      rear_Face  : Geometry.textured.view;
+      upper_Face : Geometry.textured.view;
+      lower_Face : Geometry.textured.view;
+      left_Face  : Geometry.textured.view;
+      right_Face : Geometry.textured.view;
+
+   begin
+      if Self.is_Skybox
+      then
+         the_Indices := [4, 3, 2, 1];
+      end if;
+
+      --  Front
+      --
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (Site => the_Sites ( left_lower_front),   Coords => (0.0, 0.0)),
+               2 => (Site => the_Sites (right_lower_front),   Coords => (1.0, 0.0)),
+               3 => (Site => the_Sites (right_upper_front),   Coords => (1.0, 1.0)),
+               4 => (Site => the_Sites ( left_upper_front),   Coords => (0.0, 1.0))];
+      begin
+         front_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Front).texture_Name /= null_Asset
+         then
+            front_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
+            front_Face.is_Transparent (now => front_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Rear
+      --
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Rear),   Coords => (0.0, 0.0)),
+               2 => (Site => the_Sites ( Left_Lower_Rear),   Coords => (1.0, 0.0)),
+               3 => (Site => the_Sites ( Left_Upper_Rear),   Coords => (1.0, 1.0)),
+               4 => (Site => the_Sites (Right_Upper_Rear),   Coords => (0.0, 1.0))];
+      begin
+         rear_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Rear).texture_Name /= null_Asset
+         then
+            rear_Face.Texture_is     (Textures.fetch (Self.Faces (Front).texture_Name));
+            rear_Face.is_Transparent (now => rear_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Upper
+      --
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (Site => the_Sites ( Left_Upper_Front),    Coords => (0.0, 0.0)),
+               2 => (Site => the_Sites (Right_Upper_Front),   Coords => (1.0, 0.0)),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Coords => (1.0, 1.0)),
+               4 => (Site => the_Sites ( Left_Upper_Rear),     Coords => (0.0, 1.0))];
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Upper).texture_Name /= null_Asset
+         then
+            upper_Face.Texture_is     (Textures.fetch (Self.Faces (Front).texture_Name));
+            upper_Face.is_Transparent (now => upper_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Lower
+      --
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),   Coords => (0.0, 0.0)),
+               2 => (Site => the_Sites ( Left_Lower_Front),   Coords => (1.0, 0.0)),
+               3 => (Site => the_Sites ( Left_Lower_Rear),    Coords => (1.0, 1.0)),
+               4 => (Site => the_Sites (Right_Lower_Rear),    Coords => (0.0, 1.0))];
+      begin
+         lower_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Lower).texture_Name /= null_Asset
+         then
+            lower_Face.Texture_is     (Textures.fetch (Self.Faces (Front).texture_Name));
+            lower_Face.is_Transparent (now => lower_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Left
+      --
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (Site => the_Sites (Left_Lower_Rear),    Coords => (0.0, 0.0)),
+               2 => (Site => the_Sites (Left_Lower_Front),   Coords => (1.0, 0.0)),
+               3 => (Site => the_Sites (Left_Upper_Front),   Coords => (1.0, 1.0)),
+               4 => (Site => the_Sites (Left_Upper_Rear),    Coords => (0.0, 1.0))];
+      begin
+         left_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Left).texture_Name /= null_Asset
+         then
+            left_Face.Texture_is     (Textures.fetch (Self.Faces (Front).texture_Name));
+            left_Face.is_Transparent (now => left_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      --  Right
+      --
+      declare
+         the_Vertices : constant Geometry.textured.Vertex_array
+           := [1 => (Site => the_Sites (Right_Lower_Front),   Coords => (0.0, 0.0)),
+               2 => (Site => the_Sites (Right_Lower_Rear),    Coords => (1.0, 0.0)),
+               3 => (Site => the_Sites (Right_Upper_Rear),    Coords => (1.0, 1.0)),
+               4 => (Site => the_Sites (Right_Upper_Front),   Coords => (0.0, 1.0))];
+      begin
+         right_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Faces (Right).texture_Name /= null_Asset
+         then
+            right_Face.Texture_is     (Textures.fetch (Self.Faces (Front).texture_Name));
+            right_Face.is_Transparent (now => right_Face.Texture.is_Transparent);
+         end if;
+      end;
+
+
+      return [1 => front_Face.all'Access,
+              2 =>  rear_Face.all'Access,
+              3 => upper_Face.all'Access,
+              4 => lower_Face.all'Access,
+              5 =>  left_Face.all'Access,
+              6 => right_Face.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.box.textured;

3-mid/opengl/source/lean/model/opengl-model-box-textured.ads

@@ -0,0 +1,52 @@
+with
+     openGL.Geometry,
+     openGL.Font,
+     openGL.Texture;
+
+
+package openGL.Model.Box.textured
+--
+--  Models a textured box.
+--
+--  Each face may have a separate texture.
+--
+is
+   type Item is new Model.box.item with private;
+   type View is access all Item'Class;
+
+
+   type Face is
+      record
+         texture_Name : asset_Name := null_Asset;
+      end record;
+
+   type Faces is array (Side) of Face;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Box (Size      : in Vector_3;
+                     Faces     : in textured.Faces;
+                     is_Skybox : in Boolean := False) 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;
+
+
+private
+
+   type Item is new Model.box.item with
+      record
+         Faces     : textured.Faces;
+         is_Skybox : Boolean := False;
+      end record;
+
+end openGL.Model.Box.textured;

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

@@ -0,0 +1,37 @@
+package body openGL.Model.box
+is
+   --------------
+   --- Attributes
+   --
+
+   function vertex_Sites (Self : in Item'Class) return Sites
+   is
+      left_Offset  : constant Real := -0.5;
+      right_Offset : constant Real :=  0.5;
+
+      lower_Offset : constant Real := -0.5;
+      upper_Offset : constant Real :=  0.5;
+
+      front_Offset : constant Real :=  0.5;
+      rear_Offset  : constant Real := -0.5;
+   begin
+      return [Left_Lower_Front  => Scaled ([ left_Offset, lower_Offset, front_Offset],   by => Self.Size),
+              Right_Lower_Front => Scaled ([right_Offset, lower_Offset, front_Offset],   by => Self.Size),
+              Right_Upper_Front => Scaled ([right_Offset, upper_Offset, front_Offset],   by => Self.Size),
+              Left_Upper_Front  => Scaled ([ left_Offset, upper_Offset, front_Offset],   by => Self.Size),
+              Right_Lower_Rear  => Scaled ([right_Offset, lower_Offset,  rear_Offset],   by => Self.Size),
+              Left_Lower_Rear   => Scaled ([ left_Offset, lower_Offset,  rear_Offset],   by => Self.Size),
+              Left_Upper_Rear   => Scaled ([ left_Offset, upper_Offset,  rear_Offset],   by => Self.Size),
+              Right_Upper_Rear  => Scaled ([right_Offset, upper_Offset,  rear_Offset],   by => Self.Size)];
+   end vertex_Sites;
+
+
+
+   function Size (Self : in Item) return Vector_3
+   is
+   begin
+      return Self.Size;
+   end Size;
+
+
+end openGL.Model.box;

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

@@ -0,0 +1,41 @@
+package openGL.Model.box
+--
+--  Provides an abstract model of a box.
+--
+is
+   type Item is abstract new Model.item with private;
+
+   type Side is (Front, Rear,
+                 Upper, Lower,
+                 Left,  Right);
+
+   function Size (Self : in Item) return Vector_3;
+
+
+
+private
+
+   type Item is abstract new Model.item with
+      record
+         Size : Vector_3;
+      end record;
+
+
+   type site_Id is ( Left_Lower_Front, Right_Lower_Front,
+                    Right_Upper_Front,  Left_Upper_Front,
+                    Right_Lower_Rear,   Left_Lower_Rear,
+                     Left_Upper_Rear,  Right_Upper_Rear);
+
+   type Sites is array (site_Id) of Site;
+
+
+   front_Normal : constant Vector_3 := [ 0.0,  0.0,  1.0];
+   rear_Normal  : constant Vector_3 := [ 0.0,  0.0, -1.0];
+   upper_Normal : constant Vector_3 := [ 0.0,  1.0,  0.0];
+   lower_Normal : constant Vector_3 := [ 0.0, -1.0,  0.0];
+   left_Normal  : constant Vector_3 := [-1.0,  0.0,  0.0];
+   right_Normal : constant Vector_3 := [ 1.0,  0.0,  0.0];
+
+   function vertex_Sites (Self : in Item'Class) return Sites;
+
+end openGL.Model.box;

3-mid/opengl/source/lean/model/opengl-model-capsule-lit_colored.adb

@@ -0,0 +1,371 @@
+with
+     openGL.Geometry.lit_colored,
+     openGL.Texture,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.capsule.lit_colored
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Color  : in lucid_Color) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius :=  Radius;
+      Self.Height :=  Height;
+      Self.Color  := +Color;
+
+      return Self;
+   end new_Capsule;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry,
+          Geometry.lit_colored,
+          real_Functions;
+
+      Length        : constant Real    := Self.Height;
+      Radius        : constant Real    := Self.Radius;
+
+      quality_Level : constant Index_t := 4;
+      sides_Count   : constant Index_t := Index_t (quality_Level * 4);     -- Number of sides to the cylinder (divisible by 4):
+
+      type Edge is   -- A 'shaft' edge.
+         record
+            Fore : Site;
+            Aft  : Site;
+         end record;
+
+      type      Edges is array (Index_t range 1 .. sides_Count)   of Edge;
+      type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
+
+      tmp,
+      nx, ny, nz,
+      start_nx,
+      start_ny   :          Real;
+      a          : constant Real := Pi * 2.0 / Real (sides_Count);
+      ca         : constant Real := Cos (a);
+      sa         : constant Real := Sin (a);
+      L          : constant Real := Length * 0.5;
+
+      the_Edges  : Edges;
+
+      the_shaft_Geometry : constant Geometry.lit_colored.view
+        := Geometry.lit_colored.new_Geometry;
+
+
+      cap_1_Geometry : Geometry.lit_colored.view;
+      cap_2_Geometry : Geometry.lit_colored.view;
+
+   begin
+      --  Define capsule shaft,
+      --
+      declare
+         vertex_Count  : constant      Index_t :=      Index_t (sides_Count * 2 + 2);   -- 2 triangles per side plus 2 since we cannot share the first and last edge.
+         indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3);   -- 2 triangles per side with 3 vertices per triangle.
+
+         the_Vertices  : aliased Geometry.lit_colored.Vertex_array := (1 .. vertex_Count  => <>);
+         the_Indices   : aliased Indices                           := (1 .. indices_Count => <>);
+
+      begin
+         ny := 1.0;
+         nz := 0.0;              -- Normal vector = (0.0, ny, nz)
+
+         -- Set vertices.
+         --
+         declare
+            use linear_Algebra;
+
+            S       :          Real    := 0.0;
+            S_delta : constant Real    := 1.0 / Real (sides_Count);
+
+            i       :          Index_t := 1;
+         begin
+            for Each in 1 .. Index_t (Edges'Length)
+            loop
+               the_Edges (Each).Fore (1) :=  ny * Radius;
+               the_Edges (Each).Fore (2) :=  nz * Radius;
+               the_Edges (Each).Fore (3) :=  L;
+
+               the_Edges (Each).Aft  (1) :=  ny * Radius;
+               the_Edges (Each).Aft  (2) :=  nz * Radius;
+               the_Edges (Each).Aft  (3) := -L;
+
+               --  Rotate ny, nz.
+               --
+               tmp := ca * ny  -  sa * nz;
+               nz  := sa * ny  +  ca * nz;
+               ny  := tmp;
+
+               the_Vertices (i).Site   := the_Edges (Each).Fore;
+               the_Vertices (i).Normal := Normalised ((the_Vertices (i).Site (1),
+                                                       the_Vertices (i).Site (2),
+                                                       0.0));
+               the_Vertices (i).Color  := Self.Color;
+               the_Vertices (i).Shine  := 0.5;
+               i := i + 1;
+
+               the_Vertices (i).Site   := the_Edges (Each).Aft;
+               the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
+               the_Vertices (i).Color  := Self.Color;
+               the_Vertices (i).Shine  := 0.5;
+               i := i + 1;
+
+               S := S + S_delta;
+            end loop;
+
+            the_Vertices (i).Site   := the_Edges (1).Fore;
+            the_Vertices (i).Normal := Normalised ((the_Vertices (i).Site (1),
+                                                    the_Vertices (i).Site (2),
+                                                    0.0));
+            the_Vertices (i).Color  := Self.Color;
+            the_Vertices (i).Shine  := 0.5;
+            i := i + 1;
+
+            the_Vertices (i).Site   := the_Edges (1).Aft;
+            the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
+            the_Vertices (i).Color  := Self.Color;
+            the_Vertices (i).Shine  := 0.5;
+         end;
+
+         -- Set indices.
+         --
+         declare
+            i     : long_Index_t := 1;
+            Start :      Index_t := 1;
+         begin
+            for Each in 1 .. long_Index_t (sides_Count)
+            loop
+               the_Indices (i) := Start;       i := i + 1;
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 3;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               Start := Start + 2;
+            end loop;
+         end;
+
+         Vertices_are (the_shaft_Geometry.all, the_Vertices);
+
+         declare
+            the_Primitive : constant Primitive.indexed.view
+              := Primitive.indexed.new_Primitive (primitive.Triangles,
+                                                  the_Indices);
+         begin
+            the_shaft_Geometry.add (Primitive.view (the_Primitive));
+         end;
+      end;
+
+
+      declare
+         function new_Cap (is_Fore : Boolean) return Geometry.lit_colored.view
+         is
+            use linear_Algebra;
+
+            cap_Geometry   : constant Geometry.lit_colored.view
+              := Geometry.lit_colored.new_Geometry;
+
+            hoop_Count     : constant      Index_t := quality_Level;
+            vertex_Count   : constant      Index_t :=      Index_t (Edges'Length * hoop_Count + 1);             -- A vertex for each edge of each hoop, + 1 for the pole.
+            indices_Count  : constant long_Index_t := long_Index_t (  (hoop_count - 1) * sides_Count * 2 * 3    -- For each hoop, 2 triangles per side with 3 vertices per triangle
+                                                                   + sides_Count * 3);                         -- plus the extra indices for the pole triangles.
+
+            the_Vertices   : aliased Geometry.lit_colored.Vertex_array := (1 ..  vertex_Count => <>);
+            the_Indices    : aliased Indices                           := (1 .. indices_Count => <>);
+
+            the_arch_Edges : arch_Edges;
+            i              : Index_t   := 1;
+
+            pole_Site      : constant Site := (if is_Fore then (0.0, 0.0,  L + Radius)
+                                                          else (0.0, 0.0, -L - Radius));
+
+            Degrees_90        : constant := Pi / 2.0;
+            Degrees_360       : constant := Pi * 2.0;
+
+            latitude_Count    : constant :=  hoop_Count + 1;
+            longitude_Count   : constant :=  Edges'Length;
+
+            latitude_Spacing  : constant Real := Degrees_90  / Real (latitude_Count - 1);
+            longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
+
+            a, b : Real := 0.0;          -- Angular 'cursors' used to track lat/long for texture coords.
+         begin
+            if not is_Fore
+            then
+               a := Degrees_360;
+            end if;
+
+            -- Set the vertices.
+            --
+            start_nx := 0.0;
+            start_ny := 1.0;
+
+            for each_Hoop in 1 .. quality_Level
+            loop
+               --  Get n=start_n.
+               --
+               nx := start_nx;
+               ny := start_ny;
+               nz := 0.0;
+
+               for Each in 1 .. sides_Count
+               loop
+                  the_arch_Edges (each_Hoop) (Each) (1) :=  ny * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (2) :=  nz * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (3) :=  (if is_Fore then nx * Radius + L
+                                                                        else nx * Radius - L);
+                  --  Rotate ny, nz.
+                  --
+                  tmp := ca * ny  -  sa * nz;
+                  nz  := sa * ny  +  ca * nz;
+                  ny  := tmp;
+
+                  the_Vertices (i).Site   := the_arch_Edges (each_Hoop) (Each);
+                  the_Vertices (i).Normal := Normalised ((the_Vertices (i).Site (1),
+                                                          the_Vertices (i).Site (2),
+                                                          (if is_Fore then the_Vertices (i).Site (3) - L
+                                                                      else the_Vertices (i).Site (3) + L)));
+                  the_Vertices (i).Color  := Self.Color;
+                  the_Vertices (i).Shine  := 0.5;
+                  i := i + 1;
+                  a := (if is_Fore then a + longitude_Spacing
+                                   else a - longitude_Spacing);
+               end loop;
+
+               declare
+                  tmp : constant Real := start_nx;
+               begin
+                  if is_Fore
+                  then
+                     start_nx :=  ca * start_nx  +  sa * start_ny;
+                     start_ny := -sa * tmp       +  ca * start_ny;
+                  else
+                     start_nx :=  ca * start_nx  -  sa * start_ny;
+                     start_ny :=  sa * tmp       +  ca * start_ny;
+                  end if;
+               end;
+
+               a := (if is_Fore then 0.0
+                                else Degrees_360);
+               b := b + latitude_Spacing;
+            end loop;
+
+            -- Add pole vertex.
+            --
+            the_Vertices (i).Site   := pole_Site;
+            the_Vertices (i).Normal := Normalised (pole_Site);
+            the_Vertices (i).Color  := Self.Color;
+            the_Vertices (i).Shine  := 0.5;
+
+            -- Set indices.
+            --
+            declare
+               i          :     long_Index_t := 1;
+               Start      :          Index_t := 1;
+               hoop_Start :          Index_t := 1;
+               pole_Index : constant Index_t := vertex_Count;
+
+            begin
+               for each_Hoop in 1 .. quality_Level
+               loop
+                  for Each in 1 .. sides_Count
+                  loop
+                     declare
+                        function next_hoop_Vertex return Index_t
+                        is
+                        begin
+                           if Each = sides_Count then return hoop_Start;
+                           else                       return Start + 1;
+                           end if;
+                        end next_hoop_Vertex;
+                     begin
+                        if each_Hoop = quality_Level
+                        then
+                           if is_Fore
+                           then
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                           else
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                           end if;
+                        else
+                           declare
+                              v1 : constant Index_t := Start;
+                              v2 : constant Index_t := next_hoop_Vertex;
+                              v3 : constant Index_t := v1 + sides_Count;
+                              v4 : constant Index_t := v2 + sides_Count;
+                           begin
+                              if is_Fore
+                              then
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                              else
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                              end if;
+                           end;
+                        end if;
+
+                        Start := Start + 1;
+                     end;
+                  end loop;
+
+                  hoop_Start := hoop_Start + sides_Count;
+               end loop;
+
+               Vertices_are (cap_Geometry.all, the_Vertices);
+
+               declare
+                  the_Primitive : constant Primitive.indexed.view
+                    := Primitive.indexed.new_Primitive (Primitive.Triangles,
+                                                        the_Indices);
+               begin
+                  cap_Geometry.add (Primitive.view (the_Primitive));
+               end;
+            end;
+
+            return cap_Geometry;
+         end new_Cap;
+
+      begin
+         cap_1_Geometry := new_Cap (is_Fore => True);
+         cap_2_Geometry := new_Cap (is_Fore => False);
+      end;
+
+      return (1 => the_shaft_Geometry.all'Access,
+              2 =>     cap_1_Geometry.all'Access,
+              3 =>     cap_2_Geometry.all'Access);
+   end to_GL_Geometries;
+
+
+end openGL.Model.capsule.lit_colored;

3-mid/opengl/source/lean/model/opengl-model-capsule-lit_colored.ads

@@ -0,0 +1,41 @@
+with
+     openGL.Geometry;
+
+
+package openGL.Model.capsule.lit_colored
+--
+--  Models a lit and colored capsule.
+--
+is
+   type Item is new Model.capsule.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Color  : in lucid_Color) 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;
+
+
+
+private
+
+   type Item is new Model.capsule.item with
+      record
+         Radius : Real;
+         Height : Real;
+         Color  : rgba_Color;
+      end record;
+
+end openGL.Model.capsule.lit_colored;

3-mid/opengl/source/lean/model/opengl-model-capsule-lit_colored_textured.adb

@@ -0,0 +1,412 @@
+with
+     openGL.Geometry.lit_colored_textured,
+     openGL.Texture,
+     openGL.IO,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.capsule.lit_colored_textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Color  : in lucid_Color;
+                         Image  : in asset_Name := null_Asset) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Height := Height;
+
+      Self.Color := +Color;
+      Self.Image := Image;
+
+      return Self;
+   end new_Capsule;
+
+
+   --------------
+   --- Attributes
+   --
+
+   type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
+
+
+   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 (Textures, Fonts);
+
+      use Geometry,
+          Geometry.lit_colored_textured,
+          real_Functions;
+
+      Length        : constant Real    := Self.Height;
+      Radius        : constant Real    := Self.Radius;
+
+      quality_Level : constant Index_t := 4;
+      sides_Count   : constant Index_t := Index_t (quality_Level * 4);     -- Number of sides to the cylinder (divisible by 4):
+
+      type Edge is   -- A 'shaft' edge.
+         record
+            Fore : Site;
+            Aft  : Site;
+         end record;
+
+      type      Edges is array (Index_t range 1 .. sides_Count)   of Edge;
+      type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
+
+      tmp,
+      nx, ny, nz,
+      start_nx,
+      start_ny   :          Real;
+      a          : constant Real := Pi * 2.0 / Real (sides_Count);
+      ca         : constant Real := Cos (a);
+      sa         : constant Real := Sin (a);
+      L          : constant Real := Length * 0.5;
+
+      the_Edges  : Edges;
+
+      the_shaft_Geometry  : constant Geometry_view
+        := Geometry_view (Geometry.lit_colored_textured.new_Geometry (texture_is_Alpha => False));
+
+      cap_1_Geometry : Geometry_view;
+      cap_2_Geometry : Geometry_view;
+
+   begin
+      --  Define capsule shaft,
+      --
+      declare
+         vertex_Count  : constant      Index_t :=      Index_t (sides_Count * 2 + 2);   -- 2 triangles per side plus 2 since we cannot share the first and last edge.
+         indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3);   -- 2 triangles per side with 3 vertices per triangle.
+
+         the_Vertices  : aliased Geometry.lit_colored_textured.Vertex_array := [1 .. vertex_Count  => <>];
+         the_Indices   : aliased Indices                                    := [1 .. indices_Count => <>];
+
+      begin
+         ny := 1.0;
+         nz := 0.0;              -- Normal vector = (0.0, ny, nz)
+
+         -- Set vertices.
+         --
+         declare
+            use linear_Algebra;
+
+            S       :          Real    := 0.0;
+            S_delta : constant Real    := 1.0 / Real (sides_Count);
+
+            i       :          Index_t := 1;
+         begin
+            for Each in 1 .. Index_t (Edges'Length)
+            loop
+               the_Edges (Each).Fore (1) :=  ny * Radius;
+               the_Edges (Each).Fore (2) :=  nz * Radius;
+               the_Edges (Each).Fore (3) :=  L;
+
+               the_Edges (Each).Aft  (1) :=  ny * Radius;
+               the_Edges (Each).Aft  (2) :=  nz * Radius;
+               the_Edges (Each).Aft  (3) := -L;
+
+               --  Rotate ny, nz.
+               --
+               tmp := ca * ny  -  sa * nz;
+               nz  := sa * ny  +  ca * nz;
+               ny  := tmp;
+
+               the_Vertices (i).Site   := the_Edges (Each).Fore;
+               the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
+                                                       the_Vertices (i).Site (2),
+                                                       0.0]);
+               the_Vertices (i).Color  := Self.Color;
+               the_Vertices (i).Shine  := 0.5;
+               the_Vertices (i).Coords := (s => S,
+                                           t => 1.0);
+               i := i + 1;
+
+               the_Vertices (i).Site   := the_Edges (Each).Aft;
+               the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
+               the_Vertices (i).Color  := Self.Color;
+               the_Vertices (i).Shine  := 0.5;
+               the_Vertices (i).Coords := (s => S,
+                                           t => 0.0);
+               i := i + 1;
+
+               S := S + S_delta;
+            end loop;
+
+            the_Vertices (i).Site   := the_Edges (1).Fore;
+            the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
+                                                    the_Vertices (i).Site (2),
+                                                    0.0]);
+            the_Vertices (i).Color  := Self.Color;
+            the_Vertices (i).Shine  := 0.5;
+            the_Vertices (i).Coords := (s => S,
+                                        t => 1.0);
+            i := i + 1;
+
+            the_Vertices (i).Site   := the_Edges (1).Aft;
+            the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
+            the_Vertices (i).Color  := Self.Color;
+            the_Vertices (i).Shine  := 0.5;
+            the_Vertices (i).Coords := (s => S,
+                                        t => 0.0);
+         end;
+
+         -- Set indices.
+         --
+         declare
+            i     : long_Index_t := 1;
+            Start :      Index_t := 1;
+         begin
+            for Each in 1 .. long_Index_t (sides_Count)
+            loop
+               the_Indices (i) := Start;       i := i + 1;
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 3;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               Start := Start + 2;
+            end loop;
+         end;
+
+         if Self.Image /= null_Asset
+         then
+            set_Texture:
+            declare
+               use Texture;
+               the_Image   : constant Image          := IO.to_Image      (Self.Image);
+               the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+            begin
+               the_shaft_Geometry.Texture_is (the_Texture);
+            end set_Texture;
+         end if;
+
+         Vertices_are (the_shaft_Geometry.all, the_Vertices);
+
+         declare
+            the_Primitive : constant Primitive.indexed.view
+              := Primitive.indexed.new_Primitive (primitive.Triangles,
+                                                  the_Indices);
+         begin
+            the_shaft_Geometry.add (Primitive.view (the_Primitive));
+         end;
+      end;
+
+
+      declare
+         function new_Cap (is_Fore : Boolean) return Geometry_view
+         is
+            use linear_Algebra;
+
+            cap_Geometry  : constant Geometry_view
+              := Geometry.lit_colored_textured.new_Geometry (texture_is_Alpha => False);
+
+            hoop_Count    : constant      Index_t := quality_Level;
+            vertex_Count  : constant      Index_t :=      Index_t (Edges'Length * hoop_Count + 1);             -- A vertex for each edge of each hoop, + 1 for the pole.
+            indices_Count : constant long_Index_t := long_Index_t (  (hoop_count - 1) * sides_Count * 2 * 3    -- For each hoop, 2 triangles per side with 3 vertices per triangle
+                                                                   + sides_Count * 3);                         -- plus the extra indices for the pole triangles.
+
+            the_Vertices  : aliased Geometry.lit_colored_textured.Vertex_array := [1 ..  vertex_Count => <>];
+            the_Indices   : aliased Indices                                    := [1 .. indices_Count => <>];
+
+            the_arch_Edges : arch_Edges;
+            i              : Index_t   := 1;
+
+            pole_Site      : constant Site := (if is_Fore then [0.0, 0.0,  L + Radius]
+                                                          else [0.0, 0.0, -L - Radius]);
+
+            Degrees_90        : constant := Pi / 2.0;
+            Degrees_360       : constant := Pi * 2.0;
+
+            latitude_Count    : constant :=  hoop_Count + 1;
+            longitude_Count   : constant :=  Edges'Length;
+
+            latitude_Spacing  : constant Real := Degrees_90  / Real (latitude_Count - 1);
+            longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
+
+            a, b : Real := 0.0;          -- Angular 'cursors' used to track lat/long for texture coords.
+         begin
+            if not is_Fore
+            then
+               a := Degrees_360;
+            end if;
+
+            -- Set the vertices.
+            --
+            start_nx := 0.0;
+            start_ny := 1.0;
+
+            for each_Hoop in 1 .. quality_Level
+            loop
+               --  Get n=start_n.
+               --
+               nx := start_nx;
+               ny := start_ny;
+               nz := 0.0;
+
+               for Each in 1 .. sides_Count
+               loop
+                  the_arch_Edges (each_Hoop) (Each) (1) :=  ny * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (2) :=  nz * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (3) :=  (if is_Fore then nx * Radius + L
+                                                                        else nx * Radius - L);
+                  --  Rotate ny, nz.
+                  --
+                  tmp := ca * ny  -  sa * nz;
+                  nz  := sa * ny  +  ca * nz;
+                  ny  := tmp;
+
+                  the_Vertices (i).Site   := the_arch_Edges (each_Hoop) (Each);
+                  the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
+                                                          the_Vertices (i).Site (2),
+                                                          (if is_Fore then the_Vertices (i).Site (3) - L
+                                                                      else the_Vertices (i).Site (3) + L)]);
+                  the_Vertices (i).Color  := Self.Color;
+                  the_Vertices (i).Shine  := 0.5;
+                  the_Vertices (i).Coords :=  (s => a / Degrees_360,
+                                               t => b / Degrees_90);
+                  i := i + 1;
+                  a := (if is_Fore then a + longitude_Spacing
+                                   else a - longitude_Spacing);
+               end loop;
+
+               declare
+                  tmp : constant Real := start_nx;
+               begin
+                  if is_Fore
+                  then
+                     start_nx :=  ca * start_nx  +  sa * start_ny;
+                     start_ny := -sa * tmp       +  ca * start_ny;
+                  else
+                     start_nx :=  ca * start_nx  -  sa * start_ny;
+                     start_ny :=  sa * tmp       +  ca * start_ny;
+                  end if;
+               end;
+
+               a := (if is_Fore then 0.0
+                                else Degrees_360);
+               b := b + latitude_Spacing;
+            end loop;
+
+            -- Add pole vertex.
+            --
+            the_Vertices (i).Site   := pole_Site;
+            the_Vertices (i).Normal := Normalised (pole_Site);
+            the_Vertices (i).Color  := Self.Color;
+            the_Vertices (i).Shine  := 0.5;
+            the_Vertices (i).Coords := (s => 0.5,
+                                        t => 1.0);
+            -- Set indices.
+            --
+            declare
+               i          :     long_Index_t := 1;
+               Start      :          Index_t := 1;
+               hoop_Start :          Index_t := 1;
+               pole_Index : constant Index_t := vertex_Count;
+
+            begin
+               for each_Hoop in 1 .. quality_Level
+               loop
+                  for Each in 1 .. sides_Count
+                  loop
+                     declare
+                        function next_hoop_Vertex return Index_t
+                        is
+                        begin
+                           if Each = sides_Count then return hoop_Start;
+                           else                       return Start + 1;
+                           end if;
+                        end next_hoop_Vertex;
+                     begin
+                        if each_Hoop = quality_Level
+                        then
+                           if is_Fore
+                           then
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                           else
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                           end if;
+                        else
+                           declare
+                              v1 : constant Index_t := Start;
+                              v2 : constant Index_t := next_hoop_Vertex;
+                              v3 : constant Index_t := v1 + sides_Count;
+                              v4 : constant Index_t := v2 + sides_Count;
+                           begin
+                              if is_Fore
+                              then
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                              else
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                              end if;
+                           end;
+                        end if;
+
+                        Start := Start + 1;
+                     end;
+                  end loop;
+
+                  hoop_Start := hoop_Start + sides_Count;
+               end loop;
+
+               if Self.Image /= null_Asset
+               then
+                  set_the_Texture:
+                  declare
+                     use Texture;
+                     the_Image   : constant Image          := IO.to_Image      (Self.Image);
+                     the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+                  begin
+                     cap_Geometry.Texture_is (the_Texture);
+                  end set_the_Texture;
+               end if;
+
+               Vertices_are (cap_Geometry.all, the_Vertices);
+
+               declare
+                  the_Primitive : constant Primitive.indexed.view
+                    := Primitive.indexed.new_Primitive (Primitive.Triangles,
+                                                        the_Indices);
+               begin
+                  cap_Geometry.add (Primitive.view (the_Primitive));
+               end;
+            end;
+
+            return cap_Geometry;
+         end new_Cap;
+
+      begin
+         cap_1_Geometry := new_Cap (is_Fore => True);
+         cap_2_Geometry := new_Cap (is_Fore => False);
+      end;
+
+      return [1 => the_shaft_Geometry.all'Access,
+              2 =>     cap_1_Geometry.all'Access,
+              3 =>     cap_2_Geometry.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.capsule.lit_colored_textured;

3-mid/opengl/source/lean/model/opengl-model-capsule-lit_colored_textured.ads

@@ -0,0 +1,44 @@
+with
+     openGL.Geometry;
+
+
+package openGL.Model.capsule.lit_colored_textured
+--
+--  Models a lit, colored and textured capsule.
+--
+is
+   type Item is new Model.capsule.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Color  : in lucid_Color;
+                         Image  : in asset_Name := null_Asset) 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;
+
+
+
+private
+
+   type Item is new Model.capsule.item with
+      record
+         Radius : Real;
+         Height : Real;
+
+         Color  : rgba_Color;
+         Image  : asset_Name := null_Asset;
+      end record;
+
+end openGL.Model.capsule.lit_colored_textured;

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

@@ -0,0 +1,403 @@
+with
+     openGL.Geometry.lit_textured,
+     openGL.Texture,
+     openGL.IO,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.capsule.lit_textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Image  : in asset_Name := null_Asset) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Height := Height;
+      Self.Image  := Image;
+
+      return Self;
+   end new_Capsule;
+
+
+   --------------
+   --- Attributes
+   --
+
+--     type Geometry_view is access all Geometry.lit_textured.item'Class;
+
+
+   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 (Textures, Fonts);
+
+      use Geometry,
+          Geometry.lit_textured,
+          real_Functions;
+
+      Length        : constant Real    := Self.Height;
+      Radius        : constant Real    := Self.Radius;
+
+      quality_Level : constant Index_t := 4;
+      sides_Count   : constant Index_t := Index_t (quality_Level * 4);     -- Number of sides to the cylinder (divisible by 4):
+
+      type Edge is   -- A 'shaft' edge.
+         record
+            Fore : Site;
+            Aft  : Site;
+         end record;
+
+      type      Edges is array (Index_t range 1 .. sides_Count)   of Edge;
+      type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
+
+      tmp,
+      nx, ny, nz,
+      start_nx,
+      start_ny   :          Real;
+      a          : constant Real := Pi * 2.0 / Real (sides_Count);
+      ca         : constant Real := Cos (a);
+      sa         : constant Real := Sin (a);
+      L          : constant Real := Length * 0.5;
+
+      the_Edges  : Edges;
+
+      the_shaft_Geometry  : constant Geometry.lit_textured.view
+        := Geometry.lit_textured.new_Geometry;
+
+      cap_1_Geometry : Geometry.lit_textured.view;
+      cap_2_Geometry : Geometry.lit_textured.view;
+
+   begin
+      --  Define capsule shaft,
+      --
+      declare
+         vertex_Count  : constant      Index_t :=      Index_t (sides_Count * 2 + 2);   -- 2 triangles per side plus 2 since we cannot share the first and last edge.
+         indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3);   -- 2 triangles per side with 3 vertices per triangle.
+
+         the_Vertices  : aliased Geometry.lit_textured.Vertex_array := [1 .. vertex_Count  => <>];
+         the_Indices   : aliased Indices                            := [1 .. indices_Count => <>];
+
+      begin
+         ny := 1.0;
+         nz := 0.0;              -- Normal vector = (0.0, ny, nz)
+
+         -- Set vertices.
+         --
+         declare
+            use linear_Algebra;
+
+            S       :          Real    := 0.0;
+            S_delta : constant Real    := 1.0 / Real (sides_Count);
+
+            i       :          Index_t := 1;
+         begin
+            for Each in 1 .. Index_t (Edges'Length)
+            loop
+               the_Edges (Each).Fore (1) :=  ny * Radius;
+               the_Edges (Each).Fore (2) :=  nz * Radius;
+               the_Edges (Each).Fore (3) :=  L;
+
+               the_Edges (Each).Aft  (1) :=  ny * Radius;
+               the_Edges (Each).Aft  (2) :=  nz * Radius;
+               the_Edges (Each).Aft  (3) := -L;
+
+               --  Rotate ny, nz.
+               --
+               tmp := ca * ny  -  sa * nz;
+               nz  := sa * ny  +  ca * nz;
+               ny  := tmp;
+
+               the_Vertices (i).Site   := the_Edges (Each).Fore;
+               the_Vertices (i).Shine  := 0.5;
+               the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
+                                                       the_Vertices (i).Site (2),
+                                                       0.0]);
+               the_Vertices (i).Coords := (s => S,
+                                           t => 1.0);
+               i := i + 1;
+
+               the_Vertices (i).Site   := the_Edges (Each).Aft;
+               the_Vertices (i).Shine  := 0.5;
+               the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
+               the_Vertices (i).Coords := (s => S,
+                                           t => 0.0);
+               i := i + 1;
+
+               S := S + S_delta;
+            end loop;
+
+            the_Vertices (i).Site   := the_Edges (1).Fore;
+            the_Vertices (i).Shine  := 0.5;
+            the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
+                                                    the_Vertices (i).Site (2),
+                                                    0.0]);
+            the_Vertices (i).Coords := (s => S,
+                                        t => 1.0);
+            i := i + 1;
+
+            the_Vertices (i).Site   := the_Edges (1).Aft;
+            the_Vertices (i).Shine  := 0.5;
+            the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
+            the_Vertices (i).Coords := (s => S,
+                                        t => 0.0);
+         end;
+
+         -- Set indices.
+         --
+         declare
+            i     : long_Index_t := 1;
+            Start :      Index_t := 1;
+         begin
+            for Each in 1 .. long_Index_t (sides_Count)
+            loop
+               the_Indices (i) := Start;       i := i + 1;
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 3;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               Start := Start + 2;
+            end loop;
+         end;
+
+         if Self.Image /= null_Asset
+         then
+            set_Texture:
+            declare
+               use Texture;
+               the_Image   : constant Image          := IO.to_Image      (Self.Image);
+               the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+            begin
+               the_shaft_Geometry.Texture_is (the_Texture);
+            end set_Texture;
+         end if;
+
+         Vertices_are (the_shaft_Geometry.all, the_Vertices);
+
+         declare
+            the_Primitive : constant Primitive.indexed.view
+              := Primitive.indexed.new_Primitive (primitive.Triangles,
+                                                  the_Indices);
+         begin
+            the_shaft_Geometry.add (Primitive.view (the_Primitive));
+         end;
+      end;
+
+
+      declare
+         function new_Cap (is_Fore : Boolean) return Geometry.lit_textured.view
+         is
+            use linear_Algebra;
+
+            cap_Geometry  : constant Geometry.lit_textured.view
+              := Geometry.lit_textured.new_Geometry;
+
+            hoop_Count    : constant      Index_t := quality_Level;
+            vertex_Count  : constant      Index_t :=      Index_t (Edges'Length * hoop_Count + 1);             -- A vertex for each edge of each hoop, + 1 for the pole.
+            indices_Count : constant long_Index_t := long_Index_t (  (hoop_count - 1) * sides_Count * 2 * 3    -- For each hoop, 2 triangles per side with 3 vertices per triangle
+                                                                   + sides_Count * 3);                         -- plus the extra indices for the pole triangles.
+
+            the_Vertices  : aliased Geometry.lit_textured.Vertex_array := [1 ..  vertex_Count => <>];
+            the_Indices   : aliased Indices                            := [1 .. indices_Count => <>];
+
+            the_arch_Edges : arch_Edges;
+            i              : Index_t   := 1;
+
+            pole_Site      : constant Site := (if is_Fore then [0.0, 0.0,  L + Radius]
+                                                          else [0.0, 0.0, -L - Radius]);
+
+            Degrees_90        : constant := Pi / 2.0;
+            Degrees_360       : constant := Pi * 2.0;
+
+            latitude_Count    : constant :=  hoop_Count + 1;
+            longitude_Count   : constant :=  Edges'Length;
+
+            latitude_Spacing  : constant Real := Degrees_90  / Real (latitude_Count - 1);
+            longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
+
+            a, b : Real := 0.0;          -- Angular 'cursors' used to track lat/long for texture coords.
+         begin
+            if not is_Fore
+            then
+               a := Degrees_360;
+            end if;
+
+            -- Set the vertices.
+            --
+            start_nx := 0.0;
+            start_ny := 1.0;
+
+            for each_Hoop in 1 .. quality_Level
+            loop
+               --  Get n=start_n.
+               --
+               nx := start_nx;
+               ny := start_ny;
+               nz := 0.0;
+
+               for Each in 1 .. sides_Count
+               loop
+                  the_arch_Edges (each_Hoop) (Each) (1) :=  ny * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (2) :=  nz * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (3) :=  (if is_Fore then nx * Radius + L
+                                                                        else nx * Radius - L);
+                  --  Rotate ny, nz.
+                  --
+                  tmp := ca * ny  -  sa * nz;
+                  nz  := sa * ny  +  ca * nz;
+                  ny  := tmp;
+
+                  the_Vertices (i).Site   := the_arch_Edges (each_Hoop) (Each);
+                  the_Vertices (i).Shine  := 0.5;
+                  the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
+                                                          the_Vertices (i).Site (2),
+                                                          (if is_Fore then the_Vertices (i).Site (3) - L
+                                                                      else the_Vertices (i).Site (3) + L)]);
+                  the_Vertices (i).Coords :=  (s => a / Degrees_360,
+                                               t => b / Degrees_90);
+                  i := i + 1;
+                  a := (if is_Fore then a + longitude_Spacing
+                                   else a - longitude_Spacing);
+               end loop;
+
+               declare
+                  tmp : constant Real := start_nx;
+               begin
+                  if is_Fore
+                  then
+                     start_nx :=  ca * start_nx  +  sa * start_ny;
+                     start_ny := -sa * tmp       +  ca * start_ny;
+                  else
+                     start_nx :=  ca * start_nx  -  sa * start_ny;
+                     start_ny :=  sa * tmp       +  ca * start_ny;
+                  end if;
+               end;
+
+               a := (if is_Fore then 0.0
+                                else Degrees_360);
+               b := b + latitude_Spacing;
+            end loop;
+
+            -- Add pole vertex.
+            --
+            the_Vertices (i).Site   := pole_Site;
+            the_Vertices (i).Shine  := 0.5;
+            the_Vertices (i).Normal := Normalised (pole_Site);
+            the_Vertices (i).Coords := (s => 0.5,
+                                        t => 1.0);
+            -- Set indices.
+            --
+            declare
+               i          :     long_Index_t := 1;
+               Start      :          Index_t := 1;
+               hoop_Start :          Index_t := 1;
+               pole_Index : constant Index_t := vertex_Count;
+
+            begin
+               for each_Hoop in 1 .. quality_Level
+               loop
+                  for Each in 1 .. sides_Count
+                  loop
+                     declare
+                        function next_hoop_Vertex return Index_t
+                        is
+                        begin
+                           if Each = sides_Count then return hoop_Start;
+                           else                       return Start + 1;
+                           end if;
+                        end next_hoop_Vertex;
+                     begin
+                        if each_Hoop = quality_Level
+                        then
+                           if is_Fore
+                           then
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                           else
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                           end if;
+                        else
+                           declare
+                              v1 : constant Index_t := Start;
+                              v2 : constant Index_t := next_hoop_Vertex;
+                              v3 : constant Index_t := v1 + sides_Count;
+                              v4 : constant Index_t := v2 + sides_Count;
+                           begin
+                              if is_Fore
+                              then
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                              else
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                              end if;
+                           end;
+                        end if;
+
+                        Start := Start + 1;
+                     end;
+                  end loop;
+
+                  hoop_Start := hoop_Start + sides_Count;
+               end loop;
+
+               if Self.Image /= null_Asset
+               then
+                  set_the_Texture:
+                  declare
+                     use Texture;
+                     the_Image   : constant Image          := IO.to_Image      (Self.Image);
+                     the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+                  begin
+                     cap_Geometry.Texture_is (the_Texture);
+                  end set_the_Texture;
+               end if;
+
+               Vertices_are (cap_Geometry.all, the_Vertices);
+
+               declare
+                  the_Primitive : constant Primitive.indexed.view
+                    := Primitive.indexed.new_Primitive (Primitive.Triangles,
+                                                        the_Indices);
+               begin
+                  cap_Geometry.add (Primitive.view (the_Primitive));
+               end;
+            end;
+
+            return cap_Geometry;
+         end new_Cap;
+
+      begin
+         cap_1_Geometry := new_Cap (is_Fore => True);
+         cap_2_Geometry := new_Cap (is_Fore => False);
+      end;
+
+      return [1 => the_shaft_Geometry.all'Access,
+              2 =>     cap_1_Geometry.all'Access,
+              3 =>     cap_2_Geometry.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.capsule.lit_textured;

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

@@ -0,0 +1,42 @@
+with
+     openGL.Geometry;
+
+
+package openGL.Model.capsule.lit_textured
+--
+--  Models a lit and textured capsule.
+--
+is
+   type Item is new Model.capsule.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Image  : in asset_Name := null_Asset) 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;
+
+
+
+private
+
+   type Item is new Model.capsule.item with
+      record
+         Radius : Real;
+         Height : Real;
+
+         Image  : asset_Name := null_Asset;
+      end record;
+
+end openGL.Model.capsule.lit_textured;

3-mid/opengl/source/lean/model/opengl-model-capsule-textured.adb

@@ -0,0 +1,377 @@
+with
+     openGL.Geometry.textured,
+     openGL.Texture,
+     openGL.IO,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.capsule.textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Image  : in asset_Name := null_Asset) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Height := Height;
+      Self.Image  := Image;
+
+      return Self;
+   end new_Capsule;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use --Geometry,
+          Geometry.textured,
+          real_Functions;
+
+      Length        : constant Real    := Self.Height;
+      Radius        : constant Real    := Self.Radius;
+
+      quality_Level : constant Index_t := 4;
+      sides_Count   : constant Index_t := Index_t (quality_Level * 4);     -- Number of sides to the cylinder (divisible by 4):
+
+      type Edge is   -- A 'shaft' edge.
+         record
+            Fore : Site;
+            Aft  : Site;
+         end record;
+
+      type      Edges is array (Index_t range 1 .. sides_Count)   of Edge;
+      type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
+
+      tmp,
+      nx, ny, nz,
+      start_nx,
+      start_ny   :          Real;
+      a          : constant Real := Pi * 2.0 / Real (sides_Count);
+      ca         : constant Real := Cos (a);
+      sa         : constant Real := Sin (a);
+      L          : constant Real := Length * 0.5;
+
+      the_Edges  : Edges;
+
+      the_shaft_Geometry  : constant Geometry.textured.view
+        := Geometry.textured.new_Geometry;
+
+      cap_1_Geometry : Geometry.textured.view;
+      cap_2_Geometry : Geometry.textured.view;
+
+   begin
+      --  Define capsule shaft,
+      --
+      declare
+         vertex_Count  : constant      Index_t :=      Index_t (sides_Count * 2 + 2);   -- 2 triangles per side plus 2 since we cannot share the first and last edge.
+         indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3);   -- 2 triangles per side with 3 vertices per triangle.
+
+         the_Vertices  : aliased Geometry.textured.Vertex_array := (1 .. vertex_Count  => <>);
+         the_Indices   : aliased Indices                        := (1 .. indices_Count => <>);
+
+      begin
+         ny := 1.0;
+         nz := 0.0;              -- Normal vector = (0.0, ny, nz)
+
+         -- Set vertices.
+         --
+         declare
+            S       :          Real    := 0.0;
+            S_delta : constant Real    := 1.0 / Real (sides_Count);
+
+            i       :          Index_t := 1;
+         begin
+            for Each in 1 .. Index_t (Edges'Length)
+            loop
+               the_Edges (Each).Fore (1) :=  ny * Radius;
+               the_Edges (Each).Fore (2) :=  nz * Radius;
+               the_Edges (Each).Fore (3) :=  L;
+
+               the_Edges (Each).Aft  (1) :=  ny * Radius;
+               the_Edges (Each).Aft  (2) :=  nz * Radius;
+               the_Edges (Each).Aft  (3) := -L;
+
+               --  Rotate ny, nz.
+               --
+               tmp := ca * ny  -  sa * nz;
+               nz  := sa * ny  +  ca * nz;
+               ny  := tmp;
+
+               the_Vertices (i).Site   := the_Edges (Each).Fore;
+               the_Vertices (i).Coords := (s => S,
+                                           t => 1.0);
+               i := i + 1;
+
+               the_Vertices (i).Site   := the_Edges (Each).Aft;
+               the_Vertices (i).Coords := (s => S,
+                                           t => 0.0);
+               i := i + 1;
+
+               S := S + S_delta;
+            end loop;
+
+            the_Vertices (i).Site   := the_Edges (1).Fore;
+            the_Vertices (i).Coords := (s => S,
+                                        t => 1.0);
+            i := i + 1;
+
+            the_Vertices (i).Site   := the_Edges (1).Aft;
+            the_Vertices (i).Coords := (s => S,
+                                        t => 0.0);
+         end;
+
+         -- Set indices.
+         --
+         declare
+            i     : long_Index_t := 1;
+            Start :      Index_t := 1;
+         begin
+            for Each in 1 .. long_Index_t (sides_Count)
+            loop
+               the_Indices (i) := Start;       i := i + 1;
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               the_Indices (i) := Start + 1;   i := i + 1;
+               the_Indices (i) := Start + 3;   i := i + 1;
+               the_Indices (i) := Start + 2;   i := i + 1;
+
+               Start := Start + 2;
+            end loop;
+         end;
+
+         if Self.Image /= null_Asset
+         then
+            set_Texture:
+            declare
+               use Texture;
+               the_Image   : constant Image          := IO.to_Image      (Self.Image);
+               the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+            begin
+               the_shaft_Geometry.Texture_is (the_Texture);
+            end set_Texture;
+         end if;
+
+         Vertices_are (the_shaft_Geometry.all, the_Vertices);
+
+         declare
+            the_Primitive : constant Primitive.indexed.view
+              := Primitive.indexed.new_Primitive (primitive.Triangles,
+                                                  the_Indices);
+         begin
+            the_shaft_Geometry.add (Primitive.view (the_Primitive));
+         end;
+      end;
+
+
+      declare
+         function new_Cap (is_Fore : Boolean) return Geometry.textured.view
+         is
+            cap_Geometry  : constant Geometry.textured.view
+              := Geometry.textured.new_Geometry;
+
+            hoop_Count    : constant      Index_t := quality_Level;
+            vertex_Count  : constant      Index_t :=      Index_t (Edges'Length * hoop_Count + 1);             -- A vertex for each edge of each hoop, + 1 for the pole.
+            indices_Count : constant long_Index_t := long_Index_t (  (hoop_count - 1) * sides_Count * 2 * 3    -- For each hoop, 2 triangles per side with 3 vertices per triangle
+                                                                   + sides_Count * 3);                         -- plus the extra indices for the pole triangles.
+
+            the_Vertices  : aliased Geometry.textured.Vertex_array := (1 ..  vertex_Count => <>);
+            the_Indices   : aliased Indices                        := (1 .. indices_Count => <>);
+
+            the_arch_Edges : arch_Edges;
+            i              : Index_t   := 1;
+
+            pole_Site      : constant Site := (if is_Fore then (0.0, 0.0,  L + Radius)
+                                                          else (0.0, 0.0, -L - Radius));
+
+            Degrees_90        : constant := Pi / 2.0;
+            Degrees_360       : constant := Pi * 2.0;
+
+            latitude_Count    : constant :=  hoop_Count + 1;
+            longitude_Count   : constant :=  Edges'Length;
+
+            latitude_Spacing  : constant Real := Degrees_90  / Real (latitude_Count - 1);
+            longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
+
+            a, b : Real := 0.0;          -- Angular 'cursors' used to track lat/long for texture coords.
+         begin
+            if not is_Fore
+            then
+               a := Degrees_360;
+            end if;
+
+            -- Set the vertices.
+            --
+            start_nx := 0.0;
+            start_ny := 1.0;
+
+            for each_Hoop in 1 .. quality_Level
+            loop
+               --  Get n=start_n.
+               --
+               nx := start_nx;
+               ny := start_ny;
+               nz := 0.0;
+
+               for Each in 1 .. sides_Count
+               loop
+                  the_arch_Edges (each_Hoop) (Each) (1) :=  ny * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (2) :=  nz * Radius;
+                  the_arch_Edges (each_Hoop) (Each) (3) :=  (if is_Fore then nx * Radius + L
+                                                                        else nx * Radius - L);
+                  --  Rotate ny, nz.
+                  --
+                  tmp := ca * ny  -  sa * nz;
+                  nz  := sa * ny  +  ca * nz;
+                  ny  := tmp;
+
+                  the_Vertices (i).Site   := the_arch_Edges (each_Hoop) (Each);
+                  the_Vertices (i).Coords :=  (s => a / Degrees_360,
+                                               t => b / Degrees_90);
+                  i := i + 1;
+                  a := (if is_Fore then a + longitude_Spacing
+                                   else a - longitude_Spacing);
+               end loop;
+
+               declare
+                  tmp : constant Real := start_nx;
+               begin
+                  if is_Fore
+                  then
+                     start_nx :=  ca * start_nx  +  sa * start_ny;
+                     start_ny := -sa * tmp       +  ca * start_ny;
+                  else
+                     start_nx :=  ca * start_nx  -  sa * start_ny;
+                     start_ny :=  sa * tmp       +  ca * start_ny;
+                  end if;
+               end;
+
+               a := (if is_Fore then 0.0
+                                else Degrees_360);
+               b := b + latitude_Spacing;
+            end loop;
+
+            -- Add pole vertex.
+            --
+            the_Vertices (i).Site   := pole_Site;
+            the_Vertices (i).Coords := (s => 0.5,
+                                        t => 1.0);
+            -- Set indices.
+            --
+            declare
+               i          :     long_Index_t := 1;
+               Start      :          Index_t := 1;
+               hoop_Start :          Index_t := 1;
+               pole_Index : constant Index_t := vertex_Count;
+
+            begin
+               for each_Hoop in 1 .. quality_Level
+               loop
+                  for Each in 1 .. sides_Count
+                  loop
+                     declare
+                        function next_hoop_Vertex return Index_t
+                        is
+                        begin
+                           if Each = sides_Count then return hoop_Start;
+                           else                       return Start + 1;
+                           end if;
+                        end next_hoop_Vertex;
+                     begin
+                        if each_Hoop = quality_Level
+                        then
+                           if is_Fore
+                           then
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                           else
+                              the_Indices (i) := Start;              i := i + 1;
+                              the_Indices (i) := pole_Index;         i := i + 1;
+                              the_Indices (i) := next_hoop_Vertex;   i := i + 1;
+                           end if;
+                        else
+                           declare
+                              v1 : constant Index_t := Start;
+                              v2 : constant Index_t := next_hoop_Vertex;
+                              v3 : constant Index_t := v1 + sides_Count;
+                              v4 : constant Index_t := v2 + sides_Count;
+                           begin
+                              if is_Fore
+                              then
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                              else
+                                 the_Indices (i) := v1;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v2;   i := i + 1;
+
+                                 the_Indices (i) := v2;   i := i + 1;
+                                 the_Indices (i) := v3;   i := i + 1;
+                                 the_Indices (i) := v4;   i := i + 1;
+                              end if;
+                           end;
+                        end if;
+
+                        Start := Start + 1;
+                     end;
+                  end loop;
+
+                  hoop_Start := hoop_Start + sides_Count;
+               end loop;
+
+               if Self.Image /= null_Asset
+               then
+                  set_the_Texture:
+                  declare
+                     use Texture;
+                     the_Image   : constant Image          := IO.to_Image      (Self.Image);
+                     the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
+                  begin
+                     cap_Geometry.Texture_is (the_Texture);
+                  end set_the_Texture;
+               end if;
+
+               Vertices_are (cap_Geometry.all, the_Vertices);
+
+               declare
+                  the_Primitive : constant Primitive.indexed.view
+                    := Primitive.indexed.new_Primitive (Primitive.Triangles,
+                                                        the_Indices);
+               begin
+                  cap_Geometry.add (Primitive.view (the_Primitive));
+               end;
+            end;
+
+            return cap_Geometry;
+         end new_Cap;
+
+      begin
+         cap_1_Geometry := new_Cap (is_Fore => True);
+         cap_2_Geometry := new_Cap (is_Fore => False);
+      end;
+
+      return (1 => the_shaft_Geometry.all'Access,
+              2 =>     cap_1_Geometry.all'Access,
+              3 =>     cap_2_Geometry.all'Access);
+   end to_GL_Geometries;
+
+
+end openGL.Model.capsule.textured;

3-mid/opengl/source/lean/model/opengl-model-capsule-textured.ads

@@ -0,0 +1,42 @@
+with
+     openGL.Geometry;
+
+
+package openGL.Model.capsule.textured
+--
+--  Models a lit and textured capsule.
+--
+is
+   type Item is new Model.capsule.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Capsule (Radius : in Real;
+                         Height : in Real;
+                         Image  : in asset_Name := null_Asset) 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;
+
+
+
+private
+
+   type Item is new Model.capsule.item with
+      record
+         Radius : Real;
+         Height : Real;
+
+         Image  : asset_Name := null_Asset;
+      end record;
+
+end openGL.Model.capsule.textured;

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

@@ -0,0 +1,9 @@
+package openGL.Model.capsule
+--
+--  Provides an abstract base class for capsule models.
+--
+is
+
+   type Item is abstract new openGL.Model.item with null record;
+
+end openGL.Model.capsule;

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

@@ -0,0 +1,172 @@
+with
+     openGL.Palette,
+     openGL.Primitive.non_indexed;
+
+
+package body openGL.Model.grid
+is
+
+   function Line_Count (Extent : in Positive) return Positive
+   is
+   begin
+      if Extent mod 2  /=  0
+      then
+         return Extent;
+      else
+         return Extent + 1;
+      end if;
+   end Line_Count;
+
+
+   ---------
+   --- Forge
+   --
+
+   function to_grid_Model (Color  : openGL.Color;
+                           Width  : Integer;
+                           Height : Integer) return Item
+   is
+      Self : Item;
+
+      vertex_Count : constant Positive := (  line_Count (Width)
+                                           + line_Count (Height))  *  2;
+
+      half_Width   : constant Real := Real (Width)  / 2.0;
+      half_Height  : constant Real := Real (Height) / 2.0;
+   begin
+      Self.Color  := +Color;
+      Self.Width  := Width;
+      Self.Height := Height;
+      Self.Bounds := (Ball => <>,
+                      Box  => (lower => [-half_Width, -half_Height, -0.01],
+                               upper => [ half_Width,  half_Height,  0.01]));
+      set_Ball_from_Box (Self.Bounds);
+
+      Self.Vertices := new Geometry.colored.Vertex_array (1 .. Index_t (vertex_Count));
+
+      return Self;
+   end to_grid_Model;
+
+
+   function new_grid_Model (Color  : openGL.Color;
+                            Width  : Integer;
+                            Height : Integer) return View
+   is
+   begin
+      return new Item' (to_grid_Model (Color, Width, Height));
+   end new_grid_Model;
+
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Palette,
+          Geometry.colored;
+
+      the_Primitive : Primitive.non_indexed.view;
+
+   begin
+      if Self.Geometry = null
+      then
+         Self.Geometry := Geometry.colored.new_Geometry;
+      end if;
+
+      set_Sites :
+      declare
+         row_Count    : constant Positive := line_Count (Self.Height);
+         col_Count    : constant Positive := line_Count (Self.Width);
+         vertex_Count :          Index_t  := 0;
+
+         half_Width   : constant Real     := Real (Self.Width)  / 2.0;
+         half_Height  : constant Real     := Real (Self.Height) / 2.0;
+
+         x_Adjust,
+         y_Adjust : Real;
+
+         Color : openGL.rgb_Color := Self.Color;
+
+      begin
+         if Self.Width  mod 2 = 0
+         then   x_Adjust := 0.0;
+         else   x_Adjust := 0.5;
+         end if;
+
+         if Self.Height mod 2 = 0
+         then   y_Adjust := 0.0;
+         else   y_Adjust := 0.5;
+         end if;
+
+         for Row in 1 .. row_Count
+         loop
+            if Row = row_Count / 2 + 1
+            then
+               Color := +White;
+            end if;
+
+            vertex_Count                       := vertex_Count + 1;
+            Self.Vertices (vertex_Count).Site  := [-half_Width,
+                                                   Real (Row - 1) - half_Height + y_Adjust,
+                                                   0.16];
+            Self.Vertices (vertex_Count).Color := (primary => Color,
+                                                   Alpha => opaque_Value);
+
+            vertex_Count                       := vertex_Count + 1;
+            Self.Vertices (vertex_Count).Site  := [half_Width,
+                                                   Real (Row - 1) - half_Height + y_Adjust,
+                                                   0.16];
+            Self.Vertices (vertex_Count).Color := (primary => Color,
+                                                   Alpha   => opaque_Value);
+            if Row = row_Count / 2 + 1
+            then
+               Color := Self.Color;
+            end if;
+         end loop;
+
+         for Col in 1 .. col_Count
+         loop
+            if Col = col_Count / 2 + 1
+            then
+               Color := +White;
+            end if;
+
+            vertex_Count                       := vertex_Count + 1;
+            Self.Vertices (vertex_Count).Site  := [Real (Col - 1) - half_Width + x_Adjust,
+                                                   -half_Height,
+                                                   0.16];
+            Self.Vertices (vertex_Count).Color := (primary => Color,
+                                                   Alpha   => opaque_Value);
+
+            vertex_Count                       := vertex_Count + 1;
+            Self.Vertices (vertex_Count).Site  := [Real (Col - 1) - half_Width + x_Adjust,
+                                                   half_Height,
+                                                   0.16];
+            Self.Vertices (vertex_Count).Color := (primary => Color,
+                                                   Alpha => opaque_Value);
+            if Col = col_Count / 2 + 1
+            then
+               Color := Self.Color;
+            end if;
+         end loop;
+      end set_Sites;
+
+      Self.Geometry.is_Transparent (False);
+      Vertices_are (Self.Geometry.all,
+                    Self.Vertices.all);
+
+      the_Primitive := Primitive.non_indexed.new_Primitive (openGL.primitive.Lines,
+                                                            Self.Vertices'Length);
+      Self.Geometry.add (Primitive.view (the_Primitive));
+
+      return [1 => Self.Geometry.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.grid;

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

@@ -0,0 +1,43 @@
+with
+     openGL.Geometry.colored;
+
+
+package openGL.Model.grid
+--
+--  Models a grid.
+--
+--  TODO: Rename to 'line_Grid'.
+is
+   type Item is new Model.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_grid_Model (Color  : openGL.Color;
+                            Width  : Integer;
+                            Height : Integer) 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;
+
+
+private
+
+   type Item is new Model.item with
+      record
+         Color    : openGL.rgb_Color;
+         Vertices : openGL.Geometry.colored.Vertex_array_view;
+         Geometry : openGL.Geometry.colored.view;
+         Width,
+         Height   : Positive;
+      end record;
+
+end openGL.Model.grid;

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

@@ -0,0 +1,552 @@
+with
+     openGL.Geometry.colored,
+     openGL.Primitive.indexed,
+
+     float_Math.Geometry.d2.Hexagon,
+
+     ada.Containers.hashed_Maps,
+     ada.unchecked_Deallocation;
+
+
+package body openGL.Model.hex_grid
+is
+   --------
+   -- Forge
+   --
+
+   function new_Grid (heights_Asset : in asset_Name;
+                      Heights       : in height_Map_view;
+                      Color         : in lucid_Color    := (palette.White,
+                                                            Opaque)) return View
+   is
+      the_Model : constant View := new Item' (Model.item with
+                                              heights_Asset => heights_Asset,
+                                              Heights       => Heights,
+                                              Color         => +Color);
+   begin
+      the_Model.set_Bounds;
+      return the_Model;
+   end new_Grid;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (height_Map,
+                                                              height_Map_view);
+   begin
+      destroy    (Model.item (Self));
+      deallocate (Self.Heights);
+   end destroy;
+
+
+
+   -------------
+   -- Attributes
+   --
+
+   package hexagon_Geometry renames Geometry_2d.Hexagon;
+
+
+   -- site_Map_of_vertex_Id
+   --
+
+   function Hash (From : in Geometry_2d.Site) return ada.Containers.Hash_type
+   is
+      use ada.Containers;
+
+      type Fix is delta 0.00_1 range 0.0 .. 1000.0;
+
+      cell_Size  : constant Fix := 0.5;
+      grid_Width : constant     := 10;
+   begin
+      return   Hash_type (Fix (From (1)) / cell_Size)
+             + Hash_type (Fix (From (2)) / cell_Size) * grid_Width;
+   end Hash;
+
+
+
+   function Equivalent (S1, S2 : Geometry_2d.Site) return Boolean
+   is
+      Tolerance : constant := 0.1;
+   begin
+      return     abs (S2 (1) - S1 (1)) < Tolerance
+             and abs (S2 (2) - S1 (2)) < Tolerance;
+   end Equivalent;
+
+
+
+   type Coordinates_array is array (Index_t range <>) of hexagon_Geometry.Coordinates;
+
+   type hex_Vertex is
+      record
+         shared_Hexes : Coordinates_array (1 .. 3);
+         shared_Count : Index_t := 0;
+
+         Site         : Geometry_3d.Site;
+      end record;
+
+   type hex_Vertices is array (Index_t range <>) of hex_Vertex;
+
+
+
+   package site_Maps_of_vertex_Id is new ada.Containers.hashed_Maps (Key_type        => Geometry_2d.Site,
+                                                                     Element_type    => Index_t,
+                                                                     Hash            => Hash,
+                                                                     equivalent_Keys => Equivalent,
+                                                                     "="             => "=");
+
+   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 (Textures, Fonts);
+
+      use Geometry,
+          Geometry.colored,
+          Geometry_2d;
+
+      site_Map_of_vertex_Id : site_Maps_of_vertex_Id.Map;
+        next_free_vertex_Id : Index_t := 0;
+
+
+      function fetch_Id (S : in geometry_2d.Site) return Index_t
+      is
+         use site_Maps_of_vertex_Id;
+         C : constant Cursor := site_Map_of_vertex_Id.Find (S);
+      begin
+         if has_Element (C)
+         then
+            return Element (C);
+         else
+            next_free_vertex_Id := @ + 1;
+            site_Map_of_vertex_Id.insert (S, next_free_vertex_Id);
+
+            return next_free_vertex_Id;
+         end if;
+      end fetch_Id;
+
+
+      Heights   : height_Map_view renames Self.Heights;
+
+      row_Count : constant Index_t := Heights'Length (1);
+      col_Count : constant Index_t := Heights'Length (2);
+
+      the_Grid  : constant hexagon_Geometry.Grid := Hexagon.to_Grid (Rows         => Positive (row_Count),
+                                                                     Cols         => Positive (col_Count),
+                                                                     circumRadius => 1.0);
+      zigzag_Count : constant Index_t := col_Count + 1;
+
+      first_zigzag_vertex_Count  : constant Index_t := row_Count * 2 + 1;
+        mid_zigzag_vertex_Count  : constant Index_t := row_Count * 2 + 2;
+       last_zigzag_vertex_Count  : constant Index_t := row_Count * 2 + 1;
+
+      zigzags_vertex_Count       : constant Index_t :=   first_zigzag_vertex_Count
+                                                       + (mid_zigzag_vertex_Count) * (zigzag_Count - 2)
+                                                       + last_zigzag_vertex_Count;
+      zigzag_joiner_vertex_Count : constant Index_t := col_Count * 2;
+
+
+      vertex_Count  : constant Index_t :=         zigzags_vertex_Count
+                                          + zigzag_joiner_vertex_Count;
+
+      hex_Vertices  : hex_Grid.hex_Vertices (1 .. zigzags_vertex_Count);
+
+      zigzags_indices_Count : constant long_Index_t := long_Index_t (vertex_Count);
+
+      gl_Vertices      : aliased  Geometry.colored.Vertex_array (1 .. vertex_Count);
+
+      hex_Count        : constant long_Index_t := long_Index_t (col_Count * row_Count * 2);
+
+      zigzags_Indices  : aliased  Indices (1 .. zigzags_indices_Count);
+      tops_Indices     : aliased  Indices (1 ..   hex_Count
+                                                + long_Index_t (col_Count * 2));
+
+      zigzags_Geometry : constant Geometry.colored.view := Geometry.colored.new_Geometry;
+         tops_Geometry : constant Geometry.colored.view := Geometry.colored.new_Geometry;
+
+
+      min_Site : Site := [Real'Last,  Real'Last,  Real'Last];
+      max_Site : Site := [Real'First, Real'First, Real'First];
+
+   begin
+
+      find_shared_Hexes_per_Vertex:
+      begin
+         for Row in 1 .. row_Count
+         loop
+
+            for Col in 1 .. col_Count
+            loop
+
+               for Which in hexagon_Geometry.vertex_Id
+               loop
+                  declare
+                     use hexagon_Geometry;
+                     Site       : constant Geometry_2d.Site := vertex_Site (the_Grid,
+                                                                            hex_Id => [Positive (Row),
+                                                                                       Positive (Col)],
+                                                                            Which  => Which);
+
+                     vertex_Id  : constant Index_t    :=      fetch_Id (S => Site);
+                     the_Vertex :          hex_Vertex renames hex_Vertices (vertex_Id);
+                     C          : constant Index_t    :=      the_Vertex.shared_Count + 1;
+                  begin
+                     the_Vertex.shared_Count     := C;
+                     the_Vertex.shared_Hexes (C) := [Positive (Row),
+                                                     Positive (Col)];
+                     the_Vertex.Site := [Site (1),
+                                         0.0,
+                                         Site (2)];
+                  end;
+               end loop;
+
+            end loop;
+
+         end loop;
+      end find_shared_Hexes_per_Vertex;
+
+
+      set_Height_for_each_Vertex:
+      begin
+         for Row in 1 .. row_Count
+         loop
+
+            for Col in 1 .. col_Count
+            loop
+
+               for Which in hexagon_Geometry.vertex_Id
+               loop
+                  declare
+                     use hexagon_Geometry;
+                     Site       : constant Geometry_2d.Site := vertex_Site (the_Grid,
+                                                                            hex_Id => [Positive (Row),
+                                                                                       Positive (Col)],
+                                                                            Which  => Which);
+                     Height     :          Real       :=      0.0;
+                     vertex_Id  : constant Index_t    :=      fetch_Id (S => Site);
+                     the_Vertex :          hex_Vertex renames hex_Vertices (vertex_Id);
+                  begin
+                     for Each in 1 .. the_Vertex.shared_Count
+                     loop
+                        Height := Height + Heights (Row, Col);
+                     end loop;
+
+                     Height          := Height / Real (the_Vertex.shared_Count);
+                     the_Vertex.Site := [Site (1),
+                                         Height,
+                                         Site (2)];
+
+                     min_Site := [Real'Min (min_Site (1), the_Vertex.Site (1)),
+                                  Real'Min (min_Site (2), the_Vertex.Site (2)),
+                                  Real'Min (min_Site (3), the_Vertex.Site (3))];
+
+                     max_Site := [Real'Max (min_Site (1), the_Vertex.Site (1)),
+                                  Real'Max (min_Site (2), the_Vertex.Site (2)),
+                                  Real'Max (min_Site (3), the_Vertex.Site (3))];
+                  end;
+               end loop;
+
+            end loop;
+
+         end loop;
+      end set_Height_for_each_Vertex;
+
+
+      set_GL_Vertices:
+      declare
+         Center    : constant Site := [(max_Site (1) - min_Site (1)) / 2.0,
+                                       (max_Site (2) - min_Site (2)) / 2.0,
+                                       (max_Site (3) - min_Site (3)) / 2.0];
+
+         vertex_Id :          Index_t    := 0;
+         Color     : constant rgba_Color := Self.Color;
+      begin
+         --- Add hex vertices.
+         --
+         for i in hex_Vertices'Range
+         loop
+            vertex_Id := vertex_Id + 1;
+
+            gl_Vertices (vertex_Id).Site  := hex_Vertices (vertex_Id).Site - Center;
+            gl_Vertices (vertex_Id).Color := Color;
+         end loop;
+
+         --- Add joiner vertices.
+         --
+         for i in 1 .. col_Count
+         loop
+            declare
+               use hexagon_Geometry;
+
+               Site : Geometry_2d.Site := vertex_Site (the_Grid,
+                                                       hex_Id => [Row => Positive (row_Count),
+                                                                  Col => Positive (i)],
+                                                       Which  => 3);
+               hex_vertex_Id : Index_t := fetch_Id (Site);
+            begin
+               vertex_Id               := vertex_Id + 1;
+               gl_Vertices (vertex_Id) := (Site  => hex_Vertices (hex_vertex_Id).Site - Center,
+                                           Color => (Primary => Color.Primary,
+                                                     Alpha   => 0));
+
+               Site                    := vertex_Site (the_Grid,
+                                                       hex_Id => [Row => 1,
+                                                                  Col => Positive (i)],
+                                                       Which  => 6);
+
+               hex_vertex_Id           := fetch_Id (Site);
+               vertex_Id               := vertex_Id + 1;
+               gl_Vertices (vertex_Id) := (Site  => hex_Vertices (hex_vertex_Id).Site - Center,
+                                           Color => (Primary => Color.Primary,
+                                                     Alpha   => 0));
+            end;
+         end loop;
+      end set_GL_Vertices;
+
+
+      set_zigzags_GL_Indices:
+      declare
+         Cursor            : long_Index_t := 0;
+         joiners_vertex_Id :      Index_t := zigzags_vertex_Count;
+
+
+         procedure add_zigzag_Vertex (Row, Col   : in Positive;
+                                      hex_Vertex : in Hexagon.vertex_Id)
+         is
+            use hexagon_Geometry;
+
+            Site : constant Geometry_2d.Site := vertex_Site (the_Grid,
+                                                             hex_Id => [Row, Col],
+                                                             Which  => hex_Vertex);
+         begin
+            Cursor                   := Cursor + 1;
+            zigzags_Indices (Cursor) := fetch_Id (S => Site);
+         end add_zigzag_Vertex;
+
+
+         procedure add_joiner_vertex_Pair
+         is
+         begin
+            Cursor                   := Cursor + 1;
+            joiners_vertex_Id        := joiners_vertex_Id + 1;
+            zigzags_Indices (Cursor) := joiners_vertex_Id;
+
+            Cursor                   := Cursor + 1;
+            joiners_vertex_Id        := joiners_vertex_Id + 1;
+            zigzags_Indices (Cursor) := joiners_vertex_Id;
+         end add_joiner_vertex_Pair;
+
+
+      begin
+         --- Fist zigzag
+         --
+         add_zigzag_Vertex (Row => 1, Col => 1, hex_Vertex => 5);
+
+         for Row in 1 .. Positive (row_Count)
+         loop
+            add_zigzag_Vertex (Row, Col => 1, hex_Vertex => 4);
+            add_zigzag_Vertex (Row, Col => 1, hex_Vertex => 3);
+         end loop;
+
+         add_joiner_vertex_Pair;
+
+
+         --- Middles zigzags
+         --
+
+         for zz in 2 .. Positive (zigzag_Count) - 1
+         loop
+            declare
+               odd_Zigzag : constant Boolean := zz mod 2 = 1;
+            begin
+               if odd_Zigzag
+               then
+                  add_zigzag_Vertex (Row => 1, Col => Positive (zz),     hex_Vertex => 5);
+
+               else -- Even zigzag.
+                  add_zigzag_Vertex (Row => 1, Col => Positive (zz - 1), hex_Vertex => 6);
+               end if;
+
+
+               for Row in 1 .. Positive (row_Count)
+               loop
+                  if odd_Zigzag
+                  then
+                     add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 4);
+                     add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 3);
+
+                     if Row = Positive (row_Count)     -- Last row.
+                     then
+                        add_zigzag_Vertex (Row, Col => zz - 1, hex_Vertex => 2);
+                     end if;
+
+                  else -- Even zigzag.
+                     add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 5);
+                     add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 4);
+
+                     if Row = Positive (row_Count)     -- Last row.
+                     then
+                        add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 3);
+                     end if;
+                  end if;
+               end loop;
+            end;
+
+            add_joiner_vertex_Pair;
+         end loop;
+
+
+         --- Last zigzag
+         --
+         add_zigzag_Vertex (Row => 1, Col => Positive (col_Count), hex_Vertex => 6);
+
+         for Row in 1 .. Positive (row_Count)
+         loop
+            add_zigzag_Vertex (Row, Positive (col_Count), hex_Vertex => 1);
+            add_zigzag_Vertex (Row, Positive (col_Count), hex_Vertex => 2);
+         end loop;
+
+      end set_zigzags_GL_Indices;
+
+
+      zigzags_Geometry.is_Transparent (False);
+      zigzags_Geometry.Vertices_are   (gl_Vertices);
+
+
+      set_tops_GL_Indices:
+      declare
+         Cursor : long_Index_t := 0;
+      begin
+         for Col in 1 .. col_Count
+         loop
+            for Row in 1 .. row_Count
+            loop
+               declare
+                  use hexagon_Geometry;
+                  Site : Geometry_2d.Site := vertex_Site (the_Grid,
+                                                          hex_Id => [Positive (Row),
+                                                                     Positive (Col)],
+                                                          Which  => 5);
+               begin
+                  Cursor                := Cursor + 1;
+                  tops_Indices (Cursor) := fetch_Id (Site);
+
+                  Site := vertex_Site (the_Grid,
+                                       hex_Id => [Positive (Row),
+                                                  Positive (Col)],
+                                       Which  => 6);
+
+                  Cursor                := Cursor + 1;
+                  tops_Indices (Cursor) := fetch_Id (Site);
+
+                  if Row = row_Count     -- Last row, so do bottoms.
+                  then
+                     Site := vertex_Site (the_Grid,
+                                          hex_Id => [Positive (Row),
+                                                     Positive (Col)],
+                                          Which  => 3);
+
+                     Cursor                := Cursor + 1;
+                     tops_Indices (Cursor) := fetch_Id (Site);
+
+                     Site := vertex_Site (the_Grid,
+                                          hex_Id => [Positive (Row),
+                                                     Positive (Col)],
+                                          Which  => 2);
+
+                     Cursor                := Cursor + 1;
+                     tops_Indices (Cursor) := fetch_Id (Site);
+                  end if;
+               end;
+            end loop;
+         end loop;
+      end set_tops_GL_Indices;
+
+
+      tops_Geometry.is_Transparent (False);
+      tops_Geometry.Vertices_are   (gl_Vertices);
+
+
+      add_zigzag_Geometry:
+      declare
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (Primitive.line_Strip,
+                                               zigzags_Indices);
+      begin
+         zigzags_Geometry.add (Primitive.view (the_Primitive));
+      end add_zigzag_Geometry;
+
+
+      add_tops_Geometry:
+      declare
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (Primitive.Lines,
+                                               tops_Indices);
+      begin
+         tops_Geometry.add (Primitive.view (the_Primitive));
+      end add_tops_Geometry;
+
+
+      return [1 => Geometry.view (zigzags_Geometry),
+              2 => Geometry.view (   tops_Geometry)];
+   end to_GL_Geometries;
+
+
+
+   -- TODO: This is an approximation based on a rectangular grid.
+   --       Do a correct calculation based on the hexagon grid vertices.
+   --
+   overriding
+   procedure set_Bounds (Self : in out Item)
+   is
+      Heights      : height_Map_view renames Self.Heights;
+
+      row_Count    : constant Index_t := Heights'Length (1) - 1;
+      col_Count    : constant Index_t := Heights'Length (2) - 1;
+
+      vertex_Count : constant Index_t := Heights'Length (1) * Heights'Length (2);
+
+      the_Sites    : aliased  Sites (1 .. vertex_Count);
+
+      the_Bounds   : openGL.Bounds    := null_Bounds;
+
+   begin
+      set_Sites:
+      declare
+         vert_Id          :          Index_t  := 0;
+         the_height_Range : constant Vector_2 := height_Extent (Heights.all);
+         Middle           : constant Real     :=   (the_height_Range (1) + the_height_Range (2))
+                                                 / 2.0;
+      begin
+         for Row in 1 .. row_Count + 1
+         loop
+            for Col in 1 .. col_Count + 1
+            loop
+               vert_Id             := vert_Id + 1;
+               the_Sites (vert_Id) := [Real (Col)         - Real (col_Count) / 2.0 - 1.0,
+                                       Heights (Row, Col) - Middle,
+                                       Real (Row)         - Real (row_Count) / 2.0 - 1.0];
+
+               the_Bounds.Box.Lower (1) := Real'Min (the_Bounds.Box.Lower (1),  the_Sites (vert_Id) (1));
+               the_Bounds.Box.Lower (2) := Real'Min (the_Bounds.Box.Lower (2),  the_Sites (vert_Id) (2));
+               the_Bounds.Box.Lower (3) := Real'Min (the_Bounds.Box.Lower (3),  the_Sites (vert_Id) (3));
+
+               the_Bounds.Box.Upper (1) := Real'Max (the_Bounds.Box.Upper (1),  the_Sites (vert_Id) (1));
+               the_Bounds.Box.Upper (2) := Real'Max (the_Bounds.Box.Upper (2),  the_Sites (vert_Id) (2));
+               the_Bounds.Box.Upper (3) := Real'Max (the_Bounds.Box.Upper (3),  the_Sites (vert_Id) (3));
+
+               the_Bounds.Ball := Real'Max (the_Bounds.Ball,
+                                            abs (the_Sites (vert_Id)));
+            end loop;
+         end loop;
+
+         the_Bounds.Ball := the_Bounds.Ball * 1.1;     -- TODO: Why the '* 1.1' ?
+      end set_Sites;
+
+      Self.Bounds := the_Bounds;
+   end set_Bounds;
+
+
+end openGL.Model.hex_grid;

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

@@ -0,0 +1,53 @@
+with
+     openGL.Geometry,
+     openGL.Palette;
+
+
+package openGL.Model.hex_grid
+--
+--  Models a regular hexagon grid.
+--
+is
+   type Item is new Model.item with private;
+   type View is access all Item'Class;
+
+
+   type height_Map_view is access all height_Map;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Grid (heights_Asset : in asset_Name;
+                      Heights       : in height_Map_view;
+                      Color         : in lucid_Color := (palette.White,
+                                                         Opaque)) return View;
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- 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;
+
+
+private
+
+   type Item is new Model.item with
+      record
+         heights_Asset : asset_Name     := null_Asset;
+         Heights       : height_Map_view;
+         Color         : rgba_Color;
+      end record;
+
+
+   overriding
+   procedure set_Bounds (Self : in out Item);
+
+
+end openGL.Model.hex_grid;

3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_colored.adb

@@ -0,0 +1,79 @@
+with
+     openGL.Geometry.lit_colored,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.hexagon.lit_colored
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Hexagon (Radius : in Real;
+                         Face   : in lit_colored.Face) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Face   := Face;
+
+      return Self;
+   end new_Hexagon;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry.lit_colored;
+
+      the_Sites    :         constant hexagon.Sites := vertex_Sites (Self.Radius);
+      the_Indices  : aliased constant Indices       := [1, 2, 3, 4, 5, 6, 7, 2];
+
+
+      function new_Face (Vertices : in geometry.lit_colored.Vertex_array) return Geometry.lit_colored.view
+      is
+         use Primitive;
+
+         the_Geometry  : constant Geometry.lit_colored.view
+           := Geometry.lit_colored.new_Geometry;
+
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (Primitive.view (the_Primitive));
+
+         return the_Geometry;
+      end new_Face;
+
+
+      upper_Face : Geometry.lit_colored.view;
+
+   begin
+      --  Upper Face
+      --
+      declare
+         the_Vertices : constant Geometry.lit_colored.Vertex_array
+           := [1 => (Site => [0.0, 0.0, 0.0],  Normal => Normal,  Color => +Self.Face.center_Color, Shine => default_Shine),
+               2 => (Site =>   the_Sites (1),  Normal => Normal,  Color => +Self.Face.Colors (1),   Shine => default_Shine),
+               3 => (Site =>   the_Sites (2),  Normal => Normal,  Color => +Self.Face.Colors (2),   Shine => default_Shine),
+               4 => (Site =>   the_Sites (3),  Normal => Normal,  Color => +Self.Face.Colors (3),   Shine => default_Shine),
+               5 => (Site =>   the_Sites (4),  Normal => Normal,  Color => +Self.Face.Colors (4),   Shine => default_Shine),
+               6 => (Site =>   the_Sites (5),  Normal => Normal,  Color => +Self.Face.Colors (5),   Shine => default_Shine),
+               7 => (Site =>   the_Sites (6),  Normal => Normal,  Color => +Self.Face.Colors (6),   Shine => default_Shine)];
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices);
+      end;
+
+      return [1 => upper_Face.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.hexagon.lit_colored;

3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_colored.ads

@@ -0,0 +1,45 @@
+with
+     openGL.Geometry,
+     openGL.Texture;
+
+
+package openGL.Model.hexagon.lit_colored
+--
+--  Models a lit and colored hexagon.
+--
+is
+   type Item is new Model.item with private;
+   type View is access all Item'Class;
+
+   type Face is
+      record
+         center_Color : lucid_Color;                                           --  The color at the center of the hex.
+         Colors       : lucid_Colors (1 .. 6);                                 --  The color at each of the hexes 6 vertices.
+      end record;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Hexagon (Radius : in Real;
+                         Face   : in lit_colored.Face) 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;
+
+
+private
+
+   type Item is new Model.hexagon.item with
+      record
+         Face : lit_colored.Face;
+      end record;
+
+end openGL.Model.hexagon.lit_colored;

3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_colored_textured.adb

@@ -0,0 +1,89 @@
+with
+     openGL.Geometry.lit_colored_textured,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.hexagon.lit_colored_textured
+is
+
+   type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Hexagon (Radius : in Real;
+                         Face   : in lit_colored_textured.Face) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Face   := Face;
+
+      return Self;
+   end new_Hexagon;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry.lit_colored_textured,
+          Texture;
+
+      the_Sites    :         constant hexagon.Sites := vertex_Sites (Self.Radius);
+      the_Indices  : aliased constant Indices       := (1, 2, 3, 4, 5, 6, 7, 2);
+
+
+      function new_Face (Vertices : in geometry.lit_colored_textured.Vertex_array) return Geometry_view
+      is
+         use Primitive;
+
+         the_Geometry  : constant Geometry_view
+           := Geometry.lit_colored_textured.new_Geometry (texture_is_Alpha => False);
+
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (Primitive.view (the_Primitive));
+
+         return the_Geometry;
+      end new_Face;
+
+
+      upper_Face : Geometry_view;
+
+   begin
+      --  Upper Face
+      --
+      declare
+         the_Vertices : constant Geometry.lit_colored_textured.Vertex_array
+           := (1 => (Site => (0.0, 0.0, 0.0), Normal => Normal, Color => +Self.Face.center_Color, Coords => (0.0, 0.0),   Shine => default_Shine),
+               2 => (Site =>   the_Sites (1), Normal => Normal, Color => +Self.Face.Colors (1),   Coords => (0.0, 0.0),   Shine => default_Shine),
+               3 => (Site =>   the_Sites (2), Normal => Normal, Color => +Self.Face.Colors (2),   Coords => (1.0, 0.0),   Shine => default_Shine),
+               4 => (Site =>   the_Sites (3), Normal => Normal, Color => +Self.Face.Colors (3),   Coords => (1.0, 1.0),   Shine => default_Shine),
+               5 => (Site =>   the_Sites (4), Normal => Normal, Color => +Self.Face.Colors (4),   Coords => (0.0, 1.0),   Shine => default_Shine),
+               6 => (Site =>   the_Sites (5), Normal => Normal, color => +Self.Face.Colors (5),   Coords => (0.0, 1.0),   Shine => default_Shine),
+               7 => (Site =>   the_Sites (6), Normal => Normal, Color => +Self.Face.Colors (6),   Coords => (0.0, 1.0),   Shine => default_Shine));
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Face.Texture /= null_Object
+         then
+            upper_Face.Texture_is (Self.Face.Texture);
+         end if;
+      end;
+
+      return (1 => upper_Face.all'Access);
+   end to_GL_Geometries;
+
+
+end openGL.Model.hexagon.lit_colored_textured;

3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_colored_textured.ads

@@ -0,0 +1,46 @@
+with
+     openGL.Geometry,
+     openGL.Texture;
+
+
+package openGL.Model.hexagon.lit_colored_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
+         center_Color : lucid_Color;                                           --  The color at the center of the hex.
+         Colors       : lucid_Colors (1 .. 6);                                 --  The color at each of the hexes 6 vertices.
+         Texture      : openGL.Texture.Object := openGL.Texture.null_Object;   --  The texture to be applied to the hex..
+      end record;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Hexagon (Radius : in Real;
+                         Face   : in lit_colored_textured.Face) 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;
+
+
+private
+
+   type Item is new Model.hexagon.item with
+      record
+         Face : lit_colored_textured.Face;
+      end record;
+
+end openGL.Model.hexagon.lit_colored_textured;

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

@@ -0,0 +1,85 @@
+with
+     openGL.Geometry.lit_textured,
+     openGL.Primitive.indexed;
+
+
+package body openGL.Model.hexagon.lit_textured
+is
+   ---------
+   --- Forge
+   --
+
+   function new_Hexagon (Radius : in Real;
+                         Face   : in lit_textured.Face) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Face   := Face;
+
+      return Self;
+   end new_Hexagon;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry.lit_textured,
+          Texture;
+
+      the_Sites    :         constant hexagon.Sites := vertex_Sites (Self.Radius);
+      the_Indices  : aliased constant Indices       := (1, 2, 3, 4, 5, 6, 7, 2);
+
+
+      function new_Face (Vertices : in geometry.lit_textured.Vertex_array) return Geometry.lit_textured.view
+      is
+         use Primitive;
+
+         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);
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (Primitive.view (the_Primitive));
+
+         return the_Geometry;
+      end new_Face;
+
+
+      upper_Face : Geometry.lit_textured.view;
+
+   begin
+      --  Upper Face
+      --
+      declare
+         the_Vertices : constant Geometry.lit_textured.Vertex_array
+           := (1 => (Site => (0.0, 0.0, 0.0),  Normal => Normal,  Coords => (0.0, 0.0),  Shine => default_Shine),
+               2 => (Site =>   the_Sites (1),  Normal => Normal,  Coords => (0.0, 0.0),  Shine => default_Shine),
+               3 => (Site =>   the_Sites (2),  Normal => Normal,  Coords => (1.0, 0.0),  Shine => default_Shine),
+               4 => (Site =>   the_Sites (3),  Normal => Normal,  Coords => (1.0, 1.0),  Shine => default_Shine),
+               5 => (Site =>   the_Sites (4),  Normal => Normal,  Coords => (0.0, 1.0),  Shine => default_Shine),
+               6 => (Site =>   the_Sites (5),  Normal => Normal,  Coords => (0.0, 1.0),  Shine => default_Shine),
+               7 => (Site =>   the_Sites (6),  Normal => Normal,  Coords => (0.0, 1.0),  Shine => default_Shine));
+      begin
+         upper_Face := new_Face (Vertices => the_Vertices);
+
+         if Self.Face.Texture /= null_Object
+         then
+            upper_Face.Texture_is (Self.Face.Texture);
+         end if;
+      end;
+
+      return (1 => upper_Face.all'Access);
+   end to_GL_Geometries;
+
+
+end openGL.Model.hexagon.lit_textured;

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

@@ -0,0 +1,44 @@
+with
+     openGL.Geometry,
+     openGL.Texture;
+
+
+package openGL.Model.hexagon.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
+         Texture : openGL.Texture.Object := openGL.Texture.null_Object;   -- The texture to be applied to the hex.
+      end record;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_Hexagon (Radius : in Real;
+                         Face   : in lit_textured.Face) 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;
+
+
+private
+
+   type Item is new Model.hexagon.item with
+      record
+         Face : lit_textured.Face;
+      end record;
+
+end openGL.Model.hexagon.lit_textured;

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

@@ -0,0 +1,24 @@
+package body openGL.Model.hexagon
+is
+
+   function vertex_Sites (Radius : in Real) return Sites
+   is
+      use linear_Algebra_3d;
+
+      the_Site  :          Vector_3   := [Radius, 0.0, 0.0];
+      Rotation  : constant Matrix_3x3 := y_Rotation_from (to_Radians (60.0));
+
+      the_Sites :          Sites;
+
+   begin
+      for i in the_Sites'Range
+      loop
+         the_Sites (i) := the_Site;
+         the_Site      := Rotation * the_Site;
+      end loop;
+
+      return the_Sites;
+   end vertex_Sites;
+
+
+end openGL.Model.hexagon;

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

@@ -0,0 +1,25 @@
+package openGL.Model.hexagon
+--
+--  Provides an abstract model of a hexagon.
+--
+is
+   type Item is abstract new Model.item with private;
+
+
+   subtype site_Id is Integer range 1 .. 6;
+   type    Sites   is array (site_Id) of Vector_3;
+
+   function vertex_Sites (Radius : in Real) return Sites;
+
+
+
+private
+
+   type Item is abstract new Model.item with
+      record
+         Radius : Real := 1.0;
+      end record;
+
+   Normal : constant Vector_3 := [0.0, 0.0, 1.0];
+
+end openGL.Model.Hexagon;

3-mid/opengl/source/lean/model/opengl-model-hexagon_column-lit_colored_faceted.adb

@@ -0,0 +1,244 @@
+with
+     openGL.Primitive.indexed,
+     openGL.Geometry.lit_colored,
+     openGL.Model.hexagon;
+
+
+package body openGL.Model.Hexagon_Column.lit_colored_faceted
+is
+   ---------
+   --- Forge
+   --
+
+   function new_hexagon_Column (Radius : in Real;
+                                Height : in Real;
+                                Upper,
+                                Lower  : in   hex_Face;
+                                Shaft  : in shaft_Face) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius     := Radius;
+      Self.Height     := Height;
+      Self.upper_Face := Upper;
+      Self.lower_Face := Lower;
+      Self.Shaft      := Shaft;
+
+      return Self;
+   end new_hexagon_Column;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Fonts, Textures);
+
+      use Geometry.lit_colored,
+          Model.hexagon;
+
+      shaft_Height  : constant Real     := Self.Height;
+      height_Offset : constant Vector_3 := [0.0, shaft_Height / 2.0, 0.0];
+
+      mid_Sites     : constant hexagon.Sites := vertex_Sites (Self.Radius);
+      upper_Sites   :          hexagon.Sites := mid_Sites;
+      lower_Sites   :          hexagon.Sites := mid_Sites;
+
+
+      function new_hexagon_Face (Vertices : access Geometry.lit_colored.Vertex_array;
+                                 Flip     : in     Boolean := False) return Geometry.lit_colored.view
+      is
+         use Primitive;
+
+         function the_Indices return Indices
+         is
+         begin
+            if Flip
+            then   return [1, 7, 6, 5, 4, 3, 2, 7];
+            else   return [1, 2, 3, 4, 5, 6, 7, 2];
+            end if;
+         end the_Indices;
+
+         the_Geometry  : constant Geometry.lit_colored.view
+           := Geometry.lit_colored.new_Geometry;
+
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (triangle_Fan,
+                                               the_Indices);
+      begin
+         the_Geometry.Vertices_are (Vertices.all);
+         the_Geometry.add (Primitive.view (the_Primitive));
+
+         return the_Geometry;
+      end new_hexagon_Face;
+
+
+      function new_shaft_Face (Vertices : access Geometry.lit_colored.Vertex_array)
+                               return Geometry.lit_colored.view
+      is
+         use Primitive;
+
+         the_Indices   : constant Indices := [1, 2, 3, 4];
+
+         the_Geometry  : constant Geometry.lit_colored.view
+           := Geometry.lit_colored.new_Geometry;
+
+         the_Primitive : constant Primitive.view
+           := Primitive.indexed.new_Primitive (triangle_Strip, the_Indices).all'Access;
+      begin
+         the_Geometry.Vertices_are (Vertices.all);
+         the_Geometry.add          (the_Primitive);
+
+         return the_Geometry;
+      end new_shaft_Face;
+
+
+      upper_Face  : Geometry.lit_colored.view;
+      lower_Face  : Geometry.lit_colored.view;
+
+      shaft_Faces : array (1 .. 6) of Geometry.lit_colored.view;
+
+   begin
+      for Each in mid_Sites'Range
+      loop
+         upper_Sites (Each) := upper_Sites (Each) + height_Offset;
+         lower_Sites (Each) := lower_Sites (Each) - height_Offset;
+      end loop;
+
+      --  Upper
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := [1 => (Site => height_Offset,     Normal => Normal,   Color => +Self.upper_Face.center_Color,   Shine => default_Shine),
+               2 => (Site => upper_Sites (1),   Normal => Normal,   Color => +Self.upper_Face.Colors (1),     Shine => default_Shine),
+               3 => (Site => upper_Sites (2),   Normal => Normal,   Color => +Self.upper_Face.Colors (2),     Shine => default_Shine),
+               4 => (Site => upper_Sites (3),   Normal => Normal,   Color => +Self.upper_Face.Colors (3),     Shine => default_Shine),
+               5 => (Site => upper_Sites (4),   Normal => Normal,   Color => +Self.upper_Face.Colors (4),     Shine => default_Shine),
+               6 => (Site => upper_Sites (5),   Normal => Normal,   Color => +Self.upper_Face.Colors (5),     Shine => default_Shine),
+               7 => (Site => upper_Sites (6),   Normal => Normal,   Color => +Self.upper_Face.Colors (6),     Shine => default_Shine)];
+      begin
+         upper_Face := new_hexagon_Face (Vertices => the_Vertices'Access);
+      end;
+
+      --  Lower
+      --
+      declare
+         the_Vertices : aliased Geometry.lit_colored.Vertex_array
+           := [1 => (Site => -height_Offset,    Normal => -Normal,   Color => +Self.upper_Face.center_Color,   Shine => default_Shine),
+               2 => (Site =>  lower_Sites (1),  Normal => -Normal,   Color => +Self.upper_Face.Colors (1),     Shine => default_Shine),
+               3 => (Site =>  lower_Sites (2),  Normal => -Normal,   Color => +Self.upper_Face.Colors (2),     Shine => default_Shine),
+               4 => (Site =>  lower_Sites (3),  Normal => -Normal,   Color => +Self.upper_Face.Colors (3),     Shine => default_Shine),
+               5 => (Site =>  lower_Sites (4),  Normal => -Normal,   Color => +Self.upper_Face.Colors (4),     Shine => default_Shine),
+               6 => (Site =>  lower_Sites (5),  Normal => -Normal,   Color => +Self.upper_Face.Colors (5),     Shine => default_Shine),
+               7 => (Site =>  lower_Sites (6),  Normal => -Normal,   Color => +Self.upper_Face.Colors (6),     Shine => default_Shine)];
+      begin
+         lower_Face := new_hexagon_Face (Vertices => the_Vertices'Access,
+                                         Flip     => True);
+      end;
+
+
+      --  Shaft
+      --
+      declare
+         type shaft_Normals is array (1 .. 6) of Vector_3;
+
+
+         function get_Normals return shaft_Normals
+         is
+            use linear_Algebra_3D;
+
+            Rotation   : constant Matrix_3x3   := y_Rotation_from (to_Radians (60.0));
+            the_Normal :          Vector_3     := [0.0, 0.0, -1.0];
+            Result     :          shaft_Normals;
+         begin
+            Result (2) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (3) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (4) := the_Normal;
+
+            the_Normal := [0.0, 0.0, 1.0];
+            Result (5) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (6) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (1) := the_Normal;
+
+            return Result;
+         end get_Normals;
+
+
+         Normals     : constant shaft_Normals :=  get_Normals;
+         shaft_Color : constant rgba_Color    := +Self.Shaft.Color;
+
+         the_Vertices_1 : aliased Geometry.lit_colored.Vertex_array
+           := [1  => (Site => upper_Sites (1),   Normal => Normals (1),   Color => shaft_Color,   Shine => default_Shine),
+               2  => (Site => lower_Sites (1),   Normal => Normals (1),   Color => shaft_Color,   Shine => default_Shine),
+               3  => (Site => upper_Sites (2),   Normal => Normals (1),   Color => shaft_Color,   Shine => default_Shine),
+               4  => (Site => lower_Sites (2),   Normal => Normals (1),   Color => shaft_Color,   Shine => default_Shine)];
+
+         the_Vertices_2 : aliased Geometry.lit_colored.Vertex_array
+           := [1  => (Site => upper_Sites (2),   Normal => Normals (2),   Color => shaft_Color,   Shine => default_Shine),
+               2  => (Site => lower_Sites (2),   Normal => Normals (2),   Color => shaft_Color,   Shine => default_Shine),
+               3  => (Site => upper_Sites (3),   Normal => Normals (2),   Color => shaft_Color,   Shine => default_Shine),
+               4  => (Site => lower_Sites (3),   Normal => Normals (2),   Color => shaft_Color,   Shine => default_Shine)];
+
+         the_Vertices_3 : aliased Geometry.lit_colored.Vertex_array
+           := [1  => (Site => upper_Sites (3),   Normal => Normals (3),   Color => shaft_Color,   Shine => default_Shine),
+               2  => (Site => lower_Sites (3),   Normal => Normals (3),   Color => shaft_Color,   Shine => default_Shine),
+               3  => (Site => upper_Sites (4),   Normal => Normals (3),   Color => shaft_Color,   Shine => default_Shine),
+               4  => (Site => lower_Sites (4),   Normal => Normals (3),   Color => shaft_Color,   Shine => default_Shine)];
+
+         the_Vertices_4 : aliased Geometry.lit_colored.Vertex_array
+           := [1  => (Site => upper_Sites (4),   Normal => Normals (4),   Color => shaft_Color,   Shine => default_Shine),
+               2  => (Site => lower_Sites (4),   Normal => Normals (4),   Color => shaft_Color,   Shine => default_Shine),
+               3  => (Site => upper_Sites (5),   Normal => Normals (4),   Color => shaft_Color,   Shine => default_Shine),
+               4  => (Site => lower_Sites (5),   Normal => Normals (4),   Color => shaft_Color,   Shine => default_Shine)];
+
+         the_Vertices_5 : aliased Geometry.lit_colored.Vertex_array
+           := [1  => (Site => upper_Sites (5),   Normal => Normals (5),   Color => shaft_Color,   Shine => default_Shine),
+               2  => (Site => lower_Sites (5),   Normal => Normals (5),   Color => shaft_Color,   Shine => default_Shine),
+               3  => (Site => upper_Sites (6),   Normal => Normals (5),   Color => shaft_Color,   Shine => default_Shine),
+               4  => (Site => lower_Sites (6),   Normal => Normals (5),   Color => shaft_Color,   Shine => default_Shine)];
+
+         the_Vertices_6 : aliased Geometry.lit_colored.Vertex_array
+           := [1  => (Site => upper_Sites (6),   Normal => Normals (6),   Color => shaft_Color,   Shine => default_Shine),
+               2  => (Site => lower_Sites (6),   Normal => Normals (6),   Color => shaft_Color,   Shine => default_Shine),
+               3  => (Site => upper_Sites (1),   Normal => Normals (6),   Color => shaft_Color,   Shine => default_Shine),
+               4  => (Site => lower_Sites (1),   Normal => Normals (6),   Color => shaft_Color,   Shine => default_Shine)];
+
+         the_Vertices  : constant array (1 .. 6) of access Geometry.lit_colored.Vertex_array
+           := [the_Vertices_1'Access,
+               the_Vertices_2'Access,
+               the_Vertices_3'Access,
+               the_Vertices_4'Access,
+               the_Vertices_5'Access,
+               the_Vertices_6'Access];
+      begin
+         for i in shaft_Faces'Range
+         loop
+            shaft_Faces (i) := new_shaft_Face (vertices => the_Vertices (i));
+         end loop;
+      end;
+
+      return [1 => upper_Face     .all'Access,
+              2 => lower_Face     .all'Access,
+              3 => shaft_Faces (1).all'Access,
+              4 => shaft_Faces (2).all'Access,
+              5 => shaft_Faces (3).all'Access,
+              6 => shaft_Faces (4).all'Access,
+              7 => shaft_Faces (5).all'Access,
+              8 => shaft_Faces (6).all'Access];
+
+   end to_GL_Geometries;
+
+
+end openGL.Model.Hexagon_Column.lit_colored_faceted;

3-mid/opengl/source/lean/model/opengl-model-hexagon_column-lit_colored_faceted.ads

@@ -0,0 +1,59 @@
+with
+     openGL.Geometry,
+     openGL.Texture;
+
+
+package openGL.Model.hexagon_Column.lit_colored_faceted
+--
+--  Models a lit, colored and textured column with 6 faceted shaft sides.
+--
+is
+   type Item is new Model.hexagon_Column.Item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Faces
+   --
+
+   type hex_Face is
+      record
+         center_Color : lucid_Color;                         -- The color of the center of the hex.
+         Colors       : lucid_Colors (1 .. 6);               -- The color of each of the faces 4 vertices.
+      end record;
+
+   type shaft_Face is
+      record
+         Color : lucid_Color;                              -- The color of the shaft.
+      end record;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_hexagon_Column (Radius : in Real;
+                                Height : in Real;
+                                Upper,
+                                Lower  : in   hex_Face;
+                                Shaft  : in shaft_Face) 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;
+
+
+private
+
+   type Item is new Model.hexagon_Column.item with
+      record
+         upper_Face,
+         lower_Face : hex_Face;
+         Shaft      : shaft_Face;
+      end record;
+
+end openGL.Model.hexagon_Column.lit_colored_faceted;

3-mid/opengl/source/lean/model/opengl-model-hexagon_column-lit_colored_rounded.adb

@@ -0,0 +1,205 @@
+with
+     openGL.Primitive.indexed,
+     openGL.Geometry.lit_colored,
+     openGL.Model.hexagon;
+
+
+package body openGL.Model.hexagon_Column.lit_colored_rounded
+is
+   ---------
+   --- Forge
+   --
+
+   function new_hexagon_Column (Radius : in Real;
+                                Height : in Real;
+                                Upper,
+                                Lower  : in hex_Face;
+                                Shaft  : in shaft_Face) return View
+   is
+      Self : constant View := new Item;
+   begin
+      Self.Radius := Radius;
+      Self.Height := Height;
+
+      Self.upper_Face := Upper;
+      Self.lower_Face := Lower;
+      Self.Shaft      := Shaft;
+
+      return Self;
+   end new_hexagon_Column;
+
+
+   --------------
+   --- 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
+   is
+      pragma unreferenced (Textures, Fonts);
+
+      use Geometry.lit_colored,
+          Model.hexagon;
+
+      shaft_Height  : constant Real     := Self.Height;
+      height_Offset : constant Vector_3 := [0.0,  shaft_Height / 2.0,  0.0];
+
+      mid_Sites     : constant hexagon.Sites   := vertex_Sites (Self.Radius);
+      upper_Sites   :          hexagon.Sites   := mid_Sites;
+      lower_Sites   :          hexagon.Sites   := mid_Sites;
+
+
+      function new_hexagon_Face (Vertices : in Geometry.lit_colored.Vertex_array;
+                                 Flip     : in Boolean := False) return Geometry.lit_colored.view
+      is
+         use Primitive;
+
+         function the_Indices return Indices
+         is
+         begin
+            if Flip
+            then   return [1, 7, 6, 5, 4, 3, 2, 7];
+            else   return [1, 2, 3, 4, 5, 6, 7, 2];
+            end if;
+         end the_Indices;
+
+         the_Geometry  : constant Geometry.lit_colored.view
+           := Geometry.lit_colored.new_Geometry;
+
+         the_Primitive : constant Primitive.view
+           := Primitive.indexed.new_Primitive (triangle_Fan,
+                                               the_Indices).all'Access;
+
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (the_Primitive);
+
+         return the_Geometry;
+      end new_hexagon_Face;
+
+
+
+      function new_shaft_Face (Vertices : in Geometry.lit_colored.Vertex_array)
+                               return Geometry.lit_colored.view
+      is
+         use Primitive;
+
+         the_Indices   : constant Indices := [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2];
+
+         the_Geometry  : constant Geometry.lit_colored.view
+           := Geometry.lit_colored.new_Geometry;
+
+         the_Primitive : constant Primitive.indexed.view
+           := Primitive.indexed.new_Primitive (triangle_Strip,
+                                               the_Indices);
+      begin
+         the_Geometry.Vertices_are (Vertices);
+         the_Geometry.add          (Primitive.view (the_Primitive));
+
+         return the_Geometry;
+      end new_shaft_Face;
+
+
+      upper_Face  : Geometry.lit_colored.view;
+      lower_Face  : Geometry.lit_colored.view;
+      shaft_Face  : Geometry.lit_colored.view;
+
+   begin
+      for i in mid_Sites'Range
+      loop
+         upper_Sites (i) := upper_Sites (i) + height_Offset;
+         lower_Sites (i) := lower_Sites (i) - height_Offset;
+      end loop;
+
+      --  Upper
+      --
+      declare
+         the_Vertices : constant Geometry.lit_colored.Vertex_array
+           := [1 => (Site => height_Offset,    Normal => Normal,  Color => +Self.upper_Face.center_Color,  Shine => default_Shine),
+               2 => (Site => upper_Sites (1),  Normal => Normal,  Color => +Self.upper_Face.Colors (1),    Shine => default_Shine),
+               3 => (Site => upper_Sites (2),  Normal => Normal,  Color => +Self.upper_Face.Colors (2),    Shine => default_Shine),
+               4 => (Site => upper_Sites (3),  Normal => Normal,  Color => +Self.upper_Face.Colors (3),    Shine => default_Shine),
+               5 => (Site => upper_Sites (4),  Normal => Normal,  Color => +Self.upper_Face.Colors (4),    Shine => default_Shine),
+               6 => (Site => upper_Sites (5),  Normal => Normal,  Color => +Self.upper_Face.Colors (5),    Shine => default_Shine),
+               7 => (Site => upper_Sites (6),  Normal => Normal,  Color => +Self.upper_Face.Colors (6),    Shine => default_Shine)];
+      begin
+         upper_Face := new_hexagon_Face (Vertices => the_Vertices);
+      end;
+
+      --  Lower
+      --
+      declare
+         the_Vertices : constant Geometry.lit_colored.Vertex_array
+           := [1 => (Site => -height_Offset,     Normal => -Normal,   Color => +Self.lower_Face.center_Color,   Shine => default_Shine),
+               2 => (Site =>  lower_Sites (1),   Normal => -Normal,   Color => +Self.lower_Face.Colors (1),     Shine => default_Shine),
+               3 => (Site =>  lower_Sites (2),   Normal => -Normal,   Color => +Self.lower_Face.Colors (2),     Shine => default_Shine),
+               4 => (Site =>  lower_Sites (3),   Normal => -Normal,   Color => +Self.lower_Face.Colors (3),     Shine => default_Shine),
+               5 => (Site =>  lower_Sites (4),   Normal => -Normal,   Color => +Self.lower_Face.Colors (4),     Shine => default_Shine),
+               6 => (Site =>  lower_Sites (5),   Normal => -Normal,   Color => +Self.lower_Face.Colors (5),     Shine => default_Shine),
+               7 => (Site =>  lower_Sites (6),   Normal => -Normal,   Color => +Self.lower_Face.Colors (6),     Shine => default_Shine)];
+      begin
+         lower_Face := new_hexagon_Face (Vertices => the_Vertices,
+                                         Flip     => True);
+      end;
+
+      --- Shaft
+      --
+      declare
+         type shaft_Normals is array (1 .. 6) of Vector_3;
+
+         function get_Normals return shaft_Normals
+         is
+            use linear_Algebra_3D;
+
+            Rotation   : constant Matrix_3x3 := y_Rotation_from (-math.to_Radians (60.0));
+            the_Normal :          Vector_3   := [1.0, 0.0, 0.0];
+            Result     :          shaft_Normals;
+         begin
+            Result (1) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (2) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (3) := the_Normal;
+
+            the_Normal := [0.0, 0.0, 1.0];
+            Result (4) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (5) := the_Normal;
+
+            the_Normal := Rotation * the_Normal;
+            Result (6) := the_Normal;
+
+            return Result;
+         end get_Normals;
+
+         Normals      : constant shaft_Normals := get_Normals;
+         shaft_Color  : constant rgba_Color    := +Self.Shaft.Color;
+
+         the_Vertices : constant Geometry.lit_colored.Vertex_array
+           := [ 1 => (Site => upper_Sites (1),   Normal => Normals (1),   Color => shaft_Color,   Shine => default_Shine),
+                2 => (Site => lower_Sites (1),   Normal => Normals (1),   Color => shaft_Color,   Shine => default_Shine),
+                3 => (Site => upper_Sites (2),   Normal => Normals (2),   Color => shaft_Color,   Shine => default_Shine),
+                4 => (Site => lower_Sites (2),   Normal => Normals (2),   Color => shaft_Color,   Shine => default_Shine),
+                5 => (Site => upper_Sites (3),   Normal => Normals (3),   Color => shaft_Color,   Shine => default_Shine),
+                6 => (Site => lower_Sites (3),   Normal => Normals (3),   Color => shaft_Color,   Shine => default_Shine),
+                7 => (Site => upper_Sites (4),   Normal => Normals (4),   Color => shaft_Color,   Shine => default_Shine),
+                8 => (Site => lower_Sites (4),   Normal => Normals (4),   Color => shaft_Color,   Shine => default_Shine),
+                9 => (Site => upper_Sites (5),   Normal => Normals (5),   Color => shaft_Color,   Shine => default_Shine),
+               10 => (Site => lower_Sites (5),   Normal => Normals (5),   Color => shaft_Color,   Shine => default_Shine),
+               11 => (Site => upper_Sites (6),   Normal => Normals (6),   Color => shaft_Color,   Shine => default_Shine),
+               12 => (Site => lower_Sites (6),   Normal => Normals (6),   Color => shaft_Color,   Shine => default_Shine)];
+      begin
+         shaft_Face := new_shaft_Face (Vertices => the_Vertices);
+      end;
+
+      return [1 => upper_Face.all'Access,
+              2 => lower_Face.all'Access,
+              3 => shaft_Face.all'Access];
+   end to_GL_Geometries;
+
+
+end openGL.Model.hexagon_Column.lit_colored_rounded;

3-mid/opengl/source/lean/model/opengl-model-hexagon_column-lit_colored_rounded.ads

@@ -0,0 +1,62 @@
+with
+     openGL.Geometry,
+     openGL.Texture;
+
+
+package openGL.Model.hexagon_Column.lit_colored_rounded
+--
+--  Models a lit and colored column with six rounded sides.
+--
+--  The shaft of the column appears rounded, whereas the top and bottom appear as hexagons.
+--
+is
+   type Item is new Model.hexagon_Column.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Faces
+   --
+
+   type hex_Face is
+      record
+         center_Color : lucid_Color;                  -- The color of the center of the hex.
+         Colors       : lucid_Colors (1 .. 6);        -- The color of each of the faces 4 vertices.
+      end record;
+
+
+   type shaft_Face is
+      record
+         Color   : lucid_Color;                       -- The color of the shaft.
+      end record;
+
+
+   ---------
+   --- Forge
+   --
+
+   function new_hexagon_Column (Radius : in Real;
+                                Height : in Real;
+                                Upper,
+                                Lower  : in hex_Face;
+                                Shaft  : in shaft_Face) 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;
+
+
+private
+
+   type Item is new Model.hexagon_Column.item with
+      record
+         upper_Face,
+         lower_Face : hex_Face;
+         Shaft      : shaft_Face;
+      end record;
+
+end openGL.Model.hexagon_Column.lit_colored_rounded;