From d5fd3906e62969fce7fec7f2fccdc5a7436cbdbc Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 18 Feb 2025 12:54:42 +1300 Subject: Filled holes in FLTK, FLTK.Events, FLTK.Screen, tweaked Fl_Shortcut implementation --- spec/fltk-event.ads | 284 ------------------------------------------- spec/fltk-events.ads | 338 +++++++++++++++++++++++++++++++++++++++++++++++++++ spec/fltk-screen.ads | 37 ++++++ spec/fltk-static.ads | 15 ++- spec/fltk.ads | 90 ++++++-------- 5 files changed, 427 insertions(+), 337 deletions(-) delete mode 100644 spec/fltk-event.ads create mode 100644 spec/fltk-events.ads (limited to 'spec') diff --git a/spec/fltk-event.ads b/spec/fltk-event.ads deleted file mode 100644 index 483f317..0000000 --- a/spec/fltk-event.ads +++ /dev/null @@ -1,284 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - FLTK.Widgets.Groups.Windows; - -private with - - Ada.Containers.Vectors, - System.Address_To_Access_Conversions; - - -package FLTK.Event is - - - type Event_Handler is access function - (Event : in Event_Kind) - return Event_Outcome; - - -- type Event_Dispatch is access function - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome; - - - - - -- Handlers -- - - procedure Add_Handler - (Func : in Event_Handler); - - procedure Remove_Handler - (Func : in Event_Handler); - - -- function Get_Dispatch - -- return Event_Dispatch; - - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch); - - -- function Default_Dispatch - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome; - - - - - -- Receiving -- - - function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class; - - procedure Set_Grab - (To : in FLTK.Widgets.Groups.Windows.Window'Class); - - procedure Release_Grab; - - function Get_Pushed - return access FLTK.Widgets.Widget'Class; - - procedure Set_Pushed - (To : in FLTK.Widgets.Widget'Class); - - function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class; - - procedure Set_Below_Mouse - (To : in FLTK.Widgets.Widget'Class); - - function Get_Focus - return access FLTK.Widgets.Widget'Class; - - procedure Set_Focus - (To : in FLTK.Widgets.Widget'Class); - - function Has_Visible_Focus - return Boolean; - - procedure Set_Visible_Focus - (To : in Boolean); - - - - - -- Multikey -- - - function Compose - (Del : out Natural) - return Boolean; - - procedure Compose_Reset; - - function Text - return String; - - function Text_Length - return Natural; - - - - - -- Modifiers -- - - function Last - return Event_Kind; - - function Last_Modifier - return Modifier; - - function Last_Modifier - (Had : in Modifier) - return Boolean; - - - - - -- Mouse -- - - function Mouse_X - return Integer; - - function Mouse_X_Root - return Integer; - - function Mouse_Y - return Integer; - - function Mouse_Y_Root - return Integer; - - function Mouse_DX - return Integer; - - function Mouse_DY - return Integer; - - procedure Get_Mouse - (X, Y : out Integer); - - function Is_Click - return Boolean; - - function Is_Multi_Click - return Boolean; - - procedure Set_Clicks - (To : in Natural); - - function Last_Button - return Mouse_Button; - - function Mouse_Left - return Boolean; - - function Mouse_Middle - return Boolean; - - function Mouse_Right - return Boolean; - - function Is_Inside - (X, Y, W, H : in Integer) - return Boolean; - - - - - -- Keyboard -- - - function Last_Key - return Keypress; - - function Original_Last_Key - return Keypress; - - function Pressed_During - (Key : in Keypress) - return Boolean; - - function Key_Now - (Key : in Keypress) - return Boolean; - - function Key_Ctrl - return Boolean; - - function Key_Alt - return Boolean; - - function Key_Command - return Boolean; - - function Key_Shift - return Boolean; - - -private - - - package Widget_Convert is new System.Address_To_Access_Conversions - (FLTK.Widgets.Widget'Class); - package Window_Convert is new System.Address_To_Access_Conversions - (FLTK.Widgets.Groups.Windows.Window'Class); - - - package Handler_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, Element_Type => Event_Handler); - - - Handlers : Handler_Vectors.Vector := Handler_Vectors.Empty_Vector; - -- Current_Dispatch : Event_Dispatch := null; - - - function fl_widget_get_user_data - (W : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); - pragma Inline (fl_widget_get_user_data); - - - pragma Import (C, Compose_Reset, "fl_event_compose_reset"); - - - pragma Inline (Add_Handler); - pragma Inline (Remove_Handler); - -- pragma Inline (Get_Dispatch); - -- pragma Inline (Set_Dispatch); - -- pragma Inline (Default_Dispatch); - - pragma Inline (Get_Grab); - pragma Inline (Set_Grab); - pragma Inline (Release_Grab); - pragma Inline (Get_Pushed); - pragma Inline (Set_Pushed); - pragma Inline (Get_Below_Mouse); - pragma Inline (Set_Below_Mouse); - pragma Inline (Get_Focus); - pragma Inline (Set_Focus); - pragma Inline (Has_Visible_Focus); - pragma Inline (Set_Visible_Focus); - - pragma Inline (Compose); - pragma Inline (Compose_Reset); - pragma Inline (Text); - pragma Inline (Text_Length); - - pragma Inline (Last); - pragma Inline (Last_Modifier); - - pragma Inline (Mouse_X); - pragma Inline (Mouse_X_Root); - pragma Inline (Mouse_Y); - pragma Inline (Mouse_Y_Root); - pragma Inline (Mouse_DX); - pragma Inline (Mouse_DY); - pragma Inline (Get_Mouse); - pragma Inline (Is_Click); - pragma Inline (Is_Multi_Click); - pragma Inline (Set_Clicks); - pragma Inline (Last_Button); - pragma Inline (Mouse_Left); - pragma Inline (Mouse_Middle); - pragma Inline (Mouse_Right); - pragma Inline (Is_Inside); - - pragma Inline (Last_Key); - pragma Inline (Original_Last_Key); - pragma Inline (Pressed_During); - pragma Inline (Key_Now); - pragma Inline (Key_Ctrl); - pragma Inline (Key_Alt); - pragma Inline (Key_Command); - pragma Inline (Key_Shift); - - -end FLTK.Event; - - diff --git a/spec/fltk-events.ads b/spec/fltk-events.ads new file mode 100644 index 0000000..6a556ff --- /dev/null +++ b/spec/fltk-events.ads @@ -0,0 +1,338 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + +private with + + Ada.Containers.Vectors, + System.Address_To_Access_Conversions; + + +package FLTK.Events is + + + type Event_Handler is access function + (Event : in Event_Kind) + return Event_Outcome; + + type Event_Dispatch is access function + (Event : in Event_Kind; + Win : access FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + + + + -- Handlers -- + + procedure Add_Handler + (Func : in Event_Handler); + + procedure Remove_Handler + (Func : in Event_Handler); + + function Get_Dispatch + return Event_Dispatch; + + -- Any Event_Dispatch function set must call Handle + -- if you want the Event to actually be acknowledged. + procedure Set_Dispatch + (Func : in Event_Dispatch); + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + + + + -- Receiving -- + + function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class; + + procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class); + + procedure Release_Grab; + + function Get_Pushed + return access FLTK.Widgets.Widget'Class; + + procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class); + + function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class; + + procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class); + + function Get_Focus + return access FLTK.Widgets.Widget'Class; + + procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class); + + function Has_Visible_Focus + return Boolean; + + procedure Set_Visible_Focus + (To : in Boolean); + + + + + -- Clipboard -- + + function Clipboard_Text + return String; + + function Clipboard_Kind + return String; + + + + + -- Multikey -- + + function Compose + (Del : out Natural) + return Boolean; + + procedure Compose_Reset; + + function Text + return String; + + function Text_Length + return Natural; + + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean; + + + + + -- Modifiers -- + + function Last + return Event_Kind; + + -- Focuses on keyboard modifiers only, not mouse buttons + function Last_Modifier + return Modifier; + + -- Focuses on keyboard modifiers only, not mouse buttons + function Last_Modifier + (Had : in Modifier) + return Boolean; + + + + + -- Mouse -- + + function Mouse_X + return Integer; + + function Mouse_X_Root + return Integer; + + function Mouse_Y + return Integer; + + function Mouse_Y_Root + return Integer; + + function Mouse_DX + return Integer; + + function Mouse_DY + return Integer; + + procedure Get_Mouse + (X, Y : out Integer); + + function Is_Click + return Boolean; + + procedure Clear_Click; + + function Is_Multi_Click + return Boolean; + + -- Returns the actual number of clicks. + -- So no clicks is 0, a single click is 1, a double click is 2, etc. + function Get_Clicks + return Natural; + + -- Will set the actual number of clicks. + -- This means setting it to 0 will make Is_Click return False. + procedure Set_Clicks + (To : in Natural); + + function Last_Button + return Mouse_Button; + + function Mouse_Left + return Boolean; + + function Mouse_Middle + return Boolean; + + function Mouse_Right + return Boolean; + + function Mouse_Back + return Boolean; + + function Mouse_Forward + return Boolean; + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean); + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean; + + function Is_Inside + (X, Y, W, H : in Integer) + return Boolean; + + + + + -- Keyboard -- + + function Last_Key + return Keypress; + + function Original_Last_Key + return Keypress; + + function Pressed_During + (Key : in Keypress) + return Boolean; + + function Key_Now + (Key : in Keypress) + return Boolean; + + function Key_Ctrl + return Boolean; + + function Key_Alt + return Boolean; + + function Key_Command + return Boolean; + + function Key_Shift + return Boolean; + + +private + + + package Widget_Convert is new System.Address_To_Access_Conversions + (FLTK.Widgets.Widget'Class); + package Window_Convert is new System.Address_To_Access_Conversions + (FLTK.Widgets.Groups.Windows.Window'Class); + + + package Handler_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, Element_Type => Event_Handler); + + + Handlers : Handler_Vectors.Vector := Handler_Vectors.Empty_Vector; + Current_Dispatch : Event_Dispatch := null; + + + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + pragma Inline (fl_widget_get_user_data); + + + pragma Import (C, Compose_Reset, "fl_event_compose_reset"); + + + pragma Inline (Add_Handler); + pragma Inline (Remove_Handler); + pragma Inline (Get_Dispatch); + pragma Inline (Set_Dispatch); + pragma Inline (Handle_Dispatch); + pragma Inline (Handle); + + pragma Inline (Get_Grab); + pragma Inline (Set_Grab); + pragma Inline (Release_Grab); + pragma Inline (Get_Pushed); + pragma Inline (Set_Pushed); + pragma Inline (Get_Below_Mouse); + pragma Inline (Set_Below_Mouse); + pragma Inline (Get_Focus); + pragma Inline (Set_Focus); + pragma Inline (Has_Visible_Focus); + pragma Inline (Set_Visible_Focus); + + pragma Inline (Clipboard_Text); + pragma Inline (Clipboard_Kind); + + pragma Inline (Compose); + pragma Inline (Compose_Reset); + pragma Inline (Text); + pragma Inline (Text_Length); + pragma Inline (Test_Shortcut); + + pragma Inline (Last); + pragma Inline (Last_Modifier); + + pragma Inline (Mouse_X); + pragma Inline (Mouse_X_Root); + pragma Inline (Mouse_Y); + pragma Inline (Mouse_Y_Root); + pragma Inline (Mouse_DX); + pragma Inline (Mouse_DY); + pragma Inline (Get_Mouse); + pragma Inline (Is_Click); + pragma Inline (Clear_Click); + pragma Inline (Is_Multi_Click); + pragma Inline (Get_Clicks); + pragma Inline (Set_Clicks); + pragma Inline (Mouse_Left); + pragma Inline (Mouse_Middle); + pragma Inline (Mouse_Right); + pragma Inline (Mouse_Back); + pragma Inline (Mouse_Forward); + pragma Inline (Is_Inside); + + pragma Inline (Last_Key); + pragma Inline (Original_Last_Key); + pragma Inline (Pressed_During); + pragma Inline (Key_Now); + pragma Inline (Key_Ctrl); + pragma Inline (Key_Alt); + pragma Inline (Key_Command); + pragma Inline (Key_Shift); + + +end FLTK.Events; + + diff --git a/spec/fltk-screen.ads b/spec/fltk-screen.ads index ccfd224..38db9aa 100644 --- a/spec/fltk-screen.ads +++ b/spec/fltk-screen.ads @@ -7,11 +7,23 @@ package FLTK.Screen is + type Visual_Mode is (RGB, RGB_24bit, Double_Buffer, Double_RGB, Double_RGB_24bit); + + + + -- Environment -- procedure Set_Display_String (Value : in String); + procedure Set_Visual_Mode + (Value : in Visual_Mode); + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean; + @@ -87,10 +99,30 @@ package FLTK.Screen is PX, PY, PW, PH : in Integer); + + + -- Drawing -- + + function Is_Damaged + return Boolean; + + procedure Set_Damaged + (To : in Boolean); + + procedure Flush; + + procedure Redraw; + + private + pragma Import (C, Flush, "fl_screen_flush"); + pragma Import (C, Redraw, "fl_screen_redraw"); + + pragma Inline (Set_Display_String); + pragma Inline (Set_Visual_Mode); pragma Inline (Get_X); pragma Inline (Get_Y); @@ -104,6 +136,11 @@ private pragma Inline (Work_Area); pragma Inline (Bounding_Rect); + pragma Inline (Is_Damaged); + pragma Inline (Set_Damaged); + pragma Inline (Flush); + pragma Inline (Redraw); + end FLTK.Screen; diff --git a/spec/fltk-static.ads b/spec/fltk-static.ads index a2a9ff4..6b54878 100644 --- a/spec/fltk-static.ads +++ b/spec/fltk-static.ads @@ -53,7 +53,7 @@ package FLTK.Static is - -- Interthread Notify -- + -- Thread Notify -- procedure Add_Awake_Handler (Func : in Awake_Handler); @@ -61,6 +61,12 @@ package FLTK.Static is function Get_Awake_Handler return Awake_Handler; + procedure Awake; + + procedure Lock; + + procedure Unlock; + @@ -350,6 +356,10 @@ private (Read => 1, Write => 4, Except => 8); + pragma Import (C, Awake, "fl_static_awake"); + pragma Import (C, Lock, "fl_static_lock"); + pragma Import (C, Unlock, "fl_static_unlock"); + pragma Import (C, Own_Colormap, "fl_static_own_colormap"); pragma Import (C, System_Colors, "fl_static_get_system_colors"); @@ -363,6 +373,9 @@ private pragma Inline (Add_Awake_Handler); pragma Inline (Get_Awake_Handler); + pragma Inline (Awake); + pragma Inline (Lock); + pragma Inline (Unlock); pragma Inline (Add_Check); pragma Inline (Has_Check); diff --git a/spec/fltk.ads b/spec/fltk.ads index ddac9b2..2a38434 100644 --- a/spec/fltk.ads +++ b/spec/fltk.ads @@ -11,7 +11,7 @@ with private with Ada.Unchecked_Conversion, - Interfaces.C, + Interfaces.C.Strings, System.Storage_Elements; @@ -228,7 +228,14 @@ package FLTK is Tab_Key : constant Keypress; - type Mouse_Button is (No_Button, Left_Button, Middle_Button, Right_Button); + type Mouse_Button is + (No_Button, + Left_Button, + Middle_Button, + Right_Button, + Back_Button, + Forward_Button, + Any_Button); type Key_Combo is private; @@ -496,6 +503,14 @@ package FLTK is + -- Clipboard Attributes -- + + Clipboard_Image : constant String; + Clipboard_Plain_Text : constant String; + + + + -- Versioning -- type Version_Number is new Natural; @@ -516,35 +531,10 @@ package FLTK is - -- Threads -- - - procedure Awake; - - procedure Lock; - - procedure Unlock; - - - - - -- Drawing -- - - -- Need to check/revise these damage bits... - function Is_Damaged - return Boolean; - - procedure Set_Damaged - (To : in Boolean); - - procedure Flush; - - procedure Redraw; - - - - -- Event Loop -- + procedure Check; + function Check return Boolean; @@ -681,34 +671,34 @@ private function To_C (Key : in Key_Combo) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Key_Combo; function To_C (Key : in Keypress) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Keypress; function To_C (Modi : in Modifier) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Modi : in Interfaces.C.int) + (Modi : in Interfaces.C.unsigned) return Modifier; function To_C (Button : in Mouse_Button) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Button : in Interfaces.C.int) + (Button : in Interfaces.C.unsigned) return Mouse_Button; -- these values designed to align with FLTK enumeration types @@ -839,19 +829,20 @@ private - pragma Import (C, Awake, "fl_awake"); - pragma Import (C, Lock, "fl_lock"); - pragma Import (C, Unlock, "fl_unlock"); + clip_image_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_image_char_ptr, "fl_clip_image_char_ptr"); + + clip_plain_text_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_plain_text_char_ptr, "fl_clip_plain_text_char_ptr"); - pragma Import (C, Flush, "fl_flush"); - pragma Import (C, Redraw, "fl_redraw"); + Clipboard_Image : constant String := Interfaces.C.Strings.Value (clip_image_char_ptr); + Clipboard_Plain_Text : constant String := Interfaces.C.Strings.Value (clip_plain_text_char_ptr); pragma Inline (RGB_Color); pragma Inline (Color_Cube); - pragma Inline (Contrast); pragma Inline (Grey_Ramp); pragma Inline (Darker); pragma Inline (Lighter); @@ -859,20 +850,15 @@ private pragma Inline (Inactive); pragma Inline (Color_Average); + pragma Inline (Filled); + pragma Inline (Frame); + pragma Inline (Down); + pragma Inline (ABI_Check); pragma Inline (ABI_Version); pragma Inline (API_Version); pragma Inline (Version); - pragma Inline (Awake); - pragma Inline (Lock); - pragma Inline (Unlock); - - pragma Inline (Is_Damaged); - pragma Inline (Set_Damaged); - pragma Inline (Flush); - pragma Inline (Redraw); - pragma Inline (Check); pragma Inline (Ready); pragma Inline (Wait); -- cgit