diff options
Diffstat (limited to 'src/fltk-widgets-groups-browsers.adb')
| -rw-r--r-- | src/fltk-widgets-groups-browsers.adb | 1231 |
1 files changed, 1231 insertions, 0 deletions
diff --git a/src/fltk-widgets-groups-browsers.adb b/src/fltk-widgets-groups-browsers.adb new file mode 100644 index 0000000..9c2ca3d --- /dev/null +++ b/src/fltk-widgets-groups-browsers.adb @@ -0,0 +1,1231 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings, + System.Address_To_Access_Conversions; + + +package body FLTK.Widgets.Groups.Browsers is + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_sort_ascending : constant Interfaces.C.int; + pragma Import (C, fl_sort_ascending, "fl_sort_ascending"); + + fl_sort_descending : constant Interfaces.C.int; + pragma Import (C, fl_sort_descending, "fl_sort_descending"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + function new_fl_abstract_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_abstract_browser, "new_fl_abstract_browser"); + pragma Inline (new_fl_abstract_browser); + + procedure free_fl_abstract_browser + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_abstract_browser, "free_fl_abstract_browser"); + pragma Inline (free_fl_abstract_browser); + + + + + function fl_abstract_browser_select + (B, I : in Storage.Integer_Address; + V, C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_select, "fl_abstract_browser_select"); + pragma Inline (fl_abstract_browser_select); + + function fl_abstract_browser_select_only + (B, I : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_select_only, "fl_abstract_browser_select_only"); + pragma Inline (fl_abstract_browser_select_only); + + function fl_abstract_browser_selection + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_abstract_browser_selection, "fl_abstract_browser_selection"); + pragma Inline (fl_abstract_browser_selection); + + function fl_abstract_browser_deselect + (B : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_deselect, "fl_abstract_browser_deselect"); + pragma Inline (fl_abstract_browser_deselect); + + procedure fl_abstract_browser_display + (B, I : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_display, "fl_abstract_browser_display"); + pragma Inline (fl_abstract_browser_display); + + function fl_abstract_browser_displayed + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_displayed, "fl_abstract_browser_displayed"); + pragma Inline (fl_abstract_browser_displayed); + + function fl_abstract_browser_find_item + (B : in Storage.Integer_Address; + Y : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_abstract_browser_find_item, "fl_abstract_browser_find_item"); + pragma Inline (fl_abstract_browser_find_item); + + function fl_abstract_browser_top + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_abstract_browser_top, "fl_abstract_browser_top"); + pragma Inline (fl_abstract_browser_top); + + procedure fl_abstract_browser_sort + (B : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_sort, "fl_abstract_browser_sort"); + pragma Inline (fl_abstract_browser_sort); + + + + + function fl_abstract_browser_get_has_scrollbar + (B : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_abstract_browser_get_has_scrollbar, + "fl_abstract_browser_get_has_scrollbar"); + pragma Inline (fl_abstract_browser_get_has_scrollbar); + + procedure fl_abstract_browser_set_has_scrollbar + (B : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char); + pragma Import (C, fl_abstract_browser_set_has_scrollbar, + "fl_abstract_browser_set_has_scrollbar"); + pragma Inline (fl_abstract_browser_set_has_scrollbar); + + function fl_abstract_browser_get_hposition + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_get_hposition, "fl_abstract_browser_get_hposition"); + pragma Inline (fl_abstract_browser_get_hposition); + + procedure fl_abstract_browser_set_hposition + (B : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_set_hposition, "fl_abstract_browser_set_hposition"); + pragma Inline (fl_abstract_browser_set_hposition); + + function fl_abstract_browser_get_position + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_get_position, "fl_abstract_browser_get_position"); + pragma Inline (fl_abstract_browser_get_position); + + procedure fl_abstract_browser_set_position + (B : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_set_position, "fl_abstract_browser_set_position"); + pragma Inline (fl_abstract_browser_set_position); + + procedure fl_abstract_browser_scrollbar_left + (B : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_scrollbar_left, "fl_abstract_browser_scrollbar_left"); + pragma Inline (fl_abstract_browser_scrollbar_left); + + procedure fl_abstract_browser_scrollbar_right + (B : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_scrollbar_right, "fl_abstract_browser_scrollbar_right"); + pragma Inline (fl_abstract_browser_scrollbar_right); + + function fl_abstract_browser_get_scrollbar_size + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_get_scrollbar_size, + "fl_abstract_browser_get_scrollbar_size"); + pragma Inline (fl_abstract_browser_get_scrollbar_size); + + procedure fl_abstract_browser_set_scrollbar_size + (B : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_set_scrollbar_size, + "fl_abstract_browser_set_scrollbar_size"); + pragma Inline (fl_abstract_browser_set_scrollbar_size); + + + + + function fl_abstract_browser_get_textcolor + (B : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_abstract_browser_get_textcolor, "fl_abstract_browser_get_textcolor"); + pragma Inline (fl_abstract_browser_get_textcolor); + + procedure fl_abstract_browser_set_textcolor + (B : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_abstract_browser_set_textcolor, "fl_abstract_browser_set_textcolor"); + pragma Inline (fl_abstract_browser_set_textcolor); + + function fl_abstract_browser_get_textfont + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_get_textfont, "fl_abstract_browser_get_textfont"); + pragma Inline (fl_abstract_browser_get_textfont); + + procedure fl_abstract_browser_set_textfont + (B : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_set_textfont, "fl_abstract_browser_set_textfont"); + pragma Inline (fl_abstract_browser_set_textfont); + + function fl_abstract_browser_get_textsize + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_get_textsize, "fl_abstract_browser_get_textsize"); + pragma Inline (fl_abstract_browser_get_textsize); + + procedure fl_abstract_browser_set_textsize + (B : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_set_textsize, "fl_abstract_browser_set_textsize"); + pragma Inline (fl_abstract_browser_set_textsize); + + + + + procedure fl_abstract_browser_resize + (B : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_abstract_browser_resize, "fl_abstract_browser_resize"); + pragma Inline (fl_abstract_browser_resize); + + procedure fl_abstract_browser_bbox + (B : in Storage.Integer_Address; + X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_abstract_browser_bbox, "fl_abstract_browser_bbox"); + pragma Inline (fl_abstract_browser_bbox); + + function fl_abstract_browser_leftedge + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_leftedge, "fl_abstract_browser_leftedge"); + pragma Inline (fl_abstract_browser_leftedge); + + procedure fl_abstract_browser_redraw_line + (B, I : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_redraw_line, "fl_abstract_browser_redraw_line"); + pragma Inline (fl_abstract_browser_redraw_line); + + procedure fl_abstract_browser_redraw_lines + (B : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_redraw_lines, "fl_abstract_browser_redraw_lines"); + pragma Inline (fl_abstract_browser_redraw_lines); + + + + + function fl_abstract_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_full_width, "fl_abstract_browser_full_width"); + pragma Inline (fl_abstract_browser_full_width); + + function fl_abstract_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_full_height, "fl_abstract_browser_full_height"); + pragma Inline (fl_abstract_browser_full_height); + + function fl_abstract_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_incr_height, "fl_abstract_browser_incr_height"); + pragma Inline (fl_abstract_browser_incr_height); + + function fl_abstract_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_item_quick_height, + "fl_abstract_browser_item_quick_height"); + pragma Inline (fl_abstract_browser_item_quick_height); + + + + + procedure fl_abstract_browser_new_list + (B : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_new_list, "fl_abstract_browser_new_list"); + pragma Inline (fl_abstract_browser_new_list); + + procedure fl_abstract_browser_inserting + (B, A1, A2 : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_inserting, "fl_abstract_browser_inserting"); + pragma Inline (fl_abstract_browser_inserting); + + procedure fl_abstract_browser_deleting + (B, I : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_deleting, "fl_abstract_browser_deleting"); + pragma Inline (fl_abstract_browser_deleting); + + procedure fl_abstract_browser_replacing + (B, A1, A2 : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_replacing, "fl_abstract_browser_replacing"); + pragma Inline (fl_abstract_browser_replacing); + + procedure fl_abstract_browser_swapping + (B, A1, A2 : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_swapping, "fl_abstract_browser_swapping"); + pragma Inline (fl_abstract_browser_swapping); + + + + + procedure fl_abstract_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_abstract_browser_draw, "fl_abstract_browser_draw"); + pragma Inline (fl_abstract_browser_draw); + + function fl_abstract_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_abstract_browser_handle, "fl_abstract_browser_handle"); + pragma Inline (fl_abstract_browser_handle); + + + + + ---------------------- + -- Exported Hooks -- + ---------------------- + + package Browser_Convert is new System.Address_To_Access_Conversions (Abstract_Browser'Class); + + + function Full_Width_Hook + (Ada_Addr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Full_Width_Hook, "browser_full_width_hook"); + + function Full_Width_Hook + (Ada_Addr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Interfaces.C.int (Ada_Object.Full_List_Width); + end Full_Width_Hook; + + + function Full_Height_Hook + (Ada_Addr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Full_Height_Hook, "browser_full_height_hook"); + + function Full_Height_Hook + (Ada_Addr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Interfaces.C.int (Ada_Object.Full_List_Height); + end Full_Height_Hook; + + + function Average_Item_Height_Hook + (Ada_Addr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Average_Item_Height_Hook, "browser_incr_height_hook"); + + function Average_Item_Height_Hook + (Ada_Addr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Interfaces.C.int (Ada_Object.Average_Item_Height); + end Average_Item_Height_Hook; + + + function Item_Quick_Height_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Item_Quick_Height_Hook, "browser_item_quick_height_hook"); + + function Item_Quick_Height_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Interfaces.C.int (Ada_Object.Item_Quick_Height (Address_To_Cursor (Item_Ptr))); + end Item_Quick_Height_Hook; + + + function Item_Width_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Item_Width_Hook, "browser_item_width_hook"); + + function Item_Width_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Interfaces.C.int (Ada_Object.Item_Width (Address_To_Cursor (Item_Ptr))); + end Item_Width_Hook; + + + function Item_Height_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Item_Height_Hook, "browser_item_height_hook"); + + function Item_Height_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Interfaces.C.int (Ada_Object.Item_Height (Address_To_Cursor (Item_Ptr))); + end Item_Height_Hook; + + + function Item_First_Hook + (Ada_Addr : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Export (C, Item_First_Hook, "browser_item_first_hook"); + + function Item_First_Hook + (Ada_Addr : in Storage.Integer_Address) + return Storage.Integer_Address + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Cursor_To_Address (Ada_Object.Item_First); + end Item_First_Hook; + + + function Item_Last_Hook + (Ada_Addr : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Export (C, Item_Last_Hook, "browser_item_last_hook"); + + function Item_Last_Hook + (Ada_Addr : in Storage.Integer_Address) + return Storage.Integer_Address + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Cursor_To_Address (Ada_Object.Item_Last); + end Item_Last_Hook; + + + function Item_Next_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Export (C, Item_Next_Hook, "browser_item_next_hook"); + + function Item_Next_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Storage.Integer_Address + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Cursor_To_Address (Ada_Object.Item_Next (Address_To_Cursor (Item_Ptr))); + end Item_Next_Hook; + + + function Item_Previous_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Export (C, Item_Previous_Hook, "browser_item_prev_hook"); + + function Item_Previous_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Storage.Integer_Address + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Cursor_To_Address (Ada_Object.Item_Previous (Address_To_Cursor (Item_Ptr))); + end Item_Previous_Hook; + + + function Item_At_Hook + (Ada_Addr : in Storage.Integer_Address; + Index : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Export (C, Item_At_Hook, "browser_item_at_hook"); + + function Item_At_Hook + (Ada_Addr : in Storage.Integer_Address; + Index : in Interfaces.C.int) + return Storage.Integer_Address + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + use type Interfaces.C.int; + begin + return Cursor_To_Address (Ada_Object.Item_At (Positive (Index + 1))); + end Item_At_Hook; + + + procedure Item_Select_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address; + Int_State : in Interfaces.C.int); + pragma Export (C, Item_Select_Hook, "browser_item_select_hook"); + + procedure Item_Select_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address; + Int_State : in Interfaces.C.int) + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + use type Interfaces.C.int; + begin + Ada_Object.Item_Select + (Address_To_Cursor (Item_Ptr), + Int_State /= 0); + end Item_Select_Hook; + + + function Item_Selected_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Export (C, Item_Selected_Hook, "browser_item_selected_hook"); + + function Item_Selected_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + return Boolean'Pos (Ada_Object.Item_Selected (Address_To_Cursor (Item_Ptr))); + end Item_Selected_Hook; + + + procedure Item_Swap_Hook + (Ada_Addr, A_Ptr, B_Ptr : in Storage.Integer_Address); + pragma Export (C, Item_Swap_Hook, "browser_item_swap_hook"); + + procedure Item_Swap_Hook + (Ada_Addr, A_Ptr, B_Ptr : in Storage.Integer_Address) + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + Ada_Object.Item_Swap (Address_To_Cursor (A_Ptr), Address_To_Cursor (B_Ptr)); + end Item_Swap_Hook; + + + -- The following is a hack due to inherent incompatibilities between Ada Strings + -- and C char pointers. The hook will convert Strings to char* and return them + -- fine for the first two calls, but after that it will deallocate the oldest + -- char* it previously returned to make room for more. Fortunately, this hook + -- is only used by the FLTK C++ side of things for comparing two strings for the + -- purposes of sorting items so it all works out in the end. + + -- Calls by the Ada programmer to Item_Text will be completely unaffected, but + -- this does mean that the default implementation of Sort is not task safe. + + -- At the time of writing this I have no idea how task safe FLTK is anyway. + + Text_Hook_Storage : Interfaces.C.Strings.chars_ptr_array (1 .. 2); + Current_Text_Store : Interfaces.C.size_t := 1; + + function Item_Text_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Export (C, Item_Text_Hook, "browser_item_text_hook"); + + function Item_Text_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + Interfaces.C.Strings.Free (Text_Hook_Storage (Current_Text_Store)); + Text_Hook_Storage (Current_Text_Store) := Interfaces.C.Strings.New_String + (Ada_Object.Item_Text (Address_To_Cursor (Item_Ptr))); + return C_Char_Is_Not_A_String : Interfaces.C.Strings.chars_ptr := + Text_Hook_Storage (Current_Text_Store) + do + Current_Text_Store := Current_Text_Store + 1; + if Current_Text_Store > Text_Hook_Storage'Last then + Current_Text_Store := Text_Hook_Storage'First; + end if; + end return; + end Item_Text_Hook; + + + procedure Item_Draw_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Export (C, Item_Draw_Hook, "browser_item_draw_hook"); + + procedure Item_Draw_Hook + (Ada_Addr, Item_Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int) + is + Ada_Object : access Abstract_Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + Ada_Object.Item_Draw + (Address_To_Cursor (Item_Ptr), + Integer (X), + Integer (Y), + Integer (W), + Integer (H)); + end Item_Draw_Hook; + + + + + ----------------------------------- + -- Controlled Type Subprograms -- + ----------------------------------- + + procedure Finalize + (This : in out Abstract_Browser) is + begin + if This.Void_Ptr /= Null_Pointer and then + This in Abstract_Browser'Class + then + This.Clear; + free_fl_abstract_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + Finalize (Group (This)); + end Finalize; + + + procedure Finalize + (This : in out Item_Text_Hook_Final_Controller) is + begin + for Index in Text_Hook_Storage'Range loop + Interfaces.C.Strings.Free (Text_Hook_Storage (Index)); + end loop; + end Finalize; + + + + + --------------------------- + -- Abstract Browser API -- + --------------------------- + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Abstract_Browser is + begin + return This : Abstract_Browser do + This.Void_Ptr := new_fl_abstract_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + fl_widget_set_user_data + (This.Void_Ptr, + Storage.To_Integer (Widget_Convert.To_Address (This'Unchecked_Access))); + + Wrapper (This.Horizon).Void_Ptr := fl_abstract_browser_hscrollbar (This.Void_Ptr); + Wrapper (This.Horizon).Needs_Dealloc := False; + fl_widget_set_user_data + (Wrapper (This.Horizon).Void_Ptr, + Storage.To_Integer (Widget_Convert.To_Address (This.Horizon'Unchecked_Access))); + + Wrapper (This.Vertigo).Void_Ptr := fl_abstract_browser_scrollbar (This.Void_Ptr); + Wrapper (This.Vertigo).Needs_Dealloc := False; + fl_widget_set_user_data + (Wrapper (This.Vertigo).Void_Ptr, + Storage.To_Integer (Widget_Convert.To_Address (This.Vertigo'Unchecked_Access))); + + fl_widget_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end return; + end Create; + + end Forge; + + + + + -- Access to the Browser's self contained scrollbars + + function H_Bar + (This : in out Abstract_Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Horizon'Unchecked_Access); + end H_Bar; + + + function V_Bar + (This : in out Abstract_Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Vertigo'Unchecked_Access); + end V_Bar; + + + + + -- Item related settings + + function Set_Select + (This : in out Abstract_Browser; + Item : in Item_Cursor; + State : in Boolean := True; + Do_Callbacks : in Boolean := False) + return Boolean + is + Code : Interfaces.C.int := fl_abstract_browser_select + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (State), + Boolean'Pos (Do_Callbacks)); + begin + if Code not in 0 .. 1 then + raise Program_Error; + end if; + return Boolean'Val (Code); + end Set_Select; + + + function Select_Only + (This : in out Abstract_Browser; + Item : in Item_Cursor; + Do_Callbacks : in Boolean := False) + return Boolean + is + Code : Interfaces.C.int := fl_abstract_browser_select_only + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (Do_Callbacks)); + begin + if Code not in 0 .. 1 then + raise Program_Error; + end if; + return Boolean'Val (Code); + end Select_Only; + + + function Current_Selection + (This : in Abstract_Browser) + return Item_Cursor is + begin + return Address_To_Cursor (fl_abstract_browser_selection (This.Void_Ptr)); + end Current_Selection; + + + function Deselect + (This : in out Abstract_Browser; + Do_Callbacks : in Boolean := False) + return Boolean + is + Code : Interfaces.C.int := fl_abstract_browser_deselect + (This.Void_Ptr, + Boolean'Pos (Do_Callbacks)); + begin + if Code not in 0 .. 1 then + raise Program_Error; + end if; + return Boolean'Val (Code); + end Deselect; + + + procedure Display + (This : in out Abstract_Browser; + Item : in Item_Cursor) is + begin + fl_abstract_browser_display (This.Void_Ptr, Cursor_To_Address (Item)); + end Display; + + + function Is_Displayed + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Boolean + is + Code : Interfaces.C.int := fl_abstract_browser_displayed + (This.Void_Ptr, + Cursor_To_Address (Item)); + begin + if Code not in 0 .. 1 then + raise Program_Error; + end if; + return Boolean'Val (Code); + end Is_Displayed; + + + function Find_Item + (This : in Abstract_Browser; + Y_Pos : in Integer) + return Item_Cursor is + begin + return Address_To_Cursor + (fl_abstract_browser_find_item (This.Void_Ptr, Interfaces.C.int (Y_Pos))); + end Find_Item; + + + function Top_Item + (This : in Abstract_Browser) + return Item_Cursor is + begin + return Address_To_Cursor (fl_abstract_browser_top (This.Void_Ptr)); + end Top_Item; + + + procedure Sort + (This : in out Abstract_Browser; + Order : in Sort_Order) + is + Code : Interfaces.C.int := + (case Order is + when Ascending => fl_sort_ascending, + when Descending => fl_sort_descending); + begin + fl_abstract_browser_sort (This.Void_Ptr, Code); + end Sort; + + + + + -- Scrollbar related settings + + function Get_Scrollbar_Mode + (This : in Abstract_Browser) + return Scrollbar_Mode is + begin + return Uchar_To_Mode (fl_abstract_browser_get_has_scrollbar (This.Void_Ptr)); + end Get_Scrollbar_Mode; + + + procedure Set_Scrollbar_Mode + (This : in out Abstract_Browser; + Mode : in Scrollbar_Mode) is + begin + fl_abstract_browser_set_has_scrollbar (This.Void_Ptr, Mode_To_Uchar (Mode)); + end Set_Scrollbar_Mode; + + + function Get_H_Position + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_get_hposition (This.Void_Ptr)); + end Get_H_Position; + + + procedure Set_H_Position + (This : in out Abstract_Browser; + Value : in Integer) is + begin + fl_abstract_browser_set_hposition + (This.Void_Ptr, + Interfaces.C.int (Value)); + end Set_H_Position; + + + function Get_V_Position + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_get_position (This.Void_Ptr)); + end Get_V_Position; + + + procedure Set_V_Position + (This : in out Abstract_Browser; + Value : in Integer) is + begin + fl_abstract_browser_set_position + (This.Void_Ptr, + Interfaces.C.int (Value)); + end Set_V_Position; + + + procedure Set_Vertical_Left + (This : in out Abstract_Browser) is + begin + fl_abstract_browser_scrollbar_left (This.Void_Ptr); + end Set_Vertical_Left; + + + procedure Set_Vertical_Right + (This : in out Abstract_Browser) is + begin + fl_abstract_browser_scrollbar_right (This.Void_Ptr); + end Set_Vertical_Right; + + + function Get_Scrollbar_Size + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_get_scrollbar_size (This.Void_Ptr)); + end Get_Scrollbar_Size; + + + procedure Set_Scrollbar_Size + (This : in out Abstract_Browser; + Value : in Integer) is + begin + fl_abstract_browser_set_scrollbar_size + (This.Void_Ptr, + Interfaces.C.int (Value)); + end Set_Scrollbar_Size; + + + + + -- Text related settings + + function Get_Text_Color + (This : in Abstract_Browser) + return Color is + begin + return Color (fl_abstract_browser_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Abstract_Browser; + Value : in Color) is + begin + fl_abstract_browser_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Abstract_Browser) + return Font_Kind is + begin + return Font_Kind'Val (fl_abstract_browser_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Abstract_Browser; + Font : in Font_Kind) is + begin + fl_abstract_browser_set_textfont (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Abstract_Browser) + return Font_Size is + begin + return Font_Size (fl_abstract_browser_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Abstract_Browser; + Size : in Font_Size) is + begin + fl_abstract_browser_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Graphical dimensions and redrawing + + procedure Resize + (This : in out Abstract_Browser; + X, Y, W, H : in Integer) is + begin + fl_abstract_browser_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Bounding_Box + (This : in Abstract_Browser; + X, Y, W, H : out Integer) is + begin + fl_abstract_browser_bbox + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Bounding_Box; + + + function Left_Edge + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_leftedge (This.Void_Ptr)); + end Left_Edge; + + + procedure Redraw_Line + (This : in out Abstract_Browser; + Item : in Item_Cursor) is + begin + fl_abstract_browser_redraw_line (This.Void_Ptr, Cursor_To_Address (Item)); + end Redraw_Line; + + + procedure Redraw_List + (This : in out Abstract_Browser) is + begin + fl_abstract_browser_redraw_lines (This.Void_Ptr); + end Redraw_List; + + + + + -- Optional Override API + + function Full_List_Width + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_full_width (This.Void_Ptr)); + end Full_List_Width; + + + function Full_List_Height + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_full_height (This.Void_Ptr)); + end Full_List_Height; + + + function Average_Item_Height + (This : in Abstract_Browser) + return Integer is + begin + return Integer (fl_abstract_browser_incr_height (This.Void_Ptr)); + end Average_Item_Height; + + + function Item_Quick_Height + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Integer is + begin + return Integer (fl_abstract_browser_item_quick_height + (This.Void_Ptr, + Cursor_To_Address (Item))); + end Item_Quick_Height; + + + + + -- Mandatory Override API + + function Item_Width + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Integer is + begin + return raise Program_Error with "Abstract_Browser Item_Width must be overridden"; + end Item_Width; + + function Item_Height + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Integer is + begin + return raise Program_Error with "Abstract_Browser Item_Height must be overridden"; + end Item_Height; + + function Item_First + (This : in Abstract_Browser) + return Item_Cursor is + begin + return raise Program_Error with "Abstract_Browser Item_First must be overridden"; + end Item_First; + + function Item_Last + (This : in Abstract_Browser) + return Item_Cursor is + begin + return raise Program_Error with "Abstract_Browser Item_Last must be overridden"; + end Item_Last; + + function Item_Next + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Item_Cursor is + begin + return raise Program_Error with "Abstract_Browser Item_Next must be overridden"; + end Item_Next; + + function Item_Previous + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Item_Cursor is + begin + return raise Program_Error with "Abstract_Browser Item_Previous must be overridden"; + end Item_Previous; + + function Item_At + (This : in Abstract_Browser; + Index : in Positive) + return Item_Cursor is + begin + return raise Program_Error with "Abstract_Browser Item_At must be overridden"; + end Item_At; + + procedure Item_Select + (This : in out Abstract_Browser; + Item : in Item_Cursor; + State : in Boolean := True) is + begin + raise Program_Error with "Abstract_Browser Item_Select must be overridden"; + end Item_Select; + + function Item_Selected + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Boolean is + begin + return raise Program_Error with "Abstract_Browser Item_Selected must be overridden"; + end Item_Selected; + + procedure Item_Swap + (This : in out Abstract_Browser; + A, B : in Item_Cursor) is + begin + raise Program_Error with "Abstract_Browser Item_Swap must be overridden"; + end Item_Swap; + + function Item_Text + (This : in Abstract_Browser; + Item : in Item_Cursor) + return String is + begin + return raise Program_Error with "Abstract_Browser Item_Text must be overridden"; + end Item_Text; + + procedure Item_Draw + (This : in Abstract_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer) is + begin + raise Program_Error with "Abstract_Browser Item_Draw must be overridden"; + end Item_Draw; + + + + + -- Cache invalidation + + procedure New_List + (This : in out Abstract_Browser) is + begin + fl_abstract_browser_new_list (This.Void_Ptr); + end New_List; + + + procedure Inserting + (This : in out Abstract_Browser; + A, B : in Item_Cursor) is + begin + fl_abstract_browser_inserting + (This.Void_Ptr, + Cursor_To_Address (A), + Cursor_To_Address (B)); + end Inserting; + + + procedure Deleting + (This : in out Abstract_Browser; + Item : in Item_Cursor) is + begin + fl_abstract_browser_deleting + (This.Void_Ptr, + Cursor_To_Address (Item)); + end Deleting; + + + procedure Replacing + (This : in out Abstract_Browser; + A, B : in Item_Cursor) is + begin + fl_abstract_browser_replacing + (This.Void_Ptr, + Cursor_To_Address (A), + Cursor_To_Address (B)); + end Replacing; + + + procedure Swapping + (This : in out Abstract_Browser; + A, B : in Item_Cursor) is + begin + fl_abstract_browser_swapping + (This.Void_Ptr, + Cursor_To_Address (A), + Cursor_To_Address (B)); + end Swapping; + + + + + -- Standard Override API + + procedure Draw + (This : in out Abstract_Browser) is + begin + fl_abstract_browser_draw (This.Void_Ptr); + end Draw; + + + function Handle + (This : in out Abstract_Browser; + Event : in Event_Kind) + return Event_Outcome is + begin + return Event_Outcome'Val + (fl_abstract_browser_handle (This.Void_Ptr, Event_Kind'Pos (Event))); + end Handle; + + +end FLTK.Widgets.Groups.Browsers; + + |