Add initial prototype.

4-high/gel/source/applet/distributed/gel-applet-client_world.adb

@@ -0,0 +1,84 @@
+with
+     gel.Events,
+     gel.Camera.forge,
+     lace.Event.utility,
+     ada.unchecked_Deallocation;
+
+
+package body gel.Applet.client_world
+is
+
+   procedure define (Self : in gel.Applet.client_world.view;   Name       : in String;
+                                                               space_Kind : in physics.space_Kind)
+   is
+      use lace.Event.utility;
+
+      the_world_Info : constant world_Info_view  := new world_Info;
+      the_Camera     : constant gel.Camera.View  := gel.Camera.forge.new_Camera;
+   begin
+      the_world_Info.World := gel.World.client.forge.new_World (Name,
+                                                                client_world_Id,
+                                                                space_Kind,
+                                                                Self.Renderer).all'Access;
+
+      the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+      the_Camera.Renderer_is (Self.Renderer);
+      the_Camera.Site_is     ([0.0, 5.0, 50.0]);
+
+      the_world_Info.Cameras.append (the_Camera);
+
+      Self.Worlds.append (the_world_Info);
+
+      Self.local_Subject_and_Observer.add (the_add_new_sprite_Response'Access,
+                                           to_Kind (gel.events.new_sprite_added_to_world_Event'Tag),
+                                           the_world_Info.World.Name);
+      the_world_Info.World.start;
+   end define;
+
+
+
+   package body Forge
+   is
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view;
+                           space_Kind : in physics.space_Kind) return gel.Applet.client_world.view
+      is
+         Self : constant View := new Item' (gel.Applet.Forge.to_Applet (Name, use_Window)
+                                            with null record);
+      begin
+         define (Self, Name, space_Kind);
+         return Self;
+      end new_Applet;
+
+   end Forge;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+
+   function client_World (Self : in Item) return gel.World.client.view
+   is
+   begin
+      return gel.World.client.view (Self.World (client_world_Id));
+   end client_World;
+
+
+
+   function client_Camera (Self : in Item) return gel.Camera.view
+   is
+   begin
+      return Self.Camera (client_world_Id,
+                          client_camera_Id);
+   end client_Camera;
+
+
+end gel.Applet.client_world;

4-high/gel/source/applet/distributed/gel-applet-client_world.ads

@@ -0,0 +1,40 @@
+with
+     gel.World.client,
+     gel.Camera,
+     gel.Window;
+
+package gel.Applet.client_world
+--
+--  Provides a gel applet configured with a single window and a single client world.
+--
+is
+   type Item is new gel.Applet.item with private;
+   type View is access all Item'Class;
+
+
+   package Forge
+   is
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view;
+                           space_Kind : in physics.space_Kind) return gel.Applet.client_world.view;
+   end Forge;
+
+   procedure free (Self : in out View);
+
+
+   client_world_Id  : constant  world_Id := 1;
+   client_camera_Id : constant camera_Id := 1;
+
+   function client_World  (Self : in Item) return gel.World.client.view;
+   function client_Camera (Self : in Item) return gel.Camera      .view;
+
+
+
+private
+
+   type Item is new gel.Applet.item with
+      record
+         null;
+      end record;
+
+end gel.Applet.client_world;

4-high/gel/source/applet/distributed/gel-applet-server_world.adb

@@ -0,0 +1,84 @@
+with
+     gel.Events,
+     gel.Camera.forge,
+     lace.Event.utility,
+     ada.unchecked_Deallocation;
+
+
+package body gel.Applet.server_world
+is
+
+   procedure define (Self : in gel.Applet.server_world.view;   Name       : in String;
+                                                               space_Kind : in physics.space_Kind)
+   is
+      use lace.Event.utility;
+
+      the_world_Info : constant world_Info_view  := new world_Info;
+      the_Camera     : constant gel.Camera.View  := gel.Camera.forge.new_Camera;
+   begin
+      the_world_Info.World := gel.World.server.forge.new_World (Name,
+                                                                server_world_Id,
+                                                                space_Kind,
+                                                                Self.Renderer).all'Access;
+
+      the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+      the_Camera.Renderer_is (Self.Renderer);
+      the_Camera.Site_is     ([0.0, 5.0, 50.0]);
+
+      the_world_Info.Cameras.append (the_Camera);
+
+      Self.Worlds.append (the_world_Info);
+
+      Self.local_Subject_and_Observer.add (the_add_new_sprite_Response'Access,
+                                           to_Kind (gel.events.new_sprite_added_to_world_Event'Tag),
+                                           the_world_Info.World.Name);
+      the_world_Info.World.start;
+   end define;
+
+
+
+   package body Forge
+   is
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view;
+                           space_Kind : in physics.space_Kind) return gel.Applet.server_world.view
+      is
+         Self : constant View := new Item' (gel.Applet.Forge.to_Applet (Name, use_Window)
+                                            with null record);
+      begin
+         define (Self, Name, space_Kind);
+         return Self;
+      end new_Applet;
+
+   end Forge;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+
+   function server_World (Self : in Item) return gel.World.server.view
+   is
+   begin
+      return gel.World.server.view (Self.World (server_world_Id));
+   end server_World;
+
+
+
+   function server_Camera (Self : in Item) return gel.Camera.view
+   is
+   begin
+      return Self.Camera ( server_world_Id,
+                          server_camera_Id);
+   end server_Camera;
+
+
+end gel.Applet.server_world;

4-high/gel/source/applet/distributed/gel-applet-server_world.ads

@@ -0,0 +1,41 @@
+with
+     gel.Camera,
+     gel.World.server,
+     gel.Window;
+
+
+package gel.Applet.server_world
+--
+--  Provides a gel applet configured with a single window and a single server world.
+--
+is
+   type Item is new gel.Applet.item with private;
+   type View is access all Item'Class;
+
+
+   package Forge
+   is
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view;
+                           space_Kind : in physics.space_Kind) return gel.Applet.server_world.view;
+   end Forge;
+
+   procedure free (Self : in out View);
+
+
+   server_world_Id  : constant  world_Id := 1;
+   server_camera_Id : constant camera_Id := 1;
+
+   function server_World  (Self : in Item) return gel.World.server.view;
+   function server_Camera (Self : in Item) return gel.Camera.view;
+
+
+
+private
+
+   type Item is new gel.Applet.item with
+      record
+         null;
+      end record;
+
+end gel.Applet.server_world;

4-high/gel/source/applet/gel-applet-gui_and_sim_world.adb

@@ -0,0 +1,131 @@
+with
+     gel.World.simple,
+     gel.Camera.forge,
+     gel.Events,
+
+     lace.Event.utility;
+
+
+package body gel.Applet.gui_and_sim_world
+is
+
+   procedure define (Self : access Item;   Name       : in String;
+                                           use_Window : in gel.Window.view)
+   is
+      pragma Unreferenced (use_Window);
+      use lace.Event.utility;
+   begin
+      declare
+         the_world_Info : constant world_Info_view  := new world_Info;
+         the_Camera     : constant gel.Camera.view  := gel.Camera.forge.new_Camera;
+      begin
+         the_world_Info.World := gel.World.simple.forge.new_World (Name,
+                                                                   gui_world_Id,
+                                                                   space_Kind => physics.Bullet,
+                                                                   Renderer   => Self.Renderer).all'Access;
+
+         the_world_Info.World.register (Self.all'unchecked_Access,
+                                        to_Kind (gel.events.new_sprite_added_to_world_Event'Tag));
+
+         the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+         the_Camera.Renderer_is (Self.Renderer);
+         the_Camera.Site_is     ([0.0, 5.0, 5.0]);
+
+         the_world_Info.Cameras.append (the_Camera);
+         Self.Worlds           .append (the_world_Info);
+
+         Self.local_Subject_and_Observer.add (the_add_new_sprite_Response'Access,
+                                              to_Kind (gel.events.new_sprite_added_to_world_Event'Tag),
+                                              the_world_Info.World.Name);
+         the_world_Info.World.start;
+      end;
+
+      declare
+         the_world_Info : constant world_Info_view  := new world_Info;
+         the_Camera     : constant gel.Camera.View  := gel.Camera.forge.new_Camera;
+      begin
+         the_world_Info.World := gel.World.simple.forge.new_World (Name       => Name,
+                                                                   Id         => sim_world_Id,
+                                                                   space_Kind => physics.Bullet,
+                                                                   Renderer   => Self.Renderer).all'Access;
+
+         the_world_Info.World.register (the_Observer => Self.all'unchecked_Access,
+                                        of_Kind      => to_Kind (gel.events.new_sprite_added_to_world_Event'Tag));
+
+         the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+         the_Camera.Renderer_is (Self.Renderer);
+         the_Camera.Site_is     ([0.0, 5.0, 5.0]);
+
+         the_world_Info.Cameras.append (the_Camera);
+         Self.Worlds           .append (the_world_Info);
+
+         Self.local_Subject_and_Observer.add (the_add_new_sprite_Response'Access,
+                                              to_Kind (gel.events.new_sprite_added_to_world_Event'Tag),
+                                              the_world_Info.World.Name);
+         the_world_Info.World.start;
+      end;
+   end define;
+
+
+
+   package body Forge
+   is
+      function to_Applet (Name       : in String;
+                          use_Window : in gel.Window.view) return Item
+      is
+      begin
+         return Self : Item := (gel.Applet.Forge.to_Applet (Name, use_Window)
+                                with null record)
+         do
+            define (Self'unchecked_Access, Name, use_Window);
+         end return;
+      end to_Applet;
+
+
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return View
+      is
+         Self : constant View := new Item' (to_Applet (Name, use_Window));
+      begin
+         return Self;
+      end new_Applet;
+
+   end Forge;
+
+
+
+   function sim_World (Self : in Item) return gel.World.view
+   is
+   begin
+      return Self.World (sim_world_Id);
+   end sim_World;
+
+
+
+   function sim_Camera (Self : in Item) return gel.Camera.view
+   is
+   begin
+      return Self.Camera (sim_world_Id,
+                          sim_camera_Id);
+   end sim_Camera;
+
+
+
+   function gui_World (Self : in Item) return gel.World.view
+   is
+   begin
+      return Self.World (gui_world_Id);
+   end gui_World;
+
+
+
+   function gui_Camera (Self : in Item) return gel.Camera.view
+   is
+   begin
+      return Self.Camera (gui_world_Id,
+                          gui_camera_Id);
+   end gui_Camera;
+
+
+end gel.Applet.gui_and_sim_world;

4-high/gel/source/applet/gel-applet-gui_and_sim_world.ads

@@ -0,0 +1,48 @@
+with
+     gel.World,
+     gel.Camera,
+     gel.Window;
+
+
+package gel.Applet.gui_and_sim_world
+--
+-- Provides an applet configured with a single window and
+-- two worlds (generally a simulation world and a gui world).
+--
+is
+   type Item is limited new gel.Applet.item with private;
+   type View is access all Item'Class;
+
+
+   package Forge
+   is
+      function  to_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return Item;
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return View;
+   end Forge;
+
+
+   gui_world_Id  : constant gel. world_Id := 1;
+   gui_camera_Id : constant gel.camera_Id := 1;
+
+   sim_world_Id  : constant gel. world_Id := 2;
+   sim_camera_Id : constant gel.camera_Id := 1;
+
+
+   function gui_World  (Self : in Item) return gel.World .view;
+   function gui_Camera (Self : in Item) return gel.Camera.view;
+
+   function sim_World  (Self : in Item) return gel.World .view;
+   function sim_Camera (Self : in Item) return gel.Camera.view;
+
+
+
+private
+
+   type Item is limited new gel.Applet.item with
+      record
+         null;
+      end record;
+
+end gel.Applet.gui_and_sim_world;

4-high/gel/source/applet/gel-applet-gui_world.adb

@@ -0,0 +1,85 @@
+with
+     gel.World.simple,
+     gel.Events,
+     gel.Camera.forge,
+     lace.Event.utility,
+     ada.unchecked_Deallocation;
+
+
+package body gel.Applet.gui_world
+is
+
+   procedure define (Self : in gel.Applet.gui_world.view;   Name       : in String;
+                                                            space_Kind : in physics.space_Kind)
+   is
+      use lace.Event.utility;
+
+      the_world_Info : constant world_Info_view  := new world_Info;
+      the_Camera     : constant gel.Camera.View  := gel.Camera.forge.new_Camera;
+   begin
+      the_world_Info.World := gel.World.simple.Forge.new_World (Name,
+                                                                gui_world_Id,
+                                                                space_Kind,
+                                                                Self.Renderer).all'Access;
+
+      the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+      the_Camera.Renderer_is  (Self.Renderer);
+      the_Camera.Site_is      ([0.0, 5.0, 50.0]);
+
+      the_world_Info.Cameras.append (the_Camera);
+
+      Self.Worlds.append (the_world_Info);
+
+      Self.local_Subject_and_Observer.add (the_add_new_sprite_Response'Access,
+                                           to_Kind (gel.events.new_sprite_added_to_world_Event'Tag),
+                                           the_world_Info.World.Name);
+      the_world_Info.World.start;
+   end define;
+
+
+
+   package body Forge
+   is
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view;
+                           space_Kind : in physics.space_Kind) return gel.Applet.gui_world.view
+      is
+         Self : constant View := new Item' (gel.Applet.Forge.to_Applet (Name, use_Window)
+                                            with null record);
+      begin
+         define (Self, Name, space_Kind);
+         return Self;
+      end new_Applet;
+
+   end Forge;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+
+   function gui_World (Self : in Item) return gel.World.view
+   is
+   begin
+      return Self.World (gui_world_Id);
+   end gui_World;
+
+
+
+   function gui_Camera (Self : in Item) return gel.Camera.view
+   is
+   begin
+      return Self.Camera (gui_world_Id,
+                          gui_camera_Id);
+   end gui_Camera;
+
+
+end gel.Applet.gui_world;

4-high/gel/source/applet/gel-applet-gui_world.ads

@@ -0,0 +1,41 @@
+with
+     gel.World,
+     gel.Camera,
+     gel.Window;
+
+
+package gel.Applet.gui_world
+--
+--  Provides a gel applet configured with a single window and a single GUI world.
+--
+is
+   type Item is new gel.Applet.item with private;
+   type View is access all Item'Class;
+
+
+   package Forge
+   is
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view;
+                           space_Kind : in physics.space_Kind) return gel.Applet.gui_world.view;
+   end Forge;
+
+   procedure free (Self : in out View);
+
+
+   gui_world_Id  : constant  world_Id := 1;
+   gui_camera_Id : constant camera_Id := 1;
+
+   function gui_World  (Self : in Item) return gel.World .view;
+   function gui_Camera (Self : in Item) return gel.Camera.view;
+
+
+
+private
+
+   type Item is new gel.Applet.item with
+      record
+         null;
+      end record;
+
+end gel.Applet.gui_world;

4-high/gel/source/applet/gel-applet-sim_2d_world.adb

@@ -0,0 +1,68 @@
+with
+     gel.Camera.forge,
+     gel.World.simple;
+
+
+package body gel.Applet.sim_2D_world
+is
+
+   sim_world_Id  : constant gel.world_Id  := 1;
+   sim_camera_Id : constant gel.camera_Id := 1;
+
+
+
+   procedure define (Self : in View;   Name : in String)
+   is
+      the_world_Info : constant world_Info_view  := new world_Info;
+      the_Camera     : constant gel.Camera.View  := gel.Camera.forge.new_Camera;
+   begin
+      the_world_Info.World := gel.World.simple.forge.new_World (Name,
+                                                                sim_world_Id,
+                                                                physics.Box2d,
+                                                                Self.Renderer).all'Access;
+
+      the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+      the_Camera.Renderer_is (Self.Renderer);
+      the_Camera.Site_is     ((0.0, 5.0, 50.0));
+
+      the_world_Info.Cameras.append (the_Camera);
+
+      Self.Worlds.append (the_world_Info);
+   end define;
+
+
+
+   package body Forge
+   is
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return View
+      is
+         Self : constant View := new Item' (gel.Applet.Forge.to_Applet (Name, use_Window)
+                                            with null record);
+      begin
+         define (Self, Name);
+         return Self;
+      end new_Applet;
+
+   end Forge;
+
+
+
+   function sim_World (Self : in Item) return gel.World.view
+   is
+   begin
+      return Self.World (sim_world_Id);
+   end sim_World;
+
+
+
+   function sim_Camera (Self : in Item) return gel.Camera.view
+   is
+   begin
+      return Self.Camera (sim_world_Id,
+                          sim_camera_Id);
+   end sim_Camera;
+
+
+end gel.Applet.sim_2D_world;

4-high/gel/source/applet/gel-applet-sim_2d_world.ads

@@ -0,0 +1,35 @@
+with
+     gel.World,
+     gel.Camera,
+     gel.Window;
+
+
+package gel.Applet.sim_2D_world
+--
+--  Provides an applet configured with a single window and a single 2D world.
+--
+is
+   type Item is new gel.Applet.item with private;
+   type View is access all Item'Class;
+
+
+   package Forge
+   is
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return View;
+   end Forge;
+
+
+   function sim_World  (Self : in Item) return gel.World .view;
+   function sim_Camera (Self : in Item) return gel.Camera.view;
+
+
+
+private
+
+   type Item is new gel.Applet.item with
+      record
+         null;
+      end record;
+
+end gel.Applet.sim_2D_world;

4-high/gel/source/applet/gel-applet.adb

@@ -0,0 +1,996 @@
+with
+     gel.World.simple,
+     gel.Dolly.simple,
+     gel.Dolly.following,
+     gel.Camera.forge,
+     gel.Joint,
+     gel.Events,
+
+     openGL.Palette,
+     openGL.Renderer.lean.forge,
+
+     lace.Any,
+     lace.Event.utility,
+
+     ada.unchecked_Conversion,
+     ada.unchecked_Deallocation,
+     ada.Text_IO;
+
+use ada.Text_IO;
+
+
+package body gel.Applet
+is
+   use lace.Event.utility;
+
+
+   procedure my_context_Setter
+   is
+   begin
+      global_Window.enable_GL;
+   end my_context_Setter;
+
+
+   procedure my_Swapper
+   is
+   begin
+      global_Window.swap_GL;
+   end my_Swapper;
+
+
+   overriding
+   procedure respond (Self : in out add_new_Sprite;   to_Event : in lace.Event.item'Class)
+   is
+      the_Event : constant gel.events.new_sprite_added_to_world_Event
+        := gel.events.new_sprite_added_to_world_Event (to_Event);
+
+      the_Sprite : gel.Sprite.view;
+
+   begin
+      the_Sprite := Self.Applet.World (the_Event.World_Id).fetch_Sprite (the_event.Sprite_Id);
+
+      the_Sprite.is_Visible (True);
+      Self.Applet.add (the_Sprite);
+
+   exception
+      when constraint_Error =>
+         put_Line ("Exception in 'add_new_Sprite' response.");
+   end respond;
+
+
+   overriding
+   function Name (Self : in add_new_Sprite) return String
+   is
+      pragma unreferenced (Self);
+   begin
+      return "add_new_Sprite";
+   end Name;
+
+
+
+   procedure define (Self : in View;   use_Window : in gel.Window.view)
+   is
+   begin
+      Self.Window   := use_Window;
+      global_Window := use_Window;
+
+      -- Add window resize event repsonse.
+      --
+      Self.local_Subject_and_Observer.add (Self.resize_Response'unchecked_Access,
+                                           to_Kind (gel.events.window_resize_Request'Tag),
+                                           use_Window.Name);
+
+      Self.Window.register (lace.Observer.view (Self.local_Subject_and_Observer),
+                            to_Kind (gel.events.window_resize_Request'Tag));
+
+      Self.resize_Response.Applet := Self;
+
+      -- Setup the renderer.
+      --
+      Self.Renderer := openGL.Renderer.lean.forge.new_Renderer;
+
+      Self.Renderer.Background_is (openGL.Palette.Grey);
+      Self.Renderer.Swapper_is    (my_Swapper'unrestricted_Access);
+
+      Self.Window.disable_GL;
+
+      Self.Renderer.Context_Setter_is (my_context_Setter'unrestricted_Access);
+      Self.Renderer.start_Engine;
+
+      Self.Renderer.add_Font (Self.       Font);
+      Self.Renderer.add_Font (Self.titles_Font);
+
+      -- Set up the keyboard events.
+      --
+      Self.Keyboard := Self.Window.Keyboard;
+
+      Self.Mouse                          := Self.Window.Mouse;
+      Self.button_press_Response  .Applet := Self;
+      Self.button_release_Response.Applet := Self;
+      Self.mouse_motion_Response  .Applet := Self;
+
+      -- Add the new sprite event response.
+      --
+      the_add_new_sprite_Response.Applet := Self;
+
+   end define;
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      use world_Vectors,
+          gel.Dolly,
+          openGL.Renderer.lean,
+          gel.Window,
+          gel.World;
+
+      procedure free is new ada.unchecked_Deallocation (world_Info, world_Info_view);
+
+      Cursor     : world_Vectors.Cursor := Self.Worlds.First;
+
+      world_Info : world_Info_view;
+      the_World  : gel.World.view;
+
+   begin
+      while has_Element (Cursor)
+      loop
+         world_Info := Element (Cursor);
+
+         -- Free the world.
+         --
+         the_World := world_Info.World;
+         the_World.destroy;
+         free (the_World);
+
+         -- Free the cameras.
+         --
+         declare
+            use gel.Camera;
+
+            the_Cameras : camera_Vector renames world_Info.Cameras;
+            the_Camera  : gel.Camera.view;
+         begin
+            for i in 1 .. Integer (the_Cameras.Length)
+            loop
+               the_Camera := the_Cameras.Element (i);
+               free (the_Camera);
+            end loop;
+         end;
+
+         free (world_Info);
+         next (Cursor);
+      end loop;
+
+      free (Self.Dolly);
+      free (Self.Renderer);
+      free (Self.Window);
+
+      Self.local_Subject_and_Observer.destroy;
+      lace.Subject_and_deferred_Observer.item (Self).destroy;     -- Destroy base class.
+   end destroy;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Applet.item'Class, Applet.view);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+   ---------
+   --- Forge
+   --
+
+   package body Forge
+   is
+
+      function to_Applet (Name       : in String;
+                          use_Window : in gel.Window.view) return Item
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+      begin
+         return Self : Item := (to_Subject_and_Observer (Name) with
+                                local_Subject_and_Observer => new_Subject_and_Observer (Name),
+                                others                     => <>)
+         do
+            define (Self'unchecked_Access, use_Window);
+         end return;
+      end to_Applet;
+
+
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return View
+      is
+      begin
+         return new Item' (to_Applet (Name, use_Window));
+      end new_Applet;
+
+   end Forge;
+
+
+   --------------
+   --- Attributes
+   --
+
+   procedure add (Self : in out Item;   the_World : in world_Info_view)
+   is
+   begin
+      Self.Worlds.append (the_World);
+   end add;
+
+
+
+   function new_World (Self : access Item;   Name       : in String;
+                                             space_Kind : in physics.space_Kind) return gel.World.view
+   is
+   begin
+      Self.add_new_World (Name, space_Kind);
+      return Self.Worlds.last_Element.World;
+   end new_World;
+
+
+
+   procedure add_new_World (Self : in out Item;   Name       : in String;
+                                                  space_Kind : in physics.space_Kind)
+   is
+      use type ada.Containers.Count_type;
+
+      the_world_Info : constant world_Info_view  := new world_Info;
+      the_Camera     : constant gel.Camera.view  := gel.Camera.forge.new_Camera;
+   begin
+      the_world_Info.World := gel.World.simple.forge.new_World (Name,
+                                                                world_Id (Self.Worlds.Length + 1),
+                                                                space_Kind,
+                                                                Self.Renderer).all'Access;
+
+      the_Camera.Viewport_is (Self.Window.Width, Self.Window.Height);
+      the_Camera.Renderer_is (Self.Renderer);
+      the_Camera.Site_is     ([0.0, 5.0, 50.0]);
+
+      the_world_Info.Cameras.append (the_Camera);
+
+      Self.Worlds.append (the_world_Info);
+
+      Self.local_Subject_and_Observer.add (the_add_new_sprite_Response'Access,
+                                           to_Kind (gel.Events.new_sprite_added_to_world_Event'Tag),
+                                           the_world_Info.World.Name);
+      the_world_Info.World.start;
+
+      Self.add (the_world_Info);
+   end add_new_World;
+
+
+
+   function is_Open (Self : in Item) return Boolean
+   is
+   begin
+      return    Self.Window.is_Open
+        and not Self.quit_Requested;
+   end is_Open;
+
+
+
+   function Window (Self : in Item) return gel.Window.view
+   is
+   begin
+      return Self.Window;
+   end Window;
+
+
+
+   function world_Count (Self : in Item) return Natural
+   is
+   begin
+      return Natural (Self.Worlds.Length);
+   end world_Count;
+
+
+
+   function Worlds (Self : in Item) return gel.World.views
+   is
+      the_Worlds : gel.World.views (1 .. Natural (Self.Worlds.Length));
+   begin
+      for i in the_Worlds'Range
+      loop
+         the_Worlds (i) := Self.Worlds.Element (i).World;
+      end loop;
+
+      return the_Worlds;
+   end Worlds;
+
+
+
+   function World (Self : in Item;   Id : in world_Id := 1) return gel.World.view
+   is
+   begin
+      return Self.Worlds.Element (Integer (Id)).World;
+   end World;
+
+
+
+   function World_as_iFace (Self : in Item;   Id : in world_Id := 1) return gel.remote.World.view
+   is
+   begin
+      return remote.World.view (Self.Worlds.Element (Integer (Id)).World);
+   end World_as_iFace;
+
+
+
+   function Camera (Self : in Item;   world_Id  : in gel.world_Id  := 1;
+                                      camera_Id : in gel.camera_Id := 1) return gel.Camera.view
+   is
+      w : constant Integer := Integer ( world_Id);
+      c : constant Integer := Integer (camera_Id);
+   begin
+      return Self.Worlds.Element (w).Cameras.Element (c);
+   end Camera;
+
+
+
+   function Font (Self : in Item) return opengl.Font.font_Id
+   is
+   begin
+      return Self.Font;
+   end Font;
+
+
+
+   function titles_Font (Self : in Item) return opengl.Font.font_Id
+   is
+   begin
+      return Self.titles_Font;
+   end titles_Font;
+
+
+
+   function Renderer (Self : in Item) return openGL.Renderer.lean.view
+   is
+   begin
+      return Self.Renderer;
+   end Renderer;
+
+
+
+   function Keyboard (Self : in Item) return access gel.Keyboard.item'Class
+   is
+   begin
+      return Self.Keyboard;
+   end Keyboard;
+
+
+
+   function Mouse (Self : in Item) return access gel.Mouse.item'Class
+   is
+   begin
+      return Self.Mouse;
+   end Mouse;
+
+
+
+   function Dolly (Self : access Item) return gel.Dolly.view
+   is
+   begin
+      return Self.Dolly;
+   end Dolly;
+
+
+
+   function last_Keypress (Self : access Item) return gel.Keyboard.Key
+   is
+      the_last_Keypress : constant gel.Keyboard.Key := Self.last_pressed_Key;
+   begin
+      Self.last_pressed_Key := gel.Keyboard.Nil;
+      return the_last_Keypress;
+   end last_Keypress;
+
+
+   --------------
+   --- Operations
+   --
+
+   procedure evolve_all_Worlds (Self : in out Item;   By : in Duration)
+   is
+      use world_Vectors;
+      world_Cursor : world_Vectors.Cursor := Self.Worlds.First;
+
+   begin
+      while has_Element (world_Cursor)
+      loop
+         declare
+            the_world_Info : world_Info renames Element (world_Cursor).all;
+         begin
+            the_world_Info.World.evolve;
+         end;
+
+         next (world_Cursor);
+      end loop;
+   end evolve_all_Worlds;
+
+
+
+   procedure freshen (Self : in out Item)
+   is
+      use type gel.Dolly.view;
+
+      Window_is_active : Boolean;
+
+   begin
+      Self.Window.emit_Events;
+      Self.Window.swap_GL;
+
+      Self                           .respond;
+      Self.local_Subject_and_Observer.respond;
+      Self.Window                    .respond;
+
+      if Self.Dolly /= null then
+         Self.Dolly.freshen;
+      end if;
+
+      Window_is_active :=              Self.Window.is_Open
+                          and then     Self.Window.is_Exposed
+                          and then not Self.Window.is_being_Resized;
+      declare
+         use world_Vectors;
+         world_Cursor     : world_Vectors.Cursor        := Self.Worlds.First;
+         all_Cameras      : gel.Camera.views (1 .. 1000);
+         all_cameras_Last : Natural                     := 0;
+
+      begin
+         while has_Element (world_Cursor)
+         loop
+            declare
+               use camera_Vectors;
+               the_world_Info : world_Info       renames Element (world_Cursor).all;
+               camera_Cursor  : camera_Vectors.Cursor := the_world_Info.Cameras.First;
+            begin
+               --  the_world_Info.World.wait_on_evolve;
+               the_world_Info.World.evolve;
+
+               if Window_is_active
+               then
+                  while has_Element (camera_Cursor)
+                  loop
+                     all_cameras_Last               := all_cameras_Last + 1;
+                     all_Cameras (all_cameras_Last) := Element (camera_Cursor);
+                     Element (camera_Cursor).render (the_world_Info.World,
+                                                     To => Self.Window.Surface);
+                     next (camera_Cursor);
+                  end loop;
+               end if;
+            end;
+
+            next (world_Cursor);
+         end loop;
+
+         loop
+            declare
+               culls_Completed : Boolean := True;
+            begin
+               for i in 1 .. all_cameras_Last
+               loop
+                  culls_Completed :=     culls_Completed
+                                     and all_Cameras (i).cull_Completed;
+               end loop;
+
+               exit when culls_Completed;
+               delay Duration'Small;
+            end;
+         end loop;
+      end;
+
+      Self.Renderer.render;
+   end freshen;
+
+
+
+   procedure add (Self : in out Item;   the_Sprite : in gel.Sprite.view)
+   is
+      child_Joints : constant gel.Joint.views := the_Sprite.child_Joints;
+   begin
+      --  Add children and their joints.
+      --
+      for i in child_Joints'Range
+      loop
+         Self          .add (the_Sprite.child_Joints (i).Sprite_B);
+         Self.World (1).add (the_Sprite.child_Joints (i));
+      end loop;
+   end add;
+
+
+
+   procedure add (Self : in out Item;   the_Sprite : in gel.Sprite.view;
+                                        at_site    : in Vector_3)
+   is
+   begin
+      the_Sprite.Site_is (at_site);
+      Self.add (the_Sprite);
+   end add;
+
+
+
+   procedure take_Screenshot (Self : in out Item;   Filename : in String)
+   is
+   begin
+      Self.Renderer.Screenshot (Filename);
+   end take_Screenshot;
+
+
+
+   procedure request_Quit (Self : in out Item)
+   is
+   begin
+      Self.quit_Requested := True;
+   end request_Quit;
+
+
+
+   procedure toggle_video_Capture (Self : in out Item'Class)
+   is
+   begin
+      raise Error with "TODO";
+   end toggle_video_Capture;
+
+
+   ----------------------
+   --  Keyboard Responses
+   --
+
+   overriding
+   procedure respond (Self : in out key_press_Response;   to_Event : in lace.Event.item'Class)
+   is
+      use gel.Keyboard,
+          gel.Dolly;
+
+      the_Event     :          gel.Keyboard.key_press_Event renames gel.Keyboard.key_press_Event (to_Event);
+      the_Dolly     : constant gel.Dolly.view               :=      Self.Applet.Dolly;
+
+      the_Key       : constant gel.keyboard.Key             :=      the_Event.modified_Key.Key;
+      the_Modifiers : constant gel.Keyboard.modifier_Set    :=      the_Event.modified_Key.modifier_Set;
+
+   begin
+      Self.Applet.last_pressed_Key := the_Event.modified_Key.Key;
+
+      if the_Key = ESCAPE
+      then
+         Self.Applet.quit_Requested := True;
+      end if;
+
+      if the_Dolly /= null
+      then
+         if the_Modifiers (lShift)
+         then   the_Dolly.speed_Multiplier_is (6.0);
+         else   the_Dolly.speed_Multiplier_is (1.0);
+         end if;
+
+
+         if the_Modifiers (lCtrl)
+         then
+            if    the_Key = up       then   the_Dolly.is_spinning (Forward);
+            elsif the_Key = down     then   the_Dolly.is_spinning (Backward);
+            elsif the_Key = left     then   the_Dolly.is_spinning (Left);
+            elsif the_Key = right    then   the_Dolly.is_spinning (Right);
+            elsif the_Key = pageUp   then   the_Dolly.is_spinning (Up);
+            elsif the_Key = pageDown then   the_Dolly.is_spinning (Down);
+            end if;
+
+         elsif the_Modifiers (lAlt)
+         then
+            if    the_Key = up       then   the_Dolly.is_orbiting (Forward);
+            elsif the_Key = down     then   the_Dolly.is_orbiting (Backward);
+            elsif the_Key = left     then   the_Dolly.is_orbiting (Left);
+            elsif the_Key = right    then   the_Dolly.is_orbiting (Right);
+            elsif the_Key = pageUp   then   the_Dolly.is_orbiting (Up);
+            elsif the_Key = pageDown then   the_Dolly.is_orbiting (Down);
+            end if;
+
+         else
+            if    the_Key = up       then   the_Dolly.is_moving (Forward);
+            elsif the_Key = down     then   the_Dolly.is_moving (Backward);
+            elsif the_Key = left     then   the_Dolly.is_moving (Left);
+            elsif the_Key = right    then   the_Dolly.is_moving (Right);
+            elsif the_Key = pageUp   then   the_Dolly.is_moving (Up);
+            elsif the_Key = pageDown then   the_Dolly.is_moving (Down);
+            elsif the_Key = F11      then   Self.Applet.take_Screenshot ("./screenshot.bmp");
+            elsif the_Key = F12      then   Self.Applet.toggle_video_Capture;
+            end if;
+         end if;
+      end if;
+
+      if    the_Modifiers (lCtrl)
+      then
+         null;
+
+      elsif the_Modifiers (lAlt)
+      then
+         null;
+
+      else
+         if    the_Key = F11 then   Self.Applet.take_Screenshot  ("./screenshot.bmp");
+         elsif the_Key = F12 then   Self.Applet.toggle_video_Capture;
+         end if;
+      end if;
+
+   end respond;
+
+
+   overriding
+   procedure respond (Self : in out key_release_Response;   to_Event : in lace.Event.Item'Class)
+   is
+      use gel.Keyboard, gel.Dolly;
+
+      the_Event     :          gel.Keyboard.key_release_Event renames gel.Keyboard.key_release_Event (to_Event);
+      the_Dolly     :          gel.Dolly.view                 renames Self.Applet.Dolly;
+
+      the_Key       : constant gel.keyboard.Key               :=      the_Event.modified_Key.Key;
+      the_Modifiers : constant gel.Keyboard.modifier_Set      :=      the_Event.modified_Key.modifier_Set;
+      pragma Unreferenced (the_Modifiers);
+   begin
+      if the_Dolly = null
+      then
+         return;
+      end if;
+
+      if the_Key = up
+      then
+         the_Dolly.is_moving   (Forward,  False);
+         the_Dolly.is_spinning (Forward,  False);
+         the_Dolly.is_orbiting (Forward,  False);
+
+      elsif the_Key = down
+      then
+         the_Dolly.is_moving   (Backward,  False);
+         the_Dolly.is_spinning (Backward,  False);
+         the_Dolly.is_orbiting (Backward,  False);
+
+      elsif the_Key = left
+      then
+         the_Dolly.is_moving   (Left,  False);
+         the_Dolly.is_spinning (Left,  False);
+         the_Dolly.is_orbiting (Left,  False);
+
+      elsif the_Key = right
+      then
+         the_Dolly.is_moving   (Right,  False);
+         the_Dolly.is_spinning (Right,  False);
+         the_Dolly.is_orbiting (Right,  False);
+
+      elsif the_Key = pageUp
+      then
+         the_Dolly.is_moving   (Up,  False);
+         the_Dolly.is_spinning (Up,  False);
+         the_Dolly.is_orbiting (Up,  False);
+
+      elsif the_Key = pageDown
+      then
+         the_Dolly.is_moving   (Down,  False);
+         the_Dolly.is_spinning (Down,  False);
+         the_Dolly.is_orbiting (Down,  False);
+      end if;
+
+   end respond;
+
+
+
+   procedure Dolly_is (Self : access Item;   Now : in gel.Dolly.view)
+   is
+   begin
+      Self.Dolly := Now;
+   end Dolly_is;
+
+
+
+   procedure enable_simple_Dolly (Self : access Item;   in_World : in world_Id)
+   is
+   begin
+      Self.Dolly := new gel.Dolly.simple.item;
+      Self.Dolly.add_Camera (Self.Camera (in_World, 1));
+
+      Self.key_press_Response  .Applet := gel.Applet.view (Self);
+      Self.key_release_Response.Applet := gel.Applet.view (Self);
+
+      lace.Event.utility.connect (lace.Observer.view (Self.local_Subject_and_Observer),
+                                  lace.Subject .view (Self.Keyboard),
+                                  Self.key_press_Response'unchecked_Access,
+                                  to_Kind (gel.Keyboard.key_press_Event'Tag));
+
+      lace.Event.utility.connect (lace.Observer.view (Self.local_Subject_and_Observer),
+                                  lace.Subject .view (Self.Keyboard),
+                                  Self.key_release_Response'unchecked_Access,
+                                  to_Kind (gel.Keyboard.key_release_Event'Tag));
+   end enable_simple_Dolly;
+
+
+
+   procedure enable_following_Dolly (Self : access Item;   Follow : in gel.Sprite.view)
+   is
+      the_Dolly : constant gel.Dolly.following.view := new gel.Dolly.following.item;
+   begin
+      the_Dolly.follow (the_Sprite => Follow);
+
+      Self.Dolly := the_Dolly.all'Access;
+      Self.Dolly.add_Camera (Self.Camera (1, 1));
+   end enable_following_Dolly;
+
+
+   --------------------------
+   --- Mouse Button Responses
+   --
+
+   type button_press_raycast_Context is new lace.Any.limited_item with
+      record
+         is_Motion : Boolean;
+         is_Press  : Boolean;
+         button_Id : gel.mouse.Button_Id;
+      end record;
+
+   type button_press_raycast_Context_view is access all button_press_raycast_Context'Class;
+
+
+   overriding
+   procedure respond (Self : in out mouse_click_raycast_Response;   to_Event : in lace.Event.item'Class)
+   is
+      use gel.World;
+
+      the_Event   :          raycast_collision_Event           := raycast_collision_Event (to_Event);
+      the_Context : constant button_press_raycast_Context_view := button_press_raycast_Context_view (the_Event.Context);
+   begin
+      if the_Context.is_Motion
+      then
+         null;
+
+      else
+         if the_Context.is_Press
+         then
+            declare
+               collide_Event : constant gel.events.sprite_click_down_Event := (mouse_Button => the_Context.button_Id,
+                                                                               world_Site   => the_Event.Site_world);
+            begin
+               the_Event.near_Sprite.receive (collide_Event, Self.Applet.Name);
+            end;
+
+         else   -- Is a button release.
+            declare
+               collide_Event : constant gel.events.sprite_click_up_Event := (mouse_Button => the_Context.button_Id,
+                                                                             world_Site   => the_Event.Site_world);
+            begin
+               the_Event.near_Sprite.receive (collide_Event, Self.Applet.Name);
+            end;
+         end if;
+      end if;
+
+      the_Event.destruct;
+   end respond;
+
+
+   type mouse_button_collision_Event is new gel.World.raycast_collision_Event with null record;
+
+
+   overriding
+   procedure respond (Self : in out button_press_Response;   to_Event : in lace.Event.item'Class)
+   is
+      use world_Vectors,
+          gel.Mouse;
+
+      the_Event       : gel.mouse.button_press_Event renames gel.Mouse.button_press_Event (to_Event);
+      Cursor          : world_Vectors.Cursor         :=      Self.Applet.Worlds.First;
+      the_world_Info  : world_Info_view;
+
+   begin
+      while has_Element (Cursor)
+      loop
+         the_world_Info := Element (Cursor);
+
+         declare
+            use gel.World;
+
+            the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element;
+
+            Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)),
+                                                      Real (the_Event.Site (2)),
+                                                      1.0];
+            Site_world_space  : constant Vector_3 := the_Camera.to_world_Site (Site_window_space);
+
+            the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context;
+            event_Kind  :          mouse_button_collision_Event;
+
+         begin
+            the_Context.is_Motion := False;
+            the_Context.is_Press  := True;
+            the_Context.button_Id := the_Event.Button;
+
+            the_world_Info.World.cast_Ray (From     => the_Camera.Site,
+                                           To       => Site_world_space,
+                                           Observer => lace.Observer.view (Self.Applet.local_Subject_and_Observer),
+                                           Context  => the_Context,
+                                           event_Kind => event_Kind);
+         end;
+
+         next (Cursor);
+      end loop;
+   end respond;
+
+
+
+   overriding
+   procedure respond (Self : in out button_release_Response;   to_Event : in lace.Event.item'Class)
+   is
+      use world_Vectors,
+          gel.Mouse;
+
+      the_Event      : gel.Mouse.button_release_Event renames gel.Mouse.button_release_Event (to_Event);
+      Cursor         : world_Vectors.Cursor           :=      Self.Applet.Worlds.First;
+      the_world_Info : world_Info_view;
+
+   begin
+      while has_Element (Cursor)
+      loop
+         the_world_Info := Element (Cursor);
+
+         declare
+            the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element;
+
+            Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)),  Real (the_Event.Site (2)),  1.0];
+            Site_world_space  : constant Vector_3 := the_Camera.to_world_Site (Site_window_space);
+
+            the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context;
+            event_Kind  :          mouse_button_collision_Event;
+
+         begin
+            the_Context.is_Motion := False;
+            the_Context.is_Press  := False;
+            the_Context.button_Id := the_Event.Button;
+
+            the_world_Info.World.cast_Ray (From     => the_Camera.Site,
+                                           To       => Site_world_space,
+                                           Observer => lace.Observer.view (Self.Applet.local_Subject_and_Observer),
+                                           Context  => the_Context,
+                                           event_Kind => event_Kind);
+         end;
+
+         next (Cursor);
+      end loop;
+   end respond;
+
+
+
+   overriding
+   procedure respond (Self : in out mouse_motion_Response;   to_Event : in lace.Event.Item'Class)
+   is
+      use world_Vectors;
+
+      the_Event      : gel.mouse.motion_Event renames gel.mouse.motion_Event (to_Event);
+      Cursor         : world_Vectors.Cursor   :=      Self.Applet.Worlds.First;
+      the_world_Info : world_Info_view;
+
+   begin
+      while has_Element (Cursor)
+      loop
+         the_world_Info := Element (Cursor);
+
+         declare
+            the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element;
+
+            Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)),  Real (the_Event.Site (2)),  1.0];
+            Site_world_space  : constant Vector_3 := the_Camera.to_world_Site (Site_window_space);
+            pragma Unreferenced (Site_world_space);
+
+            the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context;
+
+         begin
+            the_Context.is_Motion := True;
+         end;
+
+         next (Cursor);
+      end loop;
+
+   end respond;
+
+
+   --------------------------
+   --- Window Resize Response
+   --
+
+   overriding
+   procedure respond (Self : in out resize_event_Response;   to_Event : in lace.Event.item'Class)
+   is
+      pragma unreferenced (to_Event);
+      use world_Vectors;
+
+      Cursor         : world_Vectors.Cursor := Self.Applet.Worlds.First;
+      the_world_Info : world_Info_view;
+   begin
+      while has_Element (Cursor)
+      loop
+         the_world_Info := Element (Cursor);
+
+         declare
+            the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element;
+         begin
+            the_Camera.Viewport_is (Self.Applet.Window.Width,
+                                    Self.Applet.Window.Height);
+         end;
+
+         next (Cursor);
+      end loop;
+   end respond;
+
+
+   ---------
+   --- Mouse
+   --
+
+   procedure enable_Mouse (Self : access Item;   detect_Motion : in Boolean)
+   is
+   begin
+      Self.local_Subject_and_Observer.add (Self.button_press_Response'unchecked_Access,
+                                           to_Kind (gel.Mouse.button_press_Event'Tag),
+                                           Self.Mouse.Name);
+
+      Self.local_Subject_and_Observer.add (Self.button_release_Response'unchecked_Access,
+                                           to_Kind (gel.Mouse.button_release_Event'Tag),
+                                           Self.Mouse.Name);
+
+      Self.Mouse.register (lace.Observer.view (Self.local_Subject_and_Observer),  to_Kind (gel.Mouse.button_press_Event  'Tag));
+      Self.Mouse.register (lace.Observer.view (Self.local_Subject_and_Observer),  to_Kind (gel.Mouse.button_release_Event'Tag));
+
+      if detect_Motion
+      then
+         lace.Event.Utility.connect (lace.Observer.view (Self.local_Subject_and_Observer),
+                                     lace.Subject.view  (Self.Mouse),
+                                     Self.mouse_motion_Response'unchecked_Access,
+                                     to_Kind (gel.Mouse.motion_Event'Tag));
+      end if;
+
+      Self.mouse_click_raycast_Response.Applet := Self.all'unchecked_Access;
+
+      declare
+         use world_Vectors;
+
+         Cursor         : world_Vectors.Cursor := Self.Worlds.First;
+         the_world_Info : world_Info_view;
+      begin
+         while has_Element (Cursor)
+         loop
+            the_world_Info := Element (Cursor);
+
+            Self.local_Subject_and_Observer.add (the_Response => Self.mouse_click_raycast_Response'unchecked_Access,
+                                                 to_Kind      => lace.event.Utility.to_Kind (mouse_button_collision_Event'Tag),
+                                                 from_Subject => the_world_Info.World.Name);
+            next (Cursor);
+         end loop;
+      end;
+
+   end enable_Mouse;
+
+
+   ----------------
+   --- Local Events
+   --
+
+   function local_Subject_and_Observer (Self : access Item) return lace.Subject_and_deferred_Observer.view
+   is
+   begin
+      return Self.local_Subject_and_Observer;
+   end local_Subject_and_Observer;
+
+
+   function local_Subject (Self : access Item) return lace.Subject.view
+   is
+   begin
+      return lace.Subject.view (Self.local_Subject_and_Observer);
+   end local_Subject;
+
+
+   function local_Observer (Self : access Item) return lace.Observer.view
+   is
+   begin
+      return lace.Observer.view (Self.local_Subject_and_Observer);
+   end local_Observer;
+
+
+end gel.Applet;

4-high/gel/source/applet/gel-applet.ads

@@ -0,0 +1,257 @@
+with
+     gel.remote.World,
+     gel.World,
+     gel.Camera,
+     gel.Keyboard,
+     gel.Mouse,
+     gel.Sprite,
+     gel.Dolly,
+     gel.Window,
+
+     openGL.Renderer.lean,
+     opengl.Font,
+
+     lace.Event,
+     lace.Response,
+     lace.Subject,
+     lace.Observer,
+     lace.Subject_and_deferred_Observer,
+
+     ada.Containers.Vectors;
+
+package gel.Applet
+--
+--  Provides an application model, configured with a single window.
+--
+is
+   type Item is limited new lace.Subject_and_deferred_Observer.item with private;
+   type View is access all Item'Class;
+
+
+   ----------
+   --- Forge
+   --
+
+   package Forge
+   is
+      function  to_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return Item;
+
+      function new_Applet (Name       : in String;
+                           use_Window : in gel.Window.view) return View;
+   end Forge;
+
+   overriding
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   ---------------
+   --- Attributes
+   --
+
+   function is_Open        (Self : in     Item) return        Boolean;
+
+   function Window         (Self : in     Item) return        gel.Window.view;
+   function Renderer       (Self : in     Item) return        openGL.Renderer.lean.view;
+   function Keyboard       (Self : in     Item) return access gel.Keyboard.item'Class;
+   function Mouse          (Self : in     Item) return access gel.Mouse   .item'Class;
+   function Dolly          (Self : access Item) return        gel.Dolly.view;
+
+   function last_Keypress  (Self : access Item) return        gel.Keyboard.Key;
+
+
+   function world_Count    (Self : in     Item) return Natural;
+   function Worlds         (Self : in     Item) return gel.World.views;
+   function World          (Self : in     Item;   Id : in world_Id := 1) return gel.World.view;
+   function World_as_iFace (Self : in     Item;   Id : in world_Id := 1) return gel.remote.World.view;
+
+   function Camera         (Self : in     Item;   world_Id  : in gel.world_Id  := 1;
+                                                  camera_Id : in gel.camera_Id := 1) return gel.Camera.view;
+
+   function        Font    (Self : in     Item) return opengl.Font.font_Id;
+   function titles_Font    (Self : in     Item) return opengl.Font.font_Id;
+
+
+   ---------------------------------
+   --- Add a new world and camera(s)
+   --
+
+   use type gel.Camera.view;
+   package camera_Vectors is new ada.Containers.Vectors (Positive, gel.Camera.view);
+   subtype camera_Vector  is     camera_Vectors.Vector;
+
+   type world_Info is
+      record
+         World   : gel.World.view;
+         Cameras : camera_Vector;
+      end record;
+
+   type world_Info_view is access all world_Info;
+
+   procedure add (Self : in out Item;   the_World : in world_Info_view);
+
+   procedure add_new_World (Self : in out Item;   Name       : in String;
+                                                  space_Kind : in physics.space_Kind);
+
+   function  new_World     (Self : access Item;   Name       : in String;
+                                                  space_Kind : in physics.space_Kind) return gel.World.view;
+
+   ---------------
+   --- Operations
+   --
+
+   use Math;
+
+   procedure evolve_all_Worlds (Self : in out Item;   By : in Duration);
+
+   procedure add (Self : in out Item;   the_Sprite : in gel.Sprite.view);
+   procedure add (Self : in out Item;   the_Sprite : in gel.Sprite.view;
+                                        at_site    : in Vector_3);
+
+   procedure Dolly_is               (Self : access Item;   Now      : in gel.Dolly.view);
+   procedure enable_simple_Dolly    (Self : access Item;   in_World : in world_Id);
+   procedure enable_following_Dolly (Self : access Item;   Follow   : in gel.Sprite.view);
+
+   procedure enable_Mouse (Self : access Item;   detect_Motion : in Boolean);
+
+   procedure prepare (Self : access Item) is null;
+   procedure freshen (Self : in out Item);
+   --
+   --  processes window events and then redraws the window.
+
+   procedure take_Screenshot (Self : in out Item;   Filename : in String);
+   procedure request_Quit    (Self : in out Item);
+
+   ----------
+   --- Events
+   --
+
+   function local_Subject_and_Observer
+                           (Self : access Item) return lace.Subject_and_deferred_Observer.view;
+   function local_Subject  (Self : access Item) return lace.Subject.view;
+   function local_Observer (Self : access Item) return lace.Observer.view;
+
+
+
+private
+
+   use type Sprite.view;
+   package sprite_Vectors is new ada.containers.Vectors (Positive, Sprite.view);
+
+
+   -------------------
+   --- Event Responses
+   --
+
+   type applet_event_Response is abstract new lace.Response.item with
+      record
+         Applet : gel.Applet.view;
+      end record;
+
+
+   -- 'add_new_Sprite' Response
+   --
+
+   type add_new_Sprite is new applet_event_Response with null record;
+
+   overriding
+   function  Name    (Self : in     add_new_Sprite) return String;
+   overriding
+   procedure respond (Self : in out add_new_Sprite;   to_Event : in lace.Event.item'Class);
+
+   the_add_new_sprite_Response : aliased add_new_Sprite;
+
+
+   -- 'Keyboard' Responses
+   --
+   type key_press_Response is new applet_event_Response with null record;
+   overriding
+   procedure respond (Self : in out key_press_Response;   to_Event : in lace.Event.item'Class);
+
+
+   type key_release_Response is new applet_event_Response with null record;
+   overriding
+   procedure respond (Self : in out key_release_Response; to_Event : in lace.Event.item'Class);
+
+
+   -- 'Mouse' Responses
+   --
+   type button_press_Response is new applet_event_Response with null record;
+   overriding
+   procedure respond (Self : in out button_press_Response;     to_Event : in lace.Event.item'Class);
+
+   type button_release_Response is new applet_event_Response with null record;
+   overriding
+   procedure respond (Self : in out button_release_Response;   to_Event : in lace.Event.item'Class);
+
+
+   type mouse_motion_Response is new applet_event_Response with null record;
+   overriding
+   procedure respond (Self : in out mouse_motion_Response;     to_Event : in lace.Event.item'Class);
+
+
+   type mouse_click_raycast_Response is new lace.Response.item with
+      record
+         Applet : gel.Applet.view;
+      end record;
+
+   overriding
+   procedure respond (Self : in out mouse_click_raycast_Response;   to_Event : in lace.Event.item'Class);
+
+   type mouse_click_raycast_Response_view is access all mouse_click_raycast_Response'Class;
+
+
+   -- 'Screen' Resize Response
+   --
+   type resize_event_Response is new applet_event_Response with null record;
+   overriding
+   procedure respond (Self : in out resize_event_Response;   to_Event : in lace.Event.Item'Class);
+
+
+   ----------------
+   --- world_Vector
+   --
+   use type gel.World.view;
+   package world_Vectors is new ada.Containers.Vectors (Positive, world_Info_view);
+   subtype world_Vector  is world_Vectors.Vector;
+
+
+   --------------
+   -- Applet Item
+   --
+   type Item is limited new lace.Subject_and_deferred_Observer.item with
+      record
+         local_Subject_and_Observer : lace.Subject_and_deferred_Observer.view := new lace.Subject_and_deferred_Observer.item;
+
+         Worlds : World_Vector;
+
+         Window          :         gel.Window.view;
+         resize_Response : aliased applet.resize_event_Response;
+
+         Keyboard             : access  gel.Keyboard.item'Class;
+         key_press_Response   : aliased applet.key_press_Response;
+         key_release_Response : aliased applet.key_release_Response;
+
+         Mouse                        : access  gel.Mouse.item'Class;
+         button_press_Response        : aliased applet.button_press_Response;
+         button_release_Response      : aliased applet.button_release_Response;
+         mouse_motion_Response        : aliased applet.mouse_motion_Response;
+         mouse_click_raycast_Response : aliased applet.mouse_click_raycast_Response;
+
+         Renderer           : openGL.Renderer.lean.view;
+         Font               : opengl.Font.font_Id := (openGL.to_Asset ("assets/opengl/font/LiberationMono-Regular.ttf"), 30);
+         titles_Font        : opengl.Font.font_Id := (openGL.to_Asset ("assets/opengl/font/LiberationMono-Regular.ttf"), 40);
+         is_capturing_Video : Boolean             := False;
+         Dolly              : gel.Dolly.view;
+
+         last_pressed_Key   : gel.Keyboard.Key := gel.Keyboard.Nil;
+         key_Focus          : gel.Sprite.view;
+
+         quit_Requested     : Boolean := False;
+      end record;
+
+   global_Window : gel.Window.view;
+
+
+end gel.Applet;

4-high/gel/source/concrete/gel-keyboard-local.adb

@@ -0,0 +1,107 @@
+with
+     ada.unchecked_Deallocation;
+
+package body gel.Keyboard.local
+is
+
+   package body Forge
+   is
+      function to_Keyboard (of_Name : in String) return Item
+      is
+      begin
+         return Self : constant Item := (lace.Subject.local.Forge.to_Subject (of_Name)
+                                         with no_Modifiers)
+         do
+            null;
+         end return;
+      end to_Keyboard;
+
+
+      function new_Keyboard (of_Name : in String) return View
+      is
+      begin
+         return new Item' (to_Keyboard (of_Name));
+      end new_Keyboard;
+
+   end Forge;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Modifiers (Self : in Item) return Modifier_Set
+   is
+   begin
+      return Self.Modifiers;
+   end Modifiers;
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure emit_key_press_Event (Self : in out Item;   Key      : in keyboard.Key;
+                                                         key_Code : in Integer)
+   is
+      the_key_press_Event : key_press_Event;
+   begin
+      case Key is
+         when LSHIFT    => Self.Modifiers (LSHIFT) := True;
+         when RSHIFT    => Self.Modifiers (RSHIFT) := True;
+         when LCTRL     => Self.Modifiers (LCTRL)  := True;
+         when RCTRL     => Self.Modifiers (RCTRL)  := True;
+         when LALT      => Self.Modifiers (LALT)   := True;
+         when RALT      => Self.Modifiers (RALT)   := True;
+         when LMETA     => Self.Modifiers (LMETA)  := True;
+         when RMETA     => Self.Modifiers (RMETA)  := True;
+         when NUMLOCK   => Self.Modifiers (NUM)    := True;
+         when CAPSLOCK  => Self.Modifiers (CAPS)   := True;
+         when MODE      => Self.Modifiers (MODE)   := True;
+         when others    => null;
+      end case;
+
+      the_key_press_Event := ((Key, Self.Modifiers),  key_Code);
+      Self.emit (the_key_press_Event);
+   end emit_key_press_Event;
+
+
+
+   overriding
+   procedure emit_key_release_Event (Self : in out Item;   Key : in keyboard.Key)
+   is
+      the_key_release_Event : key_release_Event;
+   begin
+      case Key is
+         when LSHIFT    => Self.Modifiers (LSHIFT) := False;
+         when RSHIFT    => Self.Modifiers (RSHIFT) := False;
+         when LCTRL     => Self.Modifiers (LCTRL)  := False;
+         when RCTRL     => Self.Modifiers (RCTRL)  := False;
+         when LALT      => Self.Modifiers (LALT)   := False;
+         when RALT      => Self.Modifiers (RALT)   := False;
+         when LMETA     => Self.Modifiers (LMETA)  := False;
+         when RMETA     => Self.Modifiers (RMETA)  := False;
+         when NUMLOCK   => Self.Modifiers (NUM)    := False;
+         when CAPSLOCK  => Self.Modifiers (CAPS)   := False;
+         when MODE      => Self.Modifiers (MODE)   := False;
+         when others    => null;
+      end case;
+
+      the_key_release_Event := (modified_Key => (Key, Self.Modifiers));
+      Self.emit (the_key_release_Event);
+   end emit_key_release_Event;
+
+
+end gel.Keyboard.local;

4-high/gel/source/concrete/gel-keyboard-local.ads

@@ -0,0 +1,54 @@
+with
+     lace.Subject.local;
+
+package gel.Keyboard.local
+--
+--  Provides a concrete keyboard.
+--
+is
+   type Item is limited new lace.Subject.local.item
+                        and gel.Keyboard.item with private;
+
+   type View is access all Item'class;
+
+
+
+   package Forge
+   is
+      function  to_Keyboard (of_Name : in String) return Item;
+      function new_Keyboard (of_Name : in String) return View;
+   end Forge;
+
+
+   procedure free (Self : in out View);
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Modifiers (Self : in Item) return Modifier_Set;
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure emit_key_press_Event   (Self : in out Item;   Key      : in keyboard.Key;
+                                                           key_Code : in Integer);
+   overriding
+   procedure emit_key_release_Event (Self : in out Item;   Key      : in keyboard.Key);
+
+
+
+private
+
+   type Item is limited new lace.Subject.local.item
+                        and gel.Keyboard.item with
+      record
+         Modifiers : Modifier_Set := no_Modifiers;
+      end record;
+
+end gel.Keyboard.local;

4-high/gel/source/concrete/gel-mouse-local.adb

@@ -0,0 +1,40 @@
+with
+     ada.unchecked_Deallocation;
+
+package body gel.Mouse.local
+is
+
+   package body Forge
+   is
+      function to_Mouse (of_Name : in String) return Item
+      is
+      begin
+         return Self : constant Item := (lace.Subject.local.Forge.to_Subject (of_Name)
+                                         with null record)
+         do
+            null;
+         end return;
+      end to_Mouse;
+
+
+
+      function new_Mouse (of_Name : in String) return View
+      is
+      begin
+         return new Item' (to_Mouse (of_Name));
+      end new_Mouse;
+
+   end Forge;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+end gel.Mouse.local;

4-high/gel/source/concrete/gel-mouse-local.ads

@@ -0,0 +1,31 @@
+with
+     lace.Subject.local;
+
+
+package gel.Mouse.local
+--
+-- Provides a concrete mouse.
+--
+is
+   type Item is limited new lace.Subject.local.item
+                        and gel.Mouse         .item with private;
+
+   type View is access all Item'Class;
+
+
+   package Forge
+   is
+      function  to_Mouse (of_Name : in String) return Item;
+      function new_Mouse (of_Name : in String) return View;
+   end Forge;
+
+   procedure free (Self : in out View);
+
+
+
+private
+
+   type Item is limited new lace.Subject.local.item
+                        and gel.Mouse         .item with null record;
+
+end gel.Mouse.local;

4-high/gel/source/dolly/gel-dolly-following.adb

@@ -0,0 +1,121 @@
+package body gel.Dolly.following
+is
+
+   overriding
+   procedure define  (Self : in out Item)
+   is
+   begin
+      null;
+   end define;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      null;
+   end destroy;
+
+
+   --------------
+   --- Attributes
+   --
+
+   procedure follow (Self : in out Item;   the_Sprite : in gel.Sprite.view)
+   is
+   begin
+      Self.Sprite := the_Sprite;
+   end follow;
+
+
+
+   overriding
+   procedure allow_linear_Motion  (Self : in out Item;   Allow : in Boolean := True)
+   is
+   begin
+      Self.allow_linear_Motion := Allow;
+   end allow_linear_Motion;
+
+
+
+   overriding
+   procedure allow_orbital_Motion (Self : in out Item;   Allow : in Boolean := True)
+   is
+   begin
+      Self.allow_orbital_Motion := Allow;
+   end allow_orbital_Motion;
+
+
+
+   function Offset (Self : in Item) return math.Vector_3
+   is
+   begin
+      return Self.sprite_Offset;
+   end Offset;
+
+
+
+   procedure Offset_is (Self : in out Item;   Now : in math.Vector_3)
+   is
+   begin
+      Self.sprite_Offset := Now;
+   end Offset_is;
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure freshen (Self : in out Item)
+   is
+      use Math,
+          linear_Algebra_3D;
+
+      Speed           :          math.Real  renames Self.Speed;
+      the_sprite_Site : constant math.Vector_3   := Self.Sprite.Site;
+      the_Camera      : constant gel.Camera.view := Self.Cameras.first_Element;
+
+   begin
+      --  Linear motion.
+      --
+      if Self.allow_linear_Motion
+      then
+         if Self.Motion (Forward)  then   Self.sprite_Offset := Self.sprite_Offset - the_Camera.Spin * [0.0, 0.0, 0.1 * Speed];   end if;
+         if Self.Motion (Backward) then   Self.sprite_Offset := Self.sprite_Offset + the_Camera.Spin * [0.0, 0.0, 0.1 * Speed];   end if;
+
+         if Self.Motion (Up)       then   Self.sprite_Offset := Self.sprite_Offset + the_Camera.Spin * [0.0, 0.1 * Speed, 0.0];   end if;
+         if Self.Motion (Down)     then   Self.sprite_Offset := Self.sprite_Offset - the_Camera.Spin * [0.0, 0.1 * Speed, 0.0];   end if;
+      end if;
+
+      --  Orbit.
+      --
+      if Self.allow_orbital_Motion
+      then
+         if Self.Motion (Left)
+         then
+            Self.camera_y_Spin := Self.camera_y_Spin - 0.01 * Speed;
+            Self.sprite_Offset := y_Rotation_from (-0.01 * Speed) * Self.sprite_Offset;
+
+            the_Camera.Spin_is (xyz_Rotation (Self.camera_x_Spin,
+                                              Self.camera_y_Spin,
+                                              Self.camera_z_Spin));
+         end if;
+
+         if Self.Motion (Right)
+         then
+            Self.camera_y_Spin := Self.camera_y_Spin + 0.01 * Speed;
+            Self.sprite_Offset := y_Rotation_from (0.01 * Speed) * Self.sprite_Offset;
+
+            the_Camera.Spin_is (xyz_Rotation (Self.camera_x_Spin,
+                                              Self.camera_y_Spin,
+                                              Self.camera_z_Spin));
+         end if;
+      end if;
+
+      the_Camera.Site_is (the_sprite_Site + Self.sprite_Offset);
+   end freshen;
+
+
+end gel.Dolly.following;

4-high/gel/source/dolly/gel-dolly-following.ads

@@ -0,0 +1,62 @@
+with
+     gel.Sprite;
+
+package gel.Dolly.following
+--
+--  Provides a camera dolly which follows a sprite.
+--
+is
+   type Item is new gel.Dolly.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   overriding
+   procedure define  (Self : in out Item);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   procedure allow_linear_Motion  (Self : in out Item;   Allow : in Boolean := True);
+   overriding
+   procedure allow_orbital_Motion (Self : in out Item;   Allow : in Boolean := True);
+
+   procedure Offset_is (Self : in out Item;   Now : in math.Vector_3);
+   function  Offset    (Self : in     Item)     return math.Vector_3;
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure freshen (Self : in out Item);
+
+   procedure follow  (Self : in out Item;   the_Sprite : in gel.Sprite.view);
+
+
+
+private
+
+   type Item is new gel.Dolly.item with
+      record
+         Sprite               : gel.Sprite.view;
+         sprite_Offset        : math.Vector_3 := [0.0, 30.0, 0.0];
+
+         allow_linear_Motion  : Boolean       := True;
+         allow_orbital_Motion : Boolean       := True;
+
+         camera_x_Spin        : math.Real     := 0.0;
+         camera_y_Spin        : math.Real     := 0.0;
+         camera_z_Spin        : math.Real     := 0.0;
+      end record;
+
+end gel.Dolly.following;

4-high/gel/source/dolly/gel-dolly-simple.adb

@@ -0,0 +1,154 @@
+package body gel.Dolly.simple
+is
+
+   overriding
+   procedure define (Self : in out Item)
+   is
+   begin
+      null;
+   end define;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      null;
+   end destroy;
+
+
+   --------------
+   --  Operations
+   --
+
+   overriding
+   procedure freshen (Self : in out Item)
+   is
+      use Math,
+          linear_Algebra_3D;
+
+      Speed         : constant Real := Self.Speed * Self.Multiplier;
+      rotate_Factor : constant Real := 0.04;
+      orbit_Factor  : constant Real := 0.08;
+
+      initial_Site  : constant Vector_3   := Self.Cameras.first_Element.Site;
+      initial_Spin  : constant Matrix_3x3 := Self.Cameras.first_Element.Spin;
+
+      new_Site      : Vector_3;
+      new_Spin      : Matrix_3x3;
+
+      site_Updated  : Boolean := False;
+      spin_Updated  : Boolean := False;
+
+      procedure update_Site (To : in Vector_3)
+      is
+      begin
+         new_Site     := To;
+         site_Updated := True;
+      end update_Site;
+
+      procedure update_Spin (To : in math.Matrix_3x3)
+      is
+      begin
+         new_Spin     := To;
+         spin_Updated := True;
+      end update_Spin;
+
+   begin
+      --  Linear Motion
+      --
+
+      if Self.Motion (Forward)  then   update_Site (initial_Site - forward_Direction (initial_Spin) * Speed);   end if;
+      if Self.Motion (Backward) then   update_Site (initial_Site + forward_Direction (initial_Spin) * Speed);   end if;
+
+      if Self.Motion (Left)     then   update_Site (initial_Site - right_Direction   (initial_Spin) * Speed);   end if;
+      if Self.Motion (Right)    then   update_Site (initial_Site + right_Direction   (initial_Spin) * Speed);   end if;
+
+      if Self.Motion (Up)       then   update_Site (initial_Site + up_Direction      (initial_Spin) * Speed);   end if;
+      if Self.Motion (Down)     then   update_Site (initial_Site - up_Direction      (initial_Spin) * Speed);   end if;
+
+      --  Angular Spin
+      --
+
+      if Self.Spin (Left)       then   update_Spin (y_Rotation_from (-rotate_Factor) * initial_Spin);     end if;
+      if Self.Spin (Right)      then   update_Spin (y_Rotation_from ( rotate_Factor) * initial_Spin);     end if;
+
+      if Self.Spin (Forward)    then   update_Spin (x_Rotation_from ( rotate_Factor) * initial_Spin);     end if;
+      if Self.Spin (Backward)   then   update_Spin (x_Rotation_from (-rotate_Factor) * initial_Spin);     end if;
+
+      if Self.Spin (Up)         then   update_Spin (z_Rotation_from (-rotate_Factor) * initial_Spin);     end if;
+      if Self.Spin (Down)       then   update_Spin (z_Rotation_from ( rotate_Factor) * initial_Spin);     end if;
+
+      --  Orbit
+      --
+
+      if Self.Orbit (Left)
+      then
+         update_Site (initial_Site * y_Rotation_from (orbit_Factor * Speed));
+         update_Spin (initial_Spin * y_Rotation_from (orbit_Factor * Speed));
+      end if;
+
+      if Self.Orbit (Right)
+      then
+         update_Site (initial_Site * y_Rotation_from (-orbit_Factor * Speed));
+         update_Spin (initial_Spin * y_Rotation_from (-orbit_Factor * Speed));
+      end if;
+
+
+      if Self.Orbit (Forward)
+      then
+         update_Site (initial_Site * x_Rotation_from (-orbit_Factor * Speed));
+         update_Spin (initial_Spin * x_Rotation_from (-orbit_Factor * Speed));
+      end if;
+
+      if Self.Orbit (Backward)
+      then
+         update_Site (initial_Site * x_Rotation_from (orbit_Factor * Speed));
+         update_Spin (initial_Spin * x_Rotation_from (orbit_Factor * Speed));
+      end if;
+
+
+      if Self.Orbit (Up)
+      then
+         update_Site (initial_Site * z_Rotation_from (-orbit_Factor * Speed));
+         update_Spin (initial_Spin * z_Rotation_from (-orbit_Factor * Speed));
+      end if;
+
+      if Self.Orbit (Down)
+      then
+         update_Site (initial_Site * z_Rotation_from (orbit_Factor * Speed));
+         update_Spin (initial_Spin * z_Rotation_from (orbit_Factor * Speed));
+      end if;
+
+
+      -- Update each camera with new site and spin.
+      --
+      declare
+         use camera_Vectors;
+         the_Camera : gel.Camera.view;
+         Cursor     : camera_Vectors.Cursor := Self.Cameras.First;
+      begin
+         while has_Element (Cursor)
+         loop
+            the_Camera := Element (Cursor);
+
+            if site_Updated
+            then
+               the_Camera.Site_is (new_Site);
+            end if;
+
+            if spin_Updated
+            then
+               the_Camera.Spin_is (new_Spin);
+            end if;
+
+            next (Cursor);
+         end loop;
+      end;
+
+   end freshen;
+
+
+end gel.Dolly.simple;
+

4-high/gel/source/dolly/gel-dolly-simple.ads

@@ -0,0 +1,35 @@
+package gel.Dolly.simple
+--
+--  Provides a simple camera dolly.
+--
+is
+   type Item is new gel.Dolly.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   overriding
+   procedure define  (Self : in out Item);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure freshen (Self : in out Item);
+
+
+
+private
+
+   type Direction_Flags is array (Direction) of Boolean;
+
+   type Item is new gel.Dolly.item with null record;
+
+end gel.Dolly.simple;

4-high/gel/source/dolly/gel-dolly.adb

@@ -0,0 +1,83 @@
+with
+     ada.unchecked_Deallocation;
+
+package body gel.Dolly
+is
+   use Math;
+
+
+   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;
+
+
+   --------------
+   --- Attributes
+   --
+
+   procedure add_Camera (Self : in out Item'Class;   the_Camera : in Camera.view)
+   is
+   begin
+      Self.Cameras.append (the_Camera);
+   end add_Camera;
+
+
+
+   procedure is_moving (Self : in out Item'Class;   Direction : dolly.Direction;   Now : in Boolean := True)
+   is
+   begin
+      Self.Motion (Direction) := Now;
+   end is_moving;
+
+
+
+   procedure is_spinning (Self : in out Item'Class;   Direction : dolly.Direction;   Now : in Boolean := True)
+   is
+   begin
+      Self.Spin (Direction) := Now;
+   end is_spinning;
+
+
+
+   procedure is_orbiting (Self : in out Item'Class;   Direction : dolly.Direction;   Now : in Boolean := True)
+   is
+   begin
+      Self.Orbit (Direction) := Now;
+   end is_orbiting;
+
+
+
+   procedure Speed_is (Self : in out Item;  Now : in Real)
+   is
+   begin
+      Self.Speed := Now;
+   end Speed_is;
+
+
+
+   function Speed (Self : in Item) return Real
+   is
+   begin
+      return Self.Speed;
+   end Speed;
+
+
+
+   procedure speed_Multiplier_is (Self : in out Item;  Now : in Real)
+   is
+   begin
+      Self.Multiplier := Now;
+   end speed_Multiplier_is;
+
+
+end gel.Dolly;
+

4-high/gel/source/dolly/gel-dolly.ads

@@ -0,0 +1,74 @@
+with
+     gel.Camera,
+     ada.Containers.Vectors;
+
+package gel.Dolly
+--
+--  Models a camera dolly.
+--
+is
+   type Item is abstract tagged private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define  (Self : in out Item)   is abstract;
+   procedure destroy (Self : in out Item)   is abstract;
+
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --- Attributes
+   --
+
+   type Direction is (Left, Right, Up, Down, Forward, Backward);
+
+   procedure add_Camera           (Self : in out Item'Class;   the_Camera : in Camera.view);
+
+   procedure is_moving            (Self : in out Item'Class;   Direction : dolly.Direction;   Now : in Boolean := True);
+   procedure is_spinning          (Self : in out Item'Class;   Direction : dolly.Direction;   Now : in Boolean := True);
+   procedure is_orbiting          (Self : in out Item'Class;   Direction : dolly.Direction;   Now : in Boolean := True);
+
+   function  Speed                (Self : in     Item)       return math.Real;
+   procedure Speed_is             (Self : in out Item;   Now   : in math.Real);
+   procedure speed_Multiplier_is  (Self : in out Item;   Now   : in math.Real);
+
+   procedure allow_linear_Motion  (Self : in out Item;   Allow : in Boolean) is null;
+   procedure allow_orbital_Motion (Self : in out Item;   Allow : in Boolean) is null;
+
+
+   --------------
+   --- Operations
+   --
+
+   procedure freshen (Self : in out Item) is abstract;
+
+
+
+private
+
+   use type gel.Camera.view;
+   package camera_Vectors is new ada.Containers.Vectors (Positive, gel.Camera.view);
+   subtype camera_Vector  is     camera_Vectors.Vector;
+
+   type Direction_Flags is array (Direction) of Boolean;
+
+
+   type Item is abstract tagged
+      record
+         Cameras    : camera_Vector;
+
+         Motion     : Direction_Flags := [others => False];
+         Spin       : Direction_Flags := [others => False];
+         Orbit      : Direction_Flags := [others => False];
+
+         Speed      : math.Real       := 1.0;
+         Multiplier : math.Real       := 1.0;     -- Applied to speed.
+      end record;
+
+
+end gel.Dolly;

4-high/gel/source/forge/gel-camera-forge.adb

@@ -0,0 +1,23 @@
+package body gel.Camera.forge
+is
+
+   function new_Camera return gel.Camera.item
+   is
+   begin
+      return the_Camera : gel.Camera.item
+      do
+         define (the_Camera);
+      end return;
+   end new_Camera;
+
+
+
+   function new_Camera return gel.Camera.view
+   is
+      Self : constant gel.Camera.view := new gel.Camera.item;
+   begin
+      Self.define;
+      return Self;
+   end new_Camera;
+
+end gel.Camera.forge;

4-high/gel/source/forge/gel-camera-forge.ads

@@ -0,0 +1,10 @@
+package gel.Camera.forge
+--
+-- Provides constructors for a camera.
+--
+is
+
+   function new_Camera return gel.Camera.item;
+   function new_Camera return gel.Camera.view;
+
+end gel.Camera.forge;

4-high/gel/source/forge/gel-forge.adb

@@ -0,0 +1,604 @@
+with
+     openGL.Model.text     .lit_colored,
+
+     openGL.Model.sphere   .lit_colored_textured,
+     openGL.Model.sphere   .lit_colored,
+     openGL.Model.sphere   .textured,
+     openGL.Model.sphere   .colored,
+
+     openGL.Model.polygon  .lit_colored,
+
+     openGL.Model.box      .colored,
+     openGL.Model.box      .textured,
+
+     openGL.Model.billboard.textured,
+     openGL.Model.billboard.colored_textured,
+
+     openGL.Model.arrow    .colored,
+     openGL.Model.line     .colored,
+     openGL.Model.segment_line,
+
+     physics.Model,
+     gel.Window;
+
+
+package body gel.Forge
+is
+
+   -----------
+   --- Applets
+   --
+
+   function new_gui_Applet (Named         : in String;
+                            window_Width  : in Positive := 500;
+                            window_Height : in Positive := 500;
+                            space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.gui_world.view
+   is
+      the_Window : constant gel.Window.view
+        := gel.Window.Forge.new_Window (Named,
+                                        window_Width,
+                                        window_Height);
+
+      the_Applet : constant gel.Applet.gui_world.view
+        := gel.Applet.gui_World.forge.new_Applet ("Applet." & Named,
+                                                  the_Window,
+                                                  space_Kind);
+   begin
+      return the_Applet;
+   end new_gui_Applet;
+
+
+
+   function new_gui_and_sim_Applet (Named         : in String;
+                                    window_Width  : in Positive := 500;
+                                    window_Height : in Positive := 500;
+                                    space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.gui_and_sim_World.view
+   is
+      pragma Unreferenced (space_Kind);
+      the_Window : constant gel.Window.view
+        := gel.Window.Forge.new_Window ("Window." & Named,
+                                        window_Width,
+                                        window_Height);
+
+      the_Applet : constant gel.Applet.gui_and_sim_World.view
+        := gel.Applet.gui_and_sim_World.forge.new_Applet ("Applet." & Named,
+                                                          the_Window);
+   begin
+      return the_Applet;
+   end new_gui_and_sim_Applet;
+
+
+
+   function new_server_Applet (Named         : in String;
+                               window_Width  : in Positive := 500;
+                               window_Height : in Positive := 500;
+                               space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.server_world.view
+   is
+      the_Window : constant gel.Window.view
+        := gel.Window.Forge.new_Window (Named,
+                                        window_Width,
+                                        window_Height);
+
+      the_Applet : constant gel.Applet.server_world.view
+        := gel.Applet.server_World.forge.new_Applet ("Applet." & Named,
+                                                     the_Window,
+                                                     space_Kind);
+   begin
+      return the_Applet;
+   end new_server_Applet;
+
+
+
+   function new_client_Applet (Named         : in String;
+                               window_Width  : in Positive := 500;
+                               window_Height : in Positive := 500;
+                               space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.client_world.view
+   is
+      the_Window : constant gel.Window.view
+        := gel.Window.Forge.new_Window (Named,
+                                        window_Width,
+                                        window_Height);
+
+      the_Applet : constant gel.Applet.client_world.view
+        := gel.Applet.client_World.forge.new_Applet ("Applet." & Named,
+                                                     the_Window,
+                                                     space_Kind);
+   begin
+      return the_Applet;
+   end new_client_Applet;
+
+
+   -----------
+   --- Sprites
+   --
+
+   -- 2D
+   --
+
+   function new_circle_Sprite (in_World : in gel.World.view;
+                               Site     : in math.Vector_2     := math.Origin_2D;
+                               Mass     : in math.Real         := 1.0;
+                               Friction : in math.Real         := 0.5;
+                               Bounce   : in math.Real         := 0.5;
+                               Radius   : in math.Real         := 0.5;
+                               Color    : in openGL.Color      := opengl.Palette.White;
+                               Texture  : in openGL.asset_Name := openGL.null_Asset) return gel.Sprite.view
+   is
+      use openGL;
+      use type Vector_2;
+
+      the_graphics_Model : openGL.Model.sphere.view;
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info  => (physics.Model.Circle, Radius),
+                                                  Mass        => Mass,
+                                                  Friction    => Friction,
+                                                  Restitution => Bounce);
+                                                  --  Site        => Vector_3 (Site & 0.0));
+   begin
+      if Texture = openGL.null_Asset
+      then
+         the_graphics_Model := openGL.Model.sphere.lit_colored.new_Sphere (Radius,
+                                                                           Color => (Color, openGL.Opaque)).all'Access;
+      else
+         the_graphics_Model := openGL.Model.sphere.lit_colored_textured.new_Sphere (Radius,
+                                                                                    Image => Texture).all'Access;
+      end if;
+
+      return gel.Sprite.Forge.new_Sprite ("circle_Sprite",
+                                          sprite.World_view (in_World),
+                                          Vector_3 (Site & 0.0),
+                                          the_graphics_Model,
+                                          the_physics_Model,
+                                          owns_graphics => True,
+                                          owns_physics  => True,
+                                          is_Kinematic  => False);
+   end new_circle_Sprite;
+
+
+
+   function new_polygon_Sprite (in_World : in gel.World.view;
+                                Site     : in math.Vector_2 := math.Origin_2D;
+                                Mass     : in math.Real     := 1.0;
+                                Friction : in math.Real     := 0.5;
+                                Bounce   : in math.Real     := 0.5;
+                                Vertices : in Geometry_2d.Sites;
+                                Color    : in openGL.Color  := opengl.Palette.White) return gel.Sprite.view
+   is
+      use Math;
+      use type Geometry_2d.Sites;
+
+      the_graphics_Model : constant openGL.Model.polygon.lit_colored.view
+        := openGL.Model.polygon.lit_colored.new_Polygon (openGL.Vector_2_array (Vertices),
+                                                         (Color, openGL.Opaque));
+
+      Padding            : constant Geometry_2d.Sites (1 .. 8 - Vertices'Length) := (others => <>);
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info  => (physics.Model.Polygon,
+                                                                  vertex_Count => Vertices'Length,
+                                                                  Vertices     => Vertices & Padding),
+                                                  --  Site        => Vector_3 (Site & 0.0),
+                                                  Mass        => Mass,
+                                                  Friction    => Friction,
+                                                  Restitution => Bounce);
+   begin
+      return gel.Sprite.Forge.new_Sprite ("polygon_Sprite",
+                                          sprite.World_view (in_World),
+                                          Vector_3 (Site & 0.0),
+                                          the_graphics_Model,
+                                          the_physics_Model,
+                                          owns_graphics => True,
+                                          owns_physics  => True,
+                                          is_Kinematic  => False);
+   end new_polygon_Sprite;
+
+
+
+   function new_rectangle_Sprite (in_World : in gel.World.view;
+                                  Site     : in math.Vector_2 := math.Origin_2D;
+                                  Mass     : in math.Real     := 1.0;
+                                  Friction : in math.Real     := 0.5;
+                                  Bounce   : in math.Real     := 0.5;
+                                  Width,
+                                  Height   : in math.Real;
+                                  Color    : in openGL.Color  := opengl.Palette.White) return gel.Sprite.view
+   is
+      use Math;
+
+      half_Width   : constant Real := Width  / 2.0;
+      half_Height  : constant Real := Height / 2.0;
+
+      the_Vertices : constant Geometry_2d.Sites (1 .. 4) := [[-half_Width, -half_Height],
+                                                             [ half_Width, -half_Height],
+                                                             [ half_Width,  half_Height],
+                                                             [-half_Width,  half_Height]];
+   begin
+      return new_polygon_Sprite (in_World, Site, Mass, Friction, Bounce, the_Vertices, Color);
+   end new_rectangle_Sprite;
+
+
+
+   -- 3D
+   --
+
+   function new_ball_Sprite (in_World   : in gel.World.view;
+                             Site       : in math.Vector_3      := math.Origin_3D;
+                             Mass       : in math.Real          := 1.0;
+                             Radius     : in math.Real          := 0.5;
+                             lat_Count  : in Positive           := openGL.Model.sphere.default_latitude_Count;
+                             long_Count : in Positive           := openGL.Model.sphere.default_longitude_Count;
+                             is_Lit     : in Boolean            := True;
+                             Color      : in openGL.lucid_Color := opengl.no_lucid_Color;
+                             Texture    : in openGL.asset_Name  := openGL.null_Asset) return gel.Sprite.view
+   is
+      use type openGL.lucid_Color;
+
+      the_graphics_Model : openGL.Model.sphere.view;
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (physics.Model.a_Sphere, Radius),
+                                                  Mass       => Mass);
+   begin
+      if is_Lit     -- TODO: Remaining combinations.
+      then
+         the_graphics_Model := openGL.Model.sphere.lit_colored_textured.new_Sphere (Radius,
+                                                                                    lat_Count  => lat_Count,
+                                                                                    long_Count => long_Count,
+                                                                                    Image      => Texture).all'Access;
+      else
+         if Color /= openGL.no_lucid_Color
+         then
+            the_graphics_Model := openGL.Model.sphere.colored.new_Sphere (Radius,
+                                                                          lat_Count  => lat_Count,
+                                                                          long_Count => long_Count,
+                                                                          Color      => Color).all'Access;
+         else
+            the_graphics_Model := openGL.Model.sphere.textured.new_Sphere (Radius,
+                                                                           lat_Count  => lat_Count,
+                                                                           long_Count => long_Count,
+                                                                           Image      => Texture).all'Access;
+         end if;
+      end if;
+
+      return gel.Sprite.Forge.new_Sprite ("ball_Sprite",
+                                          sprite.World_view (in_World),
+                                          Site,
+                                          the_graphics_Model,
+                                          the_physics_Model,
+                                          owns_Graphics => True,
+                                          owns_Physics  => True,
+                                          is_Kinematic  => False);
+   end new_ball_Sprite;
+
+
+
+   function new_skysphere_Sprite (in_World : in gel.World.view;
+                                  Site     : in math.Vector_3 := math.Origin_3D;
+                                  Radius   : in math.Real     := 1_000_000.0;
+                                  Texture  : in openGL.asset_Name) return gel.Sprite.view
+   is
+      the_graphics_Model : openGL.Model.sphere.view;
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (physics.Model.a_Sphere, Radius),
+                                                  Mass       => 0.0);
+   begin
+      the_graphics_Model := openGL.Model.sphere.textured.new_Sphere (Radius,
+                                                                     lat_Count    => 180,
+                                                                     Image        => Texture,
+                                                                     is_Skysphere => True).all'Access;
+      return gel.Sprite.Forge.new_Sprite ("skysphere_Sprite",
+                                          sprite.World_view (in_World),
+                                          Site,
+                                          the_graphics_Model,
+                                          the_physics_Model,
+                                          owns_Graphics => True,
+                                          owns_Physics  => True,
+                                          is_Kinematic  => False);
+   end new_skysphere_Sprite;
+
+
+
+   function new_box_Sprite (in_World     : in gel.World.view;
+                            Site         : in math.Vector_3 := math.Origin_3D;
+                            Mass         : in math.Real     := 1.0;
+                            Size         : in math.Vector_3 := [1.0, 1.0, 1.0];
+                            Colors       : in box_Colors    := [others => opengl.Palette.random_Color];
+                            is_Kinematic : in Boolean       := False) return gel.Sprite.view
+   is
+      use openGL.Model.box,
+          openGL,
+          Math;
+
+      the_box_Model : constant openGL.Model.box.colored.view
+        := openGL.Model.box.colored.new_Box (Size => Size,
+                                             Faces => [Front => (Colors => [others => (Colors (1), Opaque)]),
+                                                       Rear  => (Colors => [others => (Colors (2), Opaque)]),
+                                                       Upper => (Colors => [others => (Colors (3), Opaque)]),
+                                                       Lower => (Colors => [others => (Colors (4), Opaque)]),
+                                                       Left  => (Colors => [others => (Colors (5), Opaque)]),
+                                                       Right => (Colors => [others => (Colors (6), Opaque)])]);
+      the_box_physics_Model : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                                 --  half_Extents => the_box_Model.Scale / 2.0),
+                                                  Mass       => Mass);
+      the_Box : constant gel.Sprite.view
+        := gel.Sprite.Forge.new_Sprite ("demo.Box",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_box_Model.all'Access,
+                                        the_box_physics_Model,
+                                        owns_Graphics => True,
+                                        owns_Physics  => True,
+                                        is_Kinematic  => is_Kinematic);
+   begin
+      return the_Box;
+   end new_box_Sprite;
+
+
+
+   function new_box_Sprite (in_World : in gel.World.view;
+                            Site     : in math.Vector_3 := math.Origin_3D;
+                            Mass     : in math.Real     := 1.0;
+                            Size     : in math.Vector_3 := [1.0, 1.0, 1.0];
+                            Texture  : in openGL.asset_Name) return gel.Sprite.view
+   is
+      use openGL.Model.box,
+          Math;
+
+      the_box_Model : constant openGL.Model.box.textured.view
+        := openGL.Model.box.textured.new_Box (Size => Size,
+                                              Faces => [Front => (texture_Name => Texture),
+                                                        Rear  => (texture_Name => Texture),
+                                                        Upper => (texture_Name => Texture),
+                                                        Lower => (texture_Name => Texture),
+                                                        Left  => (texture_Name => Texture),
+                                                        Right => (texture_Name => Texture)]);
+      the_box_physics_Model : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                                 --  half_Extents => the_box_Model.Scale / 2.0),
+                                                  Mass       => Mass);
+      the_Box : constant gel.Sprite.view
+        := gel.Sprite.forge.new_Sprite ("demo.Box",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_box_Model.all'Access,
+                                        the_box_physics_Model,
+                                        owns_graphics => True,
+                                        owns_physics  => True,
+                                        is_Kinematic  => False);
+   begin
+      return the_Box;
+   end new_box_Sprite;
+
+
+
+   function new_billboard_Sprite (in_World : in gel.World.view;
+                                  Site     : in math.Vector_3     := math.Origin_3D;
+                                  Mass     : in math.Real         := 1.0;
+                                  Size     : in math.Vector_3     := [1.0, 1.0, 1.0];
+                                  Texture  : in openGL.asset_Name := openGL.null_Asset) return gel.Sprite.view
+   is
+      use Math;
+
+      the_billboard_Model : constant openGL.Model.billboard.textured.view
+        := openGL.Model.billboard.textured.forge.new_Billboard (Size    => (Width  => Size (1),
+                                                                            Height => Size (2)),
+                                                                Plane   => openGL.Model.Billboard.xy,
+                                                                Texture => Texture);
+
+      the_billboard_physics_Model : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                                 --  half_Extents => the_billboard_Model.Scale / 2.0),
+                                                  Mass       => Mass);
+
+      the_Billboard : constant gel.Sprite.view
+        := gel.Sprite.forge.new_Sprite ("Billboard",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_billboard_Model.all'Access,
+                                        the_billboard_physics_Model,
+                                        owns_Graphics => True,
+                                        owns_Physics  => True,
+                                        is_Kinematic  => False);
+   begin
+      return the_Billboard;
+   end new_billboard_Sprite;
+
+
+
+   function new_billboard_Sprite (in_World : in gel.World.view;
+                                  Site     : in math.Vector_3 := math.Origin_3D;
+                                  Color    : in openGL.lucid_Color;
+                                  Mass     : in math.Real         := 1.0;
+                                  Size     : in math.Vector_3     := [1.0, 1.0, 1.0];
+                                  Texture  : in openGL.asset_Name := openGL.null_Asset) return gel.Sprite.view
+   is
+      use Math;
+
+      the_billboard_Model : constant openGL.Model.billboard.colored_textured.view
+        := openGL.Model.billboard.colored_textured.new_Billboard (Size    => (Width  => Size (1),
+                                                                              Height => Size (2)),
+                                                                  Plane   => openGL.Model.Billboard.xy,
+                                                                  Texture => Texture,
+                                                                  Color   => Color);
+      the_billboard_physics_Model : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                                 --  half_Extents => the_billboard_Model.Scale / 2.0),
+                                                  Mass       => Mass);
+      the_Billboard : constant gel.Sprite.view
+        := gel.Sprite.forge.new_Sprite ("Billboard",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_billboard_Model.all'Access,
+                                        the_billboard_physics_Model,
+                                        owns_Graphics => True,
+                                        owns_Physics  => True,
+                                        is_Kinematic  => False);
+   begin
+      return the_Billboard;
+   end new_billboard_Sprite;
+
+
+
+   function new_arrow_Sprite (in_World   : in gel.World.view;
+                              Site       : in math.Vector_3      := math.Origin_3D;
+                              Mass       : in math.Real          := 0.0;
+                              Size       : in math.Vector_3      := [1.0, 1.0, 1.0];
+                              Texture    : in openGL.asset_Name  := openGL.null_Asset;
+                              Color      : in openGL.lucid_Color := (openGL.Palette.Black, openGL.Opaque);
+                              line_Width : in openGL.Real        := openGL.Primitive.unused_line_Width) return gel.Sprite.view
+   is
+      pragma Unreferenced (Texture);
+      use Math;
+
+      the_graphics_Model : constant openGL.Model.arrow.colored.view
+        := openGL.Model.arrow.colored.new_Arrow (Color      => Color.primary,
+                                                 line_Width => line_Width);
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                                 --  half_Extents => the_graphics_Model.Scale / 2.0),
+                                                  Mass       => Mass);
+      the_Arrow : constant gel.Sprite.view
+        := gel.Sprite.forge.new_Sprite ("Arrow",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_graphics_Model.all'Access,
+                                        the_physics_Model,
+                                        owns_Graphics => True,
+                                        owns_Physics  => True,
+                                        is_Kinematic  => False);
+   begin
+      return the_Arrow;
+   end new_arrow_Sprite;
+
+
+
+   function new_line_Sprite  (in_World   : in gel.World.view;
+                              Site       : in math.Vector_3      := math.Origin_3D;
+                              Mass       : in math.Real          := 0.0;
+                              Size       : in math.Vector_3      := [1.0, 1.0, 1.0];
+                              Texture    : in openGL.asset_Name  := openGL.null_Asset;
+                              Color      : in openGL.lucid_Color := (openGL.Palette.Black, openGL.Opaque);
+                              line_Width : in openGL.Real        := openGL.Primitive.unused_line_Width) return gel.Sprite.view
+   is
+      pragma Unreferenced (Texture, line_Width);
+      use Math;
+
+      the_graphics_Model : constant openGL.Model.line.colored.view
+        := openGL.Model.line.colored.new_line_Model (Color => Color.primary);
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                                 --  half_Extents => the_graphics_Model.Scale / 2.0),
+                                                  Mass       => Mass);
+      the_Line : constant gel.Sprite.view
+        := gel.Sprite.forge.new_Sprite ("Line",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_graphics_Model.all'Access,
+                                        the_physics_Model,
+                                        owns_Graphics => True,
+                                        owns_Physics  => True,
+                                        is_Kinematic  => False);
+   begin
+      return the_Line;
+   end new_line_Sprite;
+
+
+
+   function new_segment_line_Sprite  (in_World   : in gel.World.view;
+                                      Site       : in math.Vector_3      := math.Origin_3D;
+                                      Mass       : in math.Real          := 0.0;
+                                      Size       : in math.Vector_3      := [1.0, 1.0, 1.0];
+                                      Texture    : in openGL.asset_Name  := openGL.null_Asset;
+                                      Color      : in openGL.lucid_Color := (openGL.Palette.Black, openGL.Opaque);
+                                      line_Width : in openGL.Real        := openGL.Primitive.unused_line_Width) return gel.Sprite.view
+   is
+      pragma Unreferenced (Texture, line_Width);
+      use Math;
+
+      the_graphics_Model : constant openGL.Model.segment_line.view
+        := openGL.Model.segment_line.new_segment_line_Model (Color => Color.primary);
+
+      the_physics_Model  : constant physics.Model.view
+        := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                 half_Extents => Size / 2.0),
+                                                  Mass       => Mass);
+      the_Line : constant gel.Sprite.view
+        := gel.Sprite.forge.new_Sprite ("Line",
+                                        sprite.World_view (in_World),
+                                        Site,
+                                        the_graphics_Model.all'Access,
+                                        the_physics_Model,
+                                        owns_Graphics => True,
+                                        owns_Physics  => True,
+                                        is_Kinematic  => False);
+   begin
+      return the_Line;
+   end new_segment_line_Sprite;
+
+
+
+   -- Text
+   --
+
+   function new_text_Sprite (in_World : in gel.World.view;
+                             Site     : in math.Vector_3 := math.Origin_3D;
+                             Text     : in String;
+                             Font     : in openGL.Font.font_Id;
+                             Color    : in openGL.Color  := opengl.Palette.Black;
+                             Size     : in math.Vector_3 := [1.0, 1.0, 1.0];
+                             Centered : in Boolean       := True) return gel.Sprite.view
+   is
+      use Math;
+      use type Physics.space_Kind;
+
+      the_graphics_Model : constant openGL.Model.text.lit_colored.view
+        := openGL.Model.text.lit_colored.new_Text (Text     => Text,
+                                                   Font     => Font,
+                                                   Color    => (Color, openGL.Opaque),
+                                                   Centered => Centered);
+      the_physics_Model  : physics.Model.view;
+   begin
+      if in_World.space_Kind = Physics.Box2d
+      then
+         declare
+            half_Width   : constant Real                       := Size (1) / 2.0;
+            half_Height  : constant Real                       := Size (2) / 2.0;
+            the_Vertices : constant Geometry_2d.Sites (1 .. 8) := [[-half_Width, -half_Height],
+                                                                   [ half_Width, -half_Height],
+                                                                   [ half_Width,  half_Height],
+                                                                   [-half_Width,  half_Height],
+                                                                   others => [0.0, 0.0]];
+         begin
+            the_physics_Model := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Polygon,
+                                                                                       Vertices     => the_Vertices,
+                                                                                       vertex_Count => 4));
+         end;
+      else
+         the_physics_Model := physics.Model.Forge.new_physics_Model (shape_Info => (Kind         => physics.Model.Cube,
+                                                                                    half_Extents => Size / 2.0));
+                                                                                    --  half_Extents => the_graphics_Model.Scale));
+      end if;
+
+      return gel.Sprite.Forge.new_Sprite ("text_Sprite",
+                                          sprite.World_view (in_World),
+                                          Site,
+                                          the_graphics_Model,
+                                          the_physics_Model,
+                                          owns_Graphics => True,
+                                          owns_Physics  => True,
+                                          is_Kinematic  => False);
+   end new_text_Sprite;
+
+
+end gel.Forge;

4-high/gel/source/forge/gel-forge.ads

@@ -0,0 +1,159 @@
+with
+     gel.Applet.gui_world,
+     gel.Applet.gui_and_sim_world,
+     gel.Applet.server_world,
+     gel.Applet.client_world,
+     gel.Sprite,
+     gel.World,
+
+     Physics,
+
+     openGL.Primitive,
+     openGL.Model.sphere,
+     openGL.Font,
+     openGL.Palette;
+
+
+package gel.Forge
+--
+--  Provides utility constructor functions for various GEL classes.
+--
+is
+
+   -----------
+   --- Applets
+   --
+
+   function         new_gui_Applet (Named         : in String;
+                                    window_Width  : in Positive           := 500;
+                                    window_Height : in Positive           := 500;
+                                    space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.gui_world.view;
+
+   function new_gui_and_sim_Applet (Named         : in String;
+                                    window_Width  : in Positive           := 500;
+                                    window_Height : in Positive           := 500;
+                                    space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.gui_and_sim_World.view;
+
+   function      new_server_Applet (Named         : in String;
+                                    window_Width  : in Positive           := 500;
+                                    window_Height : in Positive           := 500;
+                                    space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.server_world.view;
+
+   function      new_client_Applet (Named         : in String;
+                                    window_Width  : in Positive           := 500;
+                                    window_Height : in Positive           := 500;
+                                    space_Kind    : in physics.space_Kind := physics.Bullet) return gel.Applet.client_world.view;
+   -----------
+   --- Sprites
+   --
+
+   -- 2D
+   --
+
+   function new_circle_Sprite    (in_World : in gel.World.view;
+                                  Site     : in math.Vector_2     := math.Origin_2D;
+                                  Mass     : in math.Real         := 1.0;
+                                  Friction : in math.Real         := 0.5;
+                                  Bounce   : in math.Real         := 0.5;
+                                  Radius   : in math.Real         := 0.5;
+                                  Color    : in openGL.Color      := opengl.Palette.White;
+                                  Texture  : in openGL.asset_Name := openGL.null_Asset) return gel.Sprite.view;
+
+   function new_polygon_Sprite   (in_World : in gel.World.view;
+                                  Site     : in math.Vector_2    := math.Origin_2D;
+                                  Mass     : in math.Real        := 1.0;
+                                  Friction : in math.Real        := 0.5;
+                                  Bounce   : in math.Real        := 0.5;
+                                  Vertices : in Geometry_2d.Sites;
+                                  Color    : in openGL.Color     := opengl.Palette.White) return gel.Sprite.view;
+
+   function new_rectangle_Sprite (in_World : in gel.World.view;
+                                  Site     : in math.Vector_2 := math.Origin_2D;
+                                  Mass     : in math.Real     := 1.0;
+                                  Friction : in math.Real     := 0.5;
+                                  Bounce   : in math.Real     := 0.5;
+                                  Width,
+                                  Height   : in math.Real;
+                                  Color    : in openGL.Color  := opengl.Palette.White) return gel.Sprite.view;
+   -- 3D
+   --
+
+   function new_ball_Sprite      (in_World   : in gel.World.view;
+                                  Site       : in math.Vector_3      := math.Origin_3D;
+                                  Mass       : in math.Real          := 1.0;
+                                  Radius     : in math.Real          := 0.5;
+                                  lat_Count  : in Positive           := openGL.Model.sphere.default_latitude_Count;
+                                  long_Count : in Positive           := openGL.Model.sphere.default_longitude_Count;
+                                  is_Lit     : in Boolean            := True;
+                                  Color      : in openGL.lucid_Color := opengl.no_lucid_Color;
+                                  Texture    : in openGL.asset_Name  := openGL.null_Asset) return gel.Sprite.view;
+
+   function new_skysphere_Sprite (in_World : in gel.World.view;
+                                  Site     : in math.Vector_3 := math.Origin_3D;
+                                  Radius   : in math.Real     := 1_000_000.0;
+                                  Texture  : in openGL.asset_Name) return gel.Sprite.view;
+
+
+   subtype box_Colors is openGL.Colors (1 .. 6);
+
+   function new_box_Sprite       (in_World     : in gel.World.view;
+                                  Site         : in math.Vector_3 := math.Origin_3D;
+                                  Mass         : in math.Real     := 1.0;
+                                  Size         : in math.Vector_3 := [1.0, 1.0, 1.0];
+                                  Colors       : in box_Colors    := [others => opengl.Palette.random_Color];
+                                  is_Kinematic : in Boolean       := False) return gel.Sprite.view;
+
+   function new_box_Sprite       (in_World     : in gel.World.view;
+                                  Site         : in math.Vector_3 := math.Origin_3D;
+                                  Mass         : in math.Real     := 1.0;
+                                  Size         : in math.Vector_3 := [1.0, 1.0, 1.0];
+                                  Texture      : in openGL.asset_Name) return gel.Sprite.view;
+
+   function new_billboard_Sprite (in_World     : in gel.World.view;
+                                  Site         : in math.Vector_3     := math.Origin_3D;
+                                  Mass         : in math.Real         := 1.0;
+                                  Size         : in math.Vector_3     := [1.0, 1.0, 1.0];
+                                  Texture      : in openGL.asset_Name := openGL.null_Asset) return gel.Sprite.view;
+
+   function new_billboard_Sprite (in_World     : in gel.World.view;
+                                  Site         : in math.Vector_3     := math.Origin_3D;
+                                  Color        : in openGL.lucid_Color;
+                                  Mass         : in math.Real         := 1.0;
+                                  Size         : in math.Vector_3     := [1.0, 1.0, 1.0];
+                                  Texture      : in openGL.asset_Name := openGL.null_Asset) return gel.Sprite.view;
+
+   function new_arrow_Sprite     (in_World     : in gel.World.view;
+                                  Site         : in math.Vector_3      := math.Origin_3D;
+                                  Mass         : in math.Real          := 0.0;
+                                  Size         : in math.Vector_3      := [1.0, 1.0, 1.0];
+                                  Texture      : in openGL.asset_Name  := openGL.null_Asset;
+                                  Color        : in openGL.lucid_Color := (openGL.Palette.Black, openGL.Opaque);
+                                  line_Width   : in openGL.Real        := openGL.Primitive.unused_line_Width) return gel.Sprite.view;
+
+   function new_line_Sprite      (in_World     : in gel.World.view;
+                                  Site         : in math.Vector_3      := math.Origin_3D;
+                                  Mass         : in math.Real          := 0.0;
+                                  Size         : in math.Vector_3      := [1.0, 1.0, 1.0];
+                                  Texture      : in openGL.asset_Name  := openGL.null_Asset;
+                                  Color        : in openGL.lucid_Color := (openGL.Palette.Black, openGL.Opaque);
+                                  line_Width   : in openGL.Real        := openGL.Primitive.unused_line_Width) return gel.Sprite.view;
+
+   function new_segment_line_Sprite (in_World     : in gel.World.view;
+                                     Site         : in math.Vector_3      := math.Origin_3D;
+                                     Mass         : in math.Real          := 0.0;
+                                     Size         : in math.Vector_3      := [1.0, 1.0, 1.0];
+                                     Texture      : in openGL.asset_Name  := openGL.null_Asset;
+                                     Color        : in openGL.lucid_Color := (openGL.Palette.Black, openGL.Opaque);
+                                     line_Width   : in openGL.Real        := openGL.Primitive.unused_line_Width) return gel.Sprite.view;
+   -- Text
+   --
+
+   function new_text_Sprite (in_World : in gel.World.view;
+                             Site     : in math.Vector_3 := math.Origin_3D;
+                             Text     : in String;
+                             Font     : in openGL.Font.font_Id;
+                             Color    : in openGL.Color  := opengl.Palette.Black;
+                             Size     : in math.Vector_3 := [1.0, 1.0, 1.0];
+                             Centered : in Boolean       := True) return gel.Sprite.view;
+
+end gel.Forge;

4-high/gel/source/gel-camera.adb

@@ -0,0 +1,59 @@
+with
+     gel.Sprite,
+     openGL.Visual,
+     ada.unchecked_Deallocation;
+
+
+package body gel.Camera
+is
+
+   --------
+   -- Forge
+   --
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+
+   --------------
+   --  Operations
+   --
+
+   procedure render (Self : in out Item;   the_World : in gel.World.view;
+                                           To        : in openGL.Surface.view)
+   is
+      all_Sprites : gel.World.sprite_transform_Pairs renames the_World.sprite_Transforms;
+
+      the_Visuals : openGL.Visual.views (1 .. all_Sprites'Length);
+      Count       : Natural := 0;
+
+      the_Sprite  : gel.Sprite.view;
+   begin
+      for i in all_Sprites'Range
+      loop
+         the_Sprite := all_Sprites (i).Sprite;
+
+         if         not the_Sprite.is_Destroyed
+           and then     the_Sprite.is_Visible
+         then
+            Count := Count + 1;
+
+            the_Visuals (Count)            := the_Sprite.Visual;
+            the_Visuals (Count).Transform_is (all_Sprites (i).Transform);
+            the_Visuals (Count).Scale_is     ([1.0, 1.0, 1.0]);
+
+            the_Visuals (Count).program_Parameters_are (the_Sprite.program_Parameters);
+         end if;
+      end loop;
+
+      Self.render (the_Visuals (1 .. Count));
+   end render;
+
+
+end gel.Camera;

4-high/gel/source/gel-camera.ads

@@ -0,0 +1,38 @@
+with
+     gel.World,
+
+     openGL.Surface,
+     openGL.Camera;
+
+
+package gel.Camera
+--
+-- Models a camera.
+--
+is
+   type Item  is new openGL.Camera.item with private;
+   type View  is access all Camera.item'Class;
+
+   type Views is array (Positive range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   procedure free (Self : in out View);
+
+
+   --------------
+   --  Operations
+   --
+
+   procedure render (Self : in out Item;   the_World : in gel.World.view;
+                                           To        : in openGL.Surface.view);
+
+
+private
+
+   type Item  is new openGL.Camera.item with null record;
+
+end gel.Camera;

4-high/gel/source/gel-conversions.adb

@@ -0,0 +1,73 @@
+package body gel.Conversions
+is
+   use Math;
+
+
+   function to_GL (Self : in geometry_3d.bounding_Box) return openGL.Bounds
+   is
+      the_Bounds : opengl.Bounds := (Ball => <>,
+                                     Box  => (Lower => to_GL (Self.Lower),
+                                              Upper => to_GL (Self.Upper)));
+   begin
+      openGL.set_Ball_from_Box (the_Bounds);
+      return the_Bounds;
+   end to_GL;
+
+
+
+   function to_GL (Self : in Real) return opengl.Real
+   is
+   begin
+      return opengl.Real (Self);
+
+   exception
+      when constraint_Error =>
+         if Self > 0.0
+         then   return opengl.Real'Last;
+         else   return opengl.Real'First;
+         end if;
+   end to_GL;
+
+
+
+   function to_GL (Self : in Vector_3) return opengl.Vector_3
+   is
+   begin
+      return [to_GL (Self (1)),
+              to_GL (Self (2)),
+              to_GL (Self (3))];
+   end to_GL;
+
+
+
+   function to_GL (Self : in Matrix_3x3) return opengl.Matrix_3x3
+   is
+   begin
+      return [[to_gl (Self (1, 1)),  to_gl (Self (1, 2)),  to_gl (Self (1, 3))],
+              [to_gl (Self (2, 1)),  to_gl (Self (2, 2)),  to_gl (Self (2, 3))],
+              [to_gl (Self (3, 1)),  to_gl (Self (3, 2)),  to_gl (Self (3, 3))]];
+   end to_GL;
+
+
+
+   function to_GL (Self : in Matrix_4x4) return opengl.Matrix_4x4
+   is
+   begin
+      return [[to_gl (Self (1, 1)),  to_gl (Self (1, 2)),  to_gl (Self (1, 3)),  to_gl (Self (1, 4))],
+              [to_gl (Self (2, 1)),  to_gl (Self (2, 2)),  to_gl (Self (2, 3)),  to_gl (Self (2, 4))],
+              [to_gl (Self (3, 1)),  to_gl (Self (3, 2)),  to_gl (Self (3, 3)),  to_gl (Self (3, 4))],
+              [to_gl (Self (4, 1)),  to_gl (Self (4, 2)),  to_gl (Self (4, 3)),  to_gl (Self (4, 4))]];
+   end to_GL;
+
+
+
+   function to_Math (Self : in opengl.Vector_3) return math.Vector_3
+   is
+   begin
+      return [Self (1),
+              Self (2),
+              Self (3)];
+   end to_Math;
+
+
+end gel.Conversions;

4-high/gel/source/gel-conversions.ads

@@ -0,0 +1,15 @@
+with
+     openGL;
+
+package gel.Conversions
+is
+
+   function to_GL   (Self : in math.Real)                  return opengl.Real;
+   function to_GL   (Self : in math.Vector_3)              return opengl.Vector_3;
+   function to_GL   (Self : in math.Matrix_3x3)            return opengl.Matrix_3x3;
+   function to_GL   (Self : in math.Matrix_4x4)            return opengl.Matrix_4x4;
+   function to_GL   (Self : in geometry_3d.bounding_Box)   return opengl.Bounds;
+
+   function to_Math (Self : in opengl.Vector_3)            return math.Vector_3;
+
+end gel.Conversions;

4-high/gel/source/gel-events.ads

@@ -0,0 +1,84 @@
+with
+     gel.remote.World,
+     gel.Mouse,
+     lace.Event;
+
+package gel.Events with remote_Types
+--
+-- Provides events for GEL.
+--
+is
+
+
+   type window_Enter             is new lace.Event.item with null record;
+   type window_Leave             is new lace.Event.item with null record;
+
+   type window_Focus_In          is new lace.Event.item with null record;
+   type window_Focus_Out         is new lace.Event.item with null record;
+
+   type window_keymap_Notify     is new lace.Event.item with null record;
+
+   type window_Expose            is new lace.Event.item with null record;
+   type window_graphics_Exposure is new lace.Event.item with null record;
+   type window_no_Exposure       is new lace.Event.item with null record;
+
+   type window_visibility_Notify is new lace.Event.item with null record;
+   type window_create_Notify     is new lace.Event.item with null record;
+   type window_destroy_Notify    is new lace.Event.item with null record;
+   type window_unmap_Notify      is new lace.Event.item with null record;
+   type window_map_Notify        is new lace.Event.item with null record;
+   type window_map_Request       is new lace.Event.item with null record;
+   type window_reparent_Notify   is new lace.Event.item with null record;
+   type window_configure_Notify  is new lace.Event.item with null record;
+   type window_configure_Request is new lace.Event.item with null record;
+   type window_gravity_Notify    is new lace.Event.item with null record;
+   type window_circulate_Notify  is new lace.Event.item with null record;
+   type window_circulate_Request is new lace.Event.item with null record;
+   type window_property_Notify   is new lace.Event.item with null record;
+   type window_selection_Clear   is new lace.Event.item with null record;
+   type window_selection_Request is new lace.Event.item with null record;
+   type window_selection_Notify  is new lace.Event.item with null record;
+   type window_colormap_Notify   is new lace.Event.item with null record;
+   type window_client_Message    is new lace.Event.item with null record;
+   type window_mapping_Notify    is new lace.Event.item with null record;
+
+   type window_resize_Request    is new lace.Event.item with
+      record
+         Width, Height : Positive;
+      end record;
+
+
+   type new_sprite_Event is new lace.Event.item with
+      record
+         Pair : gel.remote.World.sprite_model_Pair;
+      end record;
+
+
+   type new_sprite_added_to_world_Event is new lace.Event.item with
+      record
+         Sprite_Id : gel.sprite_Id;
+         World_Id  : gel. world_Id;
+      end record;
+
+
+   type my_new_sprite_added_to_world_Event is new lace.Event.item with
+      record
+         Pair : gel.remote.World.sprite_model_Pair;
+      end record;
+
+
+   type sprite_click_down_Event is new lace.Event.item with
+      record
+         mouse_Button : gel.Mouse.Button_Id;
+         world_Site   : math.Vector_3;
+      end record;
+
+
+   type sprite_click_up_Event is new lace.Event.item with
+      record
+         mouse_Button : gel.Mouse.Button_Id;
+         world_Site   : math.Vector_3;
+      end record;
+
+
+end gel.Events;

4-high/gel/source/gel-rig.ads

@@ -0,0 +1,393 @@
+with
+     gel.Sprite,
+     gel.Joint,
+     gel.World,
+
+     openGL,
+     openGL.Model,
+     openGL.Program,
+
+     ada.Strings.unbounded.Hash,
+     ada.Containers.Vectors,
+     ada.Containers.hashed_Maps;
+
+private
+with
+     collada.Library.visual_Scenes;
+
+package gel.Rig
+--
+-- Provides GEL sprites which allow placing a collada skinned/rigged model into a GEL World.
+--
+-- The rig motion can be controlled either by normal dynamics or pre-canned animations.
+--
+is
+   type Item  is tagged limited private;
+   type View  is access all Item'Class;
+
+   type Views is array (Positive range <>) of View;
+
+   use Math;
+
+
+   --------------
+   --- Core Types
+   --
+
+   type motion_Mode is (Dynamics, Animation);
+
+   procedure motion_Mode_is (Self : in out Item;   Now : in motion_Mode);
+
+
+   subtype bone_Id is ada.Strings.unbounded.unbounded_String;
+
+   null_Id : constant bone_Id := ada.Strings.unbounded.null_unbounded_String;
+
+
+   subtype controller_joint_Id is ada.Strings.unbounded.unbounded_String;
+
+
+   --------------
+   --- Containers
+   --
+
+   package inverse_bind_matrix_Vectors is new ada.Containers.Vectors (Positive, Matrix_4x4);
+   subtype inverse_bind_matrix_Vector  is inverse_bind_matrix_Vectors.Vector;
+
+
+   --------------
+   --- Joints Ids
+   --
+
+   subtype gel_joint_Id is ada.Strings.unbounded.unbounded_String;
+
+   package gel_joint_id_Maps_of_gel_Joint is new ada.Containers.hashed_Maps (Key_type        => gel_joint_Id,
+                                                                             Element_type    => gel.Joint.view,
+                                                                             Hash            => ada.Strings.unbounded.Hash,
+                                                                             equivalent_Keys => ada.Strings.unbounded."=",
+                                                                             "="             => gel.Joint."=");
+   subtype gel_joint_id_Map_of_gel_Joint is gel_joint_id_Maps_of_gel_Joint.Map;
+
+
+   package joint_Id_Maps_of_bone_site_offset is new ada.Containers.hashed_Maps (Key_type        => controller_joint_Id,
+                                                                                Element_type    => Vector_3,
+                                                                                Hash            => ada.Strings.unbounded.Hash,
+                                                                                equivalent_Keys => ada.Strings.unbounded."=",
+                                                                                "="             => "=");
+   subtype joint_Id_Map_of_bone_site_offset is joint_Id_Maps_of_bone_site_offset.Map;
+
+
+   ------------
+   --- Bone Ids
+   --
+
+   package bone_id_Maps_of_sprite is new ada.Containers.hashed_Maps (Key_type        => bone_Id,
+                                                                     Element_type    => gel.Sprite.view,
+                                                                     Hash            => ada.Strings.unbounded.Hash,
+                                                                     equivalent_Keys => ada.Strings.unbounded."=",
+                                                                     "="             => gel.Sprite."=");
+   subtype bone_id_Map_of_sprite is bone_id_Maps_of_sprite.Map;
+
+
+   ----------------
+   --- Bone Details
+   --
+
+   type bone_Details is
+      record
+         Length       : math.Real := 1.0;
+         width_Factor,
+         depth_Factor : math.Real := 0.1;   -- Factor * Length gives width and depth.
+
+         pitch_Limits,
+         yaw_Limits,
+         roll_Limits  : gel.Sprite.DoF_Limits := (to_Radians (-15.0),
+                                                  to_Radians ( 15.0));
+      end record;
+
+   Unspecified : constant := -1.0;
+
+   function to_Details (Length       : Real := Unspecified;
+                        width_Factor,
+                        depth_Factor : Real := 0.1;
+
+                        pitch_Limits,
+                        yaw_Limits,
+                        roll_Limits  : gel.Sprite.DoF_Limits := (to_Radians (-15.0),
+                                                                 to_Radians ( 15.0))) return bone_Details;
+
+   package bone_id_Maps_of_details is new ada.Containers.hashed_Maps (Key_Type        => bone_id,
+                                                                      Element_Type    => bone_Details,
+                                                                      Hash            => ada.Strings.unbounded.Hash,
+                                                                      Equivalent_Keys => ada.Strings.unbounded."=",
+                                                                      "="             => "=");
+   subtype bone_id_Map_of_details is bone_id_Maps_of_details.Map;
+
+
+
+
+   ---------
+   --- Forge
+   --
+
+   package Forge
+   is
+      function new_Rig (in_World                : in gel.World.view;
+                        Model                   : in openGL.Model.view;
+                        Mass                    : in Real    := 0.0;
+                        is_Kinematic            : in Boolean := False) return Rig.view;
+
+      function new_Rig (bone_Sprites            : in bone_id_Map_of_sprite;
+                        joint_inv_bind_Matrices : in inverse_bind_matrix_Vector;
+                        joint_site_Offets       : in joint_Id_Map_of_bone_site_offset;
+                        Model                   : in openGL.Model.view) return Rig.view;
+   end Forge;
+
+
+   procedure define (Self : in out Item;   in_World     : in gel.World.view;
+                                           Model        : in openGL.Model.view;
+                                           Mass         : in Real                   := 0.0;
+                                           is_Kinematic : in Boolean                := False;
+                                           bone_Details : in bone_id_Map_of_details := bone_id_Maps_of_details.empty_Map);
+
+
+   --------------
+   --- Attributes
+   --
+
+   procedure Site_is (Self : in out Item;   Now : in Vector_3);
+   procedure Spin_is (Self : in out Item;   Now : in Matrix_3x3);
+
+   function  bone_Sprites (Self : in Item)       return bone_id_Map_of_sprite;
+   function  skin_Sprite  (Self : in Item'Class) return gel.Sprite.view;
+   function  base_Sprite  (Self : in Item'Class) return gel.Sprite.view;
+   function  Sprite       (Self : in Item'Class;
+                           Bone : in bone_Id)    return gel.Sprite.view;
+
+   function  Joints (Self : in Item) return gel_joint_id_Map_of_gel_Joint;
+
+   procedure joint_inv_bind_Matrices_are (Self : in out Item'Class;   Now : in inverse_bind_matrix_Vector);
+   function  joint_inv_bind_Matrices     (Self : in     Item'Class)     return inverse_bind_matrix_Vector;
+
+   function  joint_site_Offets (Self : in Item'Class) return joint_Id_Map_of_bone_site_offset;
+
+   procedure assume_Pose     (Self : in out Item);
+   procedure enable_Graphics (Self : in out Item);
+   procedure evolve          (Self : in out Item'Class;   world_Age : in Duration);
+
+
+   -------------
+   --- Animation
+   --
+
+   subtype scene_joint_Id is ada.Strings.unbounded.unbounded_String;
+
+   package bone_id_Maps_of_transform is new ada.Containers.hashed_Maps (Key_Type        => bone_id,
+                                                                        Element_Type    => Matrix_4x4,
+                                                                        Hash            => ada.Strings.unbounded.Hash,
+                                                                        Equivalent_Keys => ada.Strings.unbounded."=",
+                                                                        "="             => "=");
+   subtype bone_id_Map_of_transform is bone_id_Maps_of_transform.Map;
+
+   procedure animation_Transforms_are (Self : in out Item'Class;   Now : in bone_id_Map_of_transform);
+
+
+   type axis_Kind is (x_Axis, y_Axis, z_Axis);
+
+   procedure set_rotation_Angle   (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               Axis      : in Axis_Kind;
+                                                               To        : in Real);     -- TODO: Use Radians type (and below).
+   procedure set_x_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in Real);
+   procedure set_y_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in Real);
+   procedure set_z_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in Real);
+
+   procedure set_Location   (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                         To        : in Vector_3);
+   procedure set_Location_x (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                         To        : in Real);
+   procedure set_Location_y (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                         To        : in Real);
+   procedure set_Location_z (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                         To        : in Real);
+   procedure set_Transform  (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                         To        : in Matrix_4x4);
+
+   procedure update_all_global_Transforms (Self : in out Item'Class);
+
+   procedure animate         (Self : in out Item;   world_Age : in Duration);
+   procedure reset_Animation (Self : in out Item);
+
+
+
+private
+
+   -- gl_transform_Vector
+   --
+   package gl_transform_Vectors is new ada.Containers.Vectors (Positive, openGL.Matrix_4x4);
+   subtype gl_transform_Vector  is gl_transform_Vectors.Vector;
+
+
+   -- joint_id_Map_of_matrix_4x4
+   --
+   package joint_id_Maps_of_matrix_4x4 is new ada.Containers.hashed_Maps (Key_type        => scene_joint_Id,
+                                                                          Element_type    => Matrix_4x4,
+                                                                          Hash            => ada.Strings.unbounded.Hash,
+                                                                          equivalent_Keys => ada.Strings.unbounded."=",
+                                                                          "="             => "=");
+   subtype joint_id_Map_of_matrix_4x4 is joint_id_Maps_of_matrix_4x4.Map;
+
+
+   -- joint_id_Map_of_scene_node
+   --
+   package joint_id_Maps_of_scene_node is new ada.Containers.hashed_Maps (Key_type        => scene_joint_Id,
+                                                                          Element_type    => collada.Library.visual_Scenes.Node_view,
+                                                                          Hash            => ada.Strings.unbounded.Hash,
+                                                                          equivalent_Keys => ada.Strings.unbounded."=",
+                                                                          "="             => collada.Library.visual_Scenes."=");
+   subtype joint_id_Map_of_scene_node is joint_id_Maps_of_scene_node.Map;
+
+
+   -- joint_id_Map_of_slot
+   --
+   package joint_id_Maps_of_slot is new ada.Containers.hashed_Maps (Key_type        => scene_joint_Id,
+                                                                    Element_type    => Positive,
+                                                                    Hash            => ada.Strings.unbounded.Hash,
+                                                                    equivalent_Keys => ada.Strings.unbounded."=",
+                                                                    "="             => "=");
+   subtype joint_id_Map_of_slot is joint_id_Maps_of_slot.Map;
+
+
+   -- skin_program_Parameters
+   --
+   type skin_program_Parameters is new opengl.Program.Parameters with
+      record
+         bone_Transforms   : gl_transform_Vector;
+         joint_Map_of_slot : joint_id_Map_of_slot;
+      end record;
+
+   overriding
+   procedure enable (Self : in out skin_program_Parameters);
+
+
+   -- joint_id_Map_of_joint_id
+   --
+   package joint_id_Maps_of_joint_id is new ada.Containers.hashed_Maps (Key_type        => scene_joint_Id,
+                                                                        Element_type    => scene_joint_Id,
+                                                                        Hash            => ada.Strings.unbounded.Hash,
+                                                                        equivalent_Keys => ada.Strings.unbounded."=",
+                                                                        "="             => ada.Strings.unbounded."=");
+   subtype joint_id_Map_of_joint_id is joint_id_Maps_of_joint_id.Map;
+
+
+   -- scene_Joint
+   --
+   type scene_Joint is
+      record
+         Node      : collada.Library.visual_Scenes.Node_view;
+         Transform : Matrix_4x4;
+      end record;
+
+   package joint_id_Maps_of_scene_Joint is new ada.Containers.hashed_Maps (Key_type        => scene_joint_Id,
+                                                                           Element_type    => scene_Joint,
+                                                                           Hash            => ada.Strings.unbounded.Hash,
+                                                                           equivalent_Keys => ada.Strings.unbounded."=",
+                                                                           "="             => "=");
+   subtype joint_id_Map_of_scene_Joint is joint_id_Maps_of_scene_Joint.Map;
+
+
+   -- Transform
+   --
+   type Transform is
+      record
+         Rotation    : Quaternion := linear_Algebra_3D.to_Quaternion (linear_Algebra_3D.x_Rotation_from (0.0));
+         Translation : Vector_3   := [0.0, 0.0, 0.0];
+      end record;
+
+   type Transforms      is array (Positive range <>) of Transform;
+   type Transforms_view is access all Transforms;
+
+
+   -- animation_Channel
+   --
+   type animation_Channel is
+      record
+         Target            : access collada.Library.visual_Scenes.Transform;
+         target_Joint      :        scene_joint_Id;
+
+         Times             : access collada.float_Array;
+         Values            : access collada.float_Array;
+
+         Cursor            :        Index := 0;       -- Current frame of the anmination.
+
+         initial_Angle     :        Real;             -- For angle interpolation during 'rotation' animation.
+         current_Angle     :        Real  := 0.0;     --
+         interp_Delta      :        Real  := 0.0;     --
+
+         initial_Site      :        Vector_3;         -- For location interpolation during 'translation' animation.
+         current_Site      :        Vector_3;         --
+         site_interp_Delta :        Vector_3;         --
+
+         initial_Transform :        Transform;        -- For matrix interpolation during 'full_transform' animation.
+         current_Transform :        Transform;        --
+         slerp_Time        :        Real;             -- Slerp Time (T) value in range '0.0 .. 1.0'.     -- TODO: use 'unit_Interval' type.
+         Transforms        :        Transforms_view;
+         Transform_interp_Delta :   Real;             -- Rate at which the SLERP time parameter increases.
+      end record;
+
+   subtype channel_Id is scene_joint_Id;
+   package channel_id_Maps_of_animation_Channel is new ada.Containers.hashed_Maps (Key_Type        => channel_Id,
+                                                                                   Element_Type    => animation_Channel,
+                                                                                   Hash            => ada.Strings.unbounded.Hash,
+                                                                                   Equivalent_Keys => ada.Strings.unbounded."=",
+                                                                                   "="             => "=");
+   subtype channel_id_Map_of_animation_Channel is channel_id_Maps_of_animation_Channel.Map;
+
+
+   -- Rig Item
+   --
+   type Item is tagged limited
+      record
+         Mode                    : motion_Mode := Dynamics;
+
+         joint_Sprites           : bone_id_Map_of_sprite;                   -- Sprite to show location/rotation of joints (mainly for debugging).
+         bone_Sprites            : bone_id_Map_of_sprite;                   -- A sprite for each bone.
+         skin_Sprite             : gel.Sprite.view;                         -- A sprite for the skin.
+
+         bind_shape_Matrix       : Matrix_4x4;
+
+         Joints                  : gel_joint_id_Map_of_gel_Joint;
+         joint_inv_bind_Matrices : inverse_bind_matrix_Vector;              -- The joint inverse transforms when in the bind pose.
+
+         phys_joint_site_Offets  : joint_Id_Map_of_bone_site_offset;        -- Offset from the bone site to the joint site when in the bind pose.
+         anim_joint_site_Offets  : joint_Id_Map_of_bone_site_offset;        -- Offset from the bone site to the joint site when in the bind pose.
+
+         joint_pose_Transforms   : joint_id_Map_of_matrix_4x4;              -- The joint transforms when in the skeletal pose.
+         joint_Parent            : joint_id_Map_of_joint_id;
+
+         collada_Joints          : joint_id_Map_of_scene_node;
+         scene_Joints            : joint_id_Map_of_scene_Joint;
+         root_Joint              : collada.Library.visual_scenes.Node_view;
+
+         animation_Transforms    : bone_id_Map_of_transform;
+         bone_pose_Transforms    : bone_id_Map_of_transform;                -- The bone transforms when in the skeletal pose.
+
+         Channels                : channel_id_Map_of_animation_Channel;
+         start_Time              : Duration := 0.0;
+
+         overall_Site            : Vector_3 := [0.0, 0.0, 0.0];
+
+         Model                   : openGL.Model.view;
+         program_Parameters      : aliased skin_program_Parameters;
+      end record;
+
+
+   function Parent_of             (Self : in Item;   the_Bone : in bone_Id) return bone_Id;
+   function joint_site_Offet      (Self : in Item;   for_Bone : in bone_Id) return Vector_3;
+   function joint_inv_bind_Matrix (Self : in Item;   for_Bone : in bone_Id) return Matrix_4x4;
+   function joint_bind_Matrix     (Self : in Item;   for_Bone : in bone_Id) return Matrix_4x4;
+
+
+end gel.Rig;

4-high/gel/source/gel-sprite.ads

@@ -0,0 +1,416 @@
+with
+     gel.Joint,
+
+     openGL.Model,
+     openGL.Visual,
+     openGL.Program,
+
+     physics.Model,
+     physics.Object,
+     physics.Shape,
+     physics.Space,
+
+     lace.Subject_and_deferred_Observer,
+     lace.Response,
+
+     ada.Containers.Vectors;
+
+limited
+with
+     gel.World;
+
+
+package gel.Sprite
+--
+--  Combines a graphics 'visual' and a physics 'solid'.
+--
+is
+   type Item  is limited new lace.Subject_and_deferred_Observer.item with private;
+   type View  is access all Item'Class;
+
+   type Items is array (math.Index range <>) of aliased Item;
+   type Views is array (math.Index range <>) of View;
+
+   null_Sprites : constant Sprite.views;
+
+
+   type physics_Space_view is access all physics.Space.item'Class;
+   type World_view         is access all gel.World.item'Class;
+
+
+   use Math;
+
+
+   --------------
+   --- Containers
+   --
+
+   type Grid       is array (math.Index range <>,
+                             math.Index range <>) of Sprite.view;
+   type Grid_view  is access all Grid;
+
+   package Vectors is new ada.Containers.Vectors (Positive, Sprite.view);
+
+
+   ----------
+   --- Forge
+   --
+
+   procedure define  (Self : access Item;   World          : in     World_view;
+                                            at_Site        : in     Vector_3;
+                                            graphics_Model : access openGL. Model.item'Class;
+                                            physics_Model  : access physics.Model.item'Class;
+                                            owns_Graphics  : in     Boolean;
+                                            owns_Physics   : in     Boolean;
+                                            is_Kinematic   : in     Boolean := False);
+
+   procedure destroy      (Self : access Item;   and_Children : in Boolean);
+   function  is_Destroyed (Self : in     Item) return Boolean;
+   procedure free         (Self : in out View);
+
+
+   package Forge
+   is
+      function  to_Sprite (Name           : in     String;
+                           World          : in     World_view;
+                           at_Site        : in     Vector_3;
+                           graphics_Model : access openGL. Model.item'Class;
+                           physics_Model  : access physics.Model.item'Class;
+                           owns_Graphics  : in     Boolean;
+                           owns_Physics   : in     Boolean;
+                           is_Kinematic   : in     Boolean := False) return Item;
+
+      function new_Sprite (Name           : in     String;
+                           World          : in     World_view;
+                           at_Site        : in     Vector_3;
+                           graphics_Model : access openGL. Model.item'Class;
+                           physics_Model  : access physics.Model.item'Class;
+                           owns_Graphics  : in     Boolean := True;
+                           owns_Physics   : in     Boolean := True;
+                           is_Kinematic   : in     Boolean := False) return View;
+   end Forge;
+
+
+   ---------------
+   --- Attributes
+   --
+
+   function  World                 (Self : in     Item)     return  access gel.World.item'Class;
+
+   function  Id                    (Self : in     Item)     return gel.sprite_Id;
+   procedure Id_is                 (Self : in out Item;   Now : in gel.sprite_Id);
+
+   function  Visual                (Self : access Item)     return openGL.Visual.view;
+
+   function  graphics_Model        (Self : in     Item)     return openGL.Model.view;
+   procedure Model_is              (Self : in out Item;   Now : in openGL.Model.view);
+   function  owns_Graphics         (Self : in     Item)           return Boolean;
+
+   function  physics_Model         (Self : in     Item)     return access physics.Model.item'Class;
+   procedure physics_Model_is      (Self : in out Item;   Now : in physics.Model.view);
+
+   function  Scale                 (Self : in     Item)     return Vector_3;
+   procedure Scale_is              (Self : in out Item;   Now : in Vector_3);
+
+   function  Mass                  (Self : in     Item)     return Real;
+   function  is_Static             (Self : in     Item)     return Boolean;
+   function  is_Kinematic          (Self : in     Item)     return Boolean;
+
+   function  Depth_in_camera_space (Self : in     Item)     return Real;
+
+   procedure mvp_Matrix_is         (Self : in out Item;   Now : in Matrix_4x4);
+   function  mvp_Matrix            (Self : in     Item)     return Matrix_4x4;
+
+   procedure is_Visible            (Self : in out Item;   Now : in Boolean);
+   function  is_Visible            (Self : in     Item)     return Boolean;
+
+   procedure key_Response_is       (Self : in out Item;   Now : in lace.Response.view);
+   function  key_Response          (Self : in     Item)     return lace.Response.view;
+
+
+   subtype physics_Object_view is physics.Object.view;
+   subtype physics_Shape_view  is physics.Shape .view;
+
+   function  Solid                 (Self : in     Item)     return physics_Object_view;
+   procedure Solid_is              (Self : in out Item;   Now : in physics_Object_view);
+
+   function  Shape                 (Self : in     Item)     return physics_Shape_view;
+
+
+   function  to_GEL (the_Solid : in physics_Object_view) return gel.Sprite.view;
+
+
+   -------------
+   --- Dynamics
+   --
+
+   --- Bounds
+   --
+
+   function Bounds (Self : in Item) return Geometry_3d.bounding_Box;
+
+
+   --- Site
+   --
+
+   function  Site    (Self : in     Item)         return Vector_3;
+   procedure Site_is (Self : in out Item;   Now     : in Vector_3);
+   procedure move    (Self : in out Item;   to_Site : in Vector_3);
+   --
+   --  Moves the sprite to a new site and recursively move children such that
+   --  relative positions are maintained.
+
+
+   --- Spin
+   --
+
+   function  Spin       (Self : in     Item)         return Matrix_3x3;
+   procedure Spin_is    (Self : in out Item;   Now     : in Matrix_3x3);
+
+   function  xy_Spin    (Self : in     Item)         return Radians;
+   procedure xy_Spin_is (Self : in out Item;   Now     : in Radians);
+
+   procedure rotate     (Self : in out Item;   to_Spin : in Matrix_3x3);
+   --
+   --  Rotates the sprite to a new spin and recursively moves and rotates children such that
+   --  relative positions/orientations are maintained.
+
+
+   --- Transform
+   --
+
+   function  Transform    (Self : in     Item)     return Matrix_4x4;
+   procedure Transform_is (Self : in out Item;   Now : in Matrix_4x4);
+
+
+   --- Speed
+   --
+
+   function  Speed     (Self : in     Item)          return Vector_3;
+   procedure Speed_is  (Self : in out Item;   Now      : in Vector_3);
+
+   procedure set_Speed (Self : in out Item;   to_Speed : in Vector_3);
+   --
+   --  Set Self and all children to given value.
+
+
+   --- Gyre
+   --
+
+   function  Gyre     (Self : in     Item)         return Vector_3;
+   procedure Gyre_is  (Self : in out Item;   Now     : in Vector_3);
+   procedure set_Gyre (Self : in out Item;   to_Gyre : in Vector_3);
+   --
+   --  Set Self and all children to given value.
+
+
+   --- Forces
+   --
+
+   procedure apply_Torque         (Self : in out Item;   Torque : in Vector_3);
+   procedure apply_Torque_impulse (Self : in out Item;   Torque : in Vector_3);
+   procedure apply_Force          (Self : in out Item;   Force  : in Vector_3);
+
+
+   --- Mirrored Dynamics
+   --
+
+   procedure desired_Dynamics_are (Self : in out Item;   Site : in Vector_3;
+                                                         Spin : in Quaternion);
+   procedure interpolate_Motion   (Self : in out Item);
+
+
+   --- Hierachy
+   --
+
+   type DoF_Limits is
+      record
+         Low  : math.Real;
+         High : math.Real;
+      end record;
+
+   function  parent_Joint (Self : in     Item) return gel.Joint.view;
+   function  child_Joints (Self : in     Item) return gel.Joint.views;
+
+   function  top_Parent   (Self : access Item) return gel.Sprite.view;
+   function  Parent       (Self : in     Item) return gel.Sprite.view;
+   function  tree_Depth   (Self : in     Item) return Natural;
+
+   procedure detach       (Self : in out Item;   the_Child : gel.Sprite.view);
+
+   no_such_Child : exception;
+
+
+   type Action is access procedure (the_Sprite : in out Item'Class);
+
+   procedure apply (Self : in out Item;   do_Action : Action);
+   --
+   -- Applies an action to a sprite and its children recursively.
+
+
+   ---  Hinge
+   --
+   procedure attach_via_Hinge (Self : access Item;   the_Child         : in      Sprite.view;
+                                                     pivot_Axis        : in      Vector_3;
+                                                     Anchor            : in      Vector_3;
+                                                     child_Anchor      : in      Vector_3;
+                                                     low_Limit         : in      Real;
+                                                     high_Limit        : in      Real;
+                                                     collide_Connected : in      Boolean;
+                                                     new_joint         :     out gel.Joint.view);
+
+
+   procedure attach_via_Hinge (Self : access Item;   the_Child    : in      Sprite.view;
+                                                     pivot_Axis   : in      Vector_3;
+                                                     pivot_Anchor : in      Vector_3;
+                                                     low_Limit    : in      Real;
+                                                     high_Limit   : in      Real;
+                                                     new_joint    :     out gel.Joint.view);
+
+   procedure attach_via_Hinge (Self : access Item;   the_Child  : in      Sprite.view;
+                                                     pivot_Axis : in      Vector_3;
+                                                     low_Limit  : in      Real;
+                                                     high_Limit : in      Real;
+                                                     new_joint  :     out gel.Joint.view);
+   --
+   --  Uses midpoint between Self and the_Child sprite as pivot_Anchor.
+
+
+   procedure attach_via_Hinge (Self : access Item;   the_Child         : in     Sprite.view;
+                                                     Frame_in_parent   : in     Matrix_4x4;
+                                                     Frame_in_child    : in     Matrix_4x4;
+                                                     Limits            : in     DoF_Limits;
+                                                     collide_Connected : in     Boolean;
+                                                     new_joint         :    out gel.Joint.view);
+
+
+   ---  Ball/Socket
+   --
+   procedure attach_via_ball_Socket (Self : access Item;   the_Child    : in     Sprite.view;
+                                                           pivot_Anchor : in     Vector_3;
+                                                           pivot_Axis   : in     Matrix_3x3;
+                                                           pitch_Limits : in     DoF_Limits;
+                                                           yaw_Limits   : in     DoF_Limits;
+                                                           roll_Limits  : in     DoF_Limits;
+                                                           new_joint    :    out gel.Joint.view);
+
+   procedure attach_via_ball_Socket (Self : access Item;   the_Child       : in     Sprite.view;
+                                                           Frame_in_parent : in     Matrix_4x4;
+                                                           Frame_in_child  : in     Matrix_4x4;
+                                                           pitch_Limits    : in     DoF_Limits;
+                                                           yaw_Limits      : in     DoF_Limits;
+                                                           roll_Limits     : in     DoF_Limits;
+                                                           new_joint       :    out gel.Joint.view);
+
+   --- Graphics
+   --
+   procedure program_Parameters_are  (Self : in out Item;   Now : in opengl.Program.Parameters_view);
+   function  program_Parameters      (Self : in     Item)  return opengl.Program.Parameters_view;
+
+
+   --- Physics
+   --
+   procedure rebuild_Shape (Self : in out Item);
+   procedure rebuild_Solid (Self : in out Item;   at_Site : in Vector_3);
+
+
+
+private
+
+   type access_Joint_views is access all Joint.views;
+
+   use type Joint.view;
+   package joint_Vectors is new ada.Containers.Vectors (Positive, Joint.view);
+
+
+   --  protected
+   --  type safe_Matrix_4x4
+   --  is
+   --     function  Value       return Matrix_4x4;
+   --     procedure Value_is (Now : in Matrix_4x4);
+   --     procedure Site_is  (Now : in Vector_3);
+   --
+   --  private
+   --     the_Value : Matrix_4x4 := Identity_4x4;
+   --  end safe_Matrix_4x4;
+
+
+   -----------------
+   --- Interpolation
+   --
+
+   type site_Interpolation is
+      record
+         Initial : Vector_3;
+         Desired : Vector_3;
+      end record;
+
+   type spin_Interpolation is
+      record
+         Initial : Quaternion;
+         Desired : Quaternion;
+      end record;
+
+   type Interpolation is
+      record
+         Site    : site_Interpolation;
+         Spin    : spin_Interpolation;
+         Percent : unit_Percentage;
+      end record;
+
+
+   protected
+   type safe_Interpolation
+   is
+      procedure set (desired_Site : in Vector_3;
+                     desired_Spin : in Quaternion);
+      procedure get (Site : out Vector_3;
+                     Spin : out Quaternion);
+   private
+      Safe : Interpolation := (Site    => (Initial => Origin_3D,
+                                           Desired => Origin_3D),
+                               Spin    => (Initial => (R =>  0.0,
+                                                       V => [0.0, 1.0, 0.0]),
+                                           Desired => (R =>  0.0,
+                                                       V => [0.0, 1.0, 0.0])),
+                               Percent => 0.0);
+   end safe_Interpolation;
+
+
+   ---------------
+   --- Sprite Item
+   --
+
+   type Item is limited new lace.Subject_and_deferred_Observer.item with
+      record
+         Id                      : gel.sprite_Id := null_sprite_Id;
+
+         Visual                  : openGL.Visual.view := new openGL.Visual.item;
+         program_Parameters      : openGL.program.Parameters_view;
+         owns_Graphics           : Boolean;
+
+         physics_Model           : physics.Model.view;
+         owns_Physics            : Boolean;
+
+         World                   : World_view;
+         Shape                   : physics_Shape_view;
+         Solid                   : physics_Object_view;
+         is_Kinematic            : Boolean;
+
+         Depth_in_camera_space   : Real;
+
+         Interpolation           : safe_Interpolation;
+
+         parent_Joint            : gel.Joint.view;
+         child_Joints            : joint_Vectors.Vector;
+
+         is_Visible              : Boolean := True;
+         key_Response            : lace.Response.view;
+
+         is_Destroyed            : Boolean := False;
+      end record;
+
+
+   null_Sprites : constant Sprite.views (1 .. 0) := [others => null];
+
+end gel.Sprite;

4-high/gel/source/gel-window.adb

@@ -0,0 +1,472 @@
+with
+     gel.Events,
+     ada.unchecked_Deallocation;
+
+package body gel.Window
+is
+   -----------
+   --- Utility
+   --
+
+   procedure free is new ada.unchecked_Deallocation (String, String_view);
+   pragma Unreferenced (free);
+
+
+   ----------
+   --- Forge
+   --
+
+   procedure define  (Self : in out Item;   Width  : in Positive;
+                                            Height : in Positive)
+   is
+   begin
+      Self.last_resize_Time := ada.Calendar.Clock;
+
+      Self.Width    := Width;
+      Self.Height   := Height;
+
+      Self.Keyboard := gel.Keyboard.local.Forge.new_Keyboard (of_name => Self.Name & "." & "Keyboard");
+      Self.Mouse    := gel.Mouse   .local.Forge.new_Mouse    (of_name => Self.Name & "." & "Mouse");
+   end define;
+
+
+
+   window_Creator : create_Window_Function;
+
+   package body Forge
+   is
+      function new_Window (Name   : in String;
+                           Width  : in Positive;
+                           Height : in Positive) return View
+      is
+      begin
+         if window_Creator = null
+         then
+            raise Error with "'window_Creator' has not been set.";
+         end if;
+
+         return window_Creator (Name, Width, Height);
+      end new_Window;
+
+   end Forge;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      use lace.Subject_and_deferred_Observer,
+          gel.Keyboard.local,
+          gel.Mouse   .local;
+
+      procedure deallocate is new ada.unchecked_Deallocation (openGL.Surface.item'Class, openGL.Surface.View);
+   begin
+      destroy (lace.Subject_and_deferred_Observer.item (Self));   -- Destroy base class.
+
+      free (Self.Keyboard);
+      free (Self.Mouse);
+
+      deallocate (Self.Surface);
+   end destroy;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      Self.destroy;
+      deallocate (Self);
+   end free;
+
+
+
+   procedure use_create_Window (create_Window : in create_Window_Function)
+   is
+   begin
+      if window_Creator /= null
+      then
+         raise Error with "'window_Creator' has already been set.";
+      end if;
+
+      window_Creator := create_Window;
+   end use_create_Window;
+
+
+
+   package body private_Forge
+   is
+      function to_Window (Name   : in String;
+                          Width  : in Positive;
+                          Height : in Positive) return Item
+      is
+      begin
+         return Self : Item := (lace.Subject_and_deferred_Observer.Forge.to_Subject_and_Observer (Name)
+                                with others => <>)
+         do
+            Self.define (Width, Height);
+         end return;
+      end to_Window;
+   end private_Forge;
+
+
+   --------------
+   --- Attributes
+   --
+
+   function Surface (Self : in Item) return openGL.Surface.view
+   is
+   begin
+      return Self.Surface;
+   end Surface;
+
+
+
+   function Keyboard (Self : access Item) return access gel.Keyboard.item'class
+   is
+   begin
+      return Self.Keyboard;
+   end Keyboard;
+
+
+
+   function Mouse (Self : access Item) return access gel.Mouse.item'class
+   is
+   begin
+      return Self.Mouse;
+   end Mouse;
+
+
+
+   function is_Open  (Self : in Item) return Boolean
+   is
+   begin
+      return Self.is_Open;
+   end is_Open;
+
+
+
+   function is_Exposed (Self : in Item) return Boolean
+   is
+   begin
+      return Self.is_Exposed;
+   end is_Exposed;
+
+
+
+   function Width (Self : in Item) return Positive
+   is
+   begin
+      return Self.Width;
+   end Width;
+
+
+
+   function Height (Self : in Item) return Positive
+   is
+   begin
+      return Self.Height;
+   end Height;
+
+
+
+   function is_being_Resized (Self : in Item'Class) return Boolean
+   is
+      use ada.Calendar;
+   begin
+      return ada.Calendar.Clock - Self.last_resize_Time < 0.1;
+   end is_being_Resized;
+
+
+
+   procedure Size_is (Self : in out Item;   Width, Height : in Positive)
+   is
+   begin
+      Self.last_resize_Time := Ada.Calendar.Clock;
+
+      Self.Width  := Width;
+      Self.Height := Height;
+
+      --  Generate a 'resize' event.
+      --
+      Self.emit (gel.Events.window_resize_Request' (Width, Height));
+   end Size_is;
+
+
+   ---------------
+   ---  Operations
+   --
+
+   procedure flush (Self : in Item)
+   is
+   begin
+      null;
+   end flush;
+   pragma Unreferenced (flush);
+
+
+
+   procedure sync (Self : in Item)
+   is
+   begin
+      null;
+   end sync;
+   pragma Unreferenced (sync);
+
+
+   ----------
+   --- Events
+   --
+
+   procedure emit_enter_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_Enter;
+   begin
+      Self.emit (the_Event);
+   end emit_enter_Event;
+
+
+
+   procedure emit_leave_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_Leave;
+   begin
+      Self.emit (the_Event);
+   end emit_leave_Event;
+
+
+
+   procedure emit_focus_in_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_Leave;
+   begin
+      Self.emit (the_Event);
+   end emit_focus_in_Event;
+
+
+
+   procedure emit_focus_out_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_Leave;
+   begin
+      Self.emit (the_Event);
+   end emit_focus_out_Event;
+
+
+
+   procedure emit_keymap_notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_keymap_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_keymap_notify_Event;
+
+
+
+   procedure emit_Expose_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_Expose;
+   begin
+      Self.emit (the_Event);
+   end emit_Expose_Event;
+
+
+
+   procedure emit_graphics_Exposure_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_graphics_Exposure;
+   begin
+      Self.emit (the_Event);
+   end emit_graphics_Exposure_Event;
+
+
+
+   procedure emit_no_Exposure_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_no_Exposure;
+   begin
+      Self.emit (the_Event);
+   end emit_no_Exposure_Event;
+
+
+
+   procedure emit_visibility_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_visibility_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_visibility_Notify_Event;
+
+
+
+   procedure emit_create_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_create_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_create_Notify_Event;
+
+
+
+   procedure emit_destroy_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_destroy_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_destroy_Notify_Event;
+
+
+
+   procedure emit_unmap_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_unmap_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_unmap_Notify_Event;
+
+
+
+   procedure emit_map_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_map_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_map_Notify_Event;
+
+
+
+   procedure emit_map_Request_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_map_Request;
+   begin
+      Self.emit (the_Event);
+   end emit_map_Request_Event;
+
+
+
+   procedure emit_reparent_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_reparent_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_reparent_Notify_Event;
+
+
+
+   procedure emit_configure_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_configure_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_configure_Notify_Event;
+
+
+
+   procedure emit_configure_Request_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_configure_Request;
+   begin
+      Self.emit (the_Event);
+   end emit_configure_Request_Event;
+
+
+
+   procedure emit_gravity_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_gravity_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_gravity_Notify_Event;
+
+
+
+   procedure emit_resize_Request_Event (Self : in out Item'Class;   Width, Height : in Positive)
+   is
+      the_Event : constant gel.Events.window_resize_Request := (Width, Height);
+   begin
+      Self.emit (the_Event);
+   end emit_resize_Request_Event;
+
+
+
+   procedure emit_circulate_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_circulate_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_circulate_Notify_Event;
+
+
+
+   procedure emit_circulate_Request_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_circulate_Request;
+   begin
+      Self.emit (the_Event);
+   end emit_circulate_Request_Event;
+
+
+
+   procedure emit_property_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_property_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_property_Notify_Event;
+
+
+
+   procedure emit_selection_Clear_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_selection_Clear;
+   begin
+      Self.emit (the_Event);
+   end emit_selection_Clear_Event;
+
+
+
+   procedure emit_selection_Request_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_selection_Request;
+   begin
+      Self.emit (the_Event);
+   end emit_selection_Request_Event;
+
+
+
+   procedure emit_selection_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_selection_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_selection_Notify_Event;
+
+
+
+   procedure emit_colormap_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_colormap_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_colormap_Notify_Event;
+
+
+
+   procedure emit_client_Message_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_client_Message;
+   begin
+      Self.emit (the_Event);
+   end emit_client_Message_Event;
+
+
+
+   procedure emit_mapping_Notify_Event (Self : in out Item'Class)
+   is
+      the_Event : gel.Events.window_mapping_Notify;
+   begin
+      Self.emit (the_Event);
+   end emit_mapping_Notify_Event;
+
+
+end gel.Window;

4-high/gel/source/gel-window.ads

@@ -0,0 +1,148 @@
+with
+     gel.Keyboard.local,
+     gel.Mouse.local,
+     openGL.Surface,
+     lace.Subject_and_deferred_Observer;
+
+private
+with
+     ada.Calendar;
+
+package gel.Window
+--
+-- Models a UI Window.
+--
+is
+   type Item is limited new lace.Subject_and_deferred_Observer.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   package Forge
+   is
+      function new_Window (Name   : in String;
+                           Width  : in Positive;
+                           Height : in Positive) return View;
+   end Forge;
+
+   overriding
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --- Exceptions
+   --
+
+   Error : exception;
+
+
+   --------------
+   --- Attributes
+   --
+
+   function is_Open          (Self : in     Item) return Boolean;
+   function is_Exposed       (Self : in     Item) return Boolean;
+
+   function Keyboard         (Self : access Item) return access gel.Keyboard.item'class;
+   function Mouse            (Self : access Item) return access gel.Mouse.item'class;
+
+   function Width            (Self : in     Item) return Positive;
+   function Height           (Self : in     Item) return Positive;
+
+   function is_being_Resized (Self : in Item'Class) return Boolean;
+
+   function Surface          (Self : in Item) return openGL.Surface.view;
+
+
+   --------------
+   --- Operations
+   --
+
+   procedure emit_Events  (Self : in out Item)   is null;
+   procedure enable_GL    (Self : in     Item)   is null;
+   procedure disable_GL   (Self : in     Item)   is null;
+   procedure swap_GL      (Self : in out Item)   is null;
+
+
+   ----------
+   --  Events
+   --
+
+   procedure emit_enter_Event             (Self : in out Item'Class);
+   procedure emit_leave_Event             (Self : in out Item'Class);
+
+   procedure emit_focus_in_Event          (Self : in out Item'Class);
+   procedure emit_focus_out_Event         (Self : in out Item'Class);
+
+   procedure emit_keymap_notify_Event     (Self : in out Item'Class);
+   procedure emit_Expose_Event            (Self : in out Item'Class);
+   procedure emit_graphics_Exposure_Event (Self : in out Item'Class);
+   procedure emit_no_Exposure_Event       (Self : in out Item'Class);
+   procedure emit_visibility_Notify_Event (Self : in out Item'Class);
+   procedure emit_create_Notify_Event     (Self : in out Item'Class);
+   procedure emit_destroy_Notify_Event    (Self : in out Item'Class);
+   procedure emit_unmap_Notify_Event      (Self : in out Item'Class);
+   procedure emit_map_Notify_Event        (Self : in out Item'Class);
+   procedure emit_map_Request_Event       (Self : in out Item'Class);
+   procedure emit_reparent_Notify_Event   (Self : in out Item'Class);
+   procedure emit_configure_Notify_Event  (Self : in out Item'Class);
+   procedure emit_configure_Request_Event (Self : in out Item'Class);
+   procedure emit_gravity_Notify_Event    (Self : in out Item'Class);
+   procedure emit_resize_Request_Event    (Self : in out Item'Class;   Width, Height : in Positive);
+   procedure emit_circulate_Notify_Event  (Self : in out Item'Class);
+   procedure emit_circulate_Request_Event (Self : in out Item'Class);
+   procedure emit_property_Notify_Event   (Self : in out Item'Class);
+   procedure emit_selection_Clear_Event   (Self : in out Item'Class);
+   procedure emit_selection_Request_Event (Self : in out Item'Class);
+   procedure emit_selection_Notify_Event  (Self : in out Item'Class);
+   procedure emit_colormap_Notify_Event   (Self : in out Item'Class);
+   procedure emit_client_Message_Event    (Self : in out Item'Class);
+   procedure emit_mapping_Notify_Event    (Self : in out Item'Class);
+
+
+
+private
+
+   type String_view is access all String;
+
+
+   type Item is limited new lace.Subject_and_deferred_Observer.item with
+      record
+         Width      : Positive;
+         Height     : Positive;
+
+         Surface    : openGL.Surface.view := new openGL.Surface.item;
+
+         Keyboard   : gel.Keyboard.local.view;
+         Mouse      : gel.Mouse   .local.view;
+
+         is_Open    : Boolean := True;
+         is_Exposed : Boolean := True;
+
+         last_resize_Time : ada.Calendar.Time;
+      end record;
+
+
+   procedure Size_is (Self : in out Item;   Width, Height : in Positive);
+
+
+   package private_Forge
+   is
+      function to_Window (Name   : in String;
+                          Width  : in Positive;
+                          Height : in Positive) return Item;
+   end private_Forge;
+
+
+   type create_Window_Function is access function (Name   : in String;
+                                                   Width  : in Positive;
+                                                   Height : in Positive) return View;
+
+   procedure use_create_Window (create_Window : in create_Window_Function);
+
+
+end gel.Window;

4-high/gel/source/gel.adb

@@ -0,0 +1,30 @@
+package body GEL
+is
+
+   function to_Asset (Self : in String) return asset_Name
+   is
+      the_Name : String (asset_Name'Range);
+   begin
+      the_Name (1               .. Self'Length)   := Self;
+      the_Name (Self'Length + 1 .. the_Name'Last) := [others => ' '];
+
+      return asset_Name (the_Name);
+   end to_Asset;
+
+
+
+   function to_String (Self : in asset_Name) return String
+   is
+   begin
+      for i in reverse Self'Range
+      loop
+         if Self (i) /= ' '
+         then
+            return String (Self (1 .. i));
+         end if;
+      end loop;
+
+      return "";
+   end to_String;
+
+end GEL;

4-high/gel/source/gel.ads

@@ -0,0 +1,83 @@
+with
+     openGL,
+     Physics,
+     float_Math.Geometry.D2,
+     float_Math.Geometry.D3,
+     float_Math.Algebra.linear.D2,
+     float_Math.Algebra.linear.D3;
+
+package GEL
+--
+--  A game engine library.
+--
+is
+   pragma Pure;
+
+   Error : exception;
+
+   --------
+   --- Math
+   --
+   package Math              renames float_Math;
+   package Geometry          renames math.Geometry;
+   package Geometry_2d       renames Geometry.D2;
+   package Geometry_3d       renames Geometry.D3;
+   package Algebra           renames math.Algebra;
+   package linear_Algebra    renames Algebra.linear;
+   package linear_Algebra_2D renames linear_Algebra.D2;
+   package linear_Algebra_3D renames linear_Algebra.D3;
+
+
+   ---------------
+   --- Constraints
+   --
+   max_Worlds          : constant := 1000;
+   max_Cameras         : constant := 1000;
+   max_graphics_Models : constant := 2**32 - 1;
+--     max_physics_Models  : constant := 2**32 - 1;
+   max_Sprites         : constant := 2**32 - 1;
+
+
+   -------
+   --- Ids
+   --
+
+   type          world_Id is range 0 .. max_Worlds;
+   type         camera_Id is range 0 .. max_Cameras;
+
+   subtype graphics_model_Id is openGL.model_Id;
+-- type  physics_model_Id is range 0 .. max_physics_Models;
+   type         sprite_Id is range 0 .. max_Sprites;
+
+   null_graphics_model_Id : constant graphics_model_Id;
+-- null_physics_model_Id  : constant physics.model_Id;
+   null_sprite_Id         : constant sprite_Id;
+
+   type graphics_model_Ids is array (Positive range <>) of graphics_model_Id;
+   type  physics_model_Ids is array (Positive range <>) of  physics.model_Id;
+   type         sprite_Ids is array (Positive range <>) of         sprite_Id;
+
+
+   ----------
+   --- Assets
+   --
+
+   type asset_Name is new String (1 .. 128);    -- TODO: Make private.
+   --
+   --  Name of a file containing textures, images, fonts, sounds, media or other resources.
+
+   null_Asset : constant asset_Name;
+
+   function to_Asset  (Self : in String)     return asset_Name;
+   function to_String (Self : in asset_Name) return String;
+
+
+
+private
+
+   null_graphics_model_Id : constant graphics_model_Id := 0;
+-- null_physics_model_Id  : constant physics.model_Id  := 0;
+   null_sprite_Id         : constant sprite_Id         := 0;
+
+   null_Asset : constant asset_Name := (others => ' ');
+end GEL;

4-high/gel/source/human/gel-human.ads

@@ -0,0 +1,288 @@
+with openGL.Model,
+     physics.Model,
+     gel.Sprite,
+     gel.Joint,
+     gel.human_Types,
+     openGL,
+     openGL.Program;
+
+limited
+with gel.World;
+
+private
+with collada.Library.visual_scenes;
+
+
+
+package gel.Human
+--
+--  Provides access to and control of a 'make_human' produced model.
+--
+is
+   type Item  is tagged limited private;
+   type View  is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+
+   procedure define (Self : in out Item;   World         : access gel.World.item'Class;
+                                           Model         : access openGL.Model.item'Class;
+                                           physics_Model : access physics.Model.item'Class;
+                                           Mass          : in     math.Real                    := 0.0;
+                                           is_Kinematic  : in     Boolean                      := False);
+
+
+
+   type bone_Sprites is array (human_types.bone_Id) of gel.Sprite.view;
+
+
+
+
+   procedure use_Model (Named : in String);
+
+
+
+
+   package Forge is
+
+      function new_Human (World         : access gel.World.item'Class;
+--                            Space         : in     gel.Sprite.physics_Space_view;
+                          Model         : access openGL.Model     .item'Class;
+                          physics_Model : access physics.Model.item'Class;
+                          Mass          : in     math.Real           := 0.0;
+                          is_Kinematic  : in     Boolean             := False) return Human.view;
+
+      function new_Human (bone_Sprites      : in     human.bone_Sprites;
+                          controller_Joints : in     human_types.controller_Joints;
+                          Model             : access openGL.Model.item'Class) return Human.view;
+
+   end Forge;
+
+
+
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   type motion_Mode is (Physics, Animation);
+
+   procedure motion_Mode_is (Self : in out Item;   Now : in motion_Mode);
+
+
+   function  base_Sprite   (Self : in     Item'Class)                                      return gel.Sprite.view;
+   function  Sprite        (Self : in     Item'Class;   for_Bone : in human_types.bone_Id) return gel.Sprite.view;
+
+
+
+   procedure controller_Joints_are (Self : in out Item'Class;   Now : in human_types.controller_Joints);
+   function  controller_Joints     (Self : in     Item'Class)     return human_types.controller_Joints;
+
+
+   procedure evolve (Self : in out Item'Class);
+
+
+
+   --- Animation
+   --
+
+   type scene_joint_Id is (Armature,
+                           MasterFloor,
+                           Root,
+                           Hips,
+                           UpLeg_L, LoLeg_L, Foot_L, Toe_L,
+                           UpLeg_R, LoLeg_R, Foot_R, Toe_R,
+                           Spine1, Spine2, Spine3,
+                           Neck,   Head,   Jaw,
+                           TongueBase, TongueMid, TongueTip,
+                           Eye_R,   Eye_L,
+                           UpLid_R, LoLid_R,
+                           UpLid_L, LoLid_L,
+
+                           Clavicle_L, UpArm_L, LoArm_L, Hand_L,
+
+                           Wrist_1_L,
+                           Palm_2_L,  Finger_2_1_L, Finger_2_2_L, Finger_2_3_L,
+                           Palm_3_L,  Finger_3_1_L, Finger_3_2_L, Finger_3_3_L,
+                           Wrist_2_L,
+                           Palm_4_L,  Finger_4_1_L, Finger_4_2_L, Finger_4_3_L,
+                           Palm_5_L,  Finger_5_1_L, Finger_5_2_L, Finger_5_3_L,
+                           Palm_1_L,  Finger_1_1_L, Finger_1_2_L, Finger_1_3_L,
+
+                           Clavicle_R, UpArm_R, LoArm_R, Hand_R,
+
+                           Wrist_1_R,
+                           Palm_2_R,  Finger_2_1_R, Finger_2_2_R, Finger_2_3_R,
+                           Palm_3_R,  Finger_3_1_R, Finger_3_2_R, Finger_3_3_R,
+                           Wrist_2_R,
+                           Palm_4_R,  Finger_4_1_R, Finger_4_2_R, Finger_4_3_R,
+                           Palm_5_R,  Finger_5_1_R, Finger_5_2_R, Finger_5_3_R,
+                           Palm_1_R,  Finger_1_1_R, Finger_1_2_R, Finger_1_3_R,
+
+                           Wrist_L, Wrist_R,
+                           Ankle_L, Ankle_R);
+
+
+
+   type axis_Kind is (x_Axis, y_Axis, z_Axis);
+
+   procedure set_rotation_Angle (Self : in out Item'Class;     for_Joint : in scene_joint_Id;
+                                                               Axis      : in Axis_Kind;
+                                                               To        : in math.Real);
+
+
+   procedure set_x_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Real);
+
+   procedure set_y_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Real);
+
+   procedure set_z_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Real);
+
+
+   procedure set_Location         (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Vector_3);
+
+
+   procedure update_all_global_Transforms (Self : in out Item'Class);
+
+
+   --- animation
+   --
+   procedure animate         (Self : in out Item;   world_Age : in Duration);
+   procedure reset_Animation (Self : in out Item);
+
+
+   type joint_Transforms is array (gel.human_Types.controller_joint_Id) of opengl.Matrix_4x4;
+
+   type skin_program_Parameters is new opengl.Program.Parameters with
+      record
+         bone_Transforms : human.joint_Transforms := (others => opengl.math.Identity_4x4);
+      end record;
+
+   overriding
+   procedure enable (Self : in out skin_program_Parameters);
+
+
+
+private
+   use human_Types;
+
+
+
+
+
+   type Joints is array (controller_joint_Id) of gel.Joint.view;
+
+
+
+   type scene_Joint is
+      record
+         Node      : collada.Library.visual_scenes.Node_view;
+         Transform : math.Matrix_4x4;
+      end record;
+
+   type scene_Joints is array (scene_joint_Id) of scene_Joint;
+
+
+
+--     type joint_Transforms is array (controller_joint_Id) of opengl.Matrix_4x4;
+--
+--     type skin_program_Parameters is new opengl.Program.Parameters with
+--        record
+--           bone_Transforms : human.joint_Transforms := (others => opengl.math.Identity_4x4);
+--        end record;
+--
+--     overriding
+--     procedure enable (Self : in out skin_program_Parameters);
+
+
+
+
+   --- Animation
+   --
+
+   type channel_Id is (root_loc,     root_x,       root_y,       root_z,
+--                         hips_x,       hips_y,       hips_z,
+                       spine_1_x,    spine_1_y,    spine_1_z,
+                       spine_2_x,    spine_2_y,    spine_2_z,
+                       spine_3_x,    spine_3_y,    spine_3_z,
+                       neck_x,       neck_y,       neck_z,
+                       head_x,       head_y,       head_z,
+
+                       l_clavicle_x, l_clavicle_y, l_clavicle_z,
+                       l_uparm_x,    l_uparm_y,    l_uparm_z,
+                       l_loarm_x,    l_loarm_y,    l_loarm_z,
+                       l_hand_x,     l_hand_y,     l_hand_z,
+                       l_wrist_loc,  l_wrist_x,    l_wrist_y,    l_wrist_z,
+
+                       r_clavicle_x, r_clavicle_y, r_clavicle_z,
+                       r_uparm_x,    r_uparm_y,    r_uparm_z,
+                       r_loarm_x,    r_loarm_y,    r_loarm_z,
+                       r_hand_x,     r_hand_y,     r_hand_z,
+                       r_wrist_loc,  r_wrist_x,    r_wrist_y,    r_wrist_z,
+
+                       l_upleg_x,    l_upleg_y,    l_upleg_z,
+                       l_loleg_x,    l_loleg_y,    l_loleg_z,
+                       l_foot_x,     l_foot_y,     l_foot_z,
+
+                       r_upleg_x,    r_upleg_y,    r_upleg_z,
+                       r_loleg_x,    r_loleg_y,    r_loleg_z,
+                       r_foot_x,     r_foot_y,     r_foot_z
+                      );
+
+
+   type animation_Channel is
+      record
+         Target        : access collada.Library.visual_scenes.Transform;
+         Times         : access collada.float_Array;
+         Cursor        :        math.Index         := 0;
+
+         Angles        : access collada.float_Array;
+         initial_Angle : math.Real;
+         current_Angle : math.Real                 := 0.0;
+         interp_Delta  : math.Real                 := 0.0;
+
+         initial_Site      : math.Vector_3;
+         current_Site      : math.Vector_3;
+         site_interp_Delta : math.Vector_3;
+      end record;
+
+
+   type animation_Channels is array (channel_Id) of animation_Channel;
+
+
+
+
+
+
+   --- Human item
+   --
+
+   type Item is tagged limited
+      record
+         Mode               :         human.motion_Mode := Physics;
+
+         Space              :          gel.Sprite.physics_Space_view;
+
+         bone_Sprites       :         human.bone_Sprites;
+
+         Joints             :         human.Joints;
+         controller_Joints  :         human_types.controller_Joints;
+
+         scene_Joints       :         human.scene_Joints;
+         root_Joint         :         collada.Library.visual_scenes.Node_view;
+
+         Model              : access  openGL.Model.item'class;
+         program_Parameters : aliased skin_program_Parameters;
+
+         Channels           :         animation_Channels;
+         start_Time         :         Duration          := 0.0;
+
+         Graphics_enabled   :         Boolean           := False;
+      end record;
+
+
+
+   procedure enable_Graphics (Self : in out Item);
+
+end gel.Human;

4-high/gel/source/human/gel-human_types.ads

@@ -0,0 +1,56 @@
+
+package gel.human_Types
+--
+--  Provides core types for defining a Human.
+--
+is
+   pragma Pure;
+
+   type controller_joint_Id is (MasterFloor,
+                                Root,
+                                Hips,
+                                UpLeg_L, LoLeg_L, Foot_L, Toe_L,
+                                UpLeg_R, LoLeg_R, Foot_R, Toe_R,
+                                Spine1, Spine2, Spine3,
+                                Neck,   Head,   Jaw,
+                                TongueBase, TongueMid, TongueTip,
+                                Eye_R,   Eye_L,
+                                UpLid_R, LoLid_R,
+                                UpLid_L, LoLid_L,
+
+                                Clavicle_L, UpArm_L, LoArm_L, Hand_L,
+
+                                Wrist_1_L,
+                                Palm_2_L,  Finger_2_1_L, Finger_2_2_L, Finger_2_3_L,
+                                Palm_3_L,  Finger_3_1_L, Finger_3_2_L, Finger_3_3_L,
+                                Wrist_2_L,
+                                Palm_4_L,  Finger_4_1_L, Finger_4_2_L, Finger_4_3_L,
+                                Palm_5_L,  Finger_5_1_L, Finger_5_2_L, Finger_5_3_L,
+                                Palm_1_L,  Finger_1_1_L, Finger_1_2_L, Finger_1_3_L,
+
+                                Clavicle_R, UpArm_R, LoArm_R, Hand_R,
+
+                                Wrist_1_R,
+                                Palm_2_R,  Finger_2_1_R, Finger_2_2_R, Finger_2_3_R,
+                                Palm_3_R,  Finger_3_1_R, Finger_3_2_R, Finger_3_3_R,
+                                Wrist_2_R,
+                                Palm_4_R,  Finger_4_1_R, Finger_4_2_R, Finger_4_3_R,
+                                Palm_5_R,  Finger_5_1_R, Finger_5_2_R, Finger_5_3_R,
+                                Palm_1_R,  Finger_1_1_R, Finger_1_2_R, Finger_1_3_R,
+
+                                Wrist_L, Wrist_R,
+                                Ankle_L, Ankle_R);
+
+   type bone_Id is new controller_joint_Id range Hips .. controller_joint_Id'Last;
+
+
+   type controller_Joint is
+      record
+         inverse_bind_Matrix      : math.Matrix_4x4;
+         joint_to_bone_site_Offet : math.Vector_3;       -- The 'bind time' offset from a joint to its bone.
+      end record;
+
+   type controller_Joints is array (controller_joint_Id) of controller_Joint;
+
+
+end gel.human_Types;

4-high/gel/source/human/gel-human_types_v1.ads

@@ -0,0 +1,79 @@
+
+package gel.human_Types_v1
+--
+--  Provides core types for defining a Human.
+--
+is
+   pragma Pure;
+
+   type controller_joint_Id is (Eye_L,             Eye_R,
+                                Head,
+                                Jaw,
+                                Chest,
+                                Clavicle_L,        Clavicle_R,
+                                Foot_L,            Foot_R,
+                                Forearm_L,         Forearm_R,
+                                Hips,
+                                Neck,
+                                Shin_L,            Shin_R,
+                                Spine,
+                                Thigh_L,           Thigh_R,
+                                Toe_L,             Toe_R,
+                                upper_Arm_L,       upper_Arm_R,
+                                F_index_01_L,      F_index_01_R,
+                                F_ring_01_L,       F_ring_01_R,
+                                Hand_L,            Hand_R,
+                                Thumb_02_L,        Thumb_02_R,
+                                Thumb_03_L,        Thumb_03_R);
+
+--     type controller_joint_Id is (MasterFloor,
+--                                  Root,
+--                                  Hips,
+--                                  UpLeg_L, LoLeg_L, Foot_L, Toe_L,
+--                                  UpLeg_R, LoLeg_R, Foot_R, Toe_R,
+--                                  Spine1, Spine2, Spine3,
+--                                  Neck,   Head,   Jaw,
+--                                  TongueBase, TongueMid, TongueTip,
+--                                  Eye_R,   Eye_L,
+--                                  UpLid_R, LoLid_R,
+--                                  UpLid_L, LoLid_L,
+--
+--                                  Clavicle_L, UpArm_L, LoArm_L, Hand_L,
+--
+--                                  Wrist_1_L,
+--                                  Palm_2_L,  Finger_2_1_L, Finger_2_2_L, Finger_2_3_L,
+--                                  Palm_3_L,  Finger_3_1_L, Finger_3_2_L, Finger_3_3_L,
+--                                  Wrist_2_L,
+--                                  Palm_4_L,  Finger_4_1_L, Finger_4_2_L, Finger_4_3_L,
+--                                  Palm_5_L,  Finger_5_1_L, Finger_5_2_L, Finger_5_3_L,
+--                                  Palm_1_L,  Finger_1_1_L, Finger_1_2_L, Finger_1_3_L,
+--
+--                                  Clavicle_R, UpArm_R, LoArm_R, Hand_R,
+--
+--                                  Wrist_1_R,
+--                                  Palm_2_R,  Finger_2_1_R, Finger_2_2_R, Finger_2_3_R,
+--                                  Palm_3_R,  Finger_3_1_R, Finger_3_2_R, Finger_3_3_R,
+--                                  Wrist_2_R,
+--                                  Palm_4_R,  Finger_4_1_R, Finger_4_2_R, Finger_4_3_R,
+--                                  Palm_5_R,  Finger_5_1_R, Finger_5_2_R, Finger_5_3_R,
+--                                  Palm_1_R,  Finger_1_1_R, Finger_1_2_R, Finger_1_3_R,
+--
+--                                  Wrist_L, Wrist_R,
+--                                  Ankle_L, Ankle_R);
+
+
+   type bone_Id is new controller_joint_Id;
+
+--     type bone_Id is new controller_joint_Id range Hips .. controller_joint_Id'Last;
+
+
+   type controller_Joint is
+      record
+         inverse_bind_Matrix      : math.Matrix_4x4;
+         joint_to_bone_site_Offet : math.Vector_3;       -- The 'bind time' offset from a joint to its bone.
+      end record;
+
+   type controller_Joints is array (controller_joint_Id) of controller_Joint;
+
+
+end gel.human_Types_v1;

4-high/gel/source/human/gel-human_v1.ads

@@ -0,0 +1,327 @@
+with
+     gel.Sprite,
+     gel.Joint,
+     gel.human_Types_v1,
+     physics.Model,
+     openGL.Model,
+     openGL.Program;
+
+limited
+with
+     gel.World;
+
+private
+with
+     collada.Library.visual_scenes;
+
+
+package gel.Human_v1
+--
+--  Provides access to and control of a 'make_human' produced model.
+--
+is
+   type Item  is tagged limited private;
+   type View  is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+
+   procedure define (Self : in out Item;   World         : access gel    .World.item'Class;
+                                           Model         : access openGL .Model.item'Class;
+                                           physics_Model : access physics.Model.item'Class;
+                                           Mass          : in     math.Real := 0.0;
+                                           is_Kinematic  : in     Boolean   := True);
+
+
+   type bone_Sprites is array (human_types_v1.bone_Id) of gel.Sprite.view;
+
+
+   procedure use_Model (Named : in String);
+
+
+   package Forge
+   is
+      function new_Human (World         : access gel    .World.item'Class;
+                          Model         : access openGL .Model.item'Class;
+                          physics_Model : access physics.Model.item'Class;
+                          Mass          : in     math.Real := 0.0;
+                          is_Kinematic  : in     Boolean   := False) return Human_v1.view;
+
+      function new_Human (bone_Sprites      : in     human_v1.bone_Sprites;
+                          controller_Joints : in     human_types_v1.controller_Joints;
+                          Model             : access openGL.Model.item'Class) return Human_v1.view;
+   end Forge;
+
+
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   type motion_Mode is (Physics, Animation);
+
+   procedure motion_Mode_is (Self : in out Item;   Now : in motion_Mode);
+
+   function  skin_Sprite   (Self     : in Item'Class)             return gel.Sprite.view;
+   function  base_Sprite   (Self     : in Item'Class)             return gel.Sprite.view;
+   function  Sprite        (Self     : in Item'Class;
+                            for_Bone : in human_types_v1.bone_Id) return gel.Sprite.view;
+
+   procedure controller_Joints_are (Self : in out Item'Class;   Now : in human_types_v1.controller_Joints);
+   function  controller_Joints     (Self : in     Item'Class)     return human_types_v1.controller_Joints;
+
+   procedure evolve (Self : in out Item'Class;   world_Age : in Duration);
+
+
+   -------------
+   --- Animation
+   --
+
+   type scene_joint_Id is (-- Armature,
+                           Hips,
+                           Thigh_L, Shin_L, Foot_L, Toe_L,
+                           Thigh_R, Shin_R, Foot_R, Toe_R,
+                           Spine, Chest,
+                           Clavicle_R, upper_Arm_R, Forearm_R, Hand_R, Thumb_02_R, Thumb_03_R, F_ring_01_R, F_index_01_R,
+                           Clavicle_L, upper_Arm_L, Forearm_L, Hand_L, Thumb_02_L, Thumb_03_L, F_ring_01_L, F_index_01_L,
+                           Neck,
+                           Head, Jaw, Eye_R, Eye_L);
+
+
+
+--     type controller_joint_Id is (Eye_L,             Eye_R,
+--                                  Head,
+--                                  Jaw,
+--                                  Chest,
+--                                  Clavicle_L,        Clavicle_R,
+--                                  Foot_L,            Foot_R,
+--                                  Forearm_L,         Forearm_R,
+--                                  Hips,
+--                                  Neck,
+--                                  Shin_L,            Shin_R,
+--                                  Spine,
+--                                  Thigh_L,           Thigh_R,
+--                                  Toe_L,             Toe_R,
+--                                  upper_Arm_L,       upper_Arm_R,
+--                                  Finger_index_01_L, Finger_index_01_R,
+--                                  Finger_ring_01_L,  Finger_ring_01_R,
+--                                  Hand_L,            Hand_R,
+--                                  Thumb_02_L,        Thumb_02_R,
+--                                  Thumb_03_L,        Thumb_03_R);
+
+
+
+
+--     type scene_joint_Id is (Armature,
+--                             MasterFloor,
+--                             Root,
+--                             Hips,
+--                             UpLeg_L, LoLeg_L, Foot_L, Toe_L,
+--                             UpLeg_R, LoLeg_R, Foot_R, Toe_R,
+--                             Spine1, Spine2, Spine3,
+--                             Neck,   Head,   Jaw,
+--                             TongueBase, TongueMid, TongueTip,
+--                             Eye_R,   Eye_L,
+--                             UpLid_R, LoLid_R,
+--                             UpLid_L, LoLid_L,
+--
+--                             Clavicle_L, UpArm_L, LoArm_L, Hand_L,
+--
+--                             Wrist_1_L,
+--                             Palm_2_L,  Finger_2_1_L, Finger_2_2_L, Finger_2_3_L,
+--                             Palm_3_L,  Finger_3_1_L, Finger_3_2_L, Finger_3_3_L,
+--                             Wrist_2_L,
+--                             Palm_4_L,  Finger_4_1_L, Finger_4_2_L, Finger_4_3_L,
+--                             Palm_5_L,  Finger_5_1_L, Finger_5_2_L, Finger_5_3_L,
+--                             Palm_1_L,  Finger_1_1_L, Finger_1_2_L, Finger_1_3_L,
+--
+--                             Clavicle_R, UpArm_R, LoArm_R, Hand_R,
+--
+--                             Wrist_1_R,
+--                             Palm_2_R,  Finger_2_1_R, Finger_2_2_R, Finger_2_3_R,
+--                             Palm_3_R,  Finger_3_1_R, Finger_3_2_R, Finger_3_3_R,
+--                             Wrist_2_R,
+--                             Palm_4_R,  Finger_4_1_R, Finger_4_2_R, Finger_4_3_R,
+--                             Palm_5_R,  Finger_5_1_R, Finger_5_2_R, Finger_5_3_R,
+--                             Palm_1_R,  Finger_1_1_R, Finger_1_2_R, Finger_1_3_R,
+--
+--                             Wrist_L, Wrist_R,
+--                             Ankle_L, Ankle_R);
+
+
+   type axis_Kind is (x_Axis, y_Axis, z_Axis);
+
+   procedure set_rotation_Angle   (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               Axis      : in Axis_Kind;
+                                                               To        : in math.Real);
+
+   procedure set_x_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Real);
+
+   procedure set_y_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Real);
+
+   procedure set_z_rotation_Angle (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Real);
+
+   procedure set_Location         (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Vector_3);
+
+   procedure set_Transform        (Self : in out Item'Class;   for_Joint : in scene_joint_Id;
+                                                               To        : in math.Matrix_4x4);
+
+   procedure update_all_global_Transforms (Self : in out Item'Class);
+
+
+   procedure animate         (Self : in out Item;   world_Age : in Duration);
+   procedure reset_Animation (Self : in out Item);
+
+
+   ----------------
+   --- Display Mode
+   --
+   type display_Mode is (Skin, Bones, Skin_and_Bones);
+
+   procedure Mode_is (Now : in display_Mode);
+
+
+
+private
+   use Human_types_v1;
+
+
+   the_display_Mode : display_Mode := Skin;
+
+
+   type Joints is array (controller_joint_Id) of gel.Joint.view;
+
+
+   type scene_Joint is
+      record
+         Node      : collada.Library.visual_scenes.Node_view;
+         Transform : math.Matrix_4x4;
+      end record;
+
+   type scene_Joints is array (scene_joint_Id) of scene_Joint;
+
+
+
+   type joint_Transforms is array (controller_joint_Id) of opengl.Matrix_4x4;
+
+   type skin_program_Parameters is new opengl.Program.Parameters with
+      record
+         bone_Transforms : human_v1.joint_Transforms := (others => opengl.math.Identity_4x4);
+      end record;
+
+   overriding
+   procedure enable (Self : in out skin_program_Parameters);
+
+
+   -------------
+   --- Animation
+   --
+
+   type channel_Id is new scene_joint_Id range Hips .. scene_joint_Id'Last;
+
+--     type channel_Id is (root_loc,     root_x,       root_y,       root_z,
+--  --                         hips_x,       hips_y,       hips_z,
+--                         spine_1_x,    spine_1_y,    spine_1_z,
+--                         spine_2_x,    spine_2_y,    spine_2_z,
+--                         spine_3_x,    spine_3_y,    spine_3_z,
+--                         neck_x,       neck_y,       neck_z,
+--                         head_x,       head_y,       head_z,
+--
+--                         l_clavicle_x, l_clavicle_y, l_clavicle_z,
+--                         l_uparm_x,    l_uparm_y,    l_uparm_z,
+--                         l_loarm_x,    l_loarm_y,    l_loarm_z,
+--                         l_hand_x,     l_hand_y,     l_hand_z,
+--                         l_wrist_loc,  l_wrist_x,    l_wrist_y,    l_wrist_z,
+--
+--                         r_clavicle_x, r_clavicle_y, r_clavicle_z,
+--                         r_uparm_x,    r_uparm_y,    r_uparm_z,
+--                         r_loarm_x,    r_loarm_y,    r_loarm_z,
+--                         r_hand_x,     r_hand_y,     r_hand_z,
+--                         r_wrist_loc,  r_wrist_x,    r_wrist_y,    r_wrist_z,
+--
+--                         l_upleg_x,    l_upleg_y,    l_upleg_z,
+--                         l_loleg_x,    l_loleg_y,    l_loleg_z,
+--                         l_foot_x,     l_foot_y,     l_foot_z,
+--
+--                         r_upleg_x,    r_upleg_y,    r_upleg_z,
+--                         r_loleg_x,    r_loleg_y,    r_loleg_z,
+--                         r_foot_x,     r_foot_y,     r_foot_z
+--                        );
+
+   type Transform is
+      record
+         Rotation    : math.Quaternion;
+         Translation : math.Vector_3;
+      end record;
+
+   type Transforms      is array (Positive range <>) of Transform;
+   type Transforms_view is access all Transforms;
+
+
+   type animation_Channel is
+      record
+         Target        : access collada.Library.visual_scenes.Transform;
+         Times         : access collada.float_Array;
+
+         Values        : access collada.float_Array;
+--           Transforms    : access collada.Matrix_4x4_array;
+
+         Cursor        :        math.Index         := 0;       -- Current frame of the anmination.
+
+         initial_Angle : math.Real;                            -- For angle interpolation during 'rotation' animation.
+         current_Angle : math.Real                 := 0.0;     --
+         interp_Delta  : math.Real                 := 0.0;     --
+
+         initial_Site      : math.Vector_3;                    -- For location interpolation during 'translation' animation.
+         current_Site      : math.Vector_3;                    --
+         site_interp_Delta : math.Vector_3;                    --
+
+         initial_Transform      : Transform;                   -- For matrix interpolation during 'full_transform' animation.
+         current_Transform      : Transform;                   --
+         slerp_Time             : math.Real;                   -- Slerp Time (T) value in range 0.0 .. 1.0.
+         Transform_interp_Delta : math.Real;                   -- Rate at which the SLERP time parameter increases.
+         Transforms             : Transforms_view;
+      end record;
+
+
+   type animation_Channels is array (channel_Id) of animation_Channel;
+
+
+   --------------
+   --- Human Item
+   --
+
+   type Item is tagged limited
+      record
+         Mode               :         human_v1.motion_Mode := Physics;
+
+         Space              :         gel.Sprite.physics_Space_view;
+
+         bone_Sprites       :         human_v1.bone_Sprites;
+         skin_Sprite        :         gel.Sprite.view;
+
+         Joints             :         human_v1.Joints;
+         controller_Joints  :         human_types_v1.controller_Joints;
+
+         scene_Joints       :         human_v1.scene_Joints;
+         root_Joint         :         collada.Library.visual_scenes.Node_view;
+
+         Model              : access  openGL.Model.item'class;
+         program_Parameters : aliased skin_program_Parameters;
+
+         Channels           :         animation_Channels;
+         start_Time         :         Duration          := 0.0;
+
+         Graphics_enabled   :         Boolean           := False;
+
+--           animation_Origin   :         math.Matrix_4x4   := to_rotate_Matrix (y_Rotation_from (math.to_Radians (90.0))); -- math.Identity_4x4;
+--           animation_Origin   :         math.Matrix_4x4   := to_transform_Matrix (math.Inverse (y_Rotation_from (math.to_Radians (-45.0))),
+--                                                                                  (0.0, 5.0, 0.0));
+      end record;
+
+
+   procedure enable_Graphics (Self : in out Item);
+
+end gel.Human_v1;

4-high/gel/source/interface/gel-keyboard.adb

@@ -0,0 +1,199 @@
+with
+     ada.Characters.latin_1;
+
+package body gel.Keyboard
+is
+
+   function Image (Self : in modified_Key) return Character
+   is
+      use ada.Characters.latin_1;
+
+      key_Map_of_character : constant array (Key) of Character
+        := [SPACE  => ' ',
+            QUOTE  => ''',
+            COMMA  => ',',
+            MINUS  => '-',
+            PERIOD => '.',
+            SLASH  => '/',
+
+            '0' => '0',
+            '1' => '1',
+            '2' => '2',
+            '3' => '3',
+            '4' => '4',
+            '5' => '5',
+            '6' => '6',
+            '7' => '7',
+            '8' => '8',
+            '9' => '9',
+
+            SEMICOLON    => ';',
+            EQUALS       => '=',
+            LEFTBRACKET  => '[',
+            BACKSLASH    => '\',
+            RIGHTBRACKET => ']',
+            BACKQUOTE    => '`',
+
+            a => 'a',
+            b => 'b',
+            c => 'c',
+            d => 'd',
+            e => 'e',
+            f => 'f',
+            g => 'g',
+            h => 'h',
+            i => 'i',
+            j => 'j',
+            k => 'k',
+            l => 'l',
+            m => 'm',
+            n => 'n',
+            o => 'o',
+            p => 'p',
+            q => 'q',
+            r => 'r',
+            s => 's',
+            t => 't',
+            u => 'u',
+            v => 'v',
+            w => 'w',
+            x => 'x',
+            y => 'y',
+            z => 'z',
+
+            KP0 => '0',
+            KP1 => '1',
+            KP2 => '2',
+            KP3 => '3',
+            KP4 => '4',
+            KP5 => '5',
+            KP6 => '6',
+            KP7 => '7',
+            KP8 => '8',
+            KP9 => '9',
+
+            KP_PERIOD   => '.',
+            KP_DIVIDE   => '/',
+            KP_MULTIPLY => '*',
+            KP_MINUS    => '-',
+            KP_PLUS     => '+',
+            KP_ENTER    => NUL,
+            KP_EQUALS   => '=',
+
+            others => NUL];
+
+
+      shifted_key_Map_of_character : constant array (Key) of Character
+        := [SPACE  => ' ',
+            QUOTE  => '"',
+            COMMA  => '<',
+            MINUS  => '_',
+            PERIOD => '>',
+            SLASH  => '?',
+
+            '0' => ')',
+            '1' => '!',
+            '2' => '@',
+            '3' => '#',
+            '4' => '$',
+            '5' => '%',
+            '6' => '^',
+            '7' => '&',
+            '8' => '*',
+            '9' => '(',
+
+            SEMICOLON    => ':',
+            EQUALS       => '+',
+            LEFTBRACKET  => '{',
+            BACKSLASH    => '|',
+            RIGHTBRACKET => '}',
+            BACKQUOTE    => '~',
+
+            a => 'A',
+            b => 'B',
+            c => 'C',
+            d => 'D',
+            e => 'E',
+            f => 'F',
+            g => 'G',
+            h => 'H',
+            i => 'I',
+            j => 'J',
+            k => 'K',
+            l => 'L',
+            m => 'M',
+            n => 'N',
+            o => 'O',
+            p => 'P',
+            q => 'Q',
+            r => 'R',
+            s => 'S',
+            t => 'T',
+            u => 'U',
+            v => 'V',
+            w => 'W',
+            x => 'X',
+            y => 'Y',
+            z => 'Z',
+
+            KP0 => '0',
+            KP1 => '1',
+            KP2 => '2',
+            KP3 => '3',
+            KP4 => '4',
+            KP5 => '5',
+            KP6 => '6',
+            KP7 => '7',
+            KP8 => '8',
+            KP9 => '9',
+
+            KP_PERIOD   => '.',
+            KP_DIVIDE   => '/',
+            KP_MULTIPLY => '*',
+            KP_MINUS    => '-',
+            KP_PLUS     => '+',
+            KP_ENTER    => NUL,
+            KP_EQUALS   => '=',
+
+            others => NUL];
+
+   begin
+      if        Self.modifier_Set (LShift)
+        or else Self.modifier_Set (RShift)
+      then
+         return shifted_key_Map_of_Character (Self.Key);
+      else
+         return         key_Map_of_Character (Self.Key);
+      end if;
+   end Image;
+
+
+
+   function is_Graphic (Self : in Key) return Boolean
+   is
+   begin
+      return    Self = SPACE
+        or else Self = QUOTE
+        or else Self = COMMA
+        or else Self = MINUS
+        or else Self = PERIOD
+        or else Self = SLASH
+        or else Self in '0' .. '9'
+        or else Self = SEMICOLON
+        or else Self = EQUALS
+        or else Self = LEFTBRACKET
+        or else Self = BACKSLASH
+        or else Self = RIGHTBRACKET
+        or else Self = BACKQUOTE
+        or else Self in   a .. z
+        or else Self in KP0 .. KP9
+        or else Self = KP_PERIOD
+        or else Self = KP_DIVIDE
+        or else Self = KP_MULTIPLY
+        or else Self = KP_MINUS
+        or else Self = KP_PLUS
+        or else Self = KP_EQUALS;
+   end is_Graphic;
+
+
+end gel.Keyboard;

4-high/gel/source/interface/gel-keyboard.ads

@@ -0,0 +1,163 @@
+with
+     lace.Event,
+     lace.Subject;
+
+package gel.Keyboard with remote_Types
+--
+--  Provides an interface for a keyboard.
+--
+is
+
+   type Item is  limited interface
+             and lace.Subject.item;
+
+   type View is access all Item'class;
+
+
+   --------
+   --- Keys
+   --
+
+   type Key is (Nil,                   -- TODO: Better names.
+                BACKSPACE,
+                TAB,
+                CLEAR,
+                ENTER,
+                PAUSE,
+                ESCAPE,
+                SPACE,
+                EXCLAIM,
+                QUOTEDBL,
+                HASH,
+                DOLLAR,
+                Percent,
+                AMPERSAND,
+                QUOTE,
+                LEFTPAREN,
+                RIGHTPAREN,
+                ASTERISK,
+                PLUS,
+                COMMA,
+                MINUS,
+                PERIOD,
+                SLASH,
+                '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
+                COLON,  SEMICOLON,
+                LESS,   EQUALS,    GREATER,
+                QUESTION,
+                AT_key,
+                LEFTBRACKET,
+                BACKSLASH,
+                RIGHTBRACKET,
+                CARET,
+                UNDERSCORE,
+                BACKQUOTE,
+                a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z,
+                DELETE,
+                WORLD_0,  WORLD_1,  WORLD_2,  WORLD_3,  WORLD_4,  WORLD_5,  WORLD_6,  WORLD_7,  WORLD_8,  WORLD_9,
+                WORLD_10, WORLD_11, WORLD_12, WORLD_13, WORLD_14, WORLD_15, WORLD_16, WORLD_17, WORLD_18, WORLD_19,
+                WORLD_20, WORLD_21, WORLD_22, WORLD_23, WORLD_24, WORLD_25, WORLD_26, WORLD_27, WORLD_28, WORLD_29,
+                WORLD_30, WORLD_31, WORLD_32, WORLD_33, WORLD_34, WORLD_35, WORLD_36, WORLD_37, WORLD_38, WORLD_39,
+                WORLD_40, WORLD_41, WORLD_42, WORLD_43, WORLD_44, WORLD_45, WORLD_46, WORLD_47, WORLD_48, WORLD_49,
+                WORLD_50, WORLD_51, WORLD_52, WORLD_53, WORLD_54, WORLD_55, WORLD_56, WORLD_57, WORLD_58, WORLD_59,
+                WORLD_60, WORLD_61, WORLD_62, WORLD_63, WORLD_64, WORLD_65, WORLD_66, WORLD_67, WORLD_68, WORLD_69,
+                WORLD_70, WORLD_71, WORLD_72, WORLD_73, WORLD_74, WORLD_75, WORLD_76, WORLD_77, WORLD_78, WORLD_79,
+                WORLD_80, WORLD_81, WORLD_82, WORLD_83, WORLD_84, WORLD_85, WORLD_86, WORLD_87, WORLD_88, WORLD_89,
+                WORLD_90, WORLD_91, WORLD_92, WORLD_93, WORLD_94, WORLD_95,
+                KP0, KP1, KP2, KP3, KP4, KP5, KP6, KP7, KP8, KP9,
+                KP_PERIOD,
+                KP_DIVIDE, KP_MULTIPLY, KP_MINUS, KP_PLUS,
+                KP_ENTER,  KP_EQUALS,
+                UP, DOWN, RIGHT, LEFT,
+                INSERT,
+                HOME, END_key,
+                PAGEUP, PAGEDOWN,
+                F1, F2, F3, F4, F5, F6, F7, F8, F9, F10, F11, F12, F13, F14, F15,
+                NUMLOCK, CAPSLOCK, SCROLLLOCK,
+                RSHIFT,  LSHIFT,
+                RCTRL,   LCTRL,
+                RALT,    LALT,
+                RMETA,   LMETA,
+                LSUPER,  RSUPER,
+                MODE,
+                COMPOSE,
+                HELP,
+                PRINT,
+                SYSREQ,
+                BREAK,
+                MENU,
+                POWER,
+                EURO,
+                UNDO);
+
+   function is_Graphic (Self : in Key) return Boolean;
+
+
+   -------------
+   --- Modifiers
+   --
+
+   type Modifier is (LSHIFT,                 -- TODO: Better names.
+                     RSHIFT,
+                     LCTRL,
+                     RCTRL,
+                     LALT,
+                     RALT,
+                     LMETA,
+                     RMETA,
+                     NUM,
+                     CAPS,
+                     MODE);
+
+   type modifier_Set is array (Modifier) of Boolean;
+
+   no_Modifiers : constant modifier_Set;
+
+
+   type modified_Key is
+      record
+         Key          : keyboard.Key;
+         modifier_Set : keyboard.modifier_Set;
+      end record;
+
+   function Image (Self : in modified_Key) return Character;
+
+
+   ----------
+   --- Events
+   --
+
+   type key_press_Event is new lace.Event.item with
+      record
+         modified_Key : keyboard.modified_Key;
+         Code         : Integer;
+      end record;
+
+   type key_release_Event is new lace.Event.item with
+      record
+         modified_Key : keyboard.modified_Key;
+      end record;
+
+
+   --------------
+   --- Attributes
+   --
+
+   function Modifiers (Self : in Item) return Modifier_Set is abstract;
+
+
+   --------------
+   --- Operations
+   --
+
+   procedure emit_key_press_Event   (Self : in out Item;   Key      : in keyboard.Key;
+                                                           key_Code : in Integer)      is abstract;
+   procedure emit_key_release_Event (Self : in out Item;   Key      : in keyboard.Key) is abstract;
+
+
+
+private
+
+   no_Modifiers : constant modifier_Set := [others => False];
+
+end gel.Keyboard;

4-high/gel/source/interface/gel-mouse.adb

@@ -0,0 +1,43 @@
+package body gel.Mouse
+is
+
+   --------------
+   --- Attributes
+   --
+
+   -- Nil.
+
+
+   ---------------
+   ---  Operations
+   --
+
+   procedure emit_button_press_Event (Self : in out Item'Class;   Button    : in mouse.button_Id;
+                                                                  Modifiers : in keyboard.modifier_Set;
+                                                                  Site      : in mouse.Site)
+   is
+   begin
+      self.emit (button_press_Event' (Button, Modifiers, Site));
+   end emit_button_press_Event;
+
+
+
+
+   procedure emit_button_release_Event (Self : in out Item'Class;   Button    : in mouse.button_Id;
+                                                                    Modifiers : in keyboard.modifier_Set;
+                                                                    Site      : in mouse.Site)
+   is
+   begin
+      self.emit (button_release_Event' (Button, Modifiers, Site));
+   end emit_button_release_Event;
+
+
+
+   procedure emit_motion_Event (Self : in out Item'Class;   Site : in mouse.Site)
+   is
+   begin
+      self.emit (motion_Event' (site => Site));
+   end emit_motion_Event;
+
+
+end gel.Mouse;

4-high/gel/source/interface/gel-mouse.ads

@@ -0,0 +1,67 @@
+with
+     gel.Keyboard,
+
+     lace.Event,
+     lace.Subject;
+
+package gel.Mouse with remote_Types
+--
+-- Provides an interface to a mouse.
+--
+is
+   type Item is  limited interface
+             and lace.Subject.item;
+
+   type View is access all Item'class;
+
+
+   ----------
+   --- Events
+   --
+
+   type Button_Id is range 1 .. 5;
+   type Site      is new math.Integers (1 .. 2);      -- Window pixel (x,y) site.
+
+   type button_press_Event is new lace.Event.item with
+      record
+         Button       : button_Id;
+         modifier_Set : keyboard.modifier_Set;
+         Site         : mouse.Site;
+      end record;
+
+   type button_release_Event is new lace.Event.item with
+      record
+         Button       : button_Id;
+         modifier_Set : keyboard.modifier_Set;
+         Site         : mouse.Site;
+      end record;
+
+   type motion_Event is new lace.Event.item with
+      record
+         Site : mouse.Site;
+      end record;
+
+
+   --------------
+   --- Attributes
+   --
+
+   -- Nil.
+
+
+   --------------
+   --- Operations
+   --
+
+   procedure emit_button_press_Event   (Self : in out Item'Class;   Button    : in mouse.button_Id;
+                                                                    Modifiers : in keyboard.modifier_Set;
+                                                                    Site      : in mouse.Site);
+
+   procedure emit_button_release_Event (Self : in out Item'Class;   Button    : in mouse.button_Id;
+                                                                    Modifiers : in keyboard.modifier_Set;
+                                                                    Site      : in mouse.Site);
+
+   procedure emit_motion_Event         (Self : in out Item'Class;   Site      : in mouse.Site);
+
+
+end gel.Mouse;

4-high/gel/source/joint/gel-any_joint.adb

@@ -0,0 +1,228 @@
+with
+     physics.Object;
+
+
+package body gel.any_Joint
+is
+   use Math;
+
+   ---------
+   --  Forge
+   --
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           Frame_A,  Frame_B  : in     Matrix_4x4)
+   is
+      A_Frame : aliased constant Matrix_4x4 := Frame_A;
+      B_Frame : aliased constant Matrix_4x4 := Frame_B;
+
+      type Joint_cast is access all gel.Joint.Item;
+
+      sprite_A_Solid,
+      sprite_B_Solid : std_Physics.Object.view;
+
+   begin
+      if Sprite_A /= null then   sprite_A_Solid := std_Physics.Object.view (Sprite_A.Solid);   end if;
+      if Sprite_B /= null then   sprite_B_Solid := std_Physics.Object.view (Sprite_B.Solid);   end if;
+
+      Joint.define (Joint_cast (Self), Sprite_A, Sprite_B);   -- Define base class.
+
+      Self.Physics := in_Space.new_DoF6_Joint (sprite_A_Solid,
+                                               sprite_B_Solid,
+                                               A_Frame,
+                                               B_Frame);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           pivot_Anchor       : in     Vector_3;
+                                           pivot_Axis         : in     Matrix_3x3)
+   is
+      use linear_Algebra_3D;
+
+      pivot_in_A : constant Vector_3   := Inverse (Sprite_A.Spin) * (pivot_Anchor - Sprite_A.Site);
+      pivot_in_B : constant Vector_3   := Inverse (Sprite_B.Spin) * (pivot_Anchor - Sprite_B.Site);
+
+      axis_in_A  : constant Matrix_3x3 := Sprite_A.Spin * pivot_Axis;
+      axis_in_B  : constant Matrix_3x3 := Sprite_B.Spin * pivot_Axis;
+
+      Frame_A    : constant Matrix_4x4 := to_transform_Matrix (axis_in_A, pivot_in_A);
+      Frame_B    : constant Matrix_4x4 := to_transform_Matrix (axis_in_B, pivot_in_B);
+   begin
+      Self.define (in_Space,
+                   Sprite_A, Sprite_B,
+                   Frame_A,  Frame_B);
+   end define;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      raise Error with "TODO";
+   end destroy;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Frame_A (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_A;
+   end Frame_A;
+
+
+
+   overriding
+   function Frame_B (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_B;
+   end Frame_B;
+
+
+
+   overriding
+   procedure Frame_A_is (Self : in out Item; Now : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_A_is (Now);
+   end Frame_A_is;
+
+
+
+   overriding
+   procedure Frame_B_is (Self : in out Item; Now : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_B_is (Now);
+   end Frame_B_is;
+
+
+
+   overriding
+   function Physics (Self : in Item) return gel.joint.Physics_view
+   is
+   begin
+      return gel.joint.Physics_view (Self.Physics);
+   end Physics;
+
+
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return Joint.Degree_of_freedom
+   is
+      pragma unreferenced (Self);
+   begin
+      return 6;
+   end Degrees_of_freedom;
+
+
+
+   --  Bounds - limits the range of motion for a degree of freedom.
+   --
+
+   -- TODO: Use Radians type for angular bounds.
+
+   overriding
+   function is_Bound (Self : in Item;   for_Degree : in joint.Degree_of_freedom) return Boolean
+   is
+   begin
+      if for_Degree in Sway .. Surge then
+         return False;
+      end if;
+
+      return Self.Physics.is_Limited (for_Degree);
+   end is_Bound;
+
+
+
+   overriding
+   function low_Bound (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.lower_Limit (for_Degree);
+      end case;
+   end low_Bound;
+
+
+
+   overriding
+   procedure low_Bound_is (Self : access Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                 Now        : in Real)
+   is
+   begin
+      Self.Physics.lower_Limit_is (Now, for_Degree);
+   end low_Bound_is;
+
+
+
+   overriding
+   function high_Bound (Self : access Item;   for_Degree : in Joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.upper_Limit (for_Degree);
+      end case;
+   end high_Bound;
+
+
+
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                  Now        : in Real)
+   is
+   begin
+      Self.Physics.upper_Limit_is (Now, for_Degree);
+   end high_Bound_is;
+
+
+   ----------
+   --  Extent
+   --
+
+   overriding
+   function Extent (Self : in Item;   for_Degree : in Joint.Degree_of_freedom) return Real
+   is
+   begin
+      if for_Degree in Sway .. Surge
+      then
+         raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.Physics.Extent (for_Degree);
+   end Extent;
+
+
+   ------------------
+   --  Motor Velocity
+   --
+
+   overriding
+   procedure Velocity_is (Self : in Item;   for_Degree : in Joint.Degree_of_freedom;
+                                            Now        : in Real)
+   is
+   begin
+      Self.Physics.Velocity_is (Now, for_Degree);
+   end Velocity_is;
+
+
+end gel.any_Joint;

4-high/gel/source/joint/gel-any_joint.ads

@@ -0,0 +1,109 @@
+with
+     gel.Joint,
+     gel.Sprite,
+
+     physics.Joint.DoF6,
+     physics.Space;
+
+package GEL.any_Joint
+--
+--  Allows sprites to be connected via '6 degree of freedom' joint.
+--
+is
+   type Item  is new GEL.Joint.Item with private;
+   type View  is access all Item'Class;
+   type Views is array (Math.Index range <>) of View;
+
+
+   Sway  : constant Joint.Degree_of_freedom := 1;
+   Heave : constant Joint.Degree_of_freedom := 2;
+   Surge : constant Joint.Degree_of_freedom := 3;
+
+   Pitch : constant Joint.Degree_of_freedom := 4;
+   Yaw   : constant Joint.Degree_of_freedom := 5;
+   Roll  : constant Joint.Degree_of_freedom := 6;
+
+
+   package std_physics renames standard.Physics;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define  (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                            Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                            pivot_Anchor       : in     math.Vector_3;
+                                            pivot_Axis         : in     math.Matrix_3x3);
+
+   procedure define  (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                            Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                            Frame_A,  Frame_B  : in     math.Matrix_4x4);
+
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function  Physics    (Self : in     Item) return gel.Joint.Physics_view;
+
+   overriding
+   function  Frame_A    (Self : in     Item) return math.Matrix_4x4;
+   overriding
+   function  Frame_B    (Self : in     Item) return math.Matrix_4x4;
+
+   overriding
+   procedure Frame_A_is (Self : in out Item;   Now : in math.Matrix_4x4);
+   overriding
+   procedure Frame_B_is (Self : in out Item;   Now : in math.Matrix_4x4);
+
+   overriding
+   function  Degrees_of_freedom (Self : in     Item) return joint.Degree_of_freedom;
+
+
+   --  Bounds - limits the range of motion for a degree of freedom.
+   --
+
+   overriding
+   function  is_Bound      (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Boolean;
+
+   overriding
+   function  low_Bound     (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return math.Real;
+   overriding
+   procedure low_Bound_is  (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                   Now        : in math.Real);
+   overriding
+   function  high_Bound    (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return math.Real;
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in math.Real);
+   overriding
+   function  Extent        (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return math.Real;
+
+   overriding
+   procedure Velocity_is   (Self : in     Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in math.Real);
+
+   --------------
+   --- Operations
+   --
+
+   -- Nil.
+
+
+
+private
+
+   type physics_DoF6_Joint_view is access all std_physics.Joint.DoF6.item'Class;
+
+
+   type Item is new gel.Joint.item with
+      record
+         Physics : access std_physics.Joint.DoF6.item'Class;
+   end record;
+
+end GEL.any_Joint;

4-high/gel/source/joint/gel-ball_joint.adb

@@ -0,0 +1,188 @@
+with
+     physics.Object;
+
+package body GEL.ball_Joint
+is
+
+   ----------
+   ---  Forge
+   --
+
+   procedure define (Self : access Item;   in_Space                : in     std_physics.Space.view;
+                                           Sprite_A,    Sprite_B   : access gel.Sprite.item'Class;
+                                           Pivot_in_A,  Pivot_in_B : in     Vector_3)
+   is
+      type Joint_cast is access all gel.Joint.Item;
+
+      sprite_A_Solid,
+      sprite_B_Solid : std_physics.Object.view;
+
+   begin
+      if Sprite_A /= null then   sprite_A_Solid := std_physics.Object.view (Sprite_A.Solid);   end if;
+      if Sprite_B /= null then   sprite_B_Solid := std_physics.Object.view (Sprite_B.Solid);   end if;
+
+      Joint.define (Joint_cast (Self), Sprite_A, Sprite_B);     -- Define base class.
+
+      Self.Physics := in_Space.new_ball_Joint (sprite_A_Solid,
+                                               sprite_B_Solid,
+                                               Pivot_in_A,
+                                               Pivot_in_B);
+   end define;
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      raise Error with "TODO";
+   end destroy;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Frame_A (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_A;
+   end Frame_A;
+
+
+   overriding
+   function Frame_B (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_B;
+   end Frame_B;
+
+
+   overriding
+   procedure Frame_A_is (Self : in out Item; Now : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_A_is (Now);
+   end Frame_A_is;
+
+
+   overriding
+   procedure Frame_B_is (Self : in out Item; Now : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_B_is (Now);
+   end Frame_B_is;
+
+
+   overriding
+   function Physics (Self : in Item) return gel.joint.Physics_view
+   is
+   begin
+      return Self.Physics;
+   end Physics;
+
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return joint.Degree_of_freedom
+   is
+      pragma unreferenced (Self);
+   begin
+      return 6;
+   end Degrees_of_freedom;
+
+
+   ----------
+   --- Bounds - limits the range of motion for a Degree of freedom.
+   --
+
+   overriding
+   function is_Bound (Self : in Item;   for_Degree : in joint.Degree_of_freedom) return Boolean
+   is
+   begin
+      if for_Degree in Sway .. Surge then
+         return False;
+      end if;
+
+      return Self.Physics.is_Limited (for_Degree);
+   end is_Bound;
+
+
+   overriding
+   function low_Bound (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.lower_Limit (for_Degree);
+      end case;
+   end low_Bound;
+
+
+   overriding
+   procedure low_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                 Now        : in Real)
+   is
+   begin
+      Self.Physics.lower_Limit_is (Now, for_Degree);
+   end low_Bound_is;
+
+
+   overriding
+   function high_Bound (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.upper_Limit (for_Degree);
+      end case;
+   end high_Bound;
+
+
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real)
+   is
+   begin
+      Self.Physics.upper_Limit_is (Now, for_Degree);
+   end high_Bound_is;
+
+
+   ----------
+   --- Extent
+   --
+
+   overriding
+   function Extent (Self : in Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      if for_Degree in Sway .. Surge
+      then
+         raise Error with "Unhandled Degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.Physics.Extent (for_Degree);
+   end Extent;
+
+
+   ------------------
+   --- Motor Velocity
+   --
+
+   overriding
+   procedure Velocity_is (Self : in Item;   for_Degree : in joint.Degree_of_freedom;
+                                            Now        : in Real)
+   is
+   begin
+      Self.Physics.Velocity_is (Now, for_Degree);
+   end Velocity_is;
+
+
+end gel.ball_Joint;

4-high/gel/source/joint/gel-ball_joint.ads

@@ -0,0 +1,107 @@
+with
+     gel.Joint,
+     gel.Sprite,
+
+     physics.Joint.DoF6,
+     physics.Joint.Ball,
+     physics.Space;
+
+package gel.ball_Joint
+--
+--  Allows sprites to be connected via a 'ball and socket' joint.
+--
+is
+   type Item  is new gel.Joint.item with private;
+   type View  is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+
+   Sway  : constant Joint.Degree_of_freedom := 1;     -- TODO: Can we use an enumeration here ?
+   Heave : constant Joint.Degree_of_freedom := 2;
+   Surge : constant Joint.Degree_of_freedom := 3;
+
+   Pitch : constant Joint.Degree_of_freedom := 4;
+   Yaw   : constant Joint.Degree_of_freedom := 5;
+   Roll  : constant Joint.Degree_of_freedom := 6;
+
+
+   package std_physics renames standard.Physics;
+   use Math;
+
+   ----------
+   ---  Forge
+   --
+
+   procedure define  (Self : access Item;   in_Space                : in     std_physics.Space.view;
+                                            Sprite_A,    Sprite_B   : access gel.Sprite.item'Class;
+                                            Pivot_in_A,  Pivot_in_B : in     Vector_3);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --  Attributes
+   --
+
+   overriding
+   function Physics     (Self : in     Item) return gel.joint.Physics_view;
+
+   overriding
+   function Frame_A     (Self : in     Item) return Matrix_4x4;
+   overriding
+   function Frame_B     (Self : in     Item) return Matrix_4x4;
+
+   overriding
+   procedure Frame_A_is (Self : in out Item;   Now : in Matrix_4x4);
+   overriding
+   procedure Frame_B_is (Self : in out Item;   Now : in Matrix_4x4);
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return joint.Degree_of_freedom;
+
+
+   ----------
+   --- Bounds - limits the range of motion for a degree of freedom.
+   --
+
+   overriding
+   function  is_Bound      (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Boolean;
+
+   overriding
+   function  low_Bound     (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+   overriding
+   procedure low_Bound_is  (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+
+   overriding
+   function  high_Bound     (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+
+   overriding
+   function  Extent        (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+
+   overriding
+   procedure Velocity_is   (Self : in     Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+
+   --------------
+   --- Operations
+   --
+
+   -- Nil.
+
+
+
+private
+
+   type physics_DoF6_Joint_view is access all std_physics.Joint.DoF6.item'Class;
+
+
+   type Item is new GEL.Joint.item with
+      record
+         Physics : access std_physics.Joint.ball.item'Class;
+   end record;
+
+end gel.ball_Joint;

4-high/gel/source/joint/gel-cone_twist_joint.adb

@@ -0,0 +1,209 @@
+with
+     physics.Object;
+
+package body gel.cone_twist_Joint
+is
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           Frame_A,  Frame_B  : in     Matrix_4x4)
+   is
+      A_Frame : aliased constant Matrix_4x4 := Frame_A;
+      B_Frame : aliased constant Matrix_4x4 := Frame_B;
+
+      type Joint_cast is access all gel.Joint.item;
+
+      sprite_A_Solid,
+      sprite_B_Solid : std_physics.Object.view;
+
+   begin
+      if Sprite_A /= null then   sprite_A_Solid := standard.physics.Object.view (Sprite_A.Solid);   end if;
+      if Sprite_B /= null then   sprite_B_Solid := standard.physics.Object.view (Sprite_B.Solid);   end if;
+
+      Joint.define (Joint_cast (Self),  Sprite_A, Sprite_B);   -- Define base class.
+
+      Self.Physics := in_Space.new_DoF6_Joint (sprite_A_Solid,
+                                               sprite_B_Solid,
+                                               A_Frame,
+                                               B_Frame);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           pivot_Anchor       : in     Vector_3;
+                                           pivot_Axis         : in     Matrix_3x3)
+   is
+      use linear_Algebra_3D;
+
+      pivot_in_A : constant Vector_3   := pivot_Anchor - Sprite_A.Site;
+      pivot_in_B : constant Vector_3   := pivot_Anchor - Sprite_B.Site;
+
+      Frame_A    : constant Matrix_4x4 := to_transform_Matrix (pivot_Axis, pivot_in_A);
+      Frame_B    : constant Matrix_4x4 := to_transform_Matrix (pivot_Axis, pivot_in_B);
+   begin
+      Self.define (in_Space,
+                   Sprite_A, Sprite_B,
+                   Frame_A,  Frame_B);
+   end define;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      raise Error with "TODO";
+   end destroy;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Frame_A (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_A;
+   end Frame_A;
+
+
+   overriding
+   function Frame_B (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_B;
+   end Frame_B;
+
+
+   overriding
+   procedure Frame_A_is (Self : in out Item; Now : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_A_is (Now);
+   end Frame_A_is;
+
+
+   overriding
+   procedure Frame_B_is (Self : in out Item; Now : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_B_is (Now);
+   end Frame_B_is;
+
+
+   overriding
+   function Physics (Self : in Item) return gel.Joint.Physics_view
+   is
+   begin
+      return joint.Physics_view (Self.Physics);
+   end Physics;
+
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return joint.Degree_of_freedom
+   is
+      pragma unreferenced (Self);
+   begin
+      return 6;
+   end Degrees_of_freedom;
+
+
+
+   --  Bounds - limits the range of motion for a Degree of freedom.
+   --
+
+   overriding
+   function is_Bound (Self : in Item;   for_Degree : in joint.Degree_of_freedom) return Boolean
+   is
+   begin
+      if for_Degree in Sway .. Surge
+      then
+         return False;
+      end if;
+
+      return Self.Physics.is_Limited (for_Degree);
+   end is_Bound;
+
+
+   overriding
+   function low_Bound (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled Degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.lower_Limit (for_Degree);
+      end case;
+   end low_Bound;
+
+
+   overriding
+   procedure low_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                 Now        : in Real)
+   is
+   begin
+      Self.Physics.lower_Limit_is (Now, for_Degree);
+   end low_Bound_is;
+
+
+   overriding
+   function high_Bound (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled Degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.upper_Limit (for_Degree);
+      end case;
+   end high_Bound;
+
+
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real)
+   is
+   begin
+      Self.Physics.upper_Limit_is (Now, for_Degree);
+   end high_Bound_is;
+
+
+   ----------
+   --- Extent
+   --
+
+   overriding
+   function Extent (Self : in Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+   begin
+      if for_Degree in Sway .. Surge
+      then
+         raise Error with "Unhandled Degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.Physics.Extent (for_Degree);
+   end Extent;
+
+
+   ------------------
+   --- Motor Velocity
+   --
+
+   overriding
+   procedure Velocity_is (Self : in Item;   for_Degree : in joint.Degree_of_freedom;
+                                            Now        : in Real)
+   is
+   begin
+      Self.Physics.Velocity_is (Now, for_Degree);
+   end Velocity_is;
+
+
+end gel.cone_twist_Joint;

4-high/gel/source/joint/gel-cone_twist_joint.ads

@@ -0,0 +1,109 @@
+with
+     gel.Joint,
+     gel.Sprite,
+
+     physics.Joint.DoF6,
+     physics.Space;
+
+package gel.cone_twist_Joint
+--
+--  Allows sprites to be connected via 'cone-twist' joint.
+--
+is
+   type Item  is new gel.Joint.item with private;
+   type View  is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+
+   Sway  : constant Joint.Degree_of_freedom := 1;     -- TODO: These are duplicated in other joints.
+   Heave : constant Joint.Degree_of_freedom := 2;
+   Surge : constant Joint.Degree_of_freedom := 3;
+
+   Pitch : constant Joint.Degree_of_freedom := 4;
+   Yaw   : constant Joint.Degree_of_freedom := 5;
+   Roll  : constant Joint.Degree_of_freedom := 6;
+
+
+   package std_physics renames standard.Physics;
+   use Math;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define  (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                            Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                            pivot_Anchor       : in     Vector_3;
+                                            pivot_Axis         : in     Matrix_3x3);
+
+   procedure define  (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                            Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                            Frame_A,  Frame_B  : in     Matrix_4x4);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function  Physics    (Self : in     Item) return gel.joint.Physics_view;
+
+   overriding
+   function  Frame_A    (Self : in     Item) return Matrix_4x4;
+   overriding
+   function  Frame_B    (Self : in     Item) return Matrix_4x4;
+
+   overriding
+   procedure Frame_A_is (Self : in out Item; Now : in Matrix_4x4);
+   overriding
+   procedure Frame_B_is (Self : in out Item; Now : in Matrix_4x4);
+
+   overriding
+   function  Degrees_of_freedom (Self : in Item) return joint.Degree_of_freedom;
+
+
+   --  Bounds - limits the range of motion for a degree of freedom.
+   --
+
+   overriding
+   function  is_Bound      (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Boolean;
+
+   overriding
+   function  low_Bound     (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+   overriding
+   procedure low_Bound_is  (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+   overriding
+   function  high_Bound    (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+   overriding
+   function  Extent        (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+
+   overriding
+   procedure Velocity_is   (Self : in     Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+
+   --------------
+   --- Operations
+   --
+
+   -- Nil.
+
+
+
+private
+
+   type physics_DoF6_Joint_view is access all std_physics.Joint.DoF6.item'Class;
+
+
+   type Item is new GEL.Joint.Item with
+      record
+         Physics : access std_physics.Joint.DoF6.item'Class;
+   end record;
+
+end gel.cone_twist_Joint;

4-high/gel/source/joint/gel-hinge_joint.adb

@@ -0,0 +1,334 @@
+with
+     physics.Object,
+     ada.unchecked_Deallocation;
+
+package body gel.hinge_Joint
+is
+   use gel.Joint;
+
+
+   procedure define (Self : access Item;  in_Space           : in     std_physics.Space.view;
+                                          Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                          pivot_Axis         : in     Vector_3;
+                                          pivot_Anchor       : in     Vector_3)
+   is
+      pivot_in_A : constant Vector_3 := (pivot_Anchor - Sprite_A.Site);
+      pivot_in_B : constant Vector_3 := (pivot_Anchor - Sprite_B.Site);
+
+      the_Axis   : constant Vector_3 := pivot_Axis;
+
+   begin
+      Self.define (in_Space,
+                   Sprite_A,   Sprite_B,
+                   the_Axis,
+                   pivot_in_A, pivot_in_B,
+                   low_Limit        => to_Radians (-180.0),
+                   high_Limit       => to_Radians ( 180.0),
+                   collide_Conected => False);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           pivot_Axis         : in     Vector_3)
+   is
+      Midpoint : constant Vector_3 := (Sprite_A.Site + Sprite_B.Site) / 2.0;
+   begin
+      Self.define (in_Space,
+                   Sprite_A,
+                   Sprite_B,
+                   pivot_Axis,
+                   pivot_anchor => Midpoint);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space              : in     std_physics.Space.view;
+                                           Sprite_A,  Sprite_B   : access gel.Sprite.item'Class;
+                                           Frame_A,   Frame_B    : in     Matrix_4x4;
+                                           low_Limit             : in     Real := to_Radians (-180.0);
+                                           high_Limit            : in     Real := to_Radians ( 180.0);
+                                           collide_Conected      : in     Boolean)
+   is
+      A_Frame : constant Matrix_4x4 := Frame_A;
+      B_Frame : constant Matrix_4x4 := Frame_B;
+
+      type Joint_cast is access all gel.Joint.item;
+
+      sprite_A_Solid,
+      sprite_B_Solid : std_physics.Object.view;
+
+   begin
+      if   Sprite_A = null
+        or Sprite_B = null
+      then
+         raise Error with "Sprite is null.";
+      end if;
+
+      sprite_A_Solid := std_physics.Object.view (Sprite_A.Solid);
+      sprite_B_Solid := std_physics.Object.view (Sprite_B.Solid);
+
+      joint.define (Joint_cast (Self),  Sprite_A, Sprite_B);   -- Define base class.
+
+      Self.Physics := in_Space.new_hinge_Joint (sprite_A_Solid,  sprite_B_Solid,
+                                                A_Frame,         B_Frame,
+                                                low_Limit,       high_Limit,
+                                                collide_Conected);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space  : in     std_physics.Space.view;
+                                           Sprite_A  : access gel.Sprite.item'Class;
+                                           Frame_A   : in     Matrix_4x4)
+   is
+      type Joint_cast is access all gel.Joint.item;
+
+      A_Frame        : constant Matrix_4x4 := Frame_A;
+      sprite_A_Solid : std_physics.Object.view;
+
+   begin
+      joint.define (Joint_cast (Self), Sprite_A, null);     -- Define base class.
+
+      sprite_A_Solid := std_physics.Object.view  (Sprite_A.Solid);
+      Self.Physics   := in_Space.new_hinge_Joint (sprite_A_Solid,
+                                                  A_Frame);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space         : in     std_physics.Space.view;
+                                           Sprite_A,
+                                           Sprite_B         : access gel.Sprite.item'Class;
+                                           pivot_Axis       : in     Vector_3;
+                                           Anchor_in_A,
+                                           Anchor_in_B      : in     Vector_3;
+                                           low_Limit,
+                                           high_Limit       : in     Real;
+                                           collide_Conected : in     Boolean)
+   is
+      type Joint_cast is access all gel.Joint.item;
+
+      sprite_A_Solid,
+      sprite_B_Solid : std_physics.Object.view;
+
+   begin
+      if   Sprite_A = null
+        or Sprite_B = null
+      then
+         raise Error with "Attempt to join a null sprite.";
+      end if;
+
+      sprite_A_Solid := std_physics.Object.view (Sprite_A.Solid);
+      sprite_B_Solid := std_physics.Object.view (Sprite_B.Solid);
+
+      Joint.define (Joint_cast (Self), Sprite_A, Sprite_B);     -- Define base class.
+
+      Self.Physics := in_Space.new_hinge_Joint  (sprite_A_Solid,  sprite_B_Solid,
+                                                 Anchor_in_A,     Anchor_in_B,
+                                                 pivot_Axis,
+                                                 low_Limit,       high_Limit,
+                                                 collide_Conected);
+   end define;
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+      my_Physics : std_physics.Joint.view := std_physics.Joint.view (Self.Physics);
+
+      procedure deallocate is new ada.unchecked_Deallocation (std_physics.Joint.item'Class,
+                                                              std_physics.Joint.view);
+   begin
+      my_Physics.destruct;
+      deallocate (my_Physics);
+
+      Self.Physics := null;
+   end destroy;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return joint.degree_of_Freedom
+   is
+      pragma unreferenced (Self);
+   begin
+      return 1;
+   end Degrees_of_freedom;
+
+
+
+   function Angle (Self : in Item'Class) return Real
+   is
+   begin
+      raise Error with "TODO";
+      return 0.0;
+   end Angle;
+
+
+   overriding
+   function Frame_A (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_A;
+   end Frame_A;
+
+
+   overriding
+   function Frame_B (Self : in Item) return Matrix_4x4
+   is
+   begin
+      return Self.Physics.Frame_B;
+   end Frame_B;
+
+
+   overriding
+   procedure Frame_A_is (Self : in out Item;   Now  : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_A_is (Now);
+   end Frame_A_is;
+
+
+   overriding
+   procedure Frame_B_is (Self : in out Item;   Now  : in Matrix_4x4)
+   is
+   begin
+      Self.Physics.Frame_B_is (Now);
+   end Frame_B_is;
+
+
+   overriding
+   function Physics (Self : in Item) return joint.Physics_view
+   is
+   begin
+      return Joint.Physics_view (Self.Physics);
+   end Physics;
+
+
+   ----------------
+   --- Joint Limits
+   --
+
+   procedure Limits_are (Self : in out Item'Class;   Low, High         : in Real;
+                                                     Softness          : in Real := 0.9;
+                                                     bias_Factor       : in Real := 0.3;
+                                                     relaxation_Factor : in Real := 1.0)
+   is
+   begin
+      Self.low_Bound         := Low;
+      Self.high_Bound        := High;
+      Self.Softness          := Softness;
+      Self.bias_Factor       := bias_Factor;
+      Self.relaxation_Factor := relaxation_Factor;
+   end Limits_are;
+
+
+
+   procedure apply_Limits (Self : in out Item)
+   is
+   begin
+      Self.Physics.Limits_are (Self.low_Bound,
+                               Self.high_Bound,
+                               Self.Softness,
+                               Self.bias_Factor,
+                               Self.relaxation_Factor);
+   end apply_Limits;
+
+
+   --  Bounds - limits the range of motion for a Degree of freedom.
+   --
+
+   overriding
+   function low_Bound (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real
+   is
+      use type joint.Degree_of_freedom;
+   begin
+      if for_Degree /= Revolve then
+         raise Error with "Invalid degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.low_Bound;
+   end low_Bound;
+
+
+   overriding
+   procedure low_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                 Now        : in Real)
+   is
+      use type joint.Degree_of_freedom;
+   begin
+      if for_Degree /= Revolve then
+         raise Error with "Invalid degree of freedom:" & for_Degree'Image;
+      end if;
+
+      Self.low_Bound := Now;
+      Self.apply_Limits;
+   end low_Bound_is;
+
+
+   overriding
+   function high_Bound (Self : access Item;  for_Degree : in joint.Degree_of_freedom) return Real
+   is
+      use type joint.Degree_of_freedom;
+   begin
+      if for_Degree /= Revolve then
+         raise Error with "Invalid degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.high_Bound;
+   end high_Bound;
+
+
+   overriding
+   procedure high_Bound_is (Self : access Item;  for_Degree : in joint.Degree_of_freedom;
+                                                 Now        : in Real)
+   is
+      use type joint.Degree_of_freedom;
+
+      Span : Real := abs (Now) * 2.0;
+   begin
+      if for_Degree /= Revolve then
+         raise Error with "Invalid degree of freedom:" & for_Degree'Image;
+      end if;
+
+      Self.high_Bound := Now;
+      Self.apply_Limits;
+   end high_Bound_is;
+
+
+   overriding
+   function Extent (Self : in Item;   for_Degree : in Degree_of_freedom) return Real
+   is
+      use type joint.Degree_of_freedom;
+   begin
+      if for_Degree /= Revolve then
+         raise Error with "Invalid degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.Angle;
+   end Extent;
+
+
+   overriding
+   function is_Bound (Self : in Item;   for_Degree : in joint.Degree_of_freedom) return Boolean
+   is
+   begin
+      return Self.Physics.is_Limited (for_Degree);
+   end is_Bound;
+
+
+   overriding
+   procedure Velocity_is (Self : in Item;   for_Degree : in joint.Degree_of_freedom;
+                                            Now        : in Real)
+   is
+   begin
+      self.Physics.Velocity_is (Now, for_Degree);
+   end Velocity_is;
+
+
+end gel.hinge_Joint;

4-high/gel/source/joint/gel-hinge_joint.ads

@@ -0,0 +1,143 @@
+with
+     gel.Joint,
+     gel.Sprite,
+
+     physics.Joint.hinge,
+     physics.Space;
+
+package gel.hinge_Joint
+--
+--  Allows sprites to be connected via a hinge joint.
+--
+is
+   type Item  is new gel.Joint.item with private;
+   type View  is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+
+   --  Degrees of freedom.
+   --
+   Revolve : constant joint.Degree_of_freedom := 1;
+
+
+   package std_physics renames standard.Physics;
+   use Math;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A,
+                                           Sprite_B           : access gel.Sprite.item'Class;
+                                           pivot_Axis         : in     Vector_3;
+                                           Anchor_in_A        : in     Vector_3;
+                                           Anchor_in_B        : in     Vector_3;
+                                           low_Limit,
+                                           high_Limit         : in     math.Real;
+                                           collide_Conected   : in     Boolean);
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           pivot_Axis         : in     Vector_3;
+                                           pivot_Anchor       : in     Vector_3);
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           pivot_Axis         : in     Vector_3);
+   --
+   --  Uses midpoint between sprite A and B for the pivot anchor.
+
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                           Frame_A,  Frame_B  : in     Matrix_4x4;
+                                           low_Limit          : in     Real := to_Radians (-180.0);
+                                           high_Limit         : in     Real := to_Radians ( 180.0);
+                                           collide_Conected   : in     Boolean);
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A           : access gel.Sprite.item'Class;
+                                           Frame_A            : in     Matrix_4x4);
+
+
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- Attributes
+   --
+
+   function  Angle      (Self : in     Item'Class) return Real;
+
+   overriding
+   function  Physics    (Self : in     Item) return Joint.Physics_view;
+
+   procedure Limits_are (Self : in out Item'Class;   Low, High         : in Real;
+                                                     Softness          : in Real := 0.9;
+                                                     bias_Factor       : in Real := 0.3;
+                                                     relaxation_Factor : in Real := 1.0);
+   overriding
+   function  Frame_A    (Self : in     Item) return Matrix_4x4;
+   overriding
+   function  Frame_B    (Self : in     Item) return Matrix_4x4;
+
+   overriding
+   procedure Frame_A_is (Self : in out Item;   Now  : in Matrix_4x4);
+   overriding
+   procedure Frame_B_is (Self : in out Item;   Now  : in Matrix_4x4);
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return joint.degree_of_Freedom;
+
+
+   --  Bounds - limits the range of motion for a degree of freedom.
+   --
+
+   overriding
+   function  low_Bound     (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+   overriding
+   procedure low_Bound_is  (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+   overriding
+   function  high_Bound    (Self : access Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+   overriding
+   function  is_Bound      (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Boolean;
+
+   overriding
+   function  Extent        (Self : in     Item;   for_Degree : in joint.Degree_of_freedom) return Real;
+
+   overriding
+   procedure Velocity_is   (Self : in     Item;   for_Degree : in joint.Degree_of_freedom;
+                                                  Now        : in Real);
+
+   --------------
+   --- Operations
+   --
+
+   -- Nil.
+
+
+
+private
+
+   type Item  is new gel.Joint.item with
+      record
+         Physics : access std_physics.Joint.hinge.item'Class;
+
+         low_Bound,
+         high_Bound        : Real;
+
+         Softness          : Real;
+         bias_Factor       : Real;
+         relaxation_Factor : Real;
+      end record;
+
+   procedure apply_Limits (Self : in out Item);
+
+end gel.hinge_Joint;

4-high/gel/source/joint/gel-joint.adb

@@ -0,0 +1,123 @@
+with
+     gel.Sprite,
+     gel.World,
+     ada.unchecked_Deallocation;
+
+package body gel.Joint
+is
+
+   function to_GEL (the_Joint : standard.physics.Joint.view) return gel.Joint.view
+   is
+   begin
+      return gel.Joint.view (the_Joint.user_Data);
+   end to_GEL;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define (Self : access Item;   Sprite_A, Sprite_B : access gel.Sprite.item'class)
+   is
+   begin
+      Self.Sprite_A := Sprite_A;
+      Self.Sprite_B := Sprite_B;
+   end define;
+
+
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Joint.item'Class, Joint.view);
+   begin
+      if Self /= null then
+         Self.destroy;
+      end if;
+
+      deallocate (Self);
+   end free;
+
+
+   --------------
+   --- Attributes
+   --
+
+   function Sprite_A (Self : in Item'Class) return access gel.Sprite.item'class
+   is
+   begin
+      return Self.Sprite_A;
+   end Sprite_A;
+
+
+
+   function Sprite_B (Self : in Item'Class) return access gel.Sprite.item'class
+   is
+   begin
+      return Self.Sprite_B;
+   end Sprite_B;
+
+
+   ----------
+   --- Hinges
+   --
+
+   function local_Anchor_on_A (Self : in Item) return Vector_3
+   is
+   begin
+      return Self.local_Anchor_on_A;
+   end local_Anchor_on_A;
+
+
+
+   function local_Anchor_on_B (Self : in Item) return Vector_3
+   is
+   begin
+      return Self.local_Anchor_on_B;
+   end local_Anchor_on_B;
+
+
+
+   procedure local_Anchor_on_A_is (Self : out Item;   Now : in Vector_3)
+   is
+   begin
+      Self.local_Anchor_on_A := Now;
+
+      if Self.Sprite_A.World /= null
+      then
+         Self.Sprite_A.World.set_local_Anchor_on_A (for_Joint => Self'unchecked_Access,
+                                                    To        => Now);
+      end if;
+   end local_Anchor_on_A_is;
+
+
+
+   procedure local_Anchor_on_B_is (Self : out Item;   Now : in Vector_3)
+   is
+   begin
+      Self.local_Anchor_on_B := Now;
+
+      if Self.Sprite_B.World /= null
+      then
+         Self.Sprite_B.World.set_local_Anchor_on_B (for_Joint => Self'unchecked_Access,
+                                                    To        => Now);
+      end if;
+   end local_Anchor_on_B_is;
+
+
+
+   function reaction_Force (Self : in Item'Class) return Vector_3
+   is
+   begin
+      return Self.Physics.reaction_Force;
+   end reaction_Force;
+
+
+
+   function reaction_Torque (Self : in Item'Class) return Real
+   is
+   begin
+      return Self.Physics.reaction_Torque;
+   end reaction_Torque;
+
+
+end gel.Joint;

4-high/gel/source/joint/gel-joint.ads

@@ -0,0 +1,124 @@
+with
+     physics.Joint,
+     lace.Any;
+
+limited
+with
+     gel.Sprite;
+
+package gel.Joint
+--
+--  Allows sprites to be connected via a joint.
+--  A joint constrains the motion of the sprites which it connects.
+--
+is
+   type Item  is abstract new lace.Any.limited_item with private;
+   type View  is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+   null_Joints : constant Joint.views;
+
+
+   function to_GEL (the_Joint : in physics.Joint.view) return gel.Joint.view;
+
+
+   subtype Degree_of_freedom is physics.Joint.Degree_of_freedom;
+
+   use Math;
+
+
+   ---------
+   --- Forge
+   --
+   procedure define  (Self : access Item;   Sprite_A, Sprite_B : access gel.Sprite.item'Class);
+
+   procedure destroy (Self : in out Item) is abstract;
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --- Attributes
+   --
+
+   function  Sprite_A   (Self : in     Item'Class) return access gel.Sprite.item'Class;
+   function  Sprite_B   (Self : in     Item'Class) return access gel.Sprite.item'Class;
+
+
+   function  Frame_A    (Self : in     Item) return Matrix_4x4 is abstract;
+   function  Frame_B    (Self : in     Item) return Matrix_4x4 is abstract;
+
+
+   procedure Frame_A_is (Self : in out Item;   Now  : in Matrix_4x4) is abstract;
+   procedure Frame_B_is (Self : in out Item;   Now  : in Matrix_4x4) is abstract;
+
+
+
+   function Degrees_of_freedom (Self : in Item) return degree_of_Freedom  is abstract;
+   --
+   --  Returns the number of possible DoF's for this joint.
+
+
+   type Physics_view is access all physics.Joint.item'Class;
+
+   function Physics (Self : in Item) return Physics_view is abstract;
+
+
+   --  Bounds - limits the range of motion for a Degree of freedom.
+   --
+
+   function  low_Bound     (Self : access Item;   for_Degree : in Degree_of_freedom) return Real is abstract;
+   procedure low_Bound_is  (Self : access Item;   for_Degree : in Degree_of_freedom;
+                                                  Now        : in Real)                          is abstract;
+   function  high_Bound    (Self : access Item;   for_Degree : in Degree_of_freedom) return Real is abstract;
+   procedure high_Bound_is (Self : access Item;   for_Degree : in Degree_of_freedom;
+                                                  Now        : in Real)                          is abstract;
+
+   function  is_Bound      (Self : in     Item;   for_Degree : in Degree_of_freedom) return Boolean is abstract;
+   --
+   --  Returns true if an upper or lower bound has been set for the given Degree of freedom.
+
+
+   function  Extent        (Self : in     Item;   for_Degree : in Degree_of_freedom) return Real is abstract;
+   --
+   --  Angle about axis for rotational joints or spatial distance along an axis, in the case of sliders, etc.
+
+   procedure Velocity_is   (Self : in     Item;   for_Degree : in Degree_of_freedom;
+                                                  Now        : in Real) is abstract;
+
+   function  reaction_Force  (Self : in   Item'Class) return Vector_3;
+   function  reaction_Torque (Self : in   Item'Class) return Real;
+
+
+   --------------
+   --- Operations
+   --
+
+   -- Nil.
+
+
+   ----------
+   --- Hinges
+   --
+
+   function  local_Anchor_on_A    (Self : in     Item)     return Vector_3;
+   function  local_Anchor_on_B    (Self : in     Item)     return Vector_3;
+
+   procedure local_Anchor_on_A_is (Self :    out Item;   Now : in Vector_3);
+   procedure local_Anchor_on_B_is (Self :    out Item;   Now : in Vector_3);
+
+
+
+private
+
+   type Item  is abstract new lace.Any.limited_item with
+      record
+         Sprite_A : access gel.Sprite.item'Class;
+         Sprite_B : access gel.Sprite.item'Class;
+
+         local_Anchor_on_A : Vector_3;
+         local_Anchor_on_B : Vector_3;
+      end record;
+
+   null_Joints : constant Joint.views (1 .. 0) := [others => null];
+
+end gel.Joint;

4-high/gel/source/joint/gel-slider_joint.adb

@@ -0,0 +1,203 @@
+with
+     physics.Object;
+
+package body gel.slider_Joint
+is
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.Item'Class;
+                                           Frame_A,  Frame_B  : in     Matrix_4x4)
+   is
+      A_Frame : constant Matrix_4x4 := Frame_A;
+      B_Frame : constant Matrix_4x4 := Frame_B;
+
+      type Joint_cast is access all gel.Joint.Item;
+
+      sprite_A_Solid,
+      sprite_B_Solid : std_physics.Object.view;
+
+   begin
+      if Sprite_A /= null then   sprite_A_Solid := std_physics.Object.view (Sprite_A.Solid);   end if;
+      if Sprite_B /= null then   sprite_B_Solid := std_physics.Object.view (Sprite_B.Solid);   end if;
+
+      Joint.define (Joint_cast (Self), Sprite_A, Sprite_B);   -- Define base class.
+
+      Self.Physics := in_Space.new_slider_Joint (sprite_A_Solid,
+                                                 sprite_B_Solid,
+                                                 A_Frame,
+                                                 B_Frame);
+   end define;
+
+
+
+   procedure define (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                           Sprite_A, Sprite_B : access gel.Sprite.Item'Class;
+                                           pivot_Anchor       : in     Vector_3;
+                                           pivot_Axis         : in     Matrix_3x3)
+   is
+      use linear_Algebra_3D;
+
+      pivot_in_A : constant Vector_3   := pivot_Anchor - Sprite_A.Site;
+      pivot_in_B : constant Vector_3   := pivot_Anchor - Sprite_B.Site;
+
+      Frame_A    : constant Matrix_4x4 := to_transform_Matrix (pivot_Axis, pivot_in_A);
+      Frame_B    : constant Matrix_4x4 := to_transform_Matrix (pivot_Axis, pivot_in_B);
+   begin
+      Self.define (in_Space,
+                   Sprite_A, Sprite_B,
+                   Frame_A,  Frame_B);
+   end define;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      raise Error with "TODO";
+   end destroy;
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function Frame_A (Self : in Item) return Matrix_4x4 is
+   begin
+      return Self.Physics.Frame_A;
+   end Frame_A;
+
+
+   overriding
+   function Frame_B (Self : in Item) return Matrix_4x4 is
+   begin
+      return Self.Physics.Frame_B;
+   end Frame_B;
+
+
+   overriding
+   procedure Frame_A_is (Self : in out Item; Now : in Matrix_4x4) is
+   begin
+      Self.Physics.Frame_A_is (Now);
+   end Frame_A_is;
+
+
+   overriding
+   procedure Frame_B_is (Self : in out Item; Now : in Matrix_4x4) is
+   begin
+      Self.Physics.Frame_B_is (Now);
+   end Frame_B_is;
+
+
+   overriding
+   function Physics (Self : in Item) return gel.Joint.Physics_view is
+   begin
+      return GEL.Joint.Physics_view (Self.Physics);
+   end Physics;
+
+
+   overriding
+   function Degrees_of_freedom (Self : in Item) return Joint.Degree_of_freedom
+   is
+      pragma unreferenced (Self);
+   begin
+      return 6;     -- TODO: Fix this and all similar.
+   end Degrees_of_freedom;
+
+
+   --  Bounds - limits the range of motion for a Degree of freedom.
+   --
+
+   overriding
+   function is_Bound (Self : in Item;   for_Degree : in Joint.Degree_of_freedom) return Boolean
+   is
+   begin
+      if for_Degree in Sway .. Surge
+      then
+         return False;
+      end if;
+
+      return Self.Physics.is_Limited (for_Degree);
+   end is_Bound;
+
+
+   overriding
+   function low_Bound (Self : access Item;   for_Degree : in Joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.lower_Limit (for_Degree);
+      end case;
+   end low_Bound;
+
+
+   overriding
+   procedure low_Bound_is (Self : access Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                 Now        : in Real)
+   is
+   begin
+      Self.Physics.lower_Limit_is (Now, for_Degree);
+   end low_Bound_is;
+
+
+   overriding
+   function high_Bound (Self : access Item;   for_Degree : in Joint.Degree_of_freedom) return Real
+   is
+   begin
+      case for_Degree
+      is
+         when Sway .. Surge =>
+            raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+
+         when Pitch .. Roll =>
+            return Self.Physics.upper_Limit (for_Degree);
+      end case;
+   end high_Bound;
+
+
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                  Now        : in Real)
+   is
+   begin
+      Self.Physics.upper_Limit_is (Now, for_Degree);
+   end high_Bound_is;
+
+
+   ----------
+   --- Extent
+   --
+
+   overriding
+   function Extent (Self : in Item;   for_Degree : in Joint.Degree_of_freedom) return Real
+   is
+   begin
+      if for_Degree in Sway .. Surge
+      then
+         raise Error with "Unhandled degree of freedom:" & for_Degree'Image;
+      end if;
+
+      return Self.Physics.Extent (for_Degree);
+   end Extent;
+
+
+   ------------------
+   --- Motor Velocity
+   --
+
+   overriding
+   procedure Velocity_is (Self : in Item;   for_Degree : in Joint.Degree_of_freedom;
+                                            Now        : in Real)
+   is
+   begin
+      Self.Physics.Velocity_is (Now, for_Degree);
+   end Velocity_is;
+
+
+end gel.slider_Joint;

4-high/gel/source/joint/gel-slider_joint.ads

@@ -0,0 +1,108 @@
+with
+     gel.Joint,
+     gel.Sprite,
+
+     physics.Joint.slider,
+     physics.Space;
+
+package gel.slider_Joint
+--
+--  Allows sprites to be connected via a slider joint.
+--
+is
+   type Item is new gel.Joint.Item with private;
+   type View is access all Item'Class;
+   type Views is array (math.Index range <>) of View;
+
+
+   Sway  : constant Joint.Degree_of_freedom := 1;     -- TODO: These are duplicated.
+   Heave : constant Joint.Degree_of_freedom := 2;
+   Surge : constant Joint.Degree_of_freedom := 3;
+
+   Pitch : constant Joint.Degree_of_freedom := 4;
+   Yaw   : constant Joint.Degree_of_freedom := 5;
+   Roll  : constant Joint.Degree_of_freedom := 6;
+
+
+   package std_physics renames standard.Physics;
+   use Math;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define  (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                            Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                            pivot_Anchor       : in     Vector_3;
+                                            pivot_Axis         : in     Matrix_3x3);
+
+   procedure define  (Self : access Item;   in_Space           : in     std_physics.Space.view;
+                                            Sprite_A, Sprite_B : access gel.Sprite.item'Class;
+                                            Frame_A,  Frame_B  : in     Matrix_4x4);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   --------------
+   --- Attributes
+   --
+
+   overriding
+   function  Physics    (Self : in     Item) return gel.Joint.Physics_view;
+
+   overriding
+   function  Frame_A    (Self : in     Item) return Matrix_4x4;
+   overriding
+   function  Frame_B    (Self : in     Item) return Matrix_4x4;
+
+   overriding
+   procedure Frame_A_is (Self : in out Item; Now : in Matrix_4x4);
+   overriding
+   procedure Frame_B_is (Self : in out Item; Now : in Matrix_4x4);
+
+   overriding
+   function  Degrees_of_freedom (Self : in Item) return Joint.Degree_of_freedom;
+
+
+   --  Bounds - limits the range of motion for a Degree of freedom.
+   --
+
+   overriding
+   function  is_Bound      (Self : in     Item;   for_Degree : in Joint.Degree_of_freedom) return Boolean;
+
+   overriding
+   function  low_Bound     (Self : access Item;   for_Degree : in Joint.Degree_of_freedom) return Real;
+   overriding
+   procedure low_Bound_is  (Self : access Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                  Now        : in Real);
+   overriding
+   function  high_Bound    (Self : access Item;   for_Degree : in Joint.Degree_of_freedom) return Real;
+   overriding
+   procedure high_Bound_is (Self : access Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                  Now        : in Real);
+   overriding
+   function  Extent        (Self : in     Item;   for_Degree : in Joint.Degree_of_freedom) return Real;
+   overriding
+   procedure Velocity_is   (Self : in     Item;   for_Degree : in Joint.Degree_of_freedom;
+                                                  Now        : in Real);
+
+   --------------
+   --- Operations
+   --
+
+   -- Nil.
+
+
+
+private
+
+   type physics_slider_Joint_view is access all std_physics.Joint.slider.item'Class;
+
+
+   type Item is new gel.Joint.Item with
+      record
+         Physics : access std_physics.Joint.slider.item'Class;
+   end record;
+
+end gel.slider_Joint;

4-high/gel/source/platform/sdl/gel-window-sdl.adb

@@ -0,0 +1,478 @@
+with
+     SDL.Events.Windows,
+     SDL.Events.Keyboards,
+     SDL.Events.Events,
+     SDL.Events.Mice,
+     SDL.Video.Windows.Makers,
+     SDL.Log,
+
+     ada.Text_IO;
+
+
+package body gel.Window.sdl
+is
+   package std_SDL renames standard.SDL;
+
+   use std_SDL,
+       std_SDL.Events;
+
+   function to_gel_Key (From : in std_SDL.Events.Keyboards.Key_Codes) return gel.keyboard.Key;
+
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define  (Self : in View;   Title  : in String;
+                                        Width  : in Natural;
+                                        Height : in Natural)
+   is
+      use type Video.Windows.Window_Flags;
+   begin
+      if not std_SDL.initialise
+      then
+         raise gel.Error with "Unable to initialise SDL.";
+      end if;
+
+      Video.Windows.Makers.create (Win    => Self.window_Handle,
+                                   Title  => Title,
+                                   X      => 100,
+                                   Y      => 100,
+                                   Width  => C.int (Width),
+                                   Height => C.int (Height),
+                                   Flags  =>    Video.Windows.openGL
+                                             or Video.Windows.Resizable);
+
+      Video.GL.create (Self.GL_Context, From => Self.window_Handle);
+   end define;
+
+
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      Self.window_Handle.finalize;
+      std_SDL.finalise;
+
+      destroy (gel.Window.item (Self));     -- Destroy base class.
+   end destroy;
+
+
+
+   package body Forge
+   is
+      function to_Window (Title  : in String;
+                          Width  : in Natural;
+                          Height : in Natural) return gel.Window.sdl.item
+      is
+      begin
+         return Self : gel.Window.sdl.item := (gel.Window.private_Forge.to_Window (Title, Width, Height)
+                                               with others => <>)
+         do
+            define (Self'unchecked_Access, Title, Width, Height);
+         end return;
+      end to_Window;
+
+
+      function new_Window (Title  : in String;
+                           Width  : in Natural;
+                           Height : in Natural) return Window.sdl.view
+      is
+         Self : constant gel.Window.sdl.view := new Window.sdl.item' (to_Window (Title, Width, Height));
+      begin
+         return Self;
+      end new_Window;
+   end Forge;
+
+
+
+   --------------
+   --- Operations
+   --
+
+   use gel.Keyboard;
+
+
+   overriding
+   procedure emit_Events (Self : in out Item)
+   is
+      use type std_SDL.Events.Keyboards.Key_Codes;
+
+      Event : aliased std_SDL.Events.Events.Events;
+
+   begin
+      while std_SDL.Events.Events.Poll (Event)
+      loop
+         case Event.Common.Event_Type
+         is
+            when std_SDL.Events.Quit =>
+               Self.is_Open := False;
+
+            when std_SDL.Events.Keyboards.Key_Down =>
+               Self.Keyboard.emit_key_press_Event (Key      => to_gel_Key (Event.keyboard.key_Sym.key_Code),
+                                                   key_Code => Integer    (Event.keyboard.key_Sym.key_Code));
+
+            when std_SDL.Events.Keyboards.Key_Up =>
+               std_SDL.Log.put_Debug ("Key up event: " & Event.keyboard.key_Sym. key_Code'Image &
+                                      "   Scan code: " & Event.keyboard.key_Sym.scan_Code'Image);
+
+               if Event.keyboard.key_Sym.key_Code = std_SDL.Events.Keyboards.Code_escape     -- TODO: Make this user-configurable.
+               then
+                  Self.is_Open := False;
+               end if;
+
+               Self.Keyboard.emit_key_release_Event (Key => to_gel_Key (Event.keyboard.key_Sym.key_Code));
+
+            when std_SDL.Events.Mice.Button_Down =>
+               Self.Mouse.emit_button_press_Event (Button    => gel.mouse.button_Id (std_SDL.Events.Mice.Buttons'Pos (Event.mouse_Button.Button) + 1),
+                                                   Modifiers => Self.Keyboard.Modifiers,
+                                                   Site      => [Integer (Event.mouse_Button.X),
+                                                                 Integer (Event.mouse_Button.Y)]);
+
+            when std_SDL.Events.Mice.Button_Up =>
+               Self.Mouse.emit_button_release_Event (Button    => gel.mouse.button_Id (std_SDL.Events.Mice.Buttons'Pos (Event.Mouse_Button.Button) + 1),
+                                                     Modifiers => Self.Keyboard.Modifiers,
+                                                     Site      => [Integer (Event.mouse_Button.X),
+                                                                   Integer (Event.mouse_Button.Y)]);
+
+            when std_SDL.Events.Mice.Motion =>
+               Self.Mouse.emit_motion_Event (Site => [Integer (Event.Mouse_Motion.x),
+                                                      Integer (Event.Mouse_Motion.y)]);
+
+
+            when std_SDL.Events.Mice.Wheel =>     -- TODO
+               null;
+
+
+            when std_SDL.Events.Windows.Window =>
+               declare
+                  use std_SDL.Events.Windows;
+               begin
+                  if Event.Window.Event_ID = Windows.Resized
+                  then
+                     Self.Size_is (Integer (Event.Window.Data_1),
+                                   Integer (Event.Window.Data_2));
+                  end if;
+               end;
+
+            when others =>     -- TODO
+               null;
+         end case;
+      end loop;
+
+--        SDL_GL_SwapBuffers;
+   end emit_Events;
+
+
+
+   overriding
+   procedure enable_GL (Self : in Item)
+   is
+   begin
+      std_SDL.Video.gl.set_Current (Self.GL_Context, To => Self.window_Handle);
+   end enable_GL;
+
+
+
+   overriding
+   procedure disable_GL (Self : in Item)
+   is
+      null_Context : standard.SDL.Video.GL.Contexts;
+   begin
+      std_SDL.Video.gl.set_Current (null_Context, To => Self.window_Handle);
+   end disable_GL;
+
+
+
+   overriding
+   procedure swap_GL (Self : in out Item)
+   is
+      use std_SDL.Video.GL;
+   begin
+      swap (Self.window_Handle);
+   end swap_GL;
+
+
+
+   function to_gel_Key (From : in std_SDL.Events.Keyboards.key_Codes) return gel.keyboard.Key
+   is
+      package Key renames std_SDL.Events.keyboards;
+   begin
+      case From
+      is
+         when Key.Code_return            => return gel.Keyboard.Enter;
+         when Key.Code_escape            => return gel.Keyboard.Escape;
+         when Key.Code_backspace         => return gel.Keyboard.BackSpace;
+         when Key.Code_tab               => return gel.Keyboard.Tab;
+         when Key.Code_space             => return gel.Keyboard.Space;
+         when Key.Code_exclamation       => return gel.Keyboard.Exclaim;
+         when Key.Code_double_quote      => return gel.Keyboard.QuoteDbl;
+         when Key.Code_hash              => return gel.Keyboard.Hash;
+         when Key.Code_percent           => return gel.Keyboard.Percent;
+         when Key.Code_dollar            => return gel.Keyboard.Dollar;
+         when Key.Code_ampersand         => return gel.Keyboard.Ampersand;
+         when Key.Code_quote             => return gel.Keyboard.Quote;
+         when Key.Code_left_parenthesis  => return gel.Keyboard.leftParen;
+         when Key.Code_right_parenthesis => return gel.Keyboard.rightParen;
+         when Key.Code_asterisk          => return gel.Keyboard.Asterisk;
+         when Key.Code_plus              => return gel.Keyboard.Plus;
+         when Key.Code_comma             => return gel.Keyboard.Comma;
+         when Key.Code_minus             => return gel.Keyboard.Minus;
+         when Key.Code_period            => return gel.Keyboard.Period;
+         when Key.Code_slash             => return gel.Keyboard.Slash;
+
+         when Key.Code_0 => return gel.Keyboard.'0';
+         when Key.Code_1 => return gel.Keyboard.'1';
+         when Key.Code_2 => return gel.Keyboard.'2';
+         when Key.Code_3 => return gel.Keyboard.'3';
+         when Key.Code_4 => return gel.Keyboard.'4';
+         when Key.Code_5 => return gel.Keyboard.'5';
+         when Key.Code_6 => return gel.Keyboard.'6';
+         when Key.Code_7 => return gel.Keyboard.'7';
+         when Key.Code_8 => return gel.Keyboard.'8';
+         when Key.Code_9 => return gel.Keyboard.'9';
+
+         when Key.Code_colon      => return gel.Keyboard.Colon;
+         when Key.Code_semi_colon => return gel.Keyboard.semiColon;
+         when Key.Code_less       => return gel.Keyboard.Less;
+         when Key.Code_equals     => return gel.Keyboard.Equals;
+         when Key.Code_greater    => return gel.Keyboard.Greater;
+         when Key.Code_question   => return gel.Keyboard.Question;
+         when Key.Code_at         => return gel.Keyboard.At_key;
+
+         when Key.Code_left_bracket  => return gel.Keyboard.leftBracket;
+         when Key.Code_back_slash    => return gel.Keyboard.backSlash;
+         when Key.Code_right_bracket => return gel.Keyboard.rightBracket;
+         when Key.Code_caret         => return gel.Keyboard.Caret;
+         when Key.Code_underscore    => return gel.Keyboard.Underscore;
+         when Key.Code_back_quote    => return gel.Keyboard.backQuote;
+
+         when Key.Code_a => return gel.Keyboard.A;
+         when Key.Code_b => return gel.Keyboard.B;
+         when Key.Code_c => return gel.Keyboard.C;
+         when Key.Code_d => return gel.Keyboard.D;
+         when Key.Code_e => return gel.Keyboard.E;
+         when Key.Code_f => return gel.Keyboard.F;
+         when Key.Code_g => return gel.Keyboard.G;
+         when Key.Code_h => return gel.Keyboard.H;
+         when Key.Code_i => return gel.Keyboard.I;
+         when Key.Code_j => return gel.Keyboard.J;
+         when Key.Code_k => return gel.Keyboard.K;
+         when Key.Code_l => return gel.Keyboard.L;
+         when Key.Code_m => return gel.Keyboard.M;
+         when Key.Code_n => return gel.Keyboard.N;
+         when Key.Code_o => return gel.Keyboard.O;
+         when Key.Code_p => return gel.Keyboard.P;
+         when Key.Code_q => return gel.Keyboard.Q;
+         when Key.Code_r => return gel.Keyboard.R;
+         when Key.Code_s => return gel.Keyboard.S;
+         when Key.Code_t => return gel.Keyboard.T;
+         when Key.Code_u => return gel.Keyboard.U;
+         when Key.Code_v => return gel.Keyboard.V;
+         when Key.Code_w => return gel.Keyboard.W;
+         when Key.Code_x => return gel.Keyboard.X;
+         when Key.Code_y => return gel.Keyboard.Y;
+         when Key.Code_z => return gel.Keyboard.Z;
+
+         when Key.Code_caps_lock => return gel.Keyboard.CapsLock;
+
+         when Key.Code_F1  => return gel.Keyboard.F1;
+         when Key.Code_F2  => return gel.Keyboard.F2;
+         when Key.Code_F3  => return gel.Keyboard.F3;
+         when Key.Code_F4  => return gel.Keyboard.F4;
+         when Key.Code_F5  => return gel.Keyboard.F5;
+         when Key.Code_F6  => return gel.Keyboard.F6;
+         when Key.Code_F7  => return gel.Keyboard.F7;
+         when Key.Code_F8  => return gel.Keyboard.F8;
+         when Key.Code_F9  => return gel.Keyboard.F9;
+         when Key.Code_F10 => return gel.Keyboard.F10;
+         when Key.Code_F11 => return gel.Keyboard.F11;
+         when Key.Code_F12 => return gel.Keyboard.F12;
+
+         when Key.Code_print_screen => return gel.Keyboard.Print;
+         when Key.Code_scroll_lock  => return gel.Keyboard.ScrollLock;
+         when Key.Code_pause        => return gel.Keyboard.Pause;
+         when Key.Code_insert       => return gel.Keyboard.Insert;
+         when Key.Code_home         => return gel.Keyboard.Home;
+         when Key.Code_page_up      => return gel.Keyboard.PageUp;
+         when Key.Code_delete       => return gel.Keyboard.Delete;
+         when Key.Code_end          => return gel.Keyboard.End_key;
+         when Key.Code_page_down    => return gel.Keyboard.PageDown;
+         when Key.Code_right        => return gel.Keyboard.Right;
+         when Key.Code_left         => return gel.Keyboard.Left;
+         when Key.Code_down         => return gel.Keyboard.Down;
+         when Key.Code_up           => return gel.Keyboard.Up;
+
+         when Key.Code_num_lock_clear => return gel.Keyboard.NumLock;
+
+         when Key.Code_KP_divide   => return gel.Keyboard.KP_Divide;
+         when Key.Code_KP_multiply => return gel.Keyboard.KP_Multiply;
+         when Key.Code_KP_minus    => return gel.Keyboard.KP_Minus;
+         when Key.Code_KP_plus     => return gel.Keyboard.KP_Plus;
+         when Key.Code_KP_enter    => return gel.Keyboard.KP_Enter;
+         when Key.Code_KP_1        => return gel.Keyboard.KP1;
+         when Key.Code_KP_2        => return gel.Keyboard.KP2;
+         when Key.Code_KP_3        => return gel.Keyboard.KP3;
+         when Key.Code_KP_4        => return gel.Keyboard.KP4;
+         when Key.Code_KP_5        => return gel.Keyboard.KP5;
+         when Key.Code_KP_6        => return gel.Keyboard.KP6;
+         when Key.Code_KP_7        => return gel.Keyboard.KP7;
+         when Key.Code_KP_8        => return gel.Keyboard.KP8;
+         when Key.Code_KP_9        => return gel.Keyboard.KP9;
+         when Key.Code_KP_0        => return gel.Keyboard.KP0;
+         when Key.Code_KP_period   => return gel.Keyboard.KP_Period;
+
+         --  when Key.Code_application     => return gel.Keyboard.;
+         when Key.Code_power           => return gel.Keyboard.Power;
+         when Key.Code_KP_equals       => return gel.Keyboard.KP_Equals;
+         when Key.Code_F13             => return gel.Keyboard.F13;
+         when Key.Code_F14             => return gel.Keyboard.F14;
+         when Key.Code_F15             => return gel.Keyboard.F15;
+         --  when Key.Code_F16             => return gel.Keyboard.;
+         --  when Key.Code_F17             => return gel.Keyboard.;
+         --  when Key.Code_F18             => return gel.Keyboard.;
+         --  when Key.Code_F19             => return gel.Keyboard.;
+         --  when Key.Code_F20             => return gel.Keyboard.;
+         --  when Key.Code_F21             => return gel.Keyboard.;
+         --  when Key.Code_F22             => return gel.Keyboard.;
+         --  when Key.Code_F23             => return gel.Keyboard.;
+         --  when Key.Code_F24             => return gel.Keyboard.;
+         --  when Key.Code_execute         => return gel.Keyboard.;
+         when Key.Code_help            => return gel.Keyboard.Help;
+         when Key.Code_menu            => return gel.Keyboard.Menu;
+         --  when Key.Code_select          => return gel.Keyboard.;
+         --  when Key.Code_stop            => return gel.Keyboard.;
+         --  when Key.Code_again           => return gel.Keyboard.;
+         when Key.Code_undo            => return gel.Keyboard.Undo;
+         --  when Key.Code_cut             => return gel.Keyboard.;
+         --  when Key.Code_copy            => return gel.Keyboard.;
+         --  when Key.Code_paste           => return gel.Keyboard.;
+         --  when Key.Code_find            => return gel.Keyboard.;
+         --  when Key.Code_mute            => return gel.Keyboard.;
+         --  when Key.Code_volume_up       => return gel.Keyboard.;
+         --  when Key.Code_volume_down     => return gel.Keyboard.;
+         --  when Key.Code_KP_comma        => return gel.Keyboard.;
+         --  when Key.Code_KP_equals_AS400 => return gel.Keyboard.;
+
+         --  when Key.Code_alt_erase   => return gel.Keyboard.;
+         when Key.Code_sys_req     => return gel.Keyboard.SysReq;
+         --  when Key.Code_cancel      => return gel.Keyboard.;
+         when Key.Code_clear       => return gel.Keyboard.Clear;
+         --  when Key.Code_prior       => return gel.Keyboard.;
+         --  when Key.Code_return_2    => return gel.Keyboard.;
+         --  when Key.Code_separator   => return gel.Keyboard.;
+         --  when Key.Code_out         => return gel.Keyboard.;
+         --  when Key.Code_oper        => return gel.Keyboard.;
+         --  when Key.Code_clear_again => return gel.Keyboard.;
+         --  when Key.Code_CR_sel      => return gel.Keyboard.;
+         --  when Key.Code_Ex_sel      => return gel.Keyboard.;
+
+         --  when Key.Code_KP_00                  => return gel.Keyboard.;
+         --  when Key.Code_KP_000                 => return gel.Keyboard.;
+         --  when Key.Code_thousands_separator    => return gel.Keyboard.;
+         --  when Key.Code_decimal_separator      => return gel.Keyboard.;
+         --  when Key.Code_currency_unit          => return gel.Keyboard.;
+         --  when Key.Code_KP_left_parenthesis    => return gel.Keyboard.;
+         --  when Key.Code_KP_right_parentheesis  => return gel.Keyboard.;
+         --  when Key.Code_KP_left_brace          => return gel.Keyboard.;
+         --  when Key.Code_KP_right_brace         => return gel.Keyboard.;
+         --  when Key.Code_KP_tab                 => return gel.Keyboard.;
+         --  when Key.Code_KP_backspace           => return gel.Keyboard.;
+         --  when Key.Code_KP_A                   => return gel.Keyboard.;
+         --  when Key.Code_KP_B                   => return gel.Keyboard.;
+         --  when Key.Code_KP_C                   => return gel.Keyboard.;
+         --  when Key.Code_KP_D                   => return gel.Keyboard.;
+         --  when Key.Code_KP_E                   => return gel.Keyboard.;
+         --  when Key.Code_KP_F                   => return gel.Keyboard.;
+         --  when Key.Code_KP_xor                 => return gel.Keyboard.;
+         --  when Key.Code_KP_power               => return gel.Keyboard.;
+         --  when Key.Code_KP_percent             => return gel.Keyboard.;
+         --  when Key.Code_KP_less                => return gel.Keyboard.;
+         --  when Key.Code_KP_greater             => return gel.Keyboard.;
+         --  when Key.Code_KP_ampersand           => return gel.Keyboard.;
+         --  when Key.Code_KP_double_ampersand    => return gel.Keyboard.;
+         --  when Key.Code_KP_vertical_bar        => return gel.Keyboard.;
+         --  when Key.Code_KP_double_vertical_bar => return gel.Keyboard.;
+         --  when Key.Code_KP_colon               => return gel.Keyboard.;
+         --  when Key.Code_KP_hash                => return gel.Keyboard.;
+         --  when Key.Code_KP_space               => return gel.Keyboard.;
+         --  when Key.Code_KP_at                  => return gel.Keyboard.;
+         --  when Key.Code_KP_exclamation         => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_store        => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_recall       => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_clear        => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_add          => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_subtract     => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_multiply     => return gel.Keyboard.;
+         --  when Key.Code_KP_memory_divide       => return gel.Keyboard.;
+         --  when Key.Code_KP_plus_minus          => return gel.Keyboard.;
+         --  when Key.Code_KP_clear               => return gel.Keyboard.;
+         --  when Key.Code_KP_clear_entry         => return gel.Keyboard.;
+         --  when Key.Code_KP_binary              => return gel.Keyboard.;
+         --  when Key.Code_KP_octal               => return gel.Keyboard.;
+         --  when Key.Code_KP_decimal             => return gel.Keyboard.;
+         --  when Key.Code_KP_hexadecimal         => return gel.Keyboard.;
+
+         when Key.Code_left_control  => return gel.Keyboard.lCtrl;
+         when Key.Code_left_shift    => return gel.Keyboard.lShift;
+         when Key.Code_left_alt      => return gel.Keyboard.lAlt;
+         --  when Key.Code_left_gui      => return gel.Keyboard.;
+         when Key.Code_right_control => return gel.Keyboard.rCtrl;
+         when Key.Code_right_shift   => return gel.Keyboard.rShift;
+         when Key.Code_right_alt     => return gel.Keyboard.rAlt;
+         --  when Key.Code_right_gui     => return gel.Keyboard.;
+         --  when Key.Code_mode          => return gel.Keyboard.;
+
+         --  when Key.Code_audio_next     => return gel.Keyboard.;
+         --  when Key.Code_audio_previous => return gel.Keyboard.;
+         --  when Key.Code_audio_stop     => return gel.Keyboard.;
+         --  when Key.Code_audio_play     => return gel.Keyboard.;
+         --  when Key.Code_audio_mute     => return gel.Keyboard.;
+         --  when Key.Code_media_select   => return gel.Keyboard.;
+         --  when Key.Code_www            => return gel.Keyboard.;
+         --  when Key.Code_mail           => return gel.Keyboard.;
+         --  when Key.Code_calculator     => return gel.Keyboard.;
+         --  when Key.Code_computer       => return gel.Keyboard.;
+         --  when Key.Code_AC_search      => return gel.Keyboard.;
+         --  when Key.Code_AC_home        => return gel.Keyboard.;
+         --  when Key.Code_AC_back        => return gel.Keyboard.;
+         --  when Key.Code_AC_forward     => return gel.Keyboard.;
+         --  when Key.Code_AC_stop        => return gel.Keyboard.;
+         --  when Key.Code_AC_refresh     => return gel.Keyboard.;
+         --  when Key.Code_AC_bookmarks   => return gel.Keyboard.;
+
+         --  when Key.Code_brightness_down     => return gel.Keyboard.;
+         --  when Key.Code_brightness_up       => return gel.Keyboard.;
+         --  when Key.Code_display_switch      => return gel.Keyboard.;
+         --  when Key.Code_illumination_toggle => return gel.Keyboard.;
+         --  when Key.Code_illumination_down   => return gel.Keyboard.;
+         --  when Key.Code_illumination_up     => return gel.Keyboard.;
+         --  when Key.Code_eject               => return gel.Keyboard.;
+         --  when Key.Code_sleep               => return gel.Keyboard.;
+
+         when others =>
+            ada.Text_IO.put_Line ("SDL window unhandled key: " & From'Image);     -- TODO: Remaining key codes.
+      end case;
+
+      return gel.Keyboard.Key'First;
+   end to_gel_Key;
+
+
+   -------------------
+   --- Window Creator
+   --
+
+   function window_Creator (Name : in String;
+                            Width,
+                            Height : in Positive) return gel.Window.view
+   is
+   begin
+      return gel.Window.view (Forge.new_Window (Name, Width, Height));
+   end window_Creator;
+
+
+begin
+   gel.Window.use_create_Window (window_Creator'Access);
+end gel.Window.sdl;

4-high/gel/source/platform/sdl/gel-window-sdl.ads

@@ -0,0 +1,57 @@
+private
+with
+     sdl.Video.Windows,
+     sdl.Video.GL;
+
+package gel.Window.sdl
+--
+-- Provides an SDL implementation of a window.
+--
+is
+   type Item is new gel.Window.item with private;
+   type View is access all Item'Class;
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure define  (Self : in     View;   Title  : in String;
+                                            Width  : in Natural;
+                                            Height : in Natural);
+   overriding
+   procedure destroy (Self : in out Item);
+
+
+   package Forge
+   is
+      function new_Window (Title  : in String;
+                           Width  : in Natural;
+                           Height : in Natural) return Window.sdl.view;
+   end Forge;
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure emit_Events (Self : in out Item);
+   overriding
+   procedure enable_GL   (Self : in     Item);
+   overriding
+   procedure disable_GL  (Self : in     Item);
+   overriding
+   procedure swap_GL     (Self : in out Item);
+
+
+
+private
+
+   type Item is new gel.Window.item with
+      record
+         window_Handle : standard.sdl.Video.Windows.Window;
+         GL_Context    : standard.sdl.Video.GL.Contexts;
+      end record;
+
+end gel.Window.sdl;

4-high/gel/source/platform/sdl/gel-window-setup.ads

@@ -0,0 +1,6 @@
+with
+     gel.Window.sdl;
+
+package gel.Window.setup
+   renames gel.Window.sdl;
+

4-high/gel/source/remote/gel-remote-world.adb

@@ -0,0 +1,201 @@
+package body gel.remote.World
+is
+
+   function refined (Self : in coarse_Vector_3) return math.Vector_3
+   is
+   begin
+      return [math.Real (Self (1)),
+              math.Real (Self (2)),
+              math.Real (Self (3))];
+   end refined;
+
+
+
+   function coarsen (Self : in math.Vector_3) return coarse_Vector_3
+   is
+      Result : coarse_Vector_3;
+   begin
+      begin
+         Result (1) := coarse_Real (Self (1));
+      exception
+         when constraint_Error =>
+            if Self (1) > 0.0 then
+               Result (1) := coarse_Real'Last;
+            else
+               Result (1) := coarse_Real'First;
+            end if;
+      end;
+
+      begin
+         Result (2) := coarse_Real (Self (2));
+      exception
+         when constraint_Error =>
+            if Self (2) > 0.0 then
+               Result (2) := coarse_Real'Last;
+            else
+               Result (2) := coarse_Real'First;
+            end if;
+      end;
+
+      begin
+         Result (3) := coarse_Real (Self (3));
+      exception
+         when constraint_Error =>
+            if Self (3) > 0.0 then
+               Result (3) := coarse_Real'Last;
+            else
+               Result (3) := coarse_Real'First;
+            end if;
+      end;
+
+      return Result;
+   end coarsen;
+
+
+
+   function refined (Self : in coarse_Quaternion) return math.Quaternion
+   is
+   begin
+      return (R =>  math.Real (Self (1)),
+              V => [math.Real (Self (2)),
+                    math.Real (Self (3)),
+                    math.Real (Self (4))]);
+   end refined;
+
+
+
+   function coarsen (Self : in math.Quaternion) return coarse_Quaternion
+   is
+      Result : coarse_Quaternion;
+   begin
+      begin
+         Result (1) := coarse_Real2 (Self.R);
+      exception
+         when constraint_Error =>
+            if Self.R > 0.0 then
+               Result (1) := coarse_Real2'Last;
+            else
+               Result (1) := coarse_Real2'First;
+            end if;
+      end;
+
+      begin
+         Result (2) := coarse_Real2 (Self.V (1));
+      exception
+         when constraint_Error =>
+            if Self.V (1) > 0.0 then
+               Result (2) := coarse_Real2'Last;
+            else
+               Result (2) := coarse_Real2'First;
+            end if;
+      end;
+
+      begin
+         Result (3) := coarse_Real2 (Self.V (2));
+      exception
+         when constraint_Error =>
+            if Self.V (2) > 0.0 then
+               Result (3) := coarse_Real2'Last;
+            else
+               Result (3) := coarse_Real2'First;
+            end if;
+      end;
+
+      begin
+         Result (4) := coarse_Real2 (Self.V (3));
+      exception
+         when Constraint_Error =>
+            if Self.V (3) > 0.0 then
+               Result (4) := coarse_Real2'Last;
+            else
+               Result (4) := coarse_Real2'First;
+            end if;
+      end;
+
+      return Result;
+   end coarsen;
+
+
+   -----------
+   --- Streams
+   --
+
+   use ada.Streams;
+
+   number_of_stream_Elements_for_a_motion_Update : constant Stream_Element_Offset
+     := motion_Update'Size / Stream_Element'Size;
+
+
+   procedure motion_Updates_write (Stream : access ada.Streams.Root_Stream_type'Class;   Item : in  motion_Updates)
+   is
+      stream_element_array_Length : constant Stream_Element_Offset
+        := Item'Length * number_of_stream_Elements_for_a_Motion_Update;
+
+      subtype the_Stream_Element_Array  is Stream_Element_Array (1 .. stream_element_array_Length);
+
+      function to_Stream_Element_Array is new ada.unchecked_Conversion (motion_Updates, the_Stream_Element_Array);
+
+   begin
+      write (Stream.all, to_Stream_Element_Array (Item));
+   end motion_Updates_write;
+
+
+
+   procedure motion_Updates_read (Stream : access ada.Streams.Root_Stream_type'Class;    Item : out motion_Updates)
+   is
+      subtype the_Stream_Element_Array
+        is Stream_Element_Array (1 .. Item'Length * number_of_stream_Elements_for_a_motion_Update);
+
+      subtype the_motion_Updates is motion_Updates (1 .. Item'Length);
+
+      function to_motion_Updates is new ada.unchecked_Conversion (the_Stream_Element_Array, the_motion_Updates);
+
+      the_Stream_Array : the_Stream_Element_Array;
+      Last             : Stream_Element_Offset;
+
+   begin
+      read (Stream.all, the_Stream_Array, Last);
+
+      pragma assert (Last = the_Stream_Array'Last);
+
+      Item := to_motion_Updates (the_Stream_Array (1 .. Last));
+   end motion_Updates_read;
+
+
+
+   procedure Write (Stream    : not null access ada.Streams.Root_Stream_type'Class;
+                    the_Event : in              new_model_Event)
+   is
+   begin
+      openGL.remote_Model.item'Class'Output (Stream,
+                                             the_Event.Model.all);
+   end Write;
+
+
+
+   procedure Read (Stream    : not null access ada.Streams.Root_Stream_type'Class;
+                   the_Event : out             new_model_Event)
+   is
+   begin
+      the_Event.Model := new openGL.remote_Model.item'Class' (openGL.remote_Model.item'Class'Input (Stream));
+   end Read;
+
+
+
+   procedure Write (Stream    : not null access ada.Streams.Root_Stream_type'Class;
+                    the_Event : in              new_physics_model_Event)
+   is
+   begin
+      physics.Remote.Model.item'Class'Output (Stream, the_Event.Model.all);
+   end Write;
+
+
+   procedure Read (Stream    : not null access ada.Streams.Root_Stream_type'Class;
+                   the_Event : out             new_physics_model_Event)
+   is
+   begin
+      the_Event.Model := new physics.remote.Model.item'Class' (physics.remote.Model.item'Class'Input (Stream));
+   end Read;
+
+
+end gel.remote.World;

4-high/gel/source/remote/gel-remote-world.ads

@@ -0,0 +1,177 @@
+with
+     physics.remote.Model,
+     openGL .remote_Model,
+
+     lace.Observer,
+     lace.Subject,
+     lace.Event,
+
+     ada.unchecked_Conversion,
+     ada.Containers.indefinite_hashed_Maps,
+     ada.Containers.indefinite_Vectors,
+     ada.Streams;
+
+package gel.remote.World
+--
+--  Provides a remote (DSA friendly) interface of a GEL world.
+--
+--  Supports world mirroring, in which a mirror world mimics the objects and dynamics of a master world.
+--
+is
+   pragma remote_Types;
+
+   type Item is  limited interface
+             and lace.Subject .item
+             and lace.Observer.item;
+
+   type View is access all Item'Class with asynchronous;
+
+
+   -----------
+   --  Mirrors
+   --
+
+   --  Registration
+   --
+
+   procedure   register (Self : access Item;   the_Mirror         : in World.view;
+                                               Mirror_as_observer : in lace.Observer.view)   is abstract;
+   procedure deregister (Self : access Item;   the_Mirror         : in World.view)           is abstract;
+
+
+   ----------
+   --  Models
+   --
+
+   --  Graphics
+   --
+
+   use type openGL.remote_Model.item;
+   package  model_Vectors is new ada.Containers.indefinite_Vectors (Positive, openGL.remote_Model.item'Class);
+
+   function Hash is new ada.unchecked_Conversion (gel.graphics_model_Id, ada.containers.Hash_type);
+   use type gel.graphics_model_Id;
+
+   package  id_Maps_of_model_plan is new ada.Containers.indefinite_Hashed_Maps (gel.graphics_model_Id,
+                                                                                openGL.remote_Model.item'Class,
+                                                                                Hash,
+                                                                                "=");
+   subtype  graphics_Model_Set is id_Maps_of_model_plan.Map;     -- TODO: Rename to id_Map_of_graphics_model_plan.
+
+   function graphics_Models (Self : in Item) return graphics_Model_Set is abstract;
+
+
+   type new_model_Event is new lace.Event.item with
+      record
+         Model : access openGL.remote_Model.item'Class;
+      end record;
+
+
+   procedure Write (Stream : not null access ada.Streams.Root_Stream_type'Class;   the_Event : in  new_model_Event);
+   procedure Read  (Stream : not null access ada.Streams.Root_Stream_type'Class;   the_Event : out new_model_Event);
+
+   for new_model_Event'write use write;
+   for new_model_Event'read  use read;
+
+
+   --  Physics
+   --
+
+   use physics.remote.Model;
+   package  physics_model_Vectors is new ada.containers.indefinite_Vectors (Positive, physics.remote.Model.item'Class);
+
+   use type physics.model_Id;
+   function Hash is new ada.unchecked_Conversion (physics.model_Id, ada.containers.Hash_type);
+
+   package  id_Maps_of_physics_model_plan is new ada.containers.indefinite_Hashed_Maps (physics.model_Id,
+                                                                                        physics.remote.Model.item'Class,
+                                                                                        Hash,
+                                                                                        "=");
+   subtype  physics_Model_Set is id_Maps_of_physics_model_plan.Map;     -- TODO: Rename to id_Map_of_physics_model_plan.
+
+   function physics_Models (Self : in Item) return physics_Model_Set is abstract;
+
+
+   type new_physics_model_Event is new lace.Event.item with
+      record
+         Model : access physics.remote.Model.item'Class;
+      end record;
+
+   procedure Write (Stream : not null access ada.Streams.Root_Stream_type'Class;   the_Event : in  new_physics_model_Event);
+   procedure Read  (Stream : not null access ada.Streams.Root_Stream_type'Class;   the_Event : out new_physics_model_Event);
+
+   for new_physics_model_Event'write use write;
+   for new_physics_model_Event'read  use read;
+
+
+   -----------
+   --- Sprites
+   --
+
+   type sprite_model_Pair is
+      record
+         sprite_Id         : gel   .sprite_Id;
+         graphics_model_Id : openGL .model_Id;
+         physics_model_Id  : physics.model_Id;
+
+         Mass              : math.Real;
+         Transform         : math.Matrix_4x4;
+         is_Visible        : Boolean;
+      end record;
+
+   type sprite_model_Pairs is array (math.Index range <>) of sprite_model_Pair;
+
+   function Sprites (Self : in out Item) return sprite_model_Pairs is abstract;
+
+
+   -------------------------
+   --- Sprite Motion Updates
+   --
+
+   --  Coarse types to help minimise network use - (TODO: Currently disabled til better quaternion 'coarsen' is ready.)
+   --
+   type coarse_Real is new math.Real;   -- Not coarse atm (see above 'TODO')
+
+   type coarse_Vector_3 is array (1 .. 3) of coarse_Real;
+
+   function refined (Self : in coarse_Vector_3) return   math.Vector_3;
+   function coarsen (Self : in   math.Vector_3) return coarse_Vector_3;
+
+
+   type coarse_Real2 is new math.Real;   -- Not coarse atm.
+
+
+   type coarse_Quaternion is array (1 .. 4) of coarse_Real2;
+
+   function refined (Self : in coarse_Quaternion) return   math.Quaternion;
+   function coarsen (Self : in   math.Quaternion) return coarse_Quaternion;
+
+
+   type motion_Update is
+      record
+         Id   : gel.sprite_Id;
+         Site : coarse_Vector_3;
+         Spin : coarse_Quaternion;
+      end record
+   with Pack;
+
+
+   type motion_Updates is array (Positive range <>) of motion_Update
+   with Pack;
+
+   procedure motion_Updates_write (Stream : access ada.Streams.Root_Stream_type'Class;   Item : in  motion_Updates);
+   procedure motion_Updates_read  (Stream : access ada.Streams.Root_Stream_type'Class;   Item : out motion_Updates);
+
+   for motion_Updates'write use motion_Updates_write;
+   for motion_Updates'read  use motion_Updates_read;
+
+   procedure motion_Updates_are (Self : in Item;   Now : in motion_Updates) is abstract;
+
+
+   --------------
+   --  Test/Debug
+   --
+
+   procedure kick_Sprite (Self : in out Item;   sprite_Id : in gel.Sprite_Id) is abstract;
+
+end gel.remote.World;

4-high/gel/source/remote/gel-remote.ads

@@ -0,0 +1,7 @@
+package gel.Remote
+--
+-- Provides a namespace for remote GEL classes.
+--
+is
+   pragma Pure;
+end gel.Remote;

4-high/gel/source/terrain/gel-terrain.adb

@@ -0,0 +1,232 @@
+with
+     physics.Model,
+     Physics,
+
+     openGL.Model.terrain,
+     openGL.IO,
+
+     ada.unchecked_Deallocation,
+     ada.unchecked_Conversion;
+
+package body gel.Terrain
+is
+   type Heightfield_view is access all physics.Heightfield;
+
+   type height_Map_view is access all opengl.height_Map;
+   type height_map_Grid is array (math.Index range <>,
+                                  math.Index range <>) of height_Map_view;
+
+
+   function Width (Self : in opengl.height_Map) return math.Real
+   is
+   begin
+      return math.Real (self'Length (2) - 1);
+   end Width;
+
+
+   function Depth (Self : in opengl.height_Map) return math.Real
+   is
+   begin
+      return math.Real (self'Length (1) - 1);
+   end Depth;
+
+
+
+   function new_Terrain (World        : in gel.World.view;
+                         heights_File : in String;
+                         texture_File : in String        := "";
+                         Scale        : in math.Vector_3 := (1.0, 1.0, 1.0)) return access gel.Sprite.Grid
+   is
+      use Math;
+
+      the_Pixels  : opengl.IO.height_Map_view := opengl.IO.to_height_Map (openGL.to_Asset (heights_File));
+
+      tile_Width  : constant Positive := 8 * 32 - 1;
+      tile_Depth  : constant Positive := 8 * 32 - 1;
+
+      total_Width : constant Real     := Real (the_Pixels'Length (2) - 1) * Scale (1);
+      total_Depth : constant Real     := Real (the_Pixels'Length (1) - 1) * Scale (3);
+
+      base_Centre : constant Vector_3 := (0.0, 0.0, 0.0);
+
+
+      function Grid_last (total_Size, tile_Size : in Positive) return math.Index
+      is
+         Last : constant math.Index := math.Index (  1
+                                                   + (total_Size - 1) / tile_Size);
+      begin
+         return Last;
+      end Grid_last;
+
+
+      the_heightmap_Grid : height_map_Grid (1  ..  Grid_last (the_Pixels'Length (1), tile_Depth),
+                                            1  ..  Grid_last (the_Pixels'Length (2), tile_Width));
+
+      the_Sprite_Grid    : constant gel.Sprite.Grid_view := new gel.Sprite.Grid (the_heightmap_Grid'Range (1),
+                                                                                 the_heightmap_Grid'Range (2));
+
+      procedure free is new ada.unchecked_Deallocation (opengl.height_Map,
+                                                        opengl.IO.height_Map_view);
+
+      procedure flip (Self : opengl.IO.height_Map_view)
+      is
+         use type opengl.Index_t;
+
+         the_Map : opengl.IO.height_Map_view := new opengl.height_Map' (Self.all);
+
+      begin
+         for Row in Self'Range (1)
+         loop
+            for Col in Self'Range (2)
+            loop
+               Self (Row, Col) := the_Map (Self'Last (1) - Row + 1,  Col);
+            end loop;
+         end loop;
+
+         free (the_Map);
+      end flip;
+
+
+   begin
+      flip (the_Pixels.all'unchecked_Access);
+
+      --  Create each grid elements 'heightmap'.
+      --
+      declare
+         use openGL;
+
+         row_First, row_Last,
+         col_First, col_Last : math.Index;     -- Row and col ranges for each sub-matrix.
+
+      begin
+         for Row in the_sprite_Grid'Range (1)
+         loop
+            row_First := math.Index (tile_Depth - 1) * (Row - 1) + 1;
+            row_Last  := math.Index'Min (row_First + math.Index (tile_Depth - 1),
+                                         math.Index (the_Pixels'Last (1)));
+
+            for Col in the_sprite_Grid'Range (2)
+            loop
+               col_First := math.Index (tile_Width - 1) * (Col - 1) + 1;
+               col_Last  := math.Index'Min (col_First + math.Index (tile_Width - 1),
+                                            math.Index (the_Pixels'Last (2)));
+
+               the_heightmap_Grid (Row, Col)
+                 := new opengl.height_Map' (Region (the_Pixels.all, (Index_t (row_First), Index_t (row_Last)),
+                                                                    (Index_t (col_First), Index_t (col_Last))));
+            end loop;
+         end loop;
+      end;
+
+      --  Create the Sprite for each grid element.
+      --
+      declare
+         site_X_offset,
+         site_Z_offset : Real := 0.0;
+         site_Y_Offset : Real;
+
+         tile_X_Offset : Real := 0.0;
+         tile_Z_Offset : Real := total_Depth;
+
+         tile_X_Scale  : Real;
+         tile_Z_Scale  : Real;
+
+      begin
+         for Row in the_sprite_Grid'Range (1)
+         loop
+            site_X_offset := 0.0;
+
+            tile_X_Offset := 0.0;
+            tile_Z_Offset := tile_Z_Offset - Depth (the_heightmap_Grid (Row, 1).all) * Scale (3);
+
+            for Col in the_sprite_Grid'Range (2)
+            loop
+               tile_Z_Scale := Depth (the_heightmap_Grid (Row,   1).all) / total_Depth;
+               tile_X_Scale := Width (the_heightmap_Grid (Row, Col).all) / total_Width;
+
+               declare
+                  the_Region       : constant height_Map_view := the_heightmap_Grid (Row, Col);
+                  the_height_Range : constant opengl.Vector_2 := openGL.height_Extent (the_Region.all);
+
+                  Tiling : constant opengl.texture_Transform_2d
+                    :=  (S => (opengl.Real (tile_X_Offset / total_Width) / opengl.Real (tile_X_Scale * Scale (1)),
+                               opengl.Real (tile_X_Scale * Scale (1))),
+                         T => (opengl.Real (tile_Z_Offset / total_Depth) / opengl.Real (tile_Z_Scale * Scale (3)),
+                               opengl.Real (tile_Z_Scale * Scale (3))));
+
+                  the_ground_Model : constant access openGL.Model.terrain.item
+                    := openGL.Model.terrain.new_Terrain (heights_Asset => openGL.to_Asset (heights_File),
+                                                         Row           => Row,
+                                                         Col           => Col,
+                                                         Heights       => the_Region.all'Access,
+                                                         color_Map     => openGL.to_Asset (texture_File),
+                                                         Tiling        => Tiling);
+
+                  function to_Physics is new ada.unchecked_Conversion (height_Map_view,
+                                                                       Heightfield_view);
+
+                  the_ground_physics_Model : constant physics.Model.view
+                    := new physics.Model.item' (Id          => physics.null_model_Id,
+                                                --  Site        => Origin_3d,
+                                                Scale       => Scale,
+                                                shape_Info  => (physics.Model.Heightfield,
+                                                                Heights      => to_Physics (the_Region),
+                                                                height_range => (the_height_Range (1),
+                                                                                 the_height_Range (2))),
+                                                Shape       => null,
+                                                Mass        => 0.0,
+                                                Friction    => 0.5,
+                                                Restitution => 0.5,
+                                                is_Tangible => True);
+
+                  the_height_Extents : constant opengl.Vector_2 := opengl.height_Extent (the_Region.all);
+                  the_Sprite         : gel.Sprite.view     renames the_sprite_Grid (Row, Col);
+                  the_Site           : vector_3;
+               begin
+                  --  the_ground_Model.Scale := (Scale (1),
+                  --                             Scale (2),
+                  --                             Scale (3));
+
+                  the_Site := (0.0, 0.0, 0.0);
+
+                  the_Sprite := gel.Sprite.Forge.new_Sprite ("Terrain" & Row'Image & Col'Image,
+                                                             sprite.World_view (World),
+                                                             the_Site,
+                                                             the_ground_Model,
+                                                             the_ground_physics_Model,
+                                                             owns_Graphics => True,
+                                                             owns_Physics  => True);
+
+                  site_y_Offset := math.Real (  the_height_Extents (1)
+                                              + (the_height_Extents (2) - the_height_Extents (1)) / 2.0);
+
+                  --  the_sprite_Grid (Row, Col).Site_is (the_Site + base_Centre);
+                  the_Sprite. Site_is (the_Site + base_Centre);
+                  the_Sprite.Scale_is (Scale);
+
+                  tile_X_Offset := tile_X_Offset + Width (the_heightmap_Grid (Row, Col).all) * Scale (1);
+
+                  if Col /= the_sprite_Grid'Last (2)
+                  then
+                     site_X_offset := site_X_offset
+                                    + Width (the_heightmap_Grid (Row, Col    ).all) * Scale (1) / 2.0
+                                    + Width (the_heightmap_Grid (Row, Col + 1).all) * Scale (1) / 2.0;
+                  end if;
+               end;
+            end loop;
+
+            if Row /= the_sprite_Grid'Last (1)
+            then
+               site_Z_offset := site_Z_offset + Depth (the_heightmap_Grid (Row,     1).all) * Scale (3) / 2.0
+                                              + Depth (the_heightmap_Grid (Row + 1, 1).all) * Scale (3) / 2.0;
+            end if;
+         end loop;
+      end;
+
+      free (the_Pixels);
+
+      return the_Sprite_Grid;
+   end new_Terrain;
+
+
+end gel.Terrain;

4-high/gel/source/terrain/gel-terrain.ads

@@ -0,0 +1,16 @@
+with
+     gel.Sprite,
+     gel.World;
+
+package gel.Terrain
+--
+--  Provides a constructor for heightmap terrain.
+--
+is
+
+   function new_Terrain (World        : in gel.World.view;
+                         heights_File : in String;
+                         texture_File : in String        := "";
+                         Scale        : in math.Vector_3 := (1.0, 1.0, 1.0)) return access gel.Sprite.Grid;
+
+end gel.Terrain;

4-high/gel/source/world/gel-world-client.adb

@@ -0,0 +1,546 @@
+with
+     gel.Events,
+
+     physics.remote.Model,
+     physics.Forge,
+
+     openGL.remote_Model,
+     openGL.Renderer.lean,
+
+     lace.Response,
+     lace.Event.utility,
+
+     ada.unchecked_Deallocation,
+     ada.Text_IO;
+
+
+package body gel.World.client
+is
+   use linear_Algebra_3D,
+       lace.Event.utility;
+
+
+   procedure log (Message : in String)
+                  renames ada.text_IO.put_Line;
+   pragma Unreferenced (log);
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      deallocate (Self);
+   end free;
+
+
+   procedure define (Self : in out Item'Class;   Name       : in     String;
+                                                 Id         : in     world_Id;
+                                                 space_Kind : in     physics.space_Kind;
+                                                 Renderer   : access openGL.Renderer.lean.item'Class);
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      physics.Space.free (Self.physics_Space);
+
+      lace.Subject_and_deferred_Observer.item (Self).destroy;     -- Destroy base class.
+      lace.Subject_and_deferred_Observer.free (Self.local_Subject_and_deferred_Observer);
+   end destroy;
+
+
+
+   package body Forge
+   is
+
+      function to_World (Name       : in     String;
+                         Id         : in     world_Id;
+                         space_Kind : in     physics.space_Kind;
+                         Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.client.item
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+      begin
+         return Self : gel.World.client.item := (to_Subject_and_Observer (Name => Name & " world" & Id'Image)
+                                          with others => <>)
+         do
+            Self.define (Name, Id, space_Kind, Renderer);
+         end return;
+      end to_World;
+
+
+
+      function new_World (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.client.view
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+
+         Self : constant gel.World.client.view
+           := new gel.World.client.item' (to_Subject_and_Observer (name => Name & " world" & Id'Image)
+                                   with others => <>);
+      begin
+         Self.define (Name, Id, space_Kind, Renderer);
+         return Self;
+      end new_World;
+
+   end Forge;
+
+
+
+   function to_Sprite (the_Pair           : in remote.World.sprite_model_Pair;
+                       the_Models         : in Id_Maps_of_Model        .Map;
+                       the_physics_Models : in Id_Maps_of_physics_Model.Map;
+                       the_World          : in gel.World.view) return gel.Sprite.view
+   is
+      the_graphics_Model : access openGL .Model.item'Class;
+      the_physics_Model  : access physics.Model.item'Class;
+      the_Sprite         :        gel.Sprite.view;
+
+      use openGL;
+   begin
+      the_graphics_Model := openGL .Model.view (the_Models        .Element (the_Pair.graphics_Model_Id));
+      the_physics_Model  := physics.Model.view (the_physics_Models.Element (the_Pair. physics_Model_Id));
+
+      the_Sprite := gel.Sprite.forge.new_Sprite ("Sprite" & the_Pair.sprite_Id'Image,
+                                                 sprite.World_view (the_World),
+                                                 get_Translation (the_Pair.Transform),
+                                                 the_graphics_Model,
+                                                 the_physics_Model,
+                                                 owns_Graphics => False,
+                                                 owns_Physics  => False,
+                                                 is_Kinematic  => the_Pair.Mass /= 0.0);
+
+      the_Sprite.Id_is      (Now => the_Pair.sprite_Id);
+      the_Sprite.is_Visible (Now => the_Pair.is_Visible);
+
+      the_Sprite.Site_is    (get_Translation (the_Pair.Transform));
+      the_Sprite.Spin_is    (get_Rotation    (the_Pair.Transform));
+
+
+      the_Sprite.desired_Dynamics_are (Site => the_Sprite.Site,
+                                       Spin => to_Quaternion (get_Rotation (the_Sprite.Transform)));
+
+      --  the_Sprite.desired_Site_is (the_Sprite.Site);
+      --  the_Sprite.desired_Spin_is (to_Quaternion (get_Rotation (the_Sprite.Transform)));
+
+      return the_Sprite;
+   end to_Sprite;
+
+
+
+   --------------------------------
+   --- 'create_new_Sprite' Response
+   --
+
+   type create_new_Sprite is new lace.Response.item with
+      record
+         World          :        gel.World.view;
+         Models         : access id_Maps_of_model        .Map;
+         physics_Models : access id_Maps_of_physics_model.Map;
+      end record;
+
+
+   overriding
+   function Name (Self : in create_new_Sprite) return String;
+
+
+
+   overriding
+   procedure respond (Self : in out create_new_Sprite;   to_Event : in lace.Event.item'Class)
+   is
+   begin
+      declare
+         the_Event  : constant gel.Events.new_sprite_Event := gel.Events.new_sprite_Event (to_Event);
+         the_Sprite : constant gel.Sprite.view             := to_Sprite (the_Event.Pair,
+                                                                         Self.Models.all,
+                                                                         Self.physics_Models.all,
+                                                                         Self.World);
+      begin
+         Self.World.add (the_Sprite);
+      end;
+   end respond;
+
+
+
+   overriding
+   function Name (Self : in create_new_Sprite) return String
+   is
+      pragma Unreferenced (Self);
+   begin
+      return "create_new_Sprite";
+   end Name;
+
+
+   ----------
+   --- Define
+   --
+
+   procedure define  (Self : in out Item'Class;   Name       : in     String;
+                                                  Id         : in     world_Id;
+                                                  space_Kind : in     physics.space_Kind;
+                                                  Renderer   : access openGL.Renderer.lean.Item'Class)
+   is
+      use lace.Subject_and_deferred_Observer.Forge;
+   begin
+      Self.local_Subject_and_deferred_Observer := new_Subject_and_Observer (name => Name & " world" & Id'Image);
+
+      Self.Id            := Id;
+      Self.space_Kind    := space_Kind;
+      Self.Renderer      := Renderer;
+      Self.physics_Space := physics.Forge.new_Space (space_Kind);
+   end define;
+
+
+
+   ----------------------
+   --- new_model_Response
+   --
+
+   type new_model_Response is new lace.Response.item with
+      record
+         World : gel.World.view;
+      end record;
+
+
+   overriding
+   function Name (Self : in new_model_Response) return String;
+
+
+   overriding
+   procedure respond (Self : in out new_model_Response;   to_Event : in lace.Event.Item'Class)
+   is
+      the_Event : constant remote.World.new_model_Event := remote.World.new_model_Event (to_Event);
+   begin
+      Self.World.add (new openGL.Model.item'Class' (openGL.Model.item'Class (the_Event.Model.all)));
+   end respond;
+
+
+   overriding
+   function Name (Self : in new_model_Response) return String
+   is
+      pragma unreferenced (Self);
+   begin
+      return "new_model_Response";
+   end Name;
+
+
+   the_new_model_Response : aliased new_model_Response;
+
+
+   --------------------------
+   --- my_new_sprite_Response
+   --
+   type my_new_sprite_Response is new lace.Response.item with
+      record
+         World          :        gel.World.view;
+         Models         : access id_Maps_of_model        .Map;
+         physics_Models : access id_Maps_of_physics_model.Map;
+      end record;
+
+
+   overriding
+   function Name (Self : in my_new_sprite_Response) return String;
+
+
+
+   overriding
+   procedure respond (Self : in out my_new_sprite_Response;   to_Event : in lace.Event.Item'Class)
+   is
+      the_Event  : constant gel.Events.my_new_sprite_added_to_world_Event
+        := gel.events.my_new_sprite_added_to_world_Event (to_Event);
+
+      the_Sprite : constant gel.Sprite.view
+        := to_Sprite (the_Event.Pair,
+                      Self.Models.all,
+                      Self.physics_Models.all,
+                      Self.World);
+   begin
+      Self.World.add (the_Sprite);
+   end respond;
+
+
+
+   procedure define (Self : in out my_new_sprite_Response;   World  : in     gel.World.view;
+                                                             Models : access id_Maps_of_model.Map)
+   is
+   begin
+      Self.World  := World;
+      Self.Models := Models;
+   end define;
+
+
+   overriding
+   function Name (Self : in my_new_sprite_Response) return String
+   is
+      pragma unreferenced (Self);
+   begin
+      return "my_new_sprite_Response";
+   end Name;
+
+   the_my_new_sprite_Response : aliased my_new_sprite_Response;
+
+
+
+   type graphics_Model_iface_view is access all openGL.remote_Model.item'Class;
+
+   type physics_Model_iface_view is access all Standard.physics.remote.Model.item'Class;
+
+
+
+   procedure is_a_Mirror (Self : access Item'Class;   of_World : in remote.World.view)
+   is
+   begin
+      the_new_model_Response.World := Self.all'Access;
+
+      Self.add (the_new_model_Response'Access,
+                to_Kind (remote.World.new_model_Event'Tag),
+                of_World.Name);
+
+      define   (the_my_new_sprite_Response, World  => Self.all'Access,
+                                            Models => Self.graphics_Models'Access);
+
+      Self.add (the_my_new_sprite_Response'Access,
+                to_Kind (gel.Events.my_new_sprite_added_to_world_Event'Tag),
+                of_World.Name);
+
+      --  Obtain and make a local copy of models, sprites and humans from the mirrored world.
+      --
+      declare
+         use remote.World.id_Maps_of_model_plan;
+
+         the_server_Models         : constant remote.World.graphics_Model_Set := of_World.graphics_Models;    -- Fetch graphics models from the server.
+         the_server_physics_Models : constant remote.World.physics_model_Set  := of_World.physics_Models;     -- Fetch physics  models from the server.
+      begin
+         --  Create our local graphics models.
+         --
+         declare
+            Cursor    : remote.World.Id_Maps_of_Model_Plan.Cursor := the_server_Models.First;
+            new_Model : graphics_Model_iFace_view;
+         begin
+            while has_Element (Cursor)
+            loop
+               new_Model := new openGL.remote_Model.item'Class' (Element (Cursor));
+               Self.add (openGL.Model.view (new_Model));
+
+               next (Cursor);
+            end loop;
+         end;
+
+         --  Create our local physics models.
+         --
+         declare
+            use remote.World.id_Maps_of_physics_model_plan;
+
+            Cursor    : remote.World.id_Maps_of_physics_model_plan.Cursor := the_server_physics_Models.First;
+            new_Model : physics_Model_iFace_view;
+
+         begin
+            while has_Element (Cursor)
+            loop
+               new_Model := new physics.remote.Model.item'Class' (Element (Cursor));
+               Self.add (physics.Model.view (new_Model));
+
+               next (Cursor);
+            end loop;
+         end;
+
+         --  Fetch sprites from the server.
+         --
+         declare
+            the_Sprite         :          gel.Sprite.view;
+            the_server_Sprites : constant remote.World.sprite_model_Pairs := of_World.Sprites;
+         begin
+            for i in the_server_Sprites'Range
+            loop
+               the_Sprite := to_Sprite (the_server_Sprites (i),
+                                        Self.graphics_Models,
+                                        Self. physics_Models,
+                                        gel.World.view (Self));
+               Self.add (the_Sprite);
+            end loop;
+         end;
+      end;
+   end is_a_Mirror;
+
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure add (Self : access Item;   the_Sprite   : in gel.Sprite.view;
+                                        and_Children : in Boolean := False)
+   is
+   begin
+      Self.all_Sprites.Map.add (the_Sprite);
+   end add;
+
+
+
+   overriding
+   procedure motion_Updates_are (Self : in Item;   Now : in remote.World.motion_Updates)
+   is
+      all_Sprites : constant id_Maps_of_sprite.Map := Self.all_Sprites.Map.fetch_all;
+
+   begin
+      for i in Now'Range
+      loop
+         declare
+            use remote.World;
+
+            the_Id             : constant gel.sprite_Id := Now (i).Id;
+            the_Sprite         : constant Sprite.view   := all_Sprites.Element (the_Id);
+
+            new_Site           : constant Vector_3      := refined (Now (i).Site);
+            --  site_Delta         :          Vector_3;
+            --  min_teleport_Delta : constant               := 20.0;
+
+            new_Spin           : constant Quaternion    := refined (Now (i).Spin);
+            --  new_Spin           : constant Matrix_3x3        := Now (i).Spin;
+
+         begin
+            --  site_Delta := new_Site - the_Sprite.desired_Site;
+            --
+            --  if        abs site_Delta (1) > min_teleport_Delta
+            --    or else abs site_Delta (2) > min_teleport_Delta
+            --    or else abs site_Delta (3) > min_teleport_Delta
+            --  then
+            --     log ("Teleport.");
+            --     the_Sprite.Site_is (new_Site);   -- Sprite has been 'teleported', so move it now
+            --  end if;                             -- to prevent later interpolation.
+
+            null;
+
+            --  the_Sprite.Site_is (new_Site);
+            --  the_Sprite.Spin_is (to_Rotation (Axis  => new_Spin.V,
+            --                                   Angle => new_Spin.R));
+
+            --  the_Sprite.Spin_is (to_Matrix (to_Quaternion (new_Spin)));
+
+            --  the_Sprite.desired_Dynamics_are (Site => new_Site,
+            --                                   Spin => to_Quaternion (new_Spin));
+
+            the_Sprite.desired_Dynamics_are (Site => new_Site,
+                                             Spin => new_Spin);
+
+            --  the_Sprite.desired_Site_is (new_Site);
+            --  the_Sprite.desired_Spin_is (new_Spin);
+         end;
+      end loop;
+   end motion_Updates_are;
+
+
+
+   overriding
+   procedure evolve (Self : in out Item)
+   is
+   begin
+      Self.Age := Self.Age + evolve_Period;
+
+      Self.respond;
+      Self.local_Subject_and_deferred_Observer.respond;
+
+      --  Interpolate sprite transforms.
+      --
+      declare
+         use id_Maps_of_sprite;
+
+         --  all_Sprites   : constant id_Maps_of_sprite.Map    := Self.id_Map_of_sprite;
+         all_Sprites   : constant id_Maps_of_sprite.Map    := Self.all_Sprites.Map.fetch_all;
+         Cursor        :          id_Maps_of_sprite.Cursor := all_Sprites.First;
+         the_Sprite    :          gel.Sprite.view;
+
+      begin
+         while has_Element (Cursor)
+         loop
+            the_Sprite := Sprite.view (Element (Cursor));
+            the_Sprite.interpolate_Motion;
+
+            next (Cursor);
+         end loop;
+      end;
+   end evolve;
+
+
+
+   overriding
+   function fetch (From : in sprite_Map) return id_Maps_of_sprite.Map
+   is
+   begin
+      return From.Map.fetch_all;
+   end fetch;
+
+
+
+   overriding
+   procedure add (To : in out sprite_Map;   the_Sprite : in Sprite.view)
+   is
+   begin
+      To.Map.add (the_Sprite);
+   end add;
+
+
+
+   overriding
+   procedure rid (To : in out sprite_Map;   the_Sprite : in Sprite.view)
+   is
+   begin
+      To.Map.rid (the_Sprite);
+   end rid;
+
+
+
+   overriding
+   function all_Sprites (Self : access Item) return access World.sprite_Map'Class
+   is
+   begin
+      return Self.all_Sprites'Access;
+   end all_Sprites;
+
+
+
+   --------------
+   --  Containers
+   --
+
+   protected
+   body safe_id_Map_of_sprite
+   is
+      procedure add (the_Sprite : in Sprite.view)
+      is
+      begin
+         Map.insert (the_Sprite.Id,
+                     the_Sprite);
+      end add;
+
+
+      procedure rid (the_Sprite : in Sprite.view)
+      is
+      begin
+         Map.delete (the_Sprite.Id);
+      end rid;
+
+
+      function fetch (Id : in sprite_Id) return Sprite.view
+      is
+      begin
+         return Map.Element (Id);
+      end fetch;
+
+
+      function fetch_all return id_Maps_of_sprite.Map
+      is
+      begin
+         return Map;
+      end fetch_all;
+
+   end safe_id_Map_of_sprite;
+
+
+end gel.World.client;

4-high/gel/source/world/gel-world-client.ads

@@ -0,0 +1,114 @@
+limited
+with
+     openGL.Renderer.lean;
+
+
+package gel.World.client
+--
+--  Provides a gel world.
+--
+is
+   type Item  is limited new gel.World.item with private;
+
+   type View  is access all Item'Class;
+   type Views is array (Positive range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   package Forge
+   is
+      function to_World  (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.client.item;
+
+      function new_World (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.client.view;
+   end Forge;
+
+   overriding
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure add (Self : access Item;   the_Sprite   : in gel.Sprite.view;
+                                        and_Children : in Boolean := False);
+
+   overriding
+   procedure evolve (Self : in out Item);
+
+   --  overriding
+   --  procedure wait_on_evolve (Self : in out Item);
+
+
+   --------------------
+   --- Server Mirroring
+   --
+
+   procedure is_a_Mirror (Self : access Item'Class;   of_World : in remote.World.view);
+
+   overriding
+   procedure motion_Updates_are (Self : in Item;   Now : in remote.World.motion_Updates);
+   --
+   --  'Self' must use 'in' as mode to ensure async transmission with DSA.
+
+
+
+private
+
+   protected
+   type safe_id_Map_of_sprite
+   is
+      procedure add (the_Sprite : in Sprite.view);
+      procedure rid (the_Sprite : in Sprite.view);
+
+      function  fetch (Id : in sprite_Id) return Sprite.view;
+      function  fetch_all return id_Maps_of_sprite.Map;
+
+   private
+      Map : id_Maps_of_sprite.Map;
+   end safe_id_Map_of_sprite;
+
+
+
+   type sprite_Map is limited new World.sprite_Map with
+      record
+         Map : safe_id_Map_of_sprite;
+      end record;
+
+   overriding
+   function  fetch (From : in sprite_Map) return id_Maps_of_sprite.Map;
+
+   overriding
+   procedure add   (To   : in out sprite_Map;   the_Sprite : in Sprite.view);
+
+   overriding
+   procedure rid   (To   : in out sprite_Map;   the_Sprite : in Sprite.view);
+
+
+   --------------
+   --- World Item
+   --
+
+   type Item is limited new gel.World.item with
+      record
+         Age_at_last_mirror_update : Duration := 0.0;
+         all_Sprites               : aliased sprite_Map;
+      end record;
+
+
+   overriding
+   function all_Sprites (Self : access Item) return access World.sprite_Map'Class;
+
+
+end gel.World.client;

4-high/gel/source/world/gel-world-server.adb

@@ -0,0 +1,292 @@
+with
+     gel.Events,
+     physics.Forge,
+     openGL.Renderer.lean,
+     lace.Event.utility,
+
+     ada.Text_IO,
+     ada.unchecked_Deallocation;
+
+
+package body gel.World.server
+is
+   use gel.Sprite,
+       linear_Algebra_3D,
+
+       lace.Event.utility,
+       lace.Event;
+
+
+   procedure log (Message : in String)
+                  renames ada.text_IO.put_Line;
+   pragma Unreferenced (log);
+
+
+   ---------
+   --- Forge
+   --
+
+   procedure free (Self : in out View)
+   is
+      procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   begin
+      deallocate (Self);
+   end free;
+
+
+
+   procedure define (Self : in out Item'Class;   Name       : in     String;
+                                                 Id         : in     world_Id;
+                                                 space_Kind : in     physics.space_Kind;
+                                                 Renderer   : access openGL.Renderer.lean.item'Class);
+
+   overriding
+   procedure destroy (Self : in out Item)
+   is
+   begin
+      physics.Space.free (Self.physics_Space);
+
+      lace.Subject_and_deferred_Observer.item (Self).destroy;     -- Destroy base class.
+      lace.Subject_and_deferred_Observer.free (Self.local_Subject_and_deferred_Observer);
+   end destroy;
+
+
+
+   package body Forge
+   is
+
+      function to_World (Name       : in     String;
+                         Id         : in     world_Id;
+                         space_Kind : in     physics.space_Kind;
+                         Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.server.item
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+      begin
+         return Self : gel.World.server.item := (to_Subject_and_Observer (Name => Name & " world" & Id'Image)
+                                                 with others => <>)
+         do
+            Self.define (Name, Id, space_Kind, Renderer);
+         end return;
+      end to_World;
+
+
+
+      function new_World (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.server.view
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+
+         Self : constant gel.World.server.view
+           := new gel.World.server.item' (to_Subject_and_Observer (name => Name & " world" & Id'Image)
+                                   with others => <>);
+      begin
+         Self.define (Name, Id, space_Kind, Renderer);
+         return Self;
+      end new_World;
+
+   end Forge;
+
+
+
+   function to_Sprite (the_Pair           : in remote.World.sprite_model_Pair;
+                       the_Models         : in Id_Maps_of_Model        .Map;
+                       the_physics_Models : in Id_Maps_of_physics_Model.Map;
+                       the_World          : in gel.World.view) return gel.Sprite.view
+   is
+      the_graphics_Model : access openGL .Model.item'Class;
+      the_physics_Model  : access physics.Model.item'Class;
+      the_Sprite         :        gel.Sprite.view;
+
+      use openGL;
+   begin
+      the_graphics_Model := openGL .Model.view (the_Models        .Element (the_Pair.graphics_Model_Id));
+      the_physics_Model  := physics.Model.view (the_physics_Models.Element (the_Pair. physics_Model_Id));
+
+      the_Sprite := gel.Sprite.forge.new_Sprite ("Sprite" & the_Pair.sprite_Id'Image,
+                                                 sprite.World_view (the_World),
+                                                 get_Translation (the_Pair.Transform),
+                                                 the_graphics_Model,
+                                                 the_physics_Model,
+                                                 owns_Graphics => False,
+                                                 owns_Physics  => False,
+                                                 is_Kinematic  => the_Pair.Mass /= 0.0);
+
+      the_Sprite.Id_is      (Now => the_Pair.sprite_Id);
+      the_Sprite.is_Visible (Now => the_Pair.is_Visible);
+
+      the_Sprite.Site_is    (get_Translation (the_Pair.Transform));
+      the_Sprite.Spin_is    (get_Rotation    (the_Pair.Transform));
+
+      the_Sprite.desired_Dynamics_are (Site => the_Sprite.Site,
+                                       Spin => to_Quaternion (get_Rotation (the_Sprite.Transform)));
+
+      --  the_Sprite.desired_Site_is (the_Sprite.Site);
+      --  the_Sprite.desired_Spin_is (to_Quaternion (get_Rotation (the_Sprite.Transform)));
+
+      return the_Sprite;
+   end to_Sprite;
+   pragma Unreferenced (to_Sprite);
+
+
+   ----------
+   --- Define
+   --
+
+   procedure define  (Self : in out Item'Class;   Name       : in     String;
+                                                  Id         : in     world_Id;
+                                                  space_Kind : in     physics.space_Kind;
+                                                  Renderer   : access openGL.Renderer.lean.Item'Class)
+   is
+      use lace.Subject_and_deferred_Observer.Forge;
+   begin
+      Self.local_Subject_and_deferred_Observer := new_Subject_and_Observer (name => Name & " world" & Id'Image);
+
+      Self.Id            := Id;
+      Self.space_Kind    := space_Kind;
+      Self.Renderer      := Renderer;
+      Self.physics_Space := physics.Forge.new_Space (space_Kind);
+   end define;
+
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure evolve (Self : in out Item)
+   is
+   begin
+      gel.World.item (Self).evolve;     -- Evolve the base class.
+
+      --  Update dynamics in client worlds.
+      --
+      declare
+         use id_Maps_of_sprite,
+             remote.World;
+
+         all_Sprites            : constant id_Maps_of_sprite.Map    := Self.all_Sprites.fetch;
+         Cursor                 :          id_Maps_of_sprite.Cursor := all_Sprites.First;
+
+
+         the_Sprite             :          gel.Sprite.view;
+
+         is_a_mirrored_World    : constant Boolean := not Self.Clients.Is_Empty;
+         mirror_Updates_are_due : constant Boolean := Self.Age >= Self.Age_at_last_Clients_update + client_update_Period;
+         updates_Count          :          Natural := 0;
+
+         the_motion_Updates     :          remote.World.motion_Updates (1 .. Integer (all_Sprites.Length));
+
+      begin
+         if    is_a_mirrored_World
+           and mirror_Updates_are_due
+         then
+            while has_Element (Cursor)
+            loop
+               the_Sprite := Sprite.view (Element (Cursor));
+
+               updates_Count                      := updates_Count + 1;
+               the_motion_Updates (updates_Count) := (Id   => the_Sprite.Id,
+                                                      Site => coarsen (the_Sprite.Site),
+                                                      Spin => coarsen (to_Quaternion (the_Sprite.Spin)));
+                                                      --  Spin => the_Sprite.Spin);
+
+               --  log (Image (Quaternion' (refined (the_motion_Updates (updates_Count).Spin))));
+
+               next (Cursor);
+            end loop;
+
+            --  Send updated sprite motions to all registered client worlds.
+            --
+            Self.Age_at_last_clients_update := Self.Age;
+
+            if updates_Count > 0
+            then
+               declare
+                  use World.server.world_Vectors;
+
+                  Cursor     : world_Vectors.Cursor := Self.Clients.First;
+                  the_Mirror : remote.World.view;
+               begin
+                  while has_Element (Cursor)
+                  loop
+                     the_Mirror := Element (Cursor);
+                     the_Mirror.motion_Updates_are (the_motion_Updates (1 .. updates_Count));
+
+                     next (Cursor);
+                  end loop;
+               end;
+            end if;
+
+         end if;
+      end;
+
+   end evolve;
+
+
+
+   overriding
+   function fetch (From : in sprite_Map) return id_Maps_of_sprite.Map
+   is
+   begin
+      return From.Map;
+   end fetch;
+
+
+
+   overriding
+   procedure add (To : in out sprite_Map;   the_Sprite : in Sprite.view)
+   is
+   begin
+      To.Map.insert (the_Sprite.Id, the_Sprite);
+   end add;
+
+
+
+   overriding
+   procedure rid (From : in out sprite_Map;   the_Sprite : in Sprite.view)
+   is
+   begin
+      From.Map.delete (the_Sprite.Id);
+   end rid;
+
+
+
+   overriding
+   function all_Sprites (Self : access Item) return access World.sprite_Map'Class
+   is
+   begin
+      return Self.all_Sprites'Access;
+   end all_Sprites;
+
+
+
+   -----------------------
+   --- Client Registration
+   --
+
+   overriding
+   procedure register (Self : access Item;   the_Mirror         : in remote.World.view;
+                                             Mirror_as_observer : in lace.Observer.view)
+   is
+   begin
+      Self.Clients.append (the_Mirror);
+
+      Self.register (Mirror_as_observer,  to_Kind (remote.World.                 new_model_Event'Tag));
+      Self.register (Mirror_as_observer,  to_Kind (gel.events.                  new_sprite_Event'Tag));
+      Self.register (Mirror_as_observer,  to_Kind (gel.events.my_new_sprite_added_to_world_Event'Tag));
+   end register;
+
+
+
+   overriding
+   procedure deregister (Self : access Item;   the_Mirror : in remote.World.view)
+   is
+   begin
+      Self.Clients.delete (Self.Clients.find_Index (the_Mirror));
+   end deregister;
+
+
+end gel.World.server;

4-high/gel/source/world/gel-world-server.ads

@@ -0,0 +1,104 @@
+with
+     lace.Observer,
+     ada.unchecked_Conversion,
+     ada.Containers.Vectors;
+
+limited
+with
+     openGL.Renderer.lean;
+
+
+package gel.World.server
+--
+--  Provides a gel world server.
+--
+is
+   type Item  is limited new gel.World.item
+   with private;
+
+   type View  is access all Item'Class;
+   type Views is array (Positive range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   package Forge
+   is
+      function to_World  (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.server.item;
+
+      function new_World (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.server.view;
+   end Forge;
+
+   overriding
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --- Operations
+   --
+
+   overriding
+   procedure   register (Self : access Item;   the_Mirror         : in remote.World.view;
+                                               Mirror_as_observer : in lace.Observer.view);
+   overriding
+   procedure deregister (Self : access Item;   the_Mirror         : in remote.World.view);
+
+   overriding
+   procedure evolve     (Self : in out Item);
+
+
+
+private
+
+   -----------
+   --- Clients
+   --
+   use type remote.World.view;
+   package world_Vectors is new ada.Containers.Vectors (Positive, remote.World.view);
+   subtype world_Vector  is     world_Vectors.Vector;
+
+
+   --------------
+   --- sprite_Map
+   --
+   type sprite_Map is limited new World.sprite_Map with
+      record
+         Map : id_Maps_of_sprite.Map;
+      end record;
+
+   overriding
+   function  fetch (From : in     sprite_Map) return id_Maps_of_sprite.Map;
+
+   overriding
+   procedure add   (To   : in out sprite_Map;   the_Sprite : in Sprite.view);
+
+   overriding
+   procedure rid   (From : in out sprite_Map;   the_Sprite : in Sprite.view);
+
+
+   --------------
+   --- World Item
+   --
+   type Item is limited new gel.World.item with
+      record
+         Age_at_last_Clients_update : Duration := 0.0;
+         Clients                    : World_vector;
+
+         all_Sprites : aliased sprite_Map;
+      end record;
+
+
+   overriding
+   function all_Sprites (Self : access Item) return access World.sprite_Map'Class;
+
+
+end gel.World.server;

4-high/gel/source/world/gel-world-simple.adb

@@ -0,0 +1,130 @@
+with
+     physics.Forge,
+     openGL.Renderer.lean;
+
+
+package body gel.World.simple
+is
+   --  procedure log (Message : in String)
+   --                 renames ada.text_IO.put_Line;
+
+
+   ---------
+   --- Forge
+   --
+
+   --  procedure free (Self : in out View)
+   --  is
+   --     procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
+   --  begin
+   --     deallocate (Self);
+   --  end free;
+
+
+
+   procedure define (Self : in out Item'Class;   Name       : in     String;
+                                                 Id         : in     world_Id;
+                                                 space_Kind : in     physics.space_Kind;
+                                                 Renderer   : access openGL.Renderer.lean.item'Class);
+
+   package body Forge
+   is
+
+      function to_World (Name       : in     String;
+                         Id         : in     world_Id;
+                         space_Kind : in     physics.space_Kind;
+                         Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.simple.item
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+      begin
+         return Self : gel.World.simple.item := (to_Subject_and_Observer (Name => Name & " world" & Id'Image)
+                                                 with others => <>)
+         do
+            Self.define (Name, Id, space_Kind, Renderer);
+         end return;
+      end to_World;
+
+
+
+      function new_World (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.simple.view
+      is
+         use lace.Subject_and_deferred_Observer.Forge;
+
+         Self : constant gel.World.simple.view
+           := new gel.World.simple.item' (to_Subject_and_Observer (name => Name & " world" & Id'Image)
+                                              with others => <>);
+      begin
+         Self.define (Name, Id, space_Kind, Renderer);
+         return Self;
+      end new_World;
+
+   end Forge;
+
+
+
+   ----------
+   --- Define
+   --
+
+   procedure define  (Self : in out Item'Class;   Name       : in     String;
+                                                  Id         : in     world_Id;
+                                                  space_Kind : in     physics.space_Kind;
+                                                  Renderer   : access openGL.Renderer.lean.Item'Class)
+   is
+      use lace.Subject_and_deferred_Observer.Forge;
+   begin
+      Self.local_Subject_and_deferred_Observer := new_Subject_and_Observer (name => Name & " world" & Id'Image);
+
+      Self.Id           := Id;
+      Self.space_Kind   := space_Kind;
+      Self.Renderer     := Renderer;
+      --  Self.sprite_Count := 0;
+
+      Self.physics_Space := physics.Forge.new_Space (space_Kind);
+   end define;
+
+
+
+   --------------
+   --- sprite_Map
+   --
+
+   overriding
+   function fetch (From : in sprite_Map) return id_Maps_of_sprite.Map
+   is
+   begin
+      return From.Map;
+   end fetch;
+
+
+
+   overriding
+   procedure add (To : in out sprite_Map;   the_Sprite : in Sprite.view)
+   is
+   begin
+      To.Map.insert (the_Sprite.Id, the_Sprite);
+   end add;
+
+
+
+   overriding
+   procedure rid (From : in out sprite_Map;   the_Sprite : in Sprite.view)
+   is
+   begin
+      From.Map.delete (the_Sprite.Id);
+   end rid;
+
+
+
+   overriding
+   function all_Sprites (Self : access Item) return access World.sprite_Map'Class
+   is
+   begin
+      return Self.all_Sprites'unchecked_Access;
+   end all_Sprites;
+
+
+end gel.World.simple;

4-high/gel/source/world/gel-world-simple.ads

@@ -0,0 +1,73 @@
+with
+     ada.unchecked_Conversion;
+
+limited
+with
+     openGL.Renderer.lean;
+
+
+package gel.World.simple
+--
+--  Provides a simple gel world.
+--
+is
+   type Item  is limited new gel.World.item
+   with private;
+
+   type View  is access all Item'Class;
+   type Views is array (Positive range <>) of View;
+
+
+   ---------
+   --  Forge
+   --
+
+   package Forge
+   is
+      function to_World  (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.simple.item;
+
+      function new_World (Name       : in     String;
+                          Id         : in     world_Id;
+                          space_Kind : in     physics.space_Kind;
+                          Renderer   : access openGL.Renderer.lean.item'Class) return gel.World.simple.view;
+   end Forge;
+
+
+
+private
+
+   --------------
+   --- sprite_Map
+   --
+   type sprite_Map is limited new World.sprite_Map with
+      record
+         Map : id_Maps_of_sprite.Map;
+      end record;
+
+   overriding
+   function  fetch (From : in     sprite_Map) return id_Maps_of_sprite.Map;
+
+   overriding
+   procedure add   (To   : in out sprite_Map;   the_Sprite : in Sprite.view);
+
+   overriding
+   procedure rid   (From : in out sprite_Map;   the_Sprite : in Sprite.view);
+
+
+   --------------
+   --- World Item
+   --
+   type Item is limited new gel.World.item with
+      record
+         all_Sprites : aliased sprite_Map;
+      end record;
+
+
+   overriding
+   function all_Sprites (Self : access Item) return access World.sprite_Map'Class;
+
+
+end gel.World.simple;

4-high/gel/source/world/gel-world.ads

@@ -0,0 +1,452 @@
+with
+     gel.remote.World,
+     gel.Sprite,
+     gel.Joint,
+
+     openGL.Model,
+
+     physics.Space,
+     physics.Model,
+
+     lace.Event,
+     lace.Observer,
+     lace.Subject,
+     lace.Subject_and_deferred_Observer,
+     lace.Any,
+
+     ada.Tags.generic_dispatching_Constructor,
+     ada.unchecked_Conversion,
+     ada.Containers.hashed_Maps;
+
+limited
+with
+     openGL.Renderer.lean;
+
+
+package gel.World
+--
+--  Provides a gel world.
+--
+is
+   type Item  is abstract limited new lace.Subject_and_deferred_Observer.item
+                                  and gel.remote.World.item
+   with private;
+
+   type View  is access all Item'Class;
+   type Views is array (Positive range <>) of View;
+
+   use Math;
+
+
+   ---------
+   --  Forge
+   --
+
+   overriding
+   procedure destroy (Self : in out Item);
+   procedure free    (Self : in out View);
+
+
+   --------------
+   --  Attributes
+   --
+
+   function  local_Observer  (Self : in     Item)     return lace.Observer.view;
+   function  local_Subject   (Self : in     Item)     return lace.Subject .view;
+
+   function  Id              (Self : in     Item)     return world_Id;
+
+   function  Age             (Self : in     Item)     return Duration;
+   procedure Age_is          (Self : in out Item;   Now : in Duration);
+
+   procedure Gravity_is      (Self : in out Item;   Now : in Vector_3);
+
+   function  space_Kind      (Self : in     Item)     return physics.space_Kind;
+   function  Space           (Self : in     Item)     return physics.Space.view;
+
+   procedure update_Bounds   (Self : in out Item;   of_Sprite : in gel.Sprite.view);
+   procedure update_Site     (Self : in out Item;   of_Sprite : in gel.Sprite.view;
+                                                    To        : in Vector_3);
+   procedure update_Scale    (Self : in out Item;   of_Sprite : in gel.Sprite.view;
+                                                    To        : in Vector_3);
+
+   procedure set_Speed       (Self : in out Item;   of_Sprite : in gel.Sprite.view;
+                                                    To        : in Vector_3);
+   procedure set_xy_Spin     (Self : in out Item;   of_Sprite : in gel.Sprite.view;
+                                                    To        : in Radians);
+
+   procedure apply_Force     (Self : in out Item;   to_Sprite : in gel.Sprite.view;
+                                                    Force     : in Vector_3);
+
+   -----------
+   --  Sprites
+   --
+   function  new_sprite_Id   (Self : access Item)                                    return sprite_Id;
+   function  free_sprite_Set (Self : access Item)                                    return gel.Sprite.views;
+   function  fetch_Sprite    (Self : in out Item'Class;   Id         : in sprite_Id) return gel.Sprite.view;
+   procedure destroy         (Self : in out Item;         the_Sprite : in gel.Sprite.view);
+   procedure set_Scale       (Self : in out Item;         for_Sprite : in gel.Sprite.view;
+                                                          To         : in Vector_3);
+
+   ---------------------
+   --- id_Maps_of_sprite
+   --
+   use type Sprite.view;
+   function Hash              is new ada.unchecked_Conversion   (gel.sprite_Id, ada.Containers.Hash_type);
+   package  id_Maps_of_sprite is new ada.Containers.hashed_Maps (gel.sprite_Id,  gel.Sprite.view,
+                                                                 Hash            => Hash,
+                                                                 equivalent_Keys => "=");
+   --------------
+   --- sprite_Map
+   --
+
+   type sprite_Map is abstract tagged limited null record;
+
+   function  fetch (From : in     sprite_Map) return id_Maps_of_sprite.Map   is abstract;
+   procedure add   (To   : in out sprite_Map;   the_Sprite : in Sprite.view) is abstract;
+   procedure rid   (From : in out sprite_Map;   the_Sprite : in Sprite.view) is abstract;
+
+
+   function all_Sprites (Self : access Item) return access sprite_Map'Class is abstract;
+
+
+
+   type sprite_transform_Pair is
+      record
+         Sprite    : gel.Sprite.view;
+         Transform : Matrix_4x4;
+      end record;
+
+   type sprite_transform_Pairs is array (Positive range <>) of sprite_transform_Pair;
+
+   function  sprite_Transforms (Self : in out Item'Class) return sprite_transform_Pairs;
+
+
+   ----------
+   --- Joints
+   --
+
+   procedure destroy               (Self : in out Item;   the_Joint : in gel.Joint.view);
+
+   procedure set_local_Anchor_on_A (Self : in out Item;   for_Joint : in gel.Joint.view;
+                                                          To        : in Vector_3);
+   procedure set_local_Anchor_on_B (Self : in out Item;   for_Joint : in gel.Joint.view;
+                                                          To        : in Vector_3);
+
+   --------------
+   --- Collisions
+   --
+
+   type a_Contact is
+      record
+         Site : Vector_3;
+      end record;
+
+   type Contacts is array (Positive range 1 .. 4) of a_Contact;
+
+
+   type a_Manifold is
+      record
+         Sprites : Sprite.views (1 .. 2);
+         Contact : a_Contact;
+      end record;
+
+   type Manifold_array is array (Positive range <>) of a_Manifold;
+
+
+   function manifold_Count (Self : in     Item)                           return Natural;
+   function Manifold       (Self : in     Item;   Index : in    Positive) return a_Manifold;
+   function Manifolds      (Self : in     Item)                           return Manifold_array;
+
+
+   type impact_Filter   is access function  (the_Manifold : in a_Manifold) return Boolean;
+   --
+   --  Returns True if the impact is of interest and requires a response.
+
+   type impact_Response is access procedure (the_Manifold : in a_Manifold;
+                                             the_World    : in World.view);
+
+   procedure add_impact_Response (Self : in out Item;   Filter   : in impact_Filter;
+                                                        Response : in impact_Response);
+
+   --------------
+   --- Operations
+   --
+
+   evolve_Period : constant Duration;
+
+   procedure add    (Self : in out Item;         the_Model    : in openGL .Model.view);
+   procedure add    (Self : in out Item;         the_Model    : in physics.Model.view);
+
+   procedure add    (Self : access Item;         the_Sprite   : in gel.Sprite.view;
+                                                 and_Children : in Boolean := False);
+
+   procedure add    (Self : in out Item;         the_Joint    : in gel.Joint.view);
+
+   procedure rid    (Self : in out Item'Class;   the_Sprite   : in gel.Sprite.view;
+                                                 and_Children : in Boolean := False);
+   procedure rid    (Self : in out Item;         the_Joint    : in gel.Joint.view);
+
+   procedure start  (Self : access Item);
+   procedure evolve (Self : in out Item);
+
+
+   ----------
+   --- Joints
+   --
+
+   procedure  allow_broken_Joints (Self :    out Item);
+   procedure handle_broken_Joints (Self : in out Item;   the_Joints   : in Joint.views);
+   --
+   -- Detaches any broken joints from associated sprites.
+   -- Override this to do custom handling of broken joints.
+   -- TODO: This should be in private section and only available to child packages.
+
+
+   ---------------
+   --- Ray Casting
+   --
+
+   type ray_Collision is
+      record
+         near_Sprite  : gel.Sprite.view;
+         hit_Fraction : Real;
+         Normal_world : Vector_3;
+         Site_world   : Vector_3;
+      end record;
+
+
+   type Any_limited_view is access all lace.Any.limited_item'Class;
+
+   type raycast_collision_Event is new lace.Event.item with
+      record
+         near_Sprite : gel.Sprite.view;
+         Context     : Any_limited_view;
+         Site_world  : Vector_3;
+      end record;
+
+   overriding
+   procedure destruct (Self : in out raycast_collision_Event);
+
+
+   type no_Parameters is null record;
+
+   function to_raycast_collision_Event (Params : not null access no_Parameters) return raycast_collision_Event;
+
+   function raycast_collision_Event_dispatching_Constructor is new ada.Tags.generic_dispatching_Constructor (raycast_collision_Event,
+                                                                                                             Parameters  => no_Parameters,
+                                                                                                             Constructor => to_raycast_collision_Event);
+   procedure cast_Ray (Self : in Item;   From, To   : in     Vector_3;
+                                         Observer   : in     lace.Observer.view;
+                                         Context    : access lace.Any.limited_Item'Class;
+                                         Event_Kind : in     raycast_collision_Event'Class);
+   --
+   -- Casts a ray between From and To.
+   -- The Observer is informed of the 1st collision with a Sprite via a raycast_collision_Event.
+   -- Context is optional and is passed back to the Observer within the Context field of the raycast_collision_Event
+   -- for use by the raycast_collision_Event response.
+
+
+   --------------------
+   ---  World Mirroring
+   --
+
+   interpolation_Steps  : constant Natural;
+
+   overriding
+   procedure   register (Self : access Item;   the_Mirror         : in remote.World.view;
+                                               Mirror_as_observer : in lace.Observer.view);
+   overriding
+   procedure deregister (Self : access Item;   the_Mirror         : in remote.World.view);
+
+   overriding
+   procedure motion_Updates_are (Self : in Item;   Now : in remote.World.motion_Updates);
+   --
+   --  'Self' must use 'in' as mode to ensure async transmission with DSA.
+
+
+   overriding
+   function  graphics_Models (Self : in Item) return remote.World.graphics_Model_Set;
+   overriding
+   function  physics_Models  (Self : in Item) return remote.World.physics_Model_Set;
+   overriding
+   function  Sprites         (Self : in out Item) return remote.World.sprite_model_Pairs;
+
+
+   ----------
+   --- Models
+   --
+
+   --  Graphics Models
+   --
+   use type openGL.Model.view;
+   use type gel.graphics_model_Id;
+   function Hash             is new ada.unchecked_Conversion   (gel.graphics_model_Id,  ada.Containers.Hash_type);
+   package  id_Maps_of_model is new ada.Containers.hashed_Maps (gel.graphics_model_Id,  openGL.Model.view,
+                                                                Hash,                   "=");
+
+   function local_graphics_Models (Self : in Item) return id_Maps_of_model.Map;
+
+
+   --  Physics Models
+   --
+   use type Standard.physics.Model.view,
+            Standard.physics.model_Id;
+   function Hash                     is new ada.unchecked_Conversion   (physics.model_Id,  ada.Containers.Hash_type);
+   package  id_Maps_of_physics_model is new ada.Containers.hashed_Maps (physics.model_Id,  physics.Model.view,
+                                                                        Hash,              "=");
+
+   function local_physics_Models (Self : in Item) return id_Maps_of_physics_model.Map;
+
+
+   ------------------
+   ---  Testing/Debug
+   --
+   overriding
+   procedure kick_Sprite (Self : in out Item;   sprite_Id : in gel.Sprite_Id);
+
+
+
+private
+
+   type Hertz is new Real;
+
+   evolve_Hz            : constant Hertz    := 60.0;
+   client_update_Hz     : constant Hertz    :=  4.0;
+
+   evolve_Period        : constant Duration := 1.0 / Duration (evolve_Hz);
+   client_update_Period : constant Duration := 1.0 / Duration (client_update_Hz);
+
+   interpolation_Steps  : constant Natural  := Positive (evolve_Hz / client_update_Hz);
+
+
+   -----------------
+   --- Signal Object
+   --
+   protected
+   type signal_Object
+   is
+      entry     wait;
+      procedure signal;
+
+   private
+      Open : Boolean := False;
+   end signal_Object;
+
+   type signal_Object_view is access all signal_Object;
+
+
+   -----------------------------
+   --- sprite_Maps_of_transforms
+   --
+   function Hash is new ada.unchecked_Conversion (gel.Sprite.view, ada.Containers.Hash_type);
+   package  sprite_Maps_of_transforms is new ada.Containers.hashed_Maps (Sprite.view,  Matrix_4x4,
+                                                                         Hash            => Hash,
+                                                                         equivalent_Keys => "=");
+   -------------------------
+   --- all_sprite_Transforms
+   --
+   protected
+   type all_sprite_Transforms
+   is
+      procedure add (the_Sprite : in Sprite.view;
+                     Transform  : in Matrix_4x4);
+
+      procedure set (To : in sprite_Maps_of_transforms.Map);
+      function  fetch return sprite_Maps_of_transforms.Map;
+
+   private
+      sprite_Map_of_transforms : sprite_Maps_of_transforms.Map;
+   end all_sprite_Transforms;
+
+
+   -----------------
+   --- Duration_safe
+   --
+   protected
+   type Duration_safe
+   is
+      procedure Duration_is (Now : in Duration);
+      function  Duration       return Duration;
+
+   private
+      the_Duration : standard.Duration;
+   end Duration_safe;
+
+
+
+   type free_Set is
+      record
+         Sprites  : gel.Sprite.views (1 .. 10_000);
+         Count    : Natural := 0;
+      end record;
+
+   type free_Sets is array (1 .. 2) of free_Set;
+
+
+   ---------------
+   --- safe_Joints
+   --
+
+   subtype safe_Joints is gel.Joint.views (1 .. 10_000);
+
+   protected
+   type safe_joint_Set
+   is
+      function  is_Empty return Boolean;
+
+      procedure add   (the_Joint : in     gel.Joint.view);
+      procedure Fetch (To        :    out safe_Joints;
+                       Count     :    out Natural);
+   private
+      Set       : safe_Joints;
+      the_Count : Natural := 0;
+   end safe_joint_Set;
+
+
+   --------------
+   --- World Item
+   --
+
+   type Item is abstract limited new lace.Subject_and_deferred_Observer.item
+                                 and gel.remote.World.item with
+      record
+         local_Subject_and_deferred_Observer : lace.Subject_and_deferred_Observer.view;
+
+         Id  : world_Id;
+         Age : Duration := 0.0;
+
+         space_Kind      :         physics.space_Kind;
+         physics_Space   : aliased physics.Space.view;
+
+         Renderer        : access  openGL.Renderer.lean.item'Class;         -- Is *not* owned by Item.
+
+         --  Models
+         --
+         graphics_Models : aliased id_Maps_of_model        .Map;
+         physics_Models  : aliased id_Maps_of_physics_model.Map;
+
+         --  Ids
+         --
+         last_used_sprite_Id        : gel.sprite_Id         := 0;
+         last_used_model_Id         : gel.graphics_model_Id := 0;
+         last_used_physics_model_Id : physics     .model_Id := 0;
+
+         --  Free Sets
+         --
+         free_Sets        : World.free_Sets;
+         current_free_Set : Integer := 2;
+
+         --  Collisions
+         --
+         Manifolds      : Manifold_array (1 .. 50_000);
+         manifold_Count : Natural := 0;
+
+         -- Broken Joints
+         --
+         broken_Joints         : safe_joint_Set;
+         broken_joints_Allowed : Boolean := False;
+      end record;
+
+
+end gel.World;