diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/c_fl_browser_.cpp | 385 | ||||
| -rw-r--r-- | src/c_fl_browser_.h | 83 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-browsers.adb | 1231 | ||||
| -rw-r--r-- | src/fltk-widgets-groups-browsers.ads | 447 | ||||
| -rw-r--r-- | src/fltk-widgets.ads | 6 |
5 files changed, 2149 insertions, 3 deletions
diff --git a/src/c_fl_browser_.cpp b/src/c_fl_browser_.cpp new file mode 100644 index 0000000..9d8678f --- /dev/null +++ b/src/c_fl_browser_.cpp @@ -0,0 +1,385 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Browser_.H> +#include "c_fl_browser_.h" + + + + +const int fl_sort_ascending = FL_SORT_ASCENDING; +const int fl_sort_descending = FL_SORT_DESCENDING; + + + + +// Exports from Ada + +extern "C" int browser_full_width_hook(void * b); +extern "C" int browser_full_height_hook(void * b); +extern "C" int browser_incr_height_hook(void * b); +extern "C" int browser_item_quick_height_hook(void * b, void * i); + +extern "C" int browser_item_width_hook(void * b, void * i); +extern "C" int browser_item_height_hook(void * b, void * i); +extern "C" void * browser_item_first_hook(void * b); +extern "C" void * browser_item_last_hook(void * b); +extern "C" void * browser_item_next_hook(void * b, void * i); +extern "C" void * browser_item_prev_hook(void * b, void * i); +extern "C" void * browser_item_at_hook(void * b, int n); +extern "C" void browser_item_select_hook(void * b, void * i, int s); +extern "C" int browser_item_selected_hook(void * b, void * i); +extern "C" void browser_item_swap_hook(void * b, void * one, void * two); +extern "C" const char * browser_item_text_hook(void * b, void * i); +extern "C" void browser_item_draw_hook(void * b, void * i, int x, int y, int w, int h); + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Attaching all relevant hooks and friends + +class My_Browser_ : public Fl_Browser_ { +public: + using Fl_Browser_::Fl_Browser_; + + friend ABSTRACTBROWSER new_fl_abstract_browser(int x, int y, int w, int h, char * label); + + friend void * fl_abstract_browser_selection(ABSTRACTBROWSER b); + friend int fl_abstract_browser_displayed(ABSTRACTBROWSER b, void * i); + friend void * fl_abstract_browser_find_item(ABSTRACTBROWSER b, int y); + friend void * fl_abstract_browser_top(ABSTRACTBROWSER b); + + friend void fl_abstract_browser_bbox(ABSTRACTBROWSER b, int &x, int &y, int &w, int &h); + friend int fl_abstract_browser_leftedge(ABSTRACTBROWSER b); + friend void fl_abstract_browser_redraw_line(ABSTRACTBROWSER b, void * i); + friend void fl_abstract_browser_redraw_lines(ABSTRACTBROWSER b); + + friend int fl_abstract_browser_full_width(ABSTRACTBROWSER b); + friend int fl_abstract_browser_full_height(ABSTRACTBROWSER b); + friend int fl_abstract_browser_incr_height(ABSTRACTBROWSER b); + friend int fl_abstract_browser_item_quick_height(ABSTRACTBROWSER b, void * i); + + friend void fl_abstract_browser_new_list(ABSTRACTBROWSER b); + friend void fl_abstract_browser_inserting(ABSTRACTBROWSER b, void * a1, void * a2); + friend void fl_abstract_browser_deleting(ABSTRACTBROWSER b, void * item); + friend void fl_abstract_browser_replacing(ABSTRACTBROWSER b, void * a1, void * a2); + friend void fl_abstract_browser_swapping(ABSTRACTBROWSER b, void * a1, void * a2); + + friend void fl_abstract_browser_draw(ABSTRACTBROWSER b); + friend int fl_abstract_browser_handle(ABSTRACTBROWSER b, int e); + +protected: + int full_width() const; + int full_height() const; + int incr_height() const; + int item_quick_height(void * item) const; + + int item_width(void * item) const; + int item_height(void * item) const; + void * item_first() const; + void * item_last() const; + void * item_next(void * item) const; + void * item_prev(void * item) const; + void * item_at(int index) const; + void item_select(void * item, int val=1); + int item_selected(void * item) const; + void item_swap(void * a, void * b); + const char * item_text(void * item) const; + void item_draw(void * item, int x, int y, int w, int h) const; + + void draw(); + int handle(int e); +}; + + +int My_Browser_::full_width() const { + return browser_full_width_hook(this->user_data()); +} + +int My_Browser_::full_height() const { + return browser_full_height_hook(this->user_data()); +} + +int My_Browser_::incr_height() const { + return browser_incr_height_hook(this->user_data()); +} + +int My_Browser_::item_quick_height(void * item) const { + return browser_item_quick_height_hook(this->user_data(), item); +} + + +int My_Browser_::item_width(void * item) const { + return browser_item_width_hook(this->user_data(), item); +} + +int My_Browser_::item_height(void * item) const { + return browser_item_height_hook(this->user_data(), item); +} + +void * My_Browser_::item_first() const { + return browser_item_first_hook(this->user_data()); +} + +void * My_Browser_::item_last() const { + return browser_item_last_hook(this->user_data()); +} + +void * My_Browser_::item_next(void * item) const { + return browser_item_next_hook(this->user_data(), item); +} + +void * My_Browser_::item_prev(void * item) const { + return browser_item_prev_hook(this->user_data(), item); +} + +void * My_Browser_::item_at(int index) const { + return browser_item_at_hook(this->user_data(), index); +} + +void My_Browser_::item_select(void * item, int val) { + browser_item_select_hook(this->user_data(), item, val); +} + +int My_Browser_::item_selected(void * item) const { + return browser_item_selected_hook(this->user_data(), item); +} + +void My_Browser_::item_swap(void * a, void * b) { + browser_item_swap_hook(this->user_data(), a, b); +} + +const char * My_Browser_::item_text(void * item) const { + return browser_item_text_hook(this->user_data(), item); +} + +void My_Browser_::item_draw(void * item, int x, int y, int w, int h) const { + browser_item_draw_hook(this->user_data(), item, x, y, w, h); +} + + +void My_Browser_::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Browser_::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +ABSTRACTBROWSER new_fl_abstract_browser(int x, int y, int w, int h, char * label) { + My_Browser_ *b = new My_Browser_(x, y, w, h, label); + return b; +} + +void free_fl_abstract_browser(ABSTRACTBROWSER b) { + delete reinterpret_cast<My_Browser_*>(b); +} + + + + +void * fl_abstract_browser_hscrollbar(ABSTRACTBROWSER b) { + return &reinterpret_cast<Fl_Browser_*>(b)->hscrollbar; +} + +void * fl_abstract_browser_scrollbar(ABSTRACTBROWSER b) { + return &reinterpret_cast<Fl_Browser_*>(b)->scrollbar; +} + + + + +int fl_abstract_browser_select(ABSTRACTBROWSER b, void * i, int v, int c) { + return reinterpret_cast<Fl_Browser_*>(b)->select(i, v, c); +} + +int fl_abstract_browser_select_only(ABSTRACTBROWSER b, void * i, int c) { + return reinterpret_cast<Fl_Browser_*>(b)->select_only(i, c); +} + +void * fl_abstract_browser_selection(ABSTRACTBROWSER b) { + return reinterpret_cast<My_Browser_*>(b)->selection(); +} + +int fl_abstract_browser_deselect(ABSTRACTBROWSER b, int c) { + return reinterpret_cast<Fl_Browser_*>(b)->deselect(c); +} + +void fl_abstract_browser_display(ABSTRACTBROWSER b, void * i) { + reinterpret_cast<Fl_Browser_*>(b)->display(i); +} + +int fl_abstract_browser_displayed(ABSTRACTBROWSER b, void * i) { + return reinterpret_cast<My_Browser_*>(b)->displayed(i); +} + +void * fl_abstract_browser_find_item(ABSTRACTBROWSER b, int y) { + return reinterpret_cast<My_Browser_*>(b)->find_item(y); +} + +void * fl_abstract_browser_top(ABSTRACTBROWSER b) { + return reinterpret_cast<My_Browser_*>(b)->top(); +} + +void fl_abstract_browser_sort(ABSTRACTBROWSER b, int f) { + reinterpret_cast<Fl_Browser_*>(b)->sort(f); +} + + + + +unsigned char fl_abstract_browser_get_has_scrollbar(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->has_scrollbar(); +} + +void fl_abstract_browser_set_has_scrollbar(ABSTRACTBROWSER b, unsigned char m) { + reinterpret_cast<Fl_Browser_*>(b)->has_scrollbar(m); +} + +int fl_abstract_browser_get_hposition(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->hposition(); +} + +void fl_abstract_browser_set_hposition(ABSTRACTBROWSER b, int p) { + reinterpret_cast<Fl_Browser_*>(b)->hposition(p); +} + +int fl_abstract_browser_get_position(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->position(); +} + +void fl_abstract_browser_set_position(ABSTRACTBROWSER b, int p) { + reinterpret_cast<Fl_Browser_*>(b)->position(p); +} + +void fl_abstract_browser_scrollbar_left(ABSTRACTBROWSER b) { + reinterpret_cast<Fl_Browser_*>(b)->scrollbar_left(); +} + +void fl_abstract_browser_scrollbar_right(ABSTRACTBROWSER b) { + reinterpret_cast<Fl_Browser_*>(b)->scrollbar_right(); +} + +int fl_abstract_browser_get_scrollbar_size(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->scrollbar_size(); +} + +void fl_abstract_browser_set_scrollbar_size(ABSTRACTBROWSER b, int s) { + reinterpret_cast<Fl_Browser_*>(b)->scrollbar_size(s); +} + + + + +unsigned int fl_abstract_browser_get_textcolor(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->textcolor(); +} + +void fl_abstract_browser_set_textcolor(ABSTRACTBROWSER b, unsigned int c) { + reinterpret_cast<Fl_Browser_*>(b)->textcolor(c); +} + +int fl_abstract_browser_get_textfont(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->textfont(); +} + +void fl_abstract_browser_set_textfont(ABSTRACTBROWSER b, int f) { + reinterpret_cast<Fl_Browser_*>(b)->textfont(f); +} + +int fl_abstract_browser_get_textsize(ABSTRACTBROWSER b) { + return reinterpret_cast<Fl_Browser_*>(b)->textsize(); +} + +void fl_abstract_browser_set_textsize(ABSTRACTBROWSER b, int s) { + reinterpret_cast<Fl_Browser_*>(b)->textsize(s); +} + + + + +void fl_abstract_browser_resize(ABSTRACTBROWSER b, int x, int y, int w, int h) { + reinterpret_cast<Fl_Browser_*>(b)->resize(x, y, w, h); +} + +void fl_abstract_browser_bbox(ABSTRACTBROWSER b, int &x, int &y, int &w, int &h) { + reinterpret_cast<My_Browser_*>(b)->bbox(x, y, w, h); +} + +int fl_abstract_browser_leftedge(ABSTRACTBROWSER b) { + return reinterpret_cast<My_Browser_*>(b)->leftedge(); +} + +void fl_abstract_browser_redraw_line(ABSTRACTBROWSER b, void * i) { + reinterpret_cast<My_Browser_*>(b)->redraw_line(i); +} + +void fl_abstract_browser_redraw_lines(ABSTRACTBROWSER b) { + reinterpret_cast<My_Browser_*>(b)->redraw_lines(); +} + + + + +int fl_abstract_browser_full_width(ABSTRACTBROWSER b) { + return reinterpret_cast<My_Browser_*>(b)->Fl_Browser_::full_width(); +} + +int fl_abstract_browser_full_height(ABSTRACTBROWSER b) { + return reinterpret_cast<My_Browser_*>(b)->Fl_Browser_::full_height(); +} + +int fl_abstract_browser_incr_height(ABSTRACTBROWSER b) { + return reinterpret_cast<My_Browser_*>(b)->Fl_Browser_::incr_height(); +} + +int fl_abstract_browser_item_quick_height(ABSTRACTBROWSER b, void * i) { + return reinterpret_cast<My_Browser_*>(b)->Fl_Browser_::item_quick_height(i); +} + + + + +void fl_abstract_browser_new_list(ABSTRACTBROWSER b) { + reinterpret_cast<My_Browser_*>(b)->new_list(); +} + +void fl_abstract_browser_inserting(ABSTRACTBROWSER b, void * a1, void * a2) { + reinterpret_cast<My_Browser_*>(b)->inserting(a1, a2); +} + +void fl_abstract_browser_deleting(ABSTRACTBROWSER b, void * item) { + reinterpret_cast<My_Browser_*>(b)->deleting(item); +} + +void fl_abstract_browser_replacing(ABSTRACTBROWSER b, void * a1, void * a2) { + reinterpret_cast<My_Browser_*>(b)->replacing(a1, a2); +} + +void fl_abstract_browser_swapping(ABSTRACTBROWSER b, void * a1, void * a2) { + reinterpret_cast<My_Browser_*>(b)->swapping(a1, a2); +} + + + + +void fl_abstract_browser_draw(ABSTRACTBROWSER b) { + reinterpret_cast<My_Browser_*>(b)->Fl_Browser_::draw(); +} + +int fl_abstract_browser_handle(ABSTRACTBROWSER b, int e) { + return reinterpret_cast<My_Browser_*>(b)->Fl_Browser_::handle(e); +} + + diff --git a/src/c_fl_browser_.h b/src/c_fl_browser_.h new file mode 100644 index 0000000..ed1157e --- /dev/null +++ b/src/c_fl_browser_.h @@ -0,0 +1,83 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ABSTRACT_BROWSER_GUARD +#define FL_ABSTRACT_BROWSER_GUARD + + +extern "C" const int fl_sort_ascending; +extern "C" const int fl_sort_descending; + + +typedef void* ABSTRACTBROWSER; + + +extern "C" ABSTRACTBROWSER new_fl_abstract_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_abstract_browser(ABSTRACTBROWSER b); + + +extern "C" void * fl_abstract_browser_hscrollbar(ABSTRACTBROWSER b); +extern "C" void * fl_abstract_browser_scrollbar(ABSTRACTBROWSER b); + + +extern "C" int fl_abstract_browser_select(ABSTRACTBROWSER b, void * i, int v, int c); +extern "C" int fl_abstract_browser_select_only(ABSTRACTBROWSER b, void * i, int c); +extern "C" void * fl_abstract_browser_selection(ABSTRACTBROWSER b); +extern "C" int fl_abstract_browser_deselect(ABSTRACTBROWSER b, int c); +extern "C" void fl_abstract_browser_display(ABSTRACTBROWSER b, void * i); +extern "C" int fl_abstract_browser_displayed(ABSTRACTBROWSER b, void * i); +extern "C" void * fl_abstract_browser_find_item(ABSTRACTBROWSER b, int y); +extern "C" void * fl_abstract_browser_top(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_sort(ABSTRACTBROWSER b, int f); + + +extern "C" unsigned char fl_abstract_browser_get_has_scrollbar(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_has_scrollbar(ABSTRACTBROWSER b, unsigned char m); +extern "C" int fl_abstract_browser_get_hposition(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_hposition(ABSTRACTBROWSER b, int p); +extern "C" int fl_abstract_browser_get_position(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_position(ABSTRACTBROWSER b, int p); +extern "C" void fl_abstract_browser_scrollbar_left(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_scrollbar_right(ABSTRACTBROWSER b); +extern "C" int fl_abstract_browser_get_scrollbar_size(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_scrollbar_size(ABSTRACTBROWSER b, int s); + + +extern "C" unsigned int fl_abstract_browser_get_textcolor(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_textcolor(ABSTRACTBROWSER b, unsigned int c); +extern "C" int fl_abstract_browser_get_textfont(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_textfont(ABSTRACTBROWSER b, int f); +extern "C" int fl_abstract_browser_get_textsize(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_set_textsize(ABSTRACTBROWSER b, int s); + + +extern "C" void fl_abstract_browser_resize(ABSTRACTBROWSER b, int x, int y, int w, int h); +extern "C" void fl_abstract_browser_bbox(ABSTRACTBROWSER b, int &x, int &y, int &w, int &h); +extern "C" int fl_abstract_browser_leftedge(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_redraw_line(ABSTRACTBROWSER b, void * i); +extern "C" void fl_abstract_browser_redraw_lines(ABSTRACTBROWSER b); + + +extern "C" int fl_abstract_browser_full_width(ABSTRACTBROWSER b); +extern "C" int fl_abstract_browser_full_height(ABSTRACTBROWSER b); +extern "C" int fl_abstract_browser_incr_height(ABSTRACTBROWSER b); +extern "C" int fl_abstract_browser_item_quick_height(ABSTRACTBROWSER b, void * i); + + +extern "C" void fl_abstract_browser_new_list(ABSTRACTBROWSER b); +extern "C" void fl_abstract_browser_inserting(ABSTRACTBROWSER b, void * a1, void * a2); +extern "C" void fl_abstract_browser_deleting(ABSTRACTBROWSER b, void * item); +extern "C" void fl_abstract_browser_replacing(ABSTRACTBROWSER b, void * a1, void * a2); +extern "C" void fl_abstract_browser_swapping(ABSTRACTBROWSER b, void * a1, void * a2); + + +extern "C" void fl_abstract_browser_draw(ABSTRACTBROWSER b); +extern "C" int fl_abstract_browser_handle(ABSTRACTBROWSER b, int e); + + +#endif + + 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; + + diff --git a/src/fltk-widgets-groups-browsers.ads b/src/fltk-widgets-groups-browsers.ads new file mode 100644 index 0000000..c93506f --- /dev/null +++ b/src/fltk-widgets-groups-browsers.ads @@ -0,0 +1,447 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Valuators.Sliders.Scrollbars, + System; + +private with + + Ada.Finalization, + Ada.Unchecked_Conversion, + Interfaces.C; + + +package FLTK.Widgets.Groups.Browsers is + + + type Abstract_Browser is new Group with private; + + type Abstract_Browser_Reference (Data : not null access Abstract_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + type Item_Cursor is mod System.Memory_Size; + + No_Item : constant Item_Cursor; + + type Sort_Order is (Ascending, Descending); + + type Scrollbar_Mode is record + Horizontal : Boolean := True; + Vertical : Boolean := True; + Always_On : Boolean := False; + end record; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Abstract_Browser; + + end Forge; + + + + + -- Access to the Browser's self contained scrollbars + + function H_Bar + (This : in out Abstract_Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + function V_Bar + (This : in out Abstract_Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + + + + -- 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; + + function Select_Only + (This : in out Abstract_Browser; + Item : in Item_Cursor; + Do_Callbacks : in Boolean := False) + return Boolean; + + function Current_Selection + (This : in Abstract_Browser) + return Item_Cursor; + + function Deselect + (This : in out Abstract_Browser; + Do_Callbacks : in Boolean := False) + return Boolean; + + procedure Display + (This : in out Abstract_Browser; + Item : in Item_Cursor); + + function Is_Displayed + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Boolean; + + function Find_Item + (This : in Abstract_Browser; + Y_Pos : in Integer) + return Item_Cursor; + + function Top_Item + (This : in Abstract_Browser) + return Item_Cursor; + + -- Not task safe due to internal issues with converting Ada Strings to char* in C. + -- Unsure how much that matters since unsure how task safe FLTK is anyway. + procedure Sort + (This : in out Abstract_Browser; + Order : in Sort_Order); + + + + + -- Scrollbar related settings + + function Get_Scrollbar_Mode + (This : in Abstract_Browser) + return Scrollbar_Mode; + + procedure Set_Scrollbar_Mode + (This : in out Abstract_Browser; + Mode : in Scrollbar_Mode); + + function Get_H_Position + (This : in Abstract_Browser) + return Integer; + + procedure Set_H_Position + (This : in out Abstract_Browser; + Value : in Integer); + + function Get_V_Position + (This : in Abstract_Browser) + return Integer; + + procedure Set_V_Position + (This : in out Abstract_Browser; + Value : in Integer); + + procedure Set_Vertical_Left + (This : in out Abstract_Browser); + + procedure Set_Vertical_Right + (This : in out Abstract_Browser); + + function Get_Scrollbar_Size + (This : in Abstract_Browser) + return Integer; + + procedure Set_Scrollbar_Size + (This : in out Abstract_Browser; + Value : in Integer); + + + + + -- Text related settings + + function Get_Text_Color + (This : in Abstract_Browser) + return Color; + + procedure Set_Text_Color + (This : in out Abstract_Browser; + Value : in Color); + + function Get_Text_Font + (This : in Abstract_Browser) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Abstract_Browser; + Font : in Font_Kind); + + function Get_Text_Size + (This : in Abstract_Browser) + return Font_Size; + + procedure Set_Text_Size + (This : in out Abstract_Browser; + Size : in Font_Size); + + + + + -- Graphical dimensions and redrawing + + procedure Resize + (This : in out Abstract_Browser; + X, Y, W, H : in Integer); + + procedure Bounding_Box + (This : in Abstract_Browser; + X, Y, W, H : out Integer); + + function Left_Edge + (This : in Abstract_Browser) + return Integer; + + procedure Redraw_Line + (This : in out Abstract_Browser; + Item : in Item_Cursor); + + procedure Redraw_List + (This : in out Abstract_Browser); + + + + + -- You may override these subprograms to change the behaviour of the widget + -- even though these are called from within FLTK. + + function Full_List_Width + (This : in Abstract_Browser) + return Integer; + + function Full_List_Height + (This : in Abstract_Browser) + return Integer; + + function Average_Item_Height + (This : in Abstract_Browser) + return Integer; + + function Item_Quick_Height + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Integer; + + + + + -- You MUST override these subprograms if deriving a type from Abstract_Browser + -- or your program will crash, since they are called from within FLTK and do not + -- have any implementations given. By default here they will raise an exception. + + function Item_Width + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_Height + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_First + (This : in Abstract_Browser) + return Item_Cursor; + + function Item_Last + (This : in Abstract_Browser) + return Item_Cursor; + + function Item_Next + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_Previous + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_At + (This : in Abstract_Browser; + Index : in Positive) + return Item_Cursor; + + procedure Item_Select + (This : in out Abstract_Browser; + Item : in Item_Cursor; + State : in Boolean := True); + + function Item_Selected + (This : in Abstract_Browser; + Item : in Item_Cursor) + return Boolean; + + procedure Item_Swap + (This : in out Abstract_Browser; + A, B : in Item_Cursor); + + function Item_Text + (This : in Abstract_Browser; + Item : in Item_Cursor) + return String; + + procedure Item_Draw + (This : in Abstract_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer); + + + + + -- Cache invalidation + + procedure New_List + (This : in out Abstract_Browser); + + procedure Inserting + (This : in out Abstract_Browser; + A, B : in Item_Cursor); + + procedure Deleting + (This : in out Abstract_Browser; + Item : in Item_Cursor); + + procedure Replacing + (This : in out Abstract_Browser; + A, B : in Item_Cursor); + + procedure Swapping + (This : in out Abstract_Browser; + A, B : in Item_Cursor); + + + + + -- You may override these subprograms to change the behaviour of the widget + -- even though these are called from within FLTK. + + procedure Draw + (This : in out Abstract_Browser); + + function Handle + (This : in out Abstract_Browser; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Abstract_Browser is new Group with record + Horizon : aliased Valuators.Sliders.Scrollbars.Scrollbar; + Vertigo : aliased Valuators.Sliders.Scrollbars.Scrollbar; + end record; + + overriding procedure Finalize + (This : in out Abstract_Browser); + + + pragma Assert + (Item_Cursor'Size = Storage.Integer_Address'Size, + "Size of Browser Item_Cursor does not match Ada address values"); + + function Address_To_Cursor is + new Ada.Unchecked_Conversion (Storage.Integer_Address, Item_Cursor); + function Cursor_To_Address is + new Ada.Unchecked_Conversion (Item_Cursor, Storage.Integer_Address); + + No_Item : constant Item_Cursor := Address_To_Cursor (Null_Pointer); + + + for Scrollbar_Mode use record + Horizontal at 0 range 0 .. 0; + Vertical at 0 range 1 .. 1; + Always_On at 0 range 2 .. 2; + end record; + + for Scrollbar_Mode'Size use Interfaces.C.unsigned_char'Size; + + function Mode_To_Uchar is + new Ada.Unchecked_Conversion (Scrollbar_Mode, Interfaces.C.unsigned_char); + function Uchar_To_Mode is + new Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Scrollbar_Mode); + + + pragma Inline (H_Bar); + pragma Inline (V_Bar); + + pragma Inline (Current_Selection); + pragma Inline (Display); + pragma Inline (Find_Item); + pragma Inline (Top_Item); + pragma Inline (Sort); + + pragma Inline (Get_Scrollbar_Mode); + pragma Inline (Set_Scrollbar_Mode); + pragma Inline (Get_H_Position); + pragma Inline (Set_H_Position); + pragma Inline (Get_V_Position); + pragma Inline (Set_V_Position); + pragma Inline (Set_Vertical_Left); + pragma Inline (Set_Vertical_Right); + pragma Inline (Get_Scrollbar_Size); + pragma Inline (Set_Scrollbar_Size); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Resize); + pragma Inline (Bounding_Box); + pragma Inline (Left_Edge); + pragma Inline (Redraw_Line); + pragma Inline (Redraw_List); + + pragma Inline (Full_List_Width); + pragma Inline (Full_List_Height); + pragma Inline (Average_Item_Height); + pragma Inline (Item_Quick_Height); + + pragma Inline (New_List); + pragma Inline (Inserting); + pragma Inline (Deleting); + pragma Inline (Replacing); + pragma Inline (Swapping); + + pragma Inline (Draw); + pragma Inline (Handle); + + + function fl_abstract_browser_hscrollbar + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_abstract_browser_hscrollbar, "fl_abstract_browser_hscrollbar"); + pragma Inline (fl_abstract_browser_hscrollbar); + + function fl_abstract_browser_scrollbar + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_abstract_browser_scrollbar, "fl_abstract_browser_scrollbar"); + pragma Inline (fl_abstract_browser_scrollbar); + + + -- Needed to ensure chars_ptr storage is properly cleaned up + type Item_Text_Hook_Final_Controller is new Ada.Finalization.Controlled with null record; + + overriding procedure Finalize + (This : in out Item_Text_Hook_Final_Controller); + + Cleanup : Item_Text_Hook_Final_Controller; + + +end FLTK.Widgets.Groups.Browsers; + + diff --git a/src/fltk-widgets.ads b/src/fltk-widgets.ads index 5fe822d..9964bda 100644 --- a/src/fltk-widgets.ads +++ b/src/fltk-widgets.ads @@ -378,17 +378,17 @@ private -- the user data portion should always be a reference back to the Ada binding procedure Callback_Hook (W, U : in Storage.Integer_Address); - pragma Convention (C, Callback_Hook); + pragma Export (C, Callback_Hook, "widget_callback_hook"); procedure Draw_Hook (U : in Storage.Integer_Address); - pragma Convention (C, Draw_Hook); + pragma Export (C, Draw_Hook, "widget_draw_hook"); function Handle_Hook (U : in Storage.Integer_Address; E : in Interfaces.C.int) return Interfaces.C.int; - pragma Convention (C, Handle_Hook); + pragma Export (C, Handle_Hook, "widget_handle_hook"); |