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

lace.events: Optimise.

Browse Source
This commit is contained in:
Rod Kay
2023-12-08 14:42:45 +11:00
parent f12686d233
commit dbe487c074
29 changed files with 275 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
1-base/lace/source/events/concrete/lace-observer-deferred.ads
View File

@@ -33,6 +33,9 @@ is
private
use ada.Strings.unbounded;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Observer is new lace.make_Observer (Any.limited_item);
package Deferred is new Observer.deferred (Observer.item);

3
1-base/lace/source/events/concrete/lace-observer-instant.ads
View File

@@ -32,6 +32,9 @@ is
private
use ada.Strings.unbounded;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Observer is new make_Observer (Any.limited_item);
type Item is limited new Observer.item with

3
1-base/lace/source/events/concrete/lace-subject-local.ads
View File

@@ -36,6 +36,9 @@ private
use ada.Strings.unbounded;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Subject is new make_Subject (Any.limited_item);
type Item is limited new Subject.item with

3
1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads
View File

@@ -39,6 +39,9 @@ is
private
use ada.Strings.unbounded;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Subject is new make_Subject (Any.limited_item);
package Observer is new make_Observer (Subject .item);
package Deferred is new Observer.deferred (Observer .item);

3
1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads
View File

@@ -36,6 +36,9 @@ is
private
use ada.Strings.unbounded;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Subject is new make_Subject (Any.limited_item);
package Observer is new make_Observer (Subject .item);

4
1-base/lace/source/events/mixin/lace-make_observer.ads
View File

@@ -56,6 +56,10 @@ is
private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
----------------------
-- Event response maps
--

3
1-base/lace/source/events/mixin/lace-make_subject.ads
View File

@@ -58,6 +58,9 @@ is
private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
-------------------------
-- Event observer vectors
--

2
1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.ads
View File

@@ -40,6 +40,8 @@ is
private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
----------------
-- Event Vectors
--

10
1-base/lace/source/text/lace-text-forge.adb
View File

@@ -11,7 +11,7 @@ is
-- Files
--
function to_String (Filename : in forge.Filename) return String
function File_to_String (Filename : in forge.Filename) return String
is
use ada.Characters,
ada.Directories;
@@ -47,15 +47,15 @@ is
end loop;
return Result (1 .. i);
end to_String;
end File_to_String;
function to_Text (Filename : in forge.Filename) return Item
function File_to_Text (Filename : in forge.Filename) return Item
is
begin
return to_Text (to_String (Filename));
end to_Text;
return to_Text (File_to_String (Filename));
end File_to_Text;

4
1-base/lace/source/text/lace-text-forge.ads
View File

@@ -10,8 +10,8 @@ is
type Filename is new String;
function to_String (Filename : in forge.Filename) return String; -- Converts 'CR & LF' to 'LF' at the end of a line.
function to_Text (Filename : in forge.Filename) return Item; -- Converts 'CR & LF' to 'LF' at the end of a line.
function File_to_String (Filename : in forge.Filename) return String; -- Converts 'CR & LF' to 'LF' at the end of a line.
function File_to_Text (Filename : in forge.Filename) return Item; -- Converts 'CR & LF' to 'LF' at the end of a line.
procedure store (Filename : in forge.Filename; the_String : in String);

2
3-mid/opengl/source/opengl-errors.adb
View File

@@ -20,7 +20,7 @@ is
when GL_INVALID_VALUE => return "invalid Value";
when GL_INVALID_OPERATION => return "invalid Operation";
when GL_OUT_OF_MEMORY => return "out of Memory";
when others => return "unknown openGL error detected";
when others => return "unknown openGL error detected (Code:" & the_Error'Image & ")";
end case;
end Current;

6
4-high/gel/source/applet/distributed/gel-applet-client_world.adb
View File

@@ -29,9 +29,9 @@ is
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);
-- 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;

6
4-high/gel/source/applet/distributed/gel-applet-server_world.adb
View File

@@ -29,9 +29,9 @@ is
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);
-- 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;

20
4-high/gel/source/applet/gel-applet-gui_and_sim_world.adb
View File

@@ -24,8 +24,8 @@ is
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_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);
@@ -34,9 +34,9 @@ is
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);
-- 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;
@@ -49,8 +49,8 @@ is
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_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);
@@ -59,9 +59,9 @@ is
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);
-- 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;

6
4-high/gel/source/applet/gel-applet-gui_world.adb
View File

@@ -30,9 +30,9 @@ is
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);
-- 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;

12
4-high/gel/source/applet/gel-applet.adb
View File

@@ -55,14 +55,14 @@ is
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_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
log ("gel.applet.add_new_Sprite.respond");
the_Sprite := Self.Applet.World (the_Event.World_Id).fetch_Sprite (the_event.Sprite_Id);
-- 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);
@@ -276,9 +276,9 @@ is
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);
-- 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);

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

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

19
4-high/gel/source/forge/gel-forge.adb
View File

@@ -1,6 +1,8 @@
with
openGL.Model.text .lit_colored,
openGL.Model.circle .lit_textured,
openGL.Model.sphere .lit_colored_textured,
openGL.Model.sphere .lit_colored,
openGL.Model.sphere .textured,
@@ -20,7 +22,8 @@ with
openGL.Model.segment_line,
physics.Model,
gel.Window;
gel.Window,
float_Math.Random;
package body gel.Forge
@@ -132,7 +135,7 @@ is
use openGL;
use type Vector_2;
the_graphics_Model : openGL.Model.sphere.view;
the_graphics_Model : openGL.Model.view;
the_physics_Model : constant physics.Model.view
:= physics.Model.Forge.new_physics_Model (shape_Info => (physics.Model.Circle, Radius),
@@ -146,14 +149,18 @@ is
the_graphics_Model := openGL.Model.sphere.lit_colored.new_Sphere (Radius,
Color => (Color, Opaque)).all'Access;
else
the_graphics_Model := openGL.Model.sphere.lit_colored_textured.new_Sphere (Radius,
Color => (Color, Opaque),
Image => Texture).all'Access;
-- the_graphics_Model := openGL.Model.sphere.lit_colored_textured.new_Sphere (Radius,
-- Color => (Color, Opaque),
-- Image => Texture).all'Access;
the_graphics_Model := openGL.Model.circle.lit_textured.new_Circle (Radius,
Face => (Fades => (1 => 0.0, others => <>),
Textures => (1 => Texture, others => <>),
texture_Count => 1)).all'Access;
end if;
return gel.Sprite.Forge.new_Sprite ("circle_Sprite",
sprite.World_view (in_World),
Vector_3 (Site & 0.0),
Vector_3 (Site & float_Math.Random.random_Real (Lower => 0.0, Upper => 1.1)),
the_graphics_Model,
the_physics_Model,
owns_graphics => True,

24
4-high/gel/source/gel-events.ads
View File

@@ -48,22 +48,28 @@ is
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 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
type rid_sprite_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;
Id : gel.sprite_Id;
end record;

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

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

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

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

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

@@ -19,6 +19,7 @@ package gel.remote.World
--
is
pragma remote_Types;
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is limited interface
and lace.Subject .item

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

@@ -158,15 +158,16 @@ is
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;
raise Program_Error with "KKK";
-- 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;
@@ -299,8 +300,8 @@ is
log ("gel.world.client.my_new_Sprite.respond");
declare
the_Event : constant gel.Events.my_new_sprite_added_to_world_Event
:= gel.events.my_new_sprite_added_to_world_Event (to_Event);
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,
@@ -320,9 +321,9 @@ is
physics_Models : access id_Maps_of_physics_model.Map)
is
begin
Self.World := World;
Self.graphics_Models := Models;
Self.physics_Models := physics_Models;
Self.World := World;
Self.graphics_Models := Models;
Self.physics_Models := physics_Models;
end define;
@@ -339,6 +340,74 @@ is
--------------------------
--- my_rid_sprite_Response
--
type my_rid_sprite_Response is new lace.Response.item with
record
World : gel.World.view;
graphics_Models : access id_Maps_of_graphics_model.Map;
physics_Models : access id_Maps_of_physics_model .Map;
end record;
overriding
function Name (Self : in my_rid_sprite_Response) return String;
overriding
procedure respond (Self : in out my_rid_sprite_Response; to_Event : in lace.Event.Item'Class)
is
begin
log ("gel.world.client.my_rid_Sprite.respond");
declare
the_Event : constant gel.Events.rid_sprite_Event
:= gel.events.rid_sprite_Event (to_Event);
-- the_Sprite : constant gel.Sprite.view
-- := to_Sprite (the_Event.Pair,
-- Self.graphics_Models.all,
-- Self.physics_Models.all,
-- Self.World);
begin
Self.World.rid (Self.World.fetch_Sprite (the_Event.Id));
end;
end respond;
procedure define (Self : in out my_rid_sprite_Response; World : in gel.World.view;
Models : access id_Maps_of_graphics_model.Map;
physics_Models : access id_Maps_of_physics_model.Map)
is
begin
Self.World := World;
Self.graphics_Models := Models;
Self.physics_Models := physics_Models;
end define;
overriding
function Name (Self : in my_rid_sprite_Response) return String
is
pragma unreferenced (Self);
begin
return "my_rid_sprite_Response";
end Name;
the_my_rid_sprite_Response : aliased my_rid_sprite_Response;
-------------------
--- World Mirroring
--
type graphics_Model_iface_view is access all openGL .remote_Model.item'Class;
type physics_Model_iface_view is access all physics.remote.Model.item'Class;
@@ -370,7 +439,17 @@ is
physics_Models => Self. physics_Models'Access);
Self.add (the_my_new_sprite_Response'Access,
to_Kind (gel.Events.my_new_sprite_added_to_world_Event'Tag),
to_Kind (gel.Events.new_sprite_Event'Tag),
from_Subject => of_World.Name);
-- Rid sprite response.
--
define (the_my_rid_sprite_Response, World => Self.all'Access,
Models => Self.graphics_Models'Access,
physics_Models => Self. physics_Models'Access);
Self.add (the_my_rid_sprite_Response'Access,
to_Kind (gel.Events.rid_sprite_Event'Tag),
from_Subject => of_World.Name);
-- Obtain and make a local copy of graphics_Models, sprites and humans from the mirrored world.
@@ -455,50 +534,56 @@ is
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;
the_Id : gel.sprite_Id;
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.
the_Id := Now (i).Id;
null;
declare
use remote.World;
-- the_Sprite.Site_is (new_Site);
-- the_Sprite.Spin_is (to_Rotation (Axis => new_Spin.V,
-- Angle => new_Spin.R));
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;
-- the_Sprite.Spin_is (to_Matrix (to_Quaternion (new_Spin)));
new_Spin : constant Quaternion := refined (Now (i).Spin);
-- new_Spin : constant Matrix_3x3 := Now (i).Spin;
-- the_Sprite.desired_Dynamics_are (Site => new_Site,
-- Spin => to_Quaternion (new_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.
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);
-- 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;
exception
when constraint_Error =>
log ("Warning: Received motion updates for unknown sprite" & the_Id'Image & ".");
end;
end loop;
end motion_Updates_are;

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

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

5
4-high/gel/source/world/gel-world-server.adb
View File

@@ -280,8 +280,9 @@ is
Self.register (Mirror_as_observer, to_Kind (remote.World. new_graphics_model_Event'Tag));
Self.register (Mirror_as_observer, to_Kind (remote.World. new_physics_model_Event'Tag));
Self.register (Mirror_as_observer, to_Kind (gel.events. new_sprite_Event'Tag)); -- TODO: Rid.
Self.register (Mirror_as_observer, to_Kind (gel.events.my_new_sprite_added_to_world_Event'Tag));
-- Self.register (Mirror_as_observer, to_Kind (gel.events. new_sprite_Event'Tag)); -- TODO: Rid.
Self.register (Mirror_as_observer, to_Kind (gel.events.new_sprite_Event'Tag));
Self.register (Mirror_as_observer, to_Kind (gel.events.rid_sprite_Event'Tag));
end register;

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

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

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

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

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

@@ -142,15 +142,16 @@ is
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.graphics_Models.all,
Self. physics_Models.all,
Self.World);
begin
Self.World.add (the_Sprite, and_children => False);
end;
raise Program_Error with "JJJ";
-- 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.graphics_Models.all,
-- Self. physics_Models.all,
-- Self.World);
-- begin
-- Self.World.add (the_Sprite, and_children => False);
-- end;
end respond;
@@ -928,35 +929,35 @@ is
-- Perform responses to events for all sprites.
--
declare
use id_Maps_of_sprite;
all_Sprites : constant id_Maps_of_sprite.Map := Item'Class (Self).all_Sprites.fetch;
Cursor : id_Maps_of_sprite.Cursor := all_Sprites.First;
the_Sprite : Sprite.view;
begin
while has_Element (Cursor)
loop
the_Sprite := Element (Cursor);
begin
if not the_Sprite.is_Destroyed
then
the_Sprite.respond;
end if;
exception
when E : others =>
new_Line (2);
put_Line ("Error in 'gel.World.evolve' sprite response.");
new_Line;
put_Line (ada.Exceptions.exception_Information (E));
new_Line (2);
end;
next (Cursor);
end loop;
end;
-- declare
-- use id_Maps_of_sprite;
--
-- all_Sprites : constant id_Maps_of_sprite.Map := Item'Class (Self).all_Sprites.fetch;
-- Cursor : id_Maps_of_sprite.Cursor := all_Sprites.First;
-- the_Sprite : Sprite.view;
-- begin
-- while has_Element (Cursor)
-- loop
-- the_Sprite := Element (Cursor);
--
-- begin
-- if not the_Sprite.is_Destroyed
-- then
-- the_Sprite.respond;
-- end if;
--
-- exception
-- when E : others =>
-- new_Line (2);
-- put_Line ("Error in 'gel.World.evolve' sprite response.");
-- new_Line;
-- put_Line (ada.Exceptions.exception_Information (E));
-- new_Line (2);
-- end;
--
-- next (Cursor);
-- end loop;
-- end;
end evolve;

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

@@ -29,6 +29,9 @@ package gel.World
-- Provides a gel world.
--
is
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
type Item is abstract limited new lace.Subject_and_deferred_Observer.item
and gel.remote.World.item
with private;