Fl (FLTK.Event) Binding Map

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 --- body/c_fl.cpp | 72 +- body/c_fl.h | 30 +- body/c_fl_event.cpp | 51 +- body/c_fl_event.h | 15 +- body/c_fl_screen.cpp | 31 + body/c_fl_screen.h | 13 + body/c_fl_static.cpp | 12 + body/c_fl_static.h | 3 + body/fltk-event.adb | 748 ---------------- body/fltk-events.adb | 988 +++++++++++++++++++++ body/fltk-menu_items.adb | 4 +- body/fltk-screen.adb | 81 ++ body/fltk-widgets-buttons.adb | 2 +- ...k-widgets-groups-text_displays-text_editors.adb | 6 +- body/fltk-widgets-groups-text_displays.adb | 4 +- body/fltk-widgets-inputs.adb | 4 +- body/fltk-widgets-menus-menu_bars-systemwide.adb | 10 +- body/fltk-widgets-menus.adb | 10 +- body/fltk-widgets-valuators-value_inputs.adb | 2 +- body/fltk.adb | 125 +-- doc/enumerations.html | 7 +- doc/fl.html | 108 +-- doc/fl_(fltk-event).html | 547 ------------ doc/fl_(fltk-events).html | 619 +++++++++++++ doc/fl_(fltk-screen).html | 59 +- doc/fl_(fltk-static).html | 48 +- doc/index.html | 4 +- spec/fltk-event.ads | 284 ------ spec/fltk-events.ads | 338 +++++++ spec/fltk-screen.ads | 37 + spec/fltk-static.ads | 15 +- spec/fltk.ads | 90 +- 32 files changed, 2509 insertions(+), 1858 deletions(-) delete mode 100644 body/fltk-event.adb create mode 100644 body/fltk-events.adb delete mode 100644 doc/fl_(fltk-event).html create mode 100644 doc/fl_(fltk-events).html delete mode 100644 spec/fltk-event.ads create mode 100644 spec/fltk-events.ads diff --git a/body/c_fl.cpp b/body/c_fl.cpp index 42d9a45..871b32d 100644 --- a/body/c_fl.cpp +++ b/body/c_fl.cpp @@ -60,6 +60,37 @@ const int fl_enum_num_gray = FL_NUM_GRAY; +const unsigned int fl_enum_button1 = FL_BUTTON1; +const unsigned int fl_enum_button2 = FL_BUTTON2; +const unsigned int fl_enum_button3 = FL_BUTTON3; +#if FL_API_VERSION >= 10310 +const unsigned int fl_enum_button4 = FL_BUTTON4; +const unsigned int fl_enum_button5 = FL_BUTTON5; +#else +// woo, limited backwards compatibility +const unsigned int fl_enum_button4 = 8; +const unsigned int fl_enum_button5 = 16; +#endif +const unsigned int fl_enum_buttons = FL_BUTTONS; + + + + +const int fl_enum_left_mouse = FL_LEFT_MOUSE; +const int fl_enum_middle_mouse = FL_MIDDLE_MOUSE; +const int fl_enum_right_mouse = FL_RIGHT_MOUSE; +#if FL_API_VERSION >= 10310 +const int fl_enum_back_mouse = FL_BACK_MOUSE; +const int fl_enum_forward_mouse = FL_FORWARD_MOUSE; +#else +// woo, limited backwards compatibility +const int fl_enum_back_mouse = 4; +const int fl_enum_forward_mouse = 5; +#endif + + + + unsigned int fl_enum_rgb_color2(unsigned char l) { return static_cast(fl_rgb_color(l)); } @@ -116,6 +147,13 @@ int fl_enum_down(int b) { +const char * fl_clip_image_char_ptr = Fl::clipboard_image; + +const char * fl_clip_plain_text_char_ptr = Fl::clipboard_plain_text; + + + + int fl_abi_check(int v) { return Fl::abi_check(v); } @@ -135,40 +173,6 @@ double fl_version() { -void fl_awake() { - Fl::awake(); -} - -void fl_lock() { - Fl::lock(); -} - -void fl_unlock() { - Fl::unlock(); -} - - - - -int fl_get_damage() { - return Fl::damage(); -} - -void fl_set_damage(int v) { - Fl::damage(v); -} - -void fl_flush() { - Fl::flush(); -} - -void fl_redraw() { - Fl::redraw(); -} - - - - short fl_inside_callback = 0; void fl_delete_widget(void * w) { diff --git a/body/c_fl.h b/body/c_fl.h index f85c36f..88d229d 100644 --- a/body/c_fl.h +++ b/body/c_fl.h @@ -49,6 +49,21 @@ extern "C" const int fl_enum_num_blue; extern "C" const int fl_enum_num_gray; +extern "C" const unsigned int fl_enum_button1; +extern "C" const unsigned int fl_enum_button2; +extern "C" const unsigned int fl_enum_button3; +extern "C" const unsigned int fl_enum_button4; +extern "C" const unsigned int fl_enum_button5; +extern "C" const unsigned int fl_enum_buttons; + + +extern "C" const int fl_enum_left_mouse; +extern "C" const int fl_enum_middle_mouse; +extern "C" const int fl_enum_right_mouse; +extern "C" const int fl_enum_back_mouse; +extern "C" const int fl_enum_forward_mouse; + + extern "C" unsigned int fl_enum_rgb_color2(unsigned char l); extern "C" unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b); extern "C" unsigned int fl_enum_color_cube(int r, int g, int b); @@ -65,23 +80,16 @@ extern "C" int fl_enum_frame(int b); extern "C" int fl_enum_down(int b); +extern "C" const char * fl_clip_image_char_ptr; +extern "C" const char * fl_clip_plain_text_char_ptr; + + extern "C" int fl_abi_check(int v); extern "C" int fl_abi_version(); extern "C" int fl_api_version(); extern "C" double fl_version(); -extern "C" void fl_awake(); -extern "C" void fl_lock(); -extern "C" void fl_unlock(); - - -extern "C" int fl_get_damage(); -extern "C" void fl_set_damage(int v); -extern "C" void fl_flush(); -extern "C" void fl_redraw(); - - extern "C" short fl_inside_callback; extern "C" void fl_delete_widget(void * w); diff --git a/body/c_fl_event.cpp b/body/c_fl_event.cpp index d8760af..d88dfc2 100644 --- a/body/c_fl_event.cpp +++ b/body/c_fl_event.cpp @@ -16,10 +16,14 @@ void fl_event_add_handler(void * f) { Fl::add_handler(reinterpret_cast(f)); } -void fl_event_set_event_dispatch(void * f) { +void fl_event_set_dispatch(void * f) { Fl::event_dispatch(reinterpret_cast(f)); } +int fl_event_handle_dispatch(int e, void * w) { + return Fl::handle(e, static_cast(w)); +} + int fl_event_handle(int e, void * w) { return Fl::handle_(e, static_cast(w)); } @@ -70,6 +74,17 @@ void fl_event_set_visible_focus(int f) { +const char * fl_event_clipboard_text() { + return static_cast(Fl::event_clipboard()); +} + +const char * fl_event_clipboard_type() { + return Fl::event_clipboard_type(); +} + + + + int fl_event_compose(int &d) { return Fl::compose(d); } @@ -86,6 +101,10 @@ int fl_event_length() { return Fl::event_length(); } +int fl_event_test_shortcut(unsigned int s) { + return Fl::test_shortcut(static_cast(s)); +} + @@ -136,7 +155,11 @@ int fl_event_is_click() { return Fl::event_is_click(); } -int fl_event_is_clicks() { +void fl_event_set_click(int c) { + Fl::event_is_click(c); +} + +int fl_event_get_clicks() { return Fl::event_clicks(); } @@ -160,6 +183,30 @@ int fl_event_button3() { return Fl::event_button3(); } +int fl_event_button4() { +#if FL_API_VERSION >= 10310 + return Fl::event_button4(); +#else + return 0; +#endif +} + +int fl_event_button5() { +#if FL_API_VERSION >= 10310 + return Fl::event_button5(); +#else + return 0; +#endif +} + +int fl_event_buttons() { + return Fl::event_buttons(); +} + +int fl_event_inside2(void * c) { + return Fl::event_inside(static_cast(c)); +} + int fl_event_inside(int x, int y, int w, int h) { return Fl::event_inside(x, y, w, h); } diff --git a/body/c_fl_event.h b/body/c_fl_event.h index 34daf2b..0acf999 100644 --- a/body/c_fl_event.h +++ b/body/c_fl_event.h @@ -9,7 +9,8 @@ extern "C" void fl_event_add_handler(void * f); -extern "C" void fl_event_set_event_dispatch(void * f); +extern "C" void fl_event_set_dispatch(void * f); +extern "C" int fl_event_handle_dispatch(int e, void * w); extern "C" int fl_event_handle(int e, void * w); @@ -25,10 +26,15 @@ extern "C" int fl_event_get_visible_focus(); extern "C" void fl_event_set_visible_focus(int f); +extern "C" const char * fl_event_clipboard_text(); +extern "C" const char * fl_event_clipboard_type(); + + extern "C" int fl_event_compose(int &d); extern "C" void fl_event_compose_reset(); extern "C" const char * fl_event_text(); extern "C" int fl_event_length(); +extern "C" int fl_event_test_shortcut(unsigned int s); extern "C" int fl_event_get(); @@ -44,12 +50,17 @@ extern "C" int fl_event_dx(); extern "C" int fl_event_dy(); extern "C" void fl_event_get_mouse(int &x, int &y); extern "C" int fl_event_is_click(); -extern "C" int fl_event_is_clicks(); +extern "C" void fl_event_set_click(int c); +extern "C" int fl_event_get_clicks(); extern "C" void fl_event_set_clicks(int c); extern "C" int fl_event_button(); extern "C" int fl_event_button1(); extern "C" int fl_event_button2(); extern "C" int fl_event_button3(); +extern "C" int fl_event_button4(); +extern "C" int fl_event_button5(); +extern "C" int fl_event_buttons(); +extern "C" int fl_event_inside2(void * c); extern "C" int fl_event_inside(int x, int y, int w, int h); diff --git a/body/c_fl_screen.cpp b/body/c_fl_screen.cpp index d0e8019..7a5fc2f 100644 --- a/body/c_fl_screen.cpp +++ b/body/c_fl_screen.cpp @@ -10,10 +10,22 @@ +const int fl_enum_mode_rgb = FL_RGB; +const int fl_enum_mode_rgb8 = FL_RGB8; +const int fl_enum_mode_double = FL_DOUBLE; +const int fl_enum_mode_index = FL_INDEX; + + + + void fl_screen_display(const char * v) { Fl::display(v); } +int fl_screen_visual(int mode) { + return Fl::visual(mode); +} + @@ -91,3 +103,22 @@ void fl_screen_xywh4(int &x, int &y, int &w, int &h, int px, int py, int pw, int } + + +int fl_screen_get_damage() { + return Fl::damage(); +} + +void fl_screen_set_damage(int v) { + Fl::damage(v); +} + +void fl_screen_flush() { + Fl::flush(); +} + +void fl_screen_redraw() { + Fl::redraw(); +} + + diff --git a/body/c_fl_screen.h b/body/c_fl_screen.h index 8fff58d..c2b0e98 100644 --- a/body/c_fl_screen.h +++ b/body/c_fl_screen.h @@ -8,7 +8,14 @@ #define FL_SCREEN_GUARD +extern "C" const int fl_enum_mode_rgb; +extern "C" const int fl_enum_mode_rgb8; +extern "C" const int fl_enum_mode_double; +extern "C" const int fl_enum_mode_index; + + extern "C" void fl_screen_display(const char * v); +extern "C" int fl_screen_visual(int mode); extern "C" int fl_screen_x(); @@ -36,6 +43,12 @@ extern "C" void fl_screen_xywh3(int &x, int &y, int &w, int &h); extern "C" void fl_screen_xywh4(int &x, int &y, int &w, int &h, int px, int py, int pw, int ph); +extern "C" int fl_screen_get_damage(); +extern "C" void fl_screen_set_damage(int v); +extern "C" void fl_screen_flush(); +extern "C" void fl_screen_redraw(); + + #endif diff --git a/body/c_fl_static.cpp b/body/c_fl_static.cpp index 0b45115..31cb3af 100644 --- a/body/c_fl_static.cpp +++ b/body/c_fl_static.cpp @@ -20,6 +20,18 @@ void fl_static_get_awake_handler(void * &h, void * &f) { Fl::get_awake_handler_(reinterpret_cast(h),f); } +void fl_static_awake() { + Fl::awake(); +} + +void fl_static_lock() { + Fl::lock(); +} + +void fl_static_unlock() { + Fl::unlock(); +} + diff --git a/body/c_fl_static.h b/body/c_fl_static.h index 2622544..c0a6c2f 100644 --- a/body/c_fl_static.h +++ b/body/c_fl_static.h @@ -10,6 +10,9 @@ extern "C" void fl_static_add_awake_handler(void * h, void * f); extern "C" void fl_static_get_awake_handler(void * &h, void * &f); +extern "C" void fl_static_awake(); +extern "C" void fl_static_lock(); +extern "C" void fl_static_unlock(); extern "C" void fl_static_add_check(void * h, void * f); diff --git a/body/fltk-event.adb b/body/fltk-event.adb deleted file mode 100644 index 2c96792..0000000 --- a/body/fltk-event.adb +++ /dev/null @@ -1,748 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Ada.Assertions, - Interfaces.C.Strings; - -use type - - Interfaces.C.int, - Interfaces.C.Strings.chars_ptr; - - -package body FLTK.Event is - - - package Chk renames Ada.Assertions; - - - - - ------------------------ - -- Functions From C -- - ------------------------ - - -- Handlers -- - - procedure fl_event_add_handler - (F : in Storage.Integer_Address); - pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); - pragma Inline (fl_event_add_handler); - - procedure fl_event_set_event_dispatch - (F : in Storage.Integer_Address); - pragma Import (C, fl_event_set_event_dispatch, "fl_event_set_event_dispatch"); - pragma Inline (fl_event_set_event_dispatch); - - -- actually handle_ but can't have an underscore on the end of an identifier - function fl_event_handle - (E : in Interfaces.C.int; - W : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_event_handle, "fl_event_handle"); - pragma Inline (fl_event_handle); - - - - - -- Receiving -- - - function fl_event_get_grab - return Storage.Integer_Address; - pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); - pragma Inline (fl_event_get_grab); - - procedure fl_event_set_grab - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); - pragma Inline (fl_event_set_grab); - - function fl_event_get_pushed - return Storage.Integer_Address; - pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); - pragma Inline (fl_event_get_pushed); - - procedure fl_event_set_pushed - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); - pragma Inline (fl_event_set_pushed); - - function fl_event_get_belowmouse - return Storage.Integer_Address; - pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); - pragma Inline (fl_event_get_belowmouse); - - procedure fl_event_set_belowmouse - (T : in Storage.Integer_Address); - pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); - pragma Inline (fl_event_set_belowmouse); - - function fl_event_get_focus - return Storage.Integer_Address; - pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); - pragma Inline (fl_event_get_focus); - - procedure fl_event_set_focus - (To : in Storage.Integer_Address); - pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); - pragma Inline (fl_event_set_focus); - - function fl_event_get_visible_focus - return Interfaces.C.int; - pragma Import (C, fl_event_get_visible_focus, "fl_event_get_visible_focus"); - pragma Inline (fl_event_get_visible_focus); - - procedure fl_event_set_visible_focus - (T : in Interfaces.C.int); - pragma Import (C, fl_event_set_visible_focus, "fl_event_set_visible_focus"); - pragma Inline (fl_event_set_visible_focus); - - - - - -- Multikey -- - - function fl_event_compose - (D : out Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_compose, "fl_event_compose"); - pragma Inline (fl_event_compose); - - function fl_event_text - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_event_text, "fl_event_text"); - pragma Inline (fl_event_text); - - function fl_event_length - return Interfaces.C.int; - pragma Import (C, fl_event_length, "fl_event_length"); - pragma Inline (fl_event_length); - - - - - -- Modifiers -- - - function fl_event_get - return Interfaces.C.int; - pragma Import (C, fl_event_get, "fl_event_get"); - pragma Inline (fl_event_get); - - function fl_event_state - return Interfaces.C.int; - pragma Import (C, fl_event_state, "fl_event_state"); - pragma Inline (fl_event_state); - - function fl_event_check_state - (S : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_check_state, "fl_event_check_state"); - pragma Inline (fl_event_check_state); - - - - - -- Mouse -- - - function fl_event_x - return Interfaces.C.int; - pragma Import (C, fl_event_x, "fl_event_x"); - pragma Inline (fl_event_x); - - function fl_event_x_root - return Interfaces.C.int; - pragma Import (C, fl_event_x_root, "fl_event_x_root"); - pragma Inline (fl_event_x_root); - - function fl_event_y - return Interfaces.C.int; - pragma Import (C, fl_event_y, "fl_event_y"); - pragma Inline (fl_event_y); - - function fl_event_y_root - return Interfaces.C.int; - pragma Import (C, fl_event_y_root, "fl_event_y_root"); - pragma Inline (fl_event_y_root); - - function fl_event_dx - return Interfaces.C.int; - pragma Import (C, fl_event_dx, "fl_event_dx"); - pragma Inline (fl_event_dx); - - function fl_event_dy - return Interfaces.C.int; - pragma Import (C, fl_event_dy, "fl_event_dy"); - pragma Inline (fl_event_dy); - - procedure fl_event_get_mouse - (X, Y : out Interfaces.C.int); - pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); - pragma Inline (fl_event_get_mouse); - - function fl_event_is_click - return Interfaces.C.int; - pragma Import (C, fl_event_is_click, "fl_event_is_click"); - pragma Inline (fl_event_is_click); - - function fl_event_is_clicks - return Interfaces.C.int; - pragma Import (C, fl_event_is_clicks, "fl_event_is_clicks"); - pragma Inline (fl_event_is_clicks); - - procedure fl_event_set_clicks - (C : in Interfaces.C.int); - pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); - pragma Inline (fl_event_set_clicks); - - function fl_event_button - return Interfaces.C.int; - pragma Import (C, fl_event_button, "fl_event_button"); - pragma Inline (fl_event_button); - - function fl_event_button1 - return Interfaces.C.int; - pragma Import (C, fl_event_button1, "fl_event_button1"); - pragma Inline (fl_event_button1); - - function fl_event_button2 - return Interfaces.C.int; - pragma Import (C, fl_event_button2, "fl_event_button2"); - pragma Inline (fl_event_button2); - - function fl_event_button3 - return Interfaces.C.int; - pragma Import (C, fl_event_button3, "fl_event_button3"); - pragma Inline (fl_event_button3); - - function fl_event_inside - (X, Y, W, H : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_inside, "fl_event_inside"); - pragma Inline (fl_event_inside); - - - - - -- Keyboard -- - - function fl_event_key - return Interfaces.C.int; - pragma Import (C, fl_event_key, "fl_event_key"); - pragma Inline (fl_event_key); - - function fl_event_original_key - return Interfaces.C.int; - pragma Import (C, fl_event_original_key, "fl_event_original_key"); - pragma Inline (fl_event_original_key); - - function fl_event_key_during - (K : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_key_during, "fl_event_key_during"); - pragma Inline (fl_event_key_during); - - function fl_event_get_key - (K : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_event_get_key, "fl_event_get_key"); - pragma Inline (fl_event_get_key); - - function fl_event_ctrl - return Interfaces.C.int; - pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); - pragma Inline (fl_event_ctrl); - - function fl_event_alt - return Interfaces.C.int; - pragma Import (C, fl_event_alt, "fl_event_alt"); - pragma Inline (fl_event_alt); - - function fl_event_command - return Interfaces.C.int; - pragma Import (C, fl_event_command, "fl_event_command"); - pragma Inline (fl_event_command); - - function fl_event_shift - return Interfaces.C.int; - pragma Import (C, fl_event_shift, "fl_event_shift"); - pragma Inline (fl_event_shift); - - - - - ------------- - -- Hooks -- - ------------- - - function Event_Handler_Hook - (Num : in Interfaces.C.int) - return Interfaces.C.int - is - Ret_Val : Event_Outcome; - begin - for Func of reverse Handlers loop - Ret_Val := Func (Event_Kind'Val (Num)); - if Ret_Val /= Not_Handled then - return Event_Outcome'Pos (Ret_Val); - end if; - end loop; - return Event_Outcome'Pos (Not_Handled); - end Event_Handler_Hook; - - - -- function Dispatch_Hook - -- (Num : in Interfaces.C.int; - -- Ptr : in Storage.Integer_Address) - -- return Interfaces.C.int - -- is - -- Ret_Val : Event_Outcome; - -- Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; - -- begin - -- if Ptr /= Null_Pointer then - -- Actual_Window := Window_Convert.To_Pointer - -- (Storage.To_Address (fl_widget_get_user_data (Ptr))); - -- end if; - -- if Current_Dispatch = null then - -- Ret_Val := Default_Dispatch (Event_Kind'Val (Num), Actual_Window); - -- else - -- Ret_Val := Current_Dispatch (Event_Kind'Val (Num), Actual_Window); - -- end if; - -- return Event_Outcome'Pos (Ret_Val); - -- end Dispatch_Hook; - - - - - ----------------------- - -- API Subprograms -- - ----------------------- - - -- Handlers -- - - procedure Add_Handler - (Func : in Event_Handler) is - begin - Handlers.Append (Func); - end Add_Handler; - - - procedure Remove_Handler - (Func : in Event_Handler) is - begin - for I in reverse Handlers.First_Index .. Handlers.Last_Index loop - if Handlers (I) = Func then - Handlers.Delete (I); - return; - end if; - end loop; - end Remove_Handler; - - - -- function Get_Dispatch - -- return Event_Dispatch is - -- begin - -- if Current_Dispatch = null then - -- return Default_Dispatch'Access; - -- else - -- return Current_Dispatch; - -- end if; - -- end Get_Dispatch; - - - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch) is - -- begin - -- Current_Dispatch := Func; - -- end Set_Dispatch; - - - -- function Default_Dispatch - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome is - -- begin - -- if Win = null then - -- return Event_Outcome'Val (fl_event_handle - -- (Event_Kind'Pos (Event), Null_Pointer)); - -- else - -- return Event_Outcome'Val (fl_event_handle - -- (Event_Kind'Pos (Event), - -- Wrapper (Win.all).Void_Ptr)); - -- end if; - -- end Default_Dispatch; - - - - - -- Receiving -- - - function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class - is - Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; - Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; - begin - if Grab_Ptr /= Null_Pointer then - Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); - pragma Assert (Grab_Ptr /= Null_Pointer); - Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); - end if; - return Actual_Grab; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::grab did not have user_data reference back to Ada"; - end Get_Grab; - - - procedure Set_Grab - (To : in FLTK.Widgets.Groups.Windows.Window'Class) is - begin - fl_event_set_grab (Wrapper (To).Void_Ptr); - end Set_Grab; - - - procedure Release_Grab is - begin - fl_event_set_grab (Null_Pointer); - end Release_Grab; - - - function Get_Pushed - return access FLTK.Widgets.Widget'Class - is - Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; - Actual_Pushed : access FLTK.Widgets.Widget'Class; - begin - if Pushed_Ptr /= Null_Pointer then - Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); - pragma Assert (Pushed_Ptr /= Null_Pointer); - Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); - end if; - return Actual_Pushed; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::pushed did not have user_data reference back to Ada"; - end Get_Pushed; - - - procedure Set_Pushed - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_pushed (Wrapper (To).Void_Ptr); - end Set_Pushed; - - - function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class - is - Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; - Actual_Below : access FLTK.Widgets.Widget'Class; - begin - if Below_Ptr /= Null_Pointer then - Below_Ptr := fl_widget_get_user_data (Below_Ptr); - pragma Assert (Below_Ptr /= Null_Pointer); - Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); - end if; - return Actual_Below; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::belowmouse did not have user_data reference back to Ada"; - end Get_Below_Mouse; - - - procedure Set_Below_Mouse - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_belowmouse (Wrapper (To).Void_Ptr); - end Set_Below_Mouse; - - - function Get_Focus - return access FLTK.Widgets.Widget'Class - is - Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; - Actual_Focus : access FLTK.Widgets.Widget'Class; - begin - if Focus_Ptr /= Null_Pointer then - Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); - pragma Assert (Focus_Ptr /= Null_Pointer); - Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); - end if; - return Actual_Focus; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Widget returned by Fl::focus did not have user_data reference back to Ada"; - end Get_Focus; - - - procedure Set_Focus - (To : in FLTK.Widgets.Widget'Class) is - begin - fl_event_set_focus (Wrapper (To).Void_Ptr); - end Set_Focus; - - - function Has_Visible_Focus - return Boolean is - begin - return fl_event_get_visible_focus /= 0; - end Has_Visible_Focus; - - - procedure Set_Visible_Focus - (To : in Boolean) is - begin - fl_event_set_visible_focus (Boolean'Pos (To)); - end Set_Visible_Focus; - - - - - -- Multikey -- - - function Compose - (Del : out Natural) - return Boolean is - begin - return fl_event_compose (Interfaces.C.int (Del)) /= 0; - end Compose; - - - function Text - return String - is - Str : Interfaces.C.Strings.chars_ptr := fl_event_text; - begin - if Str = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); - end if; - end Text; - - - function Text_Length - return Natural is - begin - return Natural (fl_event_length); - end Text_Length; - - - - - -- Modifiers -- - - function Last - return Event_Kind is - begin - return Event_Kind'Val (fl_event_get); - end Last; - - - function Last_Modifier - return Modifier is - begin - return To_Ada (fl_event_state); - end Last_Modifier; - - - function Last_Modifier - (Had : in Modifier) - return Boolean is - begin - return fl_event_check_state (To_C (Had)) /= 0; - end Last_Modifier; - - - - - -- Mouse -- - - function Mouse_X - return Integer is - begin - return Integer (fl_event_x); - end Mouse_X; - - - function Mouse_X_Root - return Integer is - begin - return Integer (fl_event_x_root); - end Mouse_X_Root; - - - function Mouse_Y - return Integer is - begin - return Integer (fl_event_y); - end Mouse_Y; - - - function Mouse_Y_Root - return Integer is - begin - return Integer (fl_event_y_root); - end Mouse_Y_Root; - - - - function Mouse_DX - return Integer is - begin - return Integer (fl_event_dx); - end Mouse_DX; - - - function Mouse_DY - return Integer is - begin - return Integer (fl_event_dy); - end Mouse_DY; - - - procedure Get_Mouse - (X, Y : out Integer) is - begin - fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); - end Get_Mouse; - - - function Is_Click - return Boolean is - begin - return fl_event_is_click /= 0; - end Is_Click; - - - function Is_Multi_Click - return Boolean is - begin - return fl_event_is_clicks /= 0; - end Is_Multi_Click; - - - procedure Set_Clicks - (To : in Natural) is - begin - fl_event_set_clicks (Interfaces.C.int (To)); - end Set_Clicks; - - - function Last_Button - return Mouse_Button is - begin - return Mouse_Button'Val (fl_event_button); - end Last_Button; - - - function Mouse_Left - return Boolean is - begin - return fl_event_button1 /= 0; - end Mouse_Left; - - - function Mouse_Middle - return Boolean is - begin - return fl_event_button2 /= 0; - end Mouse_Middle; - - - function Mouse_Right - return Boolean is - begin - return fl_event_button3 /= 0; - end Mouse_Right; - - - function Is_Inside - (X, Y, W, H : in Integer) - return Boolean is - begin - return fl_event_inside - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H)) /= 0; - end Is_Inside; - - - - - -- Keyboard -- - - function Last_Key - return Keypress is - begin - return To_Ada (fl_event_key); - end Last_Key; - - - function Original_Last_Key - return Keypress is - begin - return To_Ada (fl_event_original_key); - end Original_Last_Key; - - - function Pressed_During - (Key : in Keypress) - return Boolean is - begin - return fl_event_key_during (To_C (Key)) /= 0; - end Pressed_During; - - - function Key_Now - (Key : in Keypress) - return Boolean is - begin - return fl_event_get_key (To_C (Key)) /= 0; - end Key_Now; - - - function Key_Ctrl - return Boolean is - begin - return fl_event_ctrl /= 0; - end Key_Ctrl; - - - function Key_Alt - return Boolean is - begin - return fl_event_alt /= 0; - end Key_Alt; - - - function Key_Command - return Boolean is - begin - return fl_event_command /= 0; - end Key_Command; - - - function Key_Shift - return Boolean is - begin - return fl_event_shift /= 0; - end Key_Shift; - - -begin - - - fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); - -- fl_event_set_event_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); - - -end FLTK.Event; - - diff --git a/body/fltk-events.adb b/body/fltk-events.adb new file mode 100644 index 0000000..a15c55b --- /dev/null +++ b/body/fltk-events.adb @@ -0,0 +1,988 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Events is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_button1 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_left_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_left_mouse, "fl_enum_left_mouse"); + + fl_enum_middle_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_middle_mouse, "fl_enum_middle_mouse"); + + fl_enum_right_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_right_mouse, "fl_enum_right_mouse"); + + fl_enum_back_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_back_mouse, "fl_enum_back_mouse"); + + fl_enum_forward_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_forward_mouse, "fl_enum_forward_mouse"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Handlers -- + + procedure fl_event_add_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); + pragma Inline (fl_event_add_handler); + + procedure fl_event_set_dispatch + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_set_dispatch, "fl_event_set_dispatch"); + pragma Inline (fl_event_set_dispatch); + + function fl_event_handle_dispatch + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle_dispatch, "fl_event_handle_dispatch"); + pragma Inline (fl_event_handle_dispatch); + + function fl_event_handle + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle, "fl_event_handle"); + pragma Inline (fl_event_handle); + + + + + -- Receiving -- + + function fl_event_get_grab + return Storage.Integer_Address; + pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); + pragma Inline (fl_event_get_grab); + + procedure fl_event_set_grab + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); + pragma Inline (fl_event_set_grab); + + function fl_event_get_pushed + return Storage.Integer_Address; + pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); + pragma Inline (fl_event_get_pushed); + + procedure fl_event_set_pushed + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); + pragma Inline (fl_event_set_pushed); + + function fl_event_get_belowmouse + return Storage.Integer_Address; + pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); + pragma Inline (fl_event_get_belowmouse); + + procedure fl_event_set_belowmouse + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); + pragma Inline (fl_event_set_belowmouse); + + function fl_event_get_focus + return Storage.Integer_Address; + pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); + pragma Inline (fl_event_get_focus); + + procedure fl_event_set_focus + (To : in Storage.Integer_Address); + pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); + pragma Inline (fl_event_set_focus); + + function fl_event_get_visible_focus + return Interfaces.C.int; + pragma Import (C, fl_event_get_visible_focus, "fl_event_get_visible_focus"); + pragma Inline (fl_event_get_visible_focus); + + procedure fl_event_set_visible_focus + (T : in Interfaces.C.int); + pragma Import (C, fl_event_set_visible_focus, "fl_event_set_visible_focus"); + pragma Inline (fl_event_set_visible_focus); + + + + + -- Clipboard -- + + function fl_event_clipboard_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_text, "fl_event_clipboard_text"); + pragma Inline (fl_event_clipboard_text); + + function fl_event_clipboard_type + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_type, "fl_event_clipboard_type"); + pragma Inline (fl_event_clipboard_type); + + + + + -- Multikey -- + + function fl_event_compose + (D : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_compose, "fl_event_compose"); + pragma Inline (fl_event_compose); + + function fl_event_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_text, "fl_event_text"); + pragma Inline (fl_event_text); + + function fl_event_length + return Interfaces.C.int; + pragma Import (C, fl_event_length, "fl_event_length"); + pragma Inline (fl_event_length); + + function fl_event_test_shortcut + (S : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_event_test_shortcut, "fl_event_test_shortcut"); + pragma Inline (fl_event_test_shortcut); + + + + + -- Modifiers -- + + function fl_event_get + return Interfaces.C.int; + pragma Import (C, fl_event_get, "fl_event_get"); + pragma Inline (fl_event_get); + + function fl_event_state + return Interfaces.C.int; + pragma Import (C, fl_event_state, "fl_event_state"); + pragma Inline (fl_event_state); + + function fl_event_check_state + (S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_check_state, "fl_event_check_state"); + pragma Inline (fl_event_check_state); + + + + + -- Mouse -- + + function fl_event_x + return Interfaces.C.int; + pragma Import (C, fl_event_x, "fl_event_x"); + pragma Inline (fl_event_x); + + function fl_event_x_root + return Interfaces.C.int; + pragma Import (C, fl_event_x_root, "fl_event_x_root"); + pragma Inline (fl_event_x_root); + + function fl_event_y + return Interfaces.C.int; + pragma Import (C, fl_event_y, "fl_event_y"); + pragma Inline (fl_event_y); + + function fl_event_y_root + return Interfaces.C.int; + pragma Import (C, fl_event_y_root, "fl_event_y_root"); + pragma Inline (fl_event_y_root); + + function fl_event_dx + return Interfaces.C.int; + pragma Import (C, fl_event_dx, "fl_event_dx"); + pragma Inline (fl_event_dx); + + function fl_event_dy + return Interfaces.C.int; + pragma Import (C, fl_event_dy, "fl_event_dy"); + pragma Inline (fl_event_dy); + + procedure fl_event_get_mouse + (X, Y : out Interfaces.C.int); + pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); + pragma Inline (fl_event_get_mouse); + + function fl_event_is_click + return Interfaces.C.int; + pragma Import (C, fl_event_is_click, "fl_event_is_click"); + pragma Inline (fl_event_is_click); + + procedure fl_event_set_click + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_click, "fl_event_set_click"); + pragma Inline (fl_event_set_click); + + function fl_event_get_clicks + return Interfaces.C.int; + pragma Import (C, fl_event_get_clicks, "fl_event_get_clicks"); + pragma Inline (fl_event_get_clicks); + + procedure fl_event_set_clicks + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); + pragma Inline (fl_event_set_clicks); + + function fl_event_button + return Interfaces.C.int; + pragma Import (C, fl_event_button, "fl_event_button"); + pragma Inline (fl_event_button); + + function fl_event_button1 + return Interfaces.C.int; + pragma Import (C, fl_event_button1, "fl_event_button1"); + pragma Inline (fl_event_button1); + + function fl_event_button2 + return Interfaces.C.int; + pragma Import (C, fl_event_button2, "fl_event_button2"); + pragma Inline (fl_event_button2); + + function fl_event_button3 + return Interfaces.C.int; + pragma Import (C, fl_event_button3, "fl_event_button3"); + pragma Inline (fl_event_button3); + + function fl_event_button4 + return Interfaces.C.int; + pragma Import (C, fl_event_button4, "fl_event_button4"); + pragma Inline (fl_event_button4); + + function fl_event_button5 + return Interfaces.C.int; + pragma Import (C, fl_event_button5, "fl_event_button5"); + pragma Inline (fl_event_button5); + + function fl_event_buttons + return Interfaces.C.int; + pragma Import (C, fl_event_buttons, "fl_event_buttons"); + pragma Inline (fl_event_buttons); + + function fl_event_inside2 + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_inside2, "fl_event_inside2"); + pragma Inline (fl_event_inside2); + + function fl_event_inside + (X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_inside, "fl_event_inside"); + pragma Inline (fl_event_inside); + + + + + -- Keyboard -- + + function fl_event_key + return Interfaces.C.int; + pragma Import (C, fl_event_key, "fl_event_key"); + pragma Inline (fl_event_key); + + function fl_event_original_key + return Interfaces.C.int; + pragma Import (C, fl_event_original_key, "fl_event_original_key"); + pragma Inline (fl_event_original_key); + + function fl_event_key_during + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_key_during, "fl_event_key_during"); + pragma Inline (fl_event_key_during); + + function fl_event_get_key + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_get_key, "fl_event_get_key"); + pragma Inline (fl_event_get_key); + + function fl_event_ctrl + return Interfaces.C.int; + pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); + pragma Inline (fl_event_ctrl); + + function fl_event_alt + return Interfaces.C.int; + pragma Import (C, fl_event_alt, "fl_event_alt"); + pragma Inline (fl_event_alt); + + function fl_event_command + return Interfaces.C.int; + pragma Import (C, fl_event_command, "fl_event_command"); + pragma Inline (fl_event_command); + + function fl_event_shift + return Interfaces.C.int; + pragma Import (C, fl_event_shift, "fl_event_shift"); + pragma Inline (fl_event_shift); + + + + + ------------- + -- Hooks -- + ------------- + + function Event_Handler_Hook + (Num : in Interfaces.C.int) + return Interfaces.C.int + is + Ret_Val : Event_Outcome; + begin + for Func of reverse Handlers loop + Ret_Val := Func (Event_Kind'Val (Num)); + if Ret_Val /= Not_Handled then + return Event_Outcome'Pos (Ret_Val); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + end Event_Handler_Hook; + + + function Dispatch_Hook + (Num : in Interfaces.C.int; + Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Ptr : Storage.Integer_Address; + Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Ptr /= Null_Pointer then + Ada_Ptr := fl_widget_get_user_data (Ptr); + pragma Assert (Ada_Ptr /= Null_Pointer); + Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); + end if; + return Event_Outcome'Pos (Current_Dispatch (Event_Kind'Val (Num), Actual_Window)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Window passed to Event_Dispatch hook did not have user_data pointer back to Ada"; + when Constraint_Error => raise Internal_FLTK_Error with + "Event_Dispatch hook passed unexpected event int value of " & + Interfaces.C.int'Image (Num); + end Dispatch_Hook; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Handlers -- + + procedure Add_Handler + (Func : in Event_Handler) is + begin + Handlers.Append (Func); + end Add_Handler; + + + procedure Remove_Handler + (Func : in Event_Handler) is + begin + for I in reverse Handlers.First_Index .. Handlers.Last_Index loop + if Handlers (I) = Func then + Handlers.Delete (I); + return; + end if; + end loop; + end Remove_Handler; + + + function Get_Dispatch + return Event_Dispatch is + begin + return Current_Dispatch; + end Get_Dispatch; + + + procedure Set_Dispatch + (Func : in Event_Dispatch) is + begin + Current_Dispatch := Func; + if Current_Dispatch /= null then + fl_event_set_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); + else + fl_event_set_dispatch (Null_Pointer); + end if; + end Set_Dispatch; + + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : Interfaces.C.int := fl_event_handle_dispatch + (Event_Kind'Pos (Event), + Wrapper (Origin).Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::handle returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Handle_Dispatch; + + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : Interfaces.C.int := fl_event_handle + (Event_Kind'Pos (Event), + Wrapper (Origin).Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::handle_ returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Handle; + + + + + -- Receiving -- + + function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; + Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Grab_Ptr /= Null_Pointer then + Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); + pragma Assert (Grab_Ptr /= Null_Pointer); + Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); + end if; + return Actual_Grab; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::grab did not have user_data reference back to Ada"; + end Get_Grab; + + + procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class) is + begin + fl_event_set_grab (Wrapper (To).Void_Ptr); + end Set_Grab; + + + procedure Release_Grab is + begin + fl_event_set_grab (Null_Pointer); + end Release_Grab; + + + function Get_Pushed + return access FLTK.Widgets.Widget'Class + is + Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; + Actual_Pushed : access FLTK.Widgets.Widget'Class; + begin + if Pushed_Ptr /= Null_Pointer then + Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); + pragma Assert (Pushed_Ptr /= Null_Pointer); + Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); + end if; + return Actual_Pushed; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::pushed did not have user_data reference back to Ada"; + end Get_Pushed; + + + procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_pushed (Wrapper (To).Void_Ptr); + end Set_Pushed; + + + function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class + is + Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; + Actual_Below : access FLTK.Widgets.Widget'Class; + begin + if Below_Ptr /= Null_Pointer then + Below_Ptr := fl_widget_get_user_data (Below_Ptr); + pragma Assert (Below_Ptr /= Null_Pointer); + Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); + end if; + return Actual_Below; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::belowmouse did not have user_data reference back to Ada"; + end Get_Below_Mouse; + + + procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_belowmouse (Wrapper (To).Void_Ptr); + end Set_Below_Mouse; + + + function Get_Focus + return access FLTK.Widgets.Widget'Class + is + Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; + Actual_Focus : access FLTK.Widgets.Widget'Class; + begin + if Focus_Ptr /= Null_Pointer then + Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); + pragma Assert (Focus_Ptr /= Null_Pointer); + Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); + end if; + return Actual_Focus; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::focus did not have user_data reference back to Ada"; + end Get_Focus; + + + procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_focus (Wrapper (To).Void_Ptr); + end Set_Focus; + + + function Has_Visible_Focus + return Boolean is + begin + return fl_event_get_visible_focus /= 0; + end Has_Visible_Focus; + + + procedure Set_Visible_Focus + (To : in Boolean) is + begin + fl_event_set_visible_focus (Boolean'Pos (To)); + end Set_Visible_Focus; + + + + + -- Clipboard -- + + function Clipboard_Text + return String + is + Text_Ptr : Interfaces.C.Strings.chars_ptr := fl_event_clipboard_text; + begin + if Text_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text_Ptr); + end if; + end Clipboard_Text; + + + function Clipboard_Kind + return String + is + Text_Ptr : Interfaces.C.Strings.chars_ptr := fl_event_clipboard_type; + begin + if Text_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text_Ptr); + end if; + end Clipboard_Kind; + + + + + -- Multikey -- + + function Compose + (Del : out Natural) + return Boolean is + begin + return fl_event_compose (Interfaces.C.int (Del)) /= 0; + end Compose; + + + function Text + return String + is + Str : Interfaces.C.Strings.chars_ptr := fl_event_text; + begin + if Str = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); + end if; + end Text; + + + function Text_Length + return Natural is + begin + return Natural (fl_event_length); + end Text_Length; + + + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean is + begin + return fl_event_test_shortcut (To_C (Shortcut)) /= 0; + end Test_Shortcut; + + + + + -- Modifiers -- + + function Last + return Event_Kind + is + Value : Interfaces.C.int := fl_event_get; + begin + return Event_Kind'Val (Value); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event returned unexpected int value of " & Interfaces.C.int'Image (Value); + end Last; + + + function Last_Modifier + return Modifier is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_state)); + end Last_Modifier; + + + function Last_Modifier + (Had : in Modifier) + return Boolean is + begin + return fl_event_check_state (Interfaces.C.int (To_C (Had))) /= 0; + end Last_Modifier; + + + + + -- Mouse -- + + function Mouse_X + return Integer is + begin + return Integer (fl_event_x); + end Mouse_X; + + + function Mouse_X_Root + return Integer is + begin + return Integer (fl_event_x_root); + end Mouse_X_Root; + + + function Mouse_Y + return Integer is + begin + return Integer (fl_event_y); + end Mouse_Y; + + + function Mouse_Y_Root + return Integer is + begin + return Integer (fl_event_y_root); + end Mouse_Y_Root; + + + + function Mouse_DX + return Integer is + begin + return Integer (fl_event_dx); + end Mouse_DX; + + + function Mouse_DY + return Integer is + begin + return Integer (fl_event_dy); + end Mouse_DY; + + + procedure Get_Mouse + (X, Y : out Integer) is + begin + fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Mouse; + + + function Is_Click + return Boolean is + begin + return fl_event_is_click /= 0; + end Is_Click; + + + procedure Clear_Click is + begin + fl_event_set_click (0); + end Clear_Click; + + + function Is_Multi_Click + return Boolean is + begin + return fl_event_get_clicks /= 0; + end Is_Multi_Click; + + + function Get_Clicks + return Natural + is + Raw : Interfaces.C.int := fl_event_get_clicks; + begin + if Is_Click then + return Positive (Raw + 1); + else + return 0; + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event_clicks returned unexpected int value of " & + Interfaces.C.int'Image (Raw); + end Get_Clicks; + + + procedure Set_Clicks + (To : in Natural) is + begin + if To = 0 then + fl_event_set_clicks (0); + Clear_Click; + elsif To = 1 then + fl_event_set_clicks (0); + else + fl_event_set_clicks (Interfaces.C.int (To) - 1); + end if; + end Set_Clicks; + + + function Last_Button + return Mouse_Button + is + Code : Interfaces.C.int := fl_event_button; + begin + pragma Assert (Last = Push or Last = Release); + if Code = fl_enum_left_mouse then + return Left_Button; + elsif Code = fl_enum_middle_mouse then + return Middle_Button; + elsif Code = fl_enum_right_mouse then + return Right_Button; + elsif Code = fl_enum_back_mouse then + return Back_Button; + elsif Code = fl_enum_forward_mouse then + return Forward_Button; + else + raise Internal_FLTK_Error with "Fl::event_button returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::event_button was called when the most recent event was not Push or Release"; + end Last_Button; + + + function Mouse_Left + return Boolean is + begin + return fl_event_button1 /= 0; + end Mouse_Left; + + + function Mouse_Middle + return Boolean is + begin + return fl_event_button2 /= 0; + end Mouse_Middle; + + + function Mouse_Right + return Boolean is + begin + return fl_event_button3 /= 0; + end Mouse_Right; + + + function Mouse_Back + return Boolean is + begin + return fl_event_button4 /= 0; + end Mouse_Back; + + + function Mouse_Forward + return Boolean is + begin + return fl_event_button5 /= 0; + end Mouse_Forward; + + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean) + is + type Cint_Mod is mod 2 ** Interfaces.C.int'Size; + Mask : Interfaces.C.int := fl_event_buttons; + begin + Left := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button1)) /= 0; + Middle := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button2)) /= 0; + Right := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button3)) /= 0; + Back := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button4)) /= 0; + Forward := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button5)) /= 0; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event_buttons returned unexpected int value of " & + Interfaces.C.int'Image (Mask); + end Mouse_Buttons; + + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean is + begin + return fl_event_inside2 (Wrapper (Child).Void_Ptr) /= 0; + end Is_Inside; + + + function Is_Inside + (X, Y, W, H : in Integer) + return Boolean is + begin + return fl_event_inside + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)) /= 0; + end Is_Inside; + + + + + -- Keyboard -- + + function Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_key)); + end Last_Key; + + + function Original_Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_original_key)); + end Original_Last_Key; + + + function Pressed_During + (Key : in Keypress) + return Boolean is + begin + return fl_event_key_during (Interfaces.C.int (To_C (Key))) /= 0; + end Pressed_During; + + + function Key_Now + (Key : in Keypress) + return Boolean is + begin + return fl_event_get_key (Interfaces.C.int (To_C (Key))) /= 0; + end Key_Now; + + + function Key_Ctrl + return Boolean is + begin + return fl_event_ctrl /= 0; + end Key_Ctrl; + + + function Key_Alt + return Boolean is + begin + return fl_event_alt /= 0; + end Key_Alt; + + + function Key_Command + return Boolean is + begin + return fl_event_command /= 0; + end Key_Command; + + + function Key_Shift + return Boolean is + begin + return fl_event_shift /= 0; + end Key_Shift; + + +begin + + + fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + + +end FLTK.Events; + + diff --git a/body/fltk-menu_items.adb b/body/fltk-menu_items.adb index 7ee4d61..dfb579a 100644 --- a/body/fltk-menu_items.adb +++ b/body/fltk-menu_items.adb @@ -297,7 +297,7 @@ package body FLTK.Menu_Items is This.Void_Ptr := new_fl_menu_item (Interfaces.C.To_C (Text), Callback_Convert.To_Address (Action), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), MFlag_To_Cint (Flags)); end return; end Create; @@ -536,7 +536,7 @@ package body FLTK.Menu_Items is (This : in Menu_Item) return Key_Combo is begin - return To_Ada (fl_menu_item_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_menu_item_get_shortcut (This.Void_Ptr))); end Get_Shortcut; diff --git a/body/fltk-screen.adb b/body/fltk-screen.adb index 89f7413..6b8118e 100644 --- a/body/fltk-screen.adb +++ b/body/fltk-screen.adb @@ -16,6 +16,25 @@ use type package body FLTK.Screen is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_mode_rgb : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb, "fl_enum_mode_rgb"); + + fl_enum_mode_rgb8 : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb8, "fl_enum_mode_rgb8"); + + fl_enum_mode_double : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_double, "fl_enum_mode_double"); + + fl_enum_mode_index : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_index, "fl_enum_mode_index"); + + + + ------------------------ -- Functions From C -- ------------------------ @@ -27,6 +46,12 @@ package body FLTK.Screen is pragma Import (C, fl_screen_display, "fl_screen_display"); pragma Inline (fl_screen_display); + function fl_screen_visual + (F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_screen_visual, "fl_screen_visual"); + pragma Inline (fl_screen_visual); + @@ -133,6 +158,21 @@ package body FLTK.Screen is + -- Drawing -- + + function fl_screen_get_damage + return Interfaces.C.int; + pragma Import (C, fl_screen_get_damage, "fl_screen_get_damage"); + pragma Inline (fl_screen_get_damage); + + procedure fl_screen_set_damage + (V : in Interfaces.C.int); + pragma Import (C, fl_screen_set_damage, "fl_screen_set_damage"); + pragma Inline (fl_screen_set_damage); + + + + ----------------------- -- API Subprograms -- ----------------------- @@ -146,6 +186,29 @@ package body FLTK.Screen is end Set_Display_String; + procedure Set_Visual_Mode + (Value : in Visual_Mode) + is + Ignore : Boolean := Set_Visual_Mode (Value); + begin + null; + end Set_Visual_Mode; + + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean is + begin + return fl_screen_visual + ((case Value is + when RGB => fl_enum_mode_rgb, + when RGB_24bit => fl_enum_mode_rgb8, + when Double_Buffer => fl_enum_mode_double + fl_enum_mode_index, + when Double_RGB => fl_enum_mode_double + fl_enum_mode_rgb, + when Double_RGB_24bit => fl_enum_mode_double + fl_enum_mode_rgb8)) /= 0; + end Set_Visual_Mode; + + -- Basic Dimensions -- @@ -318,6 +381,24 @@ package body FLTK.Screen is end Bounding_Rect; + + + -- Drawing -- + + function Is_Damaged + return Boolean is + begin + return fl_screen_get_damage /= 0; + end Is_Damaged; + + + procedure Set_Damaged + (To : in Boolean) is + begin + fl_screen_set_damage (Boolean'Pos (To)); + end Set_Damaged; + + end FLTK.Screen; diff --git a/body/fltk-widgets-buttons.adb b/body/fltk-widgets-buttons.adb index d6e587e..bc78d8d 100644 --- a/body/fltk-widgets-buttons.adb +++ b/body/fltk-widgets-buttons.adb @@ -293,7 +293,7 @@ package body FLTK.Widgets.Buttons is (This : in Button) return Key_Combo is begin - return To_Ada (fl_button_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_button_get_shortcut (This.Void_Ptr))); end Get_Shortcut; diff --git a/body/fltk-widgets-groups-text_displays-text_editors.adb b/body/fltk-widgets-groups-text_displays-text_editors.adb index 906edef..680d3be 100644 --- a/body/fltk-widgets-groups-text_displays-text_editors.adb +++ b/body/fltk-widgets-groups-text_displays-text_editors.adb @@ -8,7 +8,7 @@ with Ada.Assertions, Ada.Characters.Latin_1, - FLTK.Event, + FLTK.Events, Interfaces.C; @@ -476,8 +476,8 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is Editor_Ptr : Storage.Integer_Address := fl_widget_get_user_data (E); Ada_Editor : access Text_Editor'Class; - Extra_Keys : Modifier := FLTK.Event.Last_Modifier; - Actual_Key : Keypress := FLTK.Event.Last_Key; -- fuck you FLTK, give me the real code + Extra_Keys : Modifier := FLTK.Events.Last_Modifier; + Actual_Key : Keypress := FLTK.Events.Last_Key; -- fuck you FLTK, give me the real code Ada_Key : Key_Combo := Extra_Keys + Actual_Key; -- For whatever reason, if a regular key function is used then FLTK will diff --git a/body/fltk-widgets-groups-text_displays.adb b/body/fltk-widgets-groups-text_displays.adb index 7fda2fd..601bde9 100644 --- a/body/fltk-widgets-groups-text_displays.adb +++ b/body/fltk-widgets-groups-text_displays.adb @@ -2172,7 +2172,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in Text_Display) return Key_Combo is begin - return To_Ada (fl_text_display_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_text_display_get_shortcut (This.Void_Ptr))); end Get_Shortcut; @@ -2180,7 +2180,7 @@ package body FLTK.Widgets.Groups.Text_Displays is (This : in out Text_Display; Value : in Key_Combo) is begin - fl_text_display_set_shortcut (This.Void_Ptr, To_C (Value)); + fl_text_display_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (Value))); end Set_Shortcut; diff --git a/body/fltk-widgets-inputs.adb b/body/fltk-widgets-inputs.adb index 888ef68..ef791be 100644 --- a/body/fltk-widgets-inputs.adb +++ b/body/fltk-widgets-inputs.adb @@ -633,7 +633,7 @@ package body FLTK.Widgets.Inputs is (This : in Input) return Key_Combo is begin - return To_Ada (fl_input_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_input_get_shortcut (This.Void_Ptr))); end Get_Shortcut; @@ -641,7 +641,7 @@ package body FLTK.Widgets.Inputs is (This : in out Input; To : in Key_Combo) is begin - fl_input_set_shortcut (This.Void_Ptr, To_C (To)); + fl_input_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); end Set_Shortcut; diff --git a/body/fltk-widgets-menus-menu_bars-systemwide.adb b/body/fltk-widgets-menus-menu_bars-systemwide.adb index c09ef93..47ef6d9 100644 --- a/body/fltk-widgets-menus-menu_bars-systemwide.adb +++ b/body/fltk-widgets-menus-menu_bars-systemwide.adb @@ -338,7 +338,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -357,7 +357,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -416,7 +416,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -437,7 +437,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -584,7 +584,7 @@ package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is fl_sys_menu_bar_shortcut (This.Void_Ptr, Interfaces.C.int (Place) - 1, - To_C (Press)); + Interfaces.C.int (To_C (Press))); end Set_Shortcut; diff --git a/body/fltk-widgets-menus.adb b/body/fltk-widgets-menus.adb index ede63a3..1e690f3 100644 --- a/body/fltk-widgets-menus.adb +++ b/body/fltk-widgets-menus.adb @@ -596,7 +596,7 @@ package body FLTK.Widgets.Menus is Added_Spot : Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -615,7 +615,7 @@ package body FLTK.Widgets.Menus is Added_Spot : Interfaces.C.int := fl_menu_add2 (This.Void_Ptr, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -674,7 +674,7 @@ package body FLTK.Widgets.Menus is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -695,7 +695,7 @@ package body FLTK.Widgets.Menus is (This.Void_Ptr, Interfaces.C.int (Place) - 1, Interfaces.C.To_C (Text), - To_C (Shortcut), + Interfaces.C.int (To_C (Shortcut)), Callback_Convert.To_Address (Action), MFlag_To_Cint (Flags)); begin @@ -1177,7 +1177,7 @@ package body FLTK.Widgets.Menus is fl_menu_shortcut (This.Void_Ptr, Interfaces.C.int (Place) - 1, - To_C (Press)); + Interfaces.C.int (To_C (Press))); end Set_Shortcut; diff --git a/body/fltk-widgets-valuators-value_inputs.adb b/body/fltk-widgets-valuators-value_inputs.adb index 929d117..b107e3a 100644 --- a/body/fltk-widgets-valuators-value_inputs.adb +++ b/body/fltk-widgets-valuators-value_inputs.adb @@ -317,7 +317,7 @@ package body FLTK.Widgets.Valuators.Value_Inputs is (This : in Value_Input) return Key_Combo is begin - return To_Ada (fl_value_input_get_shortcut (This.Void_Ptr)); + return To_Ada (Interfaces.C.unsigned (fl_value_input_get_shortcut (This.Void_Ptr))); end Get_Shortcut; diff --git a/body/fltk.adb b/body/fltk.adb index 48023f2..c7a8fe4 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -11,6 +11,7 @@ with use type Interfaces.C.int, + Interfaces.C.unsigned, Interfaces.C.unsigned_char, Interfaces.C.unsigned_long; @@ -22,17 +23,42 @@ package body FLTK is -- Constants From C -- ------------------------ + -- Color -- + fl_enum_num_red : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_red); + pragma Import (C, fl_enum_num_red, "fl_enum_num_red"); fl_enum_num_green : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_green); + pragma Import (C, fl_enum_num_green, "fl_enum_num_green"); fl_enum_num_blue : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_blue); + pragma Import (C, fl_enum_num_blue, "fl_enum_num_blue"); fl_enum_num_gray : constant Interfaces.C.int; - pragma Import (C, fl_enum_num_gray); + pragma Import (C, fl_enum_num_gray, "fl_enum_num_gray"); + + + + + -- Keyboard and Mouse Input -- + + fl_enum_button1 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_buttons : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_buttons, "fl_enum_buttons"); @@ -154,21 +180,6 @@ package body FLTK is - -- Drawing -- - - function fl_get_damage - return Interfaces.C.int; - pragma Import (C, fl_get_damage, "fl_get_damage"); - pragma Inline (fl_get_damage); - - procedure fl_set_damage - (V : in Interfaces.C.int); - pragma Import (C, fl_set_damage, "fl_set_damage"); - pragma Inline (fl_set_damage); - - - - -- Event Loop -- function fl_check @@ -457,14 +468,14 @@ package body FLTK is function To_C (Key : in Key_Combo) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin return To_C (Key.Modcode) + To_C (Key.Keycode) + To_C (Key.Mousecode); end To_C; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Key_Combo is begin return Result : Key_Combo do @@ -477,14 +488,14 @@ package body FLTK is function To_C (Key : in Keypress) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin - return Interfaces.C.int (Key); + return Interfaces.C.unsigned (Key); end To_C; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Keypress is begin return Keypress (Key mod 65536); @@ -493,14 +504,14 @@ package body FLTK is function To_C (Modi : in Modifier) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin - return Interfaces.C.int (Modi) * 65536; + return Interfaces.C.unsigned (Modi) * 65536; end To_C; function To_Ada - (Modi : in Interfaces.C.int) + (Modi : in Interfaces.C.unsigned) return Modifier is begin return Modifier ((Modi / 65536) mod 256); @@ -509,27 +520,41 @@ package body FLTK is function To_C (Button : in Mouse_Button) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin case Button is - when Left_Button => return 1 * (256 ** 3); - when Middle_Button => return 2 * (256 ** 3); - when Right_Button => return 4 * (256 ** 3); - when others => return 0; + when No_Button => return 0; + when Left_Button => return fl_enum_button1; + when Middle_Button => return fl_enum_button2; + when Right_Button => return fl_enum_button3; + when Back_Button => return fl_enum_button4; + when Forward_Button => return fl_enum_button5; + when Any_Button => return fl_enum_buttons; end case; end To_C; function To_Ada - (Button : in Interfaces.C.int) + (Button : in Interfaces.C.unsigned) return Mouse_Button is begin - case (Button / (256 ** 3)) is - when 1 => return Left_Button; - when 2 => return Middle_Button; - when 4 => return Right_Button; - when others => return No_Button; - end case; + if Button = 0 then + return No_Button; + elsif Button = fl_enum_button1 then + return Left_Button; + elsif Button = fl_enum_button2 then + return Middle_Button; + elsif Button = fl_enum_button3 then + return Right_Button; + elsif Button = fl_enum_button4 then + return Back_Button; + elsif Button = fl_enum_button5 then + return Forward_Button; + elsif Button = fl_enum_buttons then + return Any_Button; + else + raise Constraint_Error; + end if; end To_Ada; @@ -701,25 +726,15 @@ package body FLTK is - -- Drawing -- - - function Is_Damaged - return Boolean is - begin - return fl_get_damage /= 0; - end Is_Damaged; - + -- Event Loop -- - procedure Set_Damaged - (To : in Boolean) is + procedure Check + is + Ignore : Interfaces.C.int := fl_check; begin - fl_set_damage (Boolean'Pos (To)); - end Set_Damaged; - - - + null; + end Check; - -- Event Loop -- function Check return Boolean is diff --git a/doc/enumerations.html b/doc/enumerations.html index 3533cd9..6e4f521 100644 --- a/doc/enumerations.html +++ b/doc/enumerations.html @@ -78,9 +78,10 @@ - #define FL_LEFT_MOUSE 1
- #define FL_MIDDLE_MOUSE 2
- #define FL_RIGHT_MOUSE 3 + #define FL_BUTTON1 0x01000000
+ #define FL_BUTTON2 0x02000000
+ #define FL_BUTTON3 0x04000000
+ #define FL_BUTTONS 0x7f000000 Mouse_Button diff --git a/doc/fl.html b/doc/fl.html index 7d4d3ee..9cefff7 100644 --- a/doc/fl.html +++ b/doc/fl.html @@ -67,6 +67,31 @@ + + + + + + + + + + + + + +

