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;