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

gel.world: Work on server and client worlds.

Browse Source
This commit is contained in:
Rod Kay
2024-10-16 19:36:46 +11:00
parent 3077f2a4cd
commit ad2f92b791
10 changed files with 48 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
4-high/gel/source/applet/gel-applet.ads
View File

@@ -137,7 +137,7 @@ is
private private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
use type Sprite.view; use type Sprite.view;
package sprite_Vectors is new ada.containers.Vectors (Positive, Sprite.view); package sprite_Vectors is new ada.containers.Vectors (Positive, Sprite.view);

2
4-high/gel/source/gel-sprite.ads
View File

@@ -49,7 +49,7 @@ is
--- Containers --- Containers
-- --
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Grid is array (math.Index range <>, type Grid is array (math.Index range <>,
math.Index range <>) of Sprite.view; math.Index range <>) of Sprite.view;

2
4-high/gel/source/gel-window.ads
View File

@@ -110,7 +110,7 @@ private
type String_view is access all String; type String_view is access all String;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is limited new lace.Subject_and_deferred_Observer.item with type Item is limited new lace.Subject_and_deferred_Observer.item with
record record

11
4-high/gel/source/remote/gel-remote-world.ads
View File

@@ -20,7 +20,7 @@ package gel.remote.World
-- --
is is
pragma remote_Types; pragma remote_Types;
pragma suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is limited interface type Item is limited interface
and lace.Subject .item and lace.Subject .item
@@ -180,6 +180,9 @@ is
------------------------------
--- Sprite add and rid events.
--
type sprite_added_Event is new lace.Event.item with type sprite_added_Event is new lace.Event.item with
record record
@@ -187,6 +190,12 @@ is
end record; end record;
type sprite_ridded_Event is new lace.Event.item with
record
Sprite : gel.sprite_Id;
end record;
-------------- --------------
-- Test/Debug -- Test/Debug

32
4-high/gel/source/world/gel-world-client.adb
View File