Static Attributes
+static char const * const clipboard_image = "image"; +	+Clipboard_Image : constant String; +
+static char const * const clipboard_plain_text = "text/plain"; +	+Clipboard_Plain_Text : constant String; +

+ + + @@ -103,15 +128,6 @@ function API_Version - - - - - @@ -150,6 +166,8 @@ static cairo_t * cairo_make_current(Fl_Window *w); static int check(); @@ -164,26 +182,6 @@ static void clear_widget_pointer(Fl_Widget const *w); - - - - - - - - - - @@ -198,15 +196,6 @@ static void do_widget_deletion(); - - - - - @@ -214,24 +203,6 @@ static int gl_visual(int, int *alist=0); - - - - - - - - - - - - - - - @@ -268,22 +230,6 @@ function Run - - - - - - - - - - diff --git a/doc/fl_(fltk-event).html b/doc/fl_(fltk-event).html deleted file mode 100644 index 3aaca1f..0000000 --- a/doc/fl_(fltk-event).html +++ /dev/null @@ -1,547 +0,0 @@ - - - - - - Fl (FLTK.Event) Binding Map - - - - - - -

Fl (FLTK.Event) Binding Map

- - -Back to Index - - -

Static Functions and Procedures
-static void awake(void *message=0); -	-procedure Awake; -
static void cairo_autolink_context(bool alink);		+procedure Check; + function Check return Boolean;
-static void damage(int d); -	-procedure Set_Damaged - (To : in Boolean); -
-static int damage(); -	-function Is_Damaged - return Boolean; -
static void delete_widget(Fl_Widget *w);	Used automatically as appropriate by the binding.
-static void flush(); -	-procedure Flush; -
static int gl_visual(int, int *alist=0);
-static int handle(int, Fl_Window ); - -static int handle_(int, Fl_Window ); -
-static int lock(); -	-procedure Lock; -
static int ready();	@@ -242,15 +213,6 @@ function Ready
-static void redraw(); -	-procedure Redraw; -
static void release_widget_pointer(Fl_Widget *&w);	Marked as internal use only.
-static void * thread_message(); -
-static void unlock(); -	-procedure Unlock; -
static void use_high_res_GL(int val);

