diff options
Diffstat (limited to 'body/fltk-widgets-groups-scrolls.adb')
| -rw-r--r-- | body/fltk-widgets-groups-scrolls.adb | 191 |
1 files changed, 155 insertions, 36 deletions
diff --git a/body/fltk-widgets-groups-scrolls.adb b/body/fltk-widgets-groups-scrolls.adb index fa1b03e..65498a6 100644 --- a/body/fltk-widgets-groups-scrolls.adb +++ b/body/fltk-widgets-groups-scrolls.adb @@ -6,20 +6,29 @@ with + Ada.Characters.Latin_1, Interfaces.C.Strings; use type + Interfaces.C.int, Interfaces.C.unsigned_char; package body FLTK.Widgets.Groups.Scrolls is + package Latin renames Ada.Characters.Latin_1; + + + + ------------------------ -- Functions From C -- ------------------------ + -- Allocation -- + function new_fl_scroll (X, Y, W, H : in Interfaces.C.int; Text : in Interfaces.C.char_array) @@ -35,6 +44,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Attributes -- + function fl_scroll_hscrollbar (S : in Storage.Integer_Address) return Storage.Integer_Address; @@ -50,6 +61,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrolling -- + procedure fl_scroll_to (S : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -71,6 +84,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrollbar Settings -- + function fl_scroll_get_size (S : in Storage.Integer_Address) return Interfaces.C.int; @@ -86,6 +101,39 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Dimensions -- + + procedure fl_scroll_resize + (S : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_scroll_resize, "fl_scroll_resize"); + pragma Inline (fl_scroll_resize); + + procedure fl_scroll_recalc_scrollbars + (Addr : in Storage.Integer_Address; + CB_X, CB_Y, CB_W, CB_H : out Interfaces.C.int; + IB_X, IB_Y, IB_W, IB_H : out Interfaces.C.int; + IC_X, IC_Y, IC_W, IC_H : out Interfaces.C.int; + CH_Need, CV_Need : out Interfaces.C.int; + HS_X, HS_Y, HS_W, HS_H : out Interfaces.C.int; + HS_Size, HS_Total, HS_First, HS_Pos : out Interfaces.C.int; + VS_X, VS_Y, VS_W, VS_H : out Interfaces.C.int; + VS_Size, VS_Total, VS_First, VS_Pos : out Interfaces.C.int; + SSize : out Interfaces.C.int); + pragma Import (C, fl_scroll_recalc_scrollbars, "fl_scroll_recalc_scrollbars"); + pragma Inline (fl_scroll_recalc_scrollbars); + + + + + -- Drawing, Events -- + + procedure fl_scroll_bbox + (S : in Storage.Integer_Address; + X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_scroll_bbox, "fl_scroll_bbox"); + pragma Inline (fl_scroll_bbox); + procedure fl_scroll_draw (S : in Storage.Integer_Address); pragma Import (C, fl_scroll_draw, "fl_scroll_draw"); @@ -105,34 +153,9 @@ package body FLTK.Widgets.Groups.Scrolls is -- Destructors -- ------------------- - -- I used the FFI to bypass namespace rules and all I got was this lousy tshirt - procedure scroll_extra_final_hook - (Ada_Obj : in Storage.Integer_Address); - pragma Export (C, scroll_extra_final_hook, "scroll_extra_final_hook"); - - procedure scroll_extra_final_hook - (Ada_Obj : in Storage.Integer_Address) - is - My_Scroll : Scroll; - for My_Scroll'Address use Storage.To_Address (Ada_Obj); - pragma Import (Ada, My_Scroll); - begin - Extra_Final (My_Scroll); - end scroll_extra_final_hook; - - - -- It's the only way to be sure - procedure fl_scrollbar_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_scrollbar_extra_final, "fl_scrollbar_extra_final"); - pragma Inline (fl_scrollbar_extra_final); - - procedure Extra_Final (This : in out Scroll) is begin - fl_scrollbar_extra_final (Storage.To_Integer (This.Horizon'Address)); - fl_scrollbar_extra_final (Storage.To_Integer (This.Vertigo'Address)); Extra_Final (Group (This)); end Extra_Final; @@ -231,11 +254,11 @@ package body FLTK.Widgets.Groups.Scrolls is begin return This : Scroll do This.Void_Ptr := new_fl_scroll - (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; @@ -257,9 +280,11 @@ package body FLTK.Widgets.Groups.Scrolls is - ------------------ + ----------------------- + -- API Subprograms -- + ----------------------- + -- Attributes -- - ------------------ function H_Bar (This : in out Scroll) @@ -279,9 +304,7 @@ package body FLTK.Widgets.Groups.Scrolls is - ----------------------- - -- API Subprograms -- - ----------------------- + -- Contents -- procedure Clear (This : in out Scroll) is @@ -299,6 +322,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrolling -- + procedure Scroll_To (This : in out Scroll; X, Y : in Integer) is @@ -325,6 +350,8 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Scrollbar Settings -- + function Get_Scrollbar_Size (This : in Scroll) return Integer is @@ -345,7 +372,7 @@ package body FLTK.Widgets.Groups.Scrolls is (This : in Scroll) return Scroll_Kind is - Result : Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); begin return Scroll_Kind'Val (Result - 1); exception @@ -365,6 +392,98 @@ package body FLTK.Widgets.Groups.Scrolls is + -- Dimensions -- + + procedure Resize + (This : in out Scroll; + X, Y, W, H : in Integer) is + begin + fl_scroll_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Recalculate_Scrollbars + (This : in Scroll; + Data : out Scroll_Info) + is + C_Scroll_Size, + C_H_Need, C_V_Need, + C_H_Data_Size, C_V_Data_Size, + C_H_Data_Total, C_V_Data_Total : Interfaces.C.int; + begin + fl_scroll_recalc_scrollbars + (This.Void_Ptr, + + -- child LRTB region that will be reworked into XYWH in C++ + Interfaces.C.int (Data.Child_Box.X), Interfaces.C.int (Data.Child_Box.Y), + Interfaces.C.int (Data.Child_Box.W), Interfaces.C.int (Data.Child_Box.H), + + -- innerbox XYWH region + Interfaces.C.int (Data.Inner_Ex.X), Interfaces.C.int (Data.Inner_Ex.Y), + Interfaces.C.int (Data.Inner_Ex.W), Interfaces.C.int (Data.Inner_Ex.H), + + -- innerchild XYWH region + Interfaces.C.int (Data.Inner_Inc.X), Interfaces.C.int (Data.Inner_Inc.Y), + Interfaces.C.int (Data.Inner_Inc.W), Interfaces.C.int (Data.Inner_Inc.H), + + -- raw hneeded/vneeded values to be converted into Booleans + C_H_Need, C_V_Need, + + -- hscroll data + Interfaces.C.int (Data.H_Data.X), Interfaces.C.int (Data.H_Data.Y), + Interfaces.C.int (Data.H_Data.W), Interfaces.C.int (Data.H_Data.H), + C_H_Data_Size, C_H_Data_Total, + Interfaces.C.int (Data.H_Data.First), Interfaces.C.int (Data.H_Data.Position), + + -- vscroll data + Interfaces.C.int (Data.V_Data.X), Interfaces.C.int (Data.V_Data.Y), + Interfaces.C.int (Data.V_Data.W), Interfaces.C.int (Data.V_Data.H), + C_V_Data_Size, C_V_Data_Total, + Interfaces.C.int (Data.V_Data.First), Interfaces.C.int (Data.V_Data.Position), + + -- scrollsize + C_Scroll_Size); + + Data.H_Needed := C_H_Need /= 0; + Data.V_Needed := C_V_Need /= 0; + Data.H_Data.Size := Natural (C_H_Data_Size); + Data.H_Data.Total := Natural (C_H_Data_Total); + Data.V_Data.Size := Natural (C_V_Data_Size); + Data.V_Data.Total := Natural (C_V_Data_Total); + Data.Scroll_Size := Natural (C_Scroll_Size); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Scroll::recalc_scrollbars returned unexpected int values of " & Latin.LF & + Latin.HT & "hscroll.size = " & Interfaces.C.int'Image (C_H_Data_Size) & Latin.LF & + Latin.HT & "hscroll.total = " & Interfaces.C.int'Image (C_H_Data_Total) & Latin.LF & + Latin.HT & "vscroll.size = " & Interfaces.C.int'Image (C_V_Data_Size) & Latin.LF & + Latin.HT & "vscroll.total = " & Interfaces.C.int'Image (C_V_Data_Total) & Latin.LF & + Latin.HT & "scrollsize = " & Interfaces.C.int'Image (C_Scroll_Size); + end Recalculate_Scrollbars; + + + + + -- Drawing, Events -- + + procedure Bounding_Box + (This : in Scroll; + X, Y, W, H : out Integer) is + begin + fl_scroll_bbox + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Bounding_Box; + + procedure Draw (This : in out Scroll) is begin |