From b4438b2fbe895694be98e6e8426103deefc51448 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 21 Jan 2025 21:04:54 +1300 Subject: Split public API and private implementation files into different directories --- body/fltk-tooltips.adb | 372 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 372 insertions(+) create mode 100644 body/fltk-tooltips.adb (limited to 'body/fltk-tooltips.adb') diff --git a/body/fltk-tooltips.adb b/body/fltk-tooltips.adb new file mode 100644 index 0000000..ccdb649 --- /dev/null +++ b/body/fltk-tooltips.adb @@ -0,0 +1,372 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int; + + +package body FLTK.Tooltips is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + function fl_tooltip_get_current + return Storage.Integer_Address; + pragma Import (C, fl_tooltip_get_current, "fl_tooltip_get_current"); + pragma Inline (fl_tooltip_get_current); + + procedure fl_tooltip_set_current + (I : in Storage.Integer_Address); + pragma Import (C, fl_tooltip_set_current, "fl_tooltip_set_current"); + pragma Inline (fl_tooltip_set_current); + + function fl_tooltip_enabled + return Interfaces.C.int; + pragma Import (C, fl_tooltip_enabled, "fl_tooltip_enabled"); + pragma Inline (fl_tooltip_enabled); + + procedure fl_tooltip_enable + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_enable, "fl_tooltip_enable"); + pragma Inline (fl_tooltip_enable); + + procedure fl_tooltip_disable; + pragma Import (C, fl_tooltip_disable, "fl_tooltip_disable"); + pragma Inline (fl_tooltip_disable); + + procedure fl_tooltip_enter_area + (I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_tooltip_enter_area, "fl_tooltip_enter_area"); + pragma Inline (fl_tooltip_enter_area); + + + + + function fl_tooltip_get_delay + return Interfaces.C.C_float; + pragma Import (C, fl_tooltip_get_delay, "fl_tooltip_get_delay"); + pragma Inline (fl_tooltip_get_delay); + + procedure fl_tooltip_set_delay + (V : in Interfaces.C.C_float); + pragma Import (C, fl_tooltip_set_delay, "fl_tooltip_set_delay"); + pragma Inline (fl_tooltip_set_delay); + + function fl_tooltip_get_hoverdelay + return Interfaces.C.C_float; + pragma Import (C, fl_tooltip_get_hoverdelay, "fl_tooltip_get_hoverdelay"); + pragma Inline (fl_tooltip_get_hoverdelay); + + procedure fl_tooltip_set_hoverdelay + (V : in Interfaces.C.C_float); + pragma Import (C, fl_tooltip_set_hoverdelay, "fl_tooltip_set_hoverdelay"); + pragma Inline (fl_tooltip_set_hoverdelay); + + + + + function fl_tooltip_get_color + return Interfaces.C.unsigned; + pragma Import (C, fl_tooltip_get_color, "fl_tooltip_get_color"); + pragma Inline (fl_tooltip_get_color); + + procedure fl_tooltip_set_color + (V : in Interfaces.C.unsigned); + pragma Import (C, fl_tooltip_set_color, "fl_tooltip_set_color"); + pragma Inline (fl_tooltip_set_color); + + function fl_tooltip_get_margin_height + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_margin_height, "fl_tooltip_get_margin_height"); + pragma Inline (fl_tooltip_get_margin_height); + + procedure fl_tooltip_set_margin_height + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_margin_height, "fl_tooltip_set_margin_height"); + pragma Inline (fl_tooltip_set_margin_height); + + function fl_tooltip_get_margin_width + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_margin_width, "fl_tooltip_get_margin_width"); + pragma Inline (fl_tooltip_get_margin_width); + + procedure fl_tooltip_set_margin_width + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_margin_width, "fl_tooltip_set_margin_width"); + pragma Inline (fl_tooltip_set_margin_width); + + function fl_tooltip_get_wrap_width + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_wrap_width, "fl_tooltip_get_wrap_width"); + pragma Inline (fl_tooltip_get_wrap_width); + + procedure fl_tooltip_set_wrap_width + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_wrap_width, "fl_tooltip_set_wrap_width"); + pragma Inline (fl_tooltip_set_wrap_width); + + + + + function fl_tooltip_get_textcolor + return Interfaces.C.unsigned; + pragma Import (C, fl_tooltip_get_textcolor, "fl_tooltip_get_textcolor"); + pragma Inline (fl_tooltip_get_textcolor); + + procedure fl_tooltip_set_textcolor + (V : in Interfaces.C.unsigned); + pragma Import (C, fl_tooltip_set_textcolor, "fl_tooltip_set_textcolor"); + pragma Inline (fl_tooltip_set_textcolor); + + function fl_tooltip_get_font + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_font, "fl_tooltip_get_font"); + pragma Inline (fl_tooltip_get_font); + + procedure fl_tooltip_set_font + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_font, "fl_tooltip_set_font"); + pragma Inline (fl_tooltip_set_font); + + function fl_tooltip_get_size + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_size, "fl_tooltip_get_size"); + pragma Inline (fl_tooltip_get_size); + + procedure fl_tooltip_set_size + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_size, "fl_tooltip_set_size"); + pragma Inline (fl_tooltip_set_size); + + + + + 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); + + package Widget_Convert is new + System.Address_To_Access_Conversions (FLTK.Widgets.Widget'Class); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + function Get_Target + return access FLTK.Widgets.Widget'Class + is + Widget_Ptr : Storage.Integer_Address := fl_tooltip_get_current; + Actual_Widget : access FLTK.Widgets.Widget'Class; + begin + if Widget_Ptr /= Null_Pointer then + Widget_Ptr := fl_widget_get_user_data (Widget_Ptr); + pragma Assert (Widget_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; + end Get_Target; + + + procedure Set_Target + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_tooltip_set_current (Wrapper (To).Void_Ptr); + end Set_Target; + + + function Is_Enabled + return Boolean is + begin + return fl_tooltip_enabled /= 0; + end Is_Enabled; + + + procedure Set_Enabled + (To : in Boolean := True) is + begin + fl_tooltip_enable (Boolean'Pos (To)); + end Set_Enabled; + + + procedure Disable is + begin + fl_tooltip_disable; + end Disable; + + + procedure Enter_Area + (Item : in FLTK.Widgets.Widget'Class; + X, Y, W, H : in Integer; + Tip : in String) is + begin + fl_tooltip_enter_area + (Wrapper (Item).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Tip)); + end Enter_Area; + + + + + function Get_Delay + return Float is + begin + return Float (fl_tooltip_get_delay); + end Get_Delay; + + + procedure Set_Delay + (To : in Float) is + begin + fl_tooltip_set_delay (Interfaces.C.C_float (To)); + end Set_Delay; + + + function Get_Hover_Delay + return Float is + begin + return Float (fl_tooltip_get_hoverdelay); + end Get_Hover_Delay; + + + procedure Set_Hover_Delay + (To : in Float) is + begin + fl_tooltip_set_hoverdelay (Interfaces.C.C_float (To)); + end Set_Hover_Delay; + + + + + function Get_Background_Color + return Color is + begin + return Color (fl_tooltip_get_color); + end Get_Background_Color; + + + procedure Set_Background_Color + (To : in Color) is + begin + fl_tooltip_set_color (Interfaces.C.unsigned (To)); + end Set_Background_Color; + + + function Get_Margin_Height + return Natural is + begin + return Natural (fl_tooltip_get_margin_height); + end Get_Margin_Height; + + + procedure Set_Margin_Height + (To : in Natural) is + begin + fl_tooltip_set_margin_height (Interfaces.C.int (To)); + end Set_Margin_Height; + + + function Get_Margin_Width + return Natural is + begin + return Natural (fl_tooltip_get_margin_width); + end Get_Margin_Width; + + + procedure Set_Margin_Width + (To : in Natural) is + begin + fl_tooltip_set_margin_width (Interfaces.C.int (To)); + end Set_Margin_Width; + + + function Get_Wrap_Width + return Natural is + begin + return Natural (fl_tooltip_get_wrap_width); + end Get_Wrap_Width; + + + procedure Set_Wrap_Width + (To : in Natural) is + begin + fl_tooltip_set_wrap_width (Interfaces.C.int (To)); + end Set_Wrap_Width; + + + + + function Get_Text_Color + return Color is + begin + return Color (fl_tooltip_get_textcolor); + end Get_Text_Color; + + + procedure Set_Text_Color + (To : in Color) is + begin + fl_tooltip_set_textcolor (Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + return Font_Kind is + begin + return Font_Kind'Val (fl_tooltip_get_font); + end Get_Text_Font; + + + procedure Set_Text_Font + (To : in Font_Kind) is + begin + fl_tooltip_set_font (Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + return Font_Size is + begin + return Font_Size (fl_tooltip_get_size); + end Get_Text_Size; + + + procedure Set_Text_Size + (To : in Font_Size) is + begin + fl_tooltip_set_size (Interfaces.C.int (To)); + end Set_Text_Size; + + +end FLTK.Tooltips; + + -- cgit