nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Re-enable mouse selection of sprites.

Browse Source
This commit is contained in:
Rod Kay
2023-04-21 17:43:18 +10:00
parent ac39003165
commit ac87a2e6ca
6 changed files with 110 additions and 217 deletions
Download Patch File Download Diff File Expand all files Collapse all files

177
4-high/gel/source/applet/gel-applet.adb
View File

@@ -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;

13
4-high/gel/source/applet/gel-applet.ads
View File

@@ -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);

49
4-high/gel/source/world/gel-world.adb
View File

@@ -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

34
4-high/gel/source/world/gel-world.ads
View File

@@ -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.
--------------------