diff options
Diffstat (limited to 'body/fltk-widgets-groups-windows.adb')
| -rw-r--r-- | body/fltk-widgets-groups-windows.adb | 446 |
1 files changed, 371 insertions, 75 deletions
diff --git a/body/fltk-widgets-groups-windows.adb b/body/fltk-widgets-groups-windows.adb index 3a07d96..55f3506 100644 --- a/body/fltk-widgets-groups-windows.adb +++ b/body/fltk-widgets-groups-windows.adb @@ -6,10 +6,8 @@ with - Ada.Command_Line, Interfaces.C.Strings, - FLTK.Images.RGB, - FLTK.Show_Argv; + FLTK.Args_Marshal; use type @@ -25,6 +23,8 @@ package body FLTK.Widgets.Groups.Windows is -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_window (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -47,6 +47,8 @@ package body FLTK.Widgets.Groups.Windows is + -- Visibility -- + procedure fl_window_show (W : in Storage.Integer_Address); pragma Import (C, fl_window_show, "fl_window_show"); @@ -85,13 +87,10 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_make_current, "fl_window_make_current"); pragma Inline (fl_window_make_current); - procedure fl_window_free_position - (W : in Storage.Integer_Address); - pragma Import (C, fl_window_free_position, "fl_window_free_position"); - pragma Inline (fl_window_free_position); + -- Fullscreen -- function fl_window_fullscreen_active (W : in Storage.Integer_Address) @@ -124,16 +123,30 @@ package body FLTK.Widgets.Groups.Windows is + -- Icons, Cursors -- + procedure fl_window_set_icon (W, P : in Storage.Integer_Address); pragma Import (C, fl_window_set_icon, "fl_window_set_icon"); pragma Inline (fl_window_set_icon); + procedure fl_window_icons + (W, P : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_icons, "fl_window_icons"); + pragma Inline (fl_window_icons); + procedure fl_window_default_icon (P : in Storage.Integer_Address); pragma Import (C, fl_window_default_icon, "fl_window_default_icon"); pragma Inline (fl_window_default_icon); + procedure fl_window_default_icons + (P : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_default_icons, "fl_window_default_icons"); + pragma Inline (fl_window_default_icons); + function fl_window_get_iconlabel (W : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; @@ -167,6 +180,8 @@ package body FLTK.Widgets.Groups.Windows is + -- Settings -- + function fl_window_get_border (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -179,6 +194,11 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_set_border, "fl_window_set_border"); pragma Inline (fl_window_set_border); + procedure fl_window_clear_border + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_clear_border, "fl_window_clear_border"); + pragma Inline (fl_window_clear_border); + function fl_window_get_override (W : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -202,11 +222,6 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_non_modal, "fl_window_non_modal"); pragma Inline (fl_window_non_modal); - procedure fl_window_clear_modal_states - (W : in Storage.Integer_Address); - pragma Import (C, fl_window_clear_modal_states, "fl_window_clear_modal_states"); - pragma Inline (fl_window_clear_modal_states); - procedure fl_window_set_modal (W : in Storage.Integer_Address); pragma Import (C, fl_window_set_modal, "fl_window_set_modal"); @@ -217,20 +232,27 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_set_non_modal, "fl_window_set_non_modal"); pragma Inline (fl_window_set_non_modal); + procedure fl_window_clear_modal_states + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_clear_modal_states, "fl_window_clear_modal_states"); + pragma Inline (fl_window_clear_modal_states); + + -- Labels, Hotspot, Shape -- + function fl_window_get_label (W : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_window_get_label, "fl_window_get_label"); pragma Inline (fl_window_get_label); - procedure fl_window_set_label + procedure fl_window_copy_label (W : in Storage.Integer_Address; T : in Interfaces.C.char_array); - pragma Import (C, fl_window_set_label, "fl_window_set_label"); - pragma Inline (fl_window_set_label); + pragma Import (C, fl_window_copy_label, "fl_window_copy_label"); + pragma Inline (fl_window_copy_label); procedure fl_window_hotspot (W : in Storage.Integer_Address; @@ -244,19 +266,39 @@ package body FLTK.Widgets.Groups.Windows is pragma Import (C, fl_window_hotspot2, "fl_window_hotspot2"); pragma Inline (fl_window_hotspot2); + procedure fl_window_shape + (W, P : in Storage.Integer_Address); + pragma Import (C, fl_window_shape, "fl_window_shape"); + pragma Inline (fl_window_shape); + + + + + -- Dimensions -- + procedure fl_window_size_range (W : in Storage.Integer_Address; LW, LH, HW, HH, DW, DH, A : in Interfaces.C.int); pragma Import (C, fl_window_size_range, "fl_window_size_range"); pragma Inline (fl_window_size_range); - procedure fl_window_shape - (W, P : in Storage.Integer_Address); - pragma Import (C, fl_window_shape, "fl_window_shape"); - pragma Inline (fl_window_shape); - + procedure fl_window_resize + (N : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_window_resize, "fl_window_resize"); + pragma Inline (fl_window_resize); + function fl_window_get_force_position + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_force_position, "fl_window_get_force_position"); + pragma Inline (fl_window_get_force_position); + procedure fl_window_set_force_position + (N : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_window_set_force_position, "fl_window_set_force_position"); + pragma Inline (fl_window_set_force_position); function fl_window_get_x_root (W : in Storage.Integer_Address) @@ -285,11 +327,57 @@ package body FLTK.Widgets.Groups.Windows is + -- Class Info -- + + function fl_window_get_xclass + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_xclass, "fl_window_get_xclass"); + pragma Inline (fl_window_get_xclass); + + procedure fl_window_set_xclass + (W : in Storage.Integer_Address; + C : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_xclass, "fl_window_set_xclass"); + pragma Inline (fl_window_set_xclass); + + function fl_window_get_default_xclass + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_default_xclass, "fl_window_get_default_xclass"); + pragma Inline (fl_window_get_default_xclass); + + procedure fl_window_set_default_xclass + (C : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_default_xclass, "fl_window_set_default_xclass"); + pragma Inline (fl_window_set_default_xclass); + + function fl_window_menu_window + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_menu_window, "fl_window_menu_window"); + pragma Inline (fl_window_menu_window); + + function fl_window_tooltip_window + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_tooltip_window, "fl_window_tooltip_window"); + pragma Inline (fl_window_tooltip_window); + + + + + -- Drawing, Events -- + procedure fl_window_draw (W : in Storage.Integer_Address); pragma Import (C, fl_window_draw, "fl_window_draw"); pragma Inline (fl_window_draw); + procedure fl_window_flush + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_flush, "fl_window_flush"); + pragma Inline (fl_window_flush); + function fl_window_handle (W : in Storage.Integer_Address; E : in Interfaces.C.int) @@ -354,11 +442,11 @@ package body FLTK.Widgets.Groups.Windows is begin return This : Window do This.Void_Ptr := new_fl_window - (Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, X, Y, W, H, Text); end return; end Create; @@ -383,9 +471,9 @@ package body FLTK.Widgets.Groups.Windows is begin return This : Window do This.Void_Ptr := new_fl_window2 - (Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.To_C (Text)); + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); end return; end Create; @@ -411,6 +499,8 @@ package body FLTK.Widgets.Groups.Windows is -- API Subprograms -- ----------------------- + -- Visibility -- + procedure Show (This : in out Window) is begin @@ -421,7 +511,7 @@ package body FLTK.Widgets.Groups.Windows is procedure Show_With_Args (This : in out Window) is begin - FLTK.Show_Argv.Dispatch (fl_window_show2'Access, This.Void_Ptr); + FLTK.Args_Marshal.Dispatch (fl_window_show2'Access, This.Void_Ptr); end Show_With_Args; @@ -469,14 +559,9 @@ package body FLTK.Widgets.Groups.Windows is end Last_Made_Current; - procedure Free_Position - (This : in out Window) is - begin - fl_window_free_position (This.Void_Ptr); - end Free_Position; - + -- Fullscreen -- function Is_Fullscreen (This : in Window) @@ -528,28 +613,77 @@ package body FLTK.Widgets.Groups.Windows is + -- Icons, Cursors -- + procedure Set_Icon (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class) is + Pic : in FLTK.Images.RGB.RGB_Image'Class) is begin fl_window_set_icon - (This.Void_Ptr, - Wrapper (Pic).Void_Ptr); + (This.Void_Ptr, + Wrapper (Pic).Void_Ptr); end Set_Icon; + procedure Set_Icons + (This : in out Window; + Pics : in FLTK.Images.RGB.RGB_Image_Array) + is + Pointers : array (Pics'First .. Pics'Last) of aliased Storage.Integer_Address; + begin + for Index in Pointers'Range loop + Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; + end loop; + fl_window_icons + (This.Void_Ptr, + (if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), + Pointers'Length); + end Set_Icons; + + + procedure Reset_Icons + (This : in out Window) is + begin + fl_window_icons (This.Void_Ptr, Null_Pointer, 0); + end Reset_Icons; + + procedure Set_Default_Icon - (Pic : in out FLTK.Images.RGB.RGB_Image'Class) is + (Pic : in FLTK.Images.RGB.RGB_Image'Class) is begin fl_window_default_icon (Wrapper (Pic).Void_Ptr); end Set_Default_Icon; + procedure Set_Default_Icons + (Pics : in FLTK.Images.RGB.RGB_Image_Array) + is + Pointers : array (Pics'First .. Pics'Last) of aliased Storage.Integer_Address; + begin + for Index in Pointers'Range loop + Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; + end loop; + fl_window_default_icons + ((if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), + Pointers'Length); + end Set_Default_Icons; + + + procedure Reset_Default_Icons is + begin + fl_window_default_icons (Null_Pointer, 0); + end Reset_Default_Icons; + + function Get_Icon_Label (This : in Window) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_window_get_iconlabel (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_window_get_iconlabel (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -578,7 +712,7 @@ package body FLTK.Widgets.Groups.Windows is procedure Set_Cursor (This : in out Window; - Pic : in out FLTK.Images.RGB.RGB_Image'Class; + Pic : in FLTK.Images.RGB.RGB_Image'Class; Hot_X, Hot_Y : in Integer) is begin fl_window_set_cursor2 @@ -599,20 +733,29 @@ package body FLTK.Widgets.Groups.Windows is - function Get_Border_State + -- Settings -- + + function Has_Border (This : in Window) - return Border_State is + return Boolean is begin - return Border_State'Val (fl_window_get_border (This.Void_Ptr)); - end Get_Border_State; + return fl_window_get_border (This.Void_Ptr) /= 0; + end Has_Border; - procedure Set_Border_State - (This : in out Window; - To : in Border_State) is + procedure Set_Border + (This : in out Window; + Value : in Boolean := True) is + begin + fl_window_set_border (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Border; + + + procedure Clear_Border + (This : in out Window) is begin - fl_window_set_border (This.Void_Ptr, Border_State'Pos (To)); - end Set_Border_State; + fl_window_clear_border (This.Void_Ptr); + end Clear_Border; function Is_Override @@ -630,6 +773,22 @@ package body FLTK.Widgets.Groups.Windows is end Set_Override; + function Is_Modal + (This : in Window) + return Boolean is + begin + return fl_window_modal (This.Void_Ptr) /= 0; + end Is_Modal; + + + function Is_Non_Modal + (This : in Window) + return Boolean is + begin + return fl_window_non_modal (This.Void_Ptr) /= 0; + end Is_Non_Modal; + + function Get_Modal_State (This : in Window) return Modal_State is @@ -644,28 +803,48 @@ package body FLTK.Widgets.Groups.Windows is end Get_Modal_State; + procedure Set_Modal + (This : in out Window) is + begin + fl_window_set_modal (This.Void_Ptr); + end Set_Modal; + + + procedure Set_Non_Modal + (This : in out Window) is + begin + fl_window_set_non_modal (This.Void_Ptr); + end Set_Non_Modal; + + procedure Set_Modal_State - (This : in out Window; - To : in Modal_State) is - begin - case To is - when Normal => - fl_window_clear_modal_states (This.Void_Ptr); - when Non_Modal => - fl_window_set_non_modal (This.Void_Ptr); - when Modal => - fl_window_set_modal (This.Void_Ptr); + (This : in out Window; + Value : in Modal_State) is + begin + case Value is + when Normal => fl_window_clear_modal_states (This.Void_Ptr); + when Non_Modal => fl_window_set_non_modal (This.Void_Ptr); + when Modal => fl_window_set_modal (This.Void_Ptr); end case; end Set_Modal_State; + procedure Clear_Modal_State + (This : in out Window) is + begin + fl_window_clear_modal_states (This.Void_Ptr); + end Clear_Modal_State; + + + + -- Labels, Hotspot, Shape -- function Get_Label (This : in Window) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_window_get_label (This.Void_Ptr); + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_window_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -680,10 +859,19 @@ package body FLTK.Widgets.Groups.Windows is (This : in out Window; Text : in String) is begin - fl_window_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + fl_window_copy_label (This.Void_Ptr, Interfaces.C.To_C (Text)); end Set_Label; + procedure Set_Labels + (This : in out Window; + Text, Icon_Text : in String) is + begin + This.Set_Label (Text); + This.Set_Icon_Label (Icon_Text); + end Set_Labels; + + procedure Hotspot (This : in out Window; X, Y : in Integer; @@ -709,6 +897,18 @@ package body FLTK.Widgets.Groups.Windows is end Hotspot; + procedure Shape + (This : in out Window; + Pic : in FLTK.Images.Image'Class) is + begin + fl_window_shape (This.Void_Ptr, Wrapper (Pic).Void_Ptr); + end Shape; + + + + + -- Dimensions -- + procedure Set_Size_Range (This : in out Window; Min_W, Min_H : in Integer; @@ -716,25 +916,50 @@ package body FLTK.Widgets.Groups.Windows is Keep_Aspect : in Boolean := False) is begin fl_window_size_range - (This.Void_Ptr, - Interfaces.C.int (Min_W), - Interfaces.C.int (Min_H), - Interfaces.C.int (Max_W), - Interfaces.C.int (Max_H), - Interfaces.C.int (Incre_W), - Interfaces.C.int (Incre_H), - Boolean'Pos (Keep_Aspect)); + (This.Void_Ptr, + Interfaces.C.int (Min_W), + Interfaces.C.int (Min_H), + Interfaces.C.int (Max_W), + Interfaces.C.int (Max_H), + Interfaces.C.int (Incre_W), + Interfaces.C.int (Incre_H), + Boolean'Pos (Keep_Aspect)); end Set_Size_Range; - procedure Shape - (This : in out Window; - Pic : in out FLTK.Images.Image'Class) is + procedure Resize + (This : in out Window; + X, Y, W, H : in Integer) is begin - fl_window_shape (This.Void_Ptr, Wrapper (Pic).Void_Ptr); - end Shape; + fl_window_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + function Is_Position_Forced + (This : in Window) + return Boolean + is + Result : constant Interfaces.C.int := fl_window_get_force_position (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Window::force_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Position_Forced; + + + procedure Force_Position + (This : in out Window; + State : in Boolean := True) is + begin + fl_window_set_force_position (This.Void_Ptr, Boolean'Pos (State)); + end Force_Position; function Get_X_Root @@ -771,6 +996,70 @@ package body FLTK.Widgets.Groups.Windows is + -- Class Info -- + + function Get_X_Class + (This : in Window) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_xclass (This.Void_Ptr); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_X_Class; + + + procedure Set_X_Class + (This : in out Window; + Value : in String) is + begin + fl_window_set_xclass (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_X_Class; + + + function Get_Default_X_Class + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_default_xclass; + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Default_X_Class; + + + procedure Set_Default_X_Class + (Value : in String) is + begin + fl_window_set_default_xclass (Interfaces.C.To_C (Value)); + end Set_Default_X_Class; + + + function Is_Menu_Window + (This : in Window) + return Boolean is + begin + return fl_window_menu_window (This.Void_Ptr) /= 0; + end Is_Menu_Window; + + + function Is_Tooltip_Window + (This : in Window) + return Boolean is + begin + return fl_window_tooltip_window (This.Void_Ptr) /= 0; + end Is_Tooltip_Window; + + + + + -- Drawing, Events -- + procedure Draw (This : in out Window) is begin @@ -778,6 +1067,13 @@ package body FLTK.Widgets.Groups.Windows is end Draw; + procedure Flush + (This : in out Window) is + begin + fl_window_flush (This.Void_Ptr); + end Flush; + + function Handle (This : in out Window; Event : in Event_Kind) |