bat/tests/syntax-tests/highlighted/Ada/click.adb
Marc Poulhiès 06b403aa92 Add syntax support for Ada
Add submodule with sublime syntax.

Add corresponding tests for both Ada (in adb/ads) and for the companion tool
gpr.

fixes #1300

Signed-off-by: Marc Poulhiès <dkm@kataplop.net>
2022-09-14 22:49:39 +02:00

309 lines
33 KiB
Ada
Vendored
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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;