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

644
3-mid/physics/interface/source/physics-engine.adb Normal file
View File

@@ -0,0 +1,644 @@
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;