458 lines
14 KiB
Ada
458 lines
14 KiB
Ada
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.Streams,
|
|
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
|
|
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;
|
|
|
|
type View is access all Item'Class;
|
|
type Views is array (Positive range <>) of View;
|
|
|
|
use Math;
|
|
|
|
|
|
type Any_limited_view is access all lace.Any.limited_item'Class;
|
|
|
|
|
|
|
|
---------
|
|
-- 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;
|
|
|
|
function cast_Ray (Self : in Item; From, To : in Vector_3) return ray_Collision;
|
|
|
|
|
|
|
|
-----------------
|
|
--- Point Casting
|
|
--
|
|
|
|
type point_Collision is
|
|
record
|
|
near_Sprite : gel.Sprite.view;
|
|
Site_world : Vector_3;
|
|
end record;
|
|
|
|
function cast_Point (Self : in Item; Point : in Vector_3) return point_Collision;
|
|
|
|
|
|
|
|
--------------------
|
|
--- 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; seq_Id : in remote.World.sequence_Id;
|
|
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.id_Map_of_graphics_model;
|
|
overriding
|
|
function physics_Models (Self : in Item) return remote.World.id_Map_of_physics_model;
|
|
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_graphics_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_graphics_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;
|
|
|
|
|
|
|
|
-------
|
|
--- Ids
|
|
--
|
|
|
|
procedure reserve_Ids (Self : in out Item; Before : in long_Integer);
|
|
|
|
|
|
|
|
------------------
|
|
--- 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 := 20.0; -- Too small will make player movement response time sluggish. Too large consumes much bandwidth.
|
|
|
|
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_graphics_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; --TODO: Rename to 'last_used_graphics_model_Id'.
|
|
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;
|