-- 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;