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

Add initial prototype.

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

546
4-high/gel/source/world/gel-world-client.adb Normal file
View File

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

114
4-high/gel/source/world/gel-world-client.ads Normal file
View File

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

292
4-high/gel/source/world/gel-world-server.adb Normal file
View File

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

104
4-high/gel/source/world/gel-world-server.ads Normal file
View File

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

130
4-high/gel/source/world/gel-world-simple.adb Normal file
View File

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

73
4-high/gel/source/world/gel-world-simple.ads Normal file
View File

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

1704
4-high/gel/source/world/gel-world.adb Normal file
View File

File diff suppressed because it is too large Load Diff

452
4-high/gel/source/world/gel-world.ads Normal file
View File

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