- - - - - - - -

Package name
Fl	FLTK.Event

- - - - - - - - - - - - - - - - -

Types
Fl_Event_Handler	Event_Handler
Fl_Event_Dispatch

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Static Functions and Procedures
-static void add_handler(Fl_Event_Handler h); -	-procedure Add_Handler - (Func : in Event_Handler); -
-static Fl_Widget * belowmouse(); -	-function Get_Below_Mouse - return access FLTK.Widgets.Widget'Class; -
-static void belowmouse(Fl_Widget *); -	-procedure Set_Below_Mouse - (To : in FLTK.Widgets.Widget'Class); -
-static int compose(int &del); -	-function Compose - (Del : out Natural) - return Boolean; -
-static void compose_reset(); -	-procedure Compose_Reset; -
-static int event(); -	-function Last - return Event_Kind; -
-static int event_alt(); -	-function Key_Alt - return Boolean; -
-static int event_button(); -	-function Last_Button - return Mouse_Button; -
-static int event_button1(); -	-function Mouse_Left - return Boolean; -
-static int event_button2(); -	-function Mouse_Middle - return Boolean; -
-static int event_button3(); -	-function Mouse_Right - return Boolean; -
-static int event_buttons(); -
-static int event_clicks(); -	-function Is_Multi_Click - return Boolean; -
-static void event_clicks(int i); -	-procedure Set_Clicks - (To : in Natural); -
-static void * event_clipboard(); -
-static const char * event_clipboard_type(); -
-static int event_command(); -	-function Key_Command - return Boolean; -
-static int event_ctrl(); -	-function Key_Ctrl - return Boolean; -
-static Fl_Event_Dispatch event_dispatch(); -	TBA
-static void event_dispatch(Fl_Event_Dispatch d); -
-static int event_dx(); -	-function Mouse_DX - return Integer; -
-static int event_dy(); -	-function Mouse_DY - return Integer; -
-static int event_inside(const Fl_Widget *); -
-static int event_inside(int, int, int, int); -	-function Is_Inside - (X, Y, W, H : in Integer) - return Boolean; -
-static int event_is_click(); -	-function Is_Click - return Boolean; -
-static void event_is_click(int i); -	See static void event_clicks(int i);
-static int event_key(); -	-function Last_Key - return Keypress; -
-static int event_key(int key); -	-function Pressed_During - (Key : in Keypress) - return Boolean; -
-static int event_length(); -	-function Text_Length - return Natural; -
-static int event_original_key(); -	-function Original_Last_Key - return Keypress; -
-static int event_shift(); -	-function Key_Shift - return Boolean; -
-static int event_state(); -	-function Last_Modifier - return Modifier; -
-static int event_state(int mask); -	-function Last_Modifier - (Had : in Modifier) - return Boolean; -
-static const char * event_text(); -	-function Text - return String; -
-static int event_x(); -	-function Mouse_X - return Integer; -
-static int event_x_root(); -	-function Mouse_X_Root - return Integer; -
-static int event_y(); -	-function Mouse_Y - return Integer; -
-static int event_y_root(); -	-function Mouse_Y_Root - return Integer; -
-static Fl_Widget * focus(); -	-function Get_Focus - return access FLTK.Widgets.Widget'Class; -
-static void focus(Fl_Widget *); -	-procedure Set_Focus - (To : in FLTK.Widgets.Widget'Class); -
-static int get_key(int key); -	-function Key_Now - (Key : in Keypress) - return Boolean; -
-static void get_mouse(int &, int &); -	-procedure Get_Mouse - (X, Y : out Integer); -
-static Fl_Window * grab(); -	-function Get_Grab - return access FLTK.Widgets.Groups.Windows.Window'Class; -
-static void grab(Fl_Window *); - -static void grab(Fl_Window &win); -	-procedure Set_Grab - (To : in FLTK.Widgets.Groups.Windows.Window'Class); -
-static Fl_Widget * pushed(); -	-function Get_Pushed - return access FLTK.Widgets.Widget'Class; -
-static void pushed(Fl_Widget *); -	-procedure Set_Pushed - (To : in FLTK.Widgets.Widget'Class); -
-static void release(); -	-procedure Release_Grab; -
-static void remove_handler(Fl_Event_Handler h); -	-procedure Remove_Handler - (Func : in Event_Handler); -
-static int test_shortcut(Fl_Shortcut); -
-static int visible_focus(); -	-function Has_Visible_Focus - return Boolean; -
-static void visible_focus(int v); -	-procedure Set_Visible_Focus - (To : in Boolean); -

- - - - - diff --git a/doc/fl_(fltk-events).html b/doc/fl_(fltk-events).html new file mode 100644 index 0000000..c9846fd --- /dev/null +++ b/doc/fl_(fltk-events).html @@ -0,0 +1,619 @@ + + + + + + Fl (FLTK.Events) Binding Map + + + + + + +

Fl (FLTK.Events) Binding Map

+ + +Back to Index + + + + + + + + + + +

Package name
Fl	FLTK.Events

+ + + + + + + + + + + + + + + + +

Types
Fl_Event_Handler	Event_Handler
Fl_Event_Dispatch	Event_Dispatch

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

Static Functions and Procedures
+static void add_handler(Fl_Event_Handler h); +	+procedure Add_Handler + (Func : in Event_Handler); +
+static Fl_Widget * belowmouse(); +	+function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class; +
+static void belowmouse(Fl_Widget *); +	+procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class); +
+static int compose(int &del); +	+function Compose + (Del : out Natural) + return Boolean; +
+static void compose_reset(); +	+procedure Compose_Reset; +
+static int event(); +	+function Last + return Event_Kind; +
+static int event_alt(); +	+function Key_Alt + return Boolean; +
+static int event_button(); +	+function Last_Button + return Mouse_Button; +
+static int event_button1(); +	+function Mouse_Left + return Boolean; +
+static int event_button2(); +	+function Mouse_Middle + return Boolean; +
+static int event_button3(); +	+function Mouse_Right + return Boolean; +
+static int event_button4(); +	+function Mouse_Back + return Boolean; +
+static int event_button5(); +	+function Mouse_Forward + return Boolean; +
+static int event_buttons(); +	+procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean); +
+static int event_clicks(); +	+function Is_Multi_Click + return Boolean; + +function Get_Clicks + return Natural; +
+static void event_clicks(int i); +	+procedure Set_Clicks + (To : in Natural); +
+static void * event_clipboard(); +	+function Clipboard_Text + return String; +
+static const char * event_clipboard_type(); +	+function Clipboard_Kind + return String; +
+static int event_command(); +	+function Key_Command + return Boolean; +
+static int event_ctrl(); +	+function Key_Ctrl + return Boolean; +
+static Fl_Event_Dispatch event_dispatch(); +	+function Get_Dispatch + return Event_Dispatch; +
+static void event_dispatch(Fl_Event_Dispatch d); +	+procedure Set_Dispatch + (Func : in Event_Dispatch); +
+static int event_dx(); +	+function Mouse_DX + return Integer; +
+static int event_dy(); +	+function Mouse_DY + return Integer; +
+static int event_inside(const Fl_Widget *); +	+function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean; +
+static int event_inside(int, int, int, int); +	+function Is_Inside + (X, Y, W, H : in Integer) + return Boolean; +
+static int event_is_click(); +	+function Is_Click + return Boolean; +
+static void event_is_click(int i); +	+procedure Clear_Click; +
+static int event_key(); +	+function Last_Key + return Keypress; +
+static int event_key(int key); +	+function Pressed_During + (Key : in Keypress) + return Boolean; +
+static int event_length(); +	+function Text_Length + return Natural; +
+static int event_original_key(); +	+function Original_Last_Key + return Keypress; +
+static int event_shift(); +	+function Key_Shift + return Boolean; +
+static int event_state(); +	+function Last_Modifier + return Modifier; +
+static int event_state(int mask); +	+function Last_Modifier + (Had : in Modifier) + return Boolean; +
+static const char * event_text(); +	+function Text + return String; +
+static int event_x(); +	+function Mouse_X + return Integer; +
+static int event_x_root(); +	+function Mouse_X_Root + return Integer; +
+static int event_y(); +	+function Mouse_Y + return Integer; +
+static int event_y_root(); +	+function Mouse_Y_Root + return Integer; +
+static Fl_Widget * focus(); +	+function Get_Focus + return access FLTK.Widgets.Widget'Class; +
+static void focus(Fl_Widget *); +	+procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class); +
+static int get_key(int key); +	+function Key_Now + (Key : in Keypress) + return Boolean; +
+static void get_mouse(int &, int &); +	+procedure Get_Mouse + (X, Y : out Integer); +
+static Fl_Window * grab(); +	+function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class; +
+static void grab(Fl_Window *); + +static void grab(Fl_Window &win); +	+procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class); +
+static int handle(int, Fl_Window *); +	+function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; +
+static int handle_(int, Fl_Window *); +	+function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; +
+static Fl_Widget * pushed(); +	+function Get_Pushed + return access FLTK.Widgets.Widget'Class; +
+static void pushed(Fl_Widget *); +	+procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class); +
+static void release(); +	+procedure Release_Grab; +
+static void remove_handler(Fl_Event_Handler h); +	+procedure Remove_Handler + (Func : in Event_Handler); +
+static int test_shortcut(Fl_Shortcut); +	+function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean; +
+static int visible_focus(); +	+function Has_Visible_Focus + return Boolean; +
+static void visible_focus(int v); +	+procedure Set_Visible_Focus + (To : in Boolean); +

