645 lines
24 KiB
Ada
645 lines
24 KiB
Ada
with
|
|
ada.unchecked_Deallocation,
|
|
ada.Containers,
|
|
ada.Calendar,
|
|
ada.Text_IO,
|
|
ada.Exceptions;
|
|
|
|
package body physics.Engine
|
|
is
|
|
use ada.Text_IO;
|
|
|
|
|
|
protected body safe_command_Set
|
|
is
|
|
function is_Empty return Boolean
|
|
is
|
|
begin
|
|
return the_Count = 0;
|
|
end is_Empty;
|
|
|
|
|
|
procedure add (the_Command : in Command)
|
|
is
|
|
begin
|
|
the_Count := the_Count + 1;
|
|
Set (the_Count) := the_Command;
|
|
end add;
|
|
|
|
|
|
procedure Fetch (To : out Commands;
|
|
Count : out Natural)
|
|
is
|
|
begin
|
|
To (1 .. the_Count) := Set (1 .. the_Count);
|
|
Count := the_Count;
|
|
the_Count := 0;
|
|
end Fetch;
|
|
end safe_command_Set;
|
|
|
|
|
|
|
|
task body Evolver
|
|
is
|
|
use type physics.Joint.view,
|
|
ada.Containers.Count_type;
|
|
|
|
Stopped : Boolean := True;
|
|
Cycle : ada.Containers.Count_type := 0;
|
|
next_render_Time : ada.Calendar.Time;
|
|
|
|
-- max_joint_Force,
|
|
-- max_joint_Torque : Real := 0.0;
|
|
|
|
|
|
procedure free_Objects
|
|
is
|
|
-- the_free_Objects : gel.Object.views := the_World.free_Object_Set;
|
|
begin
|
|
-- for Each in the_free_Objects'Range
|
|
-- loop
|
|
-- log ("Engine is Freeing Object id: " & Object_Id'Image (the_free_Objects (Each).Id));
|
|
--
|
|
-- if the_free_Objects (Each).owns_Graphics
|
|
-- then
|
|
-- the_World.Renderer.free (the_free_Objects (Each).Visual.Model);
|
|
-- end if;
|
|
--
|
|
-- gel.Object.free (the_free_Objects (Each));
|
|
-- end loop;
|
|
null;
|
|
|
|
end free_Objects;
|
|
|
|
|
|
|
|
procedure evolve
|
|
is
|
|
begin
|
|
Cycle := Cycle + 1;
|
|
|
|
do_engine_Commands:
|
|
declare
|
|
the_Commands : Commands;
|
|
Count : Natural;
|
|
|
|
command_Count : array (command_Kind) of Natural := [others => 0];
|
|
|
|
begin
|
|
Self.Commands.fetch (the_Commands, Count);
|
|
|
|
for Each in 1 .. Count
|
|
loop
|
|
declare
|
|
the_Command : Command renames the_Commands (Each);
|
|
begin
|
|
command_Count (the_Command.Kind) := command_Count (the_Command.Kind) + 1;
|
|
|
|
case the_Command.Kind
|
|
is
|
|
when scale_Object =>
|
|
the_Command.Object.activate;
|
|
the_Command.Object.Shape.Scale_is (the_Command.Scale);
|
|
the_Command.Object .Scale_is (the_Command.Scale);
|
|
|
|
Self.Space.update_Bounds (the_Command.Object);
|
|
|
|
|
|
when update_Bounds =>
|
|
Self.Space.update_Bounds (the_Command.Object);
|
|
|
|
|
|
when update_Site =>
|
|
the_Command.Object.Site_is (the_Command.Site);
|
|
|
|
|
|
when set_Speed =>
|
|
the_Command.Object.Speed_is (the_Command.Speed);
|
|
|
|
|
|
when set_xy_Spin =>
|
|
the_Command.Object.xy_Spin_is (the_Command.xy_Spin);
|
|
|
|
|
|
when add_Object =>
|
|
declare
|
|
-- procedure rebuild_Shape (the_Object : in Object.view)
|
|
-- is
|
|
-- use type physics.Model.shape_Kind,
|
|
-- physics.Model.View;
|
|
--
|
|
-- the_Scale : aliased Vector_3;
|
|
--
|
|
-- begin
|
|
-- if the_Object.physics_Model = null then
|
|
-- return;
|
|
-- end if;
|
|
--
|
|
-- the_Scale := Self.physics_Model.Scale;
|
|
--
|
|
-- case Self.physics_Model.shape_Info.Kind
|
|
-- is
|
|
-- when physics.Model.Cube =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_box_Shape (Self.physics_Model.shape_Info.half_Extents));
|
|
--
|
|
-- when physics.Model.a_Sphere =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_sphere_Shape (Self.physics_Model.shape_Info.sphere_Radius));
|
|
--
|
|
-- when physics.Model.multi_Sphere =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics.new_multisphere_Shape (Self.physics_Model.shape_Info.Sites.all,
|
|
-- Self.physics_Model.shape_Info.Radii.all));
|
|
-- when physics.Model.Cone =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_cone_Shape (radius => Real (Self.physics_Model.Scale (1) / 2.0),
|
|
-- height => Real (Self.physics_Model.Scale (2))));
|
|
-- when physics.Model.a_Capsule =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_capsule_Shape (Self.physics_Model.shape_Info.lower_Radius,
|
|
-- Self.physics_Model.shape_Info.Height));
|
|
-- when physics.Model.Cylinder =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_cylinder_Shape (Self.physics_Model.shape_Info.half_Extents));
|
|
--
|
|
-- when physics.Model.Hull =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics.new_convex_hull_Shape (Self.physics_Model.shape_Info.Points.all));
|
|
--
|
|
-- when physics.Model.Mesh =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics .new_mesh_Shape (Self.physics_Model.shape_Info.Model));
|
|
--
|
|
-- when physics.Model.Plane =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_plane_Shape (Self.physics_Model.Shape_Info.plane_Normal,
|
|
-- Self.physics_Model.Shape_Info.plane_Offset));
|
|
-- when physics.Model.Heightfield =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics.new_heightfield_Shape (Self.physics_Model.shape_Info.Heights.all,
|
|
-- Self.physics_Model.Scale));
|
|
-- when physics.Model.Circle =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_circle_Shape (Self.physics_Model.shape_Info.circle_Radius));
|
|
--
|
|
-- when physics.Model.Polygon =>
|
|
-- Self.Shape := physics_Shape_view (Self.World.Physics. new_polygon_Shape (physics.space.polygon_Vertices (Self.physics_Model.shape_Info.Vertices (1 .. Self.physics_Model.shape_Info.vertex_Count))));
|
|
-- end case;
|
|
--
|
|
-- end rebuild_Shape;
|
|
|
|
|
|
procedure add (the_Object : in Object.view)
|
|
is
|
|
begin
|
|
-- the_World.add (the_Object. physics_Model.all'Access);
|
|
|
|
-- if the_Object.physics_Model.is_Tangible
|
|
-- then
|
|
|
|
-- rebuild_Shape (the_Object);
|
|
the_Object.Shape.define;
|
|
-- the_Object.define (Shape => the_Object.Shape,
|
|
-- Mass => the_Object.Model.Mass,
|
|
-- Friction => the_Object.Model.Friction,
|
|
-- Restitution => the_Object.Model.Restitution,
|
|
-- at_Site => the_Object.Model.Site);
|
|
|
|
Self.Space.add (the_Object);
|
|
-- end if;
|
|
|
|
-- begin
|
|
-- the_Object_Transforms.insert (the_Object, Identity_4x4);
|
|
-- the_Object.Solid.user_Data_is (the_Object);
|
|
-- end;
|
|
|
|
-- the_World.Object_Count := the_World.Object_Count + 1;
|
|
-- the_World.Objects (the_World.Object_Count) := the_Object;
|
|
end add;
|
|
|
|
begin
|
|
add (the_Command.Object);
|
|
end;
|
|
|
|
|
|
when rid_Object =>
|
|
declare
|
|
function find (the_Object : in Object.view) return Index
|
|
is
|
|
begin
|
|
-- for Each in 1 .. the_World.Object_Count
|
|
-- loop
|
|
-- if the_World.Objects (Each) = the_Object
|
|
-- then
|
|
-- return Each;
|
|
-- end if;
|
|
-- end loop;
|
|
|
|
raise constraint_Error with "no such Object in world";
|
|
return 0;
|
|
end find;
|
|
|
|
|
|
procedure rid (the_Object : in Object.view)
|
|
is
|
|
use type Object.view;
|
|
begin
|
|
if the_Object /= null
|
|
then
|
|
-- if the_Object.physics_Model.is_Tangible
|
|
-- then
|
|
Self.Space.rid (the_Object);
|
|
-- end if;
|
|
|
|
-- if the_Object_Transforms.contains (the_Object) then
|
|
-- the_Object_Transforms.delete (the_Object);
|
|
-- end if;
|
|
|
|
else
|
|
raise program_Error;
|
|
end if;
|
|
|
|
|
|
declare
|
|
Id : Index;
|
|
pragma Unreferenced (Id);
|
|
begin
|
|
Id := find (the_Object);
|
|
|
|
-- if Id <= the_World.Object_Count
|
|
-- then
|
|
-- the_World.Objects (1 .. the_World.Object_Count - 1)
|
|
-- := the_World.Objects ( 1 .. Id - 1)
|
|
-- & the_World.Objects (Id + 1 .. the_World.Object_Count);
|
|
-- end if;
|
|
|
|
-- the_World.Object_Count := the_World.Object_Count - 1;
|
|
end;
|
|
end rid;
|
|
|
|
begin
|
|
rid (the_Command.Object);
|
|
end;
|
|
|
|
|
|
when apply_Force =>
|
|
the_Command.Object.apply_Force (the_Command.Force);
|
|
|
|
|
|
when destroy_Object =>
|
|
declare
|
|
-- the_free_Set : free_Set renames the_World.free_Sets (the_World.current_free_Set);
|
|
begin
|
|
raise Program_Error with "destroy_Object ~ TODO";
|
|
-- the_free_Set.Count := the_free_Set.Count + 1;
|
|
-- the_free_Set.Objects (the_free_Set.Count) := the_Command.Object;
|
|
end;
|
|
|
|
|
|
when add_Joint =>
|
|
Self.Space.add (the_Command.Joint.all'Access);
|
|
the_Command.Joint.user_Data_is (the_Command.Joint);
|
|
|
|
|
|
when rid_Joint =>
|
|
Self.Space.rid (the_Command.Joint.all'Access);
|
|
|
|
|
|
when set_Joint_local_Anchor =>
|
|
Self.Space.set_Joint_local_Anchor (the_Command.anchor_Joint.all'Access,
|
|
the_Command.is_Anchor_A,
|
|
the_Command.local_Anchor);
|
|
|
|
when free_Joint =>
|
|
-- Joint.free (the_Command.Joint);
|
|
null;
|
|
|
|
|
|
when cast_Ray =>
|
|
null;
|
|
-- declare
|
|
-- function cast_Ray (Self : in Item'Class; From, To : in math.Vector_3) return ray_Collision
|
|
-- is
|
|
-- use type std_physics.Object.view;
|
|
--
|
|
-- physics_Collision : constant standard.physics.Space.ray_Collision := Self.physics.cast_Ray (From, To);
|
|
-- begin
|
|
-- if physics_Collision.near_Object = null
|
|
-- then
|
|
-- return ray_Collision' (near_Object => 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_Object = null
|
|
-- or else the_Collision.near_Object.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.near_Object := the_Collision.near_Object;
|
|
-- the_Event.Context := the_Command.Context;
|
|
-- the_Event.Site_world := the_Collision.Site_world;
|
|
--
|
|
-- the_Command.Observer.receive (the_Event, from_subject => the_World.Name);
|
|
-- end;
|
|
-- end if;
|
|
-- end;
|
|
|
|
|
|
when set_Gravity =>
|
|
Self.Space.Gravity_is (the_Command.Gravity);
|
|
end case;
|
|
end;
|
|
end loop;
|
|
end do_engine_Commands;
|
|
|
|
Self.Space.evolve (by => 1.0 / 60.0); -- Evolve the world.
|
|
-- free_Objects;
|
|
|
|
end evolve;
|
|
|
|
use ada.Calendar;
|
|
|
|
begin
|
|
-- accept start (space_Kind : in physics.space_Kind)
|
|
accept start (the_Space : in Space.view)
|
|
do
|
|
Stopped := False;
|
|
|
|
-- Self.Space := physics.Forge.new_Space (space_Kind);
|
|
Self.Space := the_Space;
|
|
end start;
|
|
|
|
|
|
next_render_Time := ada.Calendar.Clock;
|
|
|
|
loop
|
|
select
|
|
accept stop
|
|
do
|
|
Stopped := True;
|
|
|
|
|
|
-- Add 'destroy' commands for all Objects.
|
|
--
|
|
-- declare
|
|
-- the_Objects : Object.views renames the_World.Objects;
|
|
-- begin
|
|
-- for i in 1 .. the_World.Object_Count
|
|
-- loop
|
|
-- the_Objects (i).destroy (and_Children => False);
|
|
-- end loop;
|
|
-- end;
|
|
|
|
-- Evolve the world til there are no commands left.
|
|
--
|
|
while not Self.Commands.is_Empty
|
|
loop
|
|
evolve;
|
|
end loop;
|
|
|
|
-- Free both sets of freeable Objects.
|
|
--
|
|
free_Objects;
|
|
free_Objects;
|
|
end stop;
|
|
|
|
exit when Stopped;
|
|
|
|
or
|
|
accept reset_Age
|
|
do
|
|
Self.Age := 0.0;
|
|
end reset_Age;
|
|
|
|
else
|
|
null;
|
|
end select;
|
|
|
|
|
|
evolve;
|
|
|
|
|
|
-- the_World.new_Object_transforms_Available.signal;
|
|
-- the_World.evolver_Done .signal;
|
|
|
|
|
|
-- Check for joint breakage.
|
|
--
|
|
-- if the_World.broken_joints_Allowed
|
|
-- then
|
|
-- declare
|
|
-- use gel.Joint,
|
|
-- standard.physics.Space;
|
|
--
|
|
-- the_Joint : gel.Joint.view;
|
|
-- reaction_Force,
|
|
-- reaction_Torque : math.Real;
|
|
--
|
|
-- Cursor : standard.physics.Space.joint_Cursor'Class := the_World.Physics.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 .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 physics.Engine.evolver task !");
|
|
new_Line;
|
|
put_Line (Ada.Exceptions.Exception_Information (E));
|
|
put_Line ("Evolver has terminated !");
|
|
new_Line (2);
|
|
end Evolver;
|
|
|
|
|
|
|
|
-- procedure start (Self : access Item; space_Kind : in physics.space_Kind)
|
|
procedure start (Self : access Item; the_Space : in Space.view)
|
|
is
|
|
begin
|
|
Self.Evolver.start (the_Space);
|
|
end start;
|
|
|
|
|
|
procedure stop (Self : access Item)
|
|
is
|
|
procedure free is new ada.unchecked_Deallocation (safe_command_Set, safe_command_Set_view);
|
|
begin
|
|
Self.Evolver.stop;
|
|
free (Self.Commands);
|
|
end stop;
|
|
|
|
|
|
|
|
procedure add (Self : access Item; the_Object : in Object.view)
|
|
is
|
|
begin
|
|
put_Line ("physics engine: add Object");
|
|
Self.Commands.add ((Kind => add_Object,
|
|
Object => the_Object,
|
|
add_Children => False));
|
|
end add;
|
|
|
|
|
|
procedure rid (Self : in out Item; the_Object : in Object.view)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => rid_Object,
|
|
Object => the_Object,
|
|
rid_Children => False));
|
|
end rid;
|
|
|
|
|
|
|
|
procedure add (Self : in out Item; the_Joint : in Joint.view)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => add_Joint,
|
|
Object => null,
|
|
Joint => the_Joint));
|
|
end add;
|
|
|
|
|
|
procedure rid (Self : in out Item; the_Joint : in Joint.view)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => rid_Joint,
|
|
Object => null,
|
|
Joint => the_Joint));
|
|
end rid;
|
|
|
|
|
|
|
|
procedure update_Scale (Self : in out Item; of_Object : in Object.view;
|
|
To : in math.Vector_3)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => scale_Object,
|
|
Object => of_Object,
|
|
Scale => To));
|
|
end update_Scale;
|
|
|
|
|
|
|
|
procedure apply_Force (Self : in out Item; to_Object : in Object.view;
|
|
Force : in math.Vector_3)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => apply_Force,
|
|
Object => to_Object,
|
|
Force => Force));
|
|
end apply_Force;
|
|
|
|
|
|
|
|
procedure update_Site (Self : in out Item; of_Object : in Object.view;
|
|
To : in math.Vector_3)
|
|
is
|
|
begin
|
|
put_Line ("physics engine: update_Site");
|
|
Self.Commands.add ((Kind => update_Site,
|
|
Object => of_Object,
|
|
Site => To));
|
|
end update_Site;
|
|
|
|
|
|
|
|
procedure set_Speed (Self : in out Item; of_Object : in Object.view;
|
|
To : in math.Vector_3)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => set_Speed,
|
|
Object => of_Object,
|
|
Speed => To));
|
|
end set_Speed;
|
|
|
|
|
|
|
|
procedure set_Gravity (Self : in out Item; To : in math.Vector_3)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => set_Gravity,
|
|
Object => null,
|
|
Gravity => To));
|
|
end set_Gravity;
|
|
|
|
|
|
|
|
procedure set_xy_Spin (Self : in out Item; of_Object : in Object.view;
|
|
To : in math.Radians)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => set_xy_Spin,
|
|
Object => of_Object,
|
|
xy_Spin => To));
|
|
end set_xy_Spin;
|
|
|
|
|
|
|
|
procedure update_Bounds (Self : in out Item; of_Object : in Object.view)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => update_Bounds,
|
|
Object => of_Object));
|
|
end update_Bounds;
|
|
|
|
|
|
|
|
procedure set_local_Anchor (Self : in out Item; for_Joint : in Joint.view;
|
|
To : in math.Vector_3;
|
|
is_Anchor_A : in Boolean)
|
|
is
|
|
begin
|
|
Self.Commands.add ((Kind => set_Joint_local_Anchor,
|
|
Object => null,
|
|
anchor_Joint => for_Joint,
|
|
local_Anchor => To,
|
|
is_Anchor_A => is_Anchor_A));
|
|
end set_local_Anchor;
|
|
|
|
end physics.Engine;
|