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

107
4-high/gel/source/concrete/gel-keyboard-local.adb Normal file
View File

@@ -0,0 +1,107 @@
with
ada.unchecked_Deallocation;
package body gel.Keyboard.local
is
package body Forge
is
function to_Keyboard (of_Name : in String) return Item
is
begin
return Self : constant Item := (lace.Subject.local.Forge.to_Subject (of_Name)
with no_Modifiers)
do
null;
end return;
end to_Keyboard;
function new_Keyboard (of_Name : in String) return View
is
begin
return new Item' (to_Keyboard (of_Name));
end new_Keyboard;
end Forge;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
Self.destroy;
deallocate (Self);
end free;
--------------
--- Attributes
--
overriding
function Modifiers (Self : in Item) return Modifier_Set
is
begin
return Self.Modifiers;
end Modifiers;
--------------
--- Operations
--
overriding
procedure emit_key_press_Event (Self : in out Item; Key : in keyboard.Key;
key_Code : in Integer)
is
the_key_press_Event : key_press_Event;
begin
case Key is
when LSHIFT => Self.Modifiers (LSHIFT) := True;
when RSHIFT => Self.Modifiers (RSHIFT) := True;
when LCTRL => Self.Modifiers (LCTRL) := True;
when RCTRL => Self.Modifiers (RCTRL) := True;
when LALT => Self.Modifiers (LALT) := True;
when RALT => Self.Modifiers (RALT) := True;
when LMETA => Self.Modifiers (LMETA) := True;
when RMETA => Self.Modifiers (RMETA) := True;
when NUMLOCK => Self.Modifiers (NUM) := True;
when CAPSLOCK => Self.Modifiers (CAPS) := True;
when MODE => Self.Modifiers (MODE) := True;
when others => null;
end case;
the_key_press_Event := ((Key, Self.Modifiers), key_Code);
Self.emit (the_key_press_Event);
end emit_key_press_Event;
overriding
procedure emit_key_release_Event (Self : in out Item; Key : in keyboard.Key)
is
the_key_release_Event : key_release_Event;
begin
case Key is
when LSHIFT => Self.Modifiers (LSHIFT) := False;
when RSHIFT => Self.Modifiers (RSHIFT) := False;
when LCTRL => Self.Modifiers (LCTRL) := False;
when RCTRL => Self.Modifiers (RCTRL) := False;
when LALT => Self.Modifiers (LALT) := False;
when RALT => Self.Modifiers (RALT) := False;
when LMETA => Self.Modifiers (LMETA) := False;
when RMETA => Self.Modifiers (RMETA) := False;
when NUMLOCK => Self.Modifiers (NUM) := False;
when CAPSLOCK => Self.Modifiers (CAPS) := False;
when MODE => Self.Modifiers (MODE) := False;
when others => null;
end case;
the_key_release_Event := (modified_Key => (Key, Self.Modifiers));
Self.emit (the_key_release_Event);
end emit_key_release_Event;
end gel.Keyboard.local;

54
4-high/gel/source/concrete/gel-keyboard-local.ads Normal file
View File

@@ -0,0 +1,54 @@
with
lace.Subject.local;
package gel.Keyboard.local
--
-- Provides a concrete keyboard.
--
is
type Item is limited new lace.Subject.local.item
and gel.Keyboard.item with private;
type View is access all Item'class;
package Forge
is
function to_Keyboard (of_Name : in String) return Item;
function new_Keyboard (of_Name : in String) return View;
end Forge;
procedure free (Self : in out View);
--------------
--- Attributes
--
overriding
function Modifiers (Self : in Item) return Modifier_Set;
--------------
--- Operations
--
overriding
procedure emit_key_press_Event (Self : in out Item; Key : in keyboard.Key;
key_Code : in Integer);
overriding
procedure emit_key_release_Event (Self : in out Item; Key : in keyboard.Key);
private
type Item is limited new lace.Subject.local.item
and gel.Keyboard.item with
record
Modifiers : Modifier_Set := no_Modifiers;
end record;
end gel.Keyboard.local;

40
4-high/gel/source/concrete/gel-mouse-local.adb Normal file
View File

@@ -0,0 +1,40 @@
with
ada.unchecked_Deallocation;
package body gel.Mouse.local
is
package body Forge
is
function to_Mouse (of_Name : in String) return Item
is
begin
return Self : constant Item := (lace.Subject.local.Forge.to_Subject (of_Name)
with null record)
do
null;
end return;
end to_Mouse;
function new_Mouse (of_Name : in String) return View
is
begin
return new Item' (to_Mouse (of_Name));
end new_Mouse;
end Forge;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
Self.destroy;
deallocate (Self);
end free;
end gel.Mouse.local;

31
4-high/gel/source/concrete/gel-mouse-local.ads Normal file
View File

@@ -0,0 +1,31 @@
with
lace.Subject.local;
package gel.Mouse.local
--
-- Provides a concrete mouse.
--
is
type Item is limited new lace.Subject.local.item
and gel.Mouse .item with private;
type View is access all Item'Class;
package Forge
is
function to_Mouse (of_Name : in String) return Item;
function new_Mouse (of_Name : in String) return View;
end Forge;
procedure free (Self : in out View);
private
type Item is limited new lace.Subject.local.item
and gel.Mouse .item with null record;
end gel.Mouse.local;