+ + + + + diff --git a/doc/fl_(fltk-screen).html b/doc/fl_(fltk-screen).html index a5f8722..7d44273 100644 --- a/doc/fl_(fltk-screen).html +++ b/doc/fl_(fltk-screen).html @@ -28,11 +28,43 @@ + + + + + + + + +

Types
Fl_Mode	Visual_Mode

+ + + + + + + + + + + + + + + + + + + + + + + - + diff --git a/doc/fl_(fltk-static).html b/doc/fl_(fltk-static).html index 3afc53a..ac47474 100644 --- a/doc/fl_(fltk-static).html +++ b/doc/fl_(fltk-static).html @@ -132,20 +132,6 @@ static void (*atclose)(Fl_Window *, void *); - - - - - - - - - - @@ -281,6 +267,15 @@ static int awake(Fl_Awake_Handler cb, void *message=0); + + + + + + + + + + + + + + + + + + + +

Static Functions and Procedures
+static int damage(); +	+function Is_Damaged + return Boolean; +
+static void damage(int d); +	+procedure Set_Damaged + (To : in Boolean); +
static void display(const char *);	@@ -43,6 +75,15 @@ procedure Set_Display_String
+static void flush(); +	+procedure Flush; +
static int h();	@@ -53,6 +94,15 @@ function Get_H
+static void redraw(); +	+procedure Redraw; +
static int screen_count();	@@ -180,7 +230,14 @@ procedure Work_Area	static int visual(int);	+procedure Set_Visual_Mode + (Value : in Visual_Mode); + +function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean; +
-static char const * const clipboard_image = "image"; -
-static char const * const clipboard_plain_text = "text/plain"; -
static const char * const help = helpmsg + 13;
+static void awake(void *message=0); +	+procedure Awake; +
static void background(uchar, uchar, uchar);	@@ -603,6 +598,15 @@ function Is_Scheme
+static int lock(); +	+procedure Lock; +
static Fl_Window * modal();	@@ -948,6 +952,22 @@ static void set_labeltype(Fl_Labeltype, Fl_Labeltype from);
+static void * thread_message(); +
+static void unlock(); +	+procedure Unlock; +

diff --git a/doc/index.html b/doc/index.html index 57ff15c..af2faf1 100644 --- a/doc/index.html +++ b/doc/index.html @@ -20,7 +20,7 @@

@@ -161,7 +161,7 @@

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