bat/tests/syntax-tests/source/Ada/click.adb

309 lines
8.8 KiB
Ada
Raw Normal View History

with Chests.Ring_Buffers;
with USB.Device.HID.Keyboard;
package body Click is
----------------
-- DEBOUNCE --
----------------
-- Ideally, in a separate package.
-- should be [], but not fixed yet in GCC 11.
Current_Status : Key_Matrix := [others => [others => False]];
New_Status : Key_Matrix := [others => [others => False]];
Since : Natural := 0;
-- Nb_Bounce : Natural := 5;
function Update (NewS : Key_Matrix) return Boolean is
begin
-- The new state is the same as the current stable state => Do nothing.
if Current_Status = NewS then
Since := 0;
return False;
end if;
if New_Status /= NewS then
-- The new state differs from the previous
-- new state (bouncing) => reset
New_Status := NewS;
Since := 1;
else
-- The new state hasn't changed since last
-- update => towards stabilization.
Since := Since + 1;
end if;
if Since > Nb_Bounce then
declare
Tmp : constant Key_Matrix := Current_Status;
begin
-- New state has been stable enough.
-- Latch it and notifies caller.
Current_Status := New_Status;
New_Status := Tmp;
Since := 0;
end;
return True;
else
-- Not there yet
return False;
end if;
end Update;
procedure Get_Matrix;
-- Could use := []; but GNAT 12 has a bug (fixed in upcoming 13)
Read_Status : Key_Matrix := [others => [others => False]];
function Get_Events return Events is
Num_Evt : Natural := 0;
New_S : Key_Matrix renames Read_Status;
begin
Get_Matrix;
if Update (New_S) then
for I in Current_Status'Range (1) loop
for J in Current_Status'Range (2) loop
if (not New_Status (I, J) and then Current_Status (I, J))
or else (New_Status (I, J) and then not Current_Status (I, J))
then
Num_Evt := Num_Evt + 1;
end if;
end loop;
end loop;
declare
Evts : Events (Natural range 1 .. Num_Evt);
Cursor : Natural range 1 .. Num_Evt + 1 := 1;
begin
for I in Current_Status'Range (1) loop
for J in Current_Status'Range (2) loop
if not New_Status (I, J)
and then Current_Status (I, J)
then
-- Pressing I, J
Evts (Cursor) := [
Evt => Press,
Col => I,
Row => J
];
Cursor := Cursor + 1;
elsif New_Status (I, J)
and then not Current_Status (I, J)
then
-- Release I, J
Evts (Cursor) := [
Evt => Release,
Col => I,
Row => J
];
Cursor := Cursor + 1;
end if;
end loop;
end loop;
return Evts;
end;
end if;
return [];
end Get_Events;
procedure Get_Matrix is -- return Key_Matrix is
begin
for Row in Keys.Rows'Range loop
Keys.Rows (Row).Clear;
for Col in Keys.Cols'Range loop
Read_Status (Col, Row) := not Keys.Cols (Col).Set;
end loop;
Keys.Rows (Row).Set;
end loop;
end Get_Matrix;
-- End of DEBOUNCE
--------------
-- Layout --
--------------
package Events_Ring_Buffers is new Chests.Ring_Buffers
(Element_Type => Event,
Capacity => 16);
Queued_Events : Events_Ring_Buffers.Ring_Buffer;
type Statet is (Normal_Key, Layer_Mod, None);
type State is record
Typ : Statet;
Code : Key_Code_T;
Layer_Value : Natural;
-- Col : ColR;
-- Row : RowR;
end record;
type State_Array is array (ColR, RowR) of State;
States : State_Array := [others => [others => (Typ => None, Code => No, Layer_Value => 0)]];
function Kw (Code : Key_Code_T) return Action is
begin
return (T => Key, C => Code, L => 0);
end Kw;
function Lw (V : Natural) return Action is
begin
return (T => Layer, C => No, L => V);
end Lw;
-- FIXME: hardcoded max number of events
subtype Events_Range is Natural range 0 .. 60;
type Array_Of_Reg_Events is array (Events_Range) of Event;
Stamp : Natural := 0;
procedure Register_Events (L : Layout; Es : Events) is
begin
Stamp := Stamp + 1;
Log ("Reg events: " & Stamp'Image);
Log (Es'Length'Image);
for E of Es loop
declare
begin
if Events_Ring_Buffers.Is_Full (Queued_Events) then
raise Program_Error;
end if;
Events_Ring_Buffers.Append (Queued_Events, E);
end;
-- Log ("Reg'ed events:" & Events_Mark'Image);
Log ("Reg'ed events:" & Events_Ring_Buffers.Length (Queued_Events)'Image);
end loop;
end Register_Events;
procedure Release (Col: Colr; Row: Rowr) is
begin
if States (Col, Row).Typ = None then
raise Program_Error;
end if;
States (Col, Row) := (Typ => None, Code => No, Layer_Value => 0);
end Release;
function Get_Current_Layer return Natural is
L : Natural := 0;
begin
for S of States loop
if S.Typ = Layer_Mod then
L := L + S.Layer_Value;
end if;
end loop;
return L;
end Get_Current_Layer;
-- Tick the event.
-- Returns TRUE if it needs to stay in the queued events
-- FALSE if the event has been consumed.
function Tick (L: Layout; E : in out Event) return Boolean is
Current_Layer : Natural := Get_Current_Layer;
A : Action renames L (Current_Layer, E.Row, E.Col);
begin
case E.Evt is
when Press =>
case A.T is
when Key =>
States (E.Col, E.Row) :=
(Typ => Normal_Key,
Code => A.C,
Layer_Value => 0);
when Layer =>
States (E.Col, E.Row) := (Typ => Layer_Mod, Layer_Value => A.L, Code => No);
when others =>
raise Program_Error;
end case;
when Release =>
Release (E.Col, E.Row);
end case;
return False;
end Tick;
Last_Was_Empty_Log : Boolean := False;
procedure Tick (L : Layout) is
begin
for I in 1 .. Events_Ring_Buffers.Length(Queued_Events) loop
declare
E : Event := Events_Ring_Buffers.Last_Element (Queued_Events);
begin
Events_Ring_Buffers.Delete_Last (Queued_Events);
if Tick (L, E) then
Events_Ring_Buffers.Prepend (Queued_Events, E);
end if;
end;
end loop;
if not Last_Was_Empty_Log or else Events_Ring_Buffers.Length(Queued_Events) /= 0 then
Log ("End Tick layout, events: " & Events_Ring_Buffers.Length(Queued_Events)'Image);
Last_Was_Empty_Log := Events_Ring_Buffers.Length(Queued_Events) = 0;
end if;
end Tick;
function Get_Key_Codes return Key_Codes_T is
Codes : Key_Codes_T (0 .. 10);
Wm: Natural := 0;
begin
for S of States loop
if S.Typ = Normal_Key and then
(S.Code < LCtrl or else S.Code > RGui)
then
Codes (Wm) := S.Code;
Wm := Wm + 1;
end if;
end loop;
if Wm = 0 then
return [];
else
return Codes (0 .. Wm - 1);
end if;
end Get_Key_Codes;
function Get_Modifiers return Key_Modifiers is
use USB.Device.HID.Keyboard;
KM : Key_Modifiers (1..8);
I : Natural := 0;
begin
for S of States loop
if S.Typ = Normal_Key then
I := I + 1;
case S.Code is
when LCtrl =>
KM(I) := Ctrl_Left;
when RCtrl =>
KM(I) := Ctrl_Right;
when LShift =>
KM(I) := Shift_Left;
when RShift =>
KM(I) := Shift_Right;
when LAlt =>
KM(I) := Alt_Left;
when RAlt =>
KM(I) := Alt_Right;
when LGui =>
KM(I) := Meta_Left;
when RGui =>
KM(I) := Meta_Right;
when others =>
I := I - 1;
end case;
end if;
end loop;
return KM (1..I);
end Get_Modifiers;
procedure Init is
begin
Events_Ring_Buffers.Clear (Queued_Events);
end Init;
end Click;