diff --git a/3-mid/physics/interface/source/private/bullet/bullet_physics-space.adb b/3-mid/physics/interface/source/private/bullet/bullet_physics-space.adb index 3af2b38..df691e7 100644 --- a/3-mid/physics/interface/source/private/bullet/bullet_physics-space.adb +++ b/3-mid/physics/interface/source/private/bullet/bullet_physics-space.adb @@ -392,29 +392,29 @@ is end rid; + overriding function cast_Ray (Self : access Item; From, To : in Vector_3) return physics.Space.ray_Collision is - c_From : aliased c_math_c.Vector_3.item := +From; - c_To : aliased c_math_c.Vector_3.item := +To; - - the_Collision : physics.Space.ray_Collision; + c_From : aliased c_math_c.Vector_3.item := +From; + c_To : aliased c_math_c.Vector_3.item := +To; the_c_Collision : constant bullet_c.ray_Collision.item := b3d_Space_cast_Ray (Self.C, c_From'unchecked_Access, c_To 'unchecked_Access); + the_Collision : physics.Space.ray_Collision; begin if the_c_Collision.near_Object /= null then - the_Collision.near_Object := to_Object_view (b3d_Object_user_Data (the_c_Collision.near_Object)); + the_Collision.near_Object := to_Object_view (b3d_Object_user_Data (the_c_Collision.near_Object)); + the_Collision.hit_Fraction := Real (the_c_Collision.hit_Fraction); + the_Collision.Normal_world := +the_c_Collision.Normal_world; + the_Collision.Site_world := +the_c_Collision.Site_world; end if; - the_Collision.hit_Fraction := Real (the_c_Collision.hit_Fraction); - the_Collision.Normal_world := +the_c_Collision.Normal_world; - the_Collision.Site_world := +the_c_Collision.Site_world; - return the_Collision; end cast_Ray; + overriding procedure evolve (Self : in out Item; By : in Duration) is diff --git a/4-high/gel/applet/demo/mouse/mouse_selection/launch_mouse_selection.adb b/4-high/gel/applet/demo/mouse/mouse_selection/launch_mouse_selection.adb index bff958c..2171e2d 100644 --- a/4-high/gel/applet/demo/mouse/mouse_selection/launch_mouse_selection.adb +++ b/4-high/gel/applet/demo/mouse/mouse_selection/launch_mouse_selection.adb @@ -28,18 +28,21 @@ procedure launch_mouse_Selection is use lace.Event.utility, ada.Text_IO; + + the_Applet : gel.Applet.gui_world.view; + begin - lace.Event.utility.use_text_Logger ("event.log"); + lace.Event.utility.use_text_Logger ("events"); lace.Event.utility.Logger.ignore (to_Kind (gel.Mouse.motion_Event'Tag)); + the_Applet := gel.Forge.new_gui_Applet ("mouse_Demo", + space_Kind => physics.Bullet); + declare use ada.Calendar; - the_Applet : constant gel.Applet.gui_world.view := gel.Forge.new_gui_Applet ("mouse_Selection_Applet", - space_Kind => physics.Bullet); the_Ball : constant gel.Sprite.view := gel.Forge.new_ball_Sprite (the_Applet.World (1), - mass => 0.0); - + mass => 1.0); type retreat_Sprite is new lace.Response.item with @@ -52,7 +55,7 @@ begin is use float_Math; begin - put_Line ("retreat_Sprite"); + put_Line ("*** retreat_Sprite ***"); Self.Sprite.Site_is (Self.Sprite.Site - the_Applet.gui_Camera.Spin * [0.0, 0.0, 1.0]); end respond; @@ -71,7 +74,7 @@ begin is use float_Math; begin - put_Line ("advance_Sprite"); + put_Line ("*** advance_Sprite ***"); Self.Sprite.Site_is (Self.Sprite.Site + the_Applet.gui_Camera.Spin * [0.0, 0.0, 1.0]); end respond; @@ -83,13 +86,18 @@ begin next_render_Time : ada.calendar.Time; begin - the_Ball.add (advance_Sprite_Response'unchecked_Access, - to_Kind (gel.events.sprite_click_down_Event'Tag), - the_Applet.Name); + the_Applet.gui_World.Gravity_is ([0.0, 0.0, 0.0]); + + connect (the_Observer => the_Applet.local_Observer, + to_Subject => the_Ball.all'Access, + with_Response => advance_Sprite_Response'unchecked_Access, + to_Event_Kind => to_Kind (gel.events.sprite_click_down_Event'Tag)); + + connect (the_Observer => the_Applet.local_Observer, + to_Subject => the_Ball.all'Access, + with_Response => retreat_Sprite_Response'unchecked_Access, + to_Event_Kind => to_Kind (gel.events.sprite_click_up_Event'Tag)); - the_Ball.add (retreat_Sprite_Response'unchecked_Access, - to_Kind (gel.events.sprite_click_up_Event'Tag), - the_Applet.Name); the_Applet.gui_world .add (the_Ball, and_Children => False); the_Applet.gui_Camera.Site_is ([0.0, 0.0, 5.0]); @@ -114,9 +122,11 @@ begin lace.Event.utility.close; + exception when E : others => lace.Event.utility.close; + the_Applet.destroy; put_Line ("Exception detected in 'launch_mouse_Selection' ..."); put_Line (ada.Exceptions.Exception_Information (E)); diff --git a/4-high/gel/source/applet/gel-applet.adb b/4-high/gel/source/applet/gel-applet.adb index d8afcec..2899ce3 100644 --- a/4-high/gel/source/applet/gel-applet.adb +++ b/4-high/gel/source/applet/gel-applet.adb @@ -9,7 +9,6 @@ with openGL.Palette, openGL.Renderer.lean.forge, - lace.Any, lace.Event.utility, ada.unchecked_Conversion, @@ -731,61 +730,10 @@ is --- Mouse Button Responses -- - type button_press_raycast_Context is new lace.Any.limited_item with - record - is_Motion : Boolean; - is_Press : Boolean; - button_Id : gel.mouse.Button_Id; - end record; - - type button_press_raycast_Context_view is access all button_press_raycast_Context'Class; - - - overriding - procedure respond (Self : in out mouse_click_raycast_Response; to_Event : in lace.Event.item'Class) - is - use gel.World; - - the_Event : raycast_collision_Event := raycast_collision_Event (to_Event); - the_Context : constant button_press_raycast_Context_view := button_press_raycast_Context_view (the_Event.Context); - begin - if the_Context.is_Motion - then - null; - - else - if the_Context.is_Press - then - declare - collide_Event : constant gel.events.sprite_click_down_Event := (mouse_Button => the_Context.button_Id, - world_Site => the_Event.Site_world); - begin - the_Event.near_Sprite.receive (collide_Event, Self.Applet.Name); - end; - - else -- Is a button release. - declare - collide_Event : constant gel.events.sprite_click_up_Event := (mouse_Button => the_Context.button_Id, - world_Site => the_Event.Site_world); - begin - the_Event.near_Sprite.receive (collide_Event, Self.Applet.Name); - end; - end if; - end if; - - the_Event.destruct; - end respond; - - - - type mouse_button_collision_Event is new gel.World.raycast_collision_Event with null record; - - overriding procedure respond (Self : in out button_press_Response; to_Event : in lace.Event.item'Class) is - use world_Vectors, - gel.Mouse; + use world_Vectors; the_Event : gel.mouse.button_press_Event renames gel.Mouse.button_press_Event (to_Event); Cursor : world_Vectors.Cursor := Self.Applet.Worlds.First; @@ -799,26 +747,24 @@ is declare use gel.World; - the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element; + the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element; - Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)), - Real (the_Event.Site (2)), - 1.0]; - Site_world_space : constant Vector_3 := the_Camera.to_world_Site (Site_window_space); + Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)), + Real (the_Event.Site (2)), + 1.0]; - the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context; - event_Kind : mouse_button_collision_Event; + Site_world_space : constant Vector_3 := the_Camera.to_world_Site (Site_window_space); + Collision : ray_Collision := the_world_Info.World.cast_Ray (From => the_Camera.Site, + To => Site_world_space); + + Event : constant gel.Events.sprite_click_down_Event := (mouse_Button => the_Event.Button, + world_Site => Site_world_space); begin - the_Context.is_Motion := False; - the_Context.is_Press := True; - the_Context.button_Id := the_Event.Button; - - the_world_Info.World.cast_Ray (From => the_Camera.Site, - To => Site_world_space, - Observer => lace.Observer.view (Self.Applet.local_Subject_and_Observer), - Context => the_Context, - event_Kind => event_Kind); + if Collision.near_Sprite /= null + then + Collision.near_Sprite.emit (Event); + end if; end; next (Cursor); @@ -830,8 +776,7 @@ is overriding procedure respond (Self : in out button_release_Response; to_Event : in lace.Event.item'Class) is - use world_Vectors, - gel.Mouse; + use world_Vectors; the_Event : gel.Mouse.button_release_Event renames gel.Mouse.button_release_Event (to_Event); Cursor : world_Vectors.Cursor := Self.Applet.Worlds.First; @@ -843,28 +788,31 @@ is the_world_Info := Element (Cursor); declare - the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element; + use gel.World; - Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)), Real (the_Event.Site (2)), 1.0]; - Site_world_space : constant Vector_3 := the_Camera.to_world_Site (Site_window_space); + the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element; - the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context; - event_Kind : mouse_button_collision_Event; + Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)), + Real (the_Event.Site (2)), + 1.0]; + Site_world_space : constant Vector_3 := the_Camera.to_world_Site (Site_window_space); + + Collision : ray_Collision := the_world_Info.World.cast_Ray (From => the_Camera.Site, + To => Site_world_space); + + Event : constant gel.Events.sprite_click_up_Event := (mouse_Button => the_Event.Button, + world_Site => Site_world_space); begin - the_Context.is_Motion := False; - the_Context.is_Press := False; - the_Context.button_Id := the_Event.Button; - - the_world_Info.World.cast_Ray (From => the_Camera.Site, - To => Site_world_space, - Observer => lace.Observer.view (Self.Applet.local_Subject_and_Observer), - Context => the_Context, - event_Kind => event_Kind); + if Collision.near_Sprite /= null + then + Collision.near_Sprite.emit (Event); + end if; end; next (Cursor); end loop; + end respond; @@ -879,26 +827,27 @@ is the_world_Info : world_Info_view; begin - while has_Element (Cursor) - loop - the_world_Info := Element (Cursor); - - declare - the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element; - - Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)), Real (the_Event.Site (2)), 1.0]; - Site_world_space : constant Vector_3 := the_Camera.to_world_Site (Site_window_space); - pragma Unreferenced (Site_world_space); - - the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context; - - begin - the_Context.is_Motion := True; - end; - - next (Cursor); - end loop; + -- while has_Element (Cursor) + -- loop + -- the_world_Info := Element (Cursor); + -- + -- declare + -- the_Camera : constant gel.Camera.view := the_world_Info.Cameras.first_Element; + -- + -- Site_window_space : constant Vector_3 := [Real (the_Event.Site (1)), Real (the_Event.Site (2)), 1.0]; + -- Site_world_space : constant Vector_3 := the_Camera.to_world_Site (Site_window_space); + -- pragma Unreferenced (Site_world_space); + -- + -- the_Context : constant button_press_raycast_Context_view := new button_press_raycast_Context; + -- + -- begin + -- the_Context.is_Motion := True; + -- end; + -- + -- next (Cursor); + -- end loop; + null; end respond; @@ -958,26 +907,6 @@ is Self.mouse_motion_Response'unchecked_Access, to_Kind (gel.Mouse.motion_Event'Tag)); end if; - - Self.mouse_click_raycast_Response.Applet := Self.all'unchecked_Access; - - declare - use world_Vectors; - - Cursor : world_Vectors.Cursor := Self.Worlds.First; - the_world_Info : world_Info_view; - begin - while has_Element (Cursor) - loop - the_world_Info := Element (Cursor); - - Self.local_Subject_and_Observer.add (the_Response => Self.mouse_click_raycast_Response'unchecked_Access, - to_Kind => lace.event.Utility.to_Kind (mouse_button_collision_Event'Tag), - from_Subject => the_world_Info.World.Name); - next (Cursor); - end loop; - end; - end enable_Mouse; diff --git a/4-high/gel/source/applet/gel-applet.ads b/4-high/gel/source/applet/gel-applet.ads index 21389dc..d11610b 100644 --- a/4-high/gel/source/applet/gel-applet.ads +++ b/4-high/gel/source/applet/gel-applet.ads @@ -192,17 +192,6 @@ private procedure respond (Self : in out mouse_motion_Response; to_Event : in lace.Event.item'Class); - type mouse_click_raycast_Response is new lace.Response.item with - record - Applet : gel.Applet.view; - end record; - - overriding - procedure respond (Self : in out mouse_click_raycast_Response; to_Event : in lace.Event.item'Class); - - type mouse_click_raycast_Response_view is access all mouse_click_raycast_Response'Class; - - -- 'Screen' Resize Response -- type resize_event_Response is new applet_event_Response with null record; @@ -210,6 +199,7 @@ private procedure respond (Self : in out resize_event_Response; to_Event : in lace.Event.Item'Class); + ---------------- --- world_Vector -- @@ -238,7 +228,6 @@ private button_press_Response : aliased applet.button_press_Response; button_release_Response : aliased applet.button_release_Response; mouse_motion_Response : aliased applet.mouse_motion_Response; - mouse_click_raycast_Response : aliased applet.mouse_click_raycast_Response; Renderer : openGL.Renderer.lean.view; Font : opengl.Font.font_Id := (openGL.to_Asset ("assets/opengl/font/LiberationMono-Regular.ttf"), 30); diff --git a/4-high/gel/source/world/gel-world.adb b/4-high/gel/source/world/gel-world.adb index 9988f90..efce921 100644 --- a/4-high/gel/source/world/gel-world.adb +++ b/4-high/gel/source/world/gel-world.adb @@ -467,23 +467,29 @@ 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) + function cast_Ray (Self : in Item; 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 - null; - -- Self.Commands.add ((Kind => cast_Ray, - -- Sprite => null, - -- From => From, - -- To => To, - -- Observer => Observer, - -- Context => Context, - -- event_Kind => event_Kind'Tag)); + 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; + + + -------------- --- Collisions -- @@ -1102,25 +1108,6 @@ is 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 diff --git a/4-high/gel/source/world/gel-world.ads b/4-high/gel/source/world/gel-world.ads index da96eb4..a7affc5 100644 --- a/4-high/gel/source/world/gel-world.ads +++ b/4-high/gel/source/world/gel-world.ads @@ -14,6 +14,7 @@ with lace.Subject_and_deferred_Observer, lace.Any, + ada.Streams, ada.Tags.generic_dispatching_Constructor, ada.unchecked_Conversion, ada.Containers.hashed_Maps; @@ -38,6 +39,10 @@ is use Math; + type Any_limited_view is access all lace.Any.limited_item'Class; + + + --------- -- Forge -- @@ -215,36 +220,9 @@ is Site_world : Vector_3; end record; - - type Any_limited_view is access all lace.Any.limited_item'Class; - - type raycast_collision_Event is new lace.Event.item with - record - near_Sprite : gel.Sprite.view; - Context : Any_limited_view; - Site_world : Vector_3; - end record; - - overriding - procedure destruct (Self : in out raycast_collision_Event); + function cast_Ray (Self : in Item; From, To : in Vector_3) return ray_Collision; - type no_Parameters is null record; - - function to_raycast_collision_Event (Params : not null access no_Parameters) return raycast_collision_Event; - - function raycast_collision_Event_dispatching_Constructor is new ada.Tags.generic_dispatching_Constructor (raycast_collision_Event, - Parameters => no_Parameters, - Constructor => to_raycast_collision_Event); - 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); - -- - -- Casts a ray between From and To. - -- The Observer is informed of the 1st collision with a Sprite via a raycast_collision_Event. - -- Context is optional and is passed back to the Observer within the Context field of the raycast_collision_Event - -- for use by the raycast_collision_Event response. --------------------