1705 lines
54 KiB
Ada
1705 lines
54 KiB
Ada
with
|
|
gel.Events,
|
|
|
|
physics.Object,
|
|
physics.Forge,
|
|
|
|
openGL.Renderer.lean,
|
|
|
|
lace.Response,
|
|
|
|
ada.Text_IO,
|
|
ada.Exceptions,
|
|
ada.unchecked_Deallocation,
|
|
ada.Containers.hashed_Sets;
|
|
|
|
|
|
package body gel.World
|
|
is
|
|
use gel.Sprite,
|
|
linear_Algebra_3D,
|
|
|
|
-- lace.Event,
|
|
|
|
ada.Exceptions,
|
|
ada.Text_IO;
|
|
|
|
|
|
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 free is new ada.unchecked_Deallocation (lace.Any.limited_item'Class, Any_limited_view);
|
|
|
|
|
|
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
|
|
-- Free record components.
|
|
--
|
|
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;
|
|
|
|
|
|
|
|
function local_Observer (Self : in Item) return lace.Observer.view
|
|
is
|
|
begin
|
|
return lace.Observer.view (Self.local_Subject_and_deferred_Observer);
|
|
end local_Observer;
|
|
|
|
|
|
|
|
function local_Subject (Self : in Item) return lace.Subject.view
|
|
is
|
|
begin
|
|
return lace.Subject.view (Self.local_Subject_and_deferred_Observer);
|
|
end local_Subject;
|
|
|
|
|
|
|
|
function Id (Self : in Item) return world_Id
|
|
is
|
|
begin
|
|
return Self.Id;
|
|
end Id;
|
|
|
|
|
|
|
|
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)));
|
|
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, and_children => False);
|
|
end;
|
|
end respond;
|
|
|
|
|
|
|
|
procedure define (Self : in out create_new_Sprite; 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 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;
|
|
|
|
|
|
-------------------------
|
|
--- all_sprite_Transforms
|
|
--
|
|
|
|
function to_Integer is new ada.unchecked_Conversion (gel.Sprite.view, Integer);
|
|
|
|
|
|
protected
|
|
body all_sprite_Transforms
|
|
is
|
|
procedure add (the_Sprite : in Sprite.view;
|
|
Transform : in Matrix_4x4)
|
|
is
|
|
begin
|
|
sprite_Map_of_transforms.insert (the_Sprite, Transform);
|
|
end add;
|
|
|
|
|
|
procedure set (To : in sprite_Maps_of_transforms.Map)
|
|
is
|
|
begin
|
|
sprite_Map_of_transforms := To;
|
|
end set;
|
|
|
|
|
|
function fetch return sprite_Maps_of_transforms.Map
|
|
is
|
|
begin
|
|
return sprite_Map_of_transforms;
|
|
end Fetch;
|
|
|
|
end all_sprite_Transforms;
|
|
|
|
|
|
-----------------
|
|
--- Duration_safe
|
|
--
|
|
|
|
protected
|
|
body Duration_safe
|
|
is
|
|
procedure Duration_is (Now : in standard.Duration)
|
|
is
|
|
begin
|
|
the_Duration := Now;
|
|
end Duration_is;
|
|
|
|
function Duration return standard.Duration
|
|
is
|
|
begin
|
|
return the_Duration;
|
|
end Duration;
|
|
|
|
end Duration_safe;
|
|
|
|
|
|
--------------------
|
|
--- Breakable Joints
|
|
--
|
|
|
|
protected body safe_joint_Set
|
|
is
|
|
function is_Empty return Boolean
|
|
is
|
|
begin
|
|
return the_Count = 0;
|
|
end is_Empty;
|
|
|
|
|
|
procedure add (the_Joint : in gel.Joint.view)
|
|
is
|
|
begin
|
|
the_Count := the_Count + 1;
|
|
Set (the_Count) := the_Joint;
|
|
end add;
|
|
|
|
|
|
procedure fetch (To : out safe_Joints;
|
|
Count : out Natural)
|
|
is
|
|
begin
|
|
To (1 .. the_Count) := Set (1 .. the_Count);
|
|
Count := the_Count;
|
|
the_Count := 0;
|
|
end Fetch;
|
|
|
|
end safe_joint_Set;
|
|
|
|
|
|
--------------
|
|
--- Collisions
|
|
--
|
|
|
|
task
|
|
type impact_Responder
|
|
is
|
|
entry start (the_World : in gel.World.view;
|
|
Filter : in impact_Filter;
|
|
Response : in impact_Response;
|
|
responses_Done : in Signal_Object_view);
|
|
entry stop;
|
|
entry respond; -- Filter and do responses.
|
|
end impact_Responder;
|
|
|
|
|
|
type impact_Responder_view is access all impact_Responder;
|
|
|
|
procedure free (Self : in out impact_Responder_view)
|
|
is
|
|
procedure deallocate is new ada.unchecked_Deallocation (impact_Responder, impact_Responder_view);
|
|
begin
|
|
deallocate (Self);
|
|
end free;
|
|
|
|
|
|
|
|
type filtered_impact_Response is
|
|
record
|
|
Filter : impact_Filter;
|
|
Response : impact_Response;
|
|
|
|
Responder : impact_Responder_view;
|
|
|
|
responses_Done : signal_Object_view := new Signal_Object;
|
|
end record;
|
|
|
|
function Hash (Self : in filtered_impact_Response) return ada.Containers.Hash_type;
|
|
|
|
package filtered_impact_Response_Sets is new ada.Containers.hashed_Sets (filtered_impact_Response,
|
|
Hash, "=");
|
|
|
|
|
|
protected body Signal_Object
|
|
is
|
|
entry Wait
|
|
when Open
|
|
is
|
|
begin
|
|
Open := False;
|
|
end Wait;
|
|
|
|
procedure Signal
|
|
is
|
|
begin
|
|
Open := True;
|
|
end Signal;
|
|
end Signal_Object;
|
|
|
|
|
|
|
|
function local_graphics_Models (Self : in Item) return id_Maps_of_model.Map
|
|
is
|
|
begin
|
|
return Self.graphics_Models;
|
|
end local_graphics_Models;
|
|
|
|
|
|
|
|
function local_physics_Models (Self : in Item) return id_Maps_of_physics_model.Map
|
|
is
|
|
begin
|
|
return Self.physics_Models;
|
|
end local_physics_Models;
|
|
|
|
|
|
--------------
|
|
--- Attributes
|
|
--
|
|
|
|
function space_Kind (Self : in Item) return physics.space_Kind
|
|
is
|
|
begin
|
|
return Self.space_Kind;
|
|
end space_Kind;
|
|
|
|
|
|
|
|
function Space (Self : in Item) return physics.Space.view
|
|
is
|
|
begin
|
|
return Self.physics_Space;
|
|
end Space;
|
|
|
|
|
|
|
|
procedure update_Bounds (Self : in out Item; of_Sprite : in gel.Sprite.view)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.physics_Engine.update_Bounds (of_Sprite.Solid);
|
|
end update_Bounds;
|
|
|
|
|
|
|
|
procedure update_Site (Self : in out Item; of_Sprite : in gel.Sprite.view; -- TODO: Probably obsolete.
|
|
To : in Vector_3)
|
|
is
|
|
begin
|
|
of_Sprite.Solid.Site_is (To);
|
|
|
|
-- Self.physics_Engine.update_Site (of_Sprite.Solid, To);
|
|
end update_Site;
|
|
|
|
|
|
|
|
procedure set_Speed (Self : in out Item; of_Sprite : in gel.Sprite.view; -- TODO: Probably obsolete.
|
|
To : in Vector_3)
|
|
is
|
|
begin
|
|
null;
|
|
-- Self.physics_Engine.set_Speed (of_Sprite.Solid, To);
|
|
end set_Speed;
|
|
|
|
|
|
|
|
procedure set_xy_Spin (Self : in out Item; of_Sprite : in gel.Sprite.view; -- TODO: Probably obsolete.
|
|
To : in Radians)
|
|
is
|
|
begin
|
|
of_Sprite.Solid.xy_Spin_is (To);
|
|
|
|
-- Self.physics_Engine.set_xy_Spin (of_Sprite.Solid, To);
|
|
end set_xy_Spin;
|
|
|
|
|
|
|
|
procedure update_Scale (Self : in out Item; of_Sprite : in gel.Sprite.view; -- TODO: Probably obsolete.
|
|
To : in Vector_3)
|
|
is
|
|
begin
|
|
null;
|
|
-- Self.physics_Engine.update_Scale (of_Sprite.Solid, To);
|
|
|
|
-- Self.physics_Engine.add (std_Physics.Engine.Command' (Kind => scale_Object,
|
|
-- Sprite => the_Command.Sprite.Solid,
|
|
-- Scale => the_Command.Scale));
|
|
end update_Scale;
|
|
|
|
|
|
|
|
procedure apply_Force (Self : in out Item; to_Sprite : in gel.Sprite.view; -- TODO: Probably obsolete.
|
|
Force : in Vector_3)
|
|
is
|
|
begin
|
|
null;
|
|
-- Self.physics_Engine.apply_Force (to_Sprite.Solid, Force);
|
|
end apply_Force;
|
|
|
|
|
|
|
|
function Age (Self : in Item) return Duration
|
|
is
|
|
begin
|
|
return Self.Age;
|
|
end Age;
|
|
|
|
|
|
|
|
procedure Age_is (Self : in out Item; Now : in Duration)
|
|
is
|
|
begin
|
|
Self.Age := Now;
|
|
end Age_is;
|
|
|
|
|
|
|
|
procedure Gravity_is (Self : in out Item; Now : in Vector_3)
|
|
is
|
|
begin
|
|
Self.physics_Space.Gravity_is (Now);
|
|
end Gravity_is;
|
|
|
|
|
|
|
|
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)
|
|
is
|
|
begin
|
|
null;
|
|
-- Self.Commands.add ((Kind => cast_Ray,
|
|
-- Sprite => null,
|
|
-- From => From,
|
|
-- To => To,
|
|
-- Observer => Observer,
|
|
-- Context => Context,
|
|
-- event_Kind => event_Kind'Tag));
|
|
end cast_Ray;
|
|
|
|
|
|
--------------
|
|
--- Collisions
|
|
--
|
|
|
|
function manifold_Count (Self : in Item) return Natural
|
|
is
|
|
begin
|
|
return Self.manifold_Count;
|
|
end manifold_Count;
|
|
|
|
|
|
|
|
function Manifold (Self : in Item; Index : in Positive) return a_Manifold
|
|
is
|
|
begin
|
|
return Self.Manifolds (Index);
|
|
end Manifold;
|
|
|
|
|
|
|
|
function Manifolds (Self : in Item) return Manifold_array
|
|
is
|
|
begin
|
|
return Self.Manifolds (1 .. Self.manifold_Count);
|
|
end Manifolds;
|
|
|
|
|
|
-----------
|
|
--- Sprites
|
|
--
|
|
|
|
function new_sprite_Id (Self : access Item) return sprite_Id
|
|
is
|
|
begin
|
|
Self.last_used_sprite_Id := Self.last_used_sprite_Id + 1;
|
|
|
|
return Self.last_used_sprite_Id;
|
|
end new_sprite_Id;
|
|
|
|
|
|
|
|
procedure destroy (Self : in out Item; the_Sprite : in gel.Sprite.view)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.Commands.add ((Kind => destroy_Sprite,
|
|
-- Sprite => the_Sprite));
|
|
end destroy;
|
|
|
|
|
|
|
|
function free_sprite_Set (Self : access Item) return gel.Sprite.views
|
|
is
|
|
prior_set_Index : Integer;
|
|
begin
|
|
if Self.current_free_Set = 1
|
|
then prior_set_Index := 2;
|
|
else prior_set_Index := 1;
|
|
end if;
|
|
|
|
declare
|
|
the_Set : constant gel.Sprite.views
|
|
:= Self.free_Sets (prior_set_Index).Sprites (1 .. Self.free_Sets (prior_set_Index).Count);
|
|
begin
|
|
Self.free_Sets (prior_set_Index).Count := 0;
|
|
Self.current_free_Set := prior_set_Index;
|
|
|
|
return the_Set;
|
|
end;
|
|
end free_sprite_Set;
|
|
|
|
|
|
|
|
function fetch_Sprite (Self : in out Item'Class; Id : in sprite_Id) return gel.Sprite.view
|
|
is
|
|
begin
|
|
return Self.all_Sprites.fetch.Element (Id);
|
|
end fetch_Sprite;
|
|
|
|
|
|
|
|
procedure set_Scale (Self : in out Item; for_Sprite : in gel.Sprite.view;
|
|
To : in Vector_3)
|
|
is
|
|
Pad : constant Vector_3 := for_Sprite.Site;
|
|
begin
|
|
Self.rid (for_Sprite, and_children => False);
|
|
for_Sprite.Scale_is (To);
|
|
Self.add (for_Sprite, and_children => False);
|
|
|
|
for_Sprite.Site_is (Pad); -- TODO: Fix this hack !
|
|
end set_Scale;
|
|
|
|
|
|
|
|
function sprite_Transforms (Self : in out Item'Class) return sprite_transform_Pairs
|
|
is
|
|
use id_Maps_of_sprite;
|
|
|
|
all_Sprites : constant id_Maps_of_sprite.Map := Self.all_Sprites.fetch;
|
|
Cursor : id_Maps_of_sprite.Cursor := all_Sprites.First;
|
|
|
|
the_sprite_Transforms : sprite_transform_Pairs (1 .. Natural (all_Sprites.Length)) := (others => <>);
|
|
Count : Natural := 0;
|
|
|
|
the_Sprite : Sprite.view;
|
|
|
|
begin
|
|
while has_Element (Cursor)
|
|
loop
|
|
the_Sprite := Element (Cursor);
|
|
|
|
if not the_Sprite.is_Destroyed
|
|
then
|
|
Count := Count + 1;
|
|
the_sprite_Transforms (Count) := (Sprite => the_Sprite,
|
|
Transform => the_Sprite.Transform);
|
|
end if;
|
|
|
|
next (Cursor);
|
|
end loop;
|
|
|
|
return the_sprite_Transforms (1 .. Count);
|
|
end sprite_Transforms;
|
|
|
|
|
|
----------
|
|
--- Joints
|
|
--
|
|
|
|
procedure destroy (Self : in out Item; the_Joint : in gel.Joint.view)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.Commands.add ((kind => free_Joint,
|
|
-- sprite => null,
|
|
-- joint => the_Joint));
|
|
end destroy;
|
|
|
|
|
|
|
|
procedure set_local_Anchor_on_A (Self : in out Item; for_Joint : in gel.Joint.view;
|
|
To : in Vector_3)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.physics_Engine.set_local_Anchor (for_Joint.Physics.all'Access,
|
|
-- to => To,
|
|
-- is_Anchor_A => True);
|
|
|
|
-- the_World.physics_Space.set_Joint_local_Anchor (the_Command.anchor_Joint.Physics.all'Access,
|
|
-- the_Command.is_Anchor_A,
|
|
-- the_Command.local_Anchor);
|
|
--
|
|
--
|
|
-- Self.Commands.add ((Kind => set_Joint_local_Anchor,
|
|
-- Sprite => null,
|
|
-- anchor_Joint => for_Joint,
|
|
-- is_Anchor_A => True,
|
|
-- local_Anchor => To));
|
|
end set_local_Anchor_on_A;
|
|
|
|
|
|
|
|
procedure set_local_Anchor_on_B (Self : in out Item; for_Joint : in gel.Joint.view;
|
|
To : in Vector_3)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.physics_Engine.set_local_Anchor (for_Joint.Physics.all'Access,
|
|
-- To => To,
|
|
-- is_Anchor_A => False);
|
|
|
|
-- Self.Commands.add ((Kind => set_Joint_local_Anchor,
|
|
-- Sprite => null,
|
|
-- anchor_Joint => for_Joint,
|
|
-- is_Anchor_A => False,
|
|
-- local_Anchor => To));
|
|
end set_local_anchor_on_B;
|
|
|
|
|
|
|
|
-- type graphics_Model_iface_view is access all openGL.remote_Model.item'Class;
|
|
-- type graphics_Model_view is access all openGL. Model.item'Class;
|
|
--
|
|
-- type physics_Model_iface_view is access all Standard.physics.remote.Model.item'Class;
|
|
-- type physics_Model_view is access all Standard.physics.Model .item'Class;
|
|
|
|
|
|
procedure add (Self : access Item; the_Sprite : in gel.Sprite.view;
|
|
and_Children : in Boolean := False)
|
|
is
|
|
procedure add_single_Sprite (Single : in out Sprite.item'Class)
|
|
is
|
|
begin
|
|
if Single.Id = null_sprite_Id
|
|
then
|
|
raise Error with "Null sprite detected.";
|
|
end if;
|
|
|
|
Self.add (Single.graphics_Model);
|
|
Self.add (Single. physics_Model);
|
|
|
|
Single.Solid.user_Data_is (Single'Access);
|
|
Single.Solid. Model_is (Single.physics_Model);
|
|
|
|
if Single.physics_Model.is_Tangible
|
|
then
|
|
Self.physics_Space.add (physics.Object.view (Single.Solid));
|
|
end if;
|
|
|
|
Item'Class (Self.all).all_Sprites.add (Single'unchecked_Access);
|
|
end add_single_Sprite;
|
|
|
|
begin
|
|
pragma assert (the_Sprite.World = Self, "Trying to add sprite to the wrong world."); -- TODO: Use an exception.
|
|
|
|
if and_Children
|
|
then
|
|
declare
|
|
procedure add_the_Joint (the_Sprite : in out Sprite.item'Class)
|
|
is
|
|
use type gel.Joint.view;
|
|
the_Joint : constant gel.Joint.view := the_Sprite.parent_Joint;
|
|
begin
|
|
if the_Joint /= null
|
|
then
|
|
Self.physics_Space.add (the_Joint.Physics.all'Access);
|
|
the_Joint.Physics.user_Data_is (the_Joint);
|
|
end if;
|
|
end add_the_Joint;
|
|
|
|
begin
|
|
the_Sprite.apply (add_single_Sprite'unrestricted_Access);
|
|
the_Sprite.apply (add_the_Joint 'unrestricted_Access);
|
|
end;
|
|
else
|
|
add_single_Sprite (the_Sprite.all);
|
|
end if;
|
|
end add;
|
|
|
|
|
|
|
|
procedure rid (Self : in out Item'Class; the_Sprite : in gel.Sprite.view;
|
|
and_Children : in Boolean := False)
|
|
is
|
|
procedure rid_single_Sprite (Single : in out Sprite.item'Class)
|
|
is
|
|
begin
|
|
-- Self.Commands.add ((Kind => rid_Sprite,
|
|
-- Sprite => the_Sprite'unchecked_Access,
|
|
-- rid_Children => False));
|
|
|
|
Self.all_Sprites.rid (Single'unchecked_Access); -- TODO: Handle grandchildren and so on.
|
|
end rid_single_Sprite;
|
|
|
|
begin
|
|
if and_Children
|
|
then
|
|
the_Sprite.apply (rid_single_Sprite'unrestricted_Access);
|
|
else
|
|
rid_single_Sprite (the_Sprite.all);
|
|
end if;
|
|
end rid;
|
|
|
|
|
|
|
|
procedure add (Self : in out Item; the_Model : in openGL.Model.view)
|
|
is
|
|
begin
|
|
if the_Model.Id = null_graphics_model_Id
|
|
then
|
|
Self.last_used_model_Id := Self.last_used_model_Id + 1;
|
|
the_Model.Id_is (Self.last_used_model_Id);
|
|
end if;
|
|
|
|
if not Self.graphics_Models.contains (the_Model.Id)
|
|
then
|
|
Self.graphics_Models.insert (the_Model.Id, the_Model);
|
|
|
|
-- Emit a new model event.
|
|
--
|
|
declare
|
|
the_Event : remote.World.new_model_Event;
|
|
begin
|
|
the_Event.Model := the_Model;
|
|
Self.emit (the_Event);
|
|
end;
|
|
end if;
|
|
end add;
|
|
|
|
|
|
|
|
procedure add (Self : in out Item; the_Model : in physics.Model.view)
|
|
is
|
|
begin
|
|
if the_Model.Id = Physics.null_model_Id
|
|
then
|
|
Self.last_used_physics_model_Id := Self.last_used_physics_model_Id + 1;
|
|
the_Model.Id_is (Self.last_used_physics_model_Id);
|
|
end if;
|
|
|
|
if not Self.physics_Models.contains (the_Model.Id)
|
|
then
|
|
Self.physics_Models.insert (the_Model.Id, the_Model);
|
|
end if;
|
|
end add;
|
|
|
|
|
|
|
|
procedure add (Self : in out Item; the_Joint : in gel.Joint.view)
|
|
is
|
|
begin
|
|
Self.physics_Space.add (the_Joint.Physics.all'Access);
|
|
the_Joint.Physics.user_Data_is (the_Joint);
|
|
end add;
|
|
|
|
|
|
|
|
procedure rid (Self : in out Item; the_Joint : in gel.Joint.view)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.physics_Engine.rid (the_Joint.Physics.all'Access);
|
|
|
|
-- Self.Commands.add ((kind => rid_Joint,
|
|
-- sprite => null,
|
|
-- joint => the_Joint));
|
|
end rid;
|
|
|
|
|
|
|
|
--------------
|
|
--- Operations
|
|
--
|
|
|
|
procedure start (Self : access Item)
|
|
is
|
|
begin
|
|
null;
|
|
end start;
|
|
|
|
|
|
--------------------
|
|
--- World Mirroring
|
|
--
|
|
|
|
overriding
|
|
procedure register (Self : access Item; the_Mirror : in remote.World.view;
|
|
Mirror_as_observer : in lace.Observer.view) is null;
|
|
overriding
|
|
procedure deregister (Self : access Item; the_Mirror : in remote.World.view) is null;
|
|
|
|
overriding
|
|
procedure motion_Updates_are (Self : in Item; Now : in remote.World.motion_Updates) is null;
|
|
|
|
|
|
----------
|
|
--- Joints
|
|
--
|
|
|
|
procedure allow_broken_Joints (Self : out Item)
|
|
is
|
|
begin
|
|
Self.broken_joints_Allowed := True;
|
|
end allow_broken_Joints;
|
|
|
|
|
|
|
|
procedure handle_broken_Joints (Self : in out Item; the_Joints :in Joint.views)
|
|
is
|
|
begin
|
|
for i in the_Joints'Range
|
|
loop
|
|
begin
|
|
if ( the_Joints (i).Sprite_A /= null
|
|
and the_Joints (i).Sprite_B /= null)
|
|
and then ( not the_Joints (i).Sprite_A.is_Destroyed
|
|
and not the_Joints (i).Sprite_B.is_Destroyed)
|
|
then
|
|
begin
|
|
the_Joints (i).Sprite_A.detach (the_Joints (i).Sprite_B);
|
|
exception
|
|
when no_such_Child =>
|
|
put_Line ("handle_broken_Joints: Cannot detach sprite: no_such_Child." );
|
|
end;
|
|
end if;
|
|
|
|
exception
|
|
when storage_Error =>
|
|
put_Line ("handle_broken_Joints: Cannot tell if sprite exists: storage_Error." );
|
|
end;
|
|
end loop;
|
|
end handle_broken_Joints;
|
|
|
|
|
|
|
|
procedure evolve (Self : in out Item)
|
|
is
|
|
begin
|
|
Self.Age := Self.Age + evolve_Period;
|
|
|
|
-- Evolve the physics.
|
|
--
|
|
Self.physics_Space.evolve (evolve_Period); -- Evolve the physics space.
|
|
|
|
-- Handle evnts.
|
|
--
|
|
Self.respond;
|
|
Self.local_Subject_and_deferred_Observer.respond;
|
|
|
|
-- Broken joints.
|
|
--
|
|
declare
|
|
the_Joints : safe_Joints;
|
|
Count : Natural;
|
|
begin
|
|
Self.broken_Joints.fetch (the_Joints, Count);
|
|
Self.handle_broken_Joints (the_Joints (1 .. Count));
|
|
end;
|
|
|
|
-- 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;
|
|
|
|
end evolve;
|
|
|
|
|
|
|
|
overriding
|
|
function graphics_Models (Self : in Item) return remote.World.graphics_Model_Set
|
|
is
|
|
use id_Maps_of_model;
|
|
|
|
the_Models : remote.World.graphics_Model_Set;
|
|
Cursor : id_Maps_of_model.Cursor := Self.graphics_Models.First;
|
|
begin
|
|
while has_Element (Cursor)
|
|
loop
|
|
the_Models.include (Element (Cursor).Id,
|
|
Element (Cursor).all);
|
|
next (Cursor);
|
|
end loop;
|
|
|
|
return the_Models;
|
|
end graphics_Models;
|
|
|
|
|
|
|
|
overriding
|
|
function physics_Models (Self : in Item) return remote.World.physics_model_Set
|
|
is
|
|
use id_Maps_of_physics_model;
|
|
|
|
the_Models : remote.World.physics_model_Set;
|
|
Cursor : id_Maps_of_physics_model.Cursor := Self.physics_Models.First;
|
|
begin
|
|
while has_Element (Cursor)
|
|
loop
|
|
the_Models.include (Element (Cursor).Id,
|
|
Element (Cursor).all);
|
|
next (Cursor);
|
|
end loop;
|
|
|
|
return the_Models;
|
|
end physics_Models;
|
|
|
|
|
|
|
|
overriding
|
|
function Sprites (Self : in out Item) return remote.World.sprite_model_Pairs
|
|
is
|
|
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_Pairs : remote.World.sprite_model_Pairs (1 .. Natural (all_Sprites.Length));
|
|
the_Sprite : Sprite.view;
|
|
i : Natural := 0;
|
|
begin
|
|
while has_Element (Cursor)
|
|
loop
|
|
i := i + 1;
|
|
the_Sprite := Element (Cursor);
|
|
|
|
the_Pairs (i) := (sprite_Id => the_Sprite.Id,
|
|
graphics_model_Id => the_Sprite.graphics_Model.Id,
|
|
physics_model_Id => the_Sprite. physics_Model.Id,
|
|
Mass => the_Sprite.Mass,
|
|
Transform => the_Sprite.Transform,
|
|
is_Visible => the_Sprite.is_Visible);
|
|
next (Cursor);
|
|
end loop;
|
|
|
|
return the_Pairs;
|
|
end Sprites;
|
|
|
|
|
|
|
|
--------------
|
|
--- Collisions
|
|
--
|
|
|
|
function Hash (Self : in filtered_impact_Response) return ada.Containers.Hash_type
|
|
is
|
|
use type ada.Containers.Hash_type;
|
|
|
|
function to_Hash is new ada.unchecked_Conversion (impact_Filter, ada.Containers.Hash_type);
|
|
function to_Hash is new ada.unchecked_Conversion (impact_Response, ada.Containers.Hash_type);
|
|
begin
|
|
return to_Hash (Self.Filter)
|
|
+ to_Hash (Self.Response);
|
|
end Hash;
|
|
|
|
|
|
|
|
procedure add_impact_Response (Self : in out Item; Filter : in impact_Filter;
|
|
Response : in impact_Response)
|
|
is
|
|
begin
|
|
null; -- TODO
|
|
-- Self.Commands.add ((new_impact_Response,
|
|
-- null,
|
|
-- Filter,
|
|
-- Response));
|
|
end add_impact_Response;
|
|
|
|
|
|
|
|
task body impact_Responder
|
|
is
|
|
the_World : gel.World.view;
|
|
Done : Boolean := False;
|
|
|
|
Filters_through : impact_Filter;
|
|
the_Response : impact_Response;
|
|
|
|
the_responses_Done : access Signal_Object;
|
|
|
|
begin
|
|
accept start (the_World : in gel.World.view;
|
|
Filter : in impact_Filter;
|
|
Response : in impact_Response;
|
|
responses_Done : in Signal_Object_view)
|
|
do
|
|
impact_Responder.the_World := the_World;
|
|
Filters_through := Filter;
|
|
the_Response := Response;
|
|
the_responses_Done := responses_Done;
|
|
end start;
|
|
|
|
loop
|
|
begin
|
|
select
|
|
accept stop
|
|
do
|
|
Done := True;
|
|
end stop;
|
|
or
|
|
accept respond;
|
|
end select;
|
|
|
|
exit when Done;
|
|
|
|
-- Filter and call response.
|
|
--
|
|
for i in 1 .. the_World.manifold_Count
|
|
loop
|
|
if not the_World.Manifolds (i).Sprites (1).is_Destroyed
|
|
and then not the_World.Manifolds (i).Sprites (2).is_Destroyed
|
|
and then Filters_through (the_World.Manifolds (i))
|
|
then
|
|
the_Response (the_World.Manifolds (i),
|
|
the_World);
|
|
end if;
|
|
end loop;
|
|
|
|
the_responses_Done.signal;
|
|
|
|
exception
|
|
when E : others =>
|
|
put_Line ("Exception in impact_Responder.");
|
|
put_Line (Exception_Information (E));
|
|
the_responses_Done.signal;
|
|
end;
|
|
end loop;
|
|
|
|
end impact_Responder;
|
|
|
|
|
|
----------
|
|
--- Events
|
|
--
|
|
|
|
function to_raycast_collision_Event (Params : not null access no_Parameters) return raycast_collision_Event
|
|
is
|
|
begin
|
|
return raycast_collision_Event' (others => <>);
|
|
end to_raycast_collision_Event;
|
|
|
|
|
|
|
|
overriding
|
|
procedure destruct (Self : in out raycast_collision_Event)
|
|
is
|
|
begin
|
|
free (Self.Context);
|
|
end destruct;
|
|
|
|
|
|
-----------
|
|
-- Testing
|
|
--
|
|
|
|
overriding
|
|
procedure kick_Sprite (Self : in out Item; sprite_Id : in gel.sprite_Id)
|
|
is
|
|
the_Sprite : constant gel.Sprite.view := Item'Class (Self).all_Sprites.fetch.Element (sprite_Id);
|
|
begin
|
|
the_Sprite.Speed_is ([0.0, 10.0, 0.0]);
|
|
end kick_Sprite;
|
|
|
|
|
|
end gel.World;
|
|
|
|
|
|
|
|
|
|
|
|
-- Old engine code left for reference ...
|
|
|
|
----------
|
|
--- Engine
|
|
--
|
|
|
|
-- task body Engine
|
|
-- is
|
|
-- use type gel.Joint.view,
|
|
-- ada.Containers.Count_type;
|
|
--
|
|
-- Stopped : Boolean := True;
|
|
-- Cycle : ada.Containers.Count_type := 0;
|
|
-- next_render_Time : ada.Calendar.Time;
|
|
--
|
|
-- the_filtered_impact_Response_Set : filtered_impact_Response_Sets.Set;
|
|
--
|
|
-- max_joint_Force,
|
|
-- max_joint_Torque : Real := 0.0;
|
|
|
|
|
|
-- procedure free_Sprites
|
|
-- is
|
|
-- the_free_Sprites : gel.Sprite.views := the_World.free_sprite_Set;
|
|
-- begin
|
|
-- for i in the_free_Sprites'Range
|
|
-- loop
|
|
-- log ("Engine is freeing sprite id:" & the_free_Sprites (i).Id'Image);
|
|
--
|
|
-- if the_free_Sprites (i).owns_Graphics
|
|
-- then
|
|
-- the_World.Renderer.free (the_free_Sprites (i).Visual.Model);
|
|
-- end if;
|
|
--
|
|
-- gel.Sprite.free (the_free_Sprites (i));
|
|
-- end loop;
|
|
-- end free_Sprites;
|
|
|
|
|
|
|
|
-- procedure free_graphics_Models
|
|
-- is
|
|
-- use id_Maps_of_model;
|
|
-- Cursor : id_Maps_of_model.Cursor := the_World.graphics_Models.First;
|
|
-- begin
|
|
-- while has_Element (Cursor)
|
|
-- loop
|
|
-- the_World.Renderer.free (Element (Cursor));
|
|
-- next (Cursor);
|
|
-- end loop;
|
|
-- end free_graphics_Models;
|
|
|
|
|
|
|
|
-- procedure evolve
|
|
-- is
|
|
-- the_sprite_Transforms : sprite_Maps_of_transforms.Map := the_World.all_sprite_Transforms.Fetch;
|
|
-- begin
|
|
-- Cycle := Cycle + 1;
|
|
|
|
-- do_engine_Commands:
|
|
-- declare
|
|
-- the_Commands : World.Commands;
|
|
-- Count : Natural;
|
|
-- command_Count : array (command_Kind) of Natural := (others => 0);
|
|
|
|
-- begin
|
|
-- the_World.Commands.fetch (the_Commands, Count);
|
|
|
|
-- for Each in 1 .. Count
|
|
-- loop
|
|
-- declare
|
|
-- use Physics.Engine;
|
|
-- the_Command : World.Command renames the_Commands (Each);
|
|
-- begin
|
|
-- command_Count (the_Command.Kind) := command_Count (the_Command.Kind) + 1;
|
|
|
|
-- case the_Command.Kind
|
|
-- is
|
|
-- when scale_Sprite =>
|
|
-- the_World.physics_Engine.add (std_Physics.Engine.Command' (Kind => scale_Object,
|
|
-- Sprite => the_Command.Sprite.Solid,
|
|
-- Scale => the_Command.Scale));
|
|
-- the_Command.Sprite.Solid.activate;
|
|
-- the_Command.Sprite.Shape.Scale_is (the_Command.Scale);
|
|
-- the_Command.Sprite.Solid.Scale_is (the_Command.Scale);
|
|
--
|
|
-- the_World.physics_Space.update_Bounds (std_physics.Object.view (the_Command.Sprite.Solid));
|
|
|
|
|
|
-- when update_Bounds =>
|
|
-- the_World.physics_Space.update_Bounds (std_physics.Object.view (the_Command.Sprite.Solid));
|
|
|
|
|
|
-- when update_Site =>
|
|
-- the_World.physics_Engine.update_Site (the_Command.Sprite.Solid,
|
|
-- the_Command.Site);
|
|
-- std_physics.Object.view (the_Command.Sprite.Solid).Site_is (the_Command.Site);
|
|
|
|
|
|
-- when set_Speed =>
|
|
-- std_physics.Object.view (the_Command.Sprite.Solid).Speed_is (the_Command.Speed);
|
|
|
|
|
|
-- when set_xy_Spin =>
|
|
-- std_physics.Object.view (the_Command.Sprite.Solid).xy_Spin_is (the_Command.xy_Spin);
|
|
|
|
|
|
-- when add_Sprite =>
|
|
-- declare
|
|
-- procedure add (the_Sprite : in Sprite.view)
|
|
-- is
|
|
-- begin
|
|
-- if the_Sprite.Id = null_sprite_Id
|
|
-- then
|
|
-- raise Program_Error;
|
|
-- end if;
|
|
--
|
|
-- the_World.add (the_Sprite.graphics_Model);
|
|
-- the_World.add (the_Sprite. physics_Model);
|
|
--
|
|
-- the_sprite_Transforms.insert (the_Sprite, Identity_4x4);
|
|
--
|
|
-- the_Sprite.Solid.user_Data_is (the_Sprite);
|
|
-- the_Sprite.Solid.Model_is (the_Sprite.physics_Model);
|
|
--
|
|
-- if the_Sprite.physics_Model.is_Tangible
|
|
-- then
|
|
-- the_World.physics_Engine.add (physics.Object.view (the_Sprite.Solid));
|
|
-- end if;
|
|
--
|
|
-- the_World.sprite_Count := the_World.sprite_Count + 1;
|
|
-- the_World.Sprites (the_World.sprite_Count) := the_Sprite;
|
|
-- end add;
|
|
--
|
|
-- begin
|
|
-- add (the_Command.Sprite);
|
|
-- end;
|
|
|
|
|
|
-- when rid_Sprite =>
|
|
-- declare
|
|
-- function find (the_Sprite : in Sprite.view) return Index
|
|
-- is
|
|
-- begin
|
|
-- for i in 1 .. the_World.sprite_Count
|
|
-- loop
|
|
-- if the_World.Sprites (i) = the_Sprite
|
|
-- then
|
|
-- return i;
|
|
-- end if;
|
|
-- end loop;
|
|
--
|
|
-- raise constraint_Error with "No such sprite in world.";
|
|
-- return 0;
|
|
-- end find;
|
|
--
|
|
--
|
|
-- procedure rid (the_Sprite : in Sprite.view)
|
|
-- is
|
|
-- use type physics.Object.view;
|
|
-- begin
|
|
-- if the_Sprite.Solid /= null
|
|
-- then
|
|
-- if the_Sprite.physics_Model.is_Tangible
|
|
-- then
|
|
-- the_World.physics_Engine.rid (the_Sprite.Solid);
|
|
-- end if;
|
|
--
|
|
-- if the_sprite_Transforms.contains (the_Sprite) then
|
|
-- the_sprite_Transforms.delete (the_Sprite);
|
|
-- end if;
|
|
--
|
|
-- else
|
|
-- raise program_Error;
|
|
-- end if;
|
|
--
|
|
-- declare
|
|
-- Id : Index;
|
|
-- begin
|
|
-- Id := find (the_Sprite);
|
|
--
|
|
-- if Id <= the_World.sprite_Count
|
|
-- then
|
|
-- the_World.Sprites (1 .. the_World.sprite_Count - 1)
|
|
-- := the_World.Sprites ( 1 .. Id - 1)
|
|
-- & the_World.Sprites (Id + 1 .. the_World.sprite_Count);
|
|
-- end if;
|
|
--
|
|
-- the_World.sprite_Count := the_World.sprite_Count - 1;
|
|
-- end;
|
|
-- end rid;
|
|
--
|
|
-- begin
|
|
-- rid (the_Command.Sprite);
|
|
-- end;
|
|
|
|
|
|
-- when apply_Force =>
|
|
-- the_Command.Sprite.Solid.apply_Force (the_Command.Force);
|
|
|
|
|
|
-- when destroy_Sprite =>
|
|
-- declare
|
|
-- the_free_Set : free_Set renames the_World.free_Sets (the_World.current_free_Set);
|
|
-- begin
|
|
-- the_free_Set.Count := the_free_Set.Count + 1;
|
|
-- the_free_Set.Sprites (the_free_Set.Count) := the_Command.Sprite;
|
|
-- end;
|
|
|
|
|
|
-- when add_Joint =>
|
|
-- the_World.physics_Space.add (the_Command.Joint.Physics.all'Access);
|
|
-- the_Command.Joint.Physics.user_Data_is (the_Command.Joint);
|
|
|
|
|
|
-- when rid_Joint =>
|
|
-- the_World.physics_Space.rid (the_Command.Joint.Physics.all'Access);
|
|
|
|
|
|
-- when set_Joint_local_Anchor =>
|
|
-- the_World.physics_Space.set_Joint_local_Anchor (the_Command.anchor_Joint.Physics.all'Access,
|
|
-- the_Command.is_Anchor_A,
|
|
-- the_Command.local_Anchor);
|
|
|
|
-- when free_Joint =>
|
|
-- gel.Joint.free (the_Command.Joint);
|
|
|
|
|
|
-- when cast_Ray =>
|
|
-- declare
|
|
-- function cast_Ray (Self : in Item'Class; From, To : in Vector_3) return ray_Collision
|
|
-- is
|
|
-- use type physics.Object.view;
|
|
--
|
|
-- physics_Collision : constant physics.Space.ray_Collision := Self.physics_Space.cast_Ray (From, To);
|
|
-- begin
|
|
-- if physics_Collision.near_Object = null
|
|
-- then
|
|
-- return ray_Collision' (near_Sprite => null,
|
|
-- others => <>);
|
|
-- else
|
|
-- return ray_Collision' (to_GEL (physics_Collision.near_Object),
|
|
-- physics_Collision.hit_Fraction,
|
|
-- physics_Collision.Normal_world,
|
|
-- physics_Collision. Site_world);
|
|
-- end if;
|
|
-- end cast_Ray;
|
|
--
|
|
-- the_Collision : constant ray_Collision := cast_Ray (the_World.all,
|
|
-- the_Command.From,
|
|
-- the_Command.To);
|
|
-- begin
|
|
-- if the_Collision.near_Sprite = null
|
|
-- or else the_Collision.near_Sprite.is_Destroyed
|
|
-- then
|
|
-- free (the_Command.Context);
|
|
--
|
|
-- else
|
|
-- declare
|
|
-- no_Params : aliased no_Parameters;
|
|
-- the_Event : raycast_collision_Event'Class
|
|
-- := raycast_collision_Event_dispatching_Constructor (the_Command.event_Kind,
|
|
-- no_Params'Access);
|
|
-- begin
|
|
-- the_Event.Context := the_Command.Context;
|
|
-- the_Event.near_Sprite := the_Collision.near_Sprite;
|
|
-- the_Event.Site_world := the_Collision.Site_world;
|
|
--
|
|
-- the_Command.Observer.receive (the_Event, from_Subject => the_World.Name);
|
|
-- end;
|
|
-- end if;
|
|
-- end;
|
|
|
|
|
|
-- when new_impact_Response =>
|
|
-- declare
|
|
-- the_impact_Responder : constant impact_Responder_view := new impact_Responder;
|
|
-- the_responses_done_Signal : constant Signal_Object_view := new signal_Object;
|
|
-- begin
|
|
-- the_filtered_impact_Response_Set.insert ((the_Command.Filter,
|
|
-- the_Command.Response,
|
|
-- the_impact_Responder,
|
|
-- the_responses_done_Signal));
|
|
-- the_impact_Responder.start (the_World,
|
|
-- the_Command.Filter,
|
|
-- the_Command.Response,
|
|
-- the_responses_done_Signal);
|
|
-- end;
|
|
|
|
|
|
-- when set_Gravity =>
|
|
-- the_World.physics_Space.Gravity_is (the_Command.Gravity);
|
|
-- end case;
|
|
-- end;
|
|
-- end loop;
|
|
-- end do_engine_Commands;
|
|
|
|
|
|
-- Evolve the physics.
|
|
--
|
|
-- if not the_World.is_a_Mirror
|
|
-- then
|
|
-- the_World.physics_Space.evolve (by => 1.0 / 60.0); -- Evolve the world.
|
|
-- end if;
|
|
|
|
|
|
-- -- Contact Manifolds
|
|
-- --
|
|
-- declare
|
|
-- Count : Natural := 0;
|
|
-- begin
|
|
-- for i in 1 .. the_World.physics_Space.manifold_Count
|
|
-- loop
|
|
-- declare
|
|
-- function to_Integer is new ada.unchecked_Conversion (physics_Object_view, Integer);
|
|
--
|
|
-- the_physics_Manifold : constant physics.Space.a_Manifold
|
|
-- := the_World.physics_Space.Manifold (i);
|
|
-- begin
|
|
-- Count := Count + 1;
|
|
-- the_World.Manifolds (Count) := (sprites => (to_GEL (the_physics_Manifold.Objects (1)),
|
|
-- to_GEL (the_physics_Manifold.Objects (2))),
|
|
-- contact => (Site => the_physics_Manifold.Contact.Site));
|
|
-- exception
|
|
-- when others =>
|
|
-- put_Line ("Error in 'gel.world.Engine.evolve' contact manifolds.");
|
|
-- Count := Count - 1;
|
|
-- end;
|
|
-- end loop;
|
|
--
|
|
-- the_World.manifold_Count := the_World.physics_Space.manifold_Count;
|
|
--
|
|
-- exception
|
|
-- when E : others =>
|
|
-- put_Line ("'gel.World.local.Engine.Contact Manifolds' has an unhandled exception ...");
|
|
-- put_Line (exception_Information (E));
|
|
-- end;
|
|
|
|
|
|
-- -- For each registered impact response, tell the associated responder task to respond.
|
|
-- --
|
|
-- declare
|
|
-- use filtered_impact_Response_Sets;
|
|
-- Cursor : filtered_impact_Response_Sets.Cursor := the_filtered_impact_Response_Set.First;
|
|
--
|
|
-- begin
|
|
-- while has_Element (Cursor)
|
|
-- loop
|
|
-- Element (Cursor).Responder.respond;
|
|
-- next (Cursor);
|
|
-- end loop;
|
|
--
|
|
-- -- Wait for all responders to complete.
|
|
-- --
|
|
-- Cursor := the_filtered_impact_Response_Set.First;
|
|
--
|
|
-- while has_Element (Cursor)
|
|
-- loop
|
|
-- select
|
|
-- Element (Cursor).responses_Done.wait;
|
|
-- or
|
|
-- delay Duration'Last;
|
|
-- end select;
|
|
--
|
|
-- next (Cursor);
|
|
-- end loop;
|
|
--
|
|
-- exception
|
|
-- when E : others =>
|
|
-- put_Line ("'gel.World.local.Engine.impact response' has an unhandled exception ...");
|
|
-- put_Line (exception_Information (E));
|
|
-- end;
|
|
|
|
|
|
-- -- Update sprite transforms.
|
|
-- --
|
|
-- declare
|
|
-- use sprite_Maps_of_transforms;
|
|
--
|
|
-- Cursor : sprite_Maps_of_transforms.Cursor := the_sprite_Transforms.First;
|
|
-- the_Sprite : gel.Sprite.view;
|
|
-- begin
|
|
-- while has_Element (Cursor)
|
|
-- loop
|
|
-- the_Sprite := Key (Cursor);
|
|
-- declare
|
|
-- the_Transform : constant Matrix_4x4 := the_Sprite.Solid.get_Dynamics;
|
|
-- begin
|
|
-- the_sprite_Transforms.replace_Element (Cursor, the_Transform);
|
|
-- end;
|
|
-- next (Cursor);
|
|
-- end loop;
|
|
-- end;
|
|
--
|
|
-- the_World.all_sprite_Transforms.set (To => the_sprite_Transforms);
|
|
--
|
|
-- free_Sprites;
|
|
-- end evolve;
|
|
|
|
|
|
-- use type physics.Space.view;
|
|
--
|
|
-- begin
|
|
-- accept start (space_Kind : in physics.space_Kind)
|
|
-- do
|
|
-- Stopped := False;
|
|
-- the_World.physics_Space := physics.Forge.new_Space (space_Kind);
|
|
-- end start;
|
|
|
|
-- next_render_Time := ada.Calendar.Clock;
|
|
|
|
-- loop
|
|
-- select
|
|
-- accept stop
|
|
-- do
|
|
-- Stopped := True;
|
|
--
|
|
-- -- Add 'destroy' commands for all sprites.
|
|
-- --
|
|
-- declare
|
|
-- the_Sprites : Sprite.views renames the_World.Sprites;
|
|
-- begin
|
|
-- for i in 1 .. the_World.sprite_Count
|
|
-- loop
|
|
-- the_Sprites (i).destroy (and_Children => False);
|
|
-- end loop;
|
|
-- end;
|
|
|
|
-- Evolve the world til there are no commands left.
|
|
--
|
|
-- while not the_World.Commands.is_Empty
|
|
-- loop
|
|
-- evolve;
|
|
-- end loop;
|
|
|
|
-- Stop all impact responders tasks.
|
|
--
|
|
-- declare
|
|
-- use filtered_impact_Response_Sets;
|
|
--
|
|
-- procedure free is new ada.unchecked_Deallocation (Signal_Object,
|
|
-- Signal_Object_view);
|
|
--
|
|
-- Cursor : filtered_impact_Response_Sets.Cursor := the_filtered_impact_Response_Set.First;
|
|
--
|
|
-- the_Responder : impact_Responder_view;
|
|
-- the_Signal : Signal_Object_view;
|
|
--
|
|
-- begin
|
|
-- while has_Element (Cursor)
|
|
-- loop
|
|
-- the_Signal := Element (Cursor).responses_Done;
|
|
-- the_Responder := Element (Cursor).Responder;
|
|
-- the_Responder.stop;
|
|
--
|
|
-- while not the_Responder.all'Terminated
|
|
-- loop
|
|
-- delay 0.01;
|
|
-- end loop;
|
|
--
|
|
-- free (the_Responder);
|
|
-- free (the_Signal);
|
|
--
|
|
-- next (Cursor);
|
|
-- end loop;
|
|
-- end;
|
|
|
|
-- Free both sets of freeable sprites.
|
|
--
|
|
-- free_Sprites;
|
|
-- free_Sprites;
|
|
-- end stop;
|
|
|
|
-- exit when Stopped;
|
|
--
|
|
-- or
|
|
-- accept reset_Age
|
|
-- do
|
|
-- the_World.Age_is (0.0);
|
|
-- end reset_Age;
|
|
--
|
|
-- else
|
|
-- null;
|
|
-- end select;
|
|
--
|
|
--
|
|
-- if not the_World.is_a_Mirror
|
|
-- then
|
|
-- evolve;
|
|
-- end if;
|
|
--
|
|
--
|
|
-- the_World.new_sprite_transforms_Available.signal;
|
|
-- the_World.evolver_Done .signal;
|
|
--
|
|
--
|
|
-- -- Check for joint breakage.
|
|
-- --
|
|
-- if the_World.broken_joints_Allowed
|
|
-- then
|
|
-- declare
|
|
-- use gel.Joint,
|
|
-- physics.Space;
|
|
--
|
|
-- the_Joint : gel.Joint.view;
|
|
-- reaction_Force,
|
|
-- reaction_Torque : Real;
|
|
--
|
|
-- Cursor : physics.Space.joint_Cursor'Class := the_World.physics_Space.first_Joint;
|
|
-- begin
|
|
-- while has_Element (Cursor)
|
|
-- loop
|
|
-- the_Joint := to_GEL (Element (Cursor));
|
|
--
|
|
-- if the_Joint /= null
|
|
-- then
|
|
-- reaction_Force := abs (the_Joint.reaction_Force);
|
|
-- reaction_Torque := abs (the_Joint.reaction_Torque);
|
|
--
|
|
-- if reaction_Force > 50.0 / 8.0
|
|
-- or reaction_Torque > 100.0 / 8.0
|
|
-- then
|
|
-- begin
|
|
-- the_World.physics_Space .rid (the_Joint.Physics.all'Access);
|
|
-- the_World.broken_Joints.add (the_Joint);
|
|
--
|
|
-- exception
|
|
-- when no_such_Child =>
|
|
-- put_Line ("Error when breaking joint due to reaction Force: no_such_Child.");
|
|
-- end;
|
|
-- end if;
|
|
--
|
|
-- if reaction_Force > max_joint_Force
|
|
-- then
|
|
-- max_joint_Force := reaction_Force;
|
|
-- end if;
|
|
--
|
|
-- if reaction_Torque > max_joint_Torque
|
|
-- then
|
|
-- max_joint_Torque := reaction_Torque;
|
|
-- end if;
|
|
-- end if;
|
|
--
|
|
-- next (Cursor);
|
|
-- end loop;
|
|
-- end;
|
|
-- end if;
|
|
--
|
|
-- next_render_Time := next_render_Time + Duration (1.0 / 60.0);
|
|
-- end loop;
|
|
--
|
|
-- exception
|
|
-- when E : others =>
|
|
-- new_Line (2);
|
|
-- put_Line ("Error in gel.World.Engine");
|
|
-- new_Line;
|
|
-- put_Line (exception_Information (E));
|
|
-- put_Line ("Engine has terminated !");
|
|
-- new_Line (2);
|
|
-- end Engine;
|