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

199
4-high/gel/source/interface/gel-keyboard.adb Normal file
View File

@@ -0,0 +1,199 @@
with
ada.Characters.latin_1;
package body gel.Keyboard
is
function Image (Self : in modified_Key) return Character
is
use ada.Characters.latin_1;
key_Map_of_character : constant array (Key) of Character
:= [SPACE => ' ',
QUOTE => ''',
COMMA => ',',
MINUS => '-',
PERIOD => '.',
SLASH => '/',
'0' => '0',
'1' => '1',
'2' => '2',
'3' => '3',
'4' => '4',
'5' => '5',
'6' => '6',
'7' => '7',
'8' => '8',
'9' => '9',
SEMICOLON => ';',
EQUALS => '=',
LEFTBRACKET => '[',
BACKSLASH => '\',
RIGHTBRACKET => ']',
BACKQUOTE => '`',
a => 'a',
b => 'b',
c => 'c',
d => 'd',
e => 'e',
f => 'f',
g => 'g',
h => 'h',
i => 'i',
j => 'j',
k => 'k',
l => 'l',
m => 'm',
n => 'n',
o => 'o',
p => 'p',
q => 'q',
r => 'r',
s => 's',
t => 't',
u => 'u',
v => 'v',
w => 'w',
x => 'x',
y => 'y',
z => 'z',
KP0 => '0',
KP1 => '1',
KP2 => '2',
KP3 => '3',
KP4 => '4',
KP5 => '5',
KP6 => '6',
KP7 => '7',
KP8 => '8',
KP9 => '9',
KP_PERIOD => '.',
KP_DIVIDE => '/',
KP_MULTIPLY => '*',
KP_MINUS => '-',
KP_PLUS => '+',
KP_ENTER => NUL,
KP_EQUALS => '=',
others => NUL];
shifted_key_Map_of_character : constant array (Key) of Character
:= [SPACE => ' ',
QUOTE => '"',
COMMA => '<',
MINUS => '_',
PERIOD => '>',
SLASH => '?',
'0' => ')',
'1' => '!',
'2' => '@',
'3' => '#',
'4' => '$',
'5' => '%',
'6' => '^',
'7' => '&',
'8' => '*',
'9' => '(',
SEMICOLON => ':',
EQUALS => '+',
LEFTBRACKET => '{',
BACKSLASH => '|',
RIGHTBRACKET => '}',
BACKQUOTE => '~',
a => 'A',
b => 'B',
c => 'C',
d => 'D',
e => 'E',
f => 'F',
g => 'G',
h => 'H',
i => 'I',
j => 'J',
k => 'K',
l => 'L',
m => 'M',
n => 'N',
o => 'O',
p => 'P',
q => 'Q',
r => 'R',
s => 'S',
t => 'T',
u => 'U',
v => 'V',
w => 'W',
x => 'X',
y => 'Y',
z => 'Z',
KP0 => '0',
KP1 => '1',
KP2 => '2',
KP3 => '3',
KP4 => '4',
KP5 => '5',
KP6 => '6',
KP7 => '7',
KP8 => '8',
KP9 => '9',
KP_PERIOD => '.',
KP_DIVIDE => '/',
KP_MULTIPLY => '*',
KP_MINUS => '-',
KP_PLUS => '+',
KP_ENTER => NUL,
KP_EQUALS => '=',
others => NUL];
begin
if Self.modifier_Set (LShift)
or else Self.modifier_Set (RShift)
then
return shifted_key_Map_of_Character (Self.Key);
else
return key_Map_of_Character (Self.Key);
end if;
end Image;
function is_Graphic (Self : in Key) return Boolean
is
begin
return Self = SPACE
or else Self = QUOTE
or else Self = COMMA
or else Self = MINUS
or else Self = PERIOD
or else Self = SLASH
or else Self in '0' .. '9'
or else Self = SEMICOLON
or else Self = EQUALS
or else Self = LEFTBRACKET
or else Self = BACKSLASH
or else Self = RIGHTBRACKET
or else Self = BACKQUOTE
or else Self in a .. z
or else Self in KP0 .. KP9
or else Self = KP_PERIOD
or else Self = KP_DIVIDE
or else Self = KP_MULTIPLY
or else Self = KP_MINUS
or else Self = KP_PLUS
or else Self = KP_EQUALS;
end is_Graphic;
end gel.Keyboard;

163
4-high/gel/source/interface/gel-keyboard.ads Normal file
View File

@@ -0,0 +1,163 @@
with
lace.Event,
lace.Subject;
package gel.Keyboard with remote_Types
--
-- Provides an interface for a keyboard.
--
is
type Item is limited interface
and lace.Subject.item;
type View is access all Item'class;
--------
--- Keys
--
type Key is (Nil, -- TODO: Better names.
BACKSPACE,
TAB,
CLEAR,
ENTER,
PAUSE,
ESCAPE,
SPACE,
EXCLAIM,
QUOTEDBL,
HASH,
DOLLAR,
Percent,
AMPERSAND,
QUOTE,
LEFTPAREN,
RIGHTPAREN,
ASTERISK,
PLUS,
COMMA,
MINUS,
PERIOD,
SLASH,
'0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
COLON, SEMICOLON,
LESS, EQUALS, GREATER,
QUESTION,
AT_key,
LEFTBRACKET,
BACKSLASH,
RIGHTBRACKET,
CARET,
UNDERSCORE,
BACKQUOTE,
a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z,
DELETE,
WORLD_0, WORLD_1, WORLD_2, WORLD_3, WORLD_4, WORLD_5, WORLD_6, WORLD_7, WORLD_8, WORLD_9,
WORLD_10, WORLD_11, WORLD_12, WORLD_13, WORLD_14, WORLD_15, WORLD_16, WORLD_17, WORLD_18, WORLD_19,
WORLD_20, WORLD_21, WORLD_22, WORLD_23, WORLD_24, WORLD_25, WORLD_26, WORLD_27, WORLD_28, WORLD_29,
WORLD_30, WORLD_31, WORLD_32, WORLD_33, WORLD_34, WORLD_35, WORLD_36, WORLD_37, WORLD_38, WORLD_39,
WORLD_40, WORLD_41, WORLD_42, WORLD_43, WORLD_44, WORLD_45, WORLD_46, WORLD_47, WORLD_48, WORLD_49,
WORLD_50, WORLD_51, WORLD_52, WORLD_53, WORLD_54, WORLD_55, WORLD_56, WORLD_57, WORLD_58, WORLD_59,
WORLD_60, WORLD_61, WORLD_62, WORLD_63, WORLD_64, WORLD_65, WORLD_66, WORLD_67, WORLD_68, WORLD_69,
WORLD_70, WORLD_71, WORLD_72, WORLD_73, WORLD_74, WORLD_75, WORLD_76, WORLD_77, WORLD_78, WORLD_79,
WORLD_80, WORLD_81, WORLD_82, WORLD_83, WORLD_84, WORLD_85, WORLD_86, WORLD_87, WORLD_88, WORLD_89,
WORLD_90, WORLD_91, WORLD_92, WORLD_93, WORLD_94, WORLD_95,
KP0, KP1, KP2, KP3, KP4, KP5, KP6, KP7, KP8, KP9,
KP_PERIOD,
KP_DIVIDE, KP_MULTIPLY, KP_MINUS, KP_PLUS,
KP_ENTER, KP_EQUALS,
UP, DOWN, RIGHT, LEFT,
INSERT,
HOME, END_key,
PAGEUP, PAGEDOWN,
F1, F2, F3, F4, F5, F6, F7, F8, F9, F10, F11, F12, F13, F14, F15,
NUMLOCK, CAPSLOCK, SCROLLLOCK,
RSHIFT, LSHIFT,
RCTRL, LCTRL,
RALT, LALT,
RMETA, LMETA,
LSUPER, RSUPER,
MODE,
COMPOSE,
HELP,
PRINT,
SYSREQ,
BREAK,
MENU,
POWER,
EURO,
UNDO);
function is_Graphic (Self : in Key) return Boolean;
-------------
--- Modifiers
--
type Modifier is (LSHIFT, -- TODO: Better names.
RSHIFT,
LCTRL,
RCTRL,
LALT,
RALT,
LMETA,
RMETA,
NUM,
CAPS,
MODE);
type modifier_Set is array (Modifier) of Boolean;
no_Modifiers : constant modifier_Set;
type modified_Key is
record
Key : keyboard.Key;
modifier_Set : keyboard.modifier_Set;
end record;
function Image (Self : in modified_Key) return Character;
----------
--- Events
--
type key_press_Event is new lace.Event.item with
record
modified_Key : keyboard.modified_Key;
Code : Integer;
end record;
type key_release_Event is new lace.Event.item with
record
modified_Key : keyboard.modified_Key;
end record;
--------------
--- Attributes
--
function Modifiers (Self : in Item) return Modifier_Set is abstract;
--------------
--- Operations
--
procedure emit_key_press_Event (Self : in out Item; Key : in keyboard.Key;
key_Code : in Integer) is abstract;
procedure emit_key_release_Event (Self : in out Item; Key : in keyboard.Key) is abstract;
private
no_Modifiers : constant modifier_Set := [others => False];
end gel.Keyboard;

43
4-high/gel/source/interface/gel-mouse.adb Normal file
View File

@@ -0,0 +1,43 @@
package body gel.Mouse
is
--------------
--- Attributes
--
-- Nil.
---------------
--- Operations
--
procedure emit_button_press_Event (Self : in out Item'Class; Button : in mouse.button_Id;
Modifiers : in keyboard.modifier_Set;
Site : in mouse.Site)
is
begin
self.emit (button_press_Event' (Button, Modifiers, Site));
end emit_button_press_Event;
procedure emit_button_release_Event (Self : in out Item'Class; Button : in mouse.button_Id;
Modifiers : in keyboard.modifier_Set;
Site : in mouse.Site)
is
begin
self.emit (button_release_Event' (Button, Modifiers, Site));
end emit_button_release_Event;
procedure emit_motion_Event (Self : in out Item'Class; Site : in mouse.Site)
is
begin
self.emit (motion_Event' (site => Site));
end emit_motion_Event;
end gel.Mouse;

67
4-high/gel/source/interface/gel-mouse.ads Normal file
View File

@@ -0,0 +1,67 @@
with
gel.Keyboard,
lace.Event,
lace.Subject;
package gel.Mouse with remote_Types
--
-- Provides an interface to a mouse.
--
is
type Item is limited interface
and lace.Subject.item;
type View is access all Item'class;
----------
--- Events
--
type Button_Id is range 1 .. 5;
type Site is new math.Integers (1 .. 2); -- Window pixel (x,y) site.
type button_press_Event is new lace.Event.item with
record
Button : button_Id;
modifier_Set : keyboard.modifier_Set;
Site : mouse.Site;
end record;
type button_release_Event is new lace.Event.item with
record
Button : button_Id;
modifier_Set : keyboard.modifier_Set;
Site : mouse.Site;
end record;
type motion_Event is new lace.Event.item with
record
Site : mouse.Site;
end record;
--------------
--- Attributes
--
-- Nil.
--------------
--- Operations
--
procedure emit_button_press_Event (Self : in out Item'Class; Button : in mouse.button_Id;
Modifiers : in keyboard.modifier_Set;
Site : in mouse.Site);
procedure emit_button_release_Event (Self : in out Item'Class; Button : in mouse.button_Id;
Modifiers : in keyboard.modifier_Set;
Site : in mouse.Site);
procedure emit_motion_Event (Self : in out Item'Class; Site : in mouse.Site);
end gel.Mouse;