@@ -302,13 +302,10 @@ is
Self.graphics_Models.all, Self.graphics_Models.all,
Self. physics_Models.all, Self. physics_Models.all,
Self.World); Self.World);
added_Event : gel.remote.World.sprite_added_Event;
begin begin
log ("*** gel.world.client.my_new_sprite_Response.add sprite ~ " & the_Sprite.Name'Image);
Self.World.add (the_Sprite); Self.World.add (the_Sprite);
-- Self.World.emit (sprite_added_Event' (Sprite => the_Sprite.Id)); Self.World.emit (remote.world.sprite_added_Event' (Sprite => the_Sprite.Id));
added_Event.Sprite := the_Sprite.Id;
Self.World.emit (added_Event);
end; end;
end respond; end respond;
@@ -373,6 +370,7 @@ is
-- Self.World); -- Self.World);
begin begin
Self.World.rid (Self.World.fetch_Sprite (the_Event.Id)); Self.World.rid (Self.World.fetch_Sprite (the_Event.Id));
Self.World.emit (remote.world.sprite_ridded_Event' (Sprite => the_Event.Id));
end; end;
end respond; end respond;
@@ -512,7 +510,7 @@ is
-- end sprite_Fetcher; -- end sprite_Fetcher;
the_server_Sprites : remote.World.sprite_model_Pairs := of_World.Sprites; the_server_Sprites : constant remote.World.sprite_model_Pairs := of_World.Sprites;
begin begin
@@ -569,6 +567,7 @@ is
Self.graphics_Models, Self.graphics_Models,
Self. physics_Models, Self. physics_Models,
gel.World.view (Self)); gel.World.view (Self));
log ("*** gel.world.client.is_a_Mirror.add sprite ~ " & the_Sprite.Name'Image);
Self.add (the_Sprite); Self.add (the_Sprite);
end loop; end loop;
end; end;
@@ -588,15 +587,22 @@ is
procedure add (Self : access Item; the_Sprite : in gel.Sprite.view; procedure add (Self : access Item; the_Sprite : in gel.Sprite.view;
and_Children : in Boolean := False) and_Children : in Boolean := False)
is is
added_Event : gel.remote.World.sprite_added_Event; -- added_Event : gel.remote.World.sprite_added_Event;
begin begin
log ("gel.world.client.add (sprite and children)" & the_Sprite.Name & the_Sprite.Id'Image); log ("gel.world.client.add (sprite and children) " & the_Sprite.Name & the_Sprite.Id'Image);
gel.World.item (Self.all).add (the_Sprite); -- Do base class. gel.World.item (Self.all).add (the_Sprite, and_Children); -- Do base class.
Self.all_Sprites.Map.add (the_Sprite); -- Self.all_Sprites.Map.add (the_Sprite);
added_Event.Sprite := the_Sprite.Id; -- added_Event.Sprite := the_Sprite.Id;
Self.emit (added_Event);
-- log ("****** gel.world.client.add " & the_Sprite.Name);
-- if the_Sprite.Id /= 50000000
-- then
-- raise Program_Error;
-- end if;
-- Self.emit (added_Event);
end add; end add;
@@ -803,6 +809,8 @@ is
procedure add (the_Sprite : in Sprite.view) procedure add (the_Sprite : in Sprite.view)
is is
begin begin
log ("safe_id_Map_of_sprite" & the_Sprite.Id'Image);
-- raise Program_Error;
Map.insert (the_Sprite.Id, Map.insert (the_Sprite.Id,
the_Sprite); the_Sprite);
end add; end add;

2
4-high/gel/source/world/gel-world-client.ads
View File

@@ -8,7 +8,7 @@ package gel.World.client
-- Provides a gel world. -- Provides a gel world.
-- --
is is
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is limited new gel.World.item with private; type Item is limited new gel.World.item with private;

2
4-high/gel/source/world/gel-world-server.ads
View File

@@ -12,7 +12,7 @@ package gel.World.server
-- Provides a gel world server. -- Provides a gel world server.
-- --
is is
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is limited new gel.World.item type Item is limited new gel.World.item
with private; with private;

2
4-high/gel/source/world/gel-world-simple.ads
View File

@@ -11,7 +11,7 @@ package gel.World.simple
-- Provides a simple gel world. -- Provides a simple gel world.
-- --
is is
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is limited new gel.World.item type Item is limited new gel.World.item
with private; with private;

11
4-high/gel/source/world/gel-world.adb
View File

@@ -597,6 +597,14 @@ is
function sprite_Exists (Self : in out Item'Class; Id : in sprite_Id) return Boolean
is
begin
return Self.all_Sprites.fetch.Contains (Id);
end sprite_Exists;
procedure set_Scale (Self : in out Item; for_Sprite : in gel.Sprite.view; procedure set_Scale (Self : in out Item; for_Sprite : in gel.Sprite.view;
To : in Vector_3) To : in Vector_3)
is is
@@ -830,7 +838,8 @@ is
-- Emit a new model event. -- Emit a new model event.
-- --
-- log ("gel.World.add ~ emit new physics model event"); log ("gel.World.add ~ emit new physics model event");
declare declare
the_Event : remote.World.new_physics_model_Event; the_Event : remote.World.new_physics_model_Event;
begin begin

3
4-high/gel/source/world/gel-world.ads
View File

@@ -29,7 +29,7 @@ package gel.World
-- Provides a gel world. -- Provides a gel world.
-- --
is is
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. -- pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is abstract limited new lace.Subject_and_deferred_Observer.item type Item is abstract limited new lace.Subject_and_deferred_Observer.item
@@ -92,6 +92,7 @@ is
function new_sprite_Id (Self : access Item) return sprite_Id; function new_sprite_Id (Self : access Item) return sprite_Id;
function free_sprite_Set (Self : access Item) return gel.Sprite.views; 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; function fetch_Sprite (Self : in out Item'Class; Id : in sprite_Id) return gel.Sprite.view;
function sprite_Exists (Self : in out Item'Class; Id : in sprite_Id) return Boolean;
procedure destroy (Self : in out Item; the_Sprite : in 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; procedure set_Scale (Self : in out Item; for_Sprite : in gel.Sprite.view;
To : in Vector_3); To : in Vector_3);