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

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

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

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

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

7
4-high/gel/source/remote/gel-remote.ads Normal file
View File

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