diff options
Diffstat (limited to 'body')
358 files changed, 74413 insertions, 0 deletions
diff --git a/body/c_fl.cpp b/body/c_fl.cpp new file mode 100644 index 0000000..7bfc444 --- /dev/null +++ b/body/c_fl.cpp @@ -0,0 +1,225 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Enumerations.H> +#include <FL/Fl.H> +#include <FL/Fl_Widget.H> +#include "c_fl.h" + + + + +const short fl_align_center = FL_ALIGN_CENTER; +const short fl_align_top = FL_ALIGN_TOP; +const short fl_align_bottom = FL_ALIGN_BOTTOM; +const short fl_align_left = FL_ALIGN_LEFT; +const short fl_align_right = FL_ALIGN_RIGHT; +const short fl_align_inside = FL_ALIGN_INSIDE; +const short fl_align_text_over_image = FL_ALIGN_TEXT_OVER_IMAGE; +const short fl_align_image_over_text = FL_ALIGN_IMAGE_OVER_TEXT; +const short fl_align_clip = FL_ALIGN_CLIP; +const short fl_align_wrap = FL_ALIGN_WRAP; +const short fl_align_image_next_to_text = FL_ALIGN_IMAGE_NEXT_TO_TEXT; +const short fl_align_text_next_to_image = FL_ALIGN_TEXT_NEXT_TO_IMAGE; +const short fl_align_image_backdrop = FL_ALIGN_IMAGE_BACKDROP; +const short fl_align_top_left = FL_ALIGN_TOP_LEFT; +const short fl_align_top_right = FL_ALIGN_TOP_RIGHT; +const short fl_align_bottom_left = FL_ALIGN_BOTTOM_LEFT; +const short fl_align_bottom_right = FL_ALIGN_BOTTOM_RIGHT; +const short fl_align_left_top = FL_ALIGN_LEFT_TOP; +const short fl_align_right_top = FL_ALIGN_RIGHT_TOP; +const short fl_align_left_bottom = FL_ALIGN_LEFT_BOTTOM; +const short fl_align_right_bottom = FL_ALIGN_RIGHT_BOTTOM; +const short fl_align_nowrap = FL_ALIGN_NOWRAP; +const short fl_align_all_position = FL_ALIGN_POSITION_MASK; +const short fl_align_all_image = FL_ALIGN_IMAGE_MASK; + + + + +const short fl_mod_command = FL_COMMAND >> 16; + + + + +size_t c_pointer_size() { + return sizeof(void*); +} + + + + +const int fl_enum_num_red = FL_NUM_RED; +const int fl_enum_num_green = FL_NUM_GREEN; +const int fl_enum_num_blue = FL_NUM_BLUE; +const int fl_enum_num_gray = FL_NUM_GRAY; + + + + +const unsigned int fl_enum_button1 = FL_BUTTON1; +const unsigned int fl_enum_button2 = FL_BUTTON2; +const unsigned int fl_enum_button3 = FL_BUTTON3; +#if FL_API_VERSION >= 10310 +const unsigned int fl_enum_button4 = FL_BUTTON4; +const unsigned int fl_enum_button5 = FL_BUTTON5; +#else +// woo, limited backwards compatibility +const unsigned int fl_enum_button4 = 8; +const unsigned int fl_enum_button5 = 16; +#endif +const unsigned int fl_enum_buttons = FL_BUTTONS; + + + + +const int fl_enum_left_mouse = FL_LEFT_MOUSE; +const int fl_enum_middle_mouse = FL_MIDDLE_MOUSE; +const int fl_enum_right_mouse = FL_RIGHT_MOUSE; +#if FL_API_VERSION >= 10310 +const int fl_enum_back_mouse = FL_BACK_MOUSE; +const int fl_enum_forward_mouse = FL_FORWARD_MOUSE; +#else +// woo, limited backwards compatibility +const int fl_enum_back_mouse = 4; +const int fl_enum_forward_mouse = 5; +#endif + + + + +unsigned int fl_enum_rgb_color2(unsigned char l) { + return static_cast<unsigned int>(fl_rgb_color(l)); +} + +unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b) { + return static_cast<unsigned int>(fl_rgb_color(r, g, b)); +} + +unsigned int fl_enum_color_cube(int r, int g, int b) { + return static_cast<unsigned int>(fl_color_cube(r, g, b)); +} + +unsigned int fl_enum_gray_ramp(int l) { + return static_cast<unsigned int>(fl_gray_ramp(l)); +} + +unsigned int fl_enum_darker(unsigned int c) { + return static_cast<unsigned int>(fl_darker(static_cast<Fl_Color>(c))); +} + +unsigned int fl_enum_lighter(unsigned int c) { + return static_cast<unsigned int>(fl_lighter(static_cast<Fl_Color>(c))); +} + +unsigned int fl_enum_contrast(unsigned int f, unsigned int b) { + return static_cast<unsigned int>(fl_contrast + (static_cast<Fl_Color>(f), static_cast<Fl_Color>(b))); +} + +unsigned int fl_enum_inactive(unsigned int c) { + return static_cast<unsigned int>(fl_inactive(static_cast<Fl_Color>(c))); +} + +unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w) { + return static_cast<unsigned int>(fl_color_average + (static_cast<Fl_Color>(c1), static_cast<Fl_Color>(c2), w)); +} + + + + +int fl_enum_box(int b) { + return static_cast<int>(fl_box(static_cast<Fl_Boxtype>(b))); +} + +int fl_enum_frame(int b) { + return static_cast<int>(fl_frame(static_cast<Fl_Boxtype>(b))); +} + +int fl_enum_down(int b) { + return static_cast<int>(fl_down(static_cast<Fl_Boxtype>(b))); +} + + + + +const char * const fl_clip_image_char_ptr = Fl::clipboard_image; + +const char * const fl_clip_plain_text_char_ptr = Fl::clipboard_plain_text; + + + + +int fl_abi_check(int v) { + return Fl::abi_check(v); +} + +int fl_abi_version() { + return Fl::abi_version(); +} + +int fl_api_version() { + return Fl::api_version(); +} + +double fl_version() { + return Fl::version(); +} + + + + +short fl_inside_callback = 0; + +void fl_delete_widget(void * w) { + Fl::delete_widget(static_cast<Fl_Widget*>(w)); +} + + + + +int fl_check() { + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::check(); + fl_inside_callback = temp; + return ret; +} + +int fl_ready() { + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::ready(); + fl_inside_callback = temp; + return ret; +} + +int fl_wait() { + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::wait(); + fl_inside_callback = temp; + return ret; +} + +double fl_wait2(double s) { + short temp = fl_inside_callback; + fl_inside_callback = 1; + double ret = Fl::wait(s); + fl_inside_callback = temp; + return ret; +} + +int fl_run() { + short temp = fl_inside_callback; + fl_inside_callback = 1; + int ret = Fl::run(); + fl_inside_callback = temp; + return ret; +} + + diff --git a/body/c_fl.h b/body/c_fl.h new file mode 100644 index 0000000..2149640 --- /dev/null +++ b/body/c_fl.h @@ -0,0 +1,106 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_GUARD +#define FL_GUARD + + +#include <cstddef> + + +extern "C" const short fl_align_center; +extern "C" const short fl_align_top; +extern "C" const short fl_align_bottom; +extern "C" const short fl_align_left; +extern "C" const short fl_align_right; +extern "C" const short fl_align_inside; +extern "C" const short fl_align_text_over_image; +extern "C" const short fl_align_image_over_text; +extern "C" const short fl_align_clip; +extern "C" const short fl_align_wrap; +extern "C" const short fl_align_image_next_to_text; +extern "C" const short fl_align_text_next_to_image; +extern "C" const short fl_align_image_backdrop; +extern "C" const short fl_align_top_left; +extern "C" const short fl_align_top_right; +extern "C" const short fl_align_bottom_left; +extern "C" const short fl_align_bottom_right; +extern "C" const short fl_align_left_top; +extern "C" const short fl_align_right_top; +extern "C" const short fl_align_left_bottom; +extern "C" const short fl_align_right_bottom; +extern "C" const short fl_align_nowrap; +extern "C" const short fl_align_all_position; +extern "C" const short fl_align_all_image; + + +extern "C" const short fl_mod_command; + + +extern "C" size_t c_pointer_size(); + + +extern "C" const int fl_enum_num_red; +extern "C" const int fl_enum_num_green; +extern "C" const int fl_enum_num_blue; +extern "C" const int fl_enum_num_gray; + + +extern "C" const unsigned int fl_enum_button1; +extern "C" const unsigned int fl_enum_button2; +extern "C" const unsigned int fl_enum_button3; +extern "C" const unsigned int fl_enum_button4; +extern "C" const unsigned int fl_enum_button5; +extern "C" const unsigned int fl_enum_buttons; + + +extern "C" const int fl_enum_left_mouse; +extern "C" const int fl_enum_middle_mouse; +extern "C" const int fl_enum_right_mouse; +extern "C" const int fl_enum_back_mouse; +extern "C" const int fl_enum_forward_mouse; + + +extern "C" unsigned int fl_enum_rgb_color2(unsigned char l); +extern "C" unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b); +extern "C" unsigned int fl_enum_color_cube(int r, int g, int b); +extern "C" unsigned int fl_enum_gray_ramp(int l); +extern "C" unsigned int fl_enum_darker(unsigned int c); +extern "C" unsigned int fl_enum_lighter(unsigned int c); +extern "C" unsigned int fl_enum_contrast(unsigned int f, unsigned int b); +extern "C" unsigned int fl_enum_inactive(unsigned int c); +extern "C" unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w); + + +extern "C" int fl_enum_box(int b); +extern "C" int fl_enum_frame(int b); +extern "C" int fl_enum_down(int b); + + +extern "C" const char * const fl_clip_image_char_ptr; +extern "C" const char * const fl_clip_plain_text_char_ptr; + + +extern "C" int fl_abi_check(int v); +extern "C" int fl_abi_version(); +extern "C" int fl_api_version(); +extern "C" double fl_version(); + + +extern "C" short fl_inside_callback; +extern "C" void fl_delete_widget(void * w); + + +extern "C" int fl_check(); +extern "C" int fl_ready(); +extern "C" int fl_wait(); +extern "C" double fl_wait2(double s); +extern "C" int fl_run(); + + +#endif + + diff --git a/body/c_fl_adjuster.cpp b/body/c_fl_adjuster.cpp new file mode 100644 index 0000000..5550250 --- /dev/null +++ b/body/c_fl_adjuster.cpp @@ -0,0 +1,104 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Adjuster.H> +#include "c_fl_adjuster.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Non-friend protected access + +class Friend_Adjuster : Fl_Adjuster { +public: + using Fl_Adjuster::value_damage; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Adjuster : public Fl_Adjuster { +public: + using Fl_Adjuster::Fl_Adjuster; + + friend void fl_adjuster_draw(ADJUSTER a); + friend int fl_adjuster_handle(ADJUSTER a, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Adjuster::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Adjuster::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Adjuster::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +ADJUSTER new_fl_adjuster(int x, int y, int w, int h, char* label) { + My_Adjuster *a = new My_Adjuster(x, y, w, h, label); + return a; +} + +void free_fl_adjuster(ADJUSTER a) { + if (fl_inside_callback) { + fl_delete_widget(a); + } else { + delete static_cast<My_Adjuster*>(a); + } +} + + + + +int fl_adjuster_is_soft(ADJUSTER a) { + return static_cast<Fl_Adjuster*>(a)->soft(); +} + +void fl_adjuster_set_soft(ADJUSTER a, int t) { + static_cast<Fl_Adjuster*>(a)->soft(t); +} + + + + +void fl_adjuster_value_damage(ADJUSTER a) { + (static_cast<Fl_Adjuster*>(a)->*(&Friend_Adjuster::value_damage))(); +} + +void fl_adjuster_draw(ADJUSTER a) { + static_cast<My_Adjuster*>(a)->Fl_Adjuster::draw(); +} + +int fl_adjuster_handle(ADJUSTER a, int e) { + return static_cast<My_Adjuster*>(a)->Fl_Adjuster::handle(e); +} + + diff --git a/body/c_fl_adjuster.h b/body/c_fl_adjuster.h new file mode 100644 index 0000000..fbaa5ec --- /dev/null +++ b/body/c_fl_adjuster.h @@ -0,0 +1,29 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ADJUSTER_GUARD +#define FL_ADJUSTER_GUARD + + +typedef void* ADJUSTER; + + +extern "C" ADJUSTER new_fl_adjuster(int x, int y, int w, int h, char* label); +extern "C" void free_fl_adjuster(ADJUSTER a); + + +extern "C" int fl_adjuster_is_soft(ADJUSTER a); +extern "C" void fl_adjuster_set_soft(ADJUSTER a, int t); + + +extern "C" void fl_adjuster_value_damage(ADJUSTER a); +extern "C" void fl_adjuster_draw(ADJUSTER a); +extern "C" int fl_adjuster_handle(ADJUSTER a, int e); + + +#endif + + diff --git a/body/c_fl_ask.cpp b/body/c_fl_ask.cpp new file mode 100644 index 0000000..30dd480 --- /dev/null +++ b/body/c_fl_ask.cpp @@ -0,0 +1,147 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/fl_ask.H> +#include <FL/fl_show_colormap.H> +#include <FL/Fl_File_Chooser.H> +#include <FL/Fl_Color_Chooser.H> +#include "c_fl_ask.h" + + + + +const char * fl_ask_get_cancel() { + return fl_cancel; +} + +void fl_ask_set_cancel(const char * v) { + fl_cancel = v; +} + +const char * fl_ask_get_close() { + return fl_close; +} + +void fl_ask_set_close(const char * v) { + fl_close = v; +} + +const char * fl_ask_get_no() { + return fl_no; +} + +void fl_ask_set_no(const char * v) { + fl_no = v; +} + +const char * fl_ask_get_ok() { + return fl_ok; +} + +void fl_ask_set_ok(const char * v) { + fl_ok = v; +} + +const char * fl_ask_get_yes() { + return fl_yes; +} + +void fl_ask_set_yes(const char * v) { + fl_yes = v; +} + + + + +void fl_ask_alert(const char * m) { + fl_alert(m); +} + +void fl_ask_beep(int b) { + fl_beep(b); +} + +int fl_ask_choice(const char * m, const char * a, const char * b, const char * c) { + return fl_choice(m, a, b, c); +} + +int fl_ask_choice_n(const char * m, const char * a, const char * b, const char * c) { + return fl_choice_n(m, a, b, c); +} + +const char * fl_ask_input(const char * m, const char * d) { + return fl_input(m, d); +} + +void fl_ask_message(const char * m) { + fl_message(m); +} + +const char * fl_ask_password(const char * m, const char * d) { + return fl_password(m, d); +} + + + + +int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int m) { + return fl_color_chooser(n, r, g, b, m); +} + +int fl_ask_color_chooser2(const char * n, + unsigned char & r, unsigned char & g, unsigned char & b, int m) +{ + return fl_color_chooser(n, r, g, b, m); +} + +unsigned int fl_ask_show_colormap(unsigned int h) { + return static_cast<unsigned int>(fl_show_colormap(static_cast<Fl_Color>(h))); +} + +char * fl_ask_dir_chooser(const char * m, const char * d, int r) { + return fl_dir_chooser(m, d, r); +} + +char * fl_ask_file_chooser(const char * m, const char * p, const char * d, int r) { + return fl_file_chooser(m, p, d, r); +} + +void fl_ask_file_chooser_callback(void(*cb)(const char *)) { + fl_file_chooser_callback(cb); +} + +void fl_ask_file_chooser_ok_label(const char *l) { + fl_file_chooser_ok_label(l); +} + + + + +int fl_ask_get_message_hotspot(void) { + return fl_message_hotspot(); +} + +void fl_ask_set_message_hotspot(int v) { + fl_message_hotspot(v); +} + +void fl_ask_message_font(int f, int s) { + fl_message_font(f, s); +} + +void * fl_ask_message_icon(void) { + return fl_message_icon(); +} + +void fl_ask_message_title(const char * t) { + fl_message_title(t); +} + +void fl_ask_message_title_default(const char * t) { + fl_message_title_default(t); +} + + diff --git a/body/c_fl_ask.h b/body/c_fl_ask.h new file mode 100644 index 0000000..4c18391 --- /dev/null +++ b/body/c_fl_ask.h @@ -0,0 +1,52 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ASK_GUARD +#define FL_ASK_GUARD + + +extern "C" const char * fl_ask_get_cancel(); +extern "C" void fl_ask_set_cancel(const char * v); +extern "C" const char * fl_ask_get_close(); +extern "C" void fl_ask_set_close(const char * v); +extern "C" const char * fl_ask_get_no(); +extern "C" void fl_ask_set_no(const char * v); +extern "C" const char * fl_ask_get_ok(); +extern "C" void fl_ask_set_ok(const char * v); +extern "C" const char * fl_ask_get_yes(); +extern "C" void fl_ask_set_yes(const char * v); + + +extern "C" void fl_ask_alert(const char * m); +extern "C" void fl_ask_beep(int b); +extern "C" int fl_ask_choice(const char * m, const char * a, const char * b, const char * c); +extern "C" int fl_ask_choice_n(const char * m, const char * a, const char * b, const char * c); +extern "C" const char * fl_ask_input(const char * m, const char * d); +extern "C" void fl_ask_message(const char * m); +extern "C" const char * fl_ask_password(const char * m, const char * d); + + +extern "C" int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int m); +extern "C" int fl_ask_color_chooser2(const char * n, + unsigned char & r, unsigned char & g, unsigned char & b, int m); +extern "C" unsigned int fl_ask_show_colormap(unsigned int h); +extern "C" char * fl_ask_dir_chooser(const char * m, const char * d, int r); +extern "C" char * fl_ask_file_chooser(const char * m, const char * p, const char * d, int r); +extern "C" void fl_ask_file_chooser_callback(void(*cb)(const char *)); +extern "C" void fl_ask_file_chooser_ok_label(const char *l); + + +extern "C" int fl_ask_get_message_hotspot(void); +extern "C" void fl_ask_set_message_hotspot(int v); +extern "C" void fl_ask_message_font(int f, int s); +extern "C" void * fl_ask_message_icon(void); +extern "C" void fl_ask_message_title(const char * t); +extern "C" void fl_ask_message_title_default(const char * t); + + +#endif + + diff --git a/body/c_fl_bitmap.cpp b/body/c_fl_bitmap.cpp new file mode 100644 index 0000000..a54b579 --- /dev/null +++ b/body/c_fl_bitmap.cpp @@ -0,0 +1,58 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Bitmap.H> +#include "c_fl_bitmap.h" + + + + +BITMAP new_fl_bitmap(void *data, int w, int h) { + Fl_Bitmap *b = new Fl_Bitmap(static_cast<uchar*>(data), w, h); + return b; +} + +void free_fl_bitmap(BITMAP b) { + delete static_cast<Fl_Bitmap*>(b); +} + +BITMAP fl_bitmap_copy(BITMAP b, int w, int h) { + // virtual so disable dispatch + return static_cast<Fl_Bitmap*>(b)->Fl_Bitmap::copy(w, h); +} + +BITMAP fl_bitmap_copy2(BITMAP b) { + return static_cast<Fl_Bitmap*>(b)->copy(); +} + + + + +void fl_bitmap_uncache(BITMAP b) { + // virtual so disable dispatch + static_cast<Fl_Bitmap*>(b)->Fl_Bitmap::uncache(); +} + + + + +const void * fl_bitmap_data(BITMAP b) { + return static_cast<const void*>(static_cast<Fl_Bitmap*>(b)->array); +} + + + + +void fl_bitmap_draw2(BITMAP b, int x, int y) { + static_cast<Fl_Bitmap*>(b)->draw(x, y); +} + +void fl_bitmap_draw(BITMAP b, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + static_cast<Fl_Bitmap*>(b)->Fl_Bitmap::draw(x, y, w, h, cx, cy); +} + + diff --git a/body/c_fl_bitmap.h b/body/c_fl_bitmap.h new file mode 100644 index 0000000..088486c --- /dev/null +++ b/body/c_fl_bitmap.h @@ -0,0 +1,32 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_BITMAP_GUARD +#define FL_BITMAP_GUARD + + +typedef void* BITMAP; + + +extern "C" BITMAP new_fl_bitmap(void *data, int w, int h); +extern "C" void free_fl_bitmap(BITMAP b); +extern "C" BITMAP fl_bitmap_copy(BITMAP b, int w, int h); +extern "C" BITMAP fl_bitmap_copy2(BITMAP b); + + +extern "C" void fl_bitmap_uncache(BITMAP b); + + +extern "C" const void * fl_bitmap_data(BITMAP b); + + +extern "C" void fl_bitmap_draw2(BITMAP b, int x, int y); +extern "C" void fl_bitmap_draw(BITMAP b, int x, int y, int w, int h, int cx, int cy); + + +#endif + + diff --git a/body/c_fl_bmp_image.cpp b/body/c_fl_bmp_image.cpp new file mode 100644 index 0000000..f068b8f --- /dev/null +++ b/body/c_fl_bmp_image.cpp @@ -0,0 +1,22 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_BMP_Image.H> +#include "c_fl_bmp_image.h" + + + + +BMPIMAGE new_fl_bmp_image(const char * f) { + Fl_BMP_Image *b = new Fl_BMP_Image(f); + return b; +} + +void free_fl_bmp_image(BMPIMAGE b) { + delete static_cast<Fl_BMP_Image*>(b); +} + + diff --git a/body/c_fl_bmp_image.h b/body/c_fl_bmp_image.h new file mode 100644 index 0000000..e857fb7 --- /dev/null +++ b/body/c_fl_bmp_image.h @@ -0,0 +1,20 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_BMP_IMAGE_GUARD +#define FL_BMP_IMAGE_GUARD + + +typedef void* BMPIMAGE; + + +extern "C" BMPIMAGE new_fl_bmp_image(const char * f); +extern "C" void free_fl_bmp_image(BMPIMAGE b); + + +#endif + + diff --git a/body/c_fl_box.cpp b/body/c_fl_box.cpp new file mode 100644 index 0000000..22ef21e --- /dev/null +++ b/body/c_fl_box.cpp @@ -0,0 +1,87 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Box.H> +#include "c_fl_box.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void box_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); +void fl_box_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { + box_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +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_Box : public Fl_Box { +public: + using Fl_Box::Fl_Box; + + friend void fl_box_draw(BOX n); + friend int fl_box_handle(BOX n, int e); + + void draw(); + int handle(int e); +}; + +void My_Box::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Box::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +BOX new_fl_box(int x, int y, int w, int h, char* label) { + My_Box *b = new My_Box(x, y, w, h, label); + return b; +} + +BOX new_fl_box2(int k, int x, int y, int w, int h, char * label) { + My_Box *b = new My_Box(static_cast<Fl_Boxtype>(k), x, y, w, h, label); + return b; +} + +void free_fl_box(BOX b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Box*>(b); + } +} + + + + +void fl_box_draw(BOX n) { + static_cast<My_Box*>(n)->Fl_Box::draw(); +} + +int fl_box_handle(BOX n, int e) { + return static_cast<My_Box*>(n)->Fl_Box::handle(e); +} + + diff --git a/body/c_fl_box.h b/body/c_fl_box.h new file mode 100644 index 0000000..f0f8352 --- /dev/null +++ b/body/c_fl_box.h @@ -0,0 +1,28 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_BOX_GUARD +#define FL_BOX_GUARD + + +extern "C" void fl_box_extra_init(void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* BOX; + + +extern "C" BOX new_fl_box(int x, int y, int w, int h, char * label); +extern "C" BOX new_fl_box2(int k, int x, int y, int w, int h, char * label); +extern "C" void free_fl_box(BOX b); + + +extern "C" void fl_box_draw(BOX n); +extern "C" int fl_box_handle(BOX n, int e); + + +#endif + + diff --git a/body/c_fl_browser.cpp b/body/c_fl_browser.cpp new file mode 100644 index 0000000..b76c496 --- /dev/null +++ b/body/c_fl_browser.cpp @@ -0,0 +1,453 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Browser.H> +#include <FL/Fl_Image.H> +#include "c_fl_browser.h" +#include "c_fl.h" + + + + +// 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); + + + + +// Non-friend protected access + +class Friend_Browser : Fl_Browser { +public: + using Fl_Browser::lineno; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Browser : public Fl_Browser { +public: + using Fl_Browser::Fl_Browser; + + friend int fl_browser_item_width(BROWSER b, void * item); + friend int fl_browser_item_height(BROWSER b, void * item); + friend void * fl_browser_item_first(BROWSER b); + friend void * fl_browser_item_last(BROWSER b); + friend void * fl_browser_item_next(BROWSER b, void * item); + friend void * fl_browser_item_prev(BROWSER b, void * item); + friend void * fl_browser_item_at(BROWSER b, int index); + friend void fl_browser_item_select(BROWSER b, void * item, int val); + friend int fl_browser_item_selected(BROWSER b, void * item); + friend void fl_browser_item_swap(BROWSER b, void * x, void * y); + friend const char * fl_browser_item_text(BROWSER b, void * item); + friend void fl_browser_item_draw(BROWSER b, void * item, int x, int y, int w, int h); + + friend int fl_browser_full_width(BROWSER c); + friend int fl_browser_full_height(BROWSER c); + friend int fl_browser_incr_height(BROWSER c); + friend int fl_browser_item_quick_height(BROWSER c, void * i); + + friend void fl_browser_draw(BROWSER b); + + int handle(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 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 + +BROWSER new_fl_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_browser(BROWSER b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Browser*>(b); + } +} + + + + +void fl_browser_add(BROWSER b, const char * text, void * d) { + static_cast<Fl_Browser*>(b)->add(text, d); +} + +void fl_browser_insert(BROWSER b, int line, const char * text, void * d) { + static_cast<Fl_Browser*>(b)->insert(line, text, d); +} + +void fl_browser_move(BROWSER b, int to, int from) { + static_cast<Fl_Browser*>(b)->move(to, from); +} + +void fl_browser_swap(BROWSER b, int x, int y) { + static_cast<Fl_Browser*>(b)->swap(x, y); +} + +void fl_browser_remove(BROWSER b, int line) { + static_cast<Fl_Browser*>(b)->remove(line); +} + +void fl_browser_clear(BROWSER b) { + static_cast<Fl_Browser*>(b)->clear(); +} + +int fl_browser_size(BROWSER b) { + return static_cast<Fl_Browser*>(b)->size(); +} + + + + +int fl_browser_load(BROWSER b, const char * f) { + return static_cast<Fl_Browser*>(b)->load(f); +} + +const char * fl_browser_get_text(BROWSER b, int line) { + return static_cast<Fl_Browser*>(b)->text(line); +} + +void fl_browser_set_text(BROWSER b, int line, const char * text) { + static_cast<Fl_Browser*>(b)->text(line, text); +} + +int fl_browser_get_textsize(BROWSER b) { + return static_cast<Fl_Browser*>(b)->textsize(); +} + +void fl_browser_set_textsize(BROWSER b, int size) { + static_cast<Fl_Browser*>(b)->textsize(size); +} + + + + +char fl_browser_get_column_char(BROWSER b) { + return static_cast<Fl_Browser*>(b)->column_char(); +} + +void fl_browser_set_column_char(BROWSER b, char c) { + static_cast<Fl_Browser*>(b)->column_char(c); +} + +void fl_browser_set_column_widths(BROWSER b, void * w) { + static_cast<Fl_Browser*>(b)->column_widths(static_cast<const int *>(w)); +} + +char fl_browser_get_format_char(BROWSER b) { + return static_cast<Fl_Browser*>(b)->format_char(); +} + +void fl_browser_set_format_char(BROWSER b, char c) { + static_cast<Fl_Browser*>(b)->format_char(c); +} + + + + +int fl_browser_get_topline(BROWSER b) { + return static_cast<Fl_Browser*>(b)->topline(); +} + +void fl_browser_set_topline(BROWSER b, int line) { + static_cast<Fl_Browser*>(b)->topline(line); +} + +void fl_browser_middleline(BROWSER b, int line) { + static_cast<Fl_Browser*>(b)->middleline(line); +} + +void fl_browser_bottomline(BROWSER b, int line) { + static_cast<Fl_Browser*>(b)->bottomline(line); +} + +void fl_browser_lineposition(BROWSER b, int line, int p) { + static_cast<Fl_Browser*>(b)->lineposition + (line, static_cast<Fl_Browser::Fl_Line_Position>(p)); +} + + + + +int fl_browser_select(BROWSER b, int l, int v) { + return static_cast<Fl_Browser*>(b)->select(l, v); +} + +int fl_browser_selected(BROWSER b, int l) { + return static_cast<Fl_Browser*>(b)->selected(l); +} + +int fl_browser_value(BROWSER b) { + return static_cast<Fl_Browser*>(b)->value(); +} + + + + +int fl_browser_visible(BROWSER b, int l) { + return static_cast<Fl_Browser*>(b)->visible(l); +} + +void fl_browser_make_visible(BROWSER b, int l) { + static_cast<Fl_Browser*>(b)->make_visible(l); +} + +int fl_browser_displayed(BROWSER b, int l) { + return static_cast<Fl_Browser*>(b)->displayed(l); +} + +void fl_browser_show_line(BROWSER b, int l) { + static_cast<Fl_Browser*>(b)->show(l); +} + +void fl_browser_hide_line(BROWSER b, int l) { + static_cast<Fl_Browser*>(b)->hide(l); +} + +void fl_browser_show(BROWSER b) { + static_cast<Fl_Browser*>(b)->show(); +} + +void fl_browser_hide(BROWSER b) { + static_cast<Fl_Browser*>(b)->hide(); +} + + + + +void fl_browser_set_size(BROWSER b, int w, int h) { + static_cast<Fl_Browser*>(b)->size(w, h); +} + + + + +void fl_browser_set_icon(BROWSER b, int l, void * c) { + static_cast<Fl_Browser*>(b)->icon(l, static_cast<Fl_Image*>(c)); +} + +void fl_browser_remove_icon(BROWSER b, int l) { + static_cast<Fl_Browser*>(b)->remove_icon(l); +} + + + + +int fl_browser_full_height(BROWSER c) { + return static_cast<My_Browser*>(c)->Fl_Browser::full_height(); +} + +int fl_browser_incr_height(BROWSER c) { + return static_cast<My_Browser*>(c)->Fl_Browser::incr_height(); +} + + + + +int fl_browser_item_width(BROWSER b, void * item) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_width(item); +} + +int fl_browser_item_height(BROWSER b, void * item) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_height(item); +} + +void * fl_browser_item_first(BROWSER b) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_first(); +} + +void * fl_browser_item_last(BROWSER b) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_last(); +} + +void * fl_browser_item_next(BROWSER b, void * item) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_next(item); +} + +void * fl_browser_item_prev(BROWSER b, void * item) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_prev(item); +} + +void * fl_browser_item_at(BROWSER b, int index) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_at(index); +} + +void fl_browser_item_select(BROWSER b, void * item, int val) { + static_cast<My_Browser*>(b)->Fl_Browser::item_select(item, val); +} + +int fl_browser_item_selected(BROWSER b, void * item) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_selected(item); +} + +void fl_browser_item_swap(BROWSER b, void * x, void * y) { + static_cast<My_Browser*>(b)->Fl_Browser::item_swap(x, y); +} + +const char * fl_browser_item_text(BROWSER b, void * item) { + return static_cast<My_Browser*>(b)->Fl_Browser::item_text(item); +} + +void fl_browser_item_draw(BROWSER b, void * item, int x, int y, int w, int h) { + static_cast<My_Browser*>(b)->Fl_Browser::item_draw(item, x, y, w, h); +} + + + + +int fl_browser_lineno(BROWSER b, void * item) { + return (static_cast<Fl_Browser*>(b)->*(&Friend_Browser::lineno))(item); +} + + + + +// These have to be reimplemented due to relying on custom class extensions + + +int fl_browser_full_width(BROWSER c) { + return static_cast<My_Browser*>(c)->Fl_Browser::full_width(); +} + +int fl_browser_item_quick_height(BROWSER c, void * i) { + return static_cast<My_Browser*>(c)->Fl_Browser::item_quick_height(i); +} + + + + +void fl_browser_draw(BROWSER b) { + static_cast<My_Browser*>(b)->Fl_Browser::draw(); +} + +int fl_browser_handle(BROWSER b, int e) { + return static_cast<My_Browser*>(b)->Fl_Browser::handle(e); +} + + diff --git a/body/c_fl_browser.h b/body/c_fl_browser.h new file mode 100644 index 0000000..2729303 --- /dev/null +++ b/body/c_fl_browser.h @@ -0,0 +1,102 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_BROWSER_GUARD +#define FL_BROWSER_GUARD + + +typedef void* BROWSER; + + +extern "C" BROWSER new_fl_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_browser(BROWSER b); + + +extern "C" void fl_browser_add(BROWSER b, const char * text, void * d=0); +extern "C" void fl_browser_insert(BROWSER b, int line, const char * text, void * d=0); +extern "C" void fl_browser_move(BROWSER b, int to, int from); +extern "C" void fl_browser_swap(BROWSER b, int x, int y); +extern "C" void fl_browser_remove(BROWSER b, int line); +extern "C" void fl_browser_clear(BROWSER b); +extern "C" int fl_browser_size(BROWSER b); + + +extern "C" int fl_browser_load(BROWSER b, const char * f); +extern "C" const char * fl_browser_get_text(BROWSER b, int line); +extern "C" void fl_browser_set_text(BROWSER b, int line, const char * text); +extern "C" int fl_browser_get_textsize(BROWSER b); +extern "C" void fl_browser_set_textsize(BROWSER b, int size); + + +extern "C" char fl_browser_get_column_char(BROWSER b); +extern "C" void fl_browser_set_column_char(BROWSER b, char c); +extern "C" void fl_browser_set_column_widths(BROWSER b, void * w); +extern "C" char fl_browser_get_format_char(BROWSER b); +extern "C" void fl_browser_set_format_char(BROWSER b, char c); + + +extern "C" int fl_browser_get_topline(BROWSER b); +extern "C" void fl_browser_set_topline(BROWSER b, int line); +extern "C" void fl_browser_middleline(BROWSER b, int line); +extern "C" void fl_browser_bottomline(BROWSER b, int line); +extern "C" void fl_browser_lineposition(BROWSER b, int line, int p); + + +extern "C" int fl_browser_select(BROWSER b, int l, int v); +extern "C" int fl_browser_selected(BROWSER b, int l); +extern "C" int fl_browser_value(BROWSER b); + + +extern "C" int fl_browser_visible(BROWSER b, int l); +extern "C" void fl_browser_make_visible(BROWSER b, int l); +extern "C" int fl_browser_displayed(BROWSER b, int l); +extern "C" void fl_browser_show_line(BROWSER b, int l); +extern "C" void fl_browser_hide_line(BROWSER b, int l); +extern "C" void fl_browser_show(BROWSER b); +extern "C" void fl_browser_hide(BROWSER b); + + +extern "C" void fl_browser_set_size(BROWSER b, int w, int h); + + +extern "C" void fl_browser_set_icon(BROWSER b, int l, void * c); +extern "C" void fl_browser_remove_icon(BROWSER b, int l); + + +extern "C" int fl_browser_full_height(BROWSER c); +extern "C" int fl_browser_incr_height(BROWSER c); + + +extern "C" int fl_browser_item_width(BROWSER b, void * item); +extern "C" int fl_browser_item_height(BROWSER b, void * item); +extern "C" void * fl_browser_item_first(BROWSER b); +extern "C" void * fl_browser_item_last(BROWSER b); +extern "C" void * fl_browser_item_next(BROWSER b, void * item); +extern "C" void * fl_browser_item_prev(BROWSER b, void * item); +extern "C" void * fl_browser_item_at(BROWSER b, int index); +extern "C" void fl_browser_item_select(BROWSER b, void * item, int val=1); +extern "C" int fl_browser_item_selected(BROWSER b, void * item); +extern "C" void fl_browser_item_swap(BROWSER b, void * x, void * y); +extern "C" const char * fl_browser_item_text(BROWSER b, void * item); +extern "C" void fl_browser_item_draw(BROWSER b, void * item, int x, int y, int w, int h); + + +extern "C" int fl_browser_lineno(BROWSER b, void * item); + + +// reimp below here + +extern "C" int fl_browser_full_width(BROWSER c); +extern "C" int fl_browser_item_quick_height(BROWSER c, void * i); + + +extern "C" void fl_browser_draw(BROWSER b); +extern "C" int fl_browser_handle(BROWSER b, int e); + + +#endif + + diff --git a/body/c_fl_browser_.cpp b/body/c_fl_browser_.cpp new file mode 100644 index 0000000..df65818 --- /dev/null +++ b/body/c_fl_browser_.cpp @@ -0,0 +1,397 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Browser_.H> +#include "c_fl_browser_.h" +#include "c_fl.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); + + + + +// Non-friend protected access + +class Friend_Browser_ : Fl_Browser_ { +public: + using Fl_Browser_::selection; + using Fl_Browser_::displayed; + using Fl_Browser_::find_item; + using Fl_Browser_::top; + + using Fl_Browser_::bbox; + using Fl_Browser_::leftedge; + using Fl_Browser_::redraw_line; + using Fl_Browser_::redraw_lines; + + using Fl_Browser_::new_list; + using Fl_Browser_::inserting; + using Fl_Browser_::deleting; + using Fl_Browser_::replacing; + using Fl_Browser_::swapping; +}; + + + + +// 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 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_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) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Browser_*>(b); + } +} + + + + +void * fl_abstract_browser_hscrollbar(ABSTRACTBROWSER b) { + return &static_cast<Fl_Browser_*>(b)->hscrollbar; +} + +void * fl_abstract_browser_scrollbar(ABSTRACTBROWSER b) { + return &static_cast<Fl_Browser_*>(b)->scrollbar; +} + + + + +int fl_abstract_browser_select(ABSTRACTBROWSER b, void * i, int v, int c) { + return static_cast<Fl_Browser_*>(b)->select(i, v, c); +} + +int fl_abstract_browser_select_only(ABSTRACTBROWSER b, void * i, int c) { + return static_cast<Fl_Browser_*>(b)->select_only(i, c); +} + +void * fl_abstract_browser_selection(ABSTRACTBROWSER b) { + return (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::selection))(); +} + +int fl_abstract_browser_deselect(ABSTRACTBROWSER b, int c) { + return static_cast<Fl_Browser_*>(b)->deselect(c); +} + +void fl_abstract_browser_display(ABSTRACTBROWSER b, void * i) { + static_cast<Fl_Browser_*>(b)->display(i); +} + +int fl_abstract_browser_displayed(ABSTRACTBROWSER b, void * i) { + return (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::displayed))(i); +} + +void * fl_abstract_browser_find_item(ABSTRACTBROWSER b, int y) { + return (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::find_item))(y); +} + +void * fl_abstract_browser_top(ABSTRACTBROWSER b) { + return (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::top))(); +} + +void fl_abstract_browser_sort(ABSTRACTBROWSER b, int f) { + static_cast<Fl_Browser_*>(b)->sort(f); +} + + + + +unsigned char fl_abstract_browser_get_has_scrollbar(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->has_scrollbar(); +} + +void fl_abstract_browser_set_has_scrollbar(ABSTRACTBROWSER b, unsigned char m) { + static_cast<Fl_Browser_*>(b)->has_scrollbar(m); +} + +int fl_abstract_browser_get_hposition(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->hposition(); +} + +void fl_abstract_browser_set_hposition(ABSTRACTBROWSER b, int p) { + static_cast<Fl_Browser_*>(b)->hposition(p); +} + +int fl_abstract_browser_get_position(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->position(); +} + +void fl_abstract_browser_set_position(ABSTRACTBROWSER b, int p) { + static_cast<Fl_Browser_*>(b)->position(p); +} + +void fl_abstract_browser_scrollbar_left(ABSTRACTBROWSER b) { + static_cast<Fl_Browser_*>(b)->scrollbar_left(); +} + +void fl_abstract_browser_scrollbar_right(ABSTRACTBROWSER b) { + static_cast<Fl_Browser_*>(b)->scrollbar_right(); +} + +int fl_abstract_browser_get_scrollbar_size(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->scrollbar_size(); +} + +void fl_abstract_browser_set_scrollbar_size(ABSTRACTBROWSER b, int s) { + static_cast<Fl_Browser_*>(b)->scrollbar_size(s); +} + + + + +unsigned int fl_abstract_browser_get_textcolor(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->textcolor(); +} + +void fl_abstract_browser_set_textcolor(ABSTRACTBROWSER b, unsigned int c) { + static_cast<Fl_Browser_*>(b)->textcolor(c); +} + +int fl_abstract_browser_get_textfont(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->textfont(); +} + +void fl_abstract_browser_set_textfont(ABSTRACTBROWSER b, int f) { + static_cast<Fl_Browser_*>(b)->textfont(f); +} + +int fl_abstract_browser_get_textsize(ABSTRACTBROWSER b) { + return static_cast<Fl_Browser_*>(b)->textsize(); +} + +void fl_abstract_browser_set_textsize(ABSTRACTBROWSER b, int s) { + static_cast<Fl_Browser_*>(b)->textsize(s); +} + + + + +void fl_abstract_browser_resize(ABSTRACTBROWSER b, int x, int y, int w, int h) { + static_cast<Fl_Browser_*>(b)->resize(x, y, w, h); +} + +void fl_abstract_browser_bbox(ABSTRACTBROWSER b, int &x, int &y, int &w, int &h) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::bbox))(x, y, w, h); +} + +int fl_abstract_browser_leftedge(ABSTRACTBROWSER b) { + return (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::leftedge))(); +} + +void fl_abstract_browser_redraw_line(ABSTRACTBROWSER b, void * i) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::redraw_line))(i); +} + +void fl_abstract_browser_redraw_lines(ABSTRACTBROWSER b) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::redraw_lines))(); +} + + + + +int fl_abstract_browser_full_width(ABSTRACTBROWSER b) { + return static_cast<My_Browser_*>(b)->Fl_Browser_::full_width(); +} + +int fl_abstract_browser_full_height(ABSTRACTBROWSER b) { + return static_cast<My_Browser_*>(b)->Fl_Browser_::full_height(); +} + +int fl_abstract_browser_incr_height(ABSTRACTBROWSER b) { + return static_cast<My_Browser_*>(b)->Fl_Browser_::incr_height(); +} + +int fl_abstract_browser_item_quick_height(ABSTRACTBROWSER b, void * i) { + return static_cast<My_Browser_*>(b)->Fl_Browser_::item_quick_height(i); +} + + + + +void fl_abstract_browser_new_list(ABSTRACTBROWSER b) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::new_list))(); +} + +void fl_abstract_browser_inserting(ABSTRACTBROWSER b, void * a1, void * a2) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::inserting))(a1, a2); +} + +void fl_abstract_browser_deleting(ABSTRACTBROWSER b, void * item) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::deleting))(item); +} + +void fl_abstract_browser_replacing(ABSTRACTBROWSER b, void * a1, void * a2) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::replacing))(a1, a2); +} + +void fl_abstract_browser_swapping(ABSTRACTBROWSER b, void * a1, void * a2) { + (static_cast<Fl_Browser_*>(b)->*(&Friend_Browser_::swapping))(a1, a2); +} + + + + +void fl_abstract_browser_draw(ABSTRACTBROWSER b) { + static_cast<My_Browser_*>(b)->Fl_Browser_::draw(); +} + +int fl_abstract_browser_handle(ABSTRACTBROWSER b, int e) { + return static_cast<My_Browser_*>(b)->Fl_Browser_::handle(e); +} + + diff --git a/body/c_fl_browser_.h b/body/c_fl_browser_.h new file mode 100644 index 0000000..ed1157e --- /dev/null +++ b/body/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/body/c_fl_button.cpp b/body/c_fl_button.cpp new file mode 100644 index 0000000..ba08bc9 --- /dev/null +++ b/body/c_fl_button.cpp @@ -0,0 +1,133 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Button.H> +#include "c_fl_button.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void button_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); +void fl_button_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { + button_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Button : Fl_Button { +public: + using Fl_Button::simulate_key_action; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Button : public Fl_Button { +public: + using Fl_Button::Fl_Button; + + friend void fl_button_draw(BUTTON b); + friend int fl_button_handle(BUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +BUTTON new_fl_button(int x, int y, int w, int h, char* label) { + My_Button *b = new My_Button(x, y, w, h, label); + return b; +} + +void free_fl_button(BUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Button*>(b); + } +} + + + + +int fl_button_get_state(BUTTON b) { + return static_cast<Fl_Button*>(b)->Fl_Button::value(); +} + +void fl_button_set_state(BUTTON b, int s) { + static_cast<Fl_Button*>(b)->Fl_Button::value(s); +} + +void fl_button_set_only(BUTTON b) { + static_cast<Fl_Button*>(b)->Fl_Button::setonly(); +} + + + + +int fl_button_get_down_box(BUTTON b) { + return static_cast<Fl_Button*>(b)->Fl_Button::down_box(); +} + +void fl_button_set_down_box(BUTTON b, int t) { + static_cast<Fl_Button*>(b)->Fl_Button::down_box(static_cast<Fl_Boxtype>(t)); +} + +int fl_button_get_shortcut(BUTTON b) { + return static_cast<Fl_Button*>(b)->Fl_Button::shortcut(); +} + +void fl_button_set_shortcut(BUTTON b, int k) { + static_cast<Fl_Button*>(b)->Fl_Button::shortcut(k); +} + + + + +void fl_button_draw(BUTTON b) { + static_cast<My_Button*>(b)->Fl_Button::draw(); +} + +int fl_button_handle(BUTTON b, int e) { + return static_cast<My_Button*>(b)->Fl_Button::handle(e); +} + + + + +void fl_button_simulate_key_action(BUTTON b) { + (static_cast<Fl_Button*>(b)->*(&Friend_Button::simulate_key_action))(); +} + + diff --git a/body/c_fl_button.h b/body/c_fl_button.h new file mode 100644 index 0000000..dfc0631 --- /dev/null +++ b/body/c_fl_button.h @@ -0,0 +1,41 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_BUTTON_GUARD +#define FL_BUTTON_GUARD + + +extern "C" void fl_button_extra_init(void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* BUTTON; + + +extern "C" BUTTON new_fl_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_button(BUTTON b); + + +extern "C" int fl_button_get_state(BUTTON b); +extern "C" void fl_button_set_state(BUTTON b, int s); +extern "C" void fl_button_set_only(BUTTON b); + + +extern "C" int fl_button_get_down_box(BUTTON b); +extern "C" void fl_button_set_down_box(BUTTON b, int t); +extern "C" int fl_button_get_shortcut(BUTTON b); +extern "C" void fl_button_set_shortcut(BUTTON b, int k); + + +extern "C" void fl_button_draw(BUTTON b); +extern "C" int fl_button_handle(BUTTON b, int e); + + +extern "C" void fl_button_simulate_key_action(BUTTON b); + + +#endif + + diff --git a/body/c_fl_cairo_window.cpp b/body/c_fl_cairo_window.cpp new file mode 100644 index 0000000..b4891c6 --- /dev/null +++ b/body/c_fl_cairo_window.cpp @@ -0,0 +1,103 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Cairo_Window.H> +#include <FL/Fl_Double_Window.H> +#include "c_fl_cairo_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Cairo_Window : +#ifdef FLTK_HAVE_CAIRO +public Fl_Cairo_Window +#else +public Fl_Double_Window +#endif +{ +public: +#ifdef FLTK_HAVE_CAIRO + using Fl_Cairo_Window::Fl_Cairo_Window; +#else + using Fl_Double_Window::Fl_Double_Window; +#endif + + friend void fl_cairo_window_draw(CAIROWINDOW w); + + int handle(int e); + void draw(); +}; + + +void My_Cairo_Window::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Cairo_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +CAIROWINDOW new_fl_cairo_window(int w, int h) { + My_Cairo_Window *c = new My_Cairo_Window(w, h); + return c; +} + +void free_fl_cairo_window(CAIROWINDOW w) { + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Cairo_Window*>(w); + } +} + + + + +void fl_cairo_window_set_draw_cb(CAIROWINDOW w, void * cb) { + #ifdef FLTK_HAVE_CAIRO + static_cast<Fl_Cairo_Window*>(w)->set_draw_cb(reinterpret_cast<cairo_draw_cb>(cb)); + #else + (void)(w); + (void)(cb); + #endif +} + + + + +void fl_cairo_window_draw(CAIROWINDOW w) { + #ifdef FLTK_HAVE_CAIRO + static_cast<My_Cairo_Window*>(w)->Fl_Cairo_Window::draw(); + #else + static_cast<My_Cairo_Window*>(w)->Fl_Double_Window::draw(); + #endif +} + +int fl_cairo_window_handle(CAIROWINDOW w, int e) { + #ifdef FLTK_HAVE_CAIRO + return static_cast<My_Cairo_Window*>(w)->Fl_Cairo_Window::handle(e); + #else + return static_cast<My_Cairo_Window*>(w)->Fl_Double_Window::handle(e); + #endif +} + + diff --git a/body/c_fl_cairo_window.h b/body/c_fl_cairo_window.h new file mode 100644 index 0000000..d004d16 --- /dev/null +++ b/body/c_fl_cairo_window.h @@ -0,0 +1,27 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CAIRO_WINDOW_GUARD +#define FL_CAIRO_WINDOW_GUARD + + +typedef void* CAIROWINDOW; + + +extern "C" CAIROWINDOW new_fl_cairo_window(int w, int h); +extern "C" void free_fl_cairo_window(CAIROWINDOW w); + + +extern "C" void fl_cairo_window_set_draw_cb(CAIROWINDOW w, void * cb); + + +extern "C" void fl_cairo_window_draw(CAIROWINDOW w); +extern "C" int fl_cairo_window_handle(CAIROWINDOW w, int e); + + +#endif + + diff --git a/body/c_fl_chart.cpp b/body/c_fl_chart.cpp new file mode 100644 index 0000000..351841f --- /dev/null +++ b/body/c_fl_chart.cpp @@ -0,0 +1,156 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Chart.H> +#include "c_fl_chart.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Chart : public Fl_Chart { +public: + using Fl_Chart::Fl_Chart; + + friend void fl_chart_draw(CHART n); + friend int fl_chart_handle(CHART n, int e); + + void draw(); + int handle(int e); +}; + +void My_Chart::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Chart::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +CHART new_fl_chart(int x, int y, int w, int h, char* label) { + My_Chart *b = new My_Chart(x, y, w, h, label); + return b; +} + +void free_fl_chart(CHART b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Chart*>(b); + } +} + + + + +void fl_chart_add(CHART b, double v, char * s, unsigned int c) { + static_cast<Fl_Chart*>(b)->add(v,s,c); +} + +void fl_chart_insert(CHART b, int i, double v, char * s, unsigned int c) { + static_cast<Fl_Chart*>(b)->insert(i,v,s,c); +} + +void fl_chart_replace(CHART b, int i, double v, char * s, unsigned int c) { + static_cast<Fl_Chart*>(b)->replace(i,v,s,c); +} + +void fl_chart_clear(CHART b) { + static_cast<Fl_Chart*>(b)->clear(); +} + + + + +int fl_chart_get_autosize(CHART b) { + return static_cast<Fl_Chart*>(b)->autosize(); +} + +void fl_chart_set_autosize(CHART b, int a) { + static_cast<Fl_Chart*>(b)->autosize(a); +} + +void fl_chart_get_bounds(CHART b, double * l, double * u) { + static_cast<Fl_Chart*>(b)->bounds(l,u); +} + +void fl_chart_set_bounds(CHART b, double l, double u) { + static_cast<Fl_Chart*>(b)->bounds(l,u); +} + +int fl_chart_get_maxsize(CHART b) { + return static_cast<Fl_Chart*>(b)->maxsize(); +} + +void fl_chart_set_maxsize(CHART b, int m) { + static_cast<Fl_Chart*>(b)->maxsize(m); +} + +int fl_chart_size(CHART b) { + return static_cast<Fl_Chart*>(b)->size(); +} + + + + +void fl_chart_size2(CHART b, int w, int h) { + static_cast<Fl_Chart*>(b)->size(w, h); +} + + + + +unsigned int fl_chart_get_textcolor(CHART b) { + return static_cast<Fl_Chart*>(b)->textcolor(); +} + +void fl_chart_set_textcolor(CHART b, unsigned int c) { + static_cast<Fl_Chart*>(b)->textcolor(c); +} + +int fl_chart_get_textfont(CHART b) { + return static_cast<Fl_Chart*>(b)->textfont(); +} + +void fl_chart_set_textfont(CHART b, int f) { + static_cast<Fl_Chart*>(b)->textfont(f); +} + +int fl_chart_get_textsize(CHART b) { + return static_cast<Fl_Chart*>(b)->textsize(); +} + +void fl_chart_set_textsize(CHART b, int s) { + static_cast<Fl_Chart*>(b)->textsize(s); +} + + + + +void fl_chart_draw(CHART n) { + static_cast<My_Chart*>(n)->Fl_Chart::draw(); +} + +int fl_chart_handle(CHART n, int e) { + return static_cast<My_Chart*>(n)->Fl_Chart::handle(e); +} + + diff --git a/body/c_fl_chart.h b/body/c_fl_chart.h new file mode 100644 index 0000000..bd524c3 --- /dev/null +++ b/body/c_fl_chart.h @@ -0,0 +1,50 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CHART_GUARD +#define FL_CHART_GUARD + + +typedef void* CHART; + + +extern "C" CHART new_fl_chart(int x, int y, int w, int h, char * label); +extern "C" void free_fl_chart(CHART b); + + +extern "C" void fl_chart_add(CHART b, double v, char * s, unsigned int c); +extern "C" void fl_chart_insert(CHART b, int i, double v, char * s, unsigned int c); +extern "C" void fl_chart_replace(CHART b, int i, double v, char * s, unsigned int c); +extern "C" void fl_chart_clear(CHART b); + + +extern "C" int fl_chart_get_autosize(CHART b); +extern "C" void fl_chart_set_autosize(CHART b, int a); +extern "C" void fl_chart_get_bounds(CHART b, double * l, double * u); +extern "C" void fl_chart_set_bounds(CHART b, double l, double u); +extern "C" int fl_chart_get_maxsize(CHART b); +extern "C" void fl_chart_set_maxsize(CHART b, int m); +extern "C" int fl_chart_size(CHART b); + + +extern "C" void fl_chart_size2(CHART b, int w, int h); + + +extern "C" unsigned int fl_chart_get_textcolor(CHART b); +extern "C" void fl_chart_set_textcolor(CHART b, unsigned int c); +extern "C" int fl_chart_get_textfont(CHART b); +extern "C" void fl_chart_set_textfont(CHART b, int f); +extern "C" int fl_chart_get_textsize(CHART b); +extern "C" void fl_chart_set_textsize(CHART b, int s); + + +extern "C" void fl_chart_draw(CHART n); +extern "C" int fl_chart_handle(CHART n, int e); + + +#endif + + diff --git a/body/c_fl_check_browser.cpp b/body/c_fl_check_browser.cpp new file mode 100644 index 0000000..11fafa4 --- /dev/null +++ b/body/c_fl_check_browser.cpp @@ -0,0 +1,341 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Check_Browser.H> +#include <FL/Fl_Browser_.H> +#include "c_fl_check_browser.h" +#include "c_fl.h" + + + + +// 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); + +// These browser_item_* hooks are disabled since if they are used to hook +// into Ada using virtual dispatch then there will be no way to access the +// real Fl_Check_Browser versions once coming back into C++ via C since the +// versions we want to actually use here are private in FLTK because reasons. + +// Should be possible to re-enable in 1.4. + +// 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); + + + + +// Non-friend protected / private access + +class Friend_Browser : Fl_Browser_ { +public: + using Fl_Browser_::item_width; + using Fl_Browser_::item_height; + using Fl_Browser_::item_first; + using Fl_Browser_::item_next; + using Fl_Browser_::item_prev; + using Fl_Browser_::item_select; + using Fl_Browser_::item_selected; + using Fl_Browser_::item_draw; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Check_Browser : public Fl_Check_Browser { +public: + using Fl_Check_Browser::Fl_Check_Browser; + + friend int fl_check_browser_full_width(CHECKBROWSER c); + friend int fl_check_browser_full_height(CHECKBROWSER c); + friend int fl_check_browser_incr_height(CHECKBROWSER c); + friend int fl_check_browser_item_quick_height(CHECKBROWSER c, void * i); + + friend int fl_check_browser_item_width(CHECKBROWSER c, void * i); + friend int fl_check_browser_item_height(CHECKBROWSER c, void * i); + friend void * fl_check_browser_item_first(CHECKBROWSER c); + // item_last goes here + friend void * fl_check_browser_item_next(CHECKBROWSER c, void * i); + friend void * fl_check_browser_item_prev(CHECKBROWSER c, void * i); + // item_at goes here + friend void fl_check_browser_item_select(CHECKBROWSER c, void * i, int v); + friend int fl_check_browser_item_selected(CHECKBROWSER c, void * i); + // item_swap goes here + // item_text goes here + friend void fl_check_browser_item_draw(CHECKBROWSER c, void * item, int x, int y, int w, int h); + + friend void fl_check_browser_draw(CHECKBROWSER c); + friend int fl_check_browser_handle(CHECKBROWSER c, 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_Check_Browser::full_width() const { + return browser_full_width_hook(this->user_data()); +} + +int My_Check_Browser::full_height() const { + return browser_full_height_hook(this->user_data()); +} + +int My_Check_Browser::incr_height() const { + return browser_incr_height_hook(this->user_data()); +} + +int My_Check_Browser::item_quick_height(void * item) const { + return browser_item_quick_height_hook(this->user_data(), item); +} + + +// int My_Check_Browser::item_width(void * item) const { +// return browser_item_width_hook(this->user_data(), item); +// } + +// int My_Check_Browser::item_height(void * item) const { +// return browser_item_height_hook(this->user_data(), item); +// } + +// void * My_Check_Browser::item_first() const { +// return browser_item_first_hook(this->user_data()); +// } + +// void * My_Check_Browser::item_last() const { +// return browser_item_last_hook(this->user_data()); +// } + +// void * My_Check_Browser::item_next(void * item) const { +// return browser_item_next_hook(this->user_data(), item); +// } + +// void * My_Check_Browser::item_prev(void * item) const { +// return browser_item_prev_hook(this->user_data(), item); +// } + +// void * My_Check_Browser::item_at(int index) const { +// return browser_item_at_hook(this->user_data(), index); +// } + +// void My_Check_Browser::item_select(void * item, int val) { +// browser_item_select_hook(this->user_data(), item, val); +// } + +// int My_Check_Browser::item_selected(void * item) const { +// return browser_item_selected_hook(this->user_data(), item); +// } + +// void My_Check_Browser::item_swap(void * a, void * b) { +// browser_item_swap_hook(this->user_data(), a, b); +// } + +// const char * My_Check_Browser::item_text(void * item) const { +// return browser_item_text_hook(this->user_data(), item); +// } + +// void My_Check_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_Check_Browser::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Check_Browser::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +CHECKBROWSER new_fl_check_browser(int x, int y, int w, int h, char * label) { + My_Check_Browser *c = new My_Check_Browser(x, y, w, h, label); + return c; +} + +void free_fl_check_browser(CHECKBROWSER c) { + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Check_Browser*>(c); + } +} + + + + +int fl_check_browser_add(CHECKBROWSER c, const char * s, int b) { + return static_cast<Fl_Check_Browser*>(c)->add(s, b); +} + +int fl_check_browser_remove(CHECKBROWSER c, int i) { + return static_cast<Fl_Check_Browser*>(c)->remove(i); +} + +void fl_check_browser_clear(CHECKBROWSER c) { + static_cast<Fl_Check_Browser*>(c)->clear(); +} + +int fl_check_browser_nitems(CHECKBROWSER c) { + return static_cast<Fl_Check_Browser*>(c)->nitems(); +} + + + + +void fl_check_browser_check_all(CHECKBROWSER c) { + static_cast<Fl_Check_Browser*>(c)->check_all(); +} + +void fl_check_browser_check_none(CHECKBROWSER c) { + static_cast<Fl_Check_Browser*>(c)->check_none(); +} + +int fl_check_browser_get_checked(CHECKBROWSER c, int i) { + return static_cast<Fl_Check_Browser*>(c)->checked(i); +} + +void fl_check_browser_set_checked(CHECKBROWSER c, int i, int b) { + static_cast<Fl_Check_Browser*>(c)->checked(i, b); +} + +int fl_check_browser_nchecked(CHECKBROWSER c) { + return static_cast<Fl_Check_Browser*>(c)->nchecked(); +} + + + + +const char * fl_check_browser_text(CHECKBROWSER c, int i) { + return static_cast<Fl_Check_Browser*>(c)->text(i); +} + +int fl_check_browser_value(CHECKBROWSER c) { + return static_cast<Fl_Check_Browser*>(c)->value(); +} + + + + +int fl_check_browser_full_width(CHECKBROWSER c) { + return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::full_width(); +} + +int fl_check_browser_full_height(CHECKBROWSER c) { + return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::full_height(); +} + +int fl_check_browser_incr_height(CHECKBROWSER c) { + return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::incr_height(); +} + +int fl_check_browser_item_quick_height(CHECKBROWSER c, void * i) { + return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_quick_height(i); +} + + + + +int fl_check_browser_item_width(CHECKBROWSER c, void * i) { + return (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_width))(i); + // return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_width(i); +} + +int fl_check_browser_item_height(CHECKBROWSER c, void * i) { + return (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_height))(i); + // return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_height(i); +} + +void * fl_check_browser_item_first(CHECKBROWSER c) { + return (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_first))(); + // return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_first(); +} + +// missing item_last + +void * fl_check_browser_item_next(CHECKBROWSER c, void * i) { + return (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_next))(i); + // return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_next(i); +} + +void * fl_check_browser_item_prev(CHECKBROWSER c, void * i) { + return (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_prev))(i); + // return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_prev(i); +} + +// missing item_at + +void fl_check_browser_item_select(CHECKBROWSER c, void * i, int v) { + (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_select))(i, v); + // static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_select(i, v); +} + +int fl_check_browser_item_selected(CHECKBROWSER c, void * i) { + return (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_selected))(i); + // return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_selected(i); +} + +// missing item_swap +// missing item_text + +void fl_check_browser_item_draw(CHECKBROWSER c, void * item, int x, int y, int w, int h) { + (static_cast<Fl_Check_Browser*>(c)->*(&Friend_Browser::item_draw))(item, x, y, w, h); + // static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::item_draw(item, x, y, w, h); +} + + + + +void fl_check_browser_draw(CHECKBROWSER c) { + static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::draw(); +} + +int fl_check_browser_handle(CHECKBROWSER c, int e) { + return static_cast<My_Check_Browser*>(c)->Fl_Check_Browser::handle(e); +} + + diff --git a/body/c_fl_check_browser.h b/body/c_fl_check_browser.h new file mode 100644 index 0000000..e9e832e --- /dev/null +++ b/body/c_fl_check_browser.h @@ -0,0 +1,61 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CHECK_BROWSER_GUARD +#define FL_CHECK_BROWSER_GUARD + + +typedef void* CHECKBROWSER; + + +extern "C" CHECKBROWSER new_fl_check_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_check_browser(CHECKBROWSER c); + + +extern "C" int fl_check_browser_add(CHECKBROWSER c, const char * s, int b); +extern "C" int fl_check_browser_remove(CHECKBROWSER c, int i); +extern "C" void fl_check_browser_clear(CHECKBROWSER c); +extern "C" int fl_check_browser_nitems(CHECKBROWSER c); + + +extern "C" void fl_check_browser_check_all(CHECKBROWSER c); +extern "C" void fl_check_browser_check_none(CHECKBROWSER c); +extern "C" int fl_check_browser_get_checked(CHECKBROWSER c, int i); +extern "C" void fl_check_browser_set_checked(CHECKBROWSER c, int i, int b); +extern "C" int fl_check_browser_nchecked(CHECKBROWSER c); + + +extern "C" const char * fl_check_browser_text(CHECKBROWSER c, int i); +extern "C" int fl_check_browser_value(CHECKBROWSER c); + + +extern "C" int fl_check_browser_full_width(CHECKBROWSER c); +extern "C" int fl_check_browser_full_height(CHECKBROWSER c); +extern "C" int fl_check_browser_incr_height(CHECKBROWSER c); +extern "C" int fl_check_browser_item_quick_height(CHECKBROWSER c, void * i); + + +extern "C" int fl_check_browser_item_width(CHECKBROWSER c, void * i); +extern "C" int fl_check_browser_item_height(CHECKBROWSER c, void * i); +extern "C" void * fl_check_browser_item_first(CHECKBROWSER c); +// missing item_last +extern "C" void * fl_check_browser_item_next(CHECKBROWSER c, void * i); +extern "C" void * fl_check_browser_item_prev(CHECKBROWSER c, void * i); +// missing item_at +extern "C" void fl_check_browser_item_select(CHECKBROWSER c, void * i, int v); +extern "C" int fl_check_browser_item_selected(CHECKBROWSER c, void * i); +// missing item_swap +// missing item_text +extern "C" void fl_check_browser_item_draw(CHECKBROWSER c, void * item, int x, int y, int w, int h); + + +extern "C" void fl_check_browser_draw(CHECKBROWSER c); +extern "C" int fl_check_browser_handle(CHECKBROWSER c, int e); + + +#endif + + diff --git a/body/c_fl_check_button.cpp b/body/c_fl_check_button.cpp new file mode 100644 index 0000000..f590aa0 --- /dev/null +++ b/body/c_fl_check_button.cpp @@ -0,0 +1,83 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Check_Button.H> +#include "c_fl_check_button.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void check_button_extra_init_hook + (void * aobj, int x, int y, int w, int h, const char * l); +void fl_check_button_extra_init (void * adaobj, int x, int y, int w, int h, const char * label) { + check_button_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +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_Check_Button : public Fl_Check_Button { +public: + using Fl_Check_Button::Fl_Check_Button; + + friend void fl_check_button_draw(CHECKBUTTON b); + friend int fl_check_button_handle(CHECKBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Check_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Check_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +CHECKBUTTON new_fl_check_button(int x, int y, int w, int h, char* label) { + My_Check_Button *b = new My_Check_Button(x, y, w, h, label); + return b; +} + +void free_fl_check_button(CHECKBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Check_Button*>(b); + } +} + + + + +void fl_check_button_draw(CHECKBUTTON b) { + static_cast<My_Check_Button*>(b)->Fl_Check_Button::draw(); +} + +int fl_check_button_handle(CHECKBUTTON b, int e) { + return static_cast<My_Check_Button*>(b)->Fl_Check_Button::handle(e); +} + + diff --git a/body/c_fl_check_button.h b/body/c_fl_check_button.h new file mode 100644 index 0000000..88f1a00 --- /dev/null +++ b/body/c_fl_check_button.h @@ -0,0 +1,28 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CHECK_BUTTON_GUARD +#define FL_CHECK_BUTTON_GUARD + + +extern "C" void fl_check_button_extra_init + (void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* CHECKBUTTON; + + +extern "C" CHECKBUTTON new_fl_check_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_check_button(CHECKBUTTON b); + + +extern "C" void fl_check_button_draw(CHECKBUTTON b); +extern "C" int fl_check_button_handle(CHECKBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_choice.cpp b/body/c_fl_choice.cpp new file mode 100644 index 0000000..e4471e5 --- /dev/null +++ b/body/c_fl_choice.cpp @@ -0,0 +1,87 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Choice.H> +#include "c_fl_choice.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Choice : public Fl_Choice { +public: + using Fl_Choice::Fl_Choice; + + friend void fl_choice_draw(CHOICE n); + friend int fl_choice_handle(CHOICE n, int e); + + void draw(); + int handle(int e); +}; + +void My_Choice::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Choice::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +CHOICE new_fl_choice(int x, int y, int w, int h, char* label) { + My_Choice *b = new My_Choice(x, y, w, h, label); + return b; +} + +void free_fl_choice(CHOICE b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Choice*>(b); + } +} + + + + +int fl_choice_value(CHOICE c) { + return static_cast<Fl_Choice*>(c)->value(); +} + +int fl_choice_set_value(CHOICE c, void * i) { + return static_cast<Fl_Choice*>(c)->value(static_cast<Fl_Menu_Item*>(i)); +} + +int fl_choice_set_value2(CHOICE c, int p) { + return static_cast<Fl_Choice*>(c)->value(p); +} + + + + +void fl_choice_draw(CHOICE n) { + static_cast<My_Choice*>(n)->Fl_Choice::draw(); +} + +int fl_choice_handle(CHOICE n, int e) { + return static_cast<My_Choice*>(n)->Fl_Choice::handle(e); +} + + diff --git a/body/c_fl_choice.h b/body/c_fl_choice.h new file mode 100644 index 0000000..031e67e --- /dev/null +++ b/body/c_fl_choice.h @@ -0,0 +1,29 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CHOICE_GUARD +#define FL_CHOICE_GUARD + + +typedef void* CHOICE; + + +extern "C" CHOICE new_fl_choice(int x, int y, int w, int h, char * label); +extern "C" void free_fl_choice(CHOICE b); + + +extern "C" int fl_choice_value(CHOICE c); +extern "C" int fl_choice_set_value(CHOICE c, void * i); +extern "C" int fl_choice_set_value2(CHOICE c, int p); + + +extern "C" void fl_choice_draw(CHOICE n); +extern "C" int fl_choice_handle(CHOICE n, int e); + + +#endif + + diff --git a/body/c_fl_clock.cpp b/body/c_fl_clock.cpp new file mode 100644 index 0000000..2828f9e --- /dev/null +++ b/body/c_fl_clock.cpp @@ -0,0 +1,77 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Clock.H> +#include "c_fl_clock.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Clock : public Fl_Clock { +public: + using Fl_Clock::Fl_Clock; + + friend void fl_clock_draw(CLOCK c); + friend int fl_clock_handle(CLOCK c, int e); + + void draw(); + int handle(int e); +}; + +void My_Clock::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Clock::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +CLOCK new_fl_clock(int x, int y, int w, int h, char* label) { + My_Clock *c = new My_Clock(x, y, w, h, label); + return c; +} + +CLOCK new_fl_clock2(unsigned char k, int x, int y, int w, int h, char* label) { + My_Clock *c = new My_Clock(k,x,y,w,h,label); + return c; +} + +void free_fl_clock(CLOCK c) { + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Clock*>(c); + } +} + + + + +void fl_clock_draw(CLOCK c) { + static_cast<My_Clock*>(c)->Fl_Clock::draw(); +} + +int fl_clock_handle(CLOCK c, int e) { + return static_cast<My_Clock*>(c)->Fl_Clock::handle(e); +} + + diff --git a/body/c_fl_clock.h b/body/c_fl_clock.h new file mode 100644 index 0000000..4b07d7e --- /dev/null +++ b/body/c_fl_clock.h @@ -0,0 +1,25 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CLOCK_GUARD +#define FL_CLOCK_GUARD + + +typedef void* CLOCK; + + +extern "C" CLOCK new_fl_clock(int x, int y, int w, int h, char* label); +extern "C" CLOCK new_fl_clock2(unsigned char k, int x, int y, int w, int h, char* label); +extern "C" void free_fl_clock(CLOCK c); + + +extern "C" void fl_clock_draw(CLOCK c); +extern "C" int fl_clock_handle(CLOCK c, int e); + + +#endif + + diff --git a/body/c_fl_clock_output.cpp b/body/c_fl_clock_output.cpp new file mode 100644 index 0000000..7e977f3 --- /dev/null +++ b/body/c_fl_clock_output.cpp @@ -0,0 +1,116 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Clock.H> +#include "c_fl_clock_output.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Clock_Output : Fl_Clock_Output { +public: + // Really only needed for the (int,int,int,int) version + using Fl_Clock_Output::draw; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Clock_Output : public Fl_Clock_Output { +public: + using Fl_Clock_Output::Fl_Clock_Output; + + friend void fl_clock_output_draw(CLOCKOUTPUT c); + friend int fl_clock_output_handle(CLOCKOUTPUT c, int e); + + void draw(); + int handle(int e); +}; + +void My_Clock_Output::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Clock_Output::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +CLOCKOUTPUT new_fl_clock_output(int x, int y, int w, int h, char* label) { + My_Clock_Output *c = new My_Clock_Output(x, y, w, h, label); + return c; +} + +void free_fl_clock_output(CLOCKOUTPUT c) { + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Clock_Output*>(c); + } +} + + + + +int fl_clock_output_get_hour(CLOCKOUTPUT c) { + return static_cast<Fl_Clock_Output*>(c)->Fl_Clock_Output::hour(); +} + +int fl_clock_output_get_minute(CLOCKOUTPUT c) { + return static_cast<Fl_Clock_Output*>(c)->Fl_Clock_Output::minute(); +} + +int fl_clock_output_get_second(CLOCKOUTPUT c) { + return static_cast<Fl_Clock_Output*>(c)->Fl_Clock_Output::second(); +} + + +unsigned long fl_clock_output_get_value(CLOCKOUTPUT c) { + return static_cast<Fl_Clock_Output*>(c)->Fl_Clock_Output::value(); +} + +void fl_clock_output_set_value(CLOCKOUTPUT c, unsigned long v) { + static_cast<Fl_Clock_Output*>(c)->Fl_Clock_Output::value(v); +} + +void fl_clock_output_set_value2(CLOCKOUTPUT c, int h, int m, int s) { + static_cast<Fl_Clock_Output*>(c)->Fl_Clock_Output::value(h,m,s); +} + + + + +void fl_clock_output_draw(CLOCKOUTPUT c) { + static_cast<My_Clock_Output*>(c)->Fl_Clock_Output::draw(); +} + +void fl_clock_output_draw2(CLOCKOUTPUT c, int x, int y, int w, int h) { + void (Fl_Clock_Output::*mydraw)(int,int,int,int) = &Friend_Clock_Output::draw; + (static_cast<Fl_Clock_Output*>(c)->*mydraw)(x, y, w, h); +} + +int fl_clock_output_handle(CLOCKOUTPUT c, int e) { + return static_cast<My_Clock_Output*>(c)->Fl_Clock_Output::handle(e); +} + + diff --git a/body/c_fl_clock_output.h b/body/c_fl_clock_output.h new file mode 100644 index 0000000..6098b25 --- /dev/null +++ b/body/c_fl_clock_output.h @@ -0,0 +1,35 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_CLOCK_OUTPUT_GUARD +#define FL_CLOCK_OUTPUT_GUARD + + +typedef void* CLOCKOUTPUT; + + +extern "C" CLOCKOUTPUT new_fl_clock_output(int x, int y, int w, int h, char* label); +extern "C" void free_fl_clock_output(CLOCKOUTPUT c); + + +extern "C" int fl_clock_output_get_hour(CLOCKOUTPUT c); +extern "C" int fl_clock_output_get_minute(CLOCKOUTPUT c); +extern "C" int fl_clock_output_get_second(CLOCKOUTPUT c); + + +extern "C" unsigned long fl_clock_output_get_value(CLOCKOUTPUT c); +extern "C" void fl_clock_output_set_value(CLOCKOUTPUT c, unsigned long v); +extern "C" void fl_clock_output_set_value2(CLOCKOUTPUT c, int h, int m, int s); + + +extern "C" void fl_clock_output_draw(CLOCKOUTPUT c); +extern "C" void fl_clock_output_draw2(CLOCKOUTPUT c, int x, int y, int w, int h); +extern "C" int fl_clock_output_handle(CLOCKOUTPUT c, int e); + + +#endif + + diff --git a/body/c_fl_color_chooser.cpp b/body/c_fl_color_chooser.cpp new file mode 100644 index 0000000..8f54437 --- /dev/null +++ b/body/c_fl_color_chooser.cpp @@ -0,0 +1,132 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Color_Chooser.H> +#include "c_fl_color_chooser.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Color_Chooser : public Fl_Color_Chooser { +public: + using Fl_Color_Chooser::Fl_Color_Chooser; + + friend void fl_color_chooser_draw(COLORCHOOSER n); + friend int fl_color_chooser_handle(COLORCHOOSER n, int e); + + void draw(); + int handle(int e); +}; + +void My_Color_Chooser::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Color_Chooser::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +COLORCHOOSER new_fl_color_chooser(int x, int y, int w, int h, char* label) { + My_Color_Chooser *n = new My_Color_Chooser(x, y, w, h, label); + return n; +} + +void free_fl_color_chooser(COLORCHOOSER n) { + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Color_Chooser*>(n); + } +} + + + + +double fl_color_chooser_r(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->r(); +} + +double fl_color_chooser_g(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->g(); +} + +double fl_color_chooser_b(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->b(); +} + +int fl_color_chooser_rgb(COLORCHOOSER n, int r, int g, int b) { + return static_cast<Fl_Color_Chooser*>(n)->rgb(r,g,b); +} + + + + +double fl_color_chooser_hue(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->hue(); +} + +double fl_color_chooser_saturation(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->saturation(); +} + +double fl_color_chooser_value(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->value(); +} + +int fl_color_chooser_hsv(COLORCHOOSER n, int h, int s, int v) { + return static_cast<Fl_Color_Chooser*>(n)->hsv(h,s,v); +} + + + + +void fl_color_chooser_hsv2rgb(double h, double s, double v, double &r, double &g, double &b) { + Fl_Color_Chooser::hsv2rgb(h,s,v,r,g,b); +} + +void fl_color_chooser_rgb2hsv(double r, double g, double b, double &h, double &s, double &v) { + Fl_Color_Chooser::rgb2hsv(r,g,b,h,s,v); +} + + + + +int fl_color_chooser_get_mode(COLORCHOOSER n) { + return static_cast<Fl_Color_Chooser*>(n)->mode(); +} + +void fl_color_chooser_set_mode(COLORCHOOSER n, int m) { + static_cast<Fl_Color_Chooser*>(n)->mode(m); +} + + + + +void fl_color_chooser_draw(COLORCHOOSER n) { + static_cast<My_Color_Chooser*>(n)->Fl_Color_Chooser::draw(); +} + +int fl_color_chooser_handle(COLORCHOOSER n, int e) { + return static_cast<My_Color_Chooser*>(n)->Fl_Color_Chooser::handle(e); +} + + diff --git a/body/c_fl_color_chooser.h b/body/c_fl_color_chooser.h new file mode 100644 index 0000000..22f9bc7 --- /dev/null +++ b/body/c_fl_color_chooser.h @@ -0,0 +1,46 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_COLOR_CHOOSER_GUARD +#define FL_COLOR_CHOOSER_GUARD + + +typedef void* COLORCHOOSER; + + +extern "C" COLORCHOOSER new_fl_color_chooser(int x, int y, int w, int h, char* label); +extern "C" void free_fl_color_chooser(COLORCHOOSER n); + + +extern "C" double fl_color_chooser_r(COLORCHOOSER n); +extern "C" double fl_color_chooser_g(COLORCHOOSER n); +extern "C" double fl_color_chooser_b(COLORCHOOSER n); +extern "C" int fl_color_chooser_rgb(COLORCHOOSER n, int r, int g, int b); + + +extern "C" double fl_color_chooser_hue(COLORCHOOSER n); +extern "C" double fl_color_chooser_saturation(COLORCHOOSER n); +extern "C" double fl_color_chooser_value(COLORCHOOSER n); +extern "C" int fl_color_chooser_hsv(COLORCHOOSER n, int h, int s, int v); + + +extern "C" void fl_color_chooser_hsv2rgb + (double h, double s, double v, double &r, double &g, double &b); +extern "C" void fl_color_chooser_rgb2hsv + (double r, double g, double b, double &h, double &s, double &v); + + +extern "C" int fl_color_chooser_get_mode(COLORCHOOSER n); +extern "C" void fl_color_chooser_set_mode(COLORCHOOSER n, int m); + + +extern "C" void fl_color_chooser_draw(COLORCHOOSER n); +extern "C" int fl_color_chooser_handle(COLORCHOOSER n, int e); + + +#endif + + diff --git a/body/c_fl_copy_surface.cpp b/body/c_fl_copy_surface.cpp new file mode 100644 index 0000000..a13b314 --- /dev/null +++ b/body/c_fl_copy_surface.cpp @@ -0,0 +1,55 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Copy_Surface.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Window.H> +#include "c_fl_copy_surface.h" + + + + +// Flattened C API + +COPYSURFACE new_fl_copy_surface(int w, int h) { + Fl_Copy_Surface *c = new Fl_Copy_Surface(w,h); + return c; +} + +void free_fl_copy_surface(COPYSURFACE c) { + delete static_cast<Fl_Copy_Surface*>(c); +} + + + + +int fl_copy_surface_get_w(COPYSURFACE c) { + return static_cast<Fl_Copy_Surface*>(c)->w(); +} + +int fl_copy_surface_get_h(COPYSURFACE c) { + return static_cast<Fl_Copy_Surface*>(c)->h(); +} + + + + +void fl_copy_surface_draw(COPYSURFACE c, void * w, int dx, int dy) { + static_cast<Fl_Copy_Surface*>(c)->draw(static_cast<Fl_Widget*>(w),dx,dy); +} + +void fl_copy_surface_draw_decorated_window(COPYSURFACE c, void * w, int dx, int dy) { + static_cast<Fl_Copy_Surface*>(c)->draw_decorated_window(static_cast<Fl_Window*>(w),dx,dy); +} + + + + +void fl_copy_surface_set_current(COPYSURFACE c) { + static_cast<Fl_Copy_Surface*>(c)->set_current(); +} + + diff --git a/body/c_fl_copy_surface.h b/body/c_fl_copy_surface.h new file mode 100644 index 0000000..81d14b8 --- /dev/null +++ b/body/c_fl_copy_surface.h @@ -0,0 +1,31 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_COPY_SURFACE_GUARD +#define CL_COPY_SURFACE_GUARD + + +typedef void* COPYSURFACE; + + +extern "C" COPYSURFACE new_fl_copy_surface(int w, int h); +extern "C" void free_fl_copy_surface(COPYSURFACE c); + + +extern "C" int fl_copy_surface_get_w(COPYSURFACE c); +extern "C" int fl_copy_surface_get_h(COPYSURFACE c); + + +extern "C" void fl_copy_surface_draw(COPYSURFACE c, void * w, int dx, int dy); +extern "C" void fl_copy_surface_draw_decorated_window(COPYSURFACE c, void * w, int dx, int dy); + + +extern "C" void fl_copy_surface_set_current(COPYSURFACE c); + + +#endif + + diff --git a/body/c_fl_counter.cpp b/body/c_fl_counter.cpp new file mode 100644 index 0000000..086a41d --- /dev/null +++ b/body/c_fl_counter.cpp @@ -0,0 +1,125 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Counter.H> +#include "c_fl_counter.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Counter : public Fl_Counter { +public: + using Fl_Counter::Fl_Counter; + + friend void fl_counter_draw(COUNTER c); + friend int fl_counter_handle(COUNTER c, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Counter::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Counter::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Counter::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +COUNTER new_fl_counter(int x, int y, int w, int h, char* label) { + My_Counter *c = new My_Counter(x, y, w, h, label); + return c; +} + +void free_fl_counter(COUNTER c) { + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Counter*>(c); + } +} + + + + +double fl_counter_get_step(COUNTER c) { + return static_cast<Fl_Counter*>(c)->step(); +} + +void fl_counter_set_step_top(COUNTER c, double t) { + static_cast<Fl_Counter*>(c)->step(t); +} + +void fl_counter_set_lstep(COUNTER c, double t) { + static_cast<Fl_Counter*>(c)->lstep(t); +} + +void fl_counter_set_step_both(COUNTER c, double s, double l) { + static_cast<Fl_Counter*>(c)->step(s, l); +} + + + + +unsigned int fl_counter_get_textcolor(COUNTER c) { + return static_cast<Fl_Counter*>(c)->textcolor(); +} + +void fl_counter_set_textcolor(COUNTER c, unsigned int t) { + static_cast<Fl_Counter*>(c)->textcolor(t); +} + +int fl_counter_get_textfont(COUNTER c) { + return static_cast<Fl_Counter*>(c)->textfont(); +} + +void fl_counter_set_textfont(COUNTER c, int t) { + static_cast<Fl_Counter*>(c)->textfont(t); +} + +int fl_counter_get_textsize(COUNTER c) { + return static_cast<Fl_Counter*>(c)->textsize(); +} + +void fl_counter_set_textsize(COUNTER c, int t) { + static_cast<Fl_Counter*>(c)->textsize(t); +} + + + + +void fl_counter_draw(COUNTER c) { + static_cast<My_Counter*>(c)->Fl_Counter::draw(); +} + +int fl_counter_handle(COUNTER c, int e) { + return static_cast<My_Counter*>(c)->Fl_Counter::handle(e); +} + + diff --git a/body/c_fl_counter.h b/body/c_fl_counter.h new file mode 100644 index 0000000..b5b4a8b --- /dev/null +++ b/body/c_fl_counter.h @@ -0,0 +1,38 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_COUNTER_GUARD +#define FL_COUNTER_GUARD + + +typedef void* COUNTER; + + +extern "C" COUNTER new_fl_counter(int x, int y, int w, int h, char* label); +extern "C" void free_fl_counter(COUNTER c); + + +extern "C" double fl_counter_get_step(COUNTER c); +extern "C" void fl_counter_set_step_top(COUNTER c, double t); +extern "C" void fl_counter_set_lstep(COUNTER c, double t); +extern "C" void fl_counter_set_step_both(COUNTER c, double s, double l); + + +extern "C" unsigned int fl_counter_get_textcolor(COUNTER c); +extern "C" void fl_counter_set_textcolor(COUNTER c, unsigned int t); +extern "C" int fl_counter_get_textfont(COUNTER c); +extern "C" void fl_counter_set_textfont(COUNTER c, int t); +extern "C" int fl_counter_get_textsize(COUNTER c); +extern "C" void fl_counter_set_textsize(COUNTER c, int t); + + +extern "C" void fl_counter_draw(COUNTER c); +extern "C" int fl_counter_handle(COUNTER c, int e); + + +#endif + + diff --git a/body/c_fl_dial.cpp b/body/c_fl_dial.cpp new file mode 100644 index 0000000..6bc5368 --- /dev/null +++ b/body/c_fl_dial.cpp @@ -0,0 +1,124 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Dial.H> +#include "c_fl_dial.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Non-friend protected access + +class Friend_Dial : Fl_Dial { +public: + // Really only needed for the (int,int,int,int) versions + using Fl_Dial::draw; + using Fl_Dial::handle; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Dial : public Fl_Dial { +public: + using Fl_Dial::Fl_Dial; + + friend void fl_dial_draw(DIAL v); + friend int fl_dial_handle(DIAL v, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Dial::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Dial::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Dial::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +DIAL new_fl_dial(int x, int y, int w, int h, char* label) { + My_Dial *v = new My_Dial(x, y, w, h, label); + return v; +} + +void free_fl_dial(DIAL v) { + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Dial*>(v); + } +} + + + + +short fl_dial_get_angle1(DIAL v) { + return static_cast<Fl_Dial*>(v)->angle1(); +} + +void fl_dial_set_angle1(DIAL v, short t) { + static_cast<Fl_Dial*>(v)->angle1(t); +} + +short fl_dial_get_angle2(DIAL v) { + return static_cast<Fl_Dial*>(v)->angle2(); +} + +void fl_dial_set_angle2(DIAL v, short t) { + static_cast<Fl_Dial*>(v)->angle2(t); +} + +void fl_dial_set_angles(DIAL v, short a, short b) { + static_cast<Fl_Dial*>(v)->angles(a,b); +} + + + + +void fl_dial_draw(DIAL v) { + static_cast<My_Dial*>(v)->Fl_Dial::draw(); +} + +void fl_dial_draw2(DIAL v, int x, int y, int w, int h) { + void (Fl_Dial::*mydraw)(int,int,int,int) = &Friend_Dial::draw; + (static_cast<Fl_Dial*>(v)->*mydraw)(x, y, w, h); +} + +int fl_dial_handle(DIAL v, int e) { + return static_cast<My_Dial*>(v)->Fl_Dial::handle(e); +} + +int fl_dial_handle2(DIAL v, int e, int x, int y, int w, int h) { + int (Fl_Dial::*myhandle)(int,int,int,int,int) = &Friend_Dial::handle; + return (static_cast<Fl_Dial*>(v)->*myhandle)(e, x, y, w, h); +} + + diff --git a/body/c_fl_dial.h b/body/c_fl_dial.h new file mode 100644 index 0000000..b642abd --- /dev/null +++ b/body/c_fl_dial.h @@ -0,0 +1,33 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_DIAL_GUARD +#define FL_DIAL_GUARD + + +typedef void* DIAL; + + +extern "C" DIAL new_fl_dial(int x, int y, int w, int h, char* label); +extern "C" void free_fl_dial(DIAL v); + + +extern "C" short fl_dial_get_angle1(DIAL v); +extern "C" void fl_dial_set_angle1(DIAL v, short t); +extern "C" short fl_dial_get_angle2(DIAL v); +extern "C" void fl_dial_set_angle2(DIAL v, short t); +extern "C" void fl_dial_set_angles(DIAL v, short a, short b); + + +extern "C" void fl_dial_draw(DIAL v); +extern "C" void fl_dial_draw2(DIAL v, int x, int y, int w, int h); +extern "C" int fl_dial_handle(DIAL v, int e); +extern "C" int fl_dial_handle2(DIAL v, int e, int x, int y, int w, int h); + + +#endif + + diff --git a/body/c_fl_display_device.cpp b/body/c_fl_display_device.cpp new file mode 100644 index 0000000..f4f53bf --- /dev/null +++ b/body/c_fl_display_device.cpp @@ -0,0 +1,29 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Device.H> +#include "c_fl_display_device.h" + + + + +DISPLAYDEVICE new_fl_display_device(void * g) { + Fl_Display_Device *d = new Fl_Display_Device(static_cast<Fl_Graphics_Driver*>(g)); + return d; +} + +void free_fl_display_device(DISPLAYDEVICE d) { + delete static_cast<Fl_Display_Device*>(d); +} + + + + +DISPLAYDEVICE fl_display_device_display_device() { + return Fl_Display_Device::display_device(); +} + + diff --git a/body/c_fl_display_device.h b/body/c_fl_display_device.h new file mode 100644 index 0000000..1cf530c --- /dev/null +++ b/body/c_fl_display_device.h @@ -0,0 +1,23 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_DISPLAY_DEVICE_GUARD +#define FL_DISPLAY_DEVICE_GUARD + + +typedef void* DISPLAYDEVICE; + + +extern "C" DISPLAYDEVICE new_fl_display_device(void * g); +extern "C" void free_fl_display_device(DISPLAYDEVICE d); + + +extern "C" DISPLAYDEVICE fl_display_device_display_device(); + + +#endif + + diff --git a/body/c_fl_double_window.cpp b/body/c_fl_double_window.cpp new file mode 100644 index 0000000..bc9c48f --- /dev/null +++ b/body/c_fl_double_window.cpp @@ -0,0 +1,119 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Double_Window.H> +#include "c_fl_double_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Double_Window : Fl_Double_Window { +public: + // Only needed for the (int) version + using Fl_Double_Window::flush; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Double_Window : public Fl_Double_Window { +public: + using Fl_Double_Window::Fl_Double_Window; + + friend void fl_double_window_draw(DOUBLEWINDOW n); + friend int fl_double_window_handle(DOUBLEWINDOW n, int e); + + void draw(); + int handle(int e); +}; + +void My_Double_Window::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Double_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +DOUBLEWINDOW new_fl_double_window(int x, int y, int w, int h, char* label) { + My_Double_Window *d = new My_Double_Window(x, y, w, h, label); + return d; +} + +DOUBLEWINDOW new_fl_double_window2(int w, int h, char* label) { + My_Double_Window *d = new My_Double_Window(w, h, label); + return d; +} + +void free_fl_double_window(DOUBLEWINDOW d) { + if (fl_inside_callback) { + fl_delete_widget(d); + } else { + delete static_cast<My_Double_Window*>(d); + } +} + + + + +void fl_double_window_show(DOUBLEWINDOW d) { + static_cast<Fl_Double_Window*>(d)->show(); +} + +void fl_double_window_show2(DOUBLEWINDOW d, int c, void * v) { + static_cast<Fl_Double_Window*>(d)->show(c, static_cast<char**>(v)); +} + +void fl_double_window_hide(DOUBLEWINDOW d) { + static_cast<Fl_Double_Window*>(d)->hide(); +} + +void fl_double_window_flush(DOUBLEWINDOW d) { + static_cast<Fl_Double_Window*>(d)->flush(); +} + +void fl_double_window_flush2(DOUBLEWINDOW d, int e) { + void (Fl_Double_Window::*myflush)(int) = &Friend_Double_Window::flush; + (static_cast<Fl_Double_Window*>(d)->*myflush)(e); +} + + + + +void fl_double_window_resize(DOUBLEWINDOW d, int x, int y, int w, int h) { + static_cast<Fl_Double_Window*>(d)->resize(x, y, w, h); +} + + + + +void fl_double_window_draw(DOUBLEWINDOW n) { + static_cast<My_Double_Window*>(n)->Fl_Double_Window::draw(); +} + +int fl_double_window_handle(DOUBLEWINDOW n, int e) { + return static_cast<My_Double_Window*>(n)->Fl_Double_Window::handle(e); +} + + diff --git a/body/c_fl_double_window.h b/body/c_fl_double_window.h new file mode 100644 index 0000000..c6f4cc8 --- /dev/null +++ b/body/c_fl_double_window.h @@ -0,0 +1,35 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_DOUBLE_WINDOW_GUARD +#define FL_DOUBLE_WINDOW_GUARD + + +typedef void* DOUBLEWINDOW; + + +extern "C" DOUBLEWINDOW new_fl_double_window(int x, int y, int w, int h, char* label); +extern "C" DOUBLEWINDOW new_fl_double_window2(int w, int h, char* label); +extern "C" void free_fl_double_window(DOUBLEWINDOW d); + + +extern "C" void fl_double_window_show(DOUBLEWINDOW d); +extern "C" void fl_double_window_show2(DOUBLEWINDOW d, int c, void * v); +extern "C" void fl_double_window_hide(DOUBLEWINDOW d); +extern "C" void fl_double_window_flush(DOUBLEWINDOW d); +extern "C" void fl_double_window_flush2(DOUBLEWINDOW d, int e); + + +extern "C" void fl_double_window_resize(DOUBLEWINDOW d, int x, int y, int w, int h); + + +extern "C" void fl_double_window_draw(DOUBLEWINDOW n); +extern "C" int fl_double_window_handle(DOUBLEWINDOW n, int e); + + +#endif + + diff --git a/body/c_fl_draw.cpp b/body/c_fl_draw.cpp new file mode 100644 index 0000000..25d7796 --- /dev/null +++ b/body/c_fl_draw.cpp @@ -0,0 +1,457 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/fl_draw.H> +#include <FL/Fl_Window.H> +#include "c_fl_draw.h" + + + + +void fl_draw_reset_spot() { + fl_reset_spot(); +} + +void fl_draw_set_spot(int f, int s, int x, int y, int w, int h, void * ptr) { + fl_set_spot(f, s, x, y, w, h, static_cast<Fl_Window*>(ptr)); +} + +void fl_draw_set_status(int x, int y, int w, int h) { + fl_set_status(x, y, w, h); +} + + + + +int fl_draw_can_do_alpha_blending() { + return fl_can_do_alpha_blending(); +} + +const char * fl_draw_shortcut_label(unsigned int shortcut) { + return fl_shortcut_label(shortcut); +} + + + + +const char * fl_draw_latin1_to_local(const char *t, int n) { + return fl_latin1_to_local(t, n); +} + +const char * fl_draw_local_to_latin1(const char *t, int n) { + return fl_local_to_latin1(t, n); +} + +const char * fl_draw_mac_roman_to_local(const char *t, int n) { + return fl_mac_roman_to_local(t, n); +} + +const char * fl_draw_local_to_mac_roman(const char *t, int n) { + return fl_local_to_mac_roman(t, n); +} + + + + +int fl_draw_clip_box(int x, int y, int w, int h, int &bx, int &by, int &bw, int &bh) { + return fl_clip_box(x, y, w, h, bx, by, bw, bh); +} + +int fl_draw_not_clipped(int x, int y, int w, int h) { + return fl_not_clipped(x, y, w, h); +} + +void fl_draw_pop_clip() { + fl_pop_clip(); +} + +void fl_draw_push_clip(int x, int y, int w, int h) { + fl_push_clip(x, y, w, h); +} + +void fl_draw_push_no_clip() { + fl_push_no_clip(); +} + +void fl_draw_restore_clip() { + fl_restore_clip(); +} + + + + +void fl_draw_overlay_clear() { + fl_overlay_clear(); +} + +void fl_draw_overlay_rect(int x, int y, int w, int h) { + fl_overlay_rect(x, y, w, h); +} + + + + +unsigned int fl_draw_get_color() { + return fl_color(); +} + +void fl_draw_set_color(unsigned int c) { + fl_color(c); +} + +void fl_draw_set_color2(uchar r, uchar g, uchar b) { + fl_color(r, g, b); +} + +void fl_draw_set_cursor(int m) { + fl_cursor((Fl_Cursor)m); +} + +void fl_draw_set_cursor2(int m, unsigned int f, unsigned int b) { + fl_cursor((Fl_Cursor)m, f, b); +} + +unsigned int fl_draw_get_font() { + return (unsigned int)fl_font(); +} + +int fl_draw_size() { + return fl_size(); +} + +void fl_draw_set_font(unsigned int f, int s) { + fl_font((Fl_Font)f, (Fl_Fontsize)s); +} + +int fl_draw_height() { + return fl_height(); +} + +int fl_draw_descent() { + return fl_descent(); +} + +int fl_draw_height2(unsigned int f, int s) { + return fl_height(f, s); +} + +void fl_draw_line_style(int style, int width, char * dashes) { + fl_line_style(style, width, dashes); +} + + + + +void fl_draw_mult_matrix(double a, double b, double c, double d, double x, double y) { + fl_mult_matrix(a, b, c, d, x, y); +} + +void fl_draw_pop_matrix() { + fl_pop_matrix(); +} + +void fl_draw_push_matrix() { + fl_push_matrix(); +} + +void fl_draw_rotate(double d) { + fl_rotate(d); +} + +void fl_draw_scale(double x) { + fl_scale(x); +} + +void fl_draw_scale2(double x, double y) { + fl_scale(x, y); +} + +double fl_draw_transform_dx(double x, double y) { + return fl_transform_dx(x, y); +} + +double fl_draw_transform_dy(double x, double y) { + return fl_transform_dy(x, y); +} + +double fl_draw_transform_x(double x, double y) { + return fl_transform_x(x, y); +} + +double fl_draw_transform_y(double x, double y) { + return fl_transform_y(x, y); +} + +void fl_draw_transformed_vertex(double xf, double yf) { + fl_transformed_vertex(xf, yf); +} + +void fl_draw_translate(double x, double y) { + fl_translate(x, y); +} + +void fl_draw_vertex(double x, double y) { + fl_vertex(x, y); +} + + + + +void fl_draw_draw_image(void * data, int x, int y, int w, int h, int d, int l) { + fl_draw_image(static_cast<uchar*>(data), x, y, w, h, d, l); +} + +void fl_draw_draw_image2(void * func, void * data, int x, int y, int w, int h, int d) { + fl_draw_image(reinterpret_cast<Fl_Draw_Image_Cb>(func), data, x, y, w, h, d); +} + +void fl_draw_draw_image_mono(void * data, int x, int y, int w, int h, int d, int l) { + fl_draw_image_mono(static_cast<uchar*>(data), x, y, w, h, d, l); +} + +void fl_draw_draw_image_mono2(void * func, void * data, int x, int y, int w, int h, int d) { + fl_draw_image_mono(reinterpret_cast<Fl_Draw_Image_Cb>(func), data, x, y, w, h, d); +} + +int fl_draw_draw_pixmap(void * data, int x, int y, unsigned int h) { + return fl_draw_pixmap(static_cast<char * const *>(data), x, y, static_cast<Fl_Color>(h)); +} + +void * fl_draw_read_image(void * data, int x, int y, int w, int h, int alpha) { + return fl_read_image(static_cast<uchar*>(data), x, y, w, h, alpha); +} + + + + +typedef void (sym_hook)(Fl_Color); +typedef sym_hook* sym_hook_p; + +int fl_draw_add_symbol(const char *name, void *func, int scalable) { + return fl_add_symbol(name, reinterpret_cast<sym_hook_p>(func), scalable); +} + +void fl_draw_draw_text(const char *str, int n, int x, int y) { + fl_draw(str, n, x, y); +} + +void fl_draw_draw_text2(const char *str, int x, int y, int w, int h, + unsigned align, void * img, int draw_symbols) { + fl_draw(str, x, y, w, h, (Fl_Align)align, (Fl_Image*)img, draw_symbols); +} + +typedef void (t_hook)(const char *, int ,int ,int); +typedef t_hook* t_hook_p; + +void fl_draw_draw_text3(const char *str, int x, int y, int w, int h, + unsigned align, void * func, void * img, int draw_symbols) { + fl_draw(str, x, y, w, h, (Fl_Align)align, + reinterpret_cast<t_hook_p>(func), (Fl_Image*)img, draw_symbols); +} + +void fl_draw_draw_text4(int angle, const char *str, int n, int x, int y) { + fl_draw(angle, str, n, x, y); +} + +void fl_draw_rtl_draw(const char *str, int n, int x, int y) { + fl_rtl_draw(str, n, x, y); +} + +void fl_draw_draw_box(int bk, int x, int y, int w, int h, unsigned int c) { + fl_draw_box((Fl_Boxtype)bk, x, y, w, h, (Fl_Color)c); +} + +int fl_draw_draw_symbol(const char *label, int x, int y, int w, int h, unsigned int c) { + return fl_draw_symbol(label, x, y, w, h, (Fl_Color)c); +} + +void fl_draw_measure(const char * str, int &w, int &h, int draw_symbols) { + fl_measure(str, w, h, draw_symbols); +} + +typedef void (a_hook)(void *, int, int, int, int); +typedef a_hook* a_hook_p; + +void fl_draw_scroll(int x, int y, int w, int h, int dx, int dy, + void * func, void * data) { + fl_scroll(x, y, w, h, dx, dy, reinterpret_cast<a_hook_p>(func), data); +} + +void fl_draw_text_extents(const char * t, int n, int &dx, int &dy, int &w, int &h) { + fl_text_extents(t, n, dx, dy, w, h); +} + +const char * fl_draw_expand_text(const char * str, char * &buf, int maxbuf, + double maxw, int &n, double &width, int wrap, int symbol) +{ + return fl_expand_text(str, buf, maxbuf, maxw, n, width, wrap, symbol); +} + +double fl_draw_width(const char *txt, int n) { + return fl_width(txt, n); +} + +double fl_draw_width2(unsigned long c) { + return fl_width(c); +} + + + + +void fl_draw_begin_complex_polygon() { + fl_begin_complex_polygon(); +} + +void fl_draw_begin_line() { + fl_begin_line(); +} + +void fl_draw_begin_loop() { + fl_begin_loop(); +} + +void fl_draw_begin_points() { + fl_begin_points(); +} + +void fl_draw_begin_polygon() { + fl_begin_polygon(); +} + + + + +void fl_draw_arc(double x, double y, double r, double start, double end) { + fl_arc(x, y, r, start, end); +} + +void fl_draw_arc2(int x, int y, int w, int h, double a1, double a2) { + fl_arc(x, y, w, h, a1, a2); +} + +// function does not yet exist +// void fl_draw_chord(int x, int y, int w, int h, double a1, double a2) { +// function does not yet exist +// fl_chord(x, y, w, h, a1, a2); +// } + +void fl_draw_circle(double x, double y, double r) { + fl_circle(x, y, r); +} + +void fl_draw_curve(double x0, double y0, double x1, double y1, + double x2, double y2, double x3, double y3) { + fl_curve(x0, y0, x1, y1, x2, y2, x3, y3); +} + +void fl_draw_frame(const char *s, int x, int y, int w, int h) { + fl_frame(s, x, y, w, h); +} + +void fl_draw_gap() { + fl_gap(); +} + +void fl_draw_line(int x0, int y0, int x1, int y1) { + fl_line(x0, y0, x1, y1); +} + +void fl_draw_line2(int x0, int y0, int x1, int y1, int x2, int y2) { + fl_line(x0, y0, x1, y1, x2, y2); +} + +void fl_draw_loop(int x0, int y0, int x1, int y1, int x2, int y2) { + fl_loop(x0, y0, x1, y1, x2, y2); +} + +void fl_draw_loop2(int x0, int y0, int x1, int y1, int x2, int y2, int x3, int y3) { + fl_loop(x0, y0, x1, y1, x2, y2, x3, y3); +} + +void fl_draw_pie(int x, int y, int w, int h, double a1, double a2) { + fl_pie(x, y, w, h, a1, a2); +} + +void fl_draw_point(int x, int y) { + fl_point(x, y); +} + +void fl_draw_polygon(int x0, int y0, int x1, int y1, int x2, int y2) { + fl_polygon(x0, y0, x1, y1, x2, y2); +} + +void fl_draw_polygon2(int x0, int y0, int x1, int y1, int x2, int y2, int x3, int y3) { + fl_polygon(x0, y0, x1, y1, x2, y2, x3, y3); +} + +void fl_draw_rect(int x, int y, int w, int h) { + fl_rect(x, y, w, h); +} + +void fl_draw_rect2(int x, int y, int w, int h, unsigned int c) { + fl_rect(x, y, w, h, c); +} + +void fl_draw_rect_fill(int x, int y, int w, int h) { + fl_rectf(x, y, w, h); +} + +void fl_draw_rect_fill2(int x, int y, int w, int h, unsigned int c) { + fl_rectf(x, y, w, h, (Fl_Color)c); +} + +void fl_draw_rect_fill3(int x, int y, int w, int h, uchar r, uchar g, uchar b) { + fl_rectf(x, y, w, h, r, g, b); +} + +void fl_draw_xy_line(int x0, int y0, int x1) { + fl_xyline(x0, y0, x1); +} + +void fl_draw_xy_line2(int x0, int y0, int x1, int y2) { + fl_xyline(x0, y0, x1, y2); +} + +void fl_draw_xy_line3(int x0, int y0, int x1, int y2, int x3) { + fl_xyline(x0, y0, x1, y2, x3); +} + +void fl_draw_yx_line(int x0, int y0, int y1) { + fl_yxline(x0, y0, y1); +} + +void fl_draw_yx_line2(int x0, int y0, int y1, int x2) { + fl_yxline(x0, y0, y1, x2); +} + +void fl_draw_yx_line3(int x0, int y0, int y1, int x2, int y3) { + fl_yxline(x0, y0, y1, x2, y3); +} + + + + +void fl_draw_end_complex_polygon() { + fl_end_complex_polygon(); +} + +void fl_draw_end_line() { + fl_end_line(); +} + +void fl_draw_end_loop() { + fl_end_loop(); +} + +void fl_draw_end_points() { + fl_end_points(); +} + +void fl_draw_end_polygon() { + fl_end_polygon(); +} + + diff --git a/body/c_fl_draw.h b/body/c_fl_draw.h new file mode 100644 index 0000000..cd1a16d --- /dev/null +++ b/body/c_fl_draw.h @@ -0,0 +1,140 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_DRAW_GUARD +#define FL_DRAW_GUARD + + +extern "C" void fl_draw_reset_spot(); +extern "C" void fl_draw_set_spot(int f, int s, int x, int y, int w, int h, void * ptr); +extern "C" void fl_draw_set_status(int x, int y, int w, int h); + + +extern "C" int fl_draw_can_do_alpha_blending(); +extern "C" const char * fl_draw_shortcut_label(unsigned int shortcut); + + +extern "C" const char * fl_draw_latin1_to_local(const char *t, int n); +extern "C" const char * fl_draw_local_to_latin1(const char *t, int n); +extern "C" const char * fl_draw_mac_roman_to_local(const char *t, int n); +extern "C" const char * fl_draw_local_to_mac_roman(const char *t, int n); + + +extern "C" int fl_draw_clip_box(int x, int y, int w, int h, int &bx, int &by, int &bw, int &bh); +extern "C" int fl_draw_not_clipped(int x, int y, int w, int h); +extern "C" void fl_draw_pop_clip(); +extern "C" void fl_draw_push_clip(int x, int y, int w, int h); +extern "C" void fl_draw_push_no_clip(); +extern "C" void fl_draw_restore_clip(); + + +extern "C" void fl_draw_overlay_clear(); +extern "C" void fl_draw_overlay_rect(int x, int y, int w, int h); + + +extern "C" unsigned int fl_draw_get_color(); +extern "C" void fl_draw_set_color(unsigned int c); +extern "C" void fl_draw_set_color2(uchar r, uchar g, uchar b); +extern "C" void fl_draw_set_cursor(int m); +extern "C" void fl_draw_set_cursor2(int m, unsigned int f, unsigned int b); +extern "C" unsigned int fl_draw_get_font(); +extern "C" int fl_draw_size(); +extern "C" void fl_draw_set_font(unsigned int f, int s); +extern "C" int fl_draw_height(); +extern "C" int fl_draw_descent(); +extern "C" int fl_draw_height2(unsigned int f, int s); +extern "C" void fl_draw_line_style(int style, int width, char * dashes); + + +extern "C" void fl_draw_mult_matrix(double a, double b, double c, double d, double x, double y); +extern "C" void fl_draw_pop_matrix(); +extern "C" void fl_draw_push_matrix(); +extern "C" void fl_draw_rotate(double d); +extern "C" void fl_draw_scale(double x); +extern "C" void fl_draw_scale2(double x, double y); +extern "C" double fl_draw_transform_dx(double x, double y); +extern "C" double fl_draw_transform_dy(double x, double y); +extern "C" double fl_draw_transform_x(double x, double y); +extern "C" double fl_draw_transform_y(double x, double y); +extern "C" void fl_draw_transformed_vertex(double xf, double yf); +extern "C" void fl_draw_translate(double x, double y); +extern "C" void fl_draw_vertex(double x, double y); + + +extern "C" void fl_draw_draw_image(void * data, int x, int y, int w, int h, int d, int l); +extern "C" void fl_draw_draw_image2(void * func, void * data, int x, int y, int w, int h, int d); +extern "C" void fl_draw_draw_image_mono(void * data, int x, int y, int w, int h, int d, int l); +extern "C" void fl_draw_draw_image_mono2(void * func, void * data, int x, int y, int w, int h, int d); +extern "C" int fl_draw_draw_pixmap(void * data, int x, int y, unsigned int h); +extern "C" void * fl_draw_read_image(void * data, int x, int y, int w, int h, int alpha); + + +extern "C" int fl_draw_add_symbol(const char *name, void *func, int scalable); +extern "C" void fl_draw_draw_text(const char *str, int n, int x, int y); +extern "C" void fl_draw_draw_text2(const char *str, int x, int y, int w, int h, + unsigned align, void * img, int draw_symbols); +extern "C" void fl_draw_draw_text3(const char *str, int x, int y, int w, int h, + unsigned align, void * func, void * img, int draw_symbols); +extern "C" void fl_draw_draw_text4(int angle, const char *str, int n, int x, int y); +extern "C" void fl_draw_rtl_draw(const char *str, int n, int x, int y); +extern "C" void fl_draw_draw_box(int bk, int x, int y, int w, int h, unsigned int c); +extern "C" int fl_draw_draw_symbol(const char *label, int x, int y, int w, int h, unsigned int c); +extern "C" void fl_draw_measure(const char * str, int &w, int &h, int draw_symbols); +extern "C" void fl_draw_scroll(int x, int y, int w, int h, int dx, int dy, + void * func, void * data); +extern "C" void fl_draw_text_extents(const char * t, int n, int &dx, int &dy, int &w, int &h); +extern "C" const char * fl_draw_expand_text(const char * str, char * &buf, int maxbuf, + double maxw, int &n, double &width, int wrap, int symbol); +extern "C" double fl_draw_width(const char *txt, int n); +extern "C" double fl_draw_width2(unsigned long c); + + +extern "C" void fl_draw_begin_complex_polygon(); +extern "C" void fl_draw_begin_line(); +extern "C" void fl_draw_begin_loop(); +extern "C" void fl_draw_begin_points(); +extern "C" void fl_draw_begin_polygon(); + + +extern "C" void fl_draw_arc(double x, double y, double r, double start, double end); +extern "C" void fl_draw_arc2(int x, int y, int w, int h, double a1, double a2); +// extern "C" void fl_draw_chord(int x, int y, int w, int h, double a1, double a2); +extern "C" void fl_draw_circle(double x, double y, double r); +extern "C" void fl_draw_curve(double x0, double y0, double x1, double y1, + double x2, double y2, double x3, double y3); +extern "C" void fl_draw_frame(const char *s, int x, int y, int w, int h); +extern "C" void fl_draw_gap(); +extern "C" void fl_draw_line(int x0, int y0, int x1, int y1); +extern "C" void fl_draw_line2(int x0, int y0, int x1, int y1, int x2, int y2); +extern "C" void fl_draw_loop(int x0, int y0, int x1, int y1, int x2, int y2); +extern "C" void fl_draw_loop2(int x0, int y0, int x1, int y1, int x2, int y2, int x3, int y3); +extern "C" void fl_draw_pie(int x, int y, int w, int h, double a1, double a2); +extern "C" void fl_draw_point(int x, int y); +extern "C" void fl_draw_polygon(int x0, int y0, int x1, int y1, int x2, int y2); +extern "C" void fl_draw_polygon2(int x0, int y0, int x1, int y1, int x2, int y2, int x3, int y3); +extern "C" void fl_draw_rect(int x, int y, int w, int h); +extern "C" void fl_draw_rect2(int x, int y, int w, int h, unsigned int c); +extern "C" void fl_draw_rect_fill(int x, int y, int w, int h); +extern "C" void fl_draw_rect_fill2(int x, int y, int w, int h, unsigned int c); +extern "C" void fl_draw_rect_fill3(int x, int y, int w, int h, uchar r, uchar g, uchar b); +extern "C" void fl_draw_xy_line(int x0, int y0, int x1); +extern "C" void fl_draw_xy_line2(int x0, int y0, int x1, int y2); +extern "C" void fl_draw_xy_line3(int x0, int y0, int x1, int y2, int x3); +extern "C" void fl_draw_yx_line(int x0, int y0, int y1); +extern "C" void fl_draw_yx_line2(int x0, int y0, int y1, int x2); +extern "C" void fl_draw_yx_line3(int x0, int y0, int y1, int x2, int y3); + + +extern "C" void fl_draw_end_complex_polygon(); +extern "C" void fl_draw_end_line(); +extern "C" void fl_draw_end_loop(); +extern "C" void fl_draw_end_points(); +extern "C" void fl_draw_end_polygon(); + + +#endif + + diff --git a/body/c_fl_error.cpp b/body/c_fl_error.cpp new file mode 100644 index 0000000..e38481a --- /dev/null +++ b/body/c_fl_error.cpp @@ -0,0 +1,98 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl.H> +#include <errno.h> +#include <stdarg.h> +#include <string.h> +#include "c_fl_error.h" + + + + +// Obtaining general error messages from errno + +char * get_error_message() { + return strerror(errno); +} + + + + +// Exports from Ada + +extern "C" void error_warning_hook(const char * m); +extern "C" void error_error_hook(const char * m); +extern "C" void error_fatal_hook(const char * m); + + +// This is the size used internally in FLTK anyway +const int error_bsize = 1024; + + +// Some prep needed to convert vargs to a single char* + +void warning_hook_prep(const char * m, ...) { + va_list args; + char buf[error_bsize]; + va_start(args, m); + vsnprintf(buf, error_bsize, m, args); + va_end(args); + error_warning_hook(buf); +} + +void error_hook_prep(const char * m, ...) { + va_list args; + char buf[error_bsize]; + va_start(args, m); + vsnprintf(buf, error_bsize, m, args); + va_end(args); + error_error_hook(buf); +} + +void fatal_hook_prep(const char * m, ...) { + va_list args; + char buf[error_bsize]; + va_start(args, m); + vsnprintf(buf, error_bsize, m, args); + va_end(args); + error_fatal_hook(buf); +} + + + + +// Original function pointers + +void (*original_warning)(const char *, ...) = Fl::warning; +void (*original_error)(const char *, ...) = Fl::error; +void (*original_fatal)(const char *, ...) = Fl::fatal; + + +void fl_error_default_warning(const char * m) { + (*original_warning)(m); +} + +void fl_error_default_error(const char * m) { + (*original_error)(m); +} + +void fl_error_default_fatal(const char * m) { + (*original_fatal)(m); +} + + + + +// Tying it all together + +void fl_error_set_hooks() { + Fl::warning = &warning_hook_prep; + Fl::error = &error_hook_prep; + Fl::fatal = &fatal_hook_prep; +} + + diff --git a/body/c_fl_error.h b/body/c_fl_error.h new file mode 100644 index 0000000..1d4bc76 --- /dev/null +++ b/body/c_fl_error.h @@ -0,0 +1,27 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ERROR_GUARD +#define FL_ERROR_GUARD + + +extern "C" char * get_error_message(); + + +extern "C" const int error_bsize; + + +extern "C" void fl_error_default_warning(const char * m); +extern "C" void fl_error_default_error(const char * m); +extern "C" void fl_error_default_fatal(const char * m); + + +extern "C" void fl_error_set_hooks(); + + +#endif + + diff --git a/body/c_fl_event.cpp b/body/c_fl_event.cpp new file mode 100644 index 0000000..7bfb466 --- /dev/null +++ b/body/c_fl_event.cpp @@ -0,0 +1,264 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Window.H> +#include "c_fl_event.h" + + + + +void fl_event_add_handler(void * f) { + Fl::add_handler(reinterpret_cast<Fl_Event_Handler>(f)); +} + +void fl_event_remove_handler(void * f) { + Fl::remove_handler(reinterpret_cast<Fl_Event_Handler>(f)); +} + +void fl_event_add_system_handler(void * h, void * f) { + Fl::add_system_handler(reinterpret_cast<Fl_System_Handler>(h), f); +} + +void fl_event_remove_system_handler(void * h) { + Fl::remove_system_handler(reinterpret_cast<Fl_System_Handler>(h)); +} + + + + +void fl_event_set_dispatch(void * f) { + Fl::event_dispatch(reinterpret_cast<Fl_Event_Dispatch>(f)); +} + +int fl_event_handle_dispatch(int e, void * w) { + return Fl::handle(e, static_cast<Fl_Window*>(w)); +} + +int fl_event_handle(int e, void * w) { + return Fl::handle_(e, static_cast<Fl_Window*>(w)); +} + + + + +void * fl_event_get_grab() { + return Fl::grab(); +} + +void fl_event_set_grab(void * w) { + Fl::grab(static_cast<Fl_Window*>(w)); +} + +void * fl_event_get_pushed() { + return Fl::pushed(); +} + +void fl_event_set_pushed(void * w) { + Fl::pushed(static_cast<Fl_Widget*>(w)); +} + +void * fl_event_get_belowmouse() { + return Fl::belowmouse(); +} + +void fl_event_set_belowmouse(void * w) { + Fl::belowmouse(static_cast<Fl_Widget*>(w)); +} + +void * fl_event_get_focus() { + return Fl::focus(); +} + +void fl_event_set_focus(void * w) { + Fl::focus(static_cast<Fl_Widget*>(w)); +} + +int fl_event_get_visible_focus() { + return Fl::visible_focus(); +} + +void fl_event_set_visible_focus(int f) { + Fl::visible_focus(f); +} + + + + +const char * fl_event_clipboard_text() { + return static_cast<const char*>(Fl::event_clipboard()); +} + +const char * fl_event_clipboard_type() { + return Fl::event_clipboard_type(); +} + + + + +int fl_event_compose(int &d) { + return Fl::compose(d); +} + +void fl_event_compose_reset() { + Fl::compose_reset(); +} + +const char * fl_event_text() { + return Fl::event_text(); +} + +int fl_event_length() { + return Fl::event_length(); +} + +int fl_event_test_shortcut(unsigned int s) { + return Fl::test_shortcut(static_cast<Fl_Shortcut>(s)); +} + + + + +int fl_event_get() { + return Fl::event(); +} + +int fl_event_state() { + return Fl::event_state(); +} + +int fl_event_check_state(int s) { + return Fl::event_state(s); +} + + + + +int fl_event_x() { + return Fl::event_x(); +} + +int fl_event_x_root() { + return Fl::event_x_root(); +} + +int fl_event_y() { + return Fl::event_y(); +} + +int fl_event_y_root() { + return Fl::event_y_root(); +} + +int fl_event_dx() { + return Fl::event_dx(); +} + +int fl_event_dy() { + return Fl::event_dy(); +} + +void fl_event_get_mouse(int &x, int &y) { + Fl::get_mouse(x, y); +} + +int fl_event_is_click() { + return Fl::event_is_click(); +} + +void fl_event_set_click(int c) { + Fl::event_is_click(c); +} + +int fl_event_get_clicks() { + return Fl::event_clicks(); +} + +void fl_event_set_clicks(int c) { + Fl::event_clicks(c); +} + +int fl_event_button() { + return Fl::event_button(); +} + +int fl_event_button1() { + return Fl::event_button1(); +} + +int fl_event_button2() { + return Fl::event_button2(); +} + +int fl_event_button3() { + return Fl::event_button3(); +} + +int fl_event_button4() { +#if FL_API_VERSION >= 10310 + return Fl::event_button4(); +#else + return 0; +#endif +} + +int fl_event_button5() { +#if FL_API_VERSION >= 10310 + return Fl::event_button5(); +#else + return 0; +#endif +} + +int fl_event_buttons() { + return Fl::event_buttons(); +} + +int fl_event_inside2(void * c) { + return Fl::event_inside(static_cast<Fl_Widget*>(c)); +} + +int fl_event_inside(int x, int y, int w, int h) { + return Fl::event_inside(x, y, w, h); +} + + + + +int fl_event_key() { + return Fl::event_key(); +} + +int fl_event_original_key() { + return Fl::event_original_key(); +} + +int fl_event_key_during(int k) { + return Fl::event_key(k); +} + +int fl_event_get_key(int k) { + return Fl::get_key(k); +} + +int fl_event_ctrl() { + return Fl::event_ctrl(); +} + +int fl_event_alt() { + return Fl::event_alt(); +} + +int fl_event_command() { + return Fl::event_command(); +} + +int fl_event_shift() { + return Fl::event_shift(); +} + + diff --git a/body/c_fl_event.h b/body/c_fl_event.h new file mode 100644 index 0000000..4cb87cb --- /dev/null +++ b/body/c_fl_event.h @@ -0,0 +1,84 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_EVENT_GUARD +#define FL_EVENT_GUARD + + +extern "C" void fl_event_add_handler(void * f); +extern "C" void fl_event_remove_handler(void * f); +extern "C" void fl_event_add_system_handler(void * h, void * f); +extern "C" void fl_event_remove_system_handler(void * h); + + +extern "C" void fl_event_set_dispatch(void * f); +extern "C" int fl_event_handle_dispatch(int e, void * w); +extern "C" int fl_event_handle(int e, void * w); + + +extern "C" void * fl_event_get_grab(); +extern "C" void fl_event_set_grab(void * w); +extern "C" void * fl_event_get_pushed(); +extern "C" void fl_event_set_pushed(void * w); +extern "C" void * fl_event_get_belowmouse(); +extern "C" void fl_event_set_belowmouse(void * w); +extern "C" void * fl_event_get_focus(); +extern "C" void fl_event_set_focus(void * w); +extern "C" int fl_event_get_visible_focus(); +extern "C" void fl_event_set_visible_focus(int f); + + +extern "C" const char * fl_event_clipboard_text(); +extern "C" const char * fl_event_clipboard_type(); + + +extern "C" int fl_event_compose(int &d); +extern "C" void fl_event_compose_reset(); +extern "C" const char * fl_event_text(); +extern "C" int fl_event_length(); +extern "C" int fl_event_test_shortcut(unsigned int s); + + +extern "C" int fl_event_get(); +extern "C" int fl_event_state(); +extern "C" int fl_event_check_state(int s); + + +extern "C" int fl_event_x(); +extern "C" int fl_event_x_root(); +extern "C" int fl_event_y(); +extern "C" int fl_event_y_root(); +extern "C" int fl_event_dx(); +extern "C" int fl_event_dy(); +extern "C" void fl_event_get_mouse(int &x, int &y); +extern "C" int fl_event_is_click(); +extern "C" void fl_event_set_click(int c); +extern "C" int fl_event_get_clicks(); +extern "C" void fl_event_set_clicks(int c); +extern "C" int fl_event_button(); +extern "C" int fl_event_button1(); +extern "C" int fl_event_button2(); +extern "C" int fl_event_button3(); +extern "C" int fl_event_button4(); +extern "C" int fl_event_button5(); +extern "C" int fl_event_buttons(); +extern "C" int fl_event_inside2(void * c); +extern "C" int fl_event_inside(int x, int y, int w, int h); + + +extern "C" int fl_event_key(); +extern "C" int fl_event_original_key(); +extern "C" int fl_event_key_during(int k); +extern "C" int fl_event_get_key(int k); +extern "C" int fl_event_ctrl(); +extern "C" int fl_event_alt(); +extern "C" int fl_event_command(); +extern "C" int fl_event_shift(); + + +#endif + + diff --git a/body/c_fl_file_browser.cpp b/body/c_fl_file_browser.cpp new file mode 100644 index 0000000..dfe45a8 --- /dev/null +++ b/body/c_fl_file_browser.cpp @@ -0,0 +1,336 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_File_Browser.H> +#include <FL/Fl_Browser.H> +#include <FL/filename.H> +#include "c_fl_file_browser.h" +#include "c_fl.h" + + + + +// 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); + + + + +// Non-friend protected / private access + +// Should check these in future versions of FLTK to see whether +// it is possible to change them back to being overridden properly. + +class Friend_Browser : Fl_Browser { +public: + using Fl_Browser::full_height; + using Fl_Browser::incr_height; + using Fl_Browser::item_width; + using Fl_Browser::item_height; + using Fl_Browser::item_draw; +}; + + + + +// Attaching all relevant hooks and friends + +class My_File_Browser : public Fl_File_Browser { +public: + using Fl_File_Browser::Fl_File_Browser; + + friend int fl_file_browser_item_width(FILEBROWSER b, void * item); + friend int fl_file_browser_item_height(FILEBROWSER b, void * item); + friend void * fl_file_browser_item_first(FILEBROWSER b); + friend void * fl_file_browser_item_last(FILEBROWSER b); + friend void * fl_file_browser_item_next(FILEBROWSER b, void * item); + friend void * fl_file_browser_item_prev(FILEBROWSER b, void * item); + friend void * fl_file_browser_item_at(FILEBROWSER b, int index); + friend void fl_file_browser_item_select(FILEBROWSER b, void * item, int val); + friend int fl_file_browser_item_selected(FILEBROWSER b, void * item); + friend void fl_file_browser_item_swap(FILEBROWSER b, void * x, void * y); + friend const char * fl_file_browser_item_text(FILEBROWSER b, void * item); + friend void fl_file_browser_item_draw(FILEBROWSER b, void * item, int x, int y, int w, int h); + + friend int fl_file_browser_full_width(FILEBROWSER c); + friend int fl_file_browser_full_height(FILEBROWSER c); + friend int fl_file_browser_incr_height(FILEBROWSER c); + friend int fl_file_browser_item_quick_height(FILEBROWSER c, void * i); + + friend void fl_file_browser_draw(FILEBROWSER b); + + int handle(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 My_File_Browser::full_width() const { + return browser_full_width_hook(this->user_data()); +} + +// int My_File_Browser::full_height() const { +// return browser_full_height_hook(this->user_data()); +// } + +// int My_File_Browser::incr_height() const { +// return browser_incr_height_hook(this->user_data()); +// } + +int My_File_Browser::item_quick_height(void * item) const { + return browser_item_quick_height_hook(this->user_data(), item); +} + + +// int My_File_Browser::item_width(void * item) const { +// return browser_item_width_hook(this->user_data(), item); +// } + +// int My_File_Browser::item_height(void * item) const { +// return browser_item_height_hook(this->user_data(), item); +// } + +void * My_File_Browser::item_first() const { + return browser_item_first_hook(this->user_data()); +} + +void * My_File_Browser::item_last() const { + return browser_item_last_hook(this->user_data()); +} + +void * My_File_Browser::item_next(void * item) const { + return browser_item_next_hook(this->user_data(), item); +} + +void * My_File_Browser::item_prev(void * item) const { + return browser_item_prev_hook(this->user_data(), item); +} + +void * My_File_Browser::item_at(int index) const { + return browser_item_at_hook(this->user_data(), index); +} + +void My_File_Browser::item_select(void * item, int val) { + browser_item_select_hook(this->user_data(), item, val); +} + +int My_File_Browser::item_selected(void * item) const { + return browser_item_selected_hook(this->user_data(), item); +} + +void My_File_Browser::item_swap(void * a, void * b) { + browser_item_swap_hook(this->user_data(), a, b); +} + +const char * My_File_Browser::item_text(void * item) const { + return browser_item_text_hook(this->user_data(), item); +} + +// void My_File_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_File_Browser::draw() { + widget_draw_hook(this->user_data()); +} + +int My_File_Browser::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +FILEBROWSER new_fl_file_browser(int x, int y, int w, int h, char * label) { + My_File_Browser *b = new My_File_Browser(x, y, w, h, label); + return b; +} + +void free_fl_file_browser(FILEBROWSER b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_File_Browser*>(b); + } +} + + + + +int fl_file_browser_load(FILEBROWSER b, const char * d, void * s) { + return static_cast<Fl_File_Browser*>(b)->load(d, reinterpret_cast<Fl_File_Sort_F*>(s)); +} + + + + +int fl_file_browser_get_filetype(FILEBROWSER b) { + return static_cast<Fl_File_Browser*>(b)->filetype(); +} + +void fl_file_browser_set_filetype(FILEBROWSER b, int f) { + static_cast<Fl_File_Browser*>(b)->filetype(f); +} + +const char * fl_file_browser_get_filter(FILEBROWSER b) { + return static_cast<Fl_File_Browser*>(b)->filter(); +} + +void fl_file_browser_set_filter(FILEBROWSER b, const char * f) { + static_cast<Fl_File_Browser*>(b)->filter(f); +} + +unsigned char fl_file_browser_get_iconsize(FILEBROWSER b) { + return static_cast<Fl_File_Browser*>(b)->iconsize(); +} + +void fl_file_browser_set_iconsize(FILEBROWSER b, unsigned int i) { + static_cast<Fl_File_Browser*>(b)->iconsize(i); +} + +int fl_file_browser_get_textsize(FILEBROWSER b) { + return static_cast<Fl_File_Browser*>(b)->textsize(); +} + +void fl_file_browser_set_textsize(FILEBROWSER b, int s) { + static_cast<Fl_File_Browser*>(b)->textsize(s); +} + + + + +// These have to be reimplemented due to relying on custom class extensions + + +int fl_file_browser_full_height(FILEBROWSER c) { + // return static_cast<My_File_Browser*>(c)->Fl_File_Browser::full_height(); + return (static_cast<Fl_File_Browser*>(c)->*(&Friend_Browser::full_height))(); +} + +int fl_file_browser_incr_height(FILEBROWSER c) { + // return static_cast<My_File_Browser*>(c)->Fl_File_Browser::incr_height(); + return (static_cast<Fl_File_Browser*>(c)->*(&Friend_Browser::incr_height))(); +} + + + + +int fl_file_browser_item_width(FILEBROWSER b, void * item) { + // return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_width(item); + return (static_cast<Fl_File_Browser*>(b)->*(&Friend_Browser::item_width))(item); +} + +int fl_file_browser_item_height(FILEBROWSER b, void * item) { + // return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_height(item); + return (static_cast<Fl_File_Browser*>(b)->*(&Friend_Browser::item_height))(item); +} + +void * fl_file_browser_item_first(FILEBROWSER b) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_first(); +} + +void * fl_file_browser_item_last(FILEBROWSER b) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_last(); +} + +void * fl_file_browser_item_next(FILEBROWSER b, void * item) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_next(item); +} + +void * fl_file_browser_item_prev(FILEBROWSER b, void * item) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_prev(item); +} + +void * fl_file_browser_item_at(FILEBROWSER b, int index) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_at(index); +} + +void fl_file_browser_item_select(FILEBROWSER b, void * item, int val) { + static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_select(item, val); +} + +int fl_file_browser_item_selected(FILEBROWSER b, void * item) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_selected(item); +} + +void fl_file_browser_item_swap(FILEBROWSER b, void * x, void * y) { + static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_swap(x, y); +} + +const char * fl_file_browser_item_text(FILEBROWSER b, void * item) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_text(item); +} + +void fl_file_browser_item_draw(FILEBROWSER b, void * item, int x, int y, int w, int h) { + // static_cast<My_File_Browser*>(b)->Fl_File_Browser::item_draw(item, x, y, w, h); + (static_cast<Fl_File_Browser*>(b)->*(&Friend_Browser::item_draw))(item, x, y, w, h); +} + + + + +int fl_file_browser_full_width(FILEBROWSER c) { + return static_cast<My_File_Browser*>(c)->Fl_File_Browser::full_width(); +} + +int fl_file_browser_item_quick_height(FILEBROWSER c, void * i) { + return static_cast<My_File_Browser*>(c)->Fl_File_Browser::item_quick_height(i); +} + + + + +void fl_file_browser_draw(FILEBROWSER b) { + static_cast<My_File_Browser*>(b)->Fl_File_Browser::draw(); +} + +int fl_file_browser_handle(FILEBROWSER b, int e) { + return static_cast<My_File_Browser*>(b)->Fl_File_Browser::handle(e); +} + + diff --git a/body/c_fl_file_browser.h b/body/c_fl_file_browser.h new file mode 100644 index 0000000..67e1489 --- /dev/null +++ b/body/c_fl_file_browser.h @@ -0,0 +1,61 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILE_BROWSER_GUARD +#define FL_FILE_BROWSER_GUARD + + +typedef void* FILEBROWSER; + + +extern "C" FILEBROWSER new_fl_file_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_file_browser(FILEBROWSER b); + + +extern "C" int fl_file_browser_load(FILEBROWSER b, const char * d, void * s); + + +extern "C" int fl_file_browser_get_filetype(FILEBROWSER b); +extern "C" void fl_file_browser_set_filetype(FILEBROWSER b, int f); +extern "C" const char * fl_file_browser_get_filter(FILEBROWSER b); +extern "C" void fl_file_browser_set_filter(FILEBROWSER b, const char * f); +extern "C" unsigned char fl_file_browser_get_iconsize(FILEBROWSER b); +extern "C" void fl_file_browser_set_iconsize(FILEBROWSER b, unsigned int i); +extern "C" int fl_file_browser_get_textsize(FILEBROWSER b); +extern "C" void fl_file_browser_set_textsize(FILEBROWSER b, int s); + + +// reimp below here + +extern "C" int fl_file_browser_full_height(FILEBROWSER c); +extern "C" int fl_file_browser_incr_height(FILEBROWSER c); + + +extern "C" int fl_file_browser_item_width(FILEBROWSER b, void * item); +extern "C" int fl_file_browser_item_height(FILEBROWSER b, void * item); +extern "C" void * fl_file_browser_item_first(FILEBROWSER b); +extern "C" void * fl_file_browser_item_last(FILEBROWSER b); +extern "C" void * fl_file_browser_item_next(FILEBROWSER b, void * item); +extern "C" void * fl_file_browser_item_prev(FILEBROWSER b, void * item); +extern "C" void * fl_file_browser_item_at(FILEBROWSER b, int index); +extern "C" void fl_file_browser_item_select(FILEBROWSER b, void * item, int val=1); +extern "C" int fl_file_browser_item_selected(FILEBROWSER b, void * item); +extern "C" void fl_file_browser_item_swap(FILEBROWSER b, void * x, void * y); +extern "C" const char * fl_file_browser_item_text(FILEBROWSER b, void * item); +extern "C" void fl_file_browser_item_draw(FILEBROWSER b, void * item, int x, int y, int w, int h); + + +extern "C" int fl_file_browser_full_width(FILEBROWSER c); +extern "C" int fl_file_browser_item_quick_height(FILEBROWSER c, void * i); + + +extern "C" void fl_file_browser_draw(FILEBROWSER b); +extern "C" int fl_file_browser_handle(FILEBROWSER b, int e); + + +#endif + + diff --git a/body/c_fl_file_chooser.cpp b/body/c_fl_file_chooser.cpp new file mode 100644 index 0000000..bdb35b0 --- /dev/null +++ b/body/c_fl_file_chooser.cpp @@ -0,0 +1,340 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_File_Chooser.H> +#include <FL/Fl_Widget.H> +#include "c_fl_file_chooser.h" + + + + +// Exports from Ada + +extern "C" int file_chooser_sort_hook(const char * a, const char * b); + + + + +// Some extra setup + +int file_chooser_sort_prehook(struct dirent ** a, struct dirent ** b) { + return file_chooser_sort_hook((*a)->d_name, (*b)->d_name); +} + +void file_chooser_setup_sort_hook() { + Fl_File_Chooser::sort = &file_chooser_sort_prehook; +} + + + + +// Flattened C API begins here + +FILECHOOSER new_fl_file_chooser(const char * n, const char * p, int k, const char * t) { + Fl_File_Chooser *f = new Fl_File_Chooser(n, p, k, t); + return f; +} + +void free_fl_file_chooser(FILECHOOSER f) { + delete static_cast<Fl_File_Chooser*>(f); +} + + + + +void * fl_file_chooser_get_user_data(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->user_data(); +} + +void fl_file_chooser_set_user_data(FILECHOOSER f, void * ud) { + static_cast<Fl_File_Chooser*>(f)->user_data(ud); +} + + + + +void * fl_file_chooser_newbutton(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->newButton; +} + +void * fl_file_chooser_previewbutton(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->previewButton; +} + +void * fl_file_chooser_showhiddenbutton(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->showHiddenButton; +} + + + + +const char * fl_file_chooser_get_add_favorites_label() { + return Fl_File_Chooser::add_favorites_label; +} + +void fl_file_chooser_set_add_favorites_label(const char * s) { + Fl_File_Chooser::add_favorites_label = s; +} + +const char * fl_file_chooser_get_all_files_label() { + return Fl_File_Chooser::all_files_label; +} + +void fl_file_chooser_set_all_files_label(const char * s) { + Fl_File_Chooser::all_files_label = s; +} + +const char * fl_file_chooser_get_custom_filter_label() { + return Fl_File_Chooser::custom_filter_label; +} + +void fl_file_chooser_set_custom_filter_label(const char * s) { + Fl_File_Chooser::custom_filter_label = s; +} + +const char * fl_file_chooser_get_existing_file_label() { + return Fl_File_Chooser::existing_file_label; +} + +void fl_file_chooser_set_existing_file_label(const char * s) { + Fl_File_Chooser::existing_file_label = s; +} + +const char * fl_file_chooser_get_favorites_label() { + return Fl_File_Chooser::favorites_label; +} + +void fl_file_chooser_set_favorites_label(const char * s) { + Fl_File_Chooser::favorites_label = s; +} + +const char * fl_file_chooser_get_filename_label() { + return Fl_File_Chooser::filename_label; +} + +void fl_file_chooser_set_filename_label(const char * s) { + Fl_File_Chooser::filename_label = s; +} + +const char * fl_file_chooser_get_filesystems_label() { + return Fl_File_Chooser::filesystems_label; +} + +void fl_file_chooser_set_filesystems_label(const char * s) { + Fl_File_Chooser::filesystems_label = s; +} + +const char * fl_file_chooser_get_hidden_label() { + return Fl_File_Chooser::hidden_label; +} + +void fl_file_chooser_set_hidden_label(const char * s) { + Fl_File_Chooser::hidden_label = s; +} + +const char * fl_file_chooser_get_manage_favorites_label() { + return Fl_File_Chooser::manage_favorites_label; +} + +void fl_file_chooser_set_manage_favorites_label(const char * s) { + Fl_File_Chooser::manage_favorites_label = s; +} + +const char * fl_file_chooser_get_new_directory_label() { + return Fl_File_Chooser::new_directory_label; +} + +void fl_file_chooser_set_new_directory_label(const char * s) { + Fl_File_Chooser::new_directory_label = s; +} + +const char * fl_file_chooser_get_new_directory_tooltip() { + return Fl_File_Chooser::new_directory_tooltip; +} + +void fl_file_chooser_set_new_directory_tooltip(const char * s) { + Fl_File_Chooser::new_directory_tooltip = s; +} + +const char * fl_file_chooser_get_preview_label() { + return Fl_File_Chooser::preview_label; +} + +void fl_file_chooser_set_preview_label(const char * s) { + Fl_File_Chooser::preview_label = s; +} + +const char * fl_file_chooser_get_save_label() { + return Fl_File_Chooser::save_label; +} + +void fl_file_chooser_set_save_label(const char * s) { + Fl_File_Chooser::save_label = s; +} + +const char * fl_file_chooser_get_show_label() { + return Fl_File_Chooser::show_label; +} + +void fl_file_chooser_set_show_label(const char * s) { + Fl_File_Chooser::show_label = s; +} + + + + +void * fl_file_chooser_add_extra(FILECHOOSER f, void * w) { + return static_cast<Fl_File_Chooser*>(f)->add_extra(static_cast<Fl_Widget*>(w)); +} + +typedef void (*Chooser_Callback)(Fl_File_Chooser *, void *); + +void fl_file_chooser_callback(FILECHOOSER f, void * c, void * u) { + static_cast<Fl_File_Chooser*>(f)->callback(reinterpret_cast<Chooser_Callback>(c), u); +} + + + + +unsigned int fl_file_chooser_get_color(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->color(); +} + +void fl_file_chooser_set_color(FILECHOOSER f, unsigned int c) { + static_cast<Fl_File_Chooser*>(f)->color(c); +} + +unsigned char fl_file_chooser_get_iconsize(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->iconsize(); +} + +void fl_file_chooser_set_iconsize(FILECHOOSER f, unsigned char i) { + static_cast<Fl_File_Chooser*>(f)->iconsize(i); +} + +const char * fl_file_chooser_get_label(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->label(); +} + +void fl_file_chooser_set_label(FILECHOOSER f, const char * t) { + static_cast<Fl_File_Chooser*>(f)->label(t); +} + +const char * fl_file_chooser_get_ok_label(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->ok_label(); +} + +void fl_file_chooser_set_ok_label(FILECHOOSER f, const char * t) { + static_cast<Fl_File_Chooser*>(f)->ok_label(t); +} + +int fl_file_chooser_get_preview(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->preview(); +} + +void fl_file_chooser_set_preview(FILECHOOSER f, int p) { + static_cast<Fl_File_Chooser*>(f)->preview(p); +} + +unsigned int fl_file_chooser_get_textcolor(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->textcolor(); +} + +void fl_file_chooser_set_textcolor(FILECHOOSER f, unsigned int c) { + static_cast<Fl_File_Chooser*>(f)->textcolor(c); +} + +int fl_file_chooser_get_textfont(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->textfont(); +} + +void fl_file_chooser_set_textfont(FILECHOOSER f, int n) { + static_cast<Fl_File_Chooser*>(f)->textfont(n); +} + +int fl_file_chooser_get_textsize(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->textsize(); +} + +void fl_file_chooser_set_textsize(FILECHOOSER f, int s) { + static_cast<Fl_File_Chooser*>(f)->textsize(s); +} + +int fl_file_chooser_get_type(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->type(); +} + +void fl_file_chooser_set_type(FILECHOOSER f, int t) { + static_cast<Fl_File_Chooser*>(f)->type(t); +} + + + + +int fl_file_chooser_count(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->count(); +} + +const char * fl_file_chooser_get_directory(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->directory(); +} + +void fl_file_chooser_set_directory(FILECHOOSER f, const char * v) { + static_cast<Fl_File_Chooser*>(f)->directory(v); +} + +const char * fl_file_chooser_get_filter(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->filter(); +} + +void fl_file_chooser_set_filter(FILECHOOSER f, const char * v) { + static_cast<Fl_File_Chooser*>(f)->filter(v); +} + +int fl_file_chooser_get_filter_value(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->filter_value(); +} + +void fl_file_chooser_set_filter_value(FILECHOOSER f, int v) { + static_cast<Fl_File_Chooser*>(f)->filter_value(v); +} + +void fl_file_chooser_rescan(FILECHOOSER f) { + static_cast<Fl_File_Chooser*>(f)->rescan(); +} + +void fl_file_chooser_rescan_keep_filename(FILECHOOSER f) { + static_cast<Fl_File_Chooser*>(f)->rescan_keep_filename(); +} + +const char * fl_file_chooser_get_value(FILECHOOSER f, int n) { + return static_cast<Fl_File_Chooser*>(f)->value(n); +} + +void fl_file_chooser_set_value(FILECHOOSER f, const char * v) { + static_cast<Fl_File_Chooser*>(f)->value(v); +} + + + + +void fl_file_chooser_show(FILECHOOSER f) { + static_cast<Fl_File_Chooser*>(f)->show(); +} + +void fl_file_chooser_hide(FILECHOOSER f) { + static_cast<Fl_File_Chooser*>(f)->hide(); +} + +int fl_file_chooser_shown(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->shown(); +} + +int fl_file_chooser_visible(FILECHOOSER f) { + return static_cast<Fl_File_Chooser*>(f)->visible(); +} + + diff --git a/body/c_fl_file_chooser.h b/body/c_fl_file_chooser.h new file mode 100644 index 0000000..17ee63c --- /dev/null +++ b/body/c_fl_file_chooser.h @@ -0,0 +1,105 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILE_CHOOSER_GUARD +#define FL_FILE_CHOOSER_GUARD + + +typedef void* FILECHOOSER; + + +extern "C" void file_chooser_setup_sort_hook(); + + +extern "C" FILECHOOSER new_fl_file_chooser(const char * n, const char * p, int k, const char * t); +extern "C" void free_fl_file_chooser(FILECHOOSER f); + + +extern "C" void * fl_file_chooser_get_user_data(FILECHOOSER f); +extern "C" void fl_file_chooser_set_user_data(FILECHOOSER f, void * ud); + + +extern "C" void * fl_file_chooser_newbutton(FILECHOOSER f); +extern "C" void * fl_file_chooser_previewbutton(FILECHOOSER f); +extern "C" void * fl_file_chooser_showhiddenbutton(FILECHOOSER f); + + +extern "C" const char * fl_file_chooser_get_add_favorites_label(); +extern "C" void fl_file_chooser_set_add_favorites_label(const char * s); +extern "C" const char * fl_file_chooser_get_all_files_label(); +extern "C" void fl_file_chooser_set_all_files_label(const char * s); +extern "C" const char * fl_file_chooser_get_custom_filter_label(); +extern "C" void fl_file_chooser_set_custom_filter_label(const char * s); +extern "C" const char * fl_file_chooser_get_existing_file_label(); +extern "C" void fl_file_chooser_set_existing_file_label(const char * s); +extern "C" const char * fl_file_chooser_get_favorites_label(); +extern "C" void fl_file_chooser_set_favorites_label(const char * s); +extern "C" const char * fl_file_chooser_get_filename_label(); +extern "C" void fl_file_chooser_set_filename_label(const char * s); +extern "C" const char * fl_file_chooser_get_filesystems_label(); +extern "C" void fl_file_chooser_set_filesystems_label(const char * s); +extern "C" const char * fl_file_chooser_get_hidden_label(); +extern "C" void fl_file_chooser_set_hidden_label(const char * s); +extern "C" const char * fl_file_chooser_get_manage_favorites_label(); +extern "C" void fl_file_chooser_set_manage_favorites_label(const char * s); +extern "C" const char * fl_file_chooser_get_new_directory_label(); +extern "C" void fl_file_chooser_set_new_directory_label(const char * s); +extern "C" const char * fl_file_chooser_get_new_directory_tooltip(); +extern "C" void fl_file_chooser_set_new_directory_tooltip(const char * s); +extern "C" const char * fl_file_chooser_get_preview_label(); +extern "C" void fl_file_chooser_set_preview_label(const char * s); +extern "C" const char * fl_file_chooser_get_save_label(); +extern "C" void fl_file_chooser_set_save_label(const char * s); +extern "C" const char * fl_file_chooser_get_show_label(); +extern "C" void fl_file_chooser_set_show_label(const char * s); + + +extern "C" void * fl_file_chooser_add_extra(FILECHOOSER f, void * w); +extern "C" void fl_file_chooser_callback(FILECHOOSER f, void * c, void * u); + + +extern "C" unsigned int fl_file_chooser_get_color(FILECHOOSER f); +extern "C" void fl_file_chooser_set_color(FILECHOOSER f, unsigned int c); +extern "C" unsigned char fl_file_chooser_get_iconsize(FILECHOOSER f); +extern "C" void fl_file_chooser_set_iconsize(FILECHOOSER f, unsigned char i); +extern "C" const char * fl_file_chooser_get_label(FILECHOOSER f); +extern "C" void fl_file_chooser_set_label(FILECHOOSER f, const char * t); +extern "C" const char * fl_file_chooser_get_ok_label(FILECHOOSER f); +extern "C" void fl_file_chooser_set_ok_label(FILECHOOSER f, const char * t); +extern "C" int fl_file_chooser_get_preview(FILECHOOSER f); +extern "C" void fl_file_chooser_set_preview(FILECHOOSER f, int p); +extern "C" unsigned int fl_file_chooser_get_textcolor(FILECHOOSER f); +extern "C" void fl_file_chooser_set_textcolor(FILECHOOSER f, unsigned int c); +extern "C" int fl_file_chooser_get_textfont(FILECHOOSER f); +extern "C" void fl_file_chooser_set_textfont(FILECHOOSER f, int n); +extern "C" int fl_file_chooser_get_textsize(FILECHOOSER f); +extern "C" void fl_file_chooser_set_textsize(FILECHOOSER f, int s); +extern "C" int fl_file_chooser_get_type(FILECHOOSER f); +extern "C" void fl_file_chooser_set_type(FILECHOOSER f, int t); + + +extern "C" int fl_file_chooser_count(FILECHOOSER f); +extern "C" const char * fl_file_chooser_get_directory(FILECHOOSER f); +extern "C" void fl_file_chooser_set_directory(FILECHOOSER f, const char * v); +extern "C" const char * fl_file_chooser_get_filter(FILECHOOSER f); +extern "C" void fl_file_chooser_set_filter(FILECHOOSER f, const char * v); +extern "C" int fl_file_chooser_get_filter_value(FILECHOOSER f); +extern "C" void fl_file_chooser_set_filter_value(FILECHOOSER f, int v); +extern "C" void fl_file_chooser_rescan(FILECHOOSER f); +extern "C" void fl_file_chooser_rescan_keep_filename(FILECHOOSER f); +extern "C" const char * fl_file_chooser_get_value(FILECHOOSER f, int n); +extern "C" void fl_file_chooser_set_value(FILECHOOSER f, const char * v); + + +extern "C" void fl_file_chooser_show(FILECHOOSER f); +extern "C" void fl_file_chooser_hide(FILECHOOSER f); +extern "C" int fl_file_chooser_shown(FILECHOOSER f); +extern "C" int fl_file_chooser_visible(FILECHOOSER f); + + +#endif + + diff --git a/body/c_fl_file_input.cpp b/body/c_fl_file_input.cpp new file mode 100644 index 0000000..0fbea0a --- /dev/null +++ b/body/c_fl_file_input.cpp @@ -0,0 +1,102 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_File_Input.H> +#include "c_fl_file_input.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_File_Input : public Fl_File_Input { +public: + using Fl_File_Input::Fl_File_Input; + + friend void fl_file_input_draw(FILEINPUT i); + friend int fl_file_input_handle(FILEINPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_File_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_File_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +FILEINPUT new_fl_file_input(int x, int y, int w, int h, char* label) { + My_File_Input *i = new My_File_Input(x, y, w, h, label); + return i; +} + +void free_fl_file_input(FILEINPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_File_Input*>(i); + } +} + + + + +int fl_file_input_get_down_box(FILEINPUT i) { + return static_cast<Fl_File_Input*>(i)->down_box(); +} + +void fl_file_input_set_down_box(FILEINPUT i, int t) { + static_cast<Fl_File_Input*>(i)->down_box(static_cast<Fl_Boxtype>(t)); +} + +unsigned int fl_file_input_get_errorcolor(FILEINPUT i) { + return static_cast<Fl_File_Input*>(i)->errorcolor(); +} + +void fl_file_input_set_errorcolor(FILEINPUT i, unsigned int t) { + static_cast<Fl_File_Input*>(i)->errorcolor(t); +} + + + + +const char * fl_file_input_get_value(FILEINPUT i) { + return static_cast<Fl_File_Input*>(i)->value(); +} + +int fl_file_input_set_value(FILEINPUT i, const char * s, int len) { + return static_cast<Fl_File_Input*>(i)->value(s,len); +} + + + + +void fl_file_input_draw(FILEINPUT i) { + static_cast<My_File_Input*>(i)->Fl_File_Input::draw(); +} + +int fl_file_input_handle(FILEINPUT i, int e) { + return static_cast<My_File_Input*>(i)->Fl_File_Input::handle(e); +} + + diff --git a/body/c_fl_file_input.h b/body/c_fl_file_input.h new file mode 100644 index 0000000..df05cbb --- /dev/null +++ b/body/c_fl_file_input.h @@ -0,0 +1,34 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILE_INPUT_GUARD +#define FL_FILE_INPUT_GUARD + + +typedef void* FILEINPUT; + + +extern "C" FILEINPUT new_fl_file_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_file_input(FILEINPUT i); + + +extern "C" int fl_file_input_get_down_box(FILEINPUT i); +extern "C" void fl_file_input_set_down_box(FILEINPUT i, int t); +extern "C" unsigned int fl_file_input_get_errorcolor(FILEINPUT i); +extern "C" void fl_file_input_set_errorcolor(FILEINPUT i, unsigned int t); + + +extern "C" const char * fl_file_input_get_value(FILEINPUT i); +extern "C" int fl_file_input_set_value(FILEINPUT i, const char * s, int len); + + +extern "C" void fl_file_input_draw(FILEINPUT i); +extern "C" int fl_file_input_handle(FILEINPUT i, int e); + + +#endif + + diff --git a/body/c_fl_filename.cpp b/body/c_fl_filename.cpp new file mode 100644 index 0000000..300f4ff --- /dev/null +++ b/body/c_fl_filename.cpp @@ -0,0 +1,127 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/filename.H> +#include <string.h> +#include "c_fl_filename.h" + + + + +const int fl_path_max = FL_PATH_MAX; + + + + +void free_filename_file_list(void * l, int n) { + struct dirent ** p = static_cast<struct dirent **>(l); + fl_filename_free_list(&p, n); +} + +const char * filename_dname(void * l, int n) { + return (static_cast<struct dirent **>(l)[n])->d_name; +} + + + + +void filename_decode_uri(char *uri) { + fl_decode_uri(uri); +} + +int filename_absolute(char * to, int tolen, const char * from) { + return fl_filename_absolute(to, tolen, from); +} + +int filename_expand(char * to, int tolen, const char * from) { + return fl_filename_expand(to, tolen, from); +} + +const char * filename_ext(const char * buf) { + return fl_filename_ext(buf); +} + +int filename_isdir(const char * name) { + return fl_filename_isdir(name); +} + +int filename_list(const char * d, void * l, void * f) { + return fl_filename_list(d, static_cast<struct dirent ***>(l), + reinterpret_cast<Fl_File_Sort_F*>(f)); +} + +int filename_match(const char * name, const char * pattern) { + return fl_filename_match(name, pattern); +} + +const char * filename_name(const char * name) { + return fl_filename_name(name); +} + +int filename_relative(char * to, int tolen, const char * from) { + return fl_filename_relative(to, tolen, from); +} + +char * filename_setext(char * to, int tolen, const char * ext) { + return fl_filename_setext(to, tolen, ext); +} + +int filename_open_uri(const char * uri, char * msg, int msglen) { + return fl_open_uri(uri, msg, msglen); +} + + + + +int filename_alphasort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_alphasort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + +int filename_casealphasort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_casealphasort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + +int filename_numericsort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_numericsort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + +int filename_casenumericsort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_casenumericsort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + + diff --git a/body/c_fl_filename.h b/body/c_fl_filename.h new file mode 100644 index 0000000..0839293 --- /dev/null +++ b/body/c_fl_filename.h @@ -0,0 +1,39 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILENAME_GUARD +#define FL_FILENAME_GUARD + + +extern "C" const int fl_path_max; + + +extern "C" void free_filename_file_list(void * l, int n); +extern "C" const char * filename_dname(void * l, int n); + + +extern "C" void filename_decode_uri(char *uri); +extern "C" int filename_absolute(char * to, int tolen, const char * from); +extern "C" int filename_expand(char * to, int tolen, const char * from); +extern "C" const char * filename_ext(const char * buf); +extern "C" int filename_isdir(const char * name); +extern "C" int filename_list(const char * d, void * l, void * f); +extern "C" int filename_match(const char * name, const char * pattern); +extern "C" const char * filename_name(const char * name); +extern "C" int filename_relative(char * to, int tolen, const char * from); +extern "C" char * filename_setext(char * to, int tolen, const char * ext); +extern "C" int filename_open_uri(const char * uri, char * msg, int msglen); + + +extern "C" int filename_alphasort(char * a, char * b); +extern "C" int filename_casealphasort(char * a, char * b); +extern "C" int filename_numericsort(char * a, char * b); +extern "C" int filename_casenumericsort(char * a, char * b); + + +#endif + + diff --git a/body/c_fl_fill_dial.cpp b/body/c_fl_fill_dial.cpp new file mode 100644 index 0000000..b29d581 --- /dev/null +++ b/body/c_fl_fill_dial.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Fill_Dial.H> +#include "c_fl_fill_dial.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Fill_Dial : public Fl_Fill_Dial { +public: + using Fl_Fill_Dial::Fl_Fill_Dial; + + friend void fl_fill_dial_draw(FILLDIAL v); + friend int fl_fill_dial_handle(FILLDIAL v, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Fill_Dial::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Fill_Dial::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Fill_Dial::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +FILLDIAL new_fl_fill_dial(int x, int y, int w, int h, char* label) { + My_Fill_Dial *v = new My_Fill_Dial(x, y, w, h, label); + return v; +} + +void free_fl_fill_dial(FILLDIAL v) { + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Fill_Dial*>(v); + } +} + + + + +void fl_fill_dial_draw(FILLDIAL v) { + static_cast<My_Fill_Dial*>(v)->Fl_Fill_Dial::draw(); +} + +int fl_fill_dial_handle(FILLDIAL v, int e) { + return static_cast<My_Fill_Dial*>(v)->Fl_Fill_Dial::handle(e); +} + + diff --git a/body/c_fl_fill_dial.h b/body/c_fl_fill_dial.h new file mode 100644 index 0000000..00a8094 --- /dev/null +++ b/body/c_fl_fill_dial.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILL_DIAL_GUARD +#define FL_FILL_DIAL_GUARD + + +typedef void* FILLDIAL; + + +extern "C" FILLDIAL new_fl_fill_dial(int x, int y, int w, int h, char* label); +extern "C" void free_fl_fill_dial(FILLDIAL v); + + +extern "C" void fl_fill_dial_draw(FILLDIAL v); +extern "C" int fl_fill_dial_handle(FILLDIAL v, int e); + + +#endif + + diff --git a/body/c_fl_fill_slider.cpp b/body/c_fl_fill_slider.cpp new file mode 100644 index 0000000..309960a --- /dev/null +++ b/body/c_fl_fill_slider.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Fill_Slider.H> +#include "c_fl_fill_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Fill_Slider : public Fl_Fill_Slider { +public: + using Fl_Fill_Slider::Fl_Fill_Slider; + + friend void fl_fill_slider_draw(FILLSLIDER s); + friend int fl_fill_slider_handle(FILLSLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Fill_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Fill_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Fill_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +FILLSLIDER new_fl_fill_slider(int x, int y, int w, int h, char* label) { + My_Fill_Slider *s = new My_Fill_Slider(x, y, w, h, label); + return s; +} + +void free_fl_fill_slider(FILLSLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Fill_Slider*>(s); + } +} + + + + +void fl_fill_slider_draw(FILLSLIDER s) { + static_cast<My_Fill_Slider*>(s)->Fl_Fill_Slider::draw(); +} + +int fl_fill_slider_handle(FILLSLIDER s, int e) { + return static_cast<My_Fill_Slider*>(s)->Fl_Fill_Slider::handle(e); +} + + diff --git a/body/c_fl_fill_slider.h b/body/c_fl_fill_slider.h new file mode 100644 index 0000000..d208d93 --- /dev/null +++ b/body/c_fl_fill_slider.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILL_SLIDER_GUARD +#define FL_FILL_SLIDER_GUARD + + +typedef void* FILLSLIDER; + + +extern "C" FILLSLIDER new_fl_fill_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_fill_slider(FILLSLIDER s); + + +extern "C" void fl_fill_slider_draw(FILLSLIDER s); +extern "C" int fl_fill_slider_handle(FILLSLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_float_input.cpp b/body/c_fl_float_input.cpp new file mode 100644 index 0000000..ca8337a --- /dev/null +++ b/body/c_fl_float_input.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Float_Input.H> +#include "c_fl_float_input.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Float_Input : public Fl_Float_Input { +public: + using Fl_Float_Input::Fl_Float_Input; + + friend void fl_float_input_draw(FLOATINPUT i); + friend int fl_float_input_handle(FLOATINPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Float_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Float_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +FLOATINPUT new_fl_float_input(int x, int y, int w, int h, char* label) { + My_Float_Input *i = new My_Float_Input(x, y, w, h, label); + return i; +} + +void free_fl_float_input(FLOATINPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Float_Input*>(i); + } +} + + + + +void fl_float_input_draw(FLOATINPUT i) { + static_cast<My_Float_Input*>(i)->Fl_Float_Input::draw(); +} + +int fl_float_input_handle(FLOATINPUT i, int e) { + return static_cast<My_Float_Input*>(i)->Fl_Float_Input::handle(e); +} + + diff --git a/body/c_fl_float_input.h b/body/c_fl_float_input.h new file mode 100644 index 0000000..5ee1689 --- /dev/null +++ b/body/c_fl_float_input.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FLOAT_INPUT_GUARD +#define FL_FLOAT_INPUT_GUARD + + +typedef void* FLOATINPUT; + + +extern "C" FLOATINPUT new_fl_float_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_float_input(FLOATINPUT i); + + +extern "C" void fl_float_input_draw(FLOATINPUT i); +extern "C" int fl_float_input_handle(FLOATINPUT i, int e); + + +#endif + + diff --git a/body/c_fl_gif_image.cpp b/body/c_fl_gif_image.cpp new file mode 100644 index 0000000..9ab5519 --- /dev/null +++ b/body/c_fl_gif_image.cpp @@ -0,0 +1,22 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_GIF_Image.H> +#include "c_fl_gif_image.h" + + + + +GIFIMAGE new_fl_gif_image(const char * f) { + Fl_GIF_Image *j = new Fl_GIF_Image(f); + return j; +} + +void free_fl_gif_image(GIFIMAGE j) { + delete static_cast<Fl_GIF_Image*>(j); +} + + diff --git a/body/c_fl_gif_image.h b/body/c_fl_gif_image.h new file mode 100644 index 0000000..4d340cd --- /dev/null +++ b/body/c_fl_gif_image.h @@ -0,0 +1,20 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_GIF_IMAGE_GUARD +#define FL_GIF_IMAGE_GUARD + + +typedef void* GIFIMAGE; + + +extern "C" GIFIMAGE new_fl_gif_image(const char * f); +extern "C" void free_fl_gif_image(GIFIMAGE j); + + +#endif + + diff --git a/body/c_fl_gl_window.cpp b/body/c_fl_gl_window.cpp new file mode 100644 index 0000000..adc33d3 --- /dev/null +++ b/body/c_fl_gl_window.cpp @@ -0,0 +1,196 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Gl_Window.H> +#include "c_fl_gl_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Gl_Window : public Fl_Gl_Window { +public: + using Fl_Gl_Window::Fl_Gl_Window; + + friend void fl_gl_window_draw(GLWINDOW n); + friend int fl_gl_window_handle(GLWINDOW n, int e); + + void draw(); + int handle(int e); +}; + +void My_Gl_Window::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Gl_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +GLWINDOW new_fl_gl_window(int x, int y, int w, int h, char* label) { + My_Gl_Window *gw = new My_Gl_Window(x, y, w, h, label); + return gw; +} + +GLWINDOW new_fl_gl_window2(int w, int h, char* label) { + My_Gl_Window *gw = new My_Gl_Window(w, h, label); + return gw; +} + +void free_fl_gl_window(GLWINDOW w) { + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Gl_Window*>(w); + } +} + + + + +void fl_gl_window_show(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->show(); +} + +void fl_gl_window_show2(GLWINDOW w, int c, void * v) { + static_cast<Fl_Gl_Window*>(w)->show(c, static_cast<char**>(v)); +} + +void fl_gl_window_hide(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->hide(); +} + +void fl_gl_window_hide_overlay(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->hide_overlay(); +} + +void fl_gl_window_flush(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->flush(); +} + + + + +int fl_gl_window_pixel_h(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->pixel_h(); +} + +int fl_gl_window_pixel_w(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->pixel_w(); +} + +float fl_gl_window_pixels_per_unit(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->pixels_per_unit(); +} + +void fl_gl_window_resize(GLWINDOW gw, int x, int y, int w, int h) { + static_cast<Fl_Gl_Window*>(gw)->resize(x, y, w, h); +} + + + + +unsigned int fl_gl_window_get_mode(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->mode(); +} + +void fl_gl_window_set_mode(GLWINDOW w, unsigned int a) { + static_cast<Fl_Gl_Window*>(w)->mode(a); +} + +int fl_gl_window_static_can_do(unsigned int m) { + return Fl_Gl_Window::can_do(m); +} + +int fl_gl_window_can_do(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->can_do(); +} + +int fl_gl_window_can_do_overlay(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->can_do_overlay(); +} + + + + +void * fl_gl_window_get_context(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->context(); +} + +void fl_gl_window_set_context(GLWINDOW w, void * con, int des) { + static_cast<Fl_Gl_Window*>(w)->context(con, des); +} + +char fl_gl_window_context_valid(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->context_valid(); +} + +void fl_gl_window_set_context_valid(GLWINDOW w, char v) { + static_cast<Fl_Gl_Window*>(w)->context_valid(v); +} + +char fl_gl_window_valid(GLWINDOW w) { + return static_cast<Fl_Gl_Window*>(w)->valid(); +} + +void fl_gl_window_set_valid(GLWINDOW w, char v) { + static_cast<Fl_Gl_Window*>(w)->valid(v); +} + +void fl_gl_window_invalidate(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->invalidate(); +} + +void fl_gl_window_make_current(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->make_current(); +} + +void fl_gl_window_make_overlay_current(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->make_overlay_current(); +} + + + + +void fl_gl_window_ortho(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->ortho(); +} + +void fl_gl_window_redraw_overlay(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->redraw_overlay(); +} + +void fl_gl_window_swap_buffers(GLWINDOW w) { + static_cast<Fl_Gl_Window*>(w)->swap_buffers(); +} + + + + +void fl_gl_window_draw(GLWINDOW n) { + static_cast<My_Gl_Window*>(n)->Fl_Gl_Window::draw(); +} + +int fl_gl_window_handle(GLWINDOW n, int e) { + return static_cast<My_Gl_Window*>(n)->Fl_Gl_Window::handle(e); +} + + diff --git a/body/c_fl_gl_window.h b/body/c_fl_gl_window.h new file mode 100644 index 0000000..6177db6 --- /dev/null +++ b/body/c_fl_gl_window.h @@ -0,0 +1,61 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_GL_WINDOW_GUARD +#define FL_GL_WINDOW_GUARD + + +typedef void* GLWINDOW; + + +extern "C" GLWINDOW new_fl_gl_window(int x, int y, int w, int h, char* label); +extern "C" GLWINDOW new_fl_gl_window2(int w, int h, char* label); +extern "C" void free_fl_gl_window(GLWINDOW w); + + +extern "C" void fl_gl_window_show(GLWINDOW w); +extern "C" void fl_gl_window_show2(GLWINDOW w, int c, void * v); +extern "C" void fl_gl_window_hide(GLWINDOW w); +extern "C" void fl_gl_window_hide_overlay(GLWINDOW w); +extern "C" void fl_gl_window_flush(GLWINDOW w); + + +extern "C" int fl_gl_window_pixel_h(GLWINDOW w); +extern "C" int fl_gl_window_pixel_w(GLWINDOW w); +extern "C" float fl_gl_window_pixels_per_unit(GLWINDOW w); +extern "C" void fl_gl_window_resize(GLWINDOW gw, int x, int y, int w, int h); + + +extern "C" unsigned int fl_gl_window_get_mode(GLWINDOW w); +extern "C" void fl_gl_window_set_mode(GLWINDOW w, unsigned int a); +extern "C" int fl_gl_window_static_can_do(unsigned int m); +extern "C" int fl_gl_window_can_do(GLWINDOW w); +extern "C" int fl_gl_window_can_do_overlay(GLWINDOW w); + + +extern "C" void * fl_gl_window_get_context(GLWINDOW w); +extern "C" void fl_gl_window_set_context(GLWINDOW w, void * con, int des); +extern "C" char fl_gl_window_context_valid(GLWINDOW w); +extern "C" void fl_gl_window_set_context_valid(GLWINDOW w, char v); +extern "C" char fl_gl_window_valid(GLWINDOW w); +extern "C" void fl_gl_window_set_valid(GLWINDOW w, char v); +extern "C" void fl_gl_window_invalidate(GLWINDOW w); +extern "C" void fl_gl_window_make_current(GLWINDOW w); +extern "C" void fl_gl_window_make_overlay_current(GLWINDOW w); + + +extern "C" void fl_gl_window_ortho(GLWINDOW w); +extern "C" void fl_gl_window_redraw_overlay(GLWINDOW w); +extern "C" void fl_gl_window_swap_buffers(GLWINDOW w); + + +extern "C" void fl_gl_window_draw(GLWINDOW n); +extern "C" int fl_gl_window_handle(GLWINDOW n, int e); + + +#endif + + diff --git a/body/c_fl_graphics_driver.cpp b/body/c_fl_graphics_driver.cpp new file mode 100644 index 0000000..56bcf62 --- /dev/null +++ b/body/c_fl_graphics_driver.cpp @@ -0,0 +1,63 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Device.H> +#include <FL/Fl_Image.H> +#include "c_fl_graphics_driver.h" + + + + +unsigned int fl_graphics_driver_color(GRAPHICSDRIVER g) { + return static_cast<Fl_Graphics_Driver*>(g)->color(); +} + + + + +int fl_graphics_driver_descent(GRAPHICSDRIVER g) { + // virtual so disable dispatch + return static_cast<Fl_Graphics_Driver*>(g)->Fl_Graphics_Driver::descent(); +} + +int fl_graphics_driver_height(GRAPHICSDRIVER g) { + // virtual so disable dispatch + return static_cast<Fl_Graphics_Driver*>(g)->Fl_Graphics_Driver::height(); +} + +double fl_graphics_driver_width(GRAPHICSDRIVER g, unsigned int c) { + // virtual so disable dispatch + return static_cast<Fl_Graphics_Driver*>(g)->Fl_Graphics_Driver::width(c); +} + +double fl_graphics_driver_width2(GRAPHICSDRIVER g, const char * s, int l) { + // virtual so disable dispatch + return static_cast<Fl_Graphics_Driver*>(g)->Fl_Graphics_Driver::width(s,l); +} + +int fl_graphics_driver_get_font(GRAPHICSDRIVER g) { + return static_cast<Fl_Graphics_Driver*>(g)->font(); +} + +int fl_graphics_driver_size(GRAPHICSDRIVER g) { + return static_cast<Fl_Graphics_Driver*>(g)->size(); +} + +void fl_graphics_driver_set_font(GRAPHICSDRIVER g, int f, int s) { + // virtual so disable dispatch + static_cast<Fl_Graphics_Driver*>(g)->Fl_Graphics_Driver::font(f,s); +} + + + + +void fl_graphics_driver_draw_scaled(GRAPHICSDRIVER g, void * i, int x, int y, int w, int h) { + // virtual so disable dispatch + static_cast<Fl_Graphics_Driver*>(g)->Fl_Graphics_Driver::draw_scaled + (static_cast<Fl_Image*>(i),x,y,w,h); +} + + diff --git a/body/c_fl_graphics_driver.h b/body/c_fl_graphics_driver.h new file mode 100644 index 0000000..e070235 --- /dev/null +++ b/body/c_fl_graphics_driver.h @@ -0,0 +1,32 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_GRAPHICS_DRIVER_GUARD +#define FL_GRAPHICS_DRIVER_GUARD + + +typedef void* GRAPHICSDRIVER; + + +extern "C" unsigned int fl_graphics_driver_color(GRAPHICSDRIVER g); + + +extern "C" int fl_graphics_driver_descent(GRAPHICSDRIVER g); +extern "C" int fl_graphics_driver_height(GRAPHICSDRIVER g); +extern "C" double fl_graphics_driver_width(GRAPHICSDRIVER g, unsigned int c); +extern "C" double fl_graphics_driver_width2(GRAPHICSDRIVER g, const char * s, int l); +extern "C" int fl_graphics_driver_get_font(GRAPHICSDRIVER g); +extern "C" int fl_graphics_driver_size(GRAPHICSDRIVER g); +extern "C" void fl_graphics_driver_set_font(GRAPHICSDRIVER g, int f, int s); + + +extern "C" void fl_graphics_driver_draw_scaled(GRAPHICSDRIVER g, void * i, + int x, int y, int w, int h); + + +#endif + + diff --git a/body/c_fl_group.cpp b/body/c_fl_group.cpp new file mode 100644 index 0000000..dde521c --- /dev/null +++ b/body/c_fl_group.cpp @@ -0,0 +1,198 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Group.H> +#include <FL/Fl_Widget.H> +#include "c_fl_group.h" +#include "c_fl_widget.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Group : Fl_Group { +public: + using Fl_Group::draw_child; + using Fl_Group::draw_children; + using Fl_Group::draw_outside_label; + using Fl_Group::update_child; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Group : public Fl_Group { +public: + using Fl_Group::Fl_Group; + + friend void fl_group_draw(GROUP g); + friend int fl_group_handle(GROUP g, int e); + + void draw(); + int handle(int e); +}; + +void My_Group::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Group::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +GROUP new_fl_group(int x, int y, int w, int h, char* label) { + My_Group *g = new My_Group(x, y, w, h, label); + return g; +} + +void free_fl_group(GROUP g) { + if (fl_inside_callback) { + fl_delete_widget(g); + } else { + delete static_cast<My_Group*>(g); + } +} + + + + +void fl_group_add(GROUP g, WIDGET item) { + static_cast<Fl_Group*>(g)->add(static_cast<Fl_Widget*>(item)); +} + +void fl_group_insert(GROUP g, WIDGET item, int place) { + static_cast<Fl_Group*>(g)->insert(*(static_cast<Fl_Widget*>(item)), place); +} + +void fl_group_insert2(GROUP g, WIDGET item, WIDGET before) { + static_cast<Fl_Group*>(g)->insert(*(static_cast<Fl_Widget*>(item)), static_cast<Fl_Widget*>(before)); +} + +void fl_group_remove(GROUP g, WIDGET item) { + static_cast<Fl_Group*>(g)->remove(static_cast<Fl_Widget*>(item)); +} + +void fl_group_remove2(GROUP g, int place) { + static_cast<Fl_Group*>(g)->remove(place); +} + + + + +void * fl_group_child(GROUP g, int place) { + return static_cast<Fl_Group*>(g)->child(place); +} + +int fl_group_find(GROUP g, WIDGET item) { + return static_cast<Fl_Group*>(g)->find(static_cast<Fl_Widget*>(item)); +} + +int fl_group_children(GROUP g) { + return static_cast<Fl_Group*>(g)->children(); +} + + + + +unsigned int fl_group_get_clip_children(GROUP g) { + return static_cast<Fl_Group*>(g)->clip_children(); +} + +void fl_group_set_clip_children(GROUP g, int c) { + static_cast<Fl_Group*>(g)->clip_children(c); +} + + + + +void fl_group_add_resizable(GROUP g, WIDGET w) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + static_cast<Fl_Group*>(g)->add_resizable(ref); +} + +void * fl_group_get_resizable(GROUP g) { + return static_cast<Fl_Group*>(g)->resizable(); +} + +void fl_group_set_resizable(GROUP g, WIDGET item) { + static_cast<Fl_Group*>(g)->resizable(static_cast<Fl_Widget*>(item)); +} + +void fl_group_init_sizes(GROUP g) { + static_cast<Fl_Group*>(g)->init_sizes(); +} + +void fl_group_resize(GROUP g, int x, int y, int w, int h) { + static_cast<Fl_Group*>(g)->resize(x, y, w, h); +} + + + + +void * fl_group_get_current() { + return Fl_Group::current(); +} + +void fl_group_set_current(GROUP g) { + Fl_Group::current(static_cast<Fl_Group*>(g)); +} + +void fl_group_begin(GROUP g) { + static_cast<Fl_Group*>(g)->begin(); +} + +void fl_group_end(GROUP g) { + static_cast<Fl_Group*>(g)->end(); +} + + + + +void fl_group_draw(GROUP g) { + static_cast<My_Group*>(g)->Fl_Group::draw(); +} + +void fl_group_draw_child(GROUP g, WIDGET w) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + (static_cast<Fl_Group*>(g)->*(&Friend_Group::draw_child))(ref); +} + +void fl_group_draw_children(GROUP g) { + (static_cast<Fl_Group*>(g)->*(&Friend_Group::draw_children))(); +} + +void fl_group_draw_outside_label(GROUP g, WIDGET w) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + (static_cast<Fl_Group*>(g)->*(&Friend_Group::draw_outside_label))(ref); +} + +void fl_group_update_child(GROUP g, WIDGET w) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + (static_cast<Fl_Group*>(g)->*(&Friend_Group::update_child))(ref); +} + +int fl_group_handle(GROUP g, int e) { + return static_cast<My_Group*>(g)->Fl_Group::handle(e); +} + + diff --git a/body/c_fl_group.h b/body/c_fl_group.h new file mode 100644 index 0000000..af4559d --- /dev/null +++ b/body/c_fl_group.h @@ -0,0 +1,59 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_GROUP_GUARD +#define FL_GROUP_GUARD + +#include "c_fl_widget.h" + + +typedef void* GROUP; + + +extern "C" GROUP new_fl_group(int x, int y, int w, int h, char* label); +extern "C" void free_fl_group(GROUP g); + + +extern "C" void fl_group_add(GROUP g, WIDGET item); +extern "C" void fl_group_insert(GROUP g, WIDGET item, int place); +extern "C" void fl_group_insert2(GROUP g, WIDGET item, WIDGET before); +extern "C" void fl_group_remove(GROUP g, WIDGET item); +extern "C" void fl_group_remove2(GROUP g, int place); + + +extern "C" void * fl_group_child(GROUP g, int place); +extern "C" int fl_group_find(GROUP g, WIDGET item); +extern "C" int fl_group_children(GROUP g); + + +extern "C" unsigned int fl_group_get_clip_children(GROUP g); +extern "C" void fl_group_set_clip_children(GROUP g, int c); + + +extern "C" void fl_group_add_resizable(GROUP g, WIDGET w); +extern "C" void * fl_group_get_resizable(GROUP g); +extern "C" void fl_group_set_resizable(GROUP g, WIDGET item); +extern "C" void fl_group_init_sizes(GROUP g); +extern "C" void fl_group_resize(GROUP g, int x, int y, int w, int h); + + +extern "C" void * fl_group_get_current(); +extern "C" void fl_group_set_current(GROUP g); +extern "C" void fl_group_begin(GROUP g); +extern "C" void fl_group_end(GROUP g); + + +extern "C" void fl_group_draw(GROUP g); +extern "C" void fl_group_draw_child(GROUP g, WIDGET w); +extern "C" void fl_group_draw_children(GROUP g); +extern "C" void fl_group_draw_outside_label(GROUP g, WIDGET w); +extern "C" void fl_group_update_child(GROUP g, WIDGET w); +extern "C" int fl_group_handle(GROUP g, int e); + + +#endif + + diff --git a/body/c_fl_help_dialog.cpp b/body/c_fl_help_dialog.cpp new file mode 100644 index 0000000..850fb07 --- /dev/null +++ b/body/c_fl_help_dialog.cpp @@ -0,0 +1,105 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Help_Dialog.H> +#include "c_fl_help_dialog.h" + + + + +HELPDIALOG new_fl_help_dialog() { + Fl_Help_Dialog *d = new Fl_Help_Dialog(); + return d; +} + +void free_fl_help_dialog(HELPDIALOG d) { + delete static_cast<Fl_Help_Dialog*>(d); +} + + + + +void fl_help_dialog_show(HELPDIALOG d) { + static_cast<Fl_Help_Dialog*>(d)->show(); +} + +void fl_help_dialog_show2(HELPDIALOG d, int c, void * v) { + static_cast<Fl_Help_Dialog*>(d)->show(c, static_cast<char**>(v)); +} + +void fl_help_dialog_hide(HELPDIALOG d) { + static_cast<Fl_Help_Dialog*>(d)->hide(); +} + +int fl_help_dialog_visible(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->visible(); +} + + + + +void fl_help_dialog_set_topline_number(HELPDIALOG d, int n) { + static_cast<Fl_Help_Dialog*>(d)->topline(n); +} + +void fl_help_dialog_set_topline_target(HELPDIALOG d, const char * t) { + static_cast<Fl_Help_Dialog*>(d)->topline(t); +} + + + + +void fl_help_dialog_load(HELPDIALOG d, const char * n) { + static_cast<Fl_Help_Dialog*>(d)->load(n); +} + +const char * fl_help_dialog_get_value(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->value(); +} + +void fl_help_dialog_set_value(HELPDIALOG d, const char * v) { + static_cast<Fl_Help_Dialog*>(d)->value(v); +} + + + + +int fl_help_dialog_get_textsize(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->textsize(); +} + +void fl_help_dialog_set_textsize(HELPDIALOG d, int s) { + static_cast<Fl_Help_Dialog*>(d)->textsize(s); +} + + + + +int fl_help_dialog_get_x(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->x(); +} + +int fl_help_dialog_get_y(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->y(); +} + +int fl_help_dialog_get_w(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->w(); +} + +int fl_help_dialog_get_h(HELPDIALOG d) { + return static_cast<Fl_Help_Dialog*>(d)->h(); +} + +void fl_help_dialog_resize(HELPDIALOG d, int xx, int yy, int ww, int hh) { + static_cast<Fl_Help_Dialog*>(d)->resize(xx, yy, ww, hh); +} + +void fl_help_dialog_position(HELPDIALOG d, int xx, int yy) { + static_cast<Fl_Help_Dialog*>(d)->position(xx, yy); +} + + diff --git a/body/c_fl_help_dialog.h b/body/c_fl_help_dialog.h new file mode 100644 index 0000000..ddabce8 --- /dev/null +++ b/body/c_fl_help_dialog.h @@ -0,0 +1,47 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HELP_DIALOG_GUARD +#define FL_HELP_DIALOG_GUARD + + +typedef void* HELPDIALOG; + + +extern "C" HELPDIALOG new_fl_help_dialog(); +extern "C" void free_fl_help_dialog(HELPDIALOG d); + + +extern "C" void fl_help_dialog_show(HELPDIALOG d); +extern "C" void fl_help_dialog_show2(HELPDIALOG d, int c, void * v); +extern "C" void fl_help_dialog_hide(HELPDIALOG d); +extern "C" int fl_help_dialog_visible(HELPDIALOG d); + + +extern "C" void fl_help_dialog_set_topline_number(HELPDIALOG d, int n); +extern "C" void fl_help_dialog_set_topline_target(HELPDIALOG d, const char * t); + + +extern "C" void fl_help_dialog_load(HELPDIALOG d, const char * n); +extern "C" const char * fl_help_dialog_get_value(HELPDIALOG d); +extern "C" void fl_help_dialog_set_value(HELPDIALOG d, const char * v); + + +extern "C" int fl_help_dialog_get_textsize(HELPDIALOG d); +extern "C" void fl_help_dialog_set_textsize(HELPDIALOG d, int s); + + +extern "C" int fl_help_dialog_get_x(HELPDIALOG d); +extern "C" int fl_help_dialog_get_y(HELPDIALOG d); +extern "C" int fl_help_dialog_get_w(HELPDIALOG d); +extern "C" int fl_help_dialog_get_h(HELPDIALOG d); +extern "C" void fl_help_dialog_resize(HELPDIALOG d, int xx, int yy, int ww, int hh); +extern "C" void fl_help_dialog_position(HELPDIALOG d, int xx, int yy); + + +#endif + + diff --git a/body/c_fl_help_view.cpp b/body/c_fl_help_view.cpp new file mode 100644 index 0000000..db7807e --- /dev/null +++ b/body/c_fl_help_view.cpp @@ -0,0 +1,198 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Group.H> +#include <FL/Fl_Help_View.H> +#include <FL/Enumerations.H> +#include "c_fl_help_view.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Help_View : public Fl_Help_View { +public: + using Fl_Help_View::Fl_Help_View; + + friend void fl_help_view_draw(HELPVIEW v); + friend int fl_help_view_handle(HELPVIEW v, int e); + + void draw(); + int handle(int e); +}; + +void My_Help_View::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Help_View::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +HELPVIEW new_fl_help_view(int x, int y, int w, int h, char * label) { + My_Help_View *v = new My_Help_View(x, y, w, h, label); + return v; +} + +void free_fl_help_view(HELPVIEW v) { + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Help_View*>(v); + } +} + + + + +void fl_help_view_clear_selection(HELPVIEW v) { + static_cast<Fl_Help_View*>(v)->clear_selection(); +} + +void fl_help_view_select_all(HELPVIEW v) { + static_cast<Fl_Help_View*>(v)->select_all(); +} + + + + +int fl_help_view_find(HELPVIEW v, const char * s, int p) { + return static_cast<Fl_Help_View*>(v)->find(s, p); +} + +int fl_help_view_get_leftline(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->leftline(); +} + +void fl_help_view_set_leftline(HELPVIEW v, int t) { + static_cast<Fl_Help_View*>(v)->leftline(t); +} + +int fl_help_view_get_topline(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->topline(); +} + +void fl_help_view_set_topline(HELPVIEW v, int t) { + static_cast<Fl_Help_View*>(v)->topline(t); +} + +void fl_help_view_set_topline_target(HELPVIEW v, const char * t) { + static_cast<Fl_Help_View*>(v)->topline(t); +} + + + + +const char * fl_help_view_directory(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->directory(); +} + +const char * fl_help_view_filename(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->filename(); +} + +int fl_help_view_load(HELPVIEW v, const char * f) { + return static_cast<Fl_Help_View*>(v)->load(f); +} + +const char * fl_help_view_title(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->title(); +} + +const char * fl_help_view_get_value(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->value(); +} + +void fl_help_view_set_value(HELPVIEW v, const char * t) { + static_cast<Fl_Help_View*>(v)->value(t); +} + +void fl_help_view_link(HELPVIEW v, void * f) { + static_cast<Fl_Help_View*>(v)->link(reinterpret_cast<Fl_Help_Func*>(f)); +} + + + + +int fl_help_view_get_scrollbar_size(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->scrollbar_size(); +} + +void fl_help_view_set_scrollbar_size(HELPVIEW v, int s) { + static_cast<Fl_Help_View*>(v)->scrollbar_size(s); +} + +int fl_help_view_get_size(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->size(); +} + +void fl_help_view_set_size(HELPVIEW v, int w, int h) { + static_cast<Fl_Help_View*>(v)->size(w, h); +} + +void fl_help_view_resize(HELPVIEW v, int x, int y, int w, int h) { + static_cast<Fl_Help_View*>(v)->resize(x, y, w, h); +} + +unsigned int fl_help_view_get_textcolor(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->textcolor(); +} + +void fl_help_view_set_textcolor(HELPVIEW v, unsigned int c) { + static_cast<Fl_Help_View*>(v)->textcolor(c); +} + +int fl_help_view_get_textfont(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->textfont(); +} + +void fl_help_view_set_textfont(HELPVIEW v, int f) { + static_cast<Fl_Help_View*>(v)->textfont(f); +} + +int fl_help_view_get_textsize(HELPVIEW v) { + return static_cast<Fl_Help_View*>(v)->textsize(); +} + +void fl_help_view_set_textsize(HELPVIEW v, int s) { + static_cast<Fl_Help_View*>(v)->textsize(s); +} + + + + +void fl_help_view_draw(HELPVIEW v) { +#if FL_ABI_VERSION >= 10303 + static_cast<My_Help_View*>(v)->Fl_Help_View::draw(); +#else + static_cast<My_Help_View*>(v)->Fl_Group::draw(); +#endif +} + +int fl_help_view_handle(HELPVIEW v, int e) { +#if FL_ABI_VERSION >= 10303 + return static_cast<My_Help_View*>(v)->Fl_Help_View::handle(e); +#else + return static_cast<My_Help_View*>(v)->Fl_Group::handle(e); +#endif +} + + diff --git a/body/c_fl_help_view.h b/body/c_fl_help_view.h new file mode 100644 index 0000000..b16b344 --- /dev/null +++ b/body/c_fl_help_view.h @@ -0,0 +1,58 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HELP_VIEW_GUARD +#define FL_HELP_VIEW_GUARD + + +typedef void* HELPVIEW; + + +extern "C" HELPVIEW new_fl_help_view(int x, int y, int w, int h, char * label); +extern "C" void free_fl_help_view(HELPVIEW v); + + +extern "C" void fl_help_view_clear_selection(HELPVIEW v); +extern "C" void fl_help_view_select_all(HELPVIEW v); + + +extern "C" int fl_help_view_find(HELPVIEW v, const char * s, int p); +extern "C" int fl_help_view_get_leftline(HELPVIEW v); +extern "C" void fl_help_view_set_leftline(HELPVIEW v, int t); +extern "C" int fl_help_view_get_topline(HELPVIEW v); +extern "C" void fl_help_view_set_topline(HELPVIEW v, int t); +extern "C" void fl_help_view_set_topline_target(HELPVIEW v, const char * t); + + +extern "C" const char * fl_help_view_directory(HELPVIEW v); +extern "C" const char * fl_help_view_filename(HELPVIEW v); +extern "C" int fl_help_view_load(HELPVIEW v, const char * f); +extern "C" const char * fl_help_view_title(HELPVIEW v); +extern "C" const char * fl_help_view_get_value(HELPVIEW v); +extern "C" void fl_help_view_set_value(HELPVIEW v, const char * t); +extern "C" void fl_help_view_link(HELPVIEW v, void * f); + + +extern "C" int fl_help_view_get_scrollbar_size(HELPVIEW v); +extern "C" void fl_help_view_set_scrollbar_size(HELPVIEW v, int s); +extern "C" int fl_help_view_get_size(HELPVIEW v); +extern "C" void fl_help_view_set_size(HELPVIEW v, int w, int h); +extern "C" void fl_help_view_resize(HELPVIEW v, int x, int y, int w, int h); +extern "C" unsigned int fl_help_view_get_textcolor(HELPVIEW v); +extern "C" void fl_help_view_set_textcolor(HELPVIEW v, unsigned int c); +extern "C" int fl_help_view_get_textfont(HELPVIEW v); +extern "C" void fl_help_view_set_textfont(HELPVIEW v, int f); +extern "C" int fl_help_view_get_textsize(HELPVIEW v); +extern "C" void fl_help_view_set_textsize(HELPVIEW v, int s); + + +extern "C" void fl_help_view_draw(HELPVIEW v); +extern "C" int fl_help_view_handle(HELPVIEW v, int e); + + +#endif + + diff --git a/body/c_fl_hold_browser.cpp b/body/c_fl_hold_browser.cpp new file mode 100644 index 0000000..f5c2268 --- /dev/null +++ b/body/c_fl_hold_browser.cpp @@ -0,0 +1,270 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Hold_Browser.H> +#include "c_fl_hold_browser.h" +#include "c_fl.h" + + + + +// 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_Hold_Browser : public Fl_Hold_Browser { +public: + using Fl_Hold_Browser::Fl_Hold_Browser; + + friend int fl_hold_browser_item_width(HOLDBROWSER b, void * item); + friend int fl_hold_browser_item_height(HOLDBROWSER b, void * item); + friend void * fl_hold_browser_item_first(HOLDBROWSER b); + friend void * fl_hold_browser_item_last(HOLDBROWSER b); + friend void * fl_hold_browser_item_next(HOLDBROWSER b, void * item); + friend void * fl_hold_browser_item_prev(HOLDBROWSER b, void * item); + friend void * fl_hold_browser_item_at(HOLDBROWSER b, int index); + friend void fl_hold_browser_item_select(HOLDBROWSER b, void * item, int val); + friend int fl_hold_browser_item_selected(HOLDBROWSER b, void * item); + friend void fl_hold_browser_item_swap(HOLDBROWSER b, void * x, void * y); + friend const char * fl_hold_browser_item_text(HOLDBROWSER b, void * item); + friend void fl_hold_browser_item_draw(HOLDBROWSER b, void * item, int x, int y, int w, int h); + + friend int fl_hold_browser_full_width(HOLDBROWSER c); + friend int fl_hold_browser_full_height(HOLDBROWSER c); + friend int fl_hold_browser_incr_height(HOLDBROWSER c); + friend int fl_hold_browser_item_quick_height(HOLDBROWSER c, void * i); + + friend void fl_hold_browser_draw(HOLDBROWSER b); + + int handle(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 My_Hold_Browser::full_width() const { + return browser_full_width_hook(this->user_data()); +} + +int My_Hold_Browser::full_height() const { + return browser_full_height_hook(this->user_data()); +} + +int My_Hold_Browser::incr_height() const { + return browser_incr_height_hook(this->user_data()); +} + +int My_Hold_Browser::item_quick_height(void * item) const { + return browser_item_quick_height_hook(this->user_data(), item); +} + + +int My_Hold_Browser::item_width(void * item) const { + return browser_item_width_hook(this->user_data(), item); +} + +int My_Hold_Browser::item_height(void * item) const { + return browser_item_height_hook(this->user_data(), item); +} + +void * My_Hold_Browser::item_first() const { + return browser_item_first_hook(this->user_data()); +} + +void * My_Hold_Browser::item_last() const { + return browser_item_last_hook(this->user_data()); +} + +void * My_Hold_Browser::item_next(void * item) const { + return browser_item_next_hook(this->user_data(), item); +} + +void * My_Hold_Browser::item_prev(void * item) const { + return browser_item_prev_hook(this->user_data(), item); +} + +void * My_Hold_Browser::item_at(int index) const { + return browser_item_at_hook(this->user_data(), index); +} + +void My_Hold_Browser::item_select(void * item, int val) { + browser_item_select_hook(this->user_data(), item, val); +} + +int My_Hold_Browser::item_selected(void * item) const { + return browser_item_selected_hook(this->user_data(), item); +} + +void My_Hold_Browser::item_swap(void * a, void * b) { + browser_item_swap_hook(this->user_data(), a, b); +} + +const char * My_Hold_Browser::item_text(void * item) const { + return browser_item_text_hook(this->user_data(), item); +} + +void My_Hold_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_Hold_Browser::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Hold_Browser::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +HOLDBROWSER new_fl_hold_browser(int x, int y, int w, int h, char * label) { + My_Hold_Browser *b = new My_Hold_Browser(x, y, w, h, label); + return b; +} + +void free_fl_hold_browser(HOLDBROWSER b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Hold_Browser*>(b); + } +} + + + + +// These have to be reimplemented due to relying on custom class extensions + + +int fl_hold_browser_full_height(HOLDBROWSER c) { + return static_cast<My_Hold_Browser*>(c)->Fl_Hold_Browser::full_height(); +} + +int fl_hold_browser_incr_height(HOLDBROWSER c) { + return static_cast<My_Hold_Browser*>(c)->Fl_Hold_Browser::incr_height(); +} + + + + +int fl_hold_browser_item_width(HOLDBROWSER b, void * item) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_width(item); +} + +int fl_hold_browser_item_height(HOLDBROWSER b, void * item) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_height(item); +} + +void * fl_hold_browser_item_first(HOLDBROWSER b) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_first(); +} + +void * fl_hold_browser_item_last(HOLDBROWSER b) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_last(); +} + +void * fl_hold_browser_item_next(HOLDBROWSER b, void * item) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_next(item); +} + +void * fl_hold_browser_item_prev(HOLDBROWSER b, void * item) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_prev(item); +} + +void * fl_hold_browser_item_at(HOLDBROWSER b, int index) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_at(index); +} + +void fl_hold_browser_item_select(HOLDBROWSER b, void * item, int val) { + static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_select(item, val); +} + +int fl_hold_browser_item_selected(HOLDBROWSER b, void * item) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_selected(item); +} + +void fl_hold_browser_item_swap(HOLDBROWSER b, void * x, void * y) { + static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_swap(x, y); +} + +const char * fl_hold_browser_item_text(HOLDBROWSER b, void * item) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_text(item); +} + +void fl_hold_browser_item_draw(HOLDBROWSER b, void * item, int x, int y, int w, int h) { + static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::item_draw(item, x, y, w, h); +} + + + + +int fl_hold_browser_full_width(HOLDBROWSER c) { + return static_cast<My_Hold_Browser*>(c)->Fl_Hold_Browser::full_width(); +} + +int fl_hold_browser_item_quick_height(HOLDBROWSER c, void * i) { + return static_cast<My_Hold_Browser*>(c)->Fl_Hold_Browser::item_quick_height(i); +} + + + + +void fl_hold_browser_draw(HOLDBROWSER b) { + static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::draw(); +} + +int fl_hold_browser_handle(HOLDBROWSER b, int e) { + return static_cast<My_Hold_Browser*>(b)->Fl_Hold_Browser::handle(e); +} + + diff --git a/body/c_fl_hold_browser.h b/body/c_fl_hold_browser.h new file mode 100644 index 0000000..6f295c6 --- /dev/null +++ b/body/c_fl_hold_browser.h @@ -0,0 +1,48 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HOLD_BROWSER_GUARD +#define FL_HOLD_BROWSER_GUARD + + +typedef void* HOLDBROWSER; + + +extern "C" HOLDBROWSER new_fl_hold_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_hold_browser(HOLDBROWSER b); + + +// reimp below here + +extern "C" int fl_hold_browser_full_height(HOLDBROWSER c); +extern "C" int fl_hold_browser_incr_height(HOLDBROWSER c); + + +extern "C" int fl_hold_browser_item_width(HOLDBROWSER b, void * item); +extern "C" int fl_hold_browser_item_height(HOLDBROWSER b, void * item); +extern "C" void * fl_hold_browser_item_first(HOLDBROWSER b); +extern "C" void * fl_hold_browser_item_last(HOLDBROWSER b); +extern "C" void * fl_hold_browser_item_next(HOLDBROWSER b, void * item); +extern "C" void * fl_hold_browser_item_prev(HOLDBROWSER b, void * item); +extern "C" void * fl_hold_browser_item_at(HOLDBROWSER b, int index); +extern "C" void fl_hold_browser_item_select(HOLDBROWSER b, void * item, int val=1); +extern "C" int fl_hold_browser_item_selected(HOLDBROWSER b, void * item); +extern "C" void fl_hold_browser_item_swap(HOLDBROWSER b, void * x, void * y); +extern "C" const char * fl_hold_browser_item_text(HOLDBROWSER b, void * item); +extern "C" void fl_hold_browser_item_draw(HOLDBROWSER b, void * item, int x, int y, int w, int h); + + +extern "C" int fl_hold_browser_full_width(HOLDBROWSER c); +extern "C" int fl_hold_browser_item_quick_height(HOLDBROWSER c, void * i); + + +extern "C" void fl_hold_browser_draw(HOLDBROWSER b); +extern "C" int fl_hold_browser_handle(HOLDBROWSER b, int e); + + +#endif + + diff --git a/body/c_fl_hor_fill_slider.cpp b/body/c_fl_hor_fill_slider.cpp new file mode 100644 index 0000000..1b35cf3 --- /dev/null +++ b/body/c_fl_hor_fill_slider.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Hor_Fill_Slider.H> +#include "c_fl_hor_fill_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Hor_Fill_Slider : public Fl_Hor_Fill_Slider { +public: + using Fl_Hor_Fill_Slider::Fl_Hor_Fill_Slider; + + friend void fl_hor_fill_slider_draw(HORFILLSLIDER s); + friend int fl_hor_fill_slider_handle(HORFILLSLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Hor_Fill_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Hor_Fill_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Hor_Fill_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +HORFILLSLIDER new_fl_hor_fill_slider(int x, int y, int w, int h, char* label) { + My_Hor_Fill_Slider *s = new My_Hor_Fill_Slider(x, y, w, h, label); + return s; +} + +void free_fl_hor_fill_slider(HORFILLSLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Hor_Fill_Slider*>(s); + } +} + + + + +void fl_hor_fill_slider_draw(HORFILLSLIDER s) { + static_cast<My_Hor_Fill_Slider*>(s)->Fl_Hor_Fill_Slider::draw(); +} + +int fl_hor_fill_slider_handle(HORFILLSLIDER s, int e) { + return static_cast<My_Hor_Fill_Slider*>(s)->Fl_Hor_Fill_Slider::handle(e); +} + + diff --git a/body/c_fl_hor_fill_slider.h b/body/c_fl_hor_fill_slider.h new file mode 100644 index 0000000..d698a93 --- /dev/null +++ b/body/c_fl_hor_fill_slider.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HOR_FILL_SLIDER_GUARD +#define FL_HOR_FILL_SLIDER_GUARD + + +typedef void* HORFILLSLIDER; + + +extern "C" HORFILLSLIDER new_fl_hor_fill_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_hor_fill_slider(HORFILLSLIDER s); + + +extern "C" void fl_hor_fill_slider_draw(HORFILLSLIDER s); +extern "C" int fl_hor_fill_slider_handle(HORFILLSLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_hor_nice_slider.cpp b/body/c_fl_hor_nice_slider.cpp new file mode 100644 index 0000000..508d28b --- /dev/null +++ b/body/c_fl_hor_nice_slider.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Hor_Nice_Slider.H> +#include "c_fl_hor_nice_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Hor_Nice_Slider : public Fl_Hor_Nice_Slider { +public: + using Fl_Hor_Nice_Slider::Fl_Hor_Nice_Slider; + + friend void fl_hor_nice_slider_draw(HORNICESLIDER s); + friend int fl_hor_nice_slider_handle(HORNICESLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Hor_Nice_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Hor_Nice_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Hor_Nice_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +HORNICESLIDER new_fl_hor_nice_slider(int x, int y, int w, int h, char* label) { + My_Hor_Nice_Slider *s = new My_Hor_Nice_Slider(x, y, w, h, label); + return s; +} + +void free_fl_hor_nice_slider(HORNICESLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Hor_Nice_Slider*>(s); + } +} + + + + +void fl_hor_nice_slider_draw(HORNICESLIDER s) { + static_cast<My_Hor_Nice_Slider*>(s)->Fl_Hor_Nice_Slider::draw(); +} + +int fl_hor_nice_slider_handle(HORNICESLIDER s, int e) { + return static_cast<My_Hor_Nice_Slider*>(s)->Fl_Hor_Nice_Slider::handle(e); +} + + diff --git a/body/c_fl_hor_nice_slider.h b/body/c_fl_hor_nice_slider.h new file mode 100644 index 0000000..a4e3bc1 --- /dev/null +++ b/body/c_fl_hor_nice_slider.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HOR_NICE_SLIDER_GUARD +#define FL_HOR_NICE_SLIDER_GUARD + + +typedef void* HORNICESLIDER; + + +extern "C" HORNICESLIDER new_fl_hor_nice_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_hor_nice_slider(HORNICESLIDER s); + + +extern "C" void fl_hor_nice_slider_draw(HORNICESLIDER s); +extern "C" int fl_hor_nice_slider_handle(HORNICESLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_hor_value_slider.cpp b/body/c_fl_hor_value_slider.cpp new file mode 100644 index 0000000..341eb60 --- /dev/null +++ b/body/c_fl_hor_value_slider.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Hor_Value_Slider.H> +#include "c_fl_hor_value_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Hor_Value_Slider : public Fl_Hor_Value_Slider { +public: + using Fl_Hor_Value_Slider::Fl_Hor_Value_Slider; + + friend void fl_hor_value_slider_draw(HORVALUESLIDER s); + friend int fl_hor_value_slider_handle(HORVALUESLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Hor_Value_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Hor_Value_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Hor_Value_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +HORVALUESLIDER new_fl_hor_value_slider(int x, int y, int w, int h, char* label) { + My_Hor_Value_Slider *s = new My_Hor_Value_Slider(x, y, w, h, label); + return s; +} + +void free_fl_hor_value_slider(HORVALUESLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Hor_Value_Slider*>(s); + } +} + + + + +void fl_hor_value_slider_draw(HORVALUESLIDER s) { + static_cast<My_Hor_Value_Slider*>(s)->Fl_Hor_Value_Slider::draw(); +} + +int fl_hor_value_slider_handle(HORVALUESLIDER s, int e) { + return static_cast<My_Hor_Value_Slider*>(s)->Fl_Hor_Value_Slider::handle(e); +} + + diff --git a/body/c_fl_hor_value_slider.h b/body/c_fl_hor_value_slider.h new file mode 100644 index 0000000..6257313 --- /dev/null +++ b/body/c_fl_hor_value_slider.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HOR_VALUE_SLIDER_GUARD +#define FL_HOR_VALUE_SLIDER_GUARD + + +typedef void* HORVALUESLIDER; + + +extern "C" HORVALUESLIDER new_fl_hor_value_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_hor_value_slider(HORVALUESLIDER s); + + +extern "C" void fl_hor_value_slider_draw(HORVALUESLIDER s); +extern "C" int fl_hor_value_slider_handle(HORVALUESLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_horizontal_slider.cpp b/body/c_fl_horizontal_slider.cpp new file mode 100644 index 0000000..6433a73 --- /dev/null +++ b/body/c_fl_horizontal_slider.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Hor_Slider.H> +#include "c_fl_horizontal_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Horizontal_Slider : public Fl_Hor_Slider { +public: + using Fl_Hor_Slider::Fl_Hor_Slider; + + friend void fl_horizontal_slider_draw(HORIZONTALSLIDER s); + friend int fl_horizontal_slider_handle(HORIZONTALSLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Horizontal_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Horizontal_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Horizontal_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +HORIZONTALSLIDER new_fl_horizontal_slider(int x, int y, int w, int h, char* label) { + My_Horizontal_Slider *s = new My_Horizontal_Slider(x, y, w, h, label); + return s; +} + +void free_fl_horizontal_slider(HORIZONTALSLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Horizontal_Slider*>(s); + } +} + + + + +void fl_horizontal_slider_draw(HORIZONTALSLIDER s) { + static_cast<My_Horizontal_Slider*>(s)->Fl_Hor_Slider::draw(); +} + +int fl_horizontal_slider_handle(HORIZONTALSLIDER s, int e) { + return static_cast<My_Horizontal_Slider*>(s)->Fl_Hor_Slider::handle(e); +} + + diff --git a/body/c_fl_horizontal_slider.h b/body/c_fl_horizontal_slider.h new file mode 100644 index 0000000..96dd11a --- /dev/null +++ b/body/c_fl_horizontal_slider.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_HORIZONTAL_SLIDER_GUARD +#define FL_HORIZONTAL_SLIDER_GUARD + + +typedef void* HORIZONTALSLIDER; + + +extern "C" HORIZONTALSLIDER new_fl_horizontal_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_horizontal_slider(HORIZONTALSLIDER s); + + +extern "C" void fl_horizontal_slider_draw(HORIZONTALSLIDER s); +extern "C" int fl_horizontal_slider_handle(HORIZONTALSLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_image.cpp b/body/c_fl_image.cpp new file mode 100644 index 0000000..cf24c59 --- /dev/null +++ b/body/c_fl_image.cpp @@ -0,0 +1,138 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Image.H> +#include "c_fl_image.h" + + + + +// Enums, macros, and constants + +const int fl_image_err_no_image = Fl_Image::ERR_NO_IMAGE; +const int fl_image_err_file_access = Fl_Image::ERR_FILE_ACCESS; +const int fl_image_err_format = Fl_Image::ERR_FORMAT; + + + + +// Non-friend protected access + +class Friend_Image : Fl_Image { +public: + using Fl_Image::draw_empty; +}; + + + + +// Flattened C API + +IMAGE new_fl_image(int w, int h, int d) { + Fl_Image *i = new Fl_Image(w, h, d); + return i; +} + +void free_fl_image(IMAGE i) { + delete static_cast<Fl_Image*>(i); +} + + + + +int fl_image_get_rgb_scaling() { + return Fl_Image::RGB_scaling(); +} + +void fl_image_set_rgb_scaling(int t) { + Fl_Image::RGB_scaling(static_cast<Fl_RGB_Scaling>(t)); +} + +IMAGE fl_image_copy(IMAGE i, int w, int h) { + // virtual so disable dispatch + return static_cast<Fl_Image*>(i)->Fl_Image::copy(w, h); +} + +IMAGE fl_image_copy2(IMAGE i) { + return static_cast<Fl_Image*>(i)->copy(); +} + + + + +void fl_image_color_average(IMAGE i, int c, float b) { + // virtual so disable dispatch + static_cast<Fl_Image*>(i)->Fl_Image::color_average(c, b); +} + +void fl_image_desaturate(IMAGE i) { + // virtual so disable dispatch + static_cast<Fl_Image*>(i)->Fl_Image::desaturate(); +} + + + + +void fl_image_inactive(IMAGE i) { + static_cast<Fl_Image*>(i)->inactive(); +} + +int fl_image_fail(IMAGE i) { + return static_cast<Fl_Image*>(i)->fail(); +} + +void fl_image_uncache(IMAGE i) { + // virtual so disable dispatch + static_cast<Fl_Image*>(i)->Fl_Image::uncache(); +} + + + + +int fl_image_w(IMAGE i) { + return static_cast<Fl_Image*>(i)->w(); +} + +int fl_image_h(IMAGE i) { + return static_cast<Fl_Image*>(i)->h(); +} + +int fl_image_d(IMAGE i) { + return static_cast<Fl_Image*>(i)->d(); +} + +int fl_image_ld(IMAGE i) { + return static_cast<Fl_Image*>(i)->ld(); +} + + + + +const void * fl_image_data(IMAGE i) { + return static_cast<Fl_Image*>(i)->data(); +} + +int fl_image_count(IMAGE i) { + return static_cast<Fl_Image*>(i)->count(); +} + + + + +void fl_image_draw(IMAGE i, int x, int y) { + static_cast<Fl_Image*>(i)->draw(x, y); +} + +void fl_image_draw2(IMAGE i, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + static_cast<Fl_Image*>(i)->Fl_Image::draw(x, y, w, h, cx, cy); +} + +void fl_image_draw_empty(IMAGE i, int x, int y) { + (static_cast<Fl_Image*>(i)->*(&Friend_Image::draw_empty))(x, y); +} + + diff --git a/body/c_fl_image.h b/body/c_fl_image.h new file mode 100644 index 0000000..24ef65c --- /dev/null +++ b/body/c_fl_image.h @@ -0,0 +1,55 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_IMAGE_GUARD +#define FL_IMAGE_GUARD + + +extern "C" const int fl_image_err_no_image; +extern "C" const int fl_image_err_file_access; +extern "C" const int fl_image_err_format; + + +typedef void* IMAGE; + + +extern "C" IMAGE new_fl_image(int w, int h, int d); +extern "C" void free_fl_image(IMAGE i); + + +extern "C" int fl_image_get_rgb_scaling(); +extern "C" void fl_image_set_rgb_scaling(int t); +extern "C" IMAGE fl_image_copy(IMAGE i, int w, int h); +extern "C" IMAGE fl_image_copy2(IMAGE i); + + +extern "C" void fl_image_color_average(IMAGE i, int c, float b); +extern "C" void fl_image_desaturate(IMAGE i); + + +extern "C" void fl_image_inactive(IMAGE i); +extern "C" int fl_image_fail(IMAGE i); +extern "C" void fl_image_uncache(IMAGE i); + + +extern "C" int fl_image_w(IMAGE i); +extern "C" int fl_image_h(IMAGE i); +extern "C" int fl_image_d(IMAGE i); +extern "C" int fl_image_ld(IMAGE i); + + +extern "C" const void * fl_image_data(IMAGE i); +extern "C" int fl_image_count(IMAGE i); + + +extern "C" void fl_image_draw(IMAGE i, int x, int y); +extern "C" void fl_image_draw2(IMAGE i, int x, int y, int w, int h, int cx, int cy); +extern "C" void fl_image_draw_empty(IMAGE i, int x, int y); + + +#endif + + diff --git a/body/c_fl_image_surface.cpp b/body/c_fl_image_surface.cpp new file mode 100644 index 0000000..51df5fb --- /dev/null +++ b/body/c_fl_image_surface.cpp @@ -0,0 +1,55 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Image_Surface.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Window.H> +#include "c_fl_image_surface.h" + + + + +// Flattened C API + +IMAGESURFACE new_fl_image_surface(int w, int h, int r) { + Fl_Image_Surface *s = new Fl_Image_Surface(w,h,r); + return s; +} + +void free_fl_image_surface(IMAGESURFACE s) { + delete static_cast<Fl_Image_Surface*>(s); +} + + + + +void fl_image_surface_draw(IMAGESURFACE s, void * w, int dx, int dy) { + static_cast<Fl_Image_Surface*>(s)->draw(static_cast<Fl_Widget*>(w),dx,dy); +} + +void fl_image_surface_draw_decorated_window(IMAGESURFACE s, void * w, int dx, int dy) { + static_cast<Fl_Image_Surface*>(s)->draw_decorated_window(static_cast<Fl_Window*>(w),dx,dy); +} + + + + +void * fl_image_surface_image(IMAGESURFACE s) { + return static_cast<Fl_Image_Surface*>(s)->image(); +} + +void * fl_image_surface_highres_image(IMAGESURFACE s) { + return static_cast<Fl_Image_Surface*>(s)->highres_image(); +} + + + + +void fl_image_surface_set_current(IMAGESURFACE s) { + static_cast<Fl_Image_Surface*>(s)->set_current(); +} + + diff --git a/body/c_fl_image_surface.h b/body/c_fl_image_surface.h new file mode 100644 index 0000000..a4ffd65 --- /dev/null +++ b/body/c_fl_image_surface.h @@ -0,0 +1,31 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_IMAGE_SURFACE_GUARD +#define FL_IMAGE_SURFACE_GUARD + + +typedef void* IMAGESURFACE; + + +extern "C" IMAGESURFACE new_fl_image_surface(int w, int h, int r); +extern "C" void free_fl_image_surface(IMAGESURFACE s); + + +extern "C" void fl_image_surface_draw(IMAGESURFACE s, void * w, int dx, int dy); +extern "C" void fl_image_surface_draw_decorated_window(IMAGESURFACE s, void * w, int dx, int dy); + + +extern "C" void * fl_image_surface_image(IMAGESURFACE s); +extern "C" void * fl_image_surface_highres_image(IMAGESURFACE s); + + +extern "C" void fl_image_surface_set_current(IMAGESURFACE s); + + +#endif + + diff --git a/body/c_fl_input.cpp b/body/c_fl_input.cpp new file mode 100644 index 0000000..73517a7 --- /dev/null +++ b/body/c_fl_input.cpp @@ -0,0 +1,82 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Input.H> +#include "c_fl_input.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void text_input_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); +void fl_text_input_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { + text_input_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +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_Text_Input : public Fl_Input { +public: + using Fl_Input::Fl_Input; + + friend void fl_text_input_draw(TEXTINPUT t); + friend int fl_text_input_handle(TEXTINPUT t, int e); + + void draw(); + int handle(int e); +}; + +void My_Text_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Text_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TEXTINPUT new_fl_text_input(int x, int y, int w, int h, char * label) { + My_Text_Input * t = new My_Text_Input(x, y, w, h, label); + return t; +} + +void free_fl_text_input(TEXTINPUT t) { + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Text_Input*>(t); + } +} + + + + +void fl_text_input_draw(TEXTINPUT t) { + static_cast<My_Text_Input*>(t)->Fl_Input::draw(); +} + +int fl_text_input_handle(TEXTINPUT t, int e) { + return static_cast<My_Text_Input*>(t)->Fl_Input::handle(e); +} + + diff --git a/body/c_fl_input.h b/body/c_fl_input.h new file mode 100644 index 0000000..dec6265 --- /dev/null +++ b/body/c_fl_input.h @@ -0,0 +1,28 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TEXT_INPUT_GUARD +#define FL_TEXT_INPUT_GUARD + + +extern "C" void fl_text_input_extra_init + (void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* TEXTINPUT; + + +extern "C" TEXTINPUT new_fl_text_input(int x, int y, int w, int h, char * label); +extern "C" void free_fl_text_input(TEXTINPUT t); + + +extern "C" void fl_text_input_draw(TEXTINPUT t); +extern "C" int fl_text_input_handle(TEXTINPUT t, int e); + + +#endif + + diff --git a/body/c_fl_input_.cpp b/body/c_fl_input_.cpp new file mode 100644 index 0000000..087a4a1 --- /dev/null +++ b/body/c_fl_input_.cpp @@ -0,0 +1,254 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Input_.H> +#include "c_fl_input_.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Input : public Fl_Input_ { +public: + using Fl_Input_::Fl_Input_; + + friend void fl_input_draw(INPUT i); + friend int fl_input_handle(INPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +INPUT new_fl_input(int x, int y, int w, int h, char* label) { + My_Input *i = new My_Input(x, y, w, h, label); + return i; +} + +void free_fl_input(INPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Input*>(i); + } +} + + + + +int fl_input_copy(INPUT i, int c) { + return static_cast<Fl_Input_*>(i)->copy(c); +} + +int fl_input_cut(INPUT i) { + return static_cast<Fl_Input_*>(i)->cut(); +} + +int fl_input_cut2(INPUT i, int b) { + return static_cast<Fl_Input_*>(i)->cut(b); +} + +int fl_input_cut3(INPUT i, int a, int b) { + return static_cast<Fl_Input_*>(i)->cut(a,b); +} + +int fl_input_copy_cuts(INPUT i) { + return static_cast<Fl_Input_*>(i)->copy_cuts(); +} + +int fl_input_undo(INPUT i) { + return static_cast<Fl_Input_*>(i)->undo(); +} + + + + +int fl_input_get_readonly(INPUT i) { + return static_cast<Fl_Input_*>(i)->readonly(); +} + +void fl_input_set_readonly(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->readonly(t); +} + +int fl_input_get_tab_nav(INPUT i) { + return static_cast<Fl_Input_*>(i)->tab_nav(); +} + +void fl_input_set_tab_nav(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->tab_nav(t); +} + +int fl_input_get_wrap(INPUT i) { + return static_cast<Fl_Input_*>(i)->wrap(); +} + +void fl_input_set_wrap(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->wrap(t); +} + + + + +int fl_input_get_input_type(INPUT i) { + return static_cast<Fl_Input_*>(i)->input_type(); +} + +void fl_input_set_input_type(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->input_type(t); +} + +int fl_input_get_shortcut(INPUT i) { + return static_cast<Fl_Input_*>(i)->shortcut(); +} + +void fl_input_set_shortcut(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->shortcut(t); +} + +int fl_input_get_mark(INPUT i) { + return static_cast<Fl_Input_*>(i)->mark(); +} + +int fl_input_set_mark(INPUT i, int t) { + return static_cast<Fl_Input_*>(i)->mark(t); +} + +int fl_input_get_position(INPUT i) { + return static_cast<Fl_Input_*>(i)->position(); +} + +int fl_input_set_position(INPUT i, int t) { + return static_cast<Fl_Input_*>(i)->position(t); +} + +int fl_input_set_position2(INPUT i, int p, int m) { + return static_cast<Fl_Input_*>(i)->position(p, m); +} + + + + +unsigned int fl_input_index(INPUT i, int p) { + return static_cast<Fl_Input_*>(i)->index(p); +} + +int fl_input_insert(INPUT i, const char * s, int l) { + return static_cast<Fl_Input_*>(i)->insert(s,l); +} + +int fl_input_replace(INPUT i, int b, int e, const char * s, int l) { + return static_cast<Fl_Input_*>(i)->replace(b,e,s,l); +} + +const char * fl_input_get_value(INPUT i) { + return static_cast<Fl_Input_*>(i)->value(); +} + +int fl_input_set_value(INPUT i, char * s, int len) { + return static_cast<Fl_Input_*>(i)->value(s,len); +} + + + + +int fl_input_get_maximum_size(INPUT i) { + return static_cast<Fl_Input_*>(i)->maximum_size(); +} + +void fl_input_set_maximum_size(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->maximum_size(t); +} + +int fl_input_get_size(INPUT i) { + return static_cast<Fl_Input_*>(i)->size(); +} + + + + +unsigned int fl_input_get_cursor_color(INPUT i) { + return static_cast<Fl_Input_*>(i)->cursor_color(); +} + +void fl_input_set_cursor_color(INPUT i, unsigned int t) { + static_cast<Fl_Input_*>(i)->cursor_color(t); +} + +unsigned int fl_input_get_textcolor(INPUT i) { + return static_cast<Fl_Input_*>(i)->textcolor(); +} + +void fl_input_set_textcolor(INPUT i, unsigned int t) { + static_cast<Fl_Input_*>(i)->textcolor(t); +} + +int fl_input_get_textfont(INPUT i) { + return static_cast<Fl_Input_*>(i)->textfont(); +} + +void fl_input_set_textfont(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->textfont(t); +} + +int fl_input_get_textsize(INPUT i) { + return static_cast<Fl_Input_*>(i)->textsize(); +} + +void fl_input_set_textsize(INPUT i, int t) { + static_cast<Fl_Input_*>(i)->textsize(t); +} + + + + +void fl_input_set_size(INPUT i, int w, int h) { + static_cast<Fl_Input_*>(i)->size(w,h); +} + +void fl_input_resize(INPUT i, int x, int y, int w, int h) { + static_cast<Fl_Input_*>(i)->Fl_Input_::resize(x, y, w, h); +} + + + + +void fl_input_draw(INPUT i) { + // This inherits directly from Fl_Widget::draw, and + // the Fl_Widget draw method doesn't technically exist, so... + (void)(i); + // It is more convenient for this function to exist, however, + // even though it will likely never be called, because it simplifies + // and makes uniform the implementation of the Ada Input Draw subprogram. +} + +int fl_input_handle(INPUT i, int e) { + return static_cast<My_Input*>(i)->Fl_Input_::handle(e); +} + + diff --git a/body/c_fl_input_.h b/body/c_fl_input_.h new file mode 100644 index 0000000..689894e --- /dev/null +++ b/body/c_fl_input_.h @@ -0,0 +1,77 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_INPUT_GUARD +#define FL_INPUT_GUARD + + +typedef void* INPUT; + + +extern "C" INPUT new_fl_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_input(INPUT i); + + +extern "C" int fl_input_copy(INPUT i, int c); +extern "C" int fl_input_cut(INPUT i); +extern "C" int fl_input_cut2(INPUT i, int b); +extern "C" int fl_input_cut3(INPUT i, int a, int b); +extern "C" int fl_input_copy_cuts(INPUT i); +extern "C" int fl_input_undo(INPUT i); + + +extern "C" int fl_input_get_readonly(INPUT i); +extern "C" void fl_input_set_readonly(INPUT i, int t); +extern "C" int fl_input_get_tab_nav(INPUT i); +extern "C" void fl_input_set_tab_nav(INPUT i, int t); +extern "C" int fl_input_get_wrap(INPUT i); +extern "C" void fl_input_set_wrap(INPUT i, int t); + + +extern "C" int fl_input_get_input_type(INPUT i); +extern "C" void fl_input_set_input_type(INPUT i, int t); +extern "C" int fl_input_get_shortcut(INPUT i); +extern "C" void fl_input_set_shortcut(INPUT i, int t); +extern "C" int fl_input_get_mark(INPUT i); +extern "C" int fl_input_set_mark(INPUT i, int t); +extern "C" int fl_input_get_position(INPUT i); +extern "C" int fl_input_set_position(INPUT i, int t); +extern "C" int fl_input_set_position2(INPUT i, int p, int m); + + +extern "C" unsigned int fl_input_index(INPUT i, int p); +extern "C" int fl_input_insert(INPUT i, const char * s, int l); +extern "C" int fl_input_replace(INPUT i, int b, int e, const char * s, int l); +extern "C" const char * fl_input_get_value(INPUT i); +extern "C" int fl_input_set_value(INPUT i, char * s, int len); + + +extern "C" int fl_input_get_maximum_size(INPUT i); +extern "C" void fl_input_set_maximum_size(INPUT i, int t); +extern "C" int fl_input_get_size(INPUT i); + + +extern "C" unsigned int fl_input_get_cursor_color(INPUT i); +extern "C" void fl_input_set_cursor_color(INPUT i, unsigned int t); +extern "C" unsigned int fl_input_get_textcolor(INPUT i); +extern "C" void fl_input_set_textcolor(INPUT i, unsigned int t); +extern "C" int fl_input_get_textfont(INPUT i); +extern "C" void fl_input_set_textfont(INPUT i, int t); +extern "C" int fl_input_get_textsize(INPUT i); +extern "C" void fl_input_set_textsize(INPUT i, int t); + + +extern "C" void fl_input_set_size(INPUT i, int w, int h); +extern "C" void fl_input_resize(INPUT i, int x, int y, int w, int h); + + +extern "C" void fl_input_draw(INPUT n); +extern "C" int fl_input_handle(INPUT i, int e); + + +#endif + + diff --git a/body/c_fl_input_choice.cpp b/body/c_fl_input_choice.cpp new file mode 100644 index 0000000..dea3023 --- /dev/null +++ b/body/c_fl_input_choice.cpp @@ -0,0 +1,156 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Input_Choice.H> +#include "c_fl_input_choice.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Input_Choice : public Fl_Input_Choice { +public: + using Fl_Input_Choice::Fl_Input_Choice; + + friend void fl_input_choice_draw(INPUTCHOICE n); + friend int fl_input_choice_handle(INPUTCHOICE n, int e); + + void draw(); + int handle(int e); +}; + +void My_Input_Choice::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Input_Choice::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +INPUTCHOICE new_fl_input_choice(int x, int y, int w, int h, char* label) { + My_Input_Choice *n = new My_Input_Choice(x, y, w, h, label); + return n; +} + +void free_fl_input_choice(INPUTCHOICE n) { + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Input_Choice*>(n); + } +} + + + + +void * fl_input_choice_input(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->input(); +} + +void * fl_input_choice_menubutton(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->menubutton(); +} + + + + +void fl_input_choice_clear(INPUTCHOICE n) { + static_cast<Fl_Input_Choice*>(n)->clear(); +} + + + + +int fl_input_choice_changed(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->changed(); +} + +void fl_input_choice_clear_changed(INPUTCHOICE n) { + static_cast<Fl_Input_Choice*>(n)->clear_changed(); +} + +void fl_input_choice_set_changed(INPUTCHOICE n) { + static_cast<Fl_Input_Choice*>(n)->set_changed(); +} + +int fl_input_choice_get_down_box(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->down_box(); +} + +void fl_input_choice_set_down_box(INPUTCHOICE n, int t) { + static_cast<Fl_Input_Choice*>(n)->down_box(static_cast<Fl_Boxtype>(t)); +} + +unsigned int fl_input_choice_get_textcolor(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->textcolor(); +} + +void fl_input_choice_set_textcolor(INPUTCHOICE n, unsigned int t) { + static_cast<Fl_Input_Choice*>(n)->textcolor(t); +} + +int fl_input_choice_get_textfont(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->textfont(); +} + +void fl_input_choice_set_textfont(INPUTCHOICE n, int t) { + static_cast<Fl_Input_Choice*>(n)->textfont(t); +} + +int fl_input_choice_get_textsize(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->textsize(); +} + +void fl_input_choice_set_textsize(INPUTCHOICE n, int t) { + static_cast<Fl_Input_Choice*>(n)->textsize(t); +} + +const char * fl_input_choice_get_value(INPUTCHOICE n) { + return static_cast<Fl_Input_Choice*>(n)->value(); +} + +void fl_input_choice_set_value(INPUTCHOICE n, const char * t) { + static_cast<Fl_Input_Choice*>(n)->value(t); +} + +void fl_input_choice_set_value2(INPUTCHOICE n, int t) { + static_cast<Fl_Input_Choice*>(n)->value(t); +} + + + + +void fl_input_choice_resize(INPUTCHOICE n, int x, int y, int w, int h) { + static_cast<Fl_Input_Choice*>(n)->resize(x, y, w, h); +} + + + + +void fl_input_choice_draw(INPUTCHOICE n) { + static_cast<My_Input_Choice*>(n)->Fl_Input_Choice::draw(); +} + +int fl_input_choice_handle(INPUTCHOICE n, int e) { + return static_cast<My_Input_Choice*>(n)->Fl_Input_Choice::handle(e); +} + + diff --git a/body/c_fl_input_choice.h b/body/c_fl_input_choice.h new file mode 100644 index 0000000..a7ee0c3 --- /dev/null +++ b/body/c_fl_input_choice.h @@ -0,0 +1,50 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_INPUT_CHOICE_GUARD +#define FL_INPUT_CHOICE_GUARD + + +typedef void* INPUTCHOICE; + + +extern "C" INPUTCHOICE new_fl_input_choice(int x, int y, int w, int h, char* label); +extern "C" void free_fl_input_choice(INPUTCHOICE n); + + +extern "C" void * fl_input_choice_input(INPUTCHOICE n); +extern "C" void * fl_input_choice_menubutton(INPUTCHOICE n); + + +extern "C" void fl_input_choice_clear(INPUTCHOICE n); + + +extern "C" int fl_input_choice_changed(INPUTCHOICE n); +extern "C" void fl_input_choice_clear_changed(INPUTCHOICE n); +extern "C" void fl_input_choice_set_changed(INPUTCHOICE n); +extern "C" int fl_input_choice_get_down_box(INPUTCHOICE n); +extern "C" void fl_input_choice_set_down_box(INPUTCHOICE n, int t); +extern "C" unsigned int fl_input_choice_get_textcolor(INPUTCHOICE n); +extern "C" void fl_input_choice_set_textcolor(INPUTCHOICE n, unsigned int t); +extern "C" int fl_input_choice_get_textfont(INPUTCHOICE n); +extern "C" void fl_input_choice_set_textfont(INPUTCHOICE n, int t); +extern "C" int fl_input_choice_get_textsize(INPUTCHOICE n); +extern "C" void fl_input_choice_set_textsize(INPUTCHOICE n, int t); +extern "C" const char * fl_input_choice_get_value(INPUTCHOICE n); +extern "C" void fl_input_choice_set_value(INPUTCHOICE n, const char * t); +extern "C" void fl_input_choice_set_value2(INPUTCHOICE n, int t); + + +extern "C" void fl_input_choice_resize(INPUTCHOICE n, int x, int y, int w, int h); + + +extern "C" void fl_input_choice_draw(INPUTCHOICE n); +extern "C" int fl_input_choice_handle(INPUTCHOICE n, int e); + + +#endif + + diff --git a/body/c_fl_int_input.cpp b/body/c_fl_int_input.cpp new file mode 100644 index 0000000..ff96560 --- /dev/null +++ b/body/c_fl_int_input.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Int_Input.H> +#include "c_fl_int_input.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Int_Input : public Fl_Int_Input { +public: + using Fl_Int_Input::Fl_Int_Input; + + friend void fl_int_input_draw(INTINPUT i); + friend int fl_int_input_handle(INTINPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Int_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Int_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +INTINPUT new_fl_int_input(int x, int y, int w, int h, char* label) { + My_Int_Input *i = new My_Int_Input(x, y, w, h, label); + return i; +} + +void free_fl_int_input(INTINPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Int_Input*>(i); + } +} + + + + +void fl_int_input_draw(INTINPUT i) { + static_cast<My_Int_Input*>(i)->Fl_Int_Input::draw(); +} + +int fl_int_input_handle(INTINPUT i, int e) { + return static_cast<My_Int_Input*>(i)->Fl_Int_Input::handle(e); +} + + diff --git a/body/c_fl_int_input.h b/body/c_fl_int_input.h new file mode 100644 index 0000000..e36cfaa --- /dev/null +++ b/body/c_fl_int_input.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_INT_INPUT_GUARD +#define FL_INT_INPUT_GUARD + + +typedef void* INTINPUT; + + +extern "C" INTINPUT new_fl_int_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_int_input(INTINPUT i); + + +extern "C" void fl_int_input_draw(INTINPUT i); +extern "C" int fl_int_input_handle(INTINPUT i, int e); + + +#endif + + diff --git a/body/c_fl_jpeg_image.cpp b/body/c_fl_jpeg_image.cpp new file mode 100644 index 0000000..63cbe8d --- /dev/null +++ b/body/c_fl_jpeg_image.cpp @@ -0,0 +1,26 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_JPEG_Image.H> +#include "c_fl_jpeg_image.h" + + + + +JPEGIMAGE new_fl_jpeg_image(const char * f) { + Fl_JPEG_Image *j = new Fl_JPEG_Image(f); + return j; +} + +JPEGIMAGE new_fl_jpeg_image2(const char *n, void *data) { + Fl_JPEG_Image *j = new Fl_JPEG_Image(n, static_cast<uchar*>(data)); + return j; +} + +void free_fl_jpeg_image(JPEGIMAGE j) { + delete static_cast<Fl_JPEG_Image*>(j); +} + diff --git a/body/c_fl_jpeg_image.h b/body/c_fl_jpeg_image.h new file mode 100644 index 0000000..013ae37 --- /dev/null +++ b/body/c_fl_jpeg_image.h @@ -0,0 +1,21 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_JPEG_IMAGE_GUARD +#define FL_JPEG_IMAGE_GUARD + + +typedef void* JPEGIMAGE; + + +extern "C" JPEGIMAGE new_fl_jpeg_image(const char * f); +extern "C" JPEGIMAGE new_fl_jpeg_image2(const char * n, void *data); +extern "C" void free_fl_jpeg_image(JPEGIMAGE j); + + +#endif + + diff --git a/body/c_fl_label.cpp b/body/c_fl_label.cpp new file mode 100644 index 0000000..b80d3d3 --- /dev/null +++ b/body/c_fl_label.cpp @@ -0,0 +1,99 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Widget.H> +#include <FL/Fl_Image.H> +#include "c_fl_label.h" + + + + +LABEL new_fl_label(const char * v, int f, int s, unsigned int h, int k, unsigned int p) { + Fl_Label *l = new Fl_Label; + l->value = v; + l->font = f; + l->size = s; + l->color = h; + l->align_ = p; + l->type = (uchar)k; + return l; +} + +void free_fl_label(LABEL l) { + delete static_cast<Fl_Label*>(l); +} + + + + +const char * fl_label_get_value(LABEL l) { + return static_cast<Fl_Label*>(l)->value; +} + +void fl_label_set_value(LABEL l, const char * v) { + static_cast<Fl_Label*>(l)->value = v; +} + +int fl_label_get_font(LABEL l) { + return static_cast<Fl_Label*>(l)->font; +} + +void fl_label_set_font(LABEL l, int f) { + static_cast<Fl_Label*>(l)->font = f; +} + +int fl_label_get_size(LABEL l) { + return static_cast<Fl_Label*>(l)->size; +} + +void fl_label_set_size(LABEL l, int s) { + static_cast<Fl_Label*>(l)->size = s; +} + +unsigned int fl_label_get_color(LABEL l) { + return static_cast<Fl_Label*>(l)->color; +} + +void fl_label_set_color(LABEL l, unsigned int h) { + static_cast<Fl_Label*>(l)->color = h; +} + +int fl_label_get_type(LABEL l) { + return (int)static_cast<Fl_Label*>(l)->type; +} + +void fl_label_set_type(LABEL l, int k) { + static_cast<Fl_Label*>(l)->type = (uchar)k; +} + +unsigned int fl_label_get_align(LABEL l) { + return static_cast<Fl_Label*>(l)->align_; +} + +void fl_label_set_align(LABEL l, unsigned int p) { + static_cast<Fl_Label*>(l)->align_ = p; +} + +void fl_label_set_image(LABEL l, void * i) { + static_cast<Fl_Label*>(l)->image = static_cast<Fl_Image*>(i); +} + +void fl_label_set_deimage(LABEL l, void * i) { + static_cast<Fl_Label*>(l)->deimage = static_cast<Fl_Image*>(i); +} + + + + +void fl_label_draw(LABEL l, int x, int y, int w, int h, unsigned int p) { + static_cast<Fl_Label*>(l)->draw(x, y, w, h, p); +} + +void fl_label_measure(LABEL l, int &w, int &h) { + static_cast<Fl_Label*>(l)->measure(w, h); +} + + diff --git a/body/c_fl_label.h b/body/c_fl_label.h new file mode 100644 index 0000000..6da3aca --- /dev/null +++ b/body/c_fl_label.h @@ -0,0 +1,40 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_LABEL_GUARD +#define FL_LABEL_GUARD + + +typedef void* LABEL; + + +extern "C" LABEL new_fl_label(const char * v, int f, int s, unsigned int h, int k, unsigned int p); +extern "C" void free_fl_label(LABEL l); + + +extern "C" const char * fl_label_get_value(LABEL l); +extern "C" void fl_label_set_value(LABEL l, const char * v); +extern "C" int fl_label_get_font(LABEL l); +extern "C" void fl_label_set_font(LABEL l, int f); +extern "C" int fl_label_get_size(LABEL l); +extern "C" void fl_label_set_size(LABEL l, int s); +extern "C" unsigned int fl_label_get_color(LABEL l); +extern "C" void fl_label_set_color(LABEL l, unsigned int h); +extern "C" int fl_label_get_type(LABEL l); +extern "C" void fl_label_set_type(LABEL l, int k); +extern "C" unsigned int fl_label_get_align(LABEL l); +extern "C" void fl_label_set_align(LABEL l, unsigned int p); +extern "C" void fl_label_set_image(LABEL l, void * i); +extern "C" void fl_label_set_deimage(LABEL l, void * i); + + +extern "C" void fl_label_draw(LABEL l, int x, int y, int w, int h, unsigned int p); +extern "C" void fl_label_measure(LABEL l, int &w, int &h); + + +#endif + + diff --git a/body/c_fl_light_button.cpp b/body/c_fl_light_button.cpp new file mode 100644 index 0000000..6c59730 --- /dev/null +++ b/body/c_fl_light_button.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Light_Button.H> +#include "c_fl_light_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Light_Button : public Fl_Light_Button { +public: + using Fl_Light_Button::Fl_Light_Button; + + friend void fl_light_button_draw(LIGHTBUTTON b); + friend int fl_light_button_handle(LIGHTBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Light_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Light_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +LIGHTBUTTON new_fl_light_button(int x, int y, int w, int h, char* label) { + My_Light_Button *b = new My_Light_Button(x, y, w, h, label); + return b; +} + +void free_fl_light_button(LIGHTBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Light_Button*>(b); + } +} + + + + +void fl_light_button_draw(LIGHTBUTTON b) { + static_cast<My_Light_Button*>(b)->Fl_Light_Button::draw(); +} + +int fl_light_button_handle(LIGHTBUTTON b, int e) { + return static_cast<My_Light_Button*>(b)->Fl_Light_Button::handle(e); +} + + diff --git a/body/c_fl_light_button.h b/body/c_fl_light_button.h new file mode 100644 index 0000000..5d604d2 --- /dev/null +++ b/body/c_fl_light_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_LIGHT_BUTTON_GUARD +#define FL_LIGHT_BUTTON_GUARD + + +typedef void* LIGHTBUTTON; + + +extern "C" LIGHTBUTTON new_fl_light_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_light_button(LIGHTBUTTON b); + + +extern "C" void fl_light_button_draw(LIGHTBUTTON b); +extern "C" int fl_light_button_handle(LIGHTBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_line_dial.cpp b/body/c_fl_line_dial.cpp new file mode 100644 index 0000000..92059f2 --- /dev/null +++ b/body/c_fl_line_dial.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Line_Dial.H> +#include "c_fl_line_dial.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Line_Dial : public Fl_Line_Dial { +public: + using Fl_Line_Dial::Fl_Line_Dial; + + friend void fl_line_dial_draw(LINEDIAL v); + friend int fl_line_dial_handle(LINEDIAL v, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Line_Dial::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Line_Dial::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Line_Dial::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +LINEDIAL new_fl_line_dial(int x, int y, int w, int h, char* label) { + My_Line_Dial *v = new My_Line_Dial(x, y, w, h, label); + return v; +} + +void free_fl_line_dial(LINEDIAL v) { + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Line_Dial*>(v); + } +} + + + + +void fl_line_dial_draw(LINEDIAL v) { + static_cast<My_Line_Dial*>(v)->Fl_Line_Dial::draw(); +} + +int fl_line_dial_handle(LINEDIAL v, int e) { + return static_cast<My_Line_Dial*>(v)->Fl_Line_Dial::handle(e); +} + + diff --git a/body/c_fl_line_dial.h b/body/c_fl_line_dial.h new file mode 100644 index 0000000..f7b49ca --- /dev/null +++ b/body/c_fl_line_dial.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_LINE_DIAL_GUARD +#define FL_LINE_DIAL_GUARD + + +typedef void* LINEDIAL; + + +extern "C" LINEDIAL new_fl_line_dial(int x, int y, int w, int h, char* label); +extern "C" void free_fl_line_dial(LINEDIAL v); + + +extern "C" void fl_line_dial_draw(LINEDIAL v); +extern "C" int fl_line_dial_handle(LINEDIAL v, int e); + + +#endif + + diff --git a/body/c_fl_menu.cpp b/body/c_fl_menu.cpp new file mode 100644 index 0000000..2ef9402 --- /dev/null +++ b/body/c_fl_menu.cpp @@ -0,0 +1,305 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Menu_.H> +#include <FL/Fl_Menu_Item.H> +#include "c_fl_menu.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" void menu_item_callback_hook(void * cobj, void * ud); + + + + +// Attaching all relevant hooks and friends + +class My_Menu : public Fl_Menu_ { +public: + using Fl_Menu_::Fl_Menu_; + + friend void fl_menu_draw(MENU m); + friend int fl_menu_handle(MENU m, int e); + + void draw(); + int handle(int e); +}; + +void My_Menu::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Menu::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +MENU new_fl_menu(int x, int y, int w, int h, char* label) { + My_Menu *m = new My_Menu(x, y, w, h, label); + return m; +} + +void free_fl_menu(MENU m) { + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu*>(m); + } +} + + + + +int fl_menu_add(MENU m, const char * t) { + return static_cast<Fl_Menu_*>(m)->add(t); +} + +int fl_menu_add2(MENU m, const char * t, unsigned long s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->add(t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +int fl_menu_add3(MENU m, const char * t, const char * s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->add(t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +int fl_menu_insert(MENU m, int p, const char * t, unsigned long s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->insert(p, t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +int fl_menu_insert2(MENU m, int p, const char * t, const char * s, void * u, unsigned long f) { + return static_cast<Fl_Menu_*>(m)->insert(p, t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +void fl_menu_copy(MENU m, void * mi) { + static_cast<Fl_Menu_*>(m)->copy(static_cast<const Fl_Menu_Item*>(mi), 0); +} + +void fl_menu_set_menu(MENU m, MENU d) { + static_cast<Fl_Menu_*>(m)->menu(static_cast<Fl_Menu_*>(d)->menu()); +} + +void fl_menu_remove(MENU m, int p) { + static_cast<Fl_Menu_*>(m)->remove(p); +} + +void fl_menu_clear(MENU m) { + static_cast<Fl_Menu_*>(m)->clear(); +} + +int fl_menu_clear_submenu(MENU m, int i) { + return static_cast<Fl_Menu_*>(m)->clear_submenu(i); +} + + + + +const void * fl_menu_get_item(MENU m, int i) { + return &(static_cast<Fl_Menu_*>(m)->menu()[i]); +} + +// find_item and find_item2 are subsumed by find_index and find_index3 +// since we need to get the index for the Ada side anyway. + +int fl_menu_find_index(MENU m, const char * t) { + return static_cast<Fl_Menu_*>(m)->find_index(t); +} + +int fl_menu_find_index2(MENU m, void * i) { + return static_cast<Fl_Menu_*>(m)->find_index(static_cast<Fl_Menu_Item*>(i)); +} + +int fl_menu_find_index3(MENU m, void * cb) { + // have to loop through the array manually since callbacks are stored in userdata + for (int i=0; i<fl_menu_size(m); i++) { + if (static_cast<Fl_Menu_*>(m)->menu()[i].user_data() == cb) { + return i; + } + } + return -1; +} + +int fl_menu_item_pathname(MENU m, char * buf, int len, void * mi) { + return static_cast<Fl_Menu_*>(m)->item_pathname(buf, len, static_cast<Fl_Menu_Item*>(mi)); +} + +int fl_menu_size(MENU m) { + return static_cast<Fl_Menu_*>(m)->size(); +} + + + + +// mvalue is subsumed by value since we need to get the index for +// the Ada side anyway. + +const char * fl_menu_text(MENU m) { + return static_cast<Fl_Menu_*>(m)->text(); +} + +int fl_menu_value(MENU m) { + return static_cast<Fl_Menu_*>(m)->value(); +} + +int fl_menu_set_value(MENU m, void * i) { + return static_cast<Fl_Menu_*>(m)->value(static_cast<Fl_Menu_Item*>(i)); +} + +int fl_menu_set_value2(MENU m, int p) { + return static_cast<Fl_Menu_*>(m)->value(p); +} + + + + +void fl_menu_setonly(MENU m, void * mi) { + static_cast<Fl_Menu_*>(m)->setonly(static_cast<Fl_Menu_Item*>(mi)); +} + +const char * fl_menu_text2(MENU m, int i) { + return static_cast<Fl_Menu_*>(m)->text(i); +} + +void fl_menu_replace(MENU m, int i, const char * t) { + static_cast<Fl_Menu_*>(m)->replace(i, t); +} + +void fl_menu_shortcut(MENU m, int i, unsigned long s) { + static_cast<Fl_Menu_*>(m)->shortcut(i, s); +} + +unsigned long fl_menu_get_mode(MENU m, int i) { + return static_cast<Fl_Menu_*>(m)->mode(i); +} + +void fl_menu_set_mode(MENU m, int i, unsigned long f) { + static_cast<Fl_Menu_*>(m)->mode(i, f); +} + + + + +unsigned int fl_menu_get_textcolor(MENU m) { + return static_cast<Fl_Menu_*>(m)->textcolor(); +} + +void fl_menu_set_textcolor(MENU m, unsigned int c) { + static_cast<Fl_Menu_*>(m)->textcolor(c); +} + +int fl_menu_get_textfont(MENU m) { + return static_cast<Fl_Menu_*>(m)->textfont(); +} + +void fl_menu_set_textfont(MENU m, int f) { + static_cast<Fl_Menu_*>(m)->textfont(f); +} + +int fl_menu_get_textsize(MENU m) { + return static_cast<Fl_Menu_*>(m)->textsize(); +} + +void fl_menu_set_textsize(MENU m, int s) { + static_cast<Fl_Menu_*>(m)->textsize(s); +} + + + + +int fl_menu_get_down_box(MENU m) { + return static_cast<Fl_Menu_*>(m)->down_box(); +} + +void fl_menu_set_down_box(MENU m, int t) { + static_cast<Fl_Menu_*>(m)->down_box(static_cast<Fl_Boxtype>(t)); +} + +void fl_menu_global(MENU m) { + static_cast<Fl_Menu_*>(m)->global(); +} + +int fl_menu_measure(MENU m, int i, int *h) { + // method actually belongs to Fl_Menu_Item + const Fl_Menu_Item * item = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,i)); + return item==0?0:item->measure(h, static_cast<Fl_Menu_*>(m)); +} + + + + +const void * fl_menu_popup(MENU m, int x, int y, const char * t, int n) { + // method actually belongs to Fl_Menu_Item + const Fl_Menu_Item * menuhead = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, 0)); + const Fl_Menu_Item * initial = n<0?0:static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, n)); + return menuhead->popup(x, y, t, initial, static_cast<Fl_Menu_*>(m)); +} + +const void * fl_menu_pulldown(MENU m, int x, int y, int w, int h, int n) { + // method actually belongs to Fl_Menu_Item + const Fl_Menu_Item * menuhead = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, 0)); + const Fl_Menu_Item * initial = n<0?0:static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, n)); + return menuhead->pulldown(x, y, w, h, initial, static_cast<Fl_Menu_*>(m)); +} + +const void * fl_menu_picked(MENU m, const void * mi) { + return static_cast<Fl_Menu_*>(m)->picked(static_cast<const Fl_Menu_Item*>(mi)); +} + +const void * fl_menu_find_shortcut(MENU m, void * ip, int a) { + // method actually belongs to Fl_Menu_Item + const Fl_Menu_Item * dummy = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m, 0)); + return dummy==0?0:dummy->find_shortcut(static_cast<int*>(ip), static_cast<bool>(a)); +} + +const void * fl_menu_test_shortcut(MENU m) { + return static_cast<Fl_Menu_*>(m)->test_shortcut(); +} + + + + +void fl_menu_size2(MENU m, int w, int h) { + static_cast<Fl_Menu_*>(m)->size(w, h); +} + + + + +void fl_menu_draw_item(MENU m, int i, int x, int y, int w, int h, int s) { + // method actually belongs to Fl_Menu_Item + const Fl_Menu_Item * item = static_cast<const Fl_Menu_Item*>(fl_menu_get_item(m,i)); + if (item != 0) { + item->draw(x, y, w, h, static_cast<Fl_Menu_*>(m), s); + } +} + +void fl_menu_draw(MENU m) { + // The Fl_Menu_ draw method doesn't technically exist, so... + (void)(m); + // It is more convenient for this function to exist, however, + // even though it will likely never be called, because it simplifies + // and makes uniform the implementation of the Ada Menu Draw subprogram. +} + +int fl_menu_handle(MENU m, int e) { + return static_cast<My_Menu*>(m)->Fl_Menu_::handle(e); +} + + diff --git a/body/c_fl_menu.h b/body/c_fl_menu.h new file mode 100644 index 0000000..17ae326 --- /dev/null +++ b/body/c_fl_menu.h @@ -0,0 +1,87 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MENU_GUARD +#define FL_MENU_GUARD + + +typedef void* MENU; + + +extern "C" MENU new_fl_menu(int x, int y, int w, int h, char* label); +extern "C" void free_fl_menu(MENU m); + + +extern "C" int fl_menu_add(MENU m, const char * t); +extern "C" int fl_menu_add2(MENU m, const char * t, unsigned long s, void * u, unsigned long f); +extern "C" int fl_menu_add3(MENU m, const char * t, const char * s, void * u, unsigned long f); +extern "C" int fl_menu_insert(MENU m, int p, const char * t, + unsigned long s, void * u, unsigned long f); +extern "C" int fl_menu_insert2(MENU m, int p, const char * t, + const char * s, void * u, unsigned long f); +extern "C" void fl_menu_copy(MENU m, void * mi); +extern "C" void fl_menu_set_menu(MENU m, MENU d); +extern "C" void fl_menu_remove(MENU m, int p); +extern "C" void fl_menu_clear(MENU m); +extern "C" int fl_menu_clear_submenu(MENU m, int i); + + +extern "C" const void * fl_menu_get_item(MENU m, int i); +// find_item and find_item2 are subsumed by find_index and find_index3 +extern "C" int fl_menu_find_index(MENU m, const char * t); +extern "C" int fl_menu_find_index2(MENU m, void * i); +extern "C" int fl_menu_find_index3(MENU m, void * cb); +extern "C" int fl_menu_item_pathname(MENU m, char * buf, int len, void * mi); +extern "C" int fl_menu_size(MENU m); + + +// mvalue is subsumed by value +extern "C" const char * fl_menu_text(MENU m); +extern "C" int fl_menu_value(MENU m); +extern "C" int fl_menu_set_value(MENU m, void * i); +extern "C" int fl_menu_set_value2(MENU m, int p); + + +extern "C" void fl_menu_setonly(MENU m, void * mi); +extern "C" const char * fl_menu_text2(MENU m, int i); +extern "C" void fl_menu_replace(MENU m, int i, const char * t); +extern "C" void fl_menu_shortcut(MENU m, int i, unsigned long s); +extern "C" unsigned long fl_menu_get_mode(MENU m, int i); +extern "C" void fl_menu_set_mode(MENU m, int i, unsigned long f); + + +extern "C" unsigned int fl_menu_get_textcolor(MENU m); +extern "C" void fl_menu_set_textcolor(MENU m, unsigned int c); +extern "C" int fl_menu_get_textfont(MENU m); +extern "C" void fl_menu_set_textfont(MENU m, int f); +extern "C" int fl_menu_get_textsize(MENU m); +extern "C" void fl_menu_set_textsize(MENU m, int s); + + +extern "C" int fl_menu_get_down_box(MENU m); +extern "C" void fl_menu_set_down_box(MENU m, int t); +extern "C" void fl_menu_global(MENU m); +extern "C" int fl_menu_measure(MENU m, int i, int *h); + + +extern "C" const void * fl_menu_popup(MENU m, int x, int y, const char * t, int n); +extern "C" const void * fl_menu_pulldown(MENU m, int x, int y, int w, int h, int n); +extern "C" const void * fl_menu_picked(MENU m, const void * mi); +extern "C" const void * fl_menu_find_shortcut(MENU m, void * ip, int a); +extern "C" const void * fl_menu_test_shortcut(MENU m); + + +extern "C" void fl_menu_size2(MENU m, int w, int h); + + +extern "C" void fl_menu_draw_item(MENU m, int i, int x, int y, int w, int h, int s); +extern "C" void fl_menu_draw(MENU m); +extern "C" int fl_menu_handle(MENU m, int e); + + +#endif + + diff --git a/body/c_fl_menu_bar.cpp b/body/c_fl_menu_bar.cpp new file mode 100644 index 0000000..8419df6 --- /dev/null +++ b/body/c_fl_menu_bar.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Menu_Bar.H> +#include "c_fl_menu_bar.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Menu_Bar : public Fl_Menu_Bar { +public: + using Fl_Menu_Bar::Fl_Menu_Bar; + + friend void fl_menu_bar_draw(MENUBAR m); + friend int fl_menu_bar_handle(MENUBAR m, int e); + + void draw(); + int handle(int e); +}; + +void My_Menu_Bar::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Menu_Bar::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +MENUBAR new_fl_menu_bar(int x, int y, int w, int h, char* label) { + My_Menu_Bar *m = new My_Menu_Bar(x, y, w, h, label); + return m; +} + +void free_fl_menu_bar(MENUBAR m) { + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu_Bar*>(m); + } +} + + + + +void fl_menu_bar_draw(MENUBAR m) { + static_cast<My_Menu_Bar*>(m)->Fl_Menu_Bar::draw(); +} + +int fl_menu_bar_handle(MENUBAR m, int e) { + return static_cast<My_Menu_Bar*>(m)->Fl_Menu_Bar::handle(e); +} + + diff --git a/body/c_fl_menu_bar.h b/body/c_fl_menu_bar.h new file mode 100644 index 0000000..ae99467 --- /dev/null +++ b/body/c_fl_menu_bar.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MENU_BAR_GUARD +#define FL_MENU_BAR_GUARD + + +typedef void* MENUBAR; + + +extern "C" MENUBAR new_fl_menu_bar(int x, int y, int w, int h, char* label); +extern "C" void free_fl_menu_bar(MENUBAR m); + + +extern "C" void fl_menu_bar_draw(MENUBAR m); +extern "C" int fl_menu_bar_handle(MENUBAR m, int e); + + +#endif + + diff --git a/body/c_fl_menu_button.cpp b/body/c_fl_menu_button.cpp new file mode 100644 index 0000000..4537e8d --- /dev/null +++ b/body/c_fl_menu_button.cpp @@ -0,0 +1,90 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Menu_Button.H> +#include "c_fl_menu_button.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void menu_button_extra_init_hook + (void * aobj, int x, int y, int w, int h, const char * l); +void fl_menu_button_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { + menu_button_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +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_Menu_Button : public Fl_Menu_Button { +public: + using Fl_Menu_Button::Fl_Menu_Button; + + friend void fl_menu_button_draw(MENUBUTTON m); + friend int fl_menu_button_handle(MENUBUTTON m, int e); + + void draw(); + int handle(int e); +}; + +void My_Menu_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Menu_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +MENUBUTTON new_fl_menu_button(int x, int y, int w, int h, char* label) { + My_Menu_Button *m = new My_Menu_Button(x, y, w, h, label); + return m; +} + +void free_fl_menu_button(MENUBUTTON m) { + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu_Button*>(m); + } +} + + + + +const void * fl_menu_button_popup(MENUBUTTON m) { + return static_cast<Fl_Menu_Button*>(m)->popup(); +} + + + + +void fl_menu_button_draw(MENUBUTTON m) { + static_cast<My_Menu_Button*>(m)->Fl_Menu_Button::draw(); +} + +int fl_menu_button_handle(MENUBUTTON m, int e) { + return static_cast<My_Menu_Button*>(m)->Fl_Menu_Button::handle(e); +} + + diff --git a/body/c_fl_menu_button.h b/body/c_fl_menu_button.h new file mode 100644 index 0000000..f8f721b --- /dev/null +++ b/body/c_fl_menu_button.h @@ -0,0 +1,31 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MENU_BUTTON_GUARD +#define FL_MENU_BUTTON_GUARD + + +extern "C" void fl_menu_button_extra_init + (void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* MENUBUTTON; + + +extern "C" MENUBUTTON new_fl_menu_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_menu_button(MENUBUTTON m); + + +extern "C" const void * fl_menu_button_popup(MENUBUTTON m); + + +extern "C" void fl_menu_button_draw(MENUBUTTON m); +extern "C" int fl_menu_button_handle(MENUBUTTON m, int e); + + +#endif + + diff --git a/body/c_fl_menu_window.cpp b/body/c_fl_menu_window.cpp new file mode 100644 index 0000000..30020c6 --- /dev/null +++ b/body/c_fl_menu_window.cpp @@ -0,0 +1,111 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Menu_Window.H> +#include "c_fl_menu_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Menu_Window : public Fl_Menu_Window { +public: + using Fl_Menu_Window::Fl_Menu_Window; + + friend void fl_menu_window_draw(MENUWINDOW n); + friend int fl_menu_window_handle(MENUWINDOW n, int e); + + void draw(); + int handle(int e); +}; + +void My_Menu_Window::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Menu_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +MENUWINDOW new_fl_menu_window(int x, int y, int w, int h, char* label) { + My_Menu_Window *m = new My_Menu_Window(x, y, w, h, label); + return m; +} + +MENUWINDOW new_fl_menu_window2(int w, int h, char* label) { + My_Menu_Window *m = new My_Menu_Window(w, h, label); + return m; +} + +void free_fl_menu_window(MENUWINDOW m) { + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Menu_Window*>(m); + } +} + + + + +void fl_menu_window_show(MENUWINDOW m) { + static_cast<Fl_Menu_Window*>(m)->show(); +} + +void fl_menu_window_hide(MENUWINDOW m) { + static_cast<Fl_Menu_Window*>(m)->hide(); +} + +void fl_menu_window_flush(MENUWINDOW m) { + static_cast<Fl_Menu_Window*>(m)->flush(); +} + +void fl_menu_window_erase(MENUWINDOW m) { + static_cast<Fl_Menu_Window*>(m)->erase(); +} + + + + +void fl_menu_window_set_overlay(MENUWINDOW m) { + static_cast<Fl_Menu_Window*>(m)->set_overlay(); +} + +void fl_menu_window_clear_overlay(MENUWINDOW m) { + static_cast<Fl_Menu_Window*>(m)->clear_overlay(); +} + +unsigned int fl_menu_window_overlay(MENUWINDOW m) { + return static_cast<Fl_Menu_Window*>(m)->overlay(); +} + + + + +void fl_menu_window_draw(MENUWINDOW n) { + static_cast<My_Menu_Window*>(n)->Fl_Menu_Window::draw(); +} + +int fl_menu_window_handle(MENUWINDOW n, int e) { + return static_cast<My_Menu_Window*>(n)->Fl_Menu_Window::handle(e); +} + + diff --git a/body/c_fl_menu_window.h b/body/c_fl_menu_window.h new file mode 100644 index 0000000..020a377 --- /dev/null +++ b/body/c_fl_menu_window.h @@ -0,0 +1,36 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MENU_WINDOW_GUARD +#define FL_MENU_WINDOW_GUARD + + +typedef void* MENUWINDOW; + + +extern "C" MENUWINDOW new_fl_menu_window(int x, int y, int w, int h, char* label); +extern "C" MENUWINDOW new_fl_menu_window2(int w, int h, char* label); +extern "C" void free_fl_menu_window(MENUWINDOW m); + + +extern "C" void fl_menu_window_show(MENUWINDOW m); +extern "C" void fl_menu_window_hide(MENUWINDOW m); +extern "C" void fl_menu_window_flush(MENUWINDOW m); +extern "C" void fl_menu_window_erase(MENUWINDOW m); + + +extern "C" void fl_menu_window_set_overlay(MENUWINDOW m); +extern "C" void fl_menu_window_clear_overlay(MENUWINDOW m); +extern "C" unsigned int fl_menu_window_overlay(MENUWINDOW m); + + +extern "C" void fl_menu_window_draw(MENUWINDOW n); +extern "C" int fl_menu_window_handle(MENUWINDOW n, int e); + + +#endif + + diff --git a/body/c_fl_menuitem.cpp b/body/c_fl_menuitem.cpp new file mode 100644 index 0000000..b72c065 --- /dev/null +++ b/body/c_fl_menuitem.cpp @@ -0,0 +1,194 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Menu_Item.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Image.H> +#include "c_fl_menuitem.h" + + + + +// Exports from Ada + +extern "C" void menu_item_callback_hook(void * cobj, void * ud); + + + + +// Flattened C API + +void * null_fl_menu_item() { + Fl_Menu_Item *mi = new Fl_Menu_Item; + mi->label(0); + return mi; +} + +void * new_fl_menu_item(char * t, void * c, int s, int f) { + Fl_Menu_Item *mi = new Fl_Menu_Item; + mi->callback(c==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), c); + mi->flags = static_cast<int>(f); + mi->shortcut(static_cast<int>(s)); + mi->label(t); + return mi; +} + +void free_fl_menu_item(MENUITEM mi) { + delete static_cast<Fl_Menu_Item*>(mi); +} + + + + +void * fl_menu_item_get_user_data(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->user_data(); +} + +void fl_menu_item_set_callback(MENUITEM mi, void * c) { + static_cast<Fl_Menu_Item*>(mi)->callback + (c==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), c); +} + +void fl_menu_item_do_callback(MENUITEM mi, void * w) { + static_cast<Fl_Menu_Item*>(mi)->do_callback(static_cast<Fl_Widget*>(w)); +} + + + + +int fl_menu_item_checkbox(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->checkbox(); +} + +int fl_menu_item_radio(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->radio(); +} + +int fl_menu_item_submenu(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->submenu(); +} + +int fl_menu_item_value(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->value(); +} + +void fl_menu_item_set(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->set(); +} + +void fl_menu_item_clear(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->clear(); +} + +void fl_menu_item_setonly(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->setonly(); +} + + + + +const char * fl_menu_item_get_label(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->label(); +} + +void fl_menu_item_set_label(MENUITEM mi, const char *t) { + static_cast<Fl_Menu_Item*>(mi)->label(t); +} + +void fl_menu_item_set_label2(MENUITEM mi, int k, const char * t) { + static_cast<Fl_Menu_Item*>(mi)->label(static_cast<Fl_Labeltype>(k), t); +} + +unsigned int fl_menu_item_get_labelcolor(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labelcolor(); +} + +void fl_menu_item_set_labelcolor(MENUITEM mi, unsigned int c) { + static_cast<Fl_Menu_Item*>(mi)->labelcolor(c); +} + +int fl_menu_item_get_labelfont(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labelfont(); +} + +void fl_menu_item_set_labelfont(MENUITEM mi, int f) { + static_cast<Fl_Menu_Item*>(mi)->labelfont(f); +} + +int fl_menu_item_get_labelsize(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labelsize(); +} + +void fl_menu_item_set_labelsize(MENUITEM mi, int s) { + static_cast<Fl_Menu_Item*>(mi)->labelsize(s); +} + +int fl_menu_item_get_labeltype(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->labeltype(); +} + +void fl_menu_item_set_labeltype(MENUITEM mi, int t) { + static_cast<Fl_Menu_Item*>(mi)->labeltype(static_cast<Fl_Labeltype>(t)); +} + + + + +int fl_menu_item_get_shortcut(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->shortcut(); +} + +void fl_menu_item_set_shortcut(MENUITEM mi, int s) { + static_cast<Fl_Menu_Item*>(mi)->shortcut(s); +} + +int fl_menu_item_get_flags(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->flags; +} + +void fl_menu_item_set_flags(MENUITEM mi, int f) { + static_cast<Fl_Menu_Item*>(mi)->flags = f; +} + + + + +void fl_menu_item_image(MENUITEM mi, void * i) { + static_cast<Fl_Menu_Item*>(mi)->image(static_cast<Fl_Image*>(i)); +} + + + + +void fl_menu_item_activate(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->activate(); +} + +void fl_menu_item_deactivate(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->deactivate(); +} + +void fl_menu_item_show(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->show(); +} + +void fl_menu_item_hide(MENUITEM mi) { + static_cast<Fl_Menu_Item*>(mi)->hide(); +} + +int fl_menu_item_active(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->active(); +} + +int fl_menu_item_visible(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->visible(); +} + +int fl_menu_item_activevisible(MENUITEM mi) { + return static_cast<Fl_Menu_Item*>(mi)->activevisible(); +} + + diff --git a/body/c_fl_menuitem.h b/body/c_fl_menuitem.h new file mode 100644 index 0000000..1e63c60 --- /dev/null +++ b/body/c_fl_menuitem.h @@ -0,0 +1,66 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MENU_ITEM_GUARD +#define FL_MENU_ITEM_GUARD + + +typedef void* MENUITEM; + + +extern "C" void * null_fl_menu_item(); +extern "C" void * new_fl_menu_item(char * t, void * c, int s, int f); +extern "C" void free_fl_menu_item(MENUITEM mi); + + +extern "C" void * fl_menu_item_get_user_data(MENUITEM mi); +extern "C" void fl_menu_item_set_callback(MENUITEM mi, void * c); +extern "C" void fl_menu_item_do_callback(MENUITEM mi, void * w); + + +extern "C" int fl_menu_item_checkbox(MENUITEM mi); +extern "C" int fl_menu_item_radio(MENUITEM mi); +extern "C" int fl_menu_item_submenu(MENUITEM mi); +extern "C" int fl_menu_item_value(MENUITEM mi); +extern "C" void fl_menu_item_set(MENUITEM mi); +extern "C" void fl_menu_item_clear(MENUITEM mi); +extern "C" void fl_menu_item_setonly(MENUITEM mi); + + +extern "C" const char * fl_menu_item_get_label(MENUITEM mi); +extern "C" void fl_menu_item_set_label(MENUITEM mi, const char *t); +extern "C" void fl_menu_item_set_label2(MENUITEM mi, int k, const char * t); +extern "C" unsigned int fl_menu_item_get_labelcolor(MENUITEM mi); +extern "C" void fl_menu_item_set_labelcolor(MENUITEM mi, unsigned int c); +extern "C" int fl_menu_item_get_labelfont(MENUITEM mi); +extern "C" void fl_menu_item_set_labelfont(MENUITEM mi, int f); +extern "C" int fl_menu_item_get_labelsize(MENUITEM mi); +extern "C" void fl_menu_item_set_labelsize(MENUITEM mi, int s); +extern "C" int fl_menu_item_get_labeltype(MENUITEM mi); +extern "C" void fl_menu_item_set_labeltype(MENUITEM mi, int t); + + +extern "C" int fl_menu_item_get_shortcut(MENUITEM mi); +extern "C" void fl_menu_item_set_shortcut(MENUITEM mi, int s); +extern "C" int fl_menu_item_get_flags(MENUITEM mi); +extern "C" void fl_menu_item_set_flags(MENUITEM mi, int f); + + +extern "C" void fl_menu_item_image(MENUITEM mi, void * i); + + +extern "C" void fl_menu_item_activate(MENUITEM mi); +extern "C" void fl_menu_item_deactivate(MENUITEM mi); +extern "C" void fl_menu_item_show(MENUITEM mi); +extern "C" void fl_menu_item_hide(MENUITEM mi); +extern "C" int fl_menu_item_active(MENUITEM mi); +extern "C" int fl_menu_item_visible(MENUITEM mi); +extern "C" int fl_menu_item_activevisible(MENUITEM mi); + + +#endif + + diff --git a/body/c_fl_multi_browser.cpp b/body/c_fl_multi_browser.cpp new file mode 100644 index 0000000..ce0b077 --- /dev/null +++ b/body/c_fl_multi_browser.cpp @@ -0,0 +1,270 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Multi_Browser.H> +#include "c_fl_multi_browser.h" +#include "c_fl.h" + + + + +// 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_Multi_Browser : public Fl_Multi_Browser { +public: + using Fl_Multi_Browser::Fl_Multi_Browser; + + friend int fl_multi_browser_item_width(MULTIBROWSER b, void * item); + friend int fl_multi_browser_item_height(MULTIBROWSER b, void * item); + friend void * fl_multi_browser_item_first(MULTIBROWSER b); + friend void * fl_multi_browser_item_last(MULTIBROWSER b); + friend void * fl_multi_browser_item_next(MULTIBROWSER b, void * item); + friend void * fl_multi_browser_item_prev(MULTIBROWSER b, void * item); + friend void * fl_multi_browser_item_at(MULTIBROWSER b, int index); + friend void fl_multi_browser_item_select(MULTIBROWSER b, void * item, int val); + friend int fl_multi_browser_item_selected(MULTIBROWSER b, void * item); + friend void fl_multi_browser_item_swap(MULTIBROWSER b, void * x, void * y); + friend const char * fl_multi_browser_item_text(MULTIBROWSER b, void * item); + friend void fl_multi_browser_item_draw(MULTIBROWSER b, void * item, int x, int y, int w, int h); + + friend int fl_multi_browser_full_width(MULTIBROWSER c); + friend int fl_multi_browser_full_height(MULTIBROWSER c); + friend int fl_multi_browser_incr_height(MULTIBROWSER c); + friend int fl_multi_browser_item_quick_height(MULTIBROWSER c, void * i); + + friend void fl_multi_browser_draw(MULTIBROWSER b); + + int handle(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 My_Multi_Browser::full_width() const { + return browser_full_width_hook(this->user_data()); +} + +int My_Multi_Browser::full_height() const { + return browser_full_height_hook(this->user_data()); +} + +int My_Multi_Browser::incr_height() const { + return browser_incr_height_hook(this->user_data()); +} + +int My_Multi_Browser::item_quick_height(void * item) const { + return browser_item_quick_height_hook(this->user_data(), item); +} + + +int My_Multi_Browser::item_width(void * item) const { + return browser_item_width_hook(this->user_data(), item); +} + +int My_Multi_Browser::item_height(void * item) const { + return browser_item_height_hook(this->user_data(), item); +} + +void * My_Multi_Browser::item_first() const { + return browser_item_first_hook(this->user_data()); +} + +void * My_Multi_Browser::item_last() const { + return browser_item_last_hook(this->user_data()); +} + +void * My_Multi_Browser::item_next(void * item) const { + return browser_item_next_hook(this->user_data(), item); +} + +void * My_Multi_Browser::item_prev(void * item) const { + return browser_item_prev_hook(this->user_data(), item); +} + +void * My_Multi_Browser::item_at(int index) const { + return browser_item_at_hook(this->user_data(), index); +} + +void My_Multi_Browser::item_select(void * item, int val) { + browser_item_select_hook(this->user_data(), item, val); +} + +int My_Multi_Browser::item_selected(void * item) const { + return browser_item_selected_hook(this->user_data(), item); +} + +void My_Multi_Browser::item_swap(void * a, void * b) { + browser_item_swap_hook(this->user_data(), a, b); +} + +const char * My_Multi_Browser::item_text(void * item) const { + return browser_item_text_hook(this->user_data(), item); +} + +void My_Multi_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_Multi_Browser::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Multi_Browser::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +MULTIBROWSER new_fl_multi_browser(int x, int y, int w, int h, char * label) { + My_Multi_Browser *b = new My_Multi_Browser(x, y, w, h, label); + return b; +} + +void free_fl_multi_browser(MULTIBROWSER b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Multi_Browser*>(b); + } +} + + + + +// These have to be reimplemented due to relying on custom class extensions + + +int fl_multi_browser_full_height(MULTIBROWSER c) { + return static_cast<My_Multi_Browser*>(c)->Fl_Multi_Browser::full_height(); +} + +int fl_multi_browser_incr_height(MULTIBROWSER c) { + return static_cast<My_Multi_Browser*>(c)->Fl_Multi_Browser::incr_height(); +} + + + + +int fl_multi_browser_item_width(MULTIBROWSER b, void * item) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_width(item); +} + +int fl_multi_browser_item_height(MULTIBROWSER b, void * item) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_height(item); +} + +void * fl_multi_browser_item_first(MULTIBROWSER b) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_first(); +} + +void * fl_multi_browser_item_last(MULTIBROWSER b) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_last(); +} + +void * fl_multi_browser_item_next(MULTIBROWSER b, void * item) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_next(item); +} + +void * fl_multi_browser_item_prev(MULTIBROWSER b, void * item) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_prev(item); +} + +void * fl_multi_browser_item_at(MULTIBROWSER b, int index) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_at(index); +} + +void fl_multi_browser_item_select(MULTIBROWSER b, void * item, int val) { + static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_select(item, val); +} + +int fl_multi_browser_item_selected(MULTIBROWSER b, void * item) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_selected(item); +} + +void fl_multi_browser_item_swap(MULTIBROWSER b, void * x, void * y) { + static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_swap(x, y); +} + +const char * fl_multi_browser_item_text(MULTIBROWSER b, void * item) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_text(item); +} + +void fl_multi_browser_item_draw(MULTIBROWSER b, void * item, int x, int y, int w, int h) { + static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::item_draw(item, x, y, w, h); +} + + + + +int fl_multi_browser_full_width(MULTIBROWSER c) { + return static_cast<My_Multi_Browser*>(c)->Fl_Multi_Browser::full_width(); +} + +int fl_multi_browser_item_quick_height(MULTIBROWSER c, void * i) { + return static_cast<My_Multi_Browser*>(c)->Fl_Multi_Browser::item_quick_height(i); +} + + + + +void fl_multi_browser_draw(MULTIBROWSER b) { + static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::draw(); +} + +int fl_multi_browser_handle(MULTIBROWSER b, int e) { + return static_cast<My_Multi_Browser*>(b)->Fl_Multi_Browser::handle(e); +} + + diff --git a/body/c_fl_multi_browser.h b/body/c_fl_multi_browser.h new file mode 100644 index 0000000..29d18ec --- /dev/null +++ b/body/c_fl_multi_browser.h @@ -0,0 +1,48 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MULTI_BROWSER_GUARD +#define FL_MULTI_BROWSER_GUARD + + +typedef void* MULTIBROWSER; + + +extern "C" MULTIBROWSER new_fl_multi_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_multi_browser(MULTIBROWSER b); + + +// reimp below here + +extern "C" int fl_multi_browser_full_height(MULTIBROWSER c); +extern "C" int fl_multi_browser_incr_height(MULTIBROWSER c); + + +extern "C" int fl_multi_browser_item_width(MULTIBROWSER b, void * item); +extern "C" int fl_multi_browser_item_height(MULTIBROWSER b, void * item); +extern "C" void * fl_multi_browser_item_first(MULTIBROWSER b); +extern "C" void * fl_multi_browser_item_last(MULTIBROWSER b); +extern "C" void * fl_multi_browser_item_next(MULTIBROWSER b, void * item); +extern "C" void * fl_multi_browser_item_prev(MULTIBROWSER b, void * item); +extern "C" void * fl_multi_browser_item_at(MULTIBROWSER b, int index); +extern "C" void fl_multi_browser_item_select(MULTIBROWSER b, void * item, int val=1); +extern "C" int fl_multi_browser_item_selected(MULTIBROWSER b, void * item); +extern "C" void fl_multi_browser_item_swap(MULTIBROWSER b, void * x, void * y); +extern "C" const char * fl_multi_browser_item_text(MULTIBROWSER b, void * item); +extern "C" void fl_multi_browser_item_draw(MULTIBROWSER b, void * item, int x, int y, int w, int h); + + +extern "C" int fl_multi_browser_full_width(MULTIBROWSER c); +extern "C" int fl_multi_browser_item_quick_height(MULTIBROWSER c, void * i); + + +extern "C" void fl_multi_browser_draw(MULTIBROWSER b); +extern "C" int fl_multi_browser_handle(MULTIBROWSER b, int e); + + +#endif + + diff --git a/body/c_fl_multiline_input.cpp b/body/c_fl_multiline_input.cpp new file mode 100644 index 0000000..2e193f2 --- /dev/null +++ b/body/c_fl_multiline_input.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Multiline_Input.H> +#include "c_fl_multiline_input.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Multiline_Input : public Fl_Multiline_Input { +public: + using Fl_Multiline_Input::Fl_Multiline_Input; + + friend void fl_multiline_input_draw(MULTILINEINPUT i); + friend int fl_multiline_input_handle(MULTILINEINPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Multiline_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Multiline_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +MULTILINEINPUT new_fl_multiline_input(int x, int y, int w, int h, char* label) { + My_Multiline_Input *i = new My_Multiline_Input(x, y, w, h, label); + return i; +} + +void free_fl_multiline_input(MULTILINEINPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Multiline_Input*>(i); + } +} + + + + +void fl_multiline_input_draw(MULTILINEINPUT i) { + static_cast<My_Multiline_Input*>(i)->Fl_Multiline_Input::draw(); +} + +int fl_multiline_input_handle(MULTILINEINPUT i, int e) { + return static_cast<My_Multiline_Input*>(i)->Fl_Multiline_Input::handle(e); +} + + diff --git a/body/c_fl_multiline_input.h b/body/c_fl_multiline_input.h new file mode 100644 index 0000000..ba4e723 --- /dev/null +++ b/body/c_fl_multiline_input.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MULTILINE_INPUT_GUARD +#define FL_MULTILINE_INPUT_GUARD + + +typedef void* MULTILINEINPUT; + + +extern "C" MULTILINEINPUT new_fl_multiline_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_multiline_input(MULTILINEINPUT i); + + +extern "C" void fl_multiline_input_draw(MULTILINEINPUT i); +extern "C" int fl_multiline_input_handle(MULTILINEINPUT i, int e); + + +#endif + + diff --git a/body/c_fl_multiline_output.cpp b/body/c_fl_multiline_output.cpp new file mode 100644 index 0000000..e5c8f05 --- /dev/null +++ b/body/c_fl_multiline_output.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Multiline_Output.H> +#include "c_fl_multiline_output.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Multiline_Output : public Fl_Multiline_Output { +public: + using Fl_Multiline_Output::Fl_Multiline_Output; + + friend void fl_multiline_output_draw(MULTILINEOUTPUT i); + friend int fl_multiline_output_handle(MULTILINEOUTPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Multiline_Output::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Multiline_Output::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +MULTILINEOUTPUT new_fl_multiline_output(int x, int y, int w, int h, char* label) { + My_Multiline_Output *i = new My_Multiline_Output(x, y, w, h, label); + return i; +} + +void free_fl_multiline_output(MULTILINEOUTPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Multiline_Output*>(i); + } +} + + + + +void fl_multiline_output_draw(MULTILINEOUTPUT i) { + static_cast<My_Multiline_Output*>(i)->Fl_Multiline_Output::draw(); +} + +int fl_multiline_output_handle(MULTILINEOUTPUT i, int e) { + return static_cast<My_Multiline_Output*>(i)->Fl_Multiline_Output::handle(e); +} + + diff --git a/body/c_fl_multiline_output.h b/body/c_fl_multiline_output.h new file mode 100644 index 0000000..43fee90 --- /dev/null +++ b/body/c_fl_multiline_output.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_MULTILINE_OUTPUT_GUARD +#define FL_MULTILINE_OUTPUT_GUARD + + +typedef void* MULTILINEOUTPUT; + + +extern "C" MULTILINEOUTPUT new_fl_multiline_output(int x, int y, int w, int h, char* label); +extern "C" void free_fl_multiline_output(MULTILINEOUTPUT i); + + +extern "C" void fl_multiline_output_draw(MULTILINEOUTPUT i); +extern "C" int fl_multiline_output_handle(MULTILINEOUTPUT i, int e); + + +#endif + + diff --git a/body/c_fl_nice_slider.cpp b/body/c_fl_nice_slider.cpp new file mode 100644 index 0000000..5e34190 --- /dev/null +++ b/body/c_fl_nice_slider.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Nice_Slider.H> +#include "c_fl_nice_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Nice_Slider : public Fl_Nice_Slider { +public: + using Fl_Nice_Slider::Fl_Nice_Slider; + + friend void fl_nice_slider_draw(NICESLIDER s); + friend int fl_nice_slider_handle(NICESLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Nice_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Nice_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Nice_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +NICESLIDER new_fl_nice_slider(int x, int y, int w, int h, char* label) { + My_Nice_Slider *s = new My_Nice_Slider(x, y, w, h, label); + return s; +} + +void free_fl_nice_slider(NICESLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Nice_Slider*>(s); + } +} + + + + +void fl_nice_slider_draw(NICESLIDER s) { + static_cast<My_Nice_Slider*>(s)->Fl_Nice_Slider::draw(); +} + +int fl_nice_slider_handle(NICESLIDER s, int e) { + return static_cast<My_Nice_Slider*>(s)->Fl_Nice_Slider::handle(e); +} + + diff --git a/body/c_fl_nice_slider.h b/body/c_fl_nice_slider.h new file mode 100644 index 0000000..2da3207 --- /dev/null +++ b/body/c_fl_nice_slider.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_NICE_SLIDER_GUARD +#define FL_NICE_SLIDER_GUARD + + +typedef void* NICESLIDER; + + +extern "C" NICESLIDER new_fl_nice_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_nice_slider(NICESLIDER s); + + +extern "C" void fl_nice_slider_draw(NICESLIDER s); +extern "C" int fl_nice_slider_handle(NICESLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_output.cpp b/body/c_fl_output.cpp new file mode 100644 index 0000000..9fa36a1 --- /dev/null +++ b/body/c_fl_output.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Output.H> +#include "c_fl_output.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Output : public Fl_Output { +public: + using Fl_Output::Fl_Output; + + friend void fl_output_draw(OUTPUTT i); + friend int fl_output_handle(OUTPUTT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Output::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Output::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +OUTPUTT new_fl_output(int x, int y, int w, int h, char* label) { + My_Output *i = new My_Output(x, y, w, h, label); + return i; +} + +void free_fl_output(OUTPUTT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Output*>(i); + } +} + + + + +void fl_output_draw(OUTPUTT i) { + static_cast<My_Output*>(i)->Fl_Output::draw(); +} + +int fl_output_handle(OUTPUTT i, int e) { + return static_cast<My_Output*>(i)->Fl_Output::handle(e); +} + + diff --git a/body/c_fl_output.h b/body/c_fl_output.h new file mode 100644 index 0000000..174c32e --- /dev/null +++ b/body/c_fl_output.h @@ -0,0 +1,26 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_OUTPUT_GUARD +#define FL_OUTPUT_GUARD + + +// using just "OUTPUT" doesn't compile for some reason +// some sort of name clash? +typedef void* OUTPUTT; + + +extern "C" OUTPUTT new_fl_output(int x, int y, int w, int h, char* label); +extern "C" void free_fl_output(OUTPUTT i); + + +extern "C" void fl_output_draw(OUTPUTT i); +extern "C" int fl_output_handle(OUTPUTT i, int e); + + +#endif + + diff --git a/body/c_fl_overlay_window.cpp b/body/c_fl_overlay_window.cpp new file mode 100644 index 0000000..fa92eed --- /dev/null +++ b/body/c_fl_overlay_window.cpp @@ -0,0 +1,121 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Overlay_Window.H> +#include "c_fl_overlay_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" void overlay_window_draw_overlay_hook(void * ud); + + + + +// Attaching all relevant hooks and friends + +class My_Overlay_Window : public Fl_Overlay_Window { +public: + using Fl_Overlay_Window::Fl_Overlay_Window; + + friend OVERLAYWINDOW new_fl_overlay_window(int x, int y, int w, int h, char *label); + friend OVERLAYWINDOW new_fl_overlay_window2(int w, int h, char *label); + + friend void fl_overlay_window_draw(OVERLAYWINDOW w); + friend int fl_overlay_window_handle(OVERLAYWINDOW w, int e); + + void draw(); + void draw_overlay(); + int handle(int e); +}; + +void My_Overlay_Window::draw() { + widget_draw_hook(this->user_data()); +} + +void My_Overlay_Window::draw_overlay() { + overlay_window_draw_overlay_hook(this->user_data()); +} + +int My_Overlay_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +OVERLAYWINDOW new_fl_overlay_window(int x, int y, int w, int h, char *label) { + My_Overlay_Window *ow = new My_Overlay_Window(x, y, w, h, label); + return ow; +} + +OVERLAYWINDOW new_fl_overlay_window2(int w, int h, char *label) { + My_Overlay_Window *ow = new My_Overlay_Window(w, h, label); + return ow; +} + +void free_fl_overlay_window(OVERLAYWINDOW w) { + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Overlay_Window*>(w); + } +} + + + + +int fl_overlay_window_can_do_overlay(OVERLAYWINDOW w) { + return static_cast<Fl_Overlay_Window*>(w)->can_do_overlay(); +} + +void fl_overlay_window_resize(OVERLAYWINDOW ow, int x, int y, int w, int h) { + static_cast<Fl_Overlay_Window*>(ow)->resize(x, y, w, h); +} + + + + +void fl_overlay_window_show(OVERLAYWINDOW w) { + static_cast<Fl_Overlay_Window*>(w)->show(); +} + +void fl_overlay_window_show2(OVERLAYWINDOW w, int c, void * v) { + static_cast<Fl_Overlay_Window*>(w)->show(c, static_cast<char**>(v)); +} + +void fl_overlay_window_hide(OVERLAYWINDOW w) { + static_cast<Fl_Overlay_Window*>(w)->hide(); +} + +void fl_overlay_window_flush(OVERLAYWINDOW w) { + static_cast<Fl_Overlay_Window*>(w)->flush(); +} + + + + +void fl_overlay_window_redraw_overlay(OVERLAYWINDOW w) { + static_cast<Fl_Overlay_Window*>(w)->redraw_overlay(); +} + +void fl_overlay_window_draw(OVERLAYWINDOW w) { + static_cast<My_Overlay_Window*>(w)->Fl_Overlay_Window::draw(); +} + +int fl_overlay_window_handle(OVERLAYWINDOW w, int e) { + return static_cast<My_Overlay_Window*>(w)->Fl_Overlay_Window::handle(e); +} + + diff --git a/body/c_fl_overlay_window.h b/body/c_fl_overlay_window.h new file mode 100644 index 0000000..a94bbec --- /dev/null +++ b/body/c_fl_overlay_window.h @@ -0,0 +1,36 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_OVERLAY_WINDOW_GUARD +#define FL_OVERLAY_WINDOW_GUARD + + +typedef void* OVERLAYWINDOW; + + +extern "C" OVERLAYWINDOW new_fl_overlay_window(int x, int y, int w, int h, char *label); +extern "C" OVERLAYWINDOW new_fl_overlay_window2(int w, int h, char *label); +extern "C" void free_fl_overlay_window(OVERLAYWINDOW w); + + +extern "C" int fl_overlay_window_can_do_overlay(OVERLAYWINDOW w); +extern "C" void fl_overlay_window_resize(OVERLAYWINDOW ow, int x, int y, int w, int h); + + +extern "C" void fl_overlay_window_show(OVERLAYWINDOW w); +extern "C" void fl_overlay_window_show2(OVERLAYWINDOW w, int c, void * v); +extern "C" void fl_overlay_window_hide(OVERLAYWINDOW w); +extern "C" void fl_overlay_window_flush(OVERLAYWINDOW w); + + +extern "C" void fl_overlay_window_redraw_overlay(OVERLAYWINDOW w); +extern "C" void fl_overlay_window_draw(OVERLAYWINDOW w); +extern "C" int fl_overlay_window_handle(OVERLAYWINDOW w, int e); + + +#endif + + diff --git a/body/c_fl_pack.cpp b/body/c_fl_pack.cpp new file mode 100644 index 0000000..48fa505 --- /dev/null +++ b/body/c_fl_pack.cpp @@ -0,0 +1,83 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Pack.H> +#include "c_fl_pack.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Pack : public Fl_Pack { +public: + using Fl_Pack::Fl_Pack; + + friend void fl_pack_draw(PACK n); + friend int fl_pack_handle(PACK n, int e); + + void draw(); + int handle(int e); +}; + +void My_Pack::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Pack::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +PACK new_fl_pack(int x, int y, int w, int h, char* label) { + My_Pack *b = new My_Pack(x, y, w, h, label); + return b; +} + +void free_fl_pack(PACK p) { + if (fl_inside_callback) { + fl_delete_widget(p); + } else { + delete static_cast<My_Pack*>(p); + } +} + + + + +int fl_pack_get_spacing(PACK p) { + return static_cast<Fl_Pack*>(p)->spacing(); +} + +void fl_pack_set_spacing(PACK p, int t) { + static_cast<Fl_Pack*>(p)->spacing(t); +} + + + + +void fl_pack_draw(PACK n) { + static_cast<My_Pack*>(n)->Fl_Pack::draw(); +} + +int fl_pack_handle(PACK n, int e) { + return static_cast<My_Pack*>(n)->Fl_Pack::handle(e); +} + + diff --git a/body/c_fl_pack.h b/body/c_fl_pack.h new file mode 100644 index 0000000..a8bfe75 --- /dev/null +++ b/body/c_fl_pack.h @@ -0,0 +1,28 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PACK_GUARD +#define FL_PACK_GUARD + + +typedef void* PACK; + + +extern "C" PACK new_fl_pack(int x, int y, int w, int h, char * label); +extern "C" void free_fl_pack(PACK p); + + +extern "C" int fl_pack_get_spacing(PACK p); +extern "C" void fl_pack_set_spacing(PACK p, int t); + + +extern "C" void fl_pack_draw(PACK n); +extern "C" int fl_pack_handle(PACK n, int e); + + +#endif + + diff --git a/body/c_fl_paged_device.cpp b/body/c_fl_paged_device.cpp new file mode 100644 index 0000000..f8f7d60 --- /dev/null +++ b/body/c_fl_paged_device.cpp @@ -0,0 +1,154 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Paged_Device.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Window.H> +#include "c_fl_paged_device.h" + + + + +// Enums and macro constants + +const int fl_page_format_media = Fl_Paged_Device::MEDIA; + +const int fl_page_layout_portrait = Fl_Paged_Device::PORTRAIT; +const int fl_page_layout_landscape = Fl_Paged_Device::LANDSCAPE; +const int fl_page_layout_reversed = Fl_Paged_Device::REVERSED; +const int fl_page_layout_orientation = Fl_Paged_Device::ORIENTATION; + +const int fl_no_page_formats = NO_PAGE_FORMATS; + + + + +// Helper functions + +void fl_paged_device_get_page_format(int i, const char ** n, int * w, int * h) { + *n = Fl_Paged_Device::page_formats[i].name; + *w = Fl_Paged_Device::page_formats[i].height; + *h = Fl_Paged_Device::page_formats[i].width; +} + + + + +// Adding relevant friends + +class My_Paged_Device : public Fl_Paged_Device { +public: + using Fl_Paged_Device::Fl_Paged_Device; + friend PAGEDDEVICE new_fl_paged_device(void); +}; + + + + +// Flattened C API + +PAGEDDEVICE new_fl_paged_device(void) { + My_Paged_Device *p = new My_Paged_Device(); + return p; +} + +void free_fl_paged_device(PAGEDDEVICE p) { + delete static_cast<My_Paged_Device*>(p); +} + + + + +int fl_paged_device_start_job(PAGEDDEVICE p, int c) { + // virtual so disable dispatch + return static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::start_job(c, 0, 0); +} + +int fl_paged_device_start_job2(PAGEDDEVICE p, int c, int * f, int * t) { + // virtual so disable dispatch + return static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::start_job(c, f, t); +} + +void fl_paged_device_end_job(PAGEDDEVICE p) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::end_job(); +} + +int fl_paged_device_start_page(PAGEDDEVICE p) { + // virtual so disable dispatch + return static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::start_page(); +} + +int fl_paged_device_end_page(PAGEDDEVICE p) { + // virtual so disable dispatch + return static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::end_page(); +} + + + + +void fl_paged_device_margins(PAGEDDEVICE p, int * l, int * t, int * r, int * b) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::margins(l,t,r,b); +} + +int fl_paged_device_printable_rect(PAGEDDEVICE p, int * w, int * h) { + // virtual so disable dispatch + return static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::printable_rect(w,h); +} + +void fl_paged_device_get_origin(PAGEDDEVICE p, int * x, int * y) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::origin(x,y); +} + +void fl_paged_device_set_origin(PAGEDDEVICE p, int x, int y) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::origin(x,y); +} + +void fl_paged_device_rotate(PAGEDDEVICE p, float r) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::rotate(r); +} + +void fl_paged_device_scale(PAGEDDEVICE p, float x, float y) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::scale(x,y); +} + +void fl_paged_device_translate(PAGEDDEVICE p, int x, int y) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::translate(x,y); +} + +void fl_paged_device_untranslate(PAGEDDEVICE p) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::untranslate(); +} + + + + +void fl_paged_device_print_widget(PAGEDDEVICE p, void * i, int dx, int dy) { + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::print_widget + (static_cast<Fl_Widget*>(i),dx,dy); +} + +void fl_paged_device_print_window(PAGEDDEVICE p, void * i, int dx, int dy) { + static_cast<Fl_Paged_Device*>(p)->print_window(static_cast<Fl_Window*>(i),dx,dy); +} + +void fl_paged_device_print_window_part(PAGEDDEVICE p, void * i, int x, int y, + int w, int h, int dx, int dy) +{ + // virtual so disable dispatch + static_cast<Fl_Paged_Device*>(p)->Fl_Paged_Device::print_window_part + (static_cast<Fl_Window*>(i),x,y,w,h,dx,dy); +} + + diff --git a/body/c_fl_paged_device.h b/body/c_fl_paged_device.h new file mode 100644 index 0000000..90befcf --- /dev/null +++ b/body/c_fl_paged_device.h @@ -0,0 +1,54 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PAGED_DEVICE_GUARD +#define FL_PAGED_DEVICE_GUARD + + +extern "C" const int fl_page_format_media; +extern "C" const int fl_page_layout_portrait; +extern "C" const int fl_page_layout_landscape; +extern "C" const int fl_page_layout_reversed; +extern "C" const int fl_page_layout_orientation; +extern "C" const int fl_no_page_formats; + + +extern "C" void fl_paged_device_get_page_format(int i, const char ** n, int * w, int * h); + + +typedef void* PAGEDDEVICE; + + +extern "C" PAGEDDEVICE new_fl_paged_device(void); +extern "C" void free_fl_paged_device(PAGEDDEVICE p); + + +extern "C" int fl_paged_device_start_job(PAGEDDEVICE p, int c); +extern "C" int fl_paged_device_start_job2(PAGEDDEVICE p, int c, int * f, int * t); +extern "C" void fl_paged_device_end_job(PAGEDDEVICE p); +extern "C" int fl_paged_device_start_page(PAGEDDEVICE p); +extern "C" int fl_paged_device_end_page(PAGEDDEVICE p); + + +extern "C" void fl_paged_device_margins(PAGEDDEVICE p, int * l, int * t, int * r, int * b); +extern "C" int fl_paged_device_printable_rect(PAGEDDEVICE p, int * w, int * h); +extern "C" void fl_paged_device_get_origin(PAGEDDEVICE p, int * x, int * y); +extern "C" void fl_paged_device_set_origin(PAGEDDEVICE p, int x, int y); +extern "C" void fl_paged_device_rotate(PAGEDDEVICE p, float r); +extern "C" void fl_paged_device_scale(PAGEDDEVICE p, float x, float y); +extern "C" void fl_paged_device_translate(PAGEDDEVICE p, int x, int y); +extern "C" void fl_paged_device_untranslate(PAGEDDEVICE p); + + +extern "C" void fl_paged_device_print_widget(PAGEDDEVICE p, void * i, int dx, int dy); +extern "C" void fl_paged_device_print_window(PAGEDDEVICE p, void * i, int dx, int dy); +extern "C" void fl_paged_device_print_window_part(PAGEDDEVICE p, void * i, int x, int y, + int w, int h, int dx, int dy); + + +#endif + + diff --git a/body/c_fl_pixmap.cpp b/body/c_fl_pixmap.cpp new file mode 100644 index 0000000..14b5a74 --- /dev/null +++ b/body/c_fl_pixmap.cpp @@ -0,0 +1,66 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Pixmap.H> +#include "c_fl_pixmap.h" + + + + +PIXMAP new_fl_pixmap(void * d) { + Fl_Pixmap *p = new Fl_Pixmap(static_cast<char**>(d)); + return p; +} + +void free_fl_pixmap(PIXMAP b) { + delete static_cast<Fl_Pixmap*>(b); +} + + + + +PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h) { + // virtual so disable dispatch + return static_cast<Fl_Pixmap*>(b)->Fl_Pixmap::copy(w, h); +} + +PIXMAP fl_pixmap_copy2(PIXMAP b) { + return static_cast<Fl_Pixmap*>(b)->copy(); +} + + + + +void fl_pixmap_color_average(PIXMAP p, int c, float b) { + // virtual so disable dispatch + static_cast<Fl_Pixmap*>(p)->Fl_Pixmap::color_average(c, b); +} + +void fl_pixmap_desaturate(PIXMAP p) { + // virtual so disable dispatch + static_cast<Fl_Pixmap*>(p)->Fl_Pixmap::desaturate(); +} + + + + +void fl_pixmap_uncache(PIXMAP p) { + // virtual so disable dispatch + static_cast<Fl_Pixmap*>(p)->Fl_Pixmap::uncache(); +} + + + + +void fl_pixmap_draw2(PIXMAP b, int x, int y) { + static_cast<Fl_Pixmap*>(b)->draw(x, y); +} + +void fl_pixmap_draw(PIXMAP b, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + static_cast<Fl_Pixmap*>(b)->Fl_Pixmap::draw(x, y, w, h, cx, cy); +} + diff --git a/body/c_fl_pixmap.h b/body/c_fl_pixmap.h new file mode 100644 index 0000000..868a3a2 --- /dev/null +++ b/body/c_fl_pixmap.h @@ -0,0 +1,35 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PIXMAP_GUARD +#define FL_PIXMAP_GUARD + + +typedef void* PIXMAP; + + +extern "C" PIXMAP new_fl_pixmap(void * d); +extern "C" void free_fl_pixmap(PIXMAP b); + + +extern "C" PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h); +extern "C" PIXMAP fl_pixmap_copy2(PIXMAP b); + + +extern "C" void fl_pixmap_color_average(PIXMAP p, int c, float b); +extern "C" void fl_pixmap_desaturate(PIXMAP p); + + +extern "C" void fl_pixmap_uncache(PIXMAP p); + + +extern "C" void fl_pixmap_draw2(PIXMAP b, int x, int y); +extern "C" void fl_pixmap_draw(PIXMAP b, int x, int y, int w, int h, int cx, int cy); + + +#endif + + diff --git a/body/c_fl_png_image.cpp b/body/c_fl_png_image.cpp new file mode 100644 index 0000000..ae77476 --- /dev/null +++ b/body/c_fl_png_image.cpp @@ -0,0 +1,27 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_PNG_Image.H> +#include "c_fl_png_image.h" + + + + +PNGIMAGE new_fl_png_image(const char * f) { + Fl_PNG_Image *p = new Fl_PNG_Image(f); + return p; +} + +PNGIMAGE new_fl_png_image2(const char *name, void *data, int size) { + Fl_PNG_Image *p = new Fl_PNG_Image(name, static_cast<uchar*>(data), size); + return p; +} + +void free_fl_png_image(PNGIMAGE p) { + delete static_cast<Fl_PNG_Image*>(p); +} + + diff --git a/body/c_fl_png_image.h b/body/c_fl_png_image.h new file mode 100644 index 0000000..83344e0 --- /dev/null +++ b/body/c_fl_png_image.h @@ -0,0 +1,21 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PNG_IMAGE_GUARD +#define FL_PNG_IMAGE_GUARD + + +typedef void* PNGIMAGE; + + +extern "C" PNGIMAGE new_fl_png_image(const char * f); +extern "C" PNGIMAGE new_fl_png_image2(const char *name, void *data, int size); +extern "C" void free_fl_png_image(PNGIMAGE p); + + +#endif + + diff --git a/body/c_fl_pnm_image.cpp b/body/c_fl_pnm_image.cpp new file mode 100644 index 0000000..e5f7f17 --- /dev/null +++ b/body/c_fl_pnm_image.cpp @@ -0,0 +1,22 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_PNM_Image.H> +#include "c_fl_pnm_image.h" + + + + +PNMIMAGE new_fl_pnm_image(const char * f) { + Fl_PNM_Image *p = new Fl_PNM_Image(f); + return p; +} + +void free_fl_pnm_image(PNMIMAGE p) { + delete static_cast<Fl_PNM_Image*>(p); +} + + diff --git a/body/c_fl_pnm_image.h b/body/c_fl_pnm_image.h new file mode 100644 index 0000000..6feeff9 --- /dev/null +++ b/body/c_fl_pnm_image.h @@ -0,0 +1,20 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PNM_IMAGE_GUARD +#define FL_PNM_IMAGE_GUARD + + +typedef void* PNMIMAGE; + + +extern "C" PNMIMAGE new_fl_pnm_image(const char * f); +extern "C" void free_fl_pnm_image(PNMIMAGE p); + + +#endif + + diff --git a/body/c_fl_positioner.cpp b/body/c_fl_positioner.cpp new file mode 100644 index 0000000..6a070d7 --- /dev/null +++ b/body/c_fl_positioner.cpp @@ -0,0 +1,171 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Positioner.H> +#include "c_fl_positioner.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Positioner : Fl_Positioner { +public: + // Really only needed for the versions with (x,y,w,h) + using Fl_Positioner::draw; + using Fl_Positioner::handle; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Positioner : public Fl_Positioner { +public: + using Fl_Positioner::Fl_Positioner; + + friend void fl_positioner_draw(POSITIONER p); + friend int fl_positioner_handle(POSITIONER p, int e); + + void draw(); + int handle(int e); +}; + +void My_Positioner::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Positioner::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +POSITIONER new_fl_positioner(int x, int y, int w, int h, char* label) { + My_Positioner *p = new My_Positioner(x, y, w, h, label); + return p; +} + +void free_fl_positioner(POSITIONER p) { + if (fl_inside_callback) { + fl_delete_widget(p); + } else { + delete static_cast<My_Positioner*>(p); + } +} + + + + +int fl_positioner_set_value(POSITIONER p, double x, double y) { + return static_cast<Fl_Positioner*>(p)->value(x, y); +} + + + + +void fl_positioner_xbounds(POSITIONER p, double l, double h) { + static_cast<Fl_Positioner*>(p)->xbounds(l, h); +} + +void fl_positioner_xstep(POSITIONER p, double a) { + static_cast<Fl_Positioner*>(p)->xstep(a); +} + +double fl_positioner_get_xminimum(POSITIONER p) { + return static_cast<Fl_Positioner*>(p)->xminimum(); +} + +void fl_positioner_set_xminimum(POSITIONER p, double a) { + static_cast<Fl_Positioner*>(p)->xminimum(a); +} + +double fl_positioner_get_xmaximum(POSITIONER p) { + return static_cast<Fl_Positioner*>(p)->xmaximum(); +} + +void fl_positioner_set_xmaximum(POSITIONER p, double a) { + static_cast<Fl_Positioner*>(p)->xmaximum(a); +} + +double fl_positioner_get_xvalue(POSITIONER p) { + return static_cast<Fl_Positioner*>(p)->xvalue(); +} + +int fl_positioner_set_xvalue(POSITIONER p, double x) { + return static_cast<Fl_Positioner*>(p)->xvalue(x); +} + + + + +void fl_positioner_ybounds(POSITIONER p, double l, double h) { + static_cast<Fl_Positioner*>(p)->ybounds(l, h); +} + +void fl_positioner_ystep(POSITIONER p, double a) { + static_cast<Fl_Positioner*>(p)->ystep(a); +} + +double fl_positioner_get_yminimum(POSITIONER p) { + return static_cast<Fl_Positioner*>(p)->yminimum(); +} + +void fl_positioner_set_yminimum(POSITIONER p, double a) { + static_cast<Fl_Positioner*>(p)->yminimum(a); +} + +double fl_positioner_get_ymaximum(POSITIONER p) { + return static_cast<Fl_Positioner*>(p)->ymaximum(); +} + +void fl_positioner_set_ymaximum(POSITIONER p, double a) { + static_cast<Fl_Positioner*>(p)->ymaximum(a); +} + +double fl_positioner_get_yvalue(POSITIONER p) { + return static_cast<Fl_Positioner*>(p)->yvalue(); +} + +int fl_positioner_set_yvalue(POSITIONER p, double y) { + return static_cast<Fl_Positioner*>(p)->yvalue(y); +} + + + + +void fl_positioner_draw(POSITIONER p) { + static_cast<My_Positioner*>(p)->Fl_Positioner::draw(); +} + +void fl_positioner_draw2(POSITIONER p, int x, int y, int w, int h) { + void (Fl_Positioner::*mydraw)(int,int,int,int) = &Friend_Positioner::draw; + (static_cast<Fl_Positioner*>(p)->*mydraw)(x, y, w, h); +} + +int fl_positioner_handle(POSITIONER p, int e) { + return static_cast<My_Positioner*>(p)->Fl_Positioner::handle(e); +} + +int fl_positioner_handle2(POSITIONER p, int e, int x, int y, int w, int h) { + int (Fl_Positioner::*myhandle)(int,int,int,int,int) = &Friend_Positioner::handle; + return (static_cast<Fl_Positioner*>(p)->*myhandle)(e, x, y, w, h); +} + + diff --git a/body/c_fl_positioner.h b/body/c_fl_positioner.h new file mode 100644 index 0000000..9fd96d4 --- /dev/null +++ b/body/c_fl_positioner.h @@ -0,0 +1,49 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_POSITIONER_GUARD +#define FL_POSITIONER_GUARD + + +typedef void* POSITIONER; + + +extern "C" POSITIONER new_fl_positioner(int x, int y, int w, int h, char* label); +extern "C" void free_fl_positioner(POSITIONER p); + + +extern "C" int fl_positioner_set_value(POSITIONER p, double x, double y); + + +extern "C" void fl_positioner_xbounds(POSITIONER p, double l, double h); +extern "C" void fl_positioner_xstep(POSITIONER p, double a); +extern "C" double fl_positioner_get_xminimum(POSITIONER p); +extern "C" void fl_positioner_set_xminimum(POSITIONER p, double a); +extern "C" double fl_positioner_get_xmaximum(POSITIONER p); +extern "C" void fl_positioner_set_xmaximum(POSITIONER p, double a); +extern "C" double fl_positioner_get_xvalue(POSITIONER p); +extern "C" int fl_positioner_set_xvalue(POSITIONER p, double x); + + +extern "C" void fl_positioner_ybounds(POSITIONER p, double l, double h); +extern "C" void fl_positioner_ystep(POSITIONER p, double a); +extern "C" double fl_positioner_get_yminimum(POSITIONER p); +extern "C" void fl_positioner_set_yminimum(POSITIONER p, double a); +extern "C" double fl_positioner_get_ymaximum(POSITIONER p); +extern "C" void fl_positioner_set_ymaximum(POSITIONER p, double a); +extern "C" double fl_positioner_get_yvalue(POSITIONER p); +extern "C" int fl_positioner_set_yvalue(POSITIONER p, double y); + + +extern "C" void fl_positioner_draw(POSITIONER p); +extern "C" void fl_positioner_draw2(POSITIONER p, int x, int y, int w, int h); +extern "C" int fl_positioner_handle(POSITIONER p, int e); +extern "C" int fl_positioner_handle2(POSITIONER p, int e, int x, int y, int w, int h); + + +#endif + + diff --git a/body/c_fl_postscript_file_device.cpp b/body/c_fl_postscript_file_device.cpp new file mode 100644 index 0000000..480d273 --- /dev/null +++ b/body/c_fl_postscript_file_device.cpp @@ -0,0 +1,125 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_PostScript.H> +#include "c_fl_postscript_file_device.h" + + + + +// Making available protected methods + +class My_PostScript_File_Device : Fl_PostScript_File_Device { +public: + using Fl_PostScript_File_Device::driver; +}; + + + + +// Flattened C API + +POSTSCRIPTFILEDEVICE new_fl_postscript_file_device(void) { + Fl_PostScript_File_Device *p = new Fl_PostScript_File_Device(); + return p; +} + +void free_fl_postscript_file_device(POSTSCRIPTFILEDEVICE p) { + delete static_cast<Fl_PostScript_File_Device*>(p); +} + + + + +const char * fl_postscript_file_device_get_file_chooser_title() { + return Fl_PostScript_File_Device::file_chooser_title; +} + +void fl_postscript_file_device_set_file_chooser_title(const char * v) { + Fl_PostScript_File_Device::file_chooser_title = v; +} + + + + +void * fl_postscript_file_device_get_driver(POSTSCRIPTFILEDEVICE p) { + return (static_cast<Fl_PostScript_File_Device*>(p)->*(&My_PostScript_File_Device::driver))(); +} + + + + +int fl_postscript_file_device_start_job(POSTSCRIPTFILEDEVICE p, int c) { + return static_cast<Fl_PostScript_File_Device*>(p)->start_job(c, 0, 0); +} + +int fl_postscript_file_device_start_job2(POSTSCRIPTFILEDEVICE p, int c, int * f, int * t) { + return static_cast<Fl_PostScript_File_Device*>(p)->start_job(c, f, t); +} + +int fl_postscript_file_device_start_job3(POSTSCRIPTFILEDEVICE p, void * o, int c, int f, int l) { + return static_cast<Fl_PostScript_File_Device*>(p)->start_job + (static_cast<FILE*>(o), + c, + static_cast<Fl_Paged_Device::Page_Format>(f), + static_cast<Fl_Paged_Device::Page_Layout>(l)); +} + +int fl_postscript_file_device_start_job4(POSTSCRIPTFILEDEVICE p, int c, int f, int l) { + return static_cast<Fl_PostScript_File_Device*>(p)->start_job + (c, + static_cast<Fl_Paged_Device::Page_Format>(f), + static_cast<Fl_Paged_Device::Page_Layout>(l)); +} + +void fl_postscript_file_device_end_job(POSTSCRIPTFILEDEVICE p) { + static_cast<Fl_PostScript_File_Device*>(p)->end_job(); +} + +int fl_postscript_file_device_start_page(POSTSCRIPTFILEDEVICE p) { + return static_cast<Fl_PostScript_File_Device*>(p)->start_page(); +} + +int fl_postscript_file_device_end_page(POSTSCRIPTFILEDEVICE p) { + return static_cast<Fl_PostScript_File_Device*>(p)->end_page(); +} + + + + +void fl_postscript_file_device_margins(POSTSCRIPTFILEDEVICE p, int * l, int * t, int * r, int * b) { + static_cast<Fl_PostScript_File_Device*>(p)->margins(l,t,r,b); +} + +int fl_postscript_file_device_printable_rect(POSTSCRIPTFILEDEVICE p, int * w, int * h) { + return static_cast<Fl_PostScript_File_Device*>(p)->printable_rect(w,h); +} + +void fl_postscript_file_device_get_origin(POSTSCRIPTFILEDEVICE p, int * x, int * y) { + static_cast<Fl_PostScript_File_Device*>(p)->origin(x,y); +} + +void fl_postscript_file_device_set_origin(POSTSCRIPTFILEDEVICE p, int x, int y) { + static_cast<Fl_PostScript_File_Device*>(p)->origin(x,y); +} + +void fl_postscript_file_device_rotate(POSTSCRIPTFILEDEVICE p, float r) { + static_cast<Fl_PostScript_File_Device*>(p)->rotate(r); +} + +void fl_postscript_file_device_scale(POSTSCRIPTFILEDEVICE p, float x, float y) { + static_cast<Fl_PostScript_File_Device*>(p)->scale(x,y); +} + +void fl_postscript_file_device_translate(POSTSCRIPTFILEDEVICE p, int x, int y) { + static_cast<Fl_PostScript_File_Device*>(p)->translate(x,y); +} + +void fl_postscript_file_device_untranslate(POSTSCRIPTFILEDEVICE p) { + static_cast<Fl_PostScript_File_Device*>(p)->untranslate(); +} + + diff --git a/body/c_fl_postscript_file_device.h b/body/c_fl_postscript_file_device.h new file mode 100644 index 0000000..f4d6d31 --- /dev/null +++ b/body/c_fl_postscript_file_device.h @@ -0,0 +1,47 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_POSTSCRIPT_FILE_DEVICE_GUARD +#define FL_POSTSCRIPT_FILE_DEVICE_GUARD + + +typedef void* POSTSCRIPTFILEDEVICE; + + +extern "C" POSTSCRIPTFILEDEVICE new_fl_postscript_file_device(void); +extern "C" void free_fl_postscript_file_device(POSTSCRIPTFILEDEVICE p); + + +extern "C" const char * fl_postscript_file_device_get_file_chooser_title(); +extern "C" void fl_postscript_file_device_set_file_chooser_title(const char * v); + + +extern "C" void * fl_postscript_file_device_get_driver(POSTSCRIPTFILEDEVICE p); + + +extern "C" int fl_postscript_file_device_start_job(POSTSCRIPTFILEDEVICE p, int c); +extern "C" int fl_postscript_file_device_start_job2(POSTSCRIPTFILEDEVICE p, int c, int * f, int * t); +extern "C" int fl_postscript_file_device_start_job3(POSTSCRIPTFILEDEVICE p, void * o, int c, int f, int l); +extern "C" int fl_postscript_file_device_start_job4(POSTSCRIPTFILEDEVICE p, int c, int f, int l); +extern "C" void fl_postscript_file_device_end_job(POSTSCRIPTFILEDEVICE p); +extern "C" int fl_postscript_file_device_start_page(POSTSCRIPTFILEDEVICE p); +extern "C" int fl_postscript_file_device_end_page(POSTSCRIPTFILEDEVICE p); + + +extern "C" void fl_postscript_file_device_margins(POSTSCRIPTFILEDEVICE p, int * l, int * t, + int * r, int * b); +extern "C" int fl_postscript_file_device_printable_rect(POSTSCRIPTFILEDEVICE p, int * w, int * h); +extern "C" void fl_postscript_file_device_get_origin(POSTSCRIPTFILEDEVICE p, int * x, int * y); +extern "C" void fl_postscript_file_device_set_origin(POSTSCRIPTFILEDEVICE p, int x, int y); +extern "C" void fl_postscript_file_device_rotate(POSTSCRIPTFILEDEVICE p, float r); +extern "C" void fl_postscript_file_device_scale(POSTSCRIPTFILEDEVICE p, float x, float y); +extern "C" void fl_postscript_file_device_translate(POSTSCRIPTFILEDEVICE p, int x, int y); +extern "C" void fl_postscript_file_device_untranslate(POSTSCRIPTFILEDEVICE p); + + +#endif + + diff --git a/body/c_fl_preferences.cpp b/body/c_fl_preferences.cpp new file mode 100644 index 0000000..d2b0d2c --- /dev/null +++ b/body/c_fl_preferences.cpp @@ -0,0 +1,233 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Preferences.H> +#include <FL/filename.H> +#include <cstdlib> +#include "c_fl_preferences.h" + + + + +const int root_fl_prefs_system = Fl_Preferences::SYSTEM; +const int root_fl_prefs_user = Fl_Preferences::USER; + +const int const_fl_path_max = FL_PATH_MAX; + + + + +const char * fl_preferences_new_uuid() { + return Fl_Preferences::newUUID(); +} + + + + +class My_Preferences : public Fl_Preferences { + public: + using Fl_Preferences::Fl_Preferences; + int reference_count = 0; +}; + + + + +PREFS new_fl_pref_database_path(char * p, char * v, char * a) { + My_Preferences *e = new My_Preferences(p, v, a); + return e; +} + +PREFS new_fl_pref_database_scope(int s, char * v, char * a) { + My_Preferences *e = new My_Preferences((Fl_Preferences::Root)s, v, a); + return e; +} + +void upref_fl_pref_database(PREFS e) { + static_cast<My_Preferences*>(e)->reference_count += 1; +} + +void free_fl_pref_database(PREFS e) { + if (static_cast<My_Preferences*>(e)->reference_count <= 0) { + delete static_cast<My_Preferences*>(e); + } else { + static_cast<My_Preferences*>(e)->reference_count -= 1; + } +} + + +PREFS new_fl_pref_group_copy(PREFS e) { + Fl_Preferences *g = new Fl_Preferences(static_cast<Fl_Preferences*>(e)); + return g; +} + +PREFS new_fl_pref_group_memory(char * n) { + Fl_Preferences *g = new Fl_Preferences(NULL, n); + return g; +} + +PREFS new_fl_pref_group_name(PREFS e, char * n) { + Fl_Preferences *g = new Fl_Preferences(static_cast<Fl_Preferences*>(e), n); + return g; +} + +PREFS new_fl_pref_group_index(PREFS e, int i) { + Fl_Preferences *g = new Fl_Preferences(static_cast<Fl_Preferences*>(e), i); + return g; +} + +void free_fl_pref_group(PREFS e) { + delete static_cast<Fl_Preferences*>(e); +} + + + + +void fl_preferences_flush(PREFS e) { + static_cast<Fl_Preferences*>(e)->flush(); +} + +int fl_preferences_getuserdatapath(PREFS e, char * p, int len) { + return (int)static_cast<Fl_Preferences*>(e)->getUserdataPath(p, len); +} + + + + +int fl_preferences_deleteentry(PREFS e, const char * k) { + return (int)static_cast<Fl_Preferences*>(e)->deleteEntry(k); +} + +int fl_preferences_deleteallentries(PREFS e) { + return (int)static_cast<Fl_Preferences*>(e)->deleteAllEntries(); +} + +int fl_preferences_deletegroup(PREFS e, const char * g) { + return (int)static_cast<Fl_Preferences*>(e)->deleteGroup(g); +} + +int fl_preferences_deleteallgroups(PREFS e) { + return (int)static_cast<Fl_Preferences*>(e)->deleteAllGroups(); +} + +int fl_preferences_clear(PREFS e) { + return (int)static_cast<Fl_Preferences*>(e)->clear(); +} + + + + +int fl_preferences_entries(PREFS e) { + return static_cast<Fl_Preferences*>(e)->entries(); +} + +const char * fl_preferences_entry(PREFS e, int i) { + return static_cast<Fl_Preferences*>(e)->entry(i); +} + +int fl_preferences_entryexists(PREFS e, const char * k) { + return (int)static_cast<Fl_Preferences*>(e)->entryExists(k); +} + +int fl_preferences_size(PREFS e, const char * k) { + return static_cast<Fl_Preferences*>(e)->size(k); +} + + + + +int fl_preferences_groups(PREFS e) { + return static_cast<Fl_Preferences*>(e)->groups(); +} + +const char * fl_preferences_group(PREFS e, int i) { + return static_cast<Fl_Preferences*>(e)->group(i); +} + +int fl_preferences_groupexists(PREFS e, const char * g) { + return (int)static_cast<Fl_Preferences*>(e)->groupExists(g); +} + + + + +const char * fl_preferences_name(PREFS e) { + return static_cast<Fl_Preferences*>(e)->name(); +} + +const char * fl_preferences_path(PREFS e) { + return static_cast<Fl_Preferences*>(e)->path(); +} + + + + +int fl_preferences_get_int(PREFS e, const char * k, int& v, int d) { + return (int)static_cast<Fl_Preferences*>(e)->get(k,v,d); +} + +int fl_preferences_get_float(PREFS e, const char * k, float& v, float d) { + return (int)static_cast<Fl_Preferences*>(e)->get(k,v,d); +} + +int fl_preferences_get_double(PREFS e, const char * k, double& v, double d) { + return (int)static_cast<Fl_Preferences*>(e)->get(k,v,d); +} + +// must deallocate result afterwards +int fl_preferences_get_str(PREFS e, const char * k, char *& v, const char * d) { + return (int)static_cast<Fl_Preferences*>(e)->get(k,v,d); +} + +int fl_preferences_get_str_limit (PREFS e, const char * k, char * v, const char * d, int m) { + return (int)static_cast<Fl_Preferences*>(e)->get(k, v, d, m); +} + +// must deallocate result afterwards +int fl_preferences_get_void (PREFS e, const char * k, void *& v, const void * d, int ds) { + return (int)static_cast<Fl_Preferences*>(e)->get(k, v, d, ds); +} + +int fl_preferences_get_void_limit (PREFS e, const char * k, void * v, const void * d, int ds, int ms) { + return (int)static_cast<Fl_Preferences*>(e)->get(k, v, d, ds, ms); +} + +void free_fl_preferences_void_data(void * v) { + free(v); +} + + + + +int fl_preferences_set_int(PREFS e, const char * k, int v) { + return (int)static_cast<Fl_Preferences*>(e)->set(k,v); +} + +int fl_preferences_set_float(PREFS e, const char * k, float v) { + return (int)static_cast<Fl_Preferences*>(e)->set(k,v); +} + +int fl_preferences_set_float_prec(PREFS e, const char * k, float v, int p) { + return (int)static_cast<Fl_Preferences*>(e)->set(k,v,p); +} + +int fl_preferences_set_double(PREFS e, const char * k, double v) { + return (int)static_cast<Fl_Preferences*>(e)->set(k,v); +} + +int fl_preferences_set_double_prec(PREFS e, const char * k, double v, int p) { + return (int)static_cast<Fl_Preferences*>(e)->set(k,v,p); +} + +int fl_preferences_set_str(PREFS e, const char * k, const char * v) { + return (int)static_cast<Fl_Preferences*>(e)->set(k,v); +} + +int fl_preferences_set_void(PREFS e, const char * k, const void * d, int ds) { + return (int)static_cast<Fl_Preferences*>(e)->set(k, d, ds); +} + + diff --git a/body/c_fl_preferences.h b/body/c_fl_preferences.h new file mode 100644 index 0000000..9f77dfb --- /dev/null +++ b/body/c_fl_preferences.h @@ -0,0 +1,86 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PREFERENCES_GUARD +#define FL_PREFERENCES_GUARD + + +typedef void* PREFS; + + +extern const int root_fl_prefs_system; +extern const int root_fl_prefs_user; + +extern const int const_fl_path_max; + + +extern "C" const char * fl_preferences_new_uuid(); + + +extern "C" PREFS new_fl_pref_database_path(char * p, char * v, char * a); +extern "C" PREFS new_fl_pref_database_scope(int s, char * v, char * a); +extern "C" void upref_fl_pref_database(PREFS e); +extern "C" void free_fl_pref_database(PREFS e); + +extern "C" PREFS new_fl_pref_group_copy(PREFS e); +extern "C" PREFS new_fl_pref_group_memory(char * n); +extern "C" PREFS new_fl_pref_group_name(PREFS e, char * n); +extern "C" PREFS new_fl_pref_group_index(PREFS e, int i); +extern "C" void free_fl_pref_group(PREFS e); + + +extern "C" void fl_preferences_flush(PREFS e); +extern "C" int fl_preferences_getuserdatapath(PREFS e, char * p, int len); + + +extern "C" int fl_preferences_deleteentry(PREFS e, const char * k); +extern "C" int fl_preferences_deleteallentries(PREFS e); +extern "C" int fl_preferences_deletegroup(PREFS e, const char * g); +extern "C" int fl_preferences_deleteallgroups(PREFS e); +extern "C" int fl_preferences_clear(PREFS e); + + +extern "C" int fl_preferences_entries(PREFS e); +extern "C" const char * fl_preferences_entry(PREFS e, int i); +extern "C" int fl_preferences_entryexists(PREFS e, const char * k); +extern "C" int fl_preferences_size(PREFS e, const char * k); + + +extern "C" int fl_preferences_groups(PREFS e); +extern "C" const char * fl_preferences_group(PREFS e, int i); +extern "C" int fl_preferences_groupexists(PREFS e, const char * g); + + +extern "C" const char * fl_preferences_name(PREFS e); +extern "C" const char * fl_preferences_path(PREFS e); + + +extern "C" int fl_preferences_get_int(PREFS e, const char * k, int& v, int d); +extern "C" int fl_preferences_get_float(PREFS e, const char * k, float& v, float d); +extern "C" int fl_preferences_get_double(PREFS e, const char * k, double& v, double d); +extern "C" int fl_preferences_get_str + (PREFS e, const char * k, char *& v, const char * d); +extern "C" int fl_preferences_get_str_limit + (PREFS e, const char * k, char * v, const char * d, int m); +extern "C" int fl_preferences_get_void + (PREFS e, const char * k, void *& v, const void * d, int ds); +extern "C" int fl_preferences_get_void_limit + (PREFS e, const char * k, void * v, const void * d, int ds, int ms); +extern "C" void free_fl_preferences_void_data(void * v); + + +extern "C" int fl_preferences_set_int(PREFS e, const char * k, int v); +extern "C" int fl_preferences_set_float(PREFS e, const char * k, float v); +extern "C" int fl_preferences_set_float_prec(PREFS e, const char * k, float v, int p); +extern "C" int fl_preferences_set_double(PREFS e, const char * k, double v); +extern "C" int fl_preferences_set_double_prec(PREFS e, const char * k, double v, int p); +extern "C" int fl_preferences_set_str(PREFS e, const char * k, const char * v); +extern "C" int fl_preferences_set_void(PREFS e, const char * k, const void * d, int ds); + + +#endif + + diff --git a/body/c_fl_printer.cpp b/body/c_fl_printer.cpp new file mode 100644 index 0000000..94f31d5 --- /dev/null +++ b/body/c_fl_printer.cpp @@ -0,0 +1,259 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Printer.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Window.H> +#include "c_fl_printer.h" + + + + +// Flattened C API + +PRINTER new_fl_printer(void) { + Fl_Printer *p = new Fl_Printer(); + return p; +} + +void free_fl_printer(PRINTER p) { + delete static_cast<Fl_Printer*>(p); +} + + + + +const char * fl_printer_get_dialog_title() { + return Fl_Printer::dialog_title; +} + +void fl_printer_set_dialog_title(const char * v) { + Fl_Printer::dialog_title = v; +} + +const char * fl_printer_get_dialog_printer() { + return Fl_Printer::dialog_printer; +} + +void fl_printer_set_dialog_printer(const char * v) { + Fl_Printer::dialog_printer = v; +} + +const char * fl_printer_get_dialog_range() { + return Fl_Printer::dialog_range; +} + +void fl_printer_set_dialog_range(const char * v) { + Fl_Printer::dialog_range = v; +} + +const char * fl_printer_get_dialog_copies() { + return Fl_Printer::dialog_copies; +} + +void fl_printer_set_dialog_copies(const char * v) { + Fl_Printer::dialog_copies = v; +} + +const char * fl_printer_get_dialog_all() { + return Fl_Printer::dialog_all; +} + +void fl_printer_set_dialog_all(const char * v) { + Fl_Printer::dialog_all = v; +} + +const char * fl_printer_get_dialog_pages() { + return Fl_Printer::dialog_pages; +} + +void fl_printer_set_dialog_pages(const char * v) { + Fl_Printer::dialog_pages = v; +} + +const char * fl_printer_get_dialog_from() { + return Fl_Printer::dialog_from; +} + +void fl_printer_set_dialog_from(const char * v) { + Fl_Printer::dialog_from = v; +} + +const char * fl_printer_get_dialog_to() { + return Fl_Printer::dialog_to; +} + +void fl_printer_set_dialog_to(const char * v) { + Fl_Printer::dialog_to = v; +} + +const char * fl_printer_get_dialog_properties() { + return Fl_Printer::dialog_properties; +} + +void fl_printer_set_dialog_properties(const char * v) { + Fl_Printer::dialog_properties = v; +} + +const char * fl_printer_get_dialog_copyno() { + return Fl_Printer::dialog_copyNo; +} + +void fl_printer_set_dialog_copyno(const char * v) { + Fl_Printer::dialog_copyNo = v; +} + +const char * fl_printer_get_dialog_print_button() { + return Fl_Printer::dialog_print_button; +} + +void fl_printer_set_dialog_print_button(const char * v) { + Fl_Printer::dialog_print_button = v; +} + +const char * fl_printer_get_dialog_cancel_button() { + return Fl_Printer::dialog_cancel_button; +} + +void fl_printer_set_dialog_cancel_button(const char * v) { + Fl_Printer::dialog_cancel_button = v; +} + +const char * fl_printer_get_dialog_print_to_file() { + return Fl_Printer::dialog_print_to_file; +} + +void fl_printer_set_dialog_print_to_file(const char * v) { + Fl_Printer::dialog_print_to_file = v; +} + +const char * fl_printer_get_property_title() { + return Fl_Printer::property_title; +} + +void fl_printer_set_property_title(const char * v) { + Fl_Printer::property_title = v; +} + +const char * fl_printer_get_property_pagesize() { + return Fl_Printer::property_pagesize; +} + +void fl_printer_set_property_pagesize(const char * v) { + Fl_Printer::property_pagesize = v; +} + +const char * fl_printer_get_property_mode() { + return Fl_Printer::property_mode; +} + +void fl_printer_set_property_mode(const char * v) { + Fl_Printer::property_mode = v; +} + +const char * fl_printer_get_property_use() { + return Fl_Printer::property_use; +} + +void fl_printer_set_property_use(const char * v) { + Fl_Printer::property_use = v; +} + +const char * fl_printer_get_property_save() { + return Fl_Printer::property_save; +} + +void fl_printer_set_property_save(const char * v) { + Fl_Printer::property_save = v; +} + +const char * fl_printer_get_property_cancel() { + return Fl_Printer::property_cancel; +} + +void fl_printer_set_property_cancel(const char * v) { + Fl_Printer::property_cancel = v; +} + + + + +int fl_printer_start_job(PRINTER p, int c) { + return static_cast<Fl_Printer*>(p)->start_job(c, 0, 0); +} + +int fl_printer_start_job2(PRINTER p, int c, int * f, int * t) { + return static_cast<Fl_Printer*>(p)->start_job(c, f, t); +} + +void fl_printer_end_job(PRINTER p) { + static_cast<Fl_Printer*>(p)->end_job(); +} + +int fl_printer_start_page(PRINTER p) { + return static_cast<Fl_Printer*>(p)->start_page(); +} + +int fl_printer_end_page(PRINTER p) { + return static_cast<Fl_Printer*>(p)->end_page(); +} + + + + +void fl_printer_margins(PRINTER p, int * l, int * t, int * r, int * b) { + static_cast<Fl_Printer*>(p)->margins(l,t,r,b); +} + +int fl_printer_printable_rect(PRINTER p, int * w, int * h) { + return static_cast<Fl_Printer*>(p)->printable_rect(w,h); +} + +void fl_printer_get_origin(PRINTER p, int * x, int * y) { + static_cast<Fl_Printer*>(p)->origin(x,y); +} + +void fl_printer_set_origin(PRINTER p, int x, int y) { + static_cast<Fl_Printer*>(p)->origin(x,y); +} + +void fl_printer_rotate(PRINTER p, float r) { + static_cast<Fl_Printer*>(p)->rotate(r); +} + +void fl_printer_scale(PRINTER p, float x, float y) { + static_cast<Fl_Printer*>(p)->scale(x,y); +} + +void fl_printer_translate(PRINTER p, int x, int y) { + static_cast<Fl_Printer*>(p)->translate(x,y); +} + +void fl_printer_untranslate(PRINTER p) { + static_cast<Fl_Printer*>(p)->untranslate(); +} + + + + +void fl_printer_print_widget(PRINTER p, void * i, int dx, int dy) { + static_cast<Fl_Printer*>(p)->print_widget(static_cast<Fl_Widget*>(i),dx,dy); +} + +void fl_printer_print_window_part(PRINTER p, void * i, int x, int y, + int w, int h, int dx, int dy) +{ + static_cast<Fl_Printer*>(p)->print_window_part(static_cast<Fl_Window*>(i),x,y,w,h,dx,dy); +} + + + + +void fl_printer_set_current(PRINTER p) { + static_cast<Fl_Printer*>(p)->set_current(); +} + + diff --git a/body/c_fl_printer.h b/body/c_fl_printer.h new file mode 100644 index 0000000..90f070d --- /dev/null +++ b/body/c_fl_printer.h @@ -0,0 +1,85 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PRINTER_GUARD +#define FL_PRINTER_GUARD + + +typedef void* PRINTER; + + +extern "C" PRINTER new_fl_printer(void); +extern "C" void free_fl_printer(PRINTER p); + + +extern "C" const char * fl_printer_get_dialog_title(); +extern "C" void fl_printer_set_dialog_title(const char * v); +extern "C" const char * fl_printer_get_dialog_printer(); +extern "C" void fl_printer_set_dialog_printer(const char * v); +extern "C" const char * fl_printer_get_dialog_range(); +extern "C" void fl_printer_set_dialog_range(const char * v); +extern "C" const char * fl_printer_get_dialog_copies(); +extern "C" void fl_printer_set_dialog_copies(const char * v); +extern "C" const char * fl_printer_get_dialog_all(); +extern "C" void fl_printer_set_dialog_all(const char * v); +extern "C" const char * fl_printer_get_dialog_pages(); +extern "C" void fl_printer_set_dialog_pages(const char * v); +extern "C" const char * fl_printer_get_dialog_from(); +extern "C" void fl_printer_set_dialog_from(const char * v); +extern "C" const char * fl_printer_get_dialog_to(); +extern "C" void fl_printer_set_dialog_to(const char * v); +extern "C" const char * fl_printer_get_dialog_properties(); +extern "C" void fl_printer_set_dialog_properties(const char * v); +extern "C" const char * fl_printer_get_dialog_copyno(); +extern "C" void fl_printer_set_dialog_copyno(const char * v); +extern "C" const char * fl_printer_get_dialog_print_button(); +extern "C" void fl_printer_set_dialog_print_button(const char * v); +extern "C" const char * fl_printer_get_dialog_cancel_button(); +extern "C" void fl_printer_set_dialog_cancel_button(const char * v); +extern "C" const char * fl_printer_get_dialog_print_to_file(); +extern "C" void fl_printer_set_dialog_print_to_file(const char * v); +extern "C" const char * fl_printer_get_property_title(); +extern "C" void fl_printer_set_property_title(const char * v); +extern "C" const char * fl_printer_get_property_pagesize(); +extern "C" void fl_printer_set_property_pagesize(const char * v); +extern "C" const char * fl_printer_get_property_mode(); +extern "C" void fl_printer_set_property_mode(const char * v); +extern "C" const char * fl_printer_get_property_use(); +extern "C" void fl_printer_set_property_use(const char * v); +extern "C" const char * fl_printer_get_property_save(); +extern "C" void fl_printer_set_property_save(const char * v); +extern "C" const char * fl_printer_get_property_cancel(); +extern "C" void fl_printer_set_property_cancel(const char * v); + + +extern "C" int fl_printer_start_job(PRINTER p, int c); +extern "C" int fl_printer_start_job2(PRINTER p, int c, int * f, int * t); +extern "C" void fl_printer_end_job(PRINTER p); +extern "C" int fl_printer_start_page(PRINTER p); +extern "C" int fl_printer_end_page(PRINTER p); + + +extern "C" void fl_printer_margins(PRINTER p, int * l, int * t, int * r, int * b); +extern "C" int fl_printer_printable_rect(PRINTER p, int * w, int * h); +extern "C" void fl_printer_get_origin(PRINTER p, int * x, int * y); +extern "C" void fl_printer_set_origin(PRINTER p, int x, int y); +extern "C" void fl_printer_rotate(PRINTER p, float r); +extern "C" void fl_printer_scale(PRINTER p, float x, float y); +extern "C" void fl_printer_translate(PRINTER p, int x, int y); +extern "C" void fl_printer_untranslate(PRINTER p); + + +extern "C" void fl_printer_print_widget(PRINTER p, void * i, int dx, int dy); +extern "C" void fl_printer_print_window_part(PRINTER p, void * i, int x, int y, + int w, int h, int dx, int dy); + + +extern "C" void fl_printer_set_current(PRINTER p); + + +#endif + + diff --git a/body/c_fl_progress.cpp b/body/c_fl_progress.cpp new file mode 100644 index 0000000..7b13a48 --- /dev/null +++ b/body/c_fl_progress.cpp @@ -0,0 +1,99 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Progress.H> +#include "c_fl_progress.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Progress : public Fl_Progress { +public: + using Fl_Progress::Fl_Progress; + + friend void fl_progress_draw(PROGRESS p); + friend int fl_progress_handle(PROGRESS p, int e); + + void draw(); + int handle(int e); +}; + +void My_Progress::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Progress::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +PROGRESS new_fl_progress(int x, int y, int w, int h, char* label) { + My_Progress *p = new My_Progress(x, y, w, h, label); + return p; +} + +void free_fl_progress(PROGRESS p) { + if (fl_inside_callback) { + fl_delete_widget(p); + } else { + delete static_cast<My_Progress*>(p); + } +} + + + + +float fl_progress_get_minimum(PROGRESS p) { + return static_cast<Fl_Progress*>(p)->minimum(); +} + +void fl_progress_set_minimum(PROGRESS p, float t) { + static_cast<Fl_Progress*>(p)->minimum(t); +} + +float fl_progress_get_maximum(PROGRESS p) { + return static_cast<Fl_Progress*>(p)->maximum(); +} + +void fl_progress_set_maximum(PROGRESS p, float t) { + static_cast<Fl_Progress*>(p)->maximum(t); +} + +float fl_progress_get_value(PROGRESS p) { + return static_cast<Fl_Progress*>(p)->value(); +} + +void fl_progress_set_value(PROGRESS p, float t) { + static_cast<Fl_Progress*>(p)->value(t); +} + + + + +void fl_progress_draw(PROGRESS p) { + static_cast<My_Progress*>(p)->Fl_Progress::draw(); +} + +int fl_progress_handle(PROGRESS p, int e) { + return static_cast<My_Progress*>(p)->Fl_Progress::handle(e); +} + + diff --git a/body/c_fl_progress.h b/body/c_fl_progress.h new file mode 100644 index 0000000..d75e136 --- /dev/null +++ b/body/c_fl_progress.h @@ -0,0 +1,32 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_PROGRESS_GUARD +#define FL_PROGRESS_GUARD + + +typedef void* PROGRESS; + + +extern "C" PROGRESS new_fl_progress(int x, int y, int w, int h, char* label); +extern "C" void free_fl_progress(PROGRESS p); + + +extern "C" float fl_progress_get_minimum(PROGRESS p); +extern "C" void fl_progress_set_minimum(PROGRESS p, float t); +extern "C" float fl_progress_get_maximum(PROGRESS p); +extern "C" void fl_progress_set_maximum(PROGRESS p, float t); +extern "C" float fl_progress_get_value(PROGRESS p); +extern "C" void fl_progress_set_value(PROGRESS p, float t); + + +extern "C" void fl_progress_draw(PROGRESS p); +extern "C" int fl_progress_handle(PROGRESS p, int e); + + +#endif + + diff --git a/body/c_fl_radio_button.cpp b/body/c_fl_radio_button.cpp new file mode 100644 index 0000000..40c8fd5 --- /dev/null +++ b/body/c_fl_radio_button.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Radio_Button.H> +#include "c_fl_radio_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Radio_Button : public Fl_Radio_Button { +public: + using Fl_Radio_Button::Fl_Radio_Button; + + friend void fl_radio_button_draw(RADIOBUTTON b); + friend int fl_radio_button_handle(RADIOBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Radio_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Radio_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +RADIOBUTTON new_fl_radio_button(int x, int y, int w, int h, char* label) { + My_Radio_Button *b = new My_Radio_Button(x, y, w, h, label); + return b; +} + +void free_fl_radio_button(RADIOBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Radio_Button*>(b); + } +} + + + + +void fl_radio_button_draw(RADIOBUTTON b) { + static_cast<My_Radio_Button*>(b)->Fl_Radio_Button::draw(); +} + +int fl_radio_button_handle(RADIOBUTTON b, int e) { + return static_cast<My_Radio_Button*>(b)->Fl_Radio_Button::handle(e); +} + + diff --git a/body/c_fl_radio_button.h b/body/c_fl_radio_button.h new file mode 100644 index 0000000..53bdd57 --- /dev/null +++ b/body/c_fl_radio_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_RADIO_BUTTON_GUARD +#define FL_RADIO_BUTTON_GUARD + + +typedef void* RADIOBUTTON; + + +extern "C" RADIOBUTTON new_fl_radio_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_radio_button(RADIOBUTTON b); + + +extern "C" void fl_radio_button_draw(RADIOBUTTON b); +extern "C" int fl_radio_button_handle(RADIOBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_radio_light_button.cpp b/body/c_fl_radio_light_button.cpp new file mode 100644 index 0000000..ce57982 --- /dev/null +++ b/body/c_fl_radio_light_button.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Radio_Light_Button.H> +#include "c_fl_radio_light_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Radio_Light_Button : public Fl_Radio_Light_Button { +public: + using Fl_Radio_Light_Button::Fl_Radio_Light_Button; + + friend void fl_radio_light_button_draw(RADIOLIGHTBUTTON b); + friend int fl_radio_light_button_handle(RADIOLIGHTBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Radio_Light_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Radio_Light_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +RADIOLIGHTBUTTON new_fl_radio_light_button(int x, int y, int w, int h, char* label) { + My_Radio_Light_Button *b = new My_Radio_Light_Button(x, y, w, h, label); + return b; +} + +void free_fl_radio_light_button(RADIOLIGHTBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Radio_Light_Button*>(b); + } +} + + + + +void fl_radio_light_button_draw(RADIOLIGHTBUTTON b) { + static_cast<My_Radio_Light_Button*>(b)->Fl_Radio_Light_Button::draw(); +} + +int fl_radio_light_button_handle(RADIOLIGHTBUTTON b, int e) { + return static_cast<My_Radio_Light_Button*>(b)->Fl_Radio_Light_Button::handle(e); +} + + diff --git a/body/c_fl_radio_light_button.h b/body/c_fl_radio_light_button.h new file mode 100644 index 0000000..217bd69 --- /dev/null +++ b/body/c_fl_radio_light_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_RADIO_LIGHT_BUTTON_GUARD +#define FL_RADIO_LIGHT_BUTTON_GUARD + + +typedef void* RADIOLIGHTBUTTON; + + +extern "C" RADIOLIGHTBUTTON new_fl_radio_light_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_radio_light_button(RADIOLIGHTBUTTON b); + + +extern "C" void fl_radio_light_button_draw(RADIOLIGHTBUTTON b); +extern "C" int fl_radio_light_button_handle(RADIOLIGHTBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_radio_round_button.cpp b/body/c_fl_radio_round_button.cpp new file mode 100644 index 0000000..62dc8e5 --- /dev/null +++ b/body/c_fl_radio_round_button.cpp @@ -0,0 +1,73 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Radio_Round_Button.H> +#include "c_fl_radio_round_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Radio_Round_Button : public Fl_Radio_Round_Button { +public: + using Fl_Radio_Round_Button::Fl_Radio_Round_Button; + + friend void fl_radio_round_button_draw(RADIOROUNDBUTTON b); + friend int fl_radio_round_button_handle(RADIOROUNDBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Radio_Round_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Radio_Round_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +RADIOROUNDBUTTON new_fl_radio_round_button(int x, int y, int w, int h, char* label) { + My_Radio_Round_Button *b = new My_Radio_Round_Button(x, y, w, h, label); + return b; +} + +void free_fl_radio_round_button(RADIOROUNDBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Radio_Round_Button*>(b); + } +} + + + + + +void fl_radio_round_button_draw(RADIOROUNDBUTTON b) { + static_cast<My_Radio_Round_Button*>(b)->Fl_Radio_Round_Button::draw(); +} + +int fl_radio_round_button_handle(RADIOROUNDBUTTON b, int e) { + return static_cast<My_Radio_Round_Button*>(b)->Fl_Radio_Round_Button::handle(e); +} + + diff --git a/body/c_fl_radio_round_button.h b/body/c_fl_radio_round_button.h new file mode 100644 index 0000000..bea7076 --- /dev/null +++ b/body/c_fl_radio_round_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_RADIO_ROUND_BUTTON_GUARD +#define FL_RADIO_ROUND_BUTTON_GUARD + + +typedef void* RADIOROUNDBUTTON; + + +extern "C" RADIOROUNDBUTTON new_fl_radio_round_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_radio_round_button(RADIOROUNDBUTTON b); + + +extern "C" void fl_radio_round_button_draw(RADIOROUNDBUTTON b); +extern "C" int fl_radio_round_button_handle(RADIOROUNDBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_repeat_button.cpp b/body/c_fl_repeat_button.cpp new file mode 100644 index 0000000..562a72d --- /dev/null +++ b/body/c_fl_repeat_button.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Repeat_Button.H> +#include "c_fl_repeat_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Repeat_Button : public Fl_Repeat_Button { +public: + using Fl_Repeat_Button::Fl_Repeat_Button; + + friend void fl_repeat_button_draw(REPEATBUTTON b); + friend int fl_repeat_button_handle(REPEATBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Repeat_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Repeat_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +REPEATBUTTON new_fl_repeat_button(int x, int y, int w, int h, char* label) { + My_Repeat_Button *b = new My_Repeat_Button(x, y, w, h, label); + return b; +} + +void free_fl_repeat_button(REPEATBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Repeat_Button*>(b); + } +} + + + + +void fl_repeat_button_deactivate(REPEATBUTTON b) { + static_cast<Fl_Repeat_Button*>(b)->deactivate(); +} + + + + +void fl_repeat_button_draw(REPEATBUTTON b) { + static_cast<My_Repeat_Button*>(b)->Fl_Repeat_Button::draw(); +} + +int fl_repeat_button_handle(REPEATBUTTON b, int e) { + return static_cast<My_Repeat_Button*>(b)->Fl_Repeat_Button::handle(e); +} + + diff --git a/body/c_fl_repeat_button.h b/body/c_fl_repeat_button.h new file mode 100644 index 0000000..5750a60 --- /dev/null +++ b/body/c_fl_repeat_button.h @@ -0,0 +1,27 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_REPEAT_BUTTON_GUARD +#define FL_REPEAT_BUTTON_GUARD + + +typedef void* REPEATBUTTON; + + +extern "C" REPEATBUTTON new_fl_repeat_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_repeat_button(REPEATBUTTON b); + + +extern "C" void fl_repeat_button_deactivate(REPEATBUTTON b); + + +extern "C" void fl_repeat_button_draw(REPEATBUTTON b); +extern "C" int fl_repeat_button_handle(REPEATBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_return_button.cpp b/body/c_fl_return_button.cpp new file mode 100644 index 0000000..3211b7f --- /dev/null +++ b/body/c_fl_return_button.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Return_Button.H> +#include "c_fl_return_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Return_Button : public Fl_Return_Button { +public: + using Fl_Return_Button::Fl_Return_Button; + + friend void fl_return_button_draw(RETURNBUTTON b); + friend int fl_return_button_handle(RETURNBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Return_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Return_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +RETURNBUTTON new_fl_return_button(int x, int y, int w, int h, char* label) { + My_Return_Button *b = new My_Return_Button(x, y, w, h, label); + return b; +} + +void free_fl_return_button(RETURNBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Return_Button*>(b); + } +} + + + + +void fl_return_button_draw(RETURNBUTTON b) { + static_cast<My_Return_Button*>(b)->Fl_Return_Button::draw(); +} + +int fl_return_button_handle(RETURNBUTTON b, int e) { + return static_cast<My_Return_Button*>(b)->Fl_Return_Button::handle(e); +} + + diff --git a/body/c_fl_return_button.h b/body/c_fl_return_button.h new file mode 100644 index 0000000..c9f4d62 --- /dev/null +++ b/body/c_fl_return_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_RETURN_BUTTON_GUARD +#define FL_RETURN_BUTTON_GUARD + + +typedef void* RETURNBUTTON; + + +extern "C" RETURNBUTTON new_fl_return_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_return_button(RETURNBUTTON b); + + +extern "C" void fl_return_button_draw(RETURNBUTTON b); +extern "C" int fl_return_button_handle(RETURNBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_rgb_image.cpp b/body/c_fl_rgb_image.cpp new file mode 100644 index 0000000..fc39594 --- /dev/null +++ b/body/c_fl_rgb_image.cpp @@ -0,0 +1,85 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_RGB_Image.H> +#include <FL/Fl_Pixmap.H> +#include "c_fl_rgb_image.h" + + + + +RGBIMAGE new_fl_rgb_image(void *data, int w, int h, int d, int ld) { + Fl_RGB_Image *rgb = new Fl_RGB_Image(static_cast<uchar*>(data), w, h, d, ld); + return rgb; +} + +RGBIMAGE new_fl_rgb_image2(void *pix, unsigned int c) { + Fl_RGB_Image *rgb = new Fl_RGB_Image(static_cast<Fl_Pixmap*>(pix), c); + return rgb; +} + +void free_fl_rgb_image(RGBIMAGE i) { + delete static_cast<Fl_RGB_Image*>(i); +} + +size_t fl_rgb_image_get_max_size() { + return Fl_RGB_Image::max_size(); +} + +void fl_rgb_image_set_max_size(size_t v) { + Fl_RGB_Image::max_size(v); +} + +RGBIMAGE fl_rgb_image_copy(RGBIMAGE i, int w, int h) { + // virtual so disable dispatch + return static_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::copy(w, h); +} + +RGBIMAGE fl_rgb_image_copy2(RGBIMAGE i) { + return static_cast<Fl_RGB_Image*>(i)->copy(); +} + + + + +void fl_rgb_image_color_average(RGBIMAGE i, int c, float b) { + // virtual so disable dispatch + static_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::color_average(c, b); +} + +void fl_rgb_image_desaturate(RGBIMAGE i) { + // virtual so disable dispatch + static_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::desaturate(); +} + + + + +void fl_rgb_image_uncache(RGBIMAGE i) { + // virtual so disable dispatch + static_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::uncache(); +} + + + + +const void * fl_rgb_image_data(RGBIMAGE i) { + return static_cast<const void*>(static_cast<Fl_RGB_Image*>(i)->array); +} + + + + +void fl_rgb_image_draw2(RGBIMAGE i, int x, int y) { + static_cast<Fl_RGB_Image*>(i)->draw(x, y); +} + +void fl_rgb_image_draw(RGBIMAGE i, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + static_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::draw(x, y, w, h, cx, cy); +} + + diff --git a/body/c_fl_rgb_image.h b/body/c_fl_rgb_image.h new file mode 100644 index 0000000..2d42993 --- /dev/null +++ b/body/c_fl_rgb_image.h @@ -0,0 +1,39 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_RGB_IMAGE_GUARD +#define FL_RGB_IMAGE_GUARD + + +typedef void* RGBIMAGE; + + +extern "C" RGBIMAGE new_fl_rgb_image(void *data, int w, int h, int d, int ld); +extern "C" RGBIMAGE new_fl_rgb_image2(void *pix, unsigned int c); +extern "C" void free_fl_rgb_image(RGBIMAGE i); +extern "C" size_t fl_rgb_image_get_max_size(); +extern "C" void fl_rgb_image_set_max_size(size_t v); +extern "C" RGBIMAGE fl_rgb_image_copy(RGBIMAGE i, int w, int h); +extern "C" RGBIMAGE fl_rgb_image_copy2(RGBIMAGE i); + + +extern "C" void fl_rgb_image_color_average(RGBIMAGE i, int c, float b); +extern "C" void fl_rgb_image_desaturate(RGBIMAGE i); + + +extern "C" void fl_rgb_image_uncache(RGBIMAGE i); + + +extern "C" const void * fl_rgb_image_data(RGBIMAGE i); + + +extern "C" void fl_rgb_image_draw2(RGBIMAGE i, int x, int y); +extern "C" void fl_rgb_image_draw(RGBIMAGE i, int x, int y, int w, int h, int cx, int cy); + + +#endif + + diff --git a/body/c_fl_roller.cpp b/body/c_fl_roller.cpp new file mode 100644 index 0000000..9f6753c --- /dev/null +++ b/body/c_fl_roller.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Roller.H> +#include "c_fl_roller.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Roller : public Fl_Roller { +public: + using Fl_Roller::Fl_Roller; + + friend void fl_roller_draw(ROLLER r); + friend int fl_roller_handle(ROLLER r, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Roller::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Roller::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Roller::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +ROLLER new_fl_roller(int x, int y, int w, int h, char* label) { + My_Roller *r = new My_Roller(x, y, w, h, label); + return r; +} + +void free_fl_roller(ROLLER r) { + if (fl_inside_callback) { + fl_delete_widget(r); + } else { + delete static_cast<My_Roller*>(r); + } +} + + + + +void fl_roller_draw(ROLLER r) { + static_cast<My_Roller*>(r)->Fl_Roller::draw(); +} + +int fl_roller_handle(ROLLER r, int e) { + return static_cast<My_Roller*>(r)->Fl_Roller::handle(e); +} + + diff --git a/body/c_fl_roller.h b/body/c_fl_roller.h new file mode 100644 index 0000000..a864d71 --- /dev/null +++ b/body/c_fl_roller.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ROLLER_GUARD +#define FL_ROLLER_GUARD + + +typedef void* ROLLER; + + +extern "C" ROLLER new_fl_roller(int x, int y, int w, int h, char* label); +extern "C" void free_fl_roller(ROLLER r); + + +extern "C" void fl_roller_draw(ROLLER r); +extern "C" int fl_roller_handle(ROLLER r, int e); + + +#endif + + diff --git a/body/c_fl_round_button.cpp b/body/c_fl_round_button.cpp new file mode 100644 index 0000000..3c9550e --- /dev/null +++ b/body/c_fl_round_button.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Round_Button.H> +#include "c_fl_round_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Round_Button : public Fl_Round_Button { +public: + using Fl_Round_Button::Fl_Round_Button; + + friend void fl_round_button_draw(ROUNDBUTTON b); + friend int fl_round_button_handle(ROUNDBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Round_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Round_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +ROUNDBUTTON new_fl_round_button(int x, int y, int w, int h, char* label) { + My_Round_Button *b = new My_Round_Button(x, y, w, h, label); + return b; +} + +void free_fl_round_button(ROUNDBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Round_Button*>(b); + } +} + + + + +void fl_round_button_draw(ROUNDBUTTON b) { + static_cast<My_Round_Button*>(b)->Fl_Round_Button::draw(); +} + +int fl_round_button_handle(ROUNDBUTTON b, int e) { + return static_cast<My_Round_Button*>(b)->Fl_Round_Button::handle(e); +} + + diff --git a/body/c_fl_round_button.h b/body/c_fl_round_button.h new file mode 100644 index 0000000..cbbaf9f --- /dev/null +++ b/body/c_fl_round_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ROUND_BUTTON_GUARD +#define FL_ROUND_BUTTON_GUARD + + +typedef void* ROUNDBUTTON; + + +extern "C" ROUNDBUTTON new_fl_round_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_round_button(ROUNDBUTTON b); + + +extern "C" void fl_round_button_draw(ROUNDBUTTON b); +extern "C" int fl_round_button_handle(ROUNDBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_round_clock.cpp b/body/c_fl_round_clock.cpp new file mode 100644 index 0000000..85774c8 --- /dev/null +++ b/body/c_fl_round_clock.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Round_Clock.H> +#include "c_fl_round_clock.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Round_Clock : public Fl_Round_Clock { +public: + using Fl_Round_Clock::Fl_Round_Clock; + + friend void fl_round_clock_draw(ROUNDCLOCK c); + friend int fl_round_clock_handle(ROUNDCLOCK c, int e); + + void draw(); + int handle(int e); +}; + +void My_Round_Clock::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Round_Clock::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +ROUNDCLOCK new_fl_round_clock(int x, int y, int w, int h, char* label) { + My_Round_Clock *c = new My_Round_Clock(x, y, w, h, label); + return c; +} + +void free_fl_round_clock(ROUNDCLOCK c) { + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Round_Clock*>(c); + } +} + + + + +void fl_round_clock_draw(ROUNDCLOCK c) { + static_cast<My_Round_Clock*>(c)->Fl_Round_Clock::draw(); +} + +int fl_round_clock_handle(ROUNDCLOCK c, int e) { + return static_cast<My_Round_Clock*>(c)->Fl_Round_Clock::handle(e); +} + + diff --git a/body/c_fl_round_clock.h b/body/c_fl_round_clock.h new file mode 100644 index 0000000..475a5d0 --- /dev/null +++ b/body/c_fl_round_clock.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_ROUND_CLOCK_GUARD +#define FL_ROUND_CLOCK_GUARD + + +typedef void* ROUNDCLOCK; + + +extern "C" ROUNDCLOCK new_fl_round_clock(int x, int y, int w, int h, char* label); +extern "C" void free_fl_round_clock(ROUNDCLOCK c); + + +extern "C" void fl_round_clock_draw(ROUNDCLOCK c); +extern "C" int fl_round_clock_handle(ROUNDCLOCK c, int e); + + +#endif + + diff --git a/body/c_fl_screen.cpp b/body/c_fl_screen.cpp new file mode 100644 index 0000000..7a5fc2f --- /dev/null +++ b/body/c_fl_screen.cpp @@ -0,0 +1,124 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl.H> +#include "c_fl_screen.h" + + + + +const int fl_enum_mode_rgb = FL_RGB; +const int fl_enum_mode_rgb8 = FL_RGB8; +const int fl_enum_mode_double = FL_DOUBLE; +const int fl_enum_mode_index = FL_INDEX; + + + + +void fl_screen_display(const char * v) { + Fl::display(v); +} + +int fl_screen_visual(int mode) { + return Fl::visual(mode); +} + + + + +int fl_screen_x() { + return Fl::x(); +} + +int fl_screen_y() { + return Fl::y(); +} + +int fl_screen_w() { + return Fl::w(); +} + +int fl_screen_h() { + return Fl::h(); +} + + + + +int fl_screen_count() { + return Fl::screen_count(); +} + +void fl_screen_dpi(float &h, float &v, int n) { + Fl::screen_dpi(h, v, n); +} + + + + +int fl_screen_num(int x, int y) { + return Fl::screen_num(x, y); +} + + +int fl_screen_num2(int x, int y, int w, int h) { + return Fl::screen_num(x, y, w, h); +} + + + + +void fl_screen_work_area(int &x, int &y, int &w, int &h, int px, int py) { + Fl::screen_work_area(x, y, w, h, px, py); +} + +void fl_screen_work_area2(int &x, int &y, int &w, int &h, int n) { + Fl::screen_work_area(x, y, w, h, n); +} + +void fl_screen_work_area3(int &x, int &y, int &w, int &h) { + Fl::screen_work_area(x, y, w, h); +} + + + + +void fl_screen_xywh(int &x, int &y, int &w, int &h, int px, int py) { + Fl::screen_xywh(x, y, w, h, px, py); +} + +void fl_screen_xywh2(int &x, int &y, int &w, int &h, int n) { + Fl::screen_xywh(x, y, w, h, n); +} + +void fl_screen_xywh3(int &x, int &y, int &w, int &h) { + Fl::screen_xywh(x, y, w, h); +} + +void fl_screen_xywh4(int &x, int &y, int &w, int &h, int px, int py, int pw, int ph) { + Fl::screen_xywh(x, y, w, h, px, py, pw, ph); +} + + + + +int fl_screen_get_damage() { + return Fl::damage(); +} + +void fl_screen_set_damage(int v) { + Fl::damage(v); +} + +void fl_screen_flush() { + Fl::flush(); +} + +void fl_screen_redraw() { + Fl::redraw(); +} + + diff --git a/body/c_fl_screen.h b/body/c_fl_screen.h new file mode 100644 index 0000000..c2b0e98 --- /dev/null +++ b/body/c_fl_screen.h @@ -0,0 +1,54 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SCREEN_GUARD +#define FL_SCREEN_GUARD + + +extern "C" const int fl_enum_mode_rgb; +extern "C" const int fl_enum_mode_rgb8; +extern "C" const int fl_enum_mode_double; +extern "C" const int fl_enum_mode_index; + + +extern "C" void fl_screen_display(const char * v); +extern "C" int fl_screen_visual(int mode); + + +extern "C" int fl_screen_x(); +extern "C" int fl_screen_y(); +extern "C" int fl_screen_w(); +extern "C" int fl_screen_h(); + + +extern "C" int fl_screen_count(); +extern "C" void fl_screen_dpi(float &h, float &v, int n); + + +extern "C" int fl_screen_num(int x, int y); +extern "C" int fl_screen_num2(int x, int y, int w, int h); + + +extern "C" void fl_screen_work_area(int &x, int &y, int &w, int &h, int px, int py); +extern "C" void fl_screen_work_area2(int &x, int &y, int &w, int &h, int n); +extern "C" void fl_screen_work_area3(int &x, int &y, int &w, int &h); + + +extern "C" void fl_screen_xywh(int &x, int &y, int &w, int &h, int px, int py); +extern "C" void fl_screen_xywh2(int &x, int &y, int &w, int &h, int n); +extern "C" void fl_screen_xywh3(int &x, int &y, int &w, int &h); +extern "C" void fl_screen_xywh4(int &x, int &y, int &w, int &h, int px, int py, int pw, int ph); + + +extern "C" int fl_screen_get_damage(); +extern "C" void fl_screen_set_damage(int v); +extern "C" void fl_screen_flush(); +extern "C" void fl_screen_redraw(); + + +#endif + + diff --git a/body/c_fl_scroll.cpp b/body/c_fl_scroll.cpp new file mode 100644 index 0000000..325d8cf --- /dev/null +++ b/body/c_fl_scroll.cpp @@ -0,0 +1,206 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Scroll.H> +#include "c_fl_scroll.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void scroll_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); +void fl_scroll_extra_init(void * adaobj, int x, int y, int w, int h, const char * label) { + scroll_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Scroll : Fl_Scroll { +public: + using Fl_Scroll::bbox; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Scroll : public Fl_Scroll { +public: + using Fl_Scroll::Fl_Scroll; + + friend void fl_scroll_draw(SCROLL s); + friend int fl_scroll_handle(SCROLL s, int e); + + void draw(); + int handle(int e); +}; + +void My_Scroll::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Scroll::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SCROLL new_fl_scroll(int x, int y, int w, int h, char* label) { + My_Scroll *s = new My_Scroll(x, y, w, h, label); + return s; +} + +void free_fl_scroll(SCROLL s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Scroll*>(s); + } +} + + + + +void * fl_scroll_hscrollbar(SCROLL s) { + return &static_cast<Fl_Scroll*>(s)->hscrollbar; +} + +void * fl_scroll_scrollbar(SCROLL s) { + return &static_cast<Fl_Scroll*>(s)->scrollbar; +} + + + + +void fl_scroll_to(SCROLL s, int x, int y) { + static_cast<Fl_Scroll*>(s)->scroll_to(x, y); +} + +int fl_scroll_xposition(SCROLL s) { + return static_cast<Fl_Scroll*>(s)->xposition(); +} + +int fl_scroll_yposition(SCROLL s) { + return static_cast<Fl_Scroll*>(s)->yposition(); +} + + + + +int fl_scroll_get_size(SCROLL s) { + return static_cast<Fl_Scroll*>(s)->scrollbar_size(); +} + +void fl_scroll_set_size(SCROLL s, int t) { + static_cast<Fl_Scroll*>(s)->scrollbar_size(t); +} + + + + +void fl_scroll_resize(SCROLL s, int x, int y, int w, int h) { + static_cast<Fl_Scroll*>(s)->resize(x, y, w, h); +} + +void fl_scroll_recalc_scrollbars(SCROLL s, + int &cb_x, int &cb_y, int &cb_w, int &cb_h, + int &ib_x, int &ib_y, int &ib_w, int &ib_h, + int &ic_x, int &ic_y, int &ic_w, int &ic_h, + int &chneed, int &cvneed, + int &hs_x, int &hs_y, int &hs_w, int &hs_h, + int &hs_size, int &hs_total, int &hs_first, int &hs_pos, + int &vs_x, int &vs_y, int &vs_w, int &vs_h, + int &vs_size, int &vs_total, int &vs_first, int &vs_pos, + int &ssize) +{ +#if FLTK_ABI_VERSION >= 10303 + Fl_Scroll::ScrollInfo my_info; + static_cast<Fl_Scroll*>(s)->recalc_scrollbars(my_info); + + cb_x = my_info.child.l; + cb_y = my_info.child.t; + cb_w = my_info.child.r - my_info.child.l; + cb_h = my_info.child.b - my_info.child.t; + + ib_x = my_info.innerbox.x; + ib_y = my_info.innerbox.y; + ib_w = my_info.innerbox.w; + ib_h = my_info.innerbox.h; + + ic_x = my_info.innerchild.x; + ic_y = my_info.innerchild.y; + ic_w = my_info.innerchild.w; + ic_h = my_info.innerchild.h; + + chneed = my_info.hneeded; + cvneed = my_info.vneeded; + + hs_x = my_info.hscroll.x; + hs_y = my_info.hscroll.y; + hs_w = my_info.hscroll.w; + hs_h = my_info.hscroll.h; + hs_size = my_info.hscroll.size; + hs_total = my_info.hscroll.total; + hs_first = my_info.hscroll.first; + hs_pos = my_info.hscroll.pos; + + vs_x = my_info.vscroll.x; + vs_y = my_info.vscroll.y; + vs_w = my_info.vscroll.w; + vs_h = my_info.vscroll.h; + vs_size = my_info.vscroll.size; + vs_total = my_info.vscroll.total; + vs_first = my_info.vscroll.first; + vs_pos = my_info.vscroll.pos; + + ssize = my_info.scrollsize; +#else + (void)(s); + (void)(cb_x); (void)(cb_y); (void)(cb_w); (void)(cb_h); + (void)(ib_x); (void)(ib_y); (void)(ib_w); (void)(ib_h); + (void)(ic_x); (void)(ic_y); (void)(ic_w); (void)(ic_h); + (void)(chneed); (void)(cvneed); + (void)(hs_x); (void)(hs_y); (void)(hs_w); (void)(hs_h); + (void)(hs_size); (void)(hs_total); (void)(hs_first); (void)(hs_pos); + (void)(vs_x); (void)(vs_y); (void)(vs_w); (void)(vs_h); + (void)(vs_size); (void)(vs_total); (void)(vs_first); (void)(vs_pos); + (void)(ssize); +#endif +} + + + + +void fl_scroll_bbox(SCROLL s, int &x, int &y, int &w, int &h) { + (static_cast<Fl_Scroll*>(s)->*(&Friend_Scroll::bbox))(x, y, w, h); +} + +void fl_scroll_draw(SCROLL s) { + static_cast<My_Scroll*>(s)->Fl_Scroll::draw(); +} + +int fl_scroll_handle(SCROLL s, int e) { + return static_cast<My_Scroll*>(s)->Fl_Scroll::handle(e); +} + + diff --git a/body/c_fl_scroll.h b/body/c_fl_scroll.h new file mode 100644 index 0000000..e39e469 --- /dev/null +++ b/body/c_fl_scroll.h @@ -0,0 +1,54 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SCROLL_GUARD +#define FL_SCROLL_GUARD + + +extern "C" void fl_scroll_extra_init(void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* SCROLL; + + +extern "C" SCROLL new_fl_scroll(int x, int y, int w, int h, char* label); +extern "C" void free_fl_scroll(SCROLL s); + + +extern "C" void * fl_scroll_hscrollbar(SCROLL s); +extern "C" void * fl_scroll_scrollbar(SCROLL s); + + +extern "C" void fl_scroll_to(SCROLL s, int x, int y); +extern "C" int fl_scroll_xposition(SCROLL s); +extern "C" int fl_scroll_yposition(SCROLL s); + + +extern "C" int fl_scroll_get_size(SCROLL s); +extern "C" void fl_scroll_set_size(SCROLL s, int t); + + +extern "C" void fl_scroll_resize(SCROLL s, int x, int y, int w, int h); +extern "C" void fl_scroll_recalc_scrollbars(SCROLL s, + int &cb_x, int &cb_y, int &cb_w, int &cb_h, + int &ib_x, int &ib_y, int &ib_w, int &ib_h, + int &ic_x, int &ic_y, int &ic_w, int &ic_h, + int &chneed, int &cvneed, + int &hs_x, int &hs_y, int &hs_w, int &hs_h, + int &hs_size, int &hs_total, int &hs_first, int &hs_pos, + int &vs_x, int &vs_y, int &vs_w, int &vs_h, + int &vs_size, int &vs_total, int &vs_first, int &vs_pos, + int &ssize); + + +extern "C" void fl_scroll_bbox(SCROLL s, int &x, int &y, int &w, int &h); +extern "C" void fl_scroll_draw(SCROLL s); +extern "C" int fl_scroll_handle(SCROLL s, int e); + + +#endif + + diff --git a/body/c_fl_scrollbar.cpp b/body/c_fl_scrollbar.cpp new file mode 100644 index 0000000..bf5ceaa --- /dev/null +++ b/body/c_fl_scrollbar.cpp @@ -0,0 +1,112 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Scrollbar.H> +#include "c_fl_scrollbar.h" +#include "c_fl.h" + + + + +// Telprot stopover + +extern "C" void scrollbar_extra_init_hook(void * aobj, int x, int y, int w, int h, const char * l); +void fl_scrollbar_extra_init (void * adaobj, int x, int y, int w, int h, const char * label) { + scrollbar_extra_init_hook(adaobj, x, y, w, h, label); +} + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Scrollbar : public Fl_Scrollbar { +public: + using Fl_Scrollbar::Fl_Scrollbar; + + friend void fl_scrollbar_draw(SCROLLBAR s); + friend int fl_scrollbar_handle(SCROLLBAR s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Scrollbar::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Scrollbar::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Scrollbar::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SCROLLBAR new_fl_scrollbar(int x, int y, int w, int h, char* label) { + My_Scrollbar *s = new My_Scrollbar(x, y, w, h, label); + return s; +} + +void free_fl_scrollbar(SCROLLBAR s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Scrollbar*>(s); + } +} + + + + +int fl_scrollbar_get_linesize(SCROLLBAR s) { + return static_cast<Fl_Scrollbar*>(s)->linesize(); +} + +void fl_scrollbar_set_linesize(SCROLLBAR s, int t) { + static_cast<Fl_Scrollbar*>(s)->linesize(t); +} + +int fl_scrollbar_get_value(SCROLLBAR s) { + return static_cast<Fl_Scrollbar*>(s)->value(); +} + +void fl_scrollbar_set_value(SCROLLBAR s, int t) { + static_cast<Fl_Scrollbar*>(s)->value(t); +} + +void fl_scrollbar_set_value2(SCROLLBAR s, int p, int w, int f, int t) { + static_cast<Fl_Scrollbar*>(s)->value(p,w,f,t); +} + + + + +void fl_scrollbar_draw(SCROLLBAR s) { + static_cast<My_Scrollbar*>(s)->Fl_Scrollbar::draw(); +} + +int fl_scrollbar_handle(SCROLLBAR s, int e) { + return static_cast<My_Scrollbar*>(s)->Fl_Scrollbar::handle(e); +} + + diff --git a/body/c_fl_scrollbar.h b/body/c_fl_scrollbar.h new file mode 100644 index 0000000..6dd599d --- /dev/null +++ b/body/c_fl_scrollbar.h @@ -0,0 +1,35 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SCROLLBAR_GUARD +#define FL_SCROLLBAR_GUARD + + +extern "C" void fl_scrollbar_extra_init + (void * adaobj, int x, int y, int w, int h, const char * label); + + +typedef void* SCROLLBAR; + + +extern "C" SCROLLBAR new_fl_scrollbar(int x, int y, int w, int h, char* label); +extern "C" void free_fl_scrollbar(SCROLLBAR s); + + +extern "C" int fl_scrollbar_get_linesize(SCROLLBAR s); +extern "C" void fl_scrollbar_set_linesize(SCROLLBAR s, int t); +extern "C" int fl_scrollbar_get_value(SCROLLBAR s); +extern "C" void fl_scrollbar_set_value(SCROLLBAR s, int t); +extern "C" void fl_scrollbar_set_value2(SCROLLBAR s, int p, int w, int f, int t); + + +extern "C" void fl_scrollbar_draw(SCROLLBAR s); +extern "C" int fl_scrollbar_handle(SCROLLBAR s, int e); + + +#endif + + diff --git a/body/c_fl_secret_input.cpp b/body/c_fl_secret_input.cpp new file mode 100644 index 0000000..4ef4720 --- /dev/null +++ b/body/c_fl_secret_input.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Secret_Input.H> +#include "c_fl_secret_input.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Secret_Input : public Fl_Secret_Input { +public: + using Fl_Secret_Input::Fl_Secret_Input; + + friend void fl_secret_input_draw(SECRETINPUT i); + friend int fl_secret_input_handle(SECRETINPUT i, int e); + + void draw(); + int handle(int e); +}; + +void My_Secret_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Secret_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SECRETINPUT new_fl_secret_input(int x, int y, int w, int h, char* label) { + My_Secret_Input *i = new My_Secret_Input(x, y, w, h, label); + return i; +} + +void free_fl_secret_input(SECRETINPUT i) { + if (fl_inside_callback) { + fl_delete_widget(i); + } else { + delete static_cast<My_Secret_Input*>(i); + } +} + + + + +void fl_secret_input_draw(SECRETINPUT i) { + static_cast<My_Secret_Input*>(i)->Fl_Secret_Input::draw(); +} + +int fl_secret_input_handle(SECRETINPUT i, int e) { + return static_cast<My_Secret_Input*>(i)->Fl_Secret_Input::handle(e); +} + + diff --git a/body/c_fl_secret_input.h b/body/c_fl_secret_input.h new file mode 100644 index 0000000..ea171d8 --- /dev/null +++ b/body/c_fl_secret_input.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SECRET_INPUT_GUARD +#define FL_SECRET_INPUT_GUARD + + +typedef void* SECRETINPUT; + + +extern "C" SECRETINPUT new_fl_secret_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_secret_input(SECRETINPUT i); + + +extern "C" void fl_secret_input_draw(SECRETINPUT i); +extern "C" int fl_secret_input_handle(SECRETINPUT i, int e); + + +#endif + + diff --git a/body/c_fl_select_browser.cpp b/body/c_fl_select_browser.cpp new file mode 100644 index 0000000..a0173fc --- /dev/null +++ b/body/c_fl_select_browser.cpp @@ -0,0 +1,269 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Select_Browser.H> +#include "c_fl_select_browser.h" +#include "c_fl.h" + + + + +// 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_Select_Browser : public Fl_Select_Browser { +public: + using Fl_Select_Browser::Fl_Select_Browser; + + friend int fl_select_browser_item_width(SELECTBROWSER b, void * item); + friend int fl_select_browser_item_height(SELECTBROWSER b, void * item); + friend void * fl_select_browser_item_first(SELECTBROWSER b); + friend void * fl_select_browser_item_last(SELECTBROWSER b); + friend void * fl_select_browser_item_next(SELECTBROWSER b, void * item); + friend void * fl_select_browser_item_prev(SELECTBROWSER b, void * item); + friend void * fl_select_browser_item_at(SELECTBROWSER b, int index); + friend void fl_select_browser_item_select(SELECTBROWSER b, void * item, int val); + friend int fl_select_browser_item_selected(SELECTBROWSER b, void * item); + friend void fl_select_browser_item_swap(SELECTBROWSER b, void * x, void * y); + friend const char * fl_select_browser_item_text(SELECTBROWSER b, void * item); + friend void fl_select_browser_item_draw(SELECTBROWSER b, void * item, int x, int y, int w, int h); + + friend int fl_select_browser_full_width(SELECTBROWSER c); + friend int fl_select_browser_full_height(SELECTBROWSER c); + friend int fl_select_browser_incr_height(SELECTBROWSER c); + friend int fl_select_browser_item_quick_height(SELECTBROWSER c, void * i); + + friend void fl_select_browser_draw(SELECTBROWSER b); + + int handle(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 My_Select_Browser::full_width() const { + return browser_full_width_hook(this->user_data()); +} + +int My_Select_Browser::full_height() const { + return browser_full_height_hook(this->user_data()); +} + +int My_Select_Browser::incr_height() const { + return browser_incr_height_hook(this->user_data()); +} + +int My_Select_Browser::item_quick_height(void * item) const { + return browser_item_quick_height_hook(this->user_data(), item); +} + + +int My_Select_Browser::item_width(void * item) const { + return browser_item_width_hook(this->user_data(), item); +} + +int My_Select_Browser::item_height(void * item) const { + return browser_item_height_hook(this->user_data(), item); +} + +void * My_Select_Browser::item_first() const { + return browser_item_first_hook(this->user_data()); +} + +void * My_Select_Browser::item_last() const { + return browser_item_last_hook(this->user_data()); +} + +void * My_Select_Browser::item_next(void * item) const { + return browser_item_next_hook(this->user_data(), item); +} + +void * My_Select_Browser::item_prev(void * item) const { + return browser_item_prev_hook(this->user_data(), item); +} + +void * My_Select_Browser::item_at(int index) const { + return browser_item_at_hook(this->user_data(), index); +} + +void My_Select_Browser::item_select(void * item, int val) { + browser_item_select_hook(this->user_data(), item, val); +} + +int My_Select_Browser::item_selected(void * item) const { + return browser_item_selected_hook(this->user_data(), item); +} + +void My_Select_Browser::item_swap(void * a, void * b) { + browser_item_swap_hook(this->user_data(), a, b); +} + +const char * My_Select_Browser::item_text(void * item) const { + return browser_item_text_hook(this->user_data(), item); +} + +void My_Select_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_Select_Browser::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Select_Browser::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API begins here + +SELECTBROWSER new_fl_select_browser(int x, int y, int w, int h, char * label) { + My_Select_Browser *b = new My_Select_Browser(x, y, w, h, label); + return b; +} + +void free_fl_select_browser(SELECTBROWSER b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Select_Browser*>(b); + } +} + + + + +// These have to be reimplemented due to relying on custom class extensions + +int fl_select_browser_full_height(SELECTBROWSER c) { + return static_cast<My_Select_Browser*>(c)->Fl_Select_Browser::full_height(); +} + +int fl_select_browser_incr_height(SELECTBROWSER c) { + return static_cast<My_Select_Browser*>(c)->Fl_Select_Browser::incr_height(); +} + + + + +int fl_select_browser_item_width(SELECTBROWSER b, void * item) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_width(item); +} + +int fl_select_browser_item_height(SELECTBROWSER b, void * item) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_height(item); +} + +void * fl_select_browser_item_first(SELECTBROWSER b) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_first(); +} + +void * fl_select_browser_item_last(SELECTBROWSER b) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_last(); +} + +void * fl_select_browser_item_next(SELECTBROWSER b, void * item) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_next(item); +} + +void * fl_select_browser_item_prev(SELECTBROWSER b, void * item) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_prev(item); +} + +void * fl_select_browser_item_at(SELECTBROWSER b, int index) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_at(index); +} + +void fl_select_browser_item_select(SELECTBROWSER b, void * item, int val) { + static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_select(item, val); +} + +int fl_select_browser_item_selected(SELECTBROWSER b, void * item) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_selected(item); +} + +void fl_select_browser_item_swap(SELECTBROWSER b, void * x, void * y) { + static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_swap(x, y); +} + +const char * fl_select_browser_item_text(SELECTBROWSER b, void * item) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_text(item); +} + +void fl_select_browser_item_draw(SELECTBROWSER b, void * item, int x, int y, int w, int h) { + static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::item_draw(item, x, y, w, h); +} + + + + +int fl_select_browser_full_width(SELECTBROWSER c) { + return static_cast<My_Select_Browser*>(c)->Fl_Select_Browser::full_width(); +} + +int fl_select_browser_item_quick_height(SELECTBROWSER c, void * i) { + return static_cast<My_Select_Browser*>(c)->Fl_Select_Browser::item_quick_height(i); +} + + + + +void fl_select_browser_draw(SELECTBROWSER b) { + static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::draw(); +} + +int fl_select_browser_handle(SELECTBROWSER b, int e) { + return static_cast<My_Select_Browser*>(b)->Fl_Select_Browser::handle(e); +} + + diff --git a/body/c_fl_select_browser.h b/body/c_fl_select_browser.h new file mode 100644 index 0000000..f72b8de --- /dev/null +++ b/body/c_fl_select_browser.h @@ -0,0 +1,48 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SELECT_BROWSER_GUARD +#define FL_SELECT_BROWSER_GUARD + + +typedef void* SELECTBROWSER; + + +extern "C" SELECTBROWSER new_fl_select_browser(int x, int y, int w, int h, char * label); +extern "C" void free_fl_select_browser(SELECTBROWSER b); + + +// reimp below here + +extern "C" int fl_select_browser_full_height(SELECTBROWSER c); +extern "C" int fl_select_browser_incr_height(SELECTBROWSER c); + + +extern "C" int fl_select_browser_item_width(SELECTBROWSER b, void * item); +extern "C" int fl_select_browser_item_height(SELECTBROWSER b, void * item); +extern "C" void * fl_select_browser_item_first(SELECTBROWSER b); +extern "C" void * fl_select_browser_item_last(SELECTBROWSER b); +extern "C" void * fl_select_browser_item_next(SELECTBROWSER b, void * item); +extern "C" void * fl_select_browser_item_prev(SELECTBROWSER b, void * item); +extern "C" void * fl_select_browser_item_at(SELECTBROWSER b, int index); +extern "C" void fl_select_browser_item_select(SELECTBROWSER b, void * item, int val=1); +extern "C" int fl_select_browser_item_selected(SELECTBROWSER b, void * item); +extern "C" void fl_select_browser_item_swap(SELECTBROWSER b, void * x, void * y); +extern "C" const char * fl_select_browser_item_text(SELECTBROWSER b, void * item); +extern "C" void fl_select_browser_item_draw(SELECTBROWSER b, void * item, int x, int y, int w, int h); + + +extern "C" int fl_select_browser_full_width(SELECTBROWSER c); +extern "C" int fl_select_browser_item_quick_height(SELECTBROWSER c, void * i); + + +extern "C" void fl_select_browser_draw(SELECTBROWSER b); +extern "C" int fl_select_browser_handle(SELECTBROWSER b, int e); + + +#endif + + diff --git a/body/c_fl_shared_image.cpp b/body/c_fl_shared_image.cpp new file mode 100644 index 0000000..bb17632 --- /dev/null +++ b/body/c_fl_shared_image.cpp @@ -0,0 +1,100 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Shared_Image.H> +#include <FL/Fl_RGB_Image.H> +#include "c_fl_shared_image.h" + + + + +SHAREDIMAGE fl_shared_image_get(const char * f, int w, int h) { + return Fl_Shared_Image::get(f, w, h); +} + +SHAREDIMAGE fl_shared_image_get2(void * r) { + return Fl_Shared_Image::get(static_cast<Fl_RGB_Image*>(r), 0); +} + +SHAREDIMAGE fl_shared_image_find(const char * n, int w, int h) { + return Fl_Shared_Image::find(n, w, h); +} + +void fl_shared_image_release(SHAREDIMAGE i) { + static_cast<Fl_Shared_Image*>(i)->release(); +} + +SHAREDIMAGE fl_shared_image_copy(SHAREDIMAGE i, int w, int h) { + // virtual so disable dispatch + return static_cast<Fl_Shared_Image*>(i)->Fl_Shared_Image::copy(w, h); +} + +SHAREDIMAGE fl_shared_image_copy2(SHAREDIMAGE i) { + return static_cast<Fl_Shared_Image*>(i)->copy(); +} + + + + +void fl_shared_image_color_average(SHAREDIMAGE i, int c, float b) { + // virtual so disable dispatch + static_cast<Fl_Shared_Image*>(i)->Fl_Shared_Image::color_average(c, b); +} + +void fl_shared_image_desaturate(SHAREDIMAGE i) { + // virtual so disable dispatch + static_cast<Fl_Shared_Image*>(i)->Fl_Shared_Image::desaturate(); +} + + + + +int fl_shared_image_num_images() { + return Fl_Shared_Image::num_images(); +} + +const char * fl_shared_image_name(SHAREDIMAGE i) { + return static_cast<Fl_Shared_Image*>(i)->name(); +} + +int fl_shared_image_original(SHAREDIMAGE i) { + return static_cast<Fl_Shared_Image*>(i)->original(); +} + +int fl_shared_image_refcount(SHAREDIMAGE i) { + return static_cast<Fl_Shared_Image*>(i)->refcount(); +} + +void fl_shared_image_reload(SHAREDIMAGE i) { + static_cast<Fl_Shared_Image*>(i)->reload(); +} + +void fl_shared_image_uncache(SHAREDIMAGE i) { + // virtual so disable dispatch + static_cast<Fl_Shared_Image*>(i)->uncache(); +} + + + + +void fl_shared_image_scaling_algorithm(int v) { + Fl_Shared_Image::scaling_algorithm(static_cast<Fl_RGB_Scaling>(v)); +} + +void fl_shared_image_scale(SHAREDIMAGE i, int w, int h, int p, int e) { + static_cast<Fl_Shared_Image*>(i)->scale(w, h, p, e); +} + +void fl_shared_image_draw(SHAREDIMAGE i, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + static_cast<Fl_Shared_Image*>(i)->Fl_Shared_Image::draw(x, y, w, h, cx, cy); +} + +void fl_shared_image_draw2(SHAREDIMAGE i, int x, int y) { + static_cast<Fl_Shared_Image*>(i)->draw(x, y); +} + + diff --git a/body/c_fl_shared_image.h b/body/c_fl_shared_image.h new file mode 100644 index 0000000..dbe0352 --- /dev/null +++ b/body/c_fl_shared_image.h @@ -0,0 +1,42 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SHARED_IMAGE_GUARD +#define FL_SHARED_IMAGE_GUARD + + +typedef void* SHAREDIMAGE; + + +extern "C" SHAREDIMAGE fl_shared_image_get(const char * f, int w, int h); +extern "C" SHAREDIMAGE fl_shared_image_get2(void * r); +extern "C" SHAREDIMAGE fl_shared_image_find(const char * n, int w, int h); +extern "C" void fl_shared_image_release(SHAREDIMAGE i); +extern "C" SHAREDIMAGE fl_shared_image_copy(SHAREDIMAGE i, int w, int h); +extern "C" SHAREDIMAGE fl_shared_image_copy2(SHAREDIMAGE i); + + +extern "C" void fl_shared_image_color_average(SHAREDIMAGE i, int c, float b); +extern "C" void fl_shared_image_desaturate(SHAREDIMAGE i); + + +extern "C" int fl_shared_image_num_images(); +extern "C" const char * fl_shared_image_name(SHAREDIMAGE i); +extern "C" int fl_shared_image_original(SHAREDIMAGE i); +extern "C" int fl_shared_image_refcount(SHAREDIMAGE i); +extern "C" void fl_shared_image_reload(SHAREDIMAGE i); +extern "C" void fl_shared_image_uncache(SHAREDIMAGE i); + + +extern "C" void fl_shared_image_scaling_algorithm(int v); +extern "C" void fl_shared_image_scale(SHAREDIMAGE i, int w, int h, int p, int e); +extern "C" void fl_shared_image_draw(SHAREDIMAGE i, int x, int y, int w, int h, int cx, int cy); +extern "C" void fl_shared_image_draw2(SHAREDIMAGE i, int x, int y); + + +#endif + + diff --git a/body/c_fl_simple_counter.cpp b/body/c_fl_simple_counter.cpp new file mode 100644 index 0000000..53aafab --- /dev/null +++ b/body/c_fl_simple_counter.cpp @@ -0,0 +1,79 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Simple_Counter.H> +#include "c_fl_simple_counter.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Simple_Counter : public Fl_Simple_Counter { +public: + using Fl_Simple_Counter::Fl_Simple_Counter; + + friend void fl_simple_counter_draw(SIMPLECOUNTER c); + friend int fl_simple_counter_handle(SIMPLECOUNTER c, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Simple_Counter::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Simple_Counter::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Simple_Counter::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SIMPLECOUNTER new_fl_simple_counter(int x, int y, int w, int h, char* label) { + My_Simple_Counter *c = new My_Simple_Counter(x, y, w, h, label); + return c; +} + +void free_fl_simple_counter(SIMPLECOUNTER c) { + if (fl_inside_callback) { + fl_delete_widget(c); + } else { + delete static_cast<My_Simple_Counter*>(c); + } +} + + + + +void fl_simple_counter_draw(SIMPLECOUNTER c) { + static_cast<My_Simple_Counter*>(c)->Fl_Simple_Counter::draw(); +} + +int fl_simple_counter_handle(SIMPLECOUNTER c, int e) { + return static_cast<My_Simple_Counter*>(c)->Fl_Simple_Counter::handle(e); +} + + diff --git a/body/c_fl_simple_counter.h b/body/c_fl_simple_counter.h new file mode 100644 index 0000000..397b488 --- /dev/null +++ b/body/c_fl_simple_counter.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SIMPLE_COUNTER_GUARD +#define FL_SIMPLE_COUNTER_GUARD + + +typedef void* SIMPLECOUNTER; + + +extern "C" SIMPLECOUNTER new_fl_simple_counter(int x, int y, int w, int h, char* label); +extern "C" void free_fl_simple_counter(SIMPLECOUNTER c); + + +extern "C" void fl_simple_counter_draw(SIMPLECOUNTER c); +extern "C" int fl_simple_counter_handle(SIMPLECOUNTER c, int e); + + +#endif + + diff --git a/body/c_fl_single_window.cpp b/body/c_fl_single_window.cpp new file mode 100644 index 0000000..d22041e --- /dev/null +++ b/body/c_fl_single_window.cpp @@ -0,0 +1,99 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Single_Window.H> +#include "c_fl_single_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Single_Window : public Fl_Single_Window { +public: + using Fl_Single_Window::Fl_Single_Window; + + friend void fl_single_window_draw(SINGLEWINDOW n); + friend int fl_single_window_handle(SINGLEWINDOW n, int e); + + void draw(); + int handle(int e); +}; + +void My_Single_Window::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Single_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SINGLEWINDOW new_fl_single_window(int x, int y, int w, int h, char* label) { + My_Single_Window *sw = new My_Single_Window(x, y, w, h, label); + return sw; +} + +SINGLEWINDOW new_fl_single_window2(int x, int y, char* label) { + My_Single_Window *sw = new My_Single_Window(x, y, label); + return sw; +} + +void free_fl_single_window(SINGLEWINDOW w) { + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Single_Window*>(w); + } +} + + + + +void fl_single_window_show(SINGLEWINDOW w) { + static_cast<Fl_Single_Window*>(w)->show(); +} + +void fl_single_window_show2(SINGLEWINDOW w, int c, void * v) { + static_cast<Fl_Single_Window*>(w)->show(c, static_cast<char**>(v)); +} + +void fl_single_window_flush(SINGLEWINDOW w) { + static_cast<Fl_Single_Window*>(w)->flush(); +} + + + + +void fl_single_window_make_current(SINGLEWINDOW w) { + static_cast<Fl_Single_Window*>(w)->Fl_Window::make_current(); +} + + + + +void fl_single_window_draw(SINGLEWINDOW n) { + static_cast<My_Single_Window*>(n)->Fl_Single_Window::draw(); +} + +int fl_single_window_handle(SINGLEWINDOW n, int e) { + return static_cast<My_Single_Window*>(n)->Fl_Single_Window::handle(e); +} + + diff --git a/body/c_fl_single_window.h b/body/c_fl_single_window.h new file mode 100644 index 0000000..85e6e29 --- /dev/null +++ b/body/c_fl_single_window.h @@ -0,0 +1,33 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SINGLE_WINDOW_GUARD +#define FL_SINGLE_WINDOW_GUARD + + +typedef void* SINGLEWINDOW; + + +extern "C" SINGLEWINDOW new_fl_single_window(int x, int y, int w, int h, char* label); +extern "C" SINGLEWINDOW new_fl_single_window2(int x, int y, char* label); +extern "C" void free_fl_single_window(SINGLEWINDOW w); + + +extern "C" void fl_single_window_show(SINGLEWINDOW w); +extern "C" void fl_single_window_show2(SINGLEWINDOW w, int c, void * v); +extern "C" void fl_single_window_flush(SINGLEWINDOW w); + + +extern "C" void fl_single_window_make_current(SINGLEWINDOW w); + + +extern "C" void fl_single_window_draw(SINGLEWINDOW n); +extern "C" int fl_single_window_handle(SINGLEWINDOW n, int e); + + +#endif + + diff --git a/body/c_fl_slider.cpp b/body/c_fl_slider.cpp new file mode 100644 index 0000000..bad03cd --- /dev/null +++ b/body/c_fl_slider.cpp @@ -0,0 +1,133 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Slider.H> +#include "c_fl_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Non-friend protected access + +class Friend_Slider : Fl_Slider { +public: + // Really only needed for the (int,int,int,int) versions + using Fl_Slider::draw; + using Fl_Slider::handle; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Slider : public Fl_Slider { +public: + using Fl_Slider::Fl_Slider; + + friend void fl_slider_draw(SLIDER s); + friend int fl_slider_handle(SLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SLIDER new_fl_slider(int x, int y, int w, int h, char* label) { + My_Slider *s = new My_Slider(x, y, w, h, label); + return s; +} + +SLIDER new_fl_slider2(unsigned char k, int x, int y, int w, int h, char * label) { + My_Slider *s = new My_Slider(k, x, y, w, h, label); + return s; +} + +void free_fl_slider(SLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Slider*>(s); + } +} + + + + +void fl_slider_set_bounds(SLIDER s, double a, double b) { + static_cast<Fl_Slider*>(s)->bounds(a,b); +} + +int fl_slider_get_slider(SLIDER s) { + return static_cast<Fl_Slider*>(s)->slider(); +} + +void fl_slider_set_slider(SLIDER s, int t) { + static_cast<Fl_Slider*>(s)->slider(static_cast<Fl_Boxtype>(t)); +} + +float fl_slider_get_slider_size(SLIDER s) { + return static_cast<Fl_Slider*>(s)->slider_size(); +} + +void fl_slider_set_slider_size(SLIDER s, double t) { + static_cast<Fl_Slider*>(s)->slider_size(t); +} + +int fl_slider_scrollvalue(SLIDER s, int p, int z, int f, int t) { + return static_cast<Fl_Slider*>(s)->scrollvalue(p,z,f,t); +} + + + + +void fl_slider_draw(SLIDER s) { + static_cast<My_Slider*>(s)->Fl_Slider::draw(); +} + +void fl_slider_draw2(SLIDER s, int x, int y, int w, int h) { + void (Fl_Slider::*mydraw)(int,int,int,int) = &Friend_Slider::draw; + (static_cast<Fl_Slider*>(s)->*mydraw)(x, y, w, h); +} + +int fl_slider_handle(SLIDER s, int e) { + return static_cast<My_Slider*>(s)->Fl_Slider::handle(e); +} + +int fl_slider_handle2(SLIDER s, int e, int x, int y, int w, int h) { + int (Fl_Slider::*myhandle)(int,int,int,int,int) = &Friend_Slider::handle; + return (static_cast<Fl_Slider*>(s)->*myhandle)(e, x, y, w, h); +} + + diff --git a/body/c_fl_slider.h b/body/c_fl_slider.h new file mode 100644 index 0000000..63c6ac3 --- /dev/null +++ b/body/c_fl_slider.h @@ -0,0 +1,35 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SLIDER_GUARD +#define FL_SLIDER_GUARD + + +typedef void* SLIDER; + + +extern "C" SLIDER new_fl_slider(int x, int y, int w, int h, char* label); +extern "C" SLIDER new_fl_slider2(unsigned char k, int x, int y, int w, int h, char * label); +extern "C" void free_fl_slider(SLIDER s); + + +extern "C" void fl_slider_set_bounds(SLIDER s, double a, double b); +extern "C" int fl_slider_get_slider(SLIDER s); +extern "C" void fl_slider_set_slider(SLIDER s, int t); +extern "C" float fl_slider_get_slider_size(SLIDER s); +extern "C" void fl_slider_set_slider_size(SLIDER s, double t); +extern "C" int fl_slider_scrollvalue(SLIDER s, int p, int z, int f, int t); + + +extern "C" void fl_slider_draw(SLIDER s); +extern "C" void fl_slider_draw2(SLIDER s, int x, int y, int w, int h); +extern "C" int fl_slider_handle(SLIDER s, int e); +extern "C" int fl_slider_handle2(SLIDER s, int e, int x, int y, int w, int h); + + +#endif + + diff --git a/body/c_fl_spinner.cpp b/body/c_fl_spinner.cpp new file mode 100644 index 0000000..d8683e5 --- /dev/null +++ b/body/c_fl_spinner.cpp @@ -0,0 +1,180 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Spinner.H> +#include "c_fl_spinner.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Attaching all hooks and friends + +class My_Spinner : public Fl_Spinner { +public: + using Fl_Spinner::Fl_Spinner; + + friend void fl_spinner_draw(SPINNER n); + friend int fl_spinner_handle(SPINNER n, int e); + + void draw(); + int handle(int e); +}; + +void My_Spinner::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Spinner::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SPINNER new_fl_spinner(int x, int y, int w, int h, char* label) { + My_Spinner *n = new My_Spinner(x, y, w, h, label); + return n; +} + +void free_fl_spinner(SPINNER n) { + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Spinner*>(n); + } +} + + + + +unsigned int fl_spinner_get_color(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->color(); +} + +void fl_spinner_set_color(SPINNER n, unsigned int t) { + static_cast<Fl_Spinner*>(n)->color(t); +} + +unsigned int fl_spinner_get_selection_color(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->selection_color(); +} + +void fl_spinner_set_selection_color(SPINNER n, unsigned int t) { + static_cast<Fl_Spinner*>(n)->selection_color(t); +} + +unsigned int fl_spinner_get_textcolor(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->textcolor(); +} + +void fl_spinner_set_textcolor(SPINNER n, unsigned int t) { + static_cast<Fl_Spinner*>(n)->textcolor(t); +} + +int fl_spinner_get_textfont(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->textfont(); +} + +void fl_spinner_set_textfont(SPINNER n, int t) { + static_cast<Fl_Spinner*>(n)->textfont(t); +} + +int fl_spinner_get_textsize(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->textsize(); +} + +void fl_spinner_set_textsize(SPINNER n, int t) { + static_cast<Fl_Spinner*>(n)->textsize(t); +} + + + + +double fl_spinner_get_minimum(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->minimum(); +} + +void fl_spinner_set_minimum(SPINNER n, double t) { + static_cast<Fl_Spinner*>(n)->minimum(t); +} + +double fl_spinner_get_maximum(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->maximum(); +} + +void fl_spinner_set_maximum(SPINNER n, double t) { + static_cast<Fl_Spinner*>(n)->maximum(t); +} + +void fl_spinner_range(SPINNER n, double a, double b) { + static_cast<Fl_Spinner*>(n)->range(a,b); +} + +double fl_spinner_get_step(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->step(); +} + +void fl_spinner_set_step(SPINNER n, double t) { + static_cast<Fl_Spinner*>(n)->step(t); +} + +double fl_spinner_get_value(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->value(); +} + +void fl_spinner_set_value(SPINNER n, double t) { + static_cast<Fl_Spinner*>(n)->value(t); +} + + + + +const char * fl_spinner_get_format(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->format(); +} + +void fl_spinner_set_format(SPINNER n, const char * f) { + static_cast<Fl_Spinner*>(n)->format(f); +} + +unsigned char fl_spinner_get_type(SPINNER n) { + return static_cast<Fl_Spinner*>(n)->type(); +} + +void fl_spinner_set_type(SPINNER n, unsigned char t) { + static_cast<Fl_Spinner*>(n)->type(t); +} + + + + +void fl_spinner_resize(SPINNER n, int x, int y, int w, int h) { + static_cast<Fl_Spinner*>(n)->resize(x, y, w, h); +} + + + + +void fl_spinner_draw(SPINNER n) { + static_cast<My_Spinner*>(n)->Fl_Spinner::draw(); +} + +int fl_spinner_handle(SPINNER n, int e) { + return static_cast<My_Spinner*>(n)->Fl_Spinner::handle(e); +} + + diff --git a/body/c_fl_spinner.h b/body/c_fl_spinner.h new file mode 100644 index 0000000..7447c33 --- /dev/null +++ b/body/c_fl_spinner.h @@ -0,0 +1,56 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SPINNER_GUARD +#define FL_SPINNER_GUARD + + +typedef void* SPINNER; + + +extern "C" SPINNER new_fl_spinner(int x, int y, int w, int h, char* label); +extern "C" void free_fl_spinner(SPINNER n); + + +extern "C" unsigned int fl_spinner_get_color(SPINNER n); +extern "C" void fl_spinner_set_color(SPINNER n, unsigned int t); +extern "C" unsigned int fl_spinner_get_selection_color(SPINNER n); +extern "C" void fl_spinner_set_selection_color(SPINNER n, unsigned int t); +extern "C" unsigned int fl_spinner_get_textcolor(SPINNER n); +extern "C" void fl_spinner_set_textcolor(SPINNER n, unsigned int t); +extern "C" int fl_spinner_get_textfont(SPINNER n); +extern "C" void fl_spinner_set_textfont(SPINNER n, int t); +extern "C" int fl_spinner_get_textsize(SPINNER n); +extern "C" void fl_spinner_set_textsize(SPINNER n, int t); + + +extern "C" double fl_spinner_get_minimum(SPINNER n); +extern "C" void fl_spinner_set_minimum(SPINNER n, double t); +extern "C" double fl_spinner_get_maximum(SPINNER n); +extern "C" void fl_spinner_set_maximum(SPINNER n, double t); +extern "C" void fl_spinner_range(SPINNER n, double a, double b); +extern "C" double fl_spinner_get_step(SPINNER n); +extern "C" void fl_spinner_set_step(SPINNER n, double t); +extern "C" double fl_spinner_get_value(SPINNER n); +extern "C" void fl_spinner_set_value(SPINNER n, double t); + + +extern "C" const char * fl_spinner_get_format(SPINNER n); +extern "C" void fl_spinner_set_format(SPINNER n, const char * f); +extern "C" unsigned char fl_spinner_get_type(SPINNER n); +extern "C" void fl_spinner_set_type(SPINNER n, unsigned char t); + + +extern "C" void fl_spinner_resize(SPINNER n, int x, int y, int w, int h); + + +extern "C" void fl_spinner_draw(SPINNER n); +extern "C" int fl_spinner_handle(SPINNER n, int e); + + +#endif + + diff --git a/body/c_fl_static.cpp b/body/c_fl_static.cpp new file mode 100644 index 0000000..5dd90e2 --- /dev/null +++ b/body/c_fl_static.cpp @@ -0,0 +1,391 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl.H> +#include <FL/Fl_Widget.H> +#include <FL/Fl_Window.H> +#include "c_fl_static.h" + + + + +void fl_static_box_draw_marshal(void * f, int x, int y, int w, int h, unsigned int t) { + reinterpret_cast<Fl_Box_Draw_F*>(f)(x, y, w, h, static_cast<Fl_Color>(t)); +} + + + + +const char * const fl_help_usage_string_ptr = Fl::help; + + + + +int fl_static_arg(int c, void * v, int &i) { + return Fl::arg(c, static_cast<char**>(v), i); +} + +void fl_static_args(int c, void * v) { + Fl::args(c, static_cast<char**>(v)); +} + +int fl_static_args2(int c, void * v, int &i, void * h) { + return Fl::args(c, static_cast<char**>(v), i, reinterpret_cast<Fl_Args_Handler>(h)); +} + + + + +int fl_static_add_awake_handler(void * h, void * f) { + return Fl::add_awake_handler_(reinterpret_cast<Fl_Awake_Handler>(h), f); +} + +int fl_static_get_awake_handler(void * &h, void * &f) { + return Fl::get_awake_handler_(reinterpret_cast<Fl_Awake_Handler&>(h), f); +} + +int fl_static_awake2(void * h, void * f) { + return Fl::awake(reinterpret_cast<Fl_Awake_Handler>(h), f); +} + +void fl_static_awake(void * msg) { + Fl::awake(msg); +} + +void fl_static_lock() { + Fl::lock(); +} + +void fl_static_unlock() { + Fl::unlock(); +} + + + + +void fl_static_add_check(void * h, void * f) { + Fl::add_check(reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + +int fl_static_has_check(void * h, void * f) { + return Fl::has_check(reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + +void fl_static_remove_check(void * h, void * f) { + Fl::remove_check(reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + + + + +void fl_static_add_timeout(double s, void * h, void * f) { + Fl::add_timeout(s, reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + +int fl_static_has_timeout(void * h, void * f) { + return Fl::has_timeout(reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + +void fl_static_remove_timeout(void * h, void * f) { + Fl::remove_timeout(reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + +void fl_static_repeat_timeout(double s, void * h, void * f) { + Fl::repeat_timeout(s, reinterpret_cast<Fl_Timeout_Handler>(h), f); +} + + + + +void fl_static_add_clipboard_notify(void * h, void * f) { + Fl::add_clipboard_notify(reinterpret_cast<Fl_Clipboard_Notify_Handler>(h), f); +} + +void fl_static_remove_clipboard_notify(void * h) { + Fl::remove_clipboard_notify(reinterpret_cast<Fl_Clipboard_Notify_Handler>(h)); +} + + + + +void fl_static_add_fd(int d, void * h, void * f) { + Fl::add_fd(d,reinterpret_cast<Fl_FD_Handler>(h), f); +} + +void fl_static_add_fd2(int d, int m, void * h, void * f) { + Fl::add_fd(d,m,reinterpret_cast<Fl_FD_Handler>(h), f); +} + +void fl_static_remove_fd(int d) { + Fl::remove_fd(d); +} + +void fl_static_remove_fd2(int d, int m) { + Fl::remove_fd(d, m); +} + + + + +void fl_static_add_idle(void * h, void * f) { + Fl::add_idle(reinterpret_cast<Fl_Idle_Handler>(h), f); +} + +int fl_static_has_idle(void * h, void * f) { + return Fl::has_idle(reinterpret_cast<Fl_Idle_Handler>(h), f); +} + +void fl_static_remove_idle(void * h, void * f) { + Fl::remove_idle(reinterpret_cast<Fl_Idle_Handler>(h), f); +} + + + + +unsigned int fl_static_get_color2(unsigned int c) { + return Fl::get_color(c); +} + +void fl_static_get_color(unsigned int c, unsigned char &r, unsigned char &g, unsigned char &b) { + Fl::get_color(c, r, g, b); +} + +void fl_static_set_color2(unsigned int t, unsigned int f) { + Fl::set_color(t, f); +} + +void fl_static_set_color(unsigned int c, unsigned char r, unsigned char g, unsigned char b) { + Fl::set_color(c, r, g, b); +} + +void fl_static_free_color(unsigned int c, int b) { + Fl::free_color(c, b); +} + +unsigned int fl_static_get_box_color(unsigned int t) { + return Fl::box_color(static_cast<Fl_Color>(t)); +} + +void fl_static_set_box_color(unsigned int t) { + Fl::set_box_color(static_cast<Fl_Color>(t)); +} + +void fl_static_own_colormap() { + Fl::own_colormap(); +} + +void fl_static_foreground(unsigned int r, unsigned int g, unsigned int b) { + Fl::foreground(r, g, b); +} + +void fl_static_background(unsigned int r, unsigned int g, unsigned int b) { + Fl::background(r, g, b); +} + +void fl_static_background2(unsigned int r, unsigned int g, unsigned int b) { + Fl::background2(r, g, b); +} + +void fl_static_get_system_colors() { + Fl::get_system_colors(); +} + + + + +const char * fl_static_get_font(int f) { + return Fl::get_font(f); +} + +const char * fl_static_get_font_name(int f) { + return Fl::get_font_name(f); +} + +void fl_static_set_font(int t, int f) { + Fl::set_font(static_cast<Fl_Font>(t), static_cast<Fl_Font>(f)); +} + +void fl_static_set_font2(int t, char * s) { + Fl::set_font(static_cast<Fl_Font>(t), s); +} + +int fl_static_get_font_sizes(int f, int * &a) { + return Fl::get_font_sizes(static_cast<Fl_Font>(f),a); +} + +int fl_static_font_size_array_get(int * a, int i) { + return *(a+((i-1)*sizeof(int))); +} + +int fl_static_set_fonts() { + return Fl::set_fonts(); +} + + + + +int fl_static_box_dh(int b) { + return Fl::box_dh(static_cast<Fl_Boxtype>(b)); +} + +int fl_static_box_dw(int b) { + return Fl::box_dw(static_cast<Fl_Boxtype>(b)); +} + +int fl_static_box_dx(int b) { + return Fl::box_dx(static_cast<Fl_Boxtype>(b)); +} + +int fl_static_box_dy(int b) { + return Fl::box_dy(static_cast<Fl_Boxtype>(b)); +} + +void * fl_static_get_boxtype(int t) { + return reinterpret_cast<void*>(Fl::get_boxtype(static_cast<Fl_Boxtype>(t))); +} + +void fl_static_set_boxtype(int t, int f) { + Fl::set_boxtype(static_cast<Fl_Boxtype>(t),static_cast<Fl_Boxtype>(f)); +} + +void fl_static_set_boxtype2(int t, void * f, + unsigned char dx, unsigned char dy, unsigned char dw, unsigned char dh) +{ + Fl::set_boxtype(static_cast<Fl_Boxtype>(t), reinterpret_cast<Fl_Box_Draw_F*>(f), dx, dy, dw, dh); +} + +int fl_static_draw_box_active() { + return Fl::draw_box_active(); +} + + + + +void fl_static_set_labeltype(int k, void * d, void * m) { + Fl::set_labeltype(static_cast<Fl_Labeltype>(k), + reinterpret_cast<Fl_Label_Draw_F*>(d), reinterpret_cast<Fl_Label_Measure_F*>(m)); +} + + + + +void fl_static_copy(const char * t, int l, int k) { + Fl::copy(t, l, k); +} + +void fl_static_paste(void * r, int s) { + Fl_Widget &ref = *static_cast<Fl_Widget*>(r); + Fl::paste(ref, s); +} + +void fl_static_selection(void * o, char * t, int l) { + Fl_Widget &ref = *static_cast<Fl_Widget*>(o); + Fl::selection(ref, t, l); +} + +int fl_static_clipboard_contains(const char * k) { + return Fl::clipboard_contains(k); +} + + + + +int fl_static_dnd() { + return Fl::dnd(); +} + +int fl_static_get_dnd_text_ops() { + return Fl::dnd_text_ops(); +} + +void fl_static_set_dnd_text_ops(int t) { + Fl::dnd_text_ops(t); +} + + + + +void fl_static_enable_im() { + Fl::enable_im(); +} + +void fl_static_disable_im() { + Fl::disable_im(); +} + + + + +void fl_static_default_atclose(void * w, void * u) { + Fl::default_atclose(static_cast<Fl_Window*>(w), u); +} + +void * fl_static_get_first_window() { + return Fl::first_window(); +} + +void fl_static_set_first_window(void * w) { + Fl::first_window(static_cast<Fl_Window*>(w)); +} + +void * fl_static_next_window(void * w) { + return Fl::next_window(static_cast<Fl_Window*>(w)); +} + +void * fl_static_modal() { + return Fl::modal(); +} + + + + +void * fl_static_readqueue() { + return Fl::readqueue(); +} + + + + +const char * fl_static_get_scheme() { + return Fl::scheme(); +} + +void fl_static_set_scheme(const char *n) { + Fl::scheme(n); +} + +int fl_static_is_scheme(const char *n) { + return Fl::is_scheme(n); +} + +void fl_static_reload_scheme() { + // this always returns 1 for some reason so we can ignore the return value + Fl::reload_scheme(); +} + + + + +int fl_static_get_option(int o) { + return Fl::option(static_cast<Fl::Fl_Option>(o)) ? 1 : 0; +} + +void fl_static_set_option(int o, int t) { + Fl::option(static_cast<Fl::Fl_Option>(o), t!=0); +} + + + + +int fl_static_get_scrollbar_size() { + return Fl::scrollbar_size(); +} + +void fl_static_set_scrollbar_size(int s) { + Fl::scrollbar_size(s); +} + + diff --git a/body/c_fl_static.h b/body/c_fl_static.h new file mode 100644 index 0000000..f39e557 --- /dev/null +++ b/body/c_fl_static.h @@ -0,0 +1,136 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_STATIC_GUARD +#define FL_STATIC_GUARD + + +extern "C" void fl_static_box_draw_marshal(void * f, int x, int y, int w, int h, unsigned int t); + + +extern "C" const char * const fl_help_usage_string_ptr; + + +extern "C" int fl_static_arg(int c, void * v, int &i); +extern "C" void fl_static_args(int c, void * v); +extern "C" int fl_static_args2(int c, void * v, int &i, void * h); + + +extern "C" int fl_static_add_awake_handler(void * h, void * f); +extern "C" int fl_static_get_awake_handler(void * &h, void * &f); +extern "C" int fl_static_awake2(void * h, void * f); +extern "C" void fl_static_awake(void * msg); +extern "C" void fl_static_lock(); +extern "C" void fl_static_unlock(); + + +extern "C" void fl_static_add_check(void * h, void * f); +extern "C" int fl_static_has_check(void * h, void * f); +extern "C" void fl_static_remove_check(void * h, void * f); + + +extern "C" void fl_static_add_timeout(double s, void * h, void * f); +extern "C" int fl_static_has_timeout(void * h, void * f); +extern "C" void fl_static_remove_timeout(void * h, void * f); +extern "C" void fl_static_repeat_timeout(double s, void * h, void * f); + + +extern "C" void fl_static_add_clipboard_notify(void * h, void * f); +extern "C" void fl_static_remove_clipboard_notify(void * h); + + +extern "C" void fl_static_add_fd(int d, void * h, void * f); +extern "C" void fl_static_add_fd2(int d, int m, void * h, void * f); +extern "C" void fl_static_remove_fd(int d); +extern "C" void fl_static_remove_fd2(int d, int m); + + +extern "C" void fl_static_add_idle(void * h, void * f); +extern "C" int fl_static_has_idle(void * h, void * f); +extern "C" void fl_static_remove_idle(void * h, void * f); + + +extern "C" unsigned int fl_static_get_color2(unsigned int c); +extern "C" void fl_static_get_color(unsigned int c, + unsigned char &r, unsigned char &g, unsigned char &b); +extern "C" void fl_static_set_color2(unsigned int t, unsigned int f); +extern "C" void fl_static_set_color(unsigned int c, + unsigned char r, unsigned char g, unsigned char b); +extern "C" void fl_static_free_color(unsigned int c, int b); +extern "C" unsigned int fl_static_get_box_color(unsigned int t); +extern "C" void fl_static_set_box_color(unsigned int t); +extern "C" void fl_static_own_colormap(); +extern "C" void fl_static_foreground(unsigned int r, unsigned int g, unsigned int b); +extern "C" void fl_static_background(unsigned int r, unsigned int g, unsigned int b); +extern "C" void fl_static_background2(unsigned int r, unsigned int g, unsigned int b); +extern "C" void fl_static_get_system_colors(); + + +extern "C" const char * fl_static_get_font(int f); +extern "C" const char * fl_static_get_font_name(int f); +extern "C" void fl_static_set_font(int t, int f); +extern "C" void fl_static_set_font2(int t, char * s); +extern "C" int fl_static_get_font_sizes(int f, int * &a); +extern "C" int fl_static_font_size_array_get(int * a, int i); +extern "C" int fl_static_set_fonts(); + + +extern "C" int fl_static_box_dh(int b); +extern "C" int fl_static_box_dw(int b); +extern "C" int fl_static_box_dx(int b); +extern "C" int fl_static_box_dy(int b); +extern "C" void * fl_static_get_boxtype(int t); +extern "C" void fl_static_set_boxtype(int t, int f); +extern "C" void fl_static_set_boxtype2(int t, void * f, + unsigned char dx, unsigned char dy, unsigned char dw, unsigned char dh); +extern "C" int fl_static_draw_box_active(); + + +extern "C" void fl_static_set_labeltype(int k, void * d, void * m); + + +extern "C" void fl_static_copy(const char * t, int l, int k); +extern "C" void fl_static_paste(void * r, int s); +extern "C" void fl_static_selection(void * o, char * t, int l); +extern "C" int fl_static_clipboard_contains(const char * k); + + +extern "C" int fl_static_dnd(); +extern "C" int fl_static_get_dnd_text_ops(); +extern "C" void fl_static_set_dnd_text_ops(int t); + + +extern "C" void fl_static_enable_im(); +extern "C" void fl_static_disable_im(); + + +extern "C" void fl_static_default_atclose(void * w, void * u); +extern "C" void * fl_static_get_first_window(); +extern "C" void fl_static_set_first_window(void * w); +extern "C" void * fl_static_next_window(void * w); +extern "C" void * fl_static_modal(); + + +extern "C" void * fl_static_readqueue(); + + +extern "C" const char * fl_static_get_scheme(); +extern "C" void fl_static_set_scheme(const char *n); +extern "C" int fl_static_is_scheme(const char *n); +extern "C" void fl_static_reload_scheme(); + + +extern "C" int fl_static_get_option(int o); +extern "C" void fl_static_set_option(int o, int t); + + +extern "C" int fl_static_get_scrollbar_size(); +extern "C" void fl_static_set_scrollbar_size(int s); + + +#endif + + diff --git a/body/c_fl_surface_device.cpp b/body/c_fl_surface_device.cpp new file mode 100644 index 0000000..9836a04 --- /dev/null +++ b/body/c_fl_surface_device.cpp @@ -0,0 +1,58 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Device.H> +#include "c_fl_surface_device.h" + + + + +// Adding relevant friends + +class My_Surface_Device : public Fl_Surface_Device { +public: + using Fl_Surface_Device::Fl_Surface_Device; + friend SURFACEDEVICE new_fl_surface_device(void * g); +}; + + + + +// Flattened C API + +SURFACEDEVICE new_fl_surface_device(void * g) { + My_Surface_Device *s = new My_Surface_Device(static_cast<Fl_Graphics_Driver*>(g)); + return s; +} + +void free_fl_surface_device(SURFACEDEVICE s) { + delete static_cast<My_Surface_Device*>(s); +} + + + + +void fl_surface_device_set_current(SURFACEDEVICE s) { + // virtual so disable dispatch + static_cast<Fl_Surface_Device*>(s)->Fl_Surface_Device::set_current(); +} + +SURFACEDEVICE fl_surface_device_get_surface(void) { + return Fl_Surface_Device::surface(); +} + + + + +void * fl_surface_device_get_driver(SURFACEDEVICE s) { + return static_cast<Fl_Surface_Device*>(s)->driver(); +} + +void fl_surface_device_set_driver(SURFACEDEVICE s, void * g) { + static_cast<Fl_Surface_Device*>(s)->driver(static_cast<Fl_Graphics_Driver*>(g)); +} + + diff --git a/body/c_fl_surface_device.h b/body/c_fl_surface_device.h new file mode 100644 index 0000000..97096c6 --- /dev/null +++ b/body/c_fl_surface_device.h @@ -0,0 +1,28 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SURFACE_DEVICE_GUARD +#define FL_SURFACE_DEVICE_GUARD + + +typedef void* SURFACEDEVICE; + + +extern "C" SURFACEDEVICE new_fl_surface_device(void * g); +extern "C" void free_fl_surface_device(SURFACEDEVICE s); + + +extern "C" void fl_surface_device_set_current(SURFACEDEVICE s); +extern "C" SURFACEDEVICE fl_surface_device_get_surface(void); + + +extern "C" void * fl_surface_device_get_driver(SURFACEDEVICE s); +extern "C" void fl_surface_device_set_driver(SURFACEDEVICE s, void * g); + + +#endif + + diff --git a/body/c_fl_sys_menu_bar.cpp b/body/c_fl_sys_menu_bar.cpp new file mode 100644 index 0000000..7f28574 --- /dev/null +++ b/body/c_fl_sys_menu_bar.cpp @@ -0,0 +1,163 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Sys_Menu_Bar.H> +#include <FL/Fl_Menu_Item.H> +#include "c_fl_sys_menu_bar.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" void menu_item_callback_hook(void * cobj, void * ud); + + + + +// Attaching all relevant hooks and friends + +class My_Sys_Menu_Bar : public Fl_Sys_Menu_Bar { +public: + using Fl_Sys_Menu_Bar::Fl_Sys_Menu_Bar; + + friend void fl_sys_menu_bar_draw(SYSMENUBAR m); + friend int fl_sys_menu_bar_handle(SYSMENUBAR m, int e); + + void draw(); + int handle(int e); +}; + +void My_Sys_Menu_Bar::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Sys_Menu_Bar::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +SYSMENUBAR new_fl_sys_menu_bar(int x, int y, int w, int h, char* label) { + My_Sys_Menu_Bar *m = new My_Sys_Menu_Bar(x, y, w, h, label); + return m; +} + +void free_fl_sys_menu_bar(SYSMENUBAR m) { + if (fl_inside_callback) { + fl_delete_widget(m); + } else { + delete static_cast<My_Sys_Menu_Bar*>(m); + } +} + + + + +int fl_sys_menu_bar_add(SYSMENUBAR m, const char * t) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->add(t); +} + +int fl_sys_menu_bar_add2(SYSMENUBAR m, const char * t, int s, void * u, int f) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->add(t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +int fl_sys_menu_bar_add3(SYSMENUBAR m, const char * t, const char * s, void * u, int f) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->add(t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +int fl_sys_menu_bar_insert(SYSMENUBAR m, int p, const char * t, int s, void * u, int f) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->insert(p, t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +int fl_sys_menu_bar_insert2(SYSMENUBAR m, int p, const char * t, const char * s, void * u, int f) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->insert(p, t, s, + u==0?0:reinterpret_cast<Fl_Callback_p>(&menu_item_callback_hook), u, f); +} + +void fl_sys_menu_bar_set_menu(SYSMENUBAR m, void * d) { + static_cast<Fl_Sys_Menu_Bar*>(m)->menu(static_cast<Fl_Menu_*>(d)->menu()); +} + +void fl_sys_menu_bar_remove(SYSMENUBAR m, int p) { + static_cast<Fl_Sys_Menu_Bar*>(m)->remove(p); +} + +void fl_sys_menu_bar_clear(SYSMENUBAR m) { + static_cast<Fl_Sys_Menu_Bar*>(m)->clear(); +} + +int fl_sys_menu_bar_clear_submenu(SYSMENUBAR m, int i) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->clear_submenu(i); +} + + + + +const void * fl_sys_menu_bar_get_item(SYSMENUBAR m, int i) { + return &(static_cast<Fl_Sys_Menu_Bar*>(m)->menu()[i]); +} + + + + +void fl_sys_menu_bar_setonly(SYSMENUBAR m, void * mi) { + static_cast<Fl_Sys_Menu_Bar*>(m)->setonly(static_cast<Fl_Menu_Item*>(mi)); +} + +void fl_sys_menu_bar_replace(SYSMENUBAR m, int i, const char * t) { + static_cast<Fl_Sys_Menu_Bar*>(m)->replace(i, t); +} + +void fl_sys_menu_bar_shortcut(SYSMENUBAR m, int i, int s) { + static_cast<Fl_Sys_Menu_Bar*>(m)->shortcut(i, s); +} + +int fl_sys_menu_bar_get_mode(SYSMENUBAR m, int i) { + return static_cast<Fl_Sys_Menu_Bar*>(m)->mode(i); +} + +void fl_sys_menu_bar_set_mode(SYSMENUBAR m, int i, int f) { + static_cast<Fl_Sys_Menu_Bar*>(m)->mode(i, f); +} + + + + +void fl_sys_menu_bar_global(SYSMENUBAR m) { + static_cast<Fl_Sys_Menu_Bar*>(m)->global(); +} + +void fl_sys_menu_bar_update(SYSMENUBAR m) { +#if FLTK_ABI_VERSION >= 10304 + static_cast<Fl_Sys_Menu_Bar*>(m)->update(); +#else + (void)(m); +#endif +} + + + + +void fl_sys_menu_bar_draw(SYSMENUBAR m) { + static_cast<My_Sys_Menu_Bar*>(m)->Fl_Sys_Menu_Bar::draw(); +} + +int fl_sys_menu_bar_handle(SYSMENUBAR m, int e) { + return static_cast<My_Sys_Menu_Bar*>(m)->Fl_Sys_Menu_Bar::handle(e); +} + + diff --git a/body/c_fl_sys_menu_bar.h b/body/c_fl_sys_menu_bar.h new file mode 100644 index 0000000..1bde8f2 --- /dev/null +++ b/body/c_fl_sys_menu_bar.h @@ -0,0 +1,50 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SYS_MENU_BAR_GUARD +#define FL_SYS_MENU_BAR_GUARD + + +typedef void* SYSMENUBAR; + + +extern "C" SYSMENUBAR new_fl_sys_menu_bar(int x, int y, int w, int h, char* label); +extern "C" void free_fl_sys_menu_bar(SYSMENUBAR m); + + +extern "C" int fl_sys_menu_bar_add(SYSMENUBAR m, const char * t); +extern "C" int fl_sys_menu_bar_add2(SYSMENUBAR m, const char * t, int s, void * u, int f); +extern "C" int fl_sys_menu_bar_add3(SYSMENUBAR m, const char * t, const char * s, void * u, int f); +extern "C" int fl_sys_menu_bar_insert(SYSMENUBAR m, int p, const char * t, int s, void * u, int f); +extern "C" int fl_sys_menu_bar_insert2(SYSMENUBAR m, int p, const char * t, + const char * s, void * u, int f); +extern "C" void fl_sys_menu_bar_set_menu(SYSMENUBAR m, void * d); +extern "C" void fl_sys_menu_bar_remove(SYSMENUBAR m, int p); +extern "C" void fl_sys_menu_bar_clear(SYSMENUBAR m); +extern "C" int fl_sys_menu_bar_clear_submenu(SYSMENUBAR m, int p); + + +extern "C" const void * fl_sys_menu_bar_get_item(SYSMENUBAR m, int i); + + +extern "C" void fl_sys_menu_bar_setonly(SYSMENUBAR m, void * mi); +extern "C" void fl_sys_menu_bar_replace(SYSMENUBAR m, int i, const char * t); +extern "C" void fl_sys_menu_bar_shortcut(SYSMENUBAR m, int p, int s); +extern "C" int fl_sys_menu_bar_get_mode(SYSMENUBAR m, int p); +extern "C" void fl_sys_menu_bar_set_mode(SYSMENUBAR m, int p, int f); + + +extern "C" void fl_sys_menu_bar_global(SYSMENUBAR m); +extern "C" void fl_sys_menu_bar_update(SYSMENUBAR m); + + +extern "C" void fl_sys_menu_bar_draw(SYSMENUBAR m); +extern "C" int fl_sys_menu_bar_handle(SYSMENUBAR m, int e); + + +#endif + + diff --git a/body/c_fl_table.cpp b/body/c_fl_table.cpp new file mode 100644 index 0000000..377ec37 --- /dev/null +++ b/body/c_fl_table.cpp @@ -0,0 +1,516 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Table.H> +#include "c_fl_table.h" +#include "c_fl.h" + + + + +// Enum and macro constants + +const int fl_context_none = Fl_Table::CONTEXT_NONE; +const int fl_context_startpage = Fl_Table::CONTEXT_STARTPAGE; +const int fl_context_endpage = Fl_Table::CONTEXT_ENDPAGE; +const int fl_context_row_header = Fl_Table::CONTEXT_ROW_HEADER; +const int fl_context_col_header = Fl_Table::CONTEXT_COL_HEADER; +const int fl_context_cell = Fl_Table::CONTEXT_CELL; +const int fl_context_table = Fl_Table::CONTEXT_TABLE; +const int fl_context_rc_resize = Fl_Table::CONTEXT_RC_RESIZE; + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" void table_draw_cell_hook(void * ud, int e, int r, int c, int x, int y, int w, int h); + + + + +// Non-friend protected access + +class Friend_Table : Fl_Table { +public: + using Fl_Table::hscrollbar; + using Fl_Table::vscrollbar; + using Fl_Table::table; + + using Fl_Table::is_fltk_container; + + using Fl_Table::scroll_cb; + + using Fl_Table::col_scroll_position; + using Fl_Table::row_scroll_position; + + using Fl_Table::change_cursor; + using Fl_Table::ResizeFlag; + using Fl_Table::cursor2rowcol; + + using Fl_Table::recalc_dimensions; + using Fl_Table::table_resized; + using Fl_Table::table_scrolled; + + using Fl_Table::redraw_range; + using Fl_Table::damage_zone; + using Fl_Table::find_cell; + using Fl_Table::get_bounds; + using Fl_Table::row_col_clamp; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Table : public Fl_Table { +public: + using Fl_Table::Fl_Table; + + friend void fl_table_draw(TABLE t); + friend void fl_table_draw_cell(TABLE t, int e, int r, int c, int x, int y, int w, int h); + friend int fl_table_handle(TABLE t, int e); + + void draw(); + void draw_cell(Fl_Table::TableContext e, int r=0, int c=0, int x=0, int y=0, int w=0, int h=0); + int handle(int e); +}; + +void My_Table::draw() { + widget_draw_hook(this->user_data()); +} + +void My_Table::draw_cell(Fl_Table::TableContext e, int r, int c, int x, int y, int w, int h) { + table_draw_cell_hook(this->user_data(), static_cast<int>(e), r, c, x, y, w, h); +} + +int My_Table::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TABLE new_fl_table(int x, int y, int w, int h, char * label) { + My_Table *t = new My_Table(x, y, w, h, label); + return t; +} + +void free_fl_table(TABLE t) { + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Table*>(t); + } +} + + + + +void * fl_table_hscrollbar(TABLE t) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::hscrollbar)); +} + +void * fl_table_vscrollbar(TABLE t) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::vscrollbar)); +} + +void * fl_table_table(TABLE t) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::table)); +} + + + + +void fl_table_add(TABLE t, void * w) { + static_cast<Fl_Table*>(t)->add(static_cast<Fl_Widget*>(w)); +} + +void fl_table_insert(TABLE t, void * w, int p) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + static_cast<Fl_Table*>(t)->insert(ref, p); +} + +void fl_table_insert2(TABLE t, void * w, void * b) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + static_cast<Fl_Table*>(t)->insert(ref, static_cast<Fl_Widget*>(b)); +} + +void fl_table_remove(TABLE t, void * w) { + Fl_Widget &ref = *(static_cast<Fl_Widget*>(w)); + static_cast<Fl_Table*>(t)->remove(ref); +} + + + + +void * fl_table_child(TABLE t, int p) { + return static_cast<Fl_Table*>(t)->child(p); +} + +int fl_table_find(TABLE t, void * w) { + return static_cast<Fl_Table*>(t)->find(static_cast<Fl_Widget*>(w)); +} + +int fl_table_children(TABLE t) { + return static_cast<Fl_Table*>(t)->children(); +} + +int fl_table_is_fltk_container(TABLE t) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::is_fltk_container))(); +} + + + + +void fl_table_begin(TABLE t) { + static_cast<Fl_Table*>(t)->begin(); +} + +void fl_table_end(TABLE t) { + static_cast<Fl_Table*>(t)->end(); +} + + + + +void fl_table_set_callback(TABLE t, void * f) { + static_cast<Fl_Table*>(t)->callback + (reinterpret_cast<Fl_Callback_p>(f), static_cast<Fl_Table*>(t)->user_data()); +} + +int fl_table_callback_col(TABLE t) { + return static_cast<Fl_Table*>(t)->callback_col(); +} + +int fl_table_callback_row(TABLE t) { + return static_cast<Fl_Table*>(t)->callback_row(); +} + +int fl_table_callback_context(TABLE t) { + return static_cast<Fl_Table*>(t)->callback_context(); +} + +void fl_table_do_callback(TABLE t, int x, int r, int c) { + static_cast<Fl_Table*>(t)->do_callback(static_cast<Fl_Table::TableContext>(x), r, c); +} + +void fl_table_when(TABLE t, unsigned char w) { + static_cast<Fl_Table*>(t)->when(static_cast<Fl_When>(w)); +} + +void fl_table_scroll_cb(void * s, TABLE t) { + Friend_Table::scroll_cb(static_cast<Fl_Widget*>(s), t); +} + + + + +int fl_table_get_col_header(TABLE t) { + return static_cast<Fl_Table*>(t)->col_header(); +} + +void fl_table_set_col_header(TABLE t, int f) { + static_cast<Fl_Table*>(t)->col_header(f); +} + +unsigned int fl_table_get_col_header_color(TABLE t) { + return static_cast<Fl_Table*>(t)->col_header_color(); +} + +void fl_table_set_col_header_color(TABLE t, unsigned int c) { + static_cast<Fl_Table*>(t)->col_header_color(static_cast<Fl_Color>(c)); +} + +int fl_table_get_col_header_height(TABLE t) { + return static_cast<Fl_Table*>(t)->col_header_height(); +} + +void fl_table_set_col_header_height(TABLE t, int h) { + static_cast<Fl_Table*>(t)->col_header_height(h); +} + +int fl_table_get_col_width(TABLE t, int c) { + return static_cast<Fl_Table*>(t)->col_width(c); +} + +void fl_table_set_col_width(TABLE t, int c, int w) { + static_cast<Fl_Table*>(t)->col_width(c, w); +} + +void fl_table_col_width_all(TABLE t, int w) { + static_cast<Fl_Table*>(t)->col_width_all(w); +} + +int fl_table_get_cols(TABLE t) { + return static_cast<Fl_Table*>(t)->cols(); +} + +void fl_table_set_cols(TABLE t, int c) { + static_cast<Fl_Table*>(t)->cols(c); +} + +int fl_table_get_col_position(TABLE t) { + return static_cast<Fl_Table*>(t)->col_position(); +} + +void fl_table_set_col_position(TABLE t, int c) { + static_cast<Fl_Table*>(t)->col_position(c); +} + +long fl_table_col_scroll_position(TABLE t, int c) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::col_scroll_position))(c); +} + +int fl_table_get_col_resize(TABLE t) { + return static_cast<Fl_Table*>(t)->col_resize(); +} + +void fl_table_set_col_resize(TABLE t, int f) { + static_cast<Fl_Table*>(t)->col_resize(f); +} + +int fl_table_get_col_resize_min(TABLE t) { + return static_cast<Fl_Table*>(t)->col_resize_min(); +} + +void fl_table_set_col_resize_min(TABLE t, int v) { + static_cast<Fl_Table*>(t)->col_resize_min(v); +} + + + + +int fl_table_get_row_header(TABLE t) { + return static_cast<Fl_Table*>(t)->row_header(); +} + +void fl_table_set_row_header(TABLE t, int f) { + static_cast<Fl_Table*>(t)->row_header(f); +} + +unsigned int fl_table_get_row_header_color(TABLE t) { + return static_cast<Fl_Table*>(t)->row_header_color(); +} + +void fl_table_set_row_header_color(TABLE t, unsigned int c) { + static_cast<Fl_Table*>(t)->row_header_color(static_cast<Fl_Color>(c)); +} + +int fl_table_get_row_header_width(TABLE t) { + return static_cast<Fl_Table*>(t)->row_header_width(); +} + +void fl_table_set_row_header_width(TABLE t, int w) { + static_cast<Fl_Table*>(t)->row_header_width(w); +} + +int fl_table_get_row_height(TABLE t, int r) { + return static_cast<Fl_Table*>(t)->row_height(r); +} + +void fl_table_set_row_height(TABLE t, int r, int h) { + static_cast<Fl_Table*>(t)->row_height(r, h); +} + +void fl_table_row_height_all(TABLE t, int h) { + static_cast<Fl_Table*>(t)->row_height_all(h); +} + +int fl_table_get_rows(TABLE t) { + return static_cast<Fl_Table*>(t)->rows(); +} + +void fl_table_set_rows(TABLE t, int r) { + static_cast<Fl_Table*>(t)->rows(r); +} + +int fl_table_get_row_position(TABLE t) { + return static_cast<Fl_Table*>(t)->row_position(); +} + +void fl_table_set_row_position(TABLE t, int r) { + static_cast<Fl_Table*>(t)->row_position(r); +} + +long fl_table_row_scroll_position(TABLE t, int r) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::row_scroll_position))(r); +} + +int fl_table_get_row_resize(TABLE t) { + return static_cast<Fl_Table*>(t)->row_resize(); +} + +void fl_table_set_row_resize(TABLE t, int f) { + static_cast<Fl_Table*>(t)->row_resize(f); +} + +int fl_table_get_row_resize_min(TABLE t) { + return static_cast<Fl_Table*>(t)->row_resize_min(); +} + +void fl_table_set_row_resize_min(TABLE t, int v) { + static_cast<Fl_Table*>(t)->row_resize_min(v); +} + +int fl_table_get_top_row(TABLE t) { + return static_cast<Fl_Table*>(t)->top_row(); +} + +void fl_table_set_top_row(TABLE t, int r) { + static_cast<Fl_Table*>(t)->top_row(r); +} + + + + +void fl_table_change_cursor(TABLE t, int c) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::change_cursor))(static_cast<Fl_Cursor>(c)); +} + +int fl_table_cursor2rowcol(TABLE t, int &r, int &c, int &f) { + Friend_Table::ResizeFlag ref; + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::cursor2rowcol))(r, c, ref); + f = static_cast<int>(ref); +} + +void fl_table_visible_cells(TABLE t, int &r1, int &r2, int &c1, int &c2) { + static_cast<Fl_Table*>(t)->visible_cells(r1, r2, c1, c2); +} + +void fl_table_get_selection(TABLE t, int &rt, int &cl, int &rb, int &cr) { + static_cast<Fl_Table*>(t)->get_selection(rt, cl, rb, cr); +} + +void fl_table_set_selection(TABLE t, int rt, int cl, int rb, int cr) { + static_cast<Fl_Table*>(t)->set_selection(rt, cl, rb, cr); +} + +int fl_table_is_selected(TABLE t, int r, int c) { + return static_cast<Fl_Table*>(t)->is_selected(r, c); +} + +int fl_table_move_cursor(TABLE t, int r, int c, int s) { + return static_cast<Fl_Table*>(t)->move_cursor(r, c, s); +} + +int fl_table_get_tab_cell_nav(TABLE t) { +#if FLTK_ABI_VERSION >= 10303 + return static_cast<Fl_Table*>(t)->tab_cell_nav(); +#else + (void)(t); + return 0; +#endif +} + +void fl_table_set_tab_cell_nav(TABLE t, int v) { +#if FLTK_ABI_VERSION >= 10303 + static_cast<Fl_Table*>(t)->tab_cell_nav(v); +#else + (void)(t); + (void)(v); +#endif +} + +int fl_table_get_table_box(TABLE t) { + return static_cast<Fl_Table*>(t)->table_box(); +} + +void fl_table_set_table_box(TABLE t, int v) { + static_cast<Fl_Table*>(t)->table_box(static_cast<Fl_Boxtype>(v)); +} + + + + +int fl_table_get_scrollbar_size(TABLE t) { +#if FLTK_ABI_VERSION >= 10301 + return static_cast<Fl_Table*>(t)->scrollbar_size(); +#else + (void)(t); + return 0; +#endif +} + +void fl_table_set_scrollbar_size(TABLE t, int v) { +#if FLTK_ABI_VERSION >= 10301 + static_cast<Fl_Table*>(t)->scrollbar_size(v); +#else + (void)(t); + (void)(v); +#endif +} + +void fl_table_resize(TABLE t, int x, int y, int w, int h) { + static_cast<Fl_Table*>(t)->resize(x, y, w, h); +} + +int fl_table_is_interactive_resize(TABLE t) { + return static_cast<Fl_Table*>(t)->is_interactive_resize(); +} + +void fl_table_init_sizes(TABLE t) { + static_cast<Fl_Table*>(t)->init_sizes(); +} + +void fl_table_recalc_dimensions(TABLE t) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::recalc_dimensions))(); +} + +void fl_table_table_resized(TABLE t) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::table_resized))(); +} + +void fl_table_table_scrolled(TABLE t) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::table_scrolled))(); +} + + + + +void fl_table_draw(TABLE t) { + static_cast<My_Table*>(t)->Fl_Table::draw(); +} + +void fl_table_draw_cell(TABLE t, int e, int r, int c, int x, int y, int w, int h) { + static_cast<My_Table*>(t)->Fl_Table::draw_cell + (static_cast<Fl_Table::TableContext>(e), r, c, x, y, w, h); +} + +void fl_table_redraw_range(TABLE t, int rt, int rb, int cl, int cr) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::redraw_range))(rt, rb, cl, cr); +} + +void fl_table_damage_zone(TABLE t, int rt, int cl, int rb, int cr, int rr, int rc) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::damage_zone))(rt, cl, rb, cr, rr, rc); +} + +int fl_table_find_cell(TABLE t, int e, int r, int c, int &x, int &y, int &w, int &h) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::find_cell)) + (static_cast<Fl_Table::TableContext>(e), r, c, x, y, w, h); +} + +void fl_table_get_bounds(TABLE t, int e, int &x, int &y, int &w, int &h) { + (static_cast<Fl_Table*>(t)->*(&Friend_Table::get_bounds)) + (static_cast<Fl_Table::TableContext>(e), x, y, w, h); +} + +int fl_table_row_col_clamp(TABLE t, int e, int &r, int &c) { + return (static_cast<Fl_Table*>(t)->*(&Friend_Table::row_col_clamp)) + (static_cast<Fl_Table::TableContext>(e), r, c); +} + +int fl_table_handle(TABLE t, int e) { + return static_cast<My_Table*>(t)->Fl_Table::handle(e); +} + + diff --git a/body/c_fl_table.h b/body/c_fl_table.h new file mode 100644 index 0000000..d93ef4f --- /dev/null +++ b/body/c_fl_table.h @@ -0,0 +1,135 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TABLE_GUARD +#define FL_TABLE_GUARD + + +extern "C" const int fl_context_none; +extern "C" const int fl_context_startpage; +extern "C" const int fl_context_endpage; +extern "C" const int fl_context_row_header; +extern "C" const int fl_context_col_header; +extern "C" const int fl_context_cell; +extern "C" const int fl_context_table; +extern "C" const int fl_context_rc_resize; + + +typedef void* TABLE; + + +extern "C" TABLE new_fl_table(int x, int y, int w, int h, char * label); +extern "C" void free_fl_table(TABLE t); + + +extern "C" void * fl_table_hscrollbar(TABLE t); +extern "C" void * fl_table_vscrollbar(TABLE t); +extern "C" void * fl_table_table(TABLE t); + + +extern "C" void fl_table_add(TABLE t, void * w); +extern "C" void fl_table_insert(TABLE t, void * w, int p); +extern "C" void fl_table_insert2(TABLE t, void * w, void * b); +extern "C" void fl_table_remove(TABLE t, void * w); + + +extern "C" void * fl_table_child(TABLE t, int p); +extern "C" int fl_table_find(TABLE t, void * w); +extern "C" int fl_table_children(TABLE t); +extern "C" int fl_table_is_fltk_container(TABLE t); + + +extern "C" void fl_table_begin(TABLE t); +extern "C" void fl_table_end(TABLE t); + + +extern "C" void fl_table_set_callback(TABLE t, void * f); +extern "C" int fl_table_callback_col(TABLE t); +extern "C" int fl_table_callback_row(TABLE t); +extern "C" int fl_table_callback_context(TABLE t); +extern "C" void fl_table_do_callback(TABLE t, int x, int r, int c); +extern "C" void fl_table_when(TABLE t, unsigned char w); +extern "C" void fl_table_scroll_cb(void * s, TABLE t); + + +extern "C" int fl_table_get_col_header(TABLE t); +extern "C" void fl_table_set_col_header(TABLE t, int f); +extern "C" unsigned int fl_table_get_col_header_color(TABLE t); +extern "C" void fl_table_set_col_header_color(TABLE t, unsigned int c); +extern "C" int fl_table_get_col_header_height(TABLE t); +extern "C" void fl_table_set_col_header_height(TABLE t, int h); +extern "C" int fl_table_get_col_width(TABLE t, int c); +extern "C" void fl_table_set_col_width(TABLE t, int c, int w); +extern "C" void fl_table_col_width_all(TABLE t, int w); +extern "C" int fl_table_get_cols(TABLE t); +extern "C" void fl_table_set_cols(TABLE t, int c); +extern "C" int fl_table_get_col_position(TABLE t); +extern "C" void fl_table_set_col_position(TABLE t, int c); +extern "C" long fl_table_col_scroll_position(TABLE t, int c); +extern "C" int fl_table_get_col_resize(TABLE t); +extern "C" void fl_table_set_col_resize(TABLE t, int f); +extern "C" int fl_table_get_col_resize_min(TABLE t); +extern "C" void fl_table_set_col_resize_min(TABLE t, int v); + + +extern "C" int fl_table_get_row_header(TABLE t); +extern "C" void fl_table_set_row_header(TABLE t, int f); +extern "C" unsigned int fl_table_get_row_header_color(TABLE t); +extern "C" void fl_table_set_row_header_color(TABLE t, unsigned int c); +extern "C" int fl_table_get_row_header_width(TABLE t); +extern "C" void fl_table_set_row_header_width(TABLE t, int w); +extern "C" int fl_table_get_row_height(TABLE t, int r); +extern "C" void fl_table_set_row_height(TABLE t, int r, int h); +extern "C" void fl_table_row_height_all(TABLE t, int h); +extern "C" int fl_table_get_rows(TABLE t); +extern "C" void fl_table_set_rows(TABLE t, int r); +extern "C" int fl_table_get_row_position(TABLE t); +extern "C" void fl_table_set_row_position(TABLE t, int r); +extern "C" long fl_table_row_scroll_position(TABLE t, int r); +extern "C" int fl_table_get_row_resize(TABLE t); +extern "C" void fl_table_set_row_resize(TABLE t, int f); +extern "C" int fl_table_get_row_resize_min(TABLE t); +extern "C" void fl_table_set_row_resize_min(TABLE t, int v); +extern "C" int fl_table_get_top_row(TABLE t); +extern "C" void fl_table_set_top_row(TABLE t, int r); + + +extern "C" void fl_table_change_cursor(TABLE t, int c); +extern "C" int fl_table_cursor2rowcol(TABLE t, int &r, int &c, int &f); +extern "C" void fl_table_visible_cells(TABLE t, int &r1, int &r2, int &c1, int &c2); +extern "C" void fl_table_get_selection(TABLE t, int &rt, int &cl, int &rb, int &cr); +extern "C" void fl_table_set_selection(TABLE t, int rt, int cl, int rb, int cr); +extern "C" int fl_table_is_selected(TABLE t, int r, int c); +extern "C" int fl_table_move_cursor(TABLE t, int r, int c, int s); +extern "C" int fl_table_get_tab_cell_nav(TABLE t); +extern "C" void fl_table_set_tab_cell_nav(TABLE t, int v); +extern "C" int fl_table_get_table_box(TABLE t); +extern "C" void fl_table_set_table_box(TABLE t, int v); + + +extern "C" int fl_table_get_scrollbar_size(TABLE t); +extern "C" void fl_table_set_scrollbar_size(TABLE t, int v); +extern "C" void fl_table_resize(TABLE t, int x, int y, int w, int h); +extern "C" int fl_table_is_interactive_resize(TABLE t); +extern "C" void fl_table_init_sizes(TABLE t); +extern "C" void fl_table_recalc_dimensions(TABLE t); +extern "C" void fl_table_table_resized(TABLE t); +extern "C" void fl_table_table_scrolled(TABLE t); + + +extern "C" void fl_table_draw(TABLE t); +extern "C" void fl_table_draw_cell(TABLE t, int e, int r, int c, int x, int y, int w, int h); +extern "C" void fl_table_redraw_range(TABLE t, int rt, int rb, int cl, int cr); +extern "C" void fl_table_damage_zone(TABLE t, int rt, int cl, int rb, int cr, int rr, int rc); +extern "C" int fl_table_find_cell(TABLE t, int e, int r, int c, int &x, int &y, int &w, int &h); +extern "C" void fl_table_get_bounds(TABLE t, int e, int &x, int &y, int &w, int &h); +extern "C" int fl_table_row_col_clamp(TABLE t, int e, int &r, int &c); +extern "C" int fl_table_handle(TABLE t, int e); + + +#endif + + diff --git a/body/c_fl_table_row.cpp b/body/c_fl_table_row.cpp new file mode 100644 index 0000000..0ded792 --- /dev/null +++ b/body/c_fl_table_row.cpp @@ -0,0 +1,134 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Table_Row.H> +#include "c_fl_table_row.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" void table_draw_cell_hook(void * ud, int e, int r, int c, int x, int y, int w, int h); + + + + +// Non-friend protected access + +class Friend_Table_Row : Fl_Table_Row { +public: + using Fl_Table_Row::find_cell; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Table_Row : public Fl_Table_Row { +public: + using Fl_Table_Row::Fl_Table_Row; + + friend void fl_table_row_draw(ROWTABLE t); + friend void fl_table_row_draw_cell(ROWTABLE t, int e, int r, int c, int x, int y, int w, int h); + friend int fl_table_row_handle(ROWTABLE t, int e); + + void draw(); + void draw_cell(Fl_Table::TableContext e, int r=0, int c=0, int x=0, int y=0, int w=0, int h=0); + int handle(int e); +}; + +void My_Table_Row::draw() { + widget_draw_hook(this->user_data()); +} + +void My_Table_Row::draw_cell(Fl_Table::TableContext e, int r, int c, int x, int y, int w, int h) { + table_draw_cell_hook(this->user_data(), static_cast<int>(e), r, c, x, y, w, h); +} + +int My_Table_Row::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +ROWTABLE new_fl_table_row(int x, int y, int w, int h, char * label) { + My_Table_Row *t = new My_Table_Row(x, y, w, h, label); + return t; +} + +void free_fl_table_row(ROWTABLE t) { + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Table_Row*>(t); + } +} + + + + +int fl_table_row_get_rows(ROWTABLE t) { + return static_cast<Fl_Table_Row*>(t)->rows(); +} + +void fl_table_row_set_rows(ROWTABLE t, int r) { + static_cast<Fl_Table_Row*>(t)->rows(r); +} + + + + +int fl_table_row_row_selected(ROWTABLE t, int r) { + return static_cast<Fl_Table_Row*>(t)->row_selected(r); +} + +int fl_table_row_select_row(ROWTABLE t, int r, int f) { + return static_cast<Fl_Table_Row*>(t)->select_row(r, f); +} + +void fl_table_row_select_all_rows(ROWTABLE t, int f) { + static_cast<Fl_Table_Row*>(t)->select_all_rows(f); +} + +int fl_table_row_get_type(ROWTABLE t) { + return static_cast<int>(static_cast<Fl_Table_Row*>(t)->type()); +} + +void fl_table_row_set_type(ROWTABLE t, int v) { + static_cast<Fl_Table_Row*>(t)->type(static_cast<Fl_Table_Row::TableRowSelectMode>(v)); +} + + + + +void fl_table_row_draw(ROWTABLE t) { + static_cast<My_Table_Row*>(t)->Fl_Table_Row::draw(); +} + +void fl_table_row_draw_cell(ROWTABLE t, int e, int r, int c, int x, int y, int w, int h) { + static_cast<My_Table_Row*>(t)->Fl_Table_Row::draw_cell + (static_cast<Fl_Table::TableContext>(e), r, c, x, y, w, h); +} + +int fl_table_row_find_cell(ROWTABLE t, int e, int r, int c, int &x, int &y, int &w, int &h) { + return (static_cast<Fl_Table_Row*>(t)->*(&Friend_Table_Row::find_cell)) + (static_cast<Fl_Table::TableContext>(e), r, c, x, y, w, h); +} + +int fl_table_row_handle(ROWTABLE t, int e) { + return static_cast<My_Table_Row*>(t)->Fl_Table_Row::handle(e); +} + + diff --git a/body/c_fl_table_row.h b/body/c_fl_table_row.h new file mode 100644 index 0000000..cb226c4 --- /dev/null +++ b/body/c_fl_table_row.h @@ -0,0 +1,38 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TABLE_ROW_GUARD +#define FL_TABLE_ROW_GUARD + + +typedef void* ROWTABLE; + + +extern "C" ROWTABLE new_fl_table_row(int x, int y, int w, int h, char * label); +extern "C" void free_fl_table_row(ROWTABLE t); + + +extern "C" int fl_table_row_get_rows(ROWTABLE t); +extern "C" void fl_table_row_set_rows(ROWTABLE t, int r); + + +extern "C" int fl_table_row_row_selected(ROWTABLE t, int r); +extern "C" int fl_table_row_select_row(ROWTABLE t, int r, int f); +extern "C" void fl_table_row_select_all_rows(ROWTABLE t, int f); +extern "C" int fl_table_row_get_type(ROWTABLE t); +extern "C" void fl_table_row_set_type(ROWTABLE t, int v); + + +extern "C" void fl_table_row_draw(ROWTABLE t); +extern "C" void fl_table_row_draw_cell(ROWTABLE t, int e, int r, int c, int x, int y, int w, int h); +extern "C" int fl_table_row_find_cell(ROWTABLE t, int e, int r, int c, + int &x, int &y, int &w, int &h); +extern "C" int fl_table_row_handle(ROWTABLE t, int e); + + +#endif + + diff --git a/body/c_fl_tabs.cpp b/body/c_fl_tabs.cpp new file mode 100644 index 0000000..4e09135 --- /dev/null +++ b/body/c_fl_tabs.cpp @@ -0,0 +1,116 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Tabs.H> +#include "c_fl_tabs.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Tabs : Fl_Tabs { +public: + using Fl_Tabs::redraw_tabs; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Tabs : public Fl_Tabs { +public: + using Fl_Tabs::Fl_Tabs; + + friend void fl_tabs_draw(TABS t); + friend int fl_tabs_handle(TABS t, int e); + + void draw(); + int handle(int e); +}; + +void My_Tabs::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Tabs::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TABS new_fl_tabs(int x, int y, int w, int h, char* label) { + My_Tabs *t = new My_Tabs(x, y, w, h, label); + return t; +} + +void free_fl_tabs(TABS t) { + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Tabs*>(t); + } +} + + + + +void fl_tabs_client_area(TABS t, int * x, int * y, int * w, int * h, int i) { + static_cast<Fl_Tabs*>(t)->client_area(*x,*y,*w,*h,i); +} + + + + +void * fl_tabs_get_push(TABS t) { + return static_cast<Fl_Tabs*>(t)->push(); +} + +void fl_tabs_set_push(TABS t, void * w) { + static_cast<Fl_Tabs*>(t)->push(static_cast<Fl_Widget*>(w)); +} + +void * fl_tabs_get_value(TABS t) { + return static_cast<Fl_Tabs*>(t)->value(); +} + +void fl_tabs_set_value(TABS t, void * w) { + static_cast<Fl_Tabs*>(t)->value(static_cast<Fl_Widget*>(w)); +} + +void * fl_tabs_which(TABS t, int x, int y) { + return static_cast<Fl_Tabs*>(t)->which(x,y); +} + + + + +void fl_tabs_draw(TABS t) { + static_cast<My_Tabs*>(t)->Fl_Tabs::draw(); +} + +void fl_tabs_redraw_tabs(TABS t) { + (static_cast<Fl_Tabs*>(t)->*(&Friend_Tabs::redraw_tabs))(); +} + +int fl_tabs_handle(TABS t, int e) { + return static_cast<My_Tabs*>(t)->Fl_Tabs::handle(e); +} + + diff --git a/body/c_fl_tabs.h b/body/c_fl_tabs.h new file mode 100644 index 0000000..3226b2d --- /dev/null +++ b/body/c_fl_tabs.h @@ -0,0 +1,35 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TABS_GUARD +#define FL_TABS_GUARD + + +typedef void* TABS; + + +extern "C" TABS new_fl_tabs(int x, int y, int w, int h, char* label); +extern "C" void free_fl_tabs(TABS t); + + +extern "C" void fl_tabs_client_area(TABS t, int * x, int * y, int * w, int * h, int i); + + +extern "C" void * fl_tabs_get_push(TABS t); +extern "C" void fl_tabs_set_push(TABS t, void * w); +extern "C" void * fl_tabs_get_value(TABS t); +extern "C" void fl_tabs_set_value(TABS t, void * w); +extern "C" void * fl_tabs_which(TABS t, int x, int y); + + +extern "C" void fl_tabs_draw(TABS t); +extern "C" void fl_tabs_redraw_tabs(TABS t); +extern "C" int fl_tabs_handle(TABS t, int e); + + +#endif + + diff --git a/body/c_fl_text_buffer.cpp b/body/c_fl_text_buffer.cpp new file mode 100644 index 0000000..2322984 --- /dev/null +++ b/body/c_fl_text_buffer.cpp @@ -0,0 +1,296 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Text_Buffer.H> +#include "c_fl_text_buffer.h" + + + + +class My_Text_Buffer : public Fl_Text_Buffer { +public: + using Fl_Text_Buffer::Fl_Text_Buffer; + int reference_count = 0; +}; + + + + +TEXTBUFFER new_fl_text_buffer(int rs, int pgs) { + My_Text_Buffer *tb = new My_Text_Buffer(rs, pgs); + return tb; +} + +void upref_fl_text_buffer(TEXTBUFFER tb) { + static_cast<My_Text_Buffer*>(tb)->reference_count += 1; +} + +void free_fl_text_buffer(TEXTBUFFER tb) { + if (static_cast<My_Text_Buffer*>(tb)->reference_count <= 0) { + delete static_cast<My_Text_Buffer*>(tb); + } else { + static_cast<My_Text_Buffer*>(tb)->reference_count -= 1; + } +} + + + + +void fl_text_buffer_add_modify_callback(TEXTBUFFER tb, void * cb, void * ud) { + static_cast<Fl_Text_Buffer*>(tb)->add_modify_callback + (reinterpret_cast<Fl_Text_Modify_Cb>(cb), ud); +} + +void fl_text_buffer_add_predelete_callback(TEXTBUFFER tb, void * cb, void * ud) { + static_cast<Fl_Text_Buffer*>(tb)->add_predelete_callback + (reinterpret_cast<Fl_Text_Predelete_Cb>(cb), ud); +} + +void fl_text_buffer_call_modify_callbacks(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->call_modify_callbacks(); +} + +void fl_text_buffer_call_predelete_callbacks(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->call_predelete_callbacks(); +} + + + + +int fl_text_buffer_loadfile(TEXTBUFFER tb, char * n, int b) { + return static_cast<Fl_Text_Buffer*>(tb)->loadfile(n,b); +} + +int fl_text_buffer_appendfile(TEXTBUFFER tb, char * n, int b) { + return static_cast<Fl_Text_Buffer*>(tb)->appendfile(n,b); +} + +int fl_text_buffer_insertfile(TEXTBUFFER tb, char * n, int p, int b) { + return static_cast<Fl_Text_Buffer*>(tb)->insertfile(n,p,b); +} + +int fl_text_buffer_outputfile(TEXTBUFFER tb, char * n, int f, int t, int b) { + return static_cast<Fl_Text_Buffer*>(tb)->outputfile(n,f,t,b); +} + +int fl_text_buffer_savefile(TEXTBUFFER tb, char * n, int b) { + return static_cast<Fl_Text_Buffer*>(tb)->savefile(n,b); +} + + + + +void fl_text_buffer_insert(TEXTBUFFER tb, int p, const char * item) { + static_cast<Fl_Text_Buffer*>(tb)->insert(p, item); +} + +void fl_text_buffer_append(TEXTBUFFER tb, const char * item) { + static_cast<Fl_Text_Buffer*>(tb)->append(item); +} + +void fl_text_buffer_replace(TEXTBUFFER tb, int s, int f, const char * text) { + static_cast<Fl_Text_Buffer*>(tb)->replace(s, f, text); +} + +void fl_text_buffer_remove(TEXTBUFFER tb, int s, int f) { + static_cast<Fl_Text_Buffer*>(tb)->remove(s, f); +} + +char * fl_text_buffer_get_text(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->text(); +} + +void fl_text_buffer_set_text(TEXTBUFFER tb, char * t) { + static_cast<Fl_Text_Buffer*>(tb)->text(t); +} + +char fl_text_buffer_byte_at(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->byte_at(p); +} + +unsigned int fl_text_buffer_char_at(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->char_at(p); +} + +char * fl_text_buffer_text_range(TEXTBUFFER tb, int s, int f) { + return static_cast<Fl_Text_Buffer*>(tb)->text_range(s, f); +} + +int fl_text_buffer_next_char(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->next_char(p); +} + +int fl_text_buffer_prev_char(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->prev_char(p); +} + + + + +int fl_text_buffer_count_displayed_characters(TEXTBUFFER tb, int s, int f) { + return static_cast<Fl_Text_Buffer*>(tb)->count_displayed_characters(s,f); +} + +int fl_text_buffer_count_lines(TEXTBUFFER tb, int s, int f) { + return static_cast<Fl_Text_Buffer*>(tb)->count_lines(s,f); +} + +int fl_text_buffer_length(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->length(); +} + +int fl_text_buffer_get_tab_distance(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->tab_distance(); +} + +void fl_text_buffer_set_tab_distance(TEXTBUFFER tb, int t) { + static_cast<Fl_Text_Buffer*>(tb)->tab_distance(t); +} + + + + +int fl_text_buffer_selection_position(TEXTBUFFER tb, int * s, int * e) { + return static_cast<Fl_Text_Buffer*>(tb)->selection_position(s, e); +} + +int fl_text_buffer_secondary_selection_position(TEXTBUFFER tb, int * s, int * e) { + return static_cast<Fl_Text_Buffer*>(tb)->secondary_selection_position(s,e); +} + +void fl_text_buffer_select(TEXTBUFFER tb, int s, int e) { + static_cast<Fl_Text_Buffer*>(tb)->select(s, e); +} + +void fl_text_buffer_secondary_select(TEXTBUFFER tb, int s, int e) { + static_cast<Fl_Text_Buffer*>(tb)->secondary_select(s,e); +} + +int fl_text_buffer_selected(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->selected(); +} + +int fl_text_buffer_secondary_selected(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->secondary_selected(); +} + +char * fl_text_buffer_selection_text(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->selection_text(); +} + +char * fl_text_buffer_secondary_selection_text(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->secondary_selection_text(); +} + +void fl_text_buffer_replace_selection(TEXTBUFFER tb, char * t) { + static_cast<Fl_Text_Buffer*>(tb)->replace_selection(t); +} + +void fl_text_buffer_replace_secondary_selection(TEXTBUFFER tb, char * t) { + static_cast<Fl_Text_Buffer*>(tb)->replace_secondary_selection(t); +} + +void fl_text_buffer_remove_selection(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->remove_selection(); +} + +void fl_text_buffer_remove_secondary_selection(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->remove_secondary_selection(); +} + +void fl_text_buffer_unselect(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->unselect(); +} + +void fl_text_buffer_secondary_unselect(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->secondary_unselect(); +} + + + + +void fl_text_buffer_highlight(TEXTBUFFER tb, int f, int t) { + static_cast<Fl_Text_Buffer*>(tb)->highlight(f,t); +} + +char * fl_text_buffer_highlight_text(TEXTBUFFER tb) { + return static_cast<Fl_Text_Buffer*>(tb)->highlight_text(); +} + +void fl_text_buffer_unhighlight(TEXTBUFFER tb) { + static_cast<Fl_Text_Buffer*>(tb)->unhighlight(); +} + + + + +int fl_text_buffer_findchar_forward(TEXTBUFFER tb, int start, unsigned int item, int * found) { + return static_cast<Fl_Text_Buffer*>(tb)->findchar_forward(start, item, found); +} + +int fl_text_buffer_findchar_backward(TEXTBUFFER tb, int start, unsigned int item, int * found) { + return static_cast<Fl_Text_Buffer*>(tb)->findchar_backward(start, item, found); +} + +int fl_text_buffer_search_forward(TEXTBUFFER tb, int start, const char * item, int * found, int mcase) { + return static_cast<Fl_Text_Buffer*>(tb)->search_forward(start, item, found, mcase); +} + +int fl_text_buffer_search_backward(TEXTBUFFER tb, int start, const char * item, int * found, int mcase) { + return static_cast<Fl_Text_Buffer*>(tb)->search_backward(start, item, found, mcase); +} + + + + +int fl_text_buffer_word_start(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->word_start(p); +} + +int fl_text_buffer_word_end(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->word_end(p); +} + +int fl_text_buffer_line_start(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->line_start(p); +} + +int fl_text_buffer_line_end(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->line_end(p); +} + +char * fl_text_buffer_line_text(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->line_text(p); +} + +int fl_text_buffer_skip_lines(TEXTBUFFER tb, int s, int l) { + return static_cast<Fl_Text_Buffer*>(tb)->skip_lines(s, l); +} + +int fl_text_buffer_rewind_lines(TEXTBUFFER tb, int s, int l) { + return static_cast<Fl_Text_Buffer*>(tb)->rewind_lines(s, l); +} + +int fl_text_buffer_skip_displayed_characters(TEXTBUFFER tb, int s, int n) { + return static_cast<Fl_Text_Buffer*>(tb)->skip_displayed_characters(s,n); +} + + + + +void fl_text_buffer_canundo(TEXTBUFFER tb, char f) { + return static_cast<Fl_Text_Buffer*>(tb)->canUndo(f); +} + +void fl_text_buffer_copy(TEXTBUFFER tb, TEXTBUFFER tb2, int s, int f, int i) { + static_cast<Fl_Text_Buffer*>(tb)->copy(static_cast<Fl_Text_Buffer*>(tb2),s,f,i); +} + +int fl_text_buffer_utf8_align(TEXTBUFFER tb, int p) { + return static_cast<Fl_Text_Buffer*>(tb)->utf8_align(p); +} + + diff --git a/body/c_fl_text_buffer.h b/body/c_fl_text_buffer.h new file mode 100644 index 0000000..ce4c262 --- /dev/null +++ b/body/c_fl_text_buffer.h @@ -0,0 +1,100 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TEXT_BUFFER_GUARD +#define FL_TEXT_BUFFER_GUARD + + +typedef void* TEXTBUFFER; + + +extern "C" TEXTBUFFER new_fl_text_buffer(int rs, int pgs); +extern "C" void upref_fl_text_buffer(TEXTBUFFER tb); +extern "C" void free_fl_text_buffer(TEXTBUFFER tb); + + +extern "C" void fl_text_buffer_add_modify_callback(TEXTBUFFER tb, void * cb, void * ud); +extern "C" void fl_text_buffer_add_predelete_callback(TEXTBUFFER tb, void * cb, void * ud); +extern "C" void fl_text_buffer_call_modify_callbacks(TEXTBUFFER tb); +extern "C" void fl_text_buffer_call_predelete_callbacks(TEXTBUFFER tb); + + +extern "C" int fl_text_buffer_loadfile(TEXTBUFFER tb, char * n, int b); +extern "C" int fl_text_buffer_appendfile(TEXTBUFFER tb, char * n, int b); +extern "C" int fl_text_buffer_insertfile(TEXTBUFFER tb, char * n, int p, int b); +extern "C" int fl_text_buffer_outputfile(TEXTBUFFER tb, char * n, int f, int t, int b); +extern "C" int fl_text_buffer_savefile(TEXTBUFFER tb, char * n, int b); + + +extern "C" void fl_text_buffer_insert(TEXTBUFFER tb, int p, const char * item); +extern "C" void fl_text_buffer_append(TEXTBUFFER tb, const char * item); +extern "C" void fl_text_buffer_replace(TEXTBUFFER tb, int s, int f, const char * text); +extern "C" void fl_text_buffer_remove(TEXTBUFFER tb, int s, int f); +extern "C" char * fl_text_buffer_get_text(TEXTBUFFER tb); +extern "C" void fl_text_buffer_set_text(TEXTBUFFER tb, char * t); +extern "C" char fl_text_buffer_byte_at(TEXTBUFFER tb, int p); +extern "C" unsigned int fl_text_buffer_char_at(TEXTBUFFER tb, int p); +extern "C" char * fl_text_buffer_text_range(TEXTBUFFER tb, int s, int f); +extern "C" int fl_text_buffer_next_char(TEXTBUFFER tb, int p); +extern "C" int fl_text_buffer_prev_char(TEXTBUFFER tb, int p); + + +extern "C" int fl_text_buffer_count_displayed_characters(TEXTBUFFER tb, int s, int f); +extern "C" int fl_text_buffer_count_lines(TEXTBUFFER tb, int s, int f); +extern "C" int fl_text_buffer_length(TEXTBUFFER tb); +extern "C" int fl_text_buffer_get_tab_distance(TEXTBUFFER tb); +extern "C" void fl_text_buffer_set_tab_distance(TEXTBUFFER tb, int t); + + +extern "C" int fl_text_buffer_selection_position(TEXTBUFFER tb, int * s, int * e); +extern "C" int fl_text_buffer_secondary_selection_position(TEXTBUFFER tb, int * s, int * e); +extern "C" void fl_text_buffer_select(TEXTBUFFER tb, int s, int e); +extern "C" void fl_text_buffer_secondary_select(TEXTBUFFER tb, int s, int e); +extern "C" int fl_text_buffer_selected(TEXTBUFFER tb); +extern "C" int fl_text_buffer_secondary_selected(TEXTBUFFER tb); +extern "C" char * fl_text_buffer_selection_text(TEXTBUFFER tb); +extern "C" char * fl_text_buffer_secondary_selection_text(TEXTBUFFER tb); +extern "C" void fl_text_buffer_replace_selection(TEXTBUFFER tb, char * t); +extern "C" void fl_text_buffer_replace_secondary_selection(TEXTBUFFER tb, char * t); +extern "C" void fl_text_buffer_remove_selection(TEXTBUFFER tb); +extern "C" void fl_text_buffer_remove_secondary_selection(TEXTBUFFER tb); +extern "C" void fl_text_buffer_unselect(TEXTBUFFER tb); +extern "C" void fl_text_buffer_secondary_unselect(TEXTBUFFER tb); + + +extern "C" void fl_text_buffer_highlight(TEXTBUFFER tb, int f, int t); +extern "C" char * fl_text_buffer_highlight_text(TEXTBUFFER tb); +extern "C" void fl_text_buffer_unhighlight(TEXTBUFFER tb); + + +extern "C" int fl_text_buffer_findchar_forward(TEXTBUFFER tb, int start, + unsigned int item, int * found); +extern "C" int fl_text_buffer_findchar_backward(TEXTBUFFER tb, int start, + unsigned int item, int * found); +extern "C" int fl_text_buffer_search_forward(TEXTBUFFER tb, int start, + const char * item, int * found, int mcase); +extern "C" int fl_text_buffer_search_backward(TEXTBUFFER tb, int start, + const char * item, int * found, int mcase); + + +extern "C" int fl_text_buffer_word_start(TEXTBUFFER tb, int p); +extern "C" int fl_text_buffer_word_end(TEXTBUFFER tb, int p); +extern "C" int fl_text_buffer_line_start(TEXTBUFFER tb, int p); +extern "C" int fl_text_buffer_line_end(TEXTBUFFER tb, int p); +extern "C" char * fl_text_buffer_line_text(TEXTBUFFER tb, int p); +extern "C" int fl_text_buffer_skip_lines(TEXTBUFFER tb, int s, int l); +extern "C" int fl_text_buffer_rewind_lines(TEXTBUFFER tb, int s, int l); +extern "C" int fl_text_buffer_skip_displayed_characters(TEXTBUFFER tb, int s, int n); + + +extern "C" void fl_text_buffer_canundo(TEXTBUFFER tb, char f); +extern "C" void fl_text_buffer_copy(TEXTBUFFER tb, TEXTBUFFER tb2, int s, int f, int i); +extern "C" int fl_text_buffer_utf8_align(TEXTBUFFER tb, int p); + + +#endif + + diff --git a/body/c_fl_text_display.cpp b/body/c_fl_text_display.cpp new file mode 100644 index 0000000..bf9dacf --- /dev/null +++ b/body/c_fl_text_display.cpp @@ -0,0 +1,603 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Text_Display.H> +#include <FL/Fl_Text_Buffer.H> +#include "c_fl_text_display.h" +#include "c_fl_text_buffer.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Text_Display : Fl_Text_Display { +public: + using Fl_Text_Display::buffer_modified_cb; + using Fl_Text_Display::buffer_predelete_cb; + + using Fl_Text_Display::find_line_end; + using Fl_Text_Display::find_x; + using Fl_Text_Display::position_to_line; + using Fl_Text_Display::position_to_linecol; + using Fl_Text_Display::xy_to_position; + using Fl_Text_Display::xy_to_rowcol; + + using Fl_Text_Display::wrap_uses_character; + using Fl_Text_Display::wrapped_line_counter; + + using Fl_Text_Display::calc_last_char; + using Fl_Text_Display::calc_line_starts; + using Fl_Text_Display::offset_line_starts; + + using Fl_Text_Display::absolute_top_line_number; + using Fl_Text_Display::get_absolute_top_line_number; + using Fl_Text_Display::maintain_absolute_top_line_number; + using Fl_Text_Display::maintaining_absolute_top_line_number; + using Fl_Text_Display::reset_absolute_top_line_number; + + using Fl_Text_Display::empty_vlines; + using Fl_Text_Display::longest_vline; + using Fl_Text_Display::vline_length; + + using Fl_Text_Display::measure_proportional_character; + using Fl_Text_Display::measure_vline; + using Fl_Text_Display::string_width; + + using Fl_Text_Display::scroll_; + using Fl_Text_Display::update_h_scrollbar; + using Fl_Text_Display::update_v_scrollbar; + + using Fl_Text_Display::clear_rect; + using Fl_Text_Display::display_insert; + using Fl_Text_Display::draw_cursor; + using Fl_Text_Display::draw_line_numbers; + using Fl_Text_Display::draw_range; + using Fl_Text_Display::draw_string; + using Fl_Text_Display::draw_text; + using Fl_Text_Display::draw_vline; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Text_Display : public Fl_Text_Display { +public: + using Fl_Text_Display::Fl_Text_Display; + + friend void fl_text_display_draw(TEXTDISPLAY td); + friend int fl_text_display_handle(TEXTDISPLAY td, int e); + + void draw(); + int handle(int e); +}; + +void My_Text_Display::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Text_Display::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TEXTDISPLAY new_fl_text_display(int x, int y, int w, int h, char* label) { + My_Text_Display *td = new My_Text_Display(x, y, w, h, label); + return td; +} + +void free_fl_text_display(TEXTDISPLAY td) { + if (fl_inside_callback) { + fl_delete_widget(td); + } else { + delete static_cast<My_Text_Display*>(td); + } +} + + + + +// this actually never gets called, since an access to the text_buffer +// object is stored on the Ada side of things +TEXTBUFFER fl_text_display_get_buffer(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->buffer(); +} + +void fl_text_display_set_buffer(TEXTDISPLAY td, TEXTBUFFER tb) { + static_cast<Fl_Text_Display*>(td)->buffer(static_cast<Fl_Text_Buffer*>(tb)); +} + +void fl_text_display_buffer_modified_cb(int p, int i, int d, int r, + const char * t, TEXTDISPLAY td) +{ + Friend_Text_Display::buffer_modified_cb(p, i, d, r, t, static_cast<Fl_Text_Display*>(td)); +} + +void fl_text_display_buffer_predelete_cb(int p, int d, TEXTDISPLAY td) { + Friend_Text_Display::buffer_predelete_cb(p, d, static_cast<Fl_Text_Display*>(td)); +} + + + + +void fl_text_display_highlight_data(TEXTDISPLAY td, TEXTBUFFER tb, void * st, int len) { + static_cast<Fl_Text_Display*>(td)->highlight_data + (static_cast<Fl_Text_Buffer*>(tb), + static_cast<Fl_Text_Display::Style_Table_Entry*>(st), + len, 0, 0, 0); +} + +void fl_text_display_highlight_data2(TEXTDISPLAY td, TEXTBUFFER tb, void * st, int len, + char us, void * cb, void * a) +{ + static_cast<Fl_Text_Display*>(td)->highlight_data + (static_cast<Fl_Text_Buffer*>(tb), + static_cast<Fl_Text_Display::Style_Table_Entry*>(st), + len, us, reinterpret_cast<Fl_Text_Display::Unfinished_Style_Cb>(cb), a); +} + +int fl_text_display_position_style(TEXTDISPLAY td, int s, int l, int i) { + return static_cast<Fl_Text_Display*>(td)->position_style(s, l, i); +} + + + + +double fl_text_display_col_to_x(TEXTDISPLAY td, double c) { + return static_cast<Fl_Text_Display*>(td)->col_to_x(c); +} + +double fl_text_display_x_to_col(TEXTDISPLAY td, double x) { + return static_cast<Fl_Text_Display*>(td)->x_to_col(x); +} + +int fl_text_display_in_selection(TEXTDISPLAY td, int x, int y) { + return static_cast<Fl_Text_Display*>(td)->in_selection(x, y); +} + +int fl_text_display_position_to_xy(TEXTDISPLAY td, int p, int * x, int * y) { + return static_cast<Fl_Text_Display*>(td)->position_to_xy(p, x, y); +} + +void fl_text_display_find_line_end(TEXTDISPLAY td, int sp, int spils, int &le, int &nls) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::find_line_end)) + (sp, spils!=0, &le, &nls); +} + +int fl_text_display_find_x(TEXTDISPLAY td, const char * str, int l, int s, int x) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::find_x))(str, l, s, x); +} + +int fl_text_display_position_to_line(TEXTDISPLAY td, int p, int &ln) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::position_to_line))(p, &ln); +} + +int fl_text_display_position_to_linecol(TEXTDISPLAY td, int p, int &ln, int &c) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::position_to_linecol)) + (p, &ln, &c); +} + +int fl_text_display_xy_to_position(TEXTDISPLAY td, int x, int y, int k) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::xy_to_position))(x, y, k); +} + +void fl_text_display_xy_to_rowcol(TEXTDISPLAY td, int x, int y, int &r, int &c, int k) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::xy_to_rowcol))(x, y, &r, &c, k); +} + + + + +unsigned int fl_text_display_get_cursor_color(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->cursor_color(); +} + +void fl_text_display_set_cursor_color(TEXTDISPLAY td, unsigned int c) { + static_cast<Fl_Text_Display*>(td)->cursor_color(c); +} + +void fl_text_display_set_cursor_style(TEXTDISPLAY td, int s) { + static_cast<Fl_Text_Display*>(td)->cursor_style(s); +} + +void fl_text_display_hide_cursor(TEXTDISPLAY td) { + static_cast<Fl_Text_Display*>(td)->hide_cursor(); +} + +void fl_text_display_show_cursor(TEXTDISPLAY td) { + static_cast<Fl_Text_Display*>(td)->show_cursor(); +} + + + + +unsigned int fl_text_display_get_text_color(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->textcolor(); +} + +void fl_text_display_set_text_color(TEXTDISPLAY td, unsigned int c) { + static_cast<Fl_Text_Display*>(td)->textcolor(static_cast<Fl_Color>(c)); +} + +int fl_text_display_get_text_font(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->textfont(); +} + +void fl_text_display_set_text_font(TEXTDISPLAY td, int f) { + static_cast<Fl_Text_Display*>(td)->textfont(static_cast<Fl_Font>(f)); +} + +int fl_text_display_get_text_size(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->textsize(); +} + +void fl_text_display_set_text_size(TEXTDISPLAY td, int s) { + static_cast<Fl_Text_Display*>(td)->textsize(static_cast<Fl_Fontsize>(s)); +} + + + + +void fl_text_display_insert(TEXTDISPLAY td, char * i) { + static_cast<Fl_Text_Display*>(td)->insert(i); +} + +void fl_text_display_overstrike(TEXTDISPLAY td, char * t) { + static_cast<Fl_Text_Display*>(td)->overstrike(t); +} + +int fl_text_display_get_insert_pos(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->insert_position(); +} + +void fl_text_display_set_insert_pos(TEXTDISPLAY td, int p) { + static_cast<Fl_Text_Display*>(td)->insert_position(p); +} + +void fl_text_display_show_insert_pos(TEXTDISPLAY td) { + static_cast<Fl_Text_Display*>(td)->show_insert_position(); +} + + + + +int fl_text_display_word_start(TEXTDISPLAY td, int p) { + return static_cast<Fl_Text_Display*>(td)->word_start(p); +} + +int fl_text_display_word_end(TEXTDISPLAY td, int p) { + return static_cast<Fl_Text_Display*>(td)->word_end(p); +} + +void fl_text_display_next_word(TEXTDISPLAY td) { + static_cast<Fl_Text_Display*>(td)->next_word(); +} + +void fl_text_display_previous_word(TEXTDISPLAY td) { + static_cast<Fl_Text_Display*>(td)->previous_word(); +} + + + + +void fl_text_display_wrap_mode(TEXTDISPLAY td, int w, int m) { + static_cast<Fl_Text_Display*>(td)->wrap_mode(w, m); +} + +int fl_text_display_wrapped_row(TEXTDISPLAY td, int r) { + return static_cast<Fl_Text_Display*>(td)->wrapped_row(r); +} + +int fl_text_display_wrapped_column(TEXTDISPLAY td, int r, int c) { + return static_cast<Fl_Text_Display*>(td)->wrapped_column(r, c); +} + +int fl_text_display_wrap_uses_character(TEXTDISPLAY td, int lep) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::wrap_uses_character))(lep); +} + +void fl_text_display_wrapped_line_counter(TEXTDISPLAY td, void * buf, int startPos, + int maxPos, int maxLines, int spils, int sbo, int &retPos, int &retLines, int &retLineStart, + int &retLineEnd, int cllmnl) +{ + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::wrapped_line_counter)) + (static_cast<Fl_Text_Buffer*>(buf), startPos, maxPos, maxLines, spils!=0, sbo, + &retPos, &retLines, &retLineStart, &retLineEnd, cllmnl!=0); +} + + + + +int fl_text_display_line_start(TEXTDISPLAY td, int s) { + return static_cast<Fl_Text_Display*>(td)->line_start(s); +} + +int fl_text_display_line_end(TEXTDISPLAY td, int s, int p) { + return static_cast<Fl_Text_Display*>(td)->line_end(s, p); +} + +int fl_text_display_count_lines(TEXTDISPLAY td, int s, int f, int p) { + return static_cast<Fl_Text_Display*>(td)->count_lines(s, f, p); +} + +int fl_text_display_skip_lines(TEXTDISPLAY td, int s, int l, int p) { + return static_cast<Fl_Text_Display*>(td)->skip_lines(s, l, p); +} + +int fl_text_display_rewind_lines(TEXTDISPLAY td, int s, int l) { + return static_cast<Fl_Text_Display*>(td)->rewind_lines(s, l); +} + +void fl_text_display_calc_last_char(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::calc_last_char))(); +} + +void fl_text_display_calc_line_starts(TEXTDISPLAY td, int s, int f) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::calc_line_starts))(s, f); +} + +void fl_text_display_offset_line_starts(TEXTDISPLAY td, int t) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::offset_line_starts))(t); +} + + + + +void fl_text_display_absolute_top_line_number(TEXTDISPLAY td, int c) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::absolute_top_line_number))(c); +} + +int fl_text_display_get_absolute_top_line_number(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::get_absolute_top_line_number))(); +} + +void fl_text_display_maintain_absolute_top_line_number(TEXTDISPLAY td, int s) { + (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::maintain_absolute_top_line_number))(s); +} + +int fl_text_display_maintaining_absolute_top_line_number(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::maintaining_absolute_top_line_number))(); +} + +void fl_text_display_reset_absolute_top_line_number(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::reset_absolute_top_line_number))(); +} + + + + +int fl_text_display_empty_vlines(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::empty_vlines))(); +} + +int fl_text_display_longest_vline(TEXTDISPLAY td) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::longest_vline))(); +} + +int fl_text_display_vline_length(TEXTDISPLAY td, int l) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::vline_length))(l); +} + + + + +unsigned int fl_text_display_get_linenumber_align(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_align(); +} + +void fl_text_display_set_linenumber_align(TEXTDISPLAY td, unsigned int a) { + static_cast<Fl_Text_Display*>(td)->linenumber_align(a); +} + +unsigned int fl_text_display_get_linenumber_bgcolor(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_bgcolor(); +} + +void fl_text_display_set_linenumber_bgcolor(TEXTDISPLAY td, unsigned int c) { + static_cast<Fl_Text_Display*>(td)->linenumber_bgcolor(c); +} + +unsigned int fl_text_display_get_linenumber_fgcolor(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_fgcolor(); +} + +void fl_text_display_set_linenumber_fgcolor(TEXTDISPLAY td, unsigned int c) { + static_cast<Fl_Text_Display*>(td)->linenumber_fgcolor(c); +} + +int fl_text_display_get_linenumber_font(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_font(); +} + +void fl_text_display_set_linenumber_font(TEXTDISPLAY td, int f) { + static_cast<Fl_Text_Display*>(td)->linenumber_font(f); +} + +int fl_text_display_get_linenumber_size(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_size(); +} + +void fl_text_display_set_linenumber_size(TEXTDISPLAY td, int s) { + static_cast<Fl_Text_Display*>(td)->linenumber_size(s); +} + +int fl_text_display_get_linenumber_width(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_width(); +} + +void fl_text_display_set_linenumber_width(TEXTDISPLAY td, int w) { + static_cast<Fl_Text_Display*>(td)->linenumber_width(w); +} + +const char * fl_text_display_get_linenumber_format(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->linenumber_format(); +} + +void fl_text_display_set_linenumber_format(TEXTDISPLAY td, const char * v) { + static_cast<Fl_Text_Display*>(td)->linenumber_format(v); +} + + + + +double fl_text_display_measure_proportional_character(TEXTDISPLAY td, const char * str, + int xpix, int pos) +{ + return (static_cast<Fl_Text_Display*>(td)->* + (&Friend_Text_Display::measure_proportional_character))(str, xpix, pos); +} + +int fl_text_display_measure_vline(TEXTDISPLAY td, int line) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::measure_vline))(line); +} + +double fl_text_display_string_width(TEXTDISPLAY td, const char * str, int len, int s) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::string_width))(str, len, s); +} + + + + +int fl_text_display_move_down(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->move_down(); +} + +int fl_text_display_move_left(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->move_left(); +} + +int fl_text_display_move_right(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->move_right(); +} + +int fl_text_display_move_up(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->move_up(); +} + + + + +void fl_text_display_scroll(TEXTDISPLAY td, int l, int c) { + static_cast<Fl_Text_Display*>(td)->scroll(l, c); +} + +int fl_text_display_scroll2(TEXTDISPLAY td, int l, int p) { + return (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::scroll_))(l, p); +} + +unsigned int fl_text_display_get_scrollbar_align(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->scrollbar_align(); +} + +void fl_text_display_set_scrollbar_align(TEXTDISPLAY td, unsigned int a) { + static_cast<Fl_Text_Display*>(td)->scrollbar_align(a); +} + +int fl_text_display_get_scrollbar_width(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->scrollbar_width(); +} + +void fl_text_display_set_scrollbar_width(TEXTDISPLAY td, int w) { + static_cast<Fl_Text_Display*>(td)->scrollbar_width(w); +} + +void fl_text_display_update_h_scrollbar(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::update_h_scrollbar))(); +} + +void fl_text_display_update_v_scrollbar(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::update_v_scrollbar))(); +} + + + + +int fl_text_display_get_shortcut(TEXTDISPLAY td) { + return static_cast<Fl_Text_Display*>(td)->shortcut(); +} + +void fl_text_display_set_shortcut(TEXTDISPLAY td, int s) { + static_cast<Fl_Text_Display*>(td)->shortcut(s); +} + + + + +void fl_text_display_resize(TEXTDISPLAY td, int x, int y, int w, int h) { + static_cast<Fl_Text_Display*>(td)->resize(x, y, w, h); +} + + + + +void fl_text_display_clear_rect(TEXTDISPLAY td, int s, int x, int y, int w, int h) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::clear_rect))(s, x, y, w, h); +} + +void fl_text_display_display_insert(TEXTDISPLAY td) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::display_insert))(); +} + +void fl_text_display_redisplay_range(TEXTDISPLAY td, int s, int f) { + static_cast<Fl_Text_Display*>(td)->redisplay_range(s,f); +} + +void fl_text_display_draw(TEXTDISPLAY td) { + static_cast<My_Text_Display*>(td)->Fl_Text_Display::draw(); +} + +void fl_text_display_draw_cursor(TEXTDISPLAY td, int x, int y) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_cursor))(x, y); +} + +void fl_text_display_draw_line_numbers(TEXTDISPLAY td, int c) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_line_numbers))(c!=0); +} + +void fl_text_display_draw_range(TEXTDISPLAY td, int s, int f) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_range))(s, f); +} + +void fl_text_display_draw_string(TEXTDISPLAY td, int s, int x, int y, int r, + const char * str, int n) +{ + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_string))(s, x, y, r, str, n); +} + +void fl_text_display_draw_text(TEXTDISPLAY td, int x, int y, int w, int h) { + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_text))(x, y, w, h); +} + +void fl_text_display_draw_vline(TEXTDISPLAY td, int line, int left, int right, + int lchar, int rchar) +{ + (static_cast<Fl_Text_Display*>(td)->*(&Friend_Text_Display::draw_vline)) + (line, left, right, lchar, rchar); +} + +int fl_text_display_handle(TEXTDISPLAY td, int e) { + return static_cast<My_Text_Display*>(td)->Fl_Text_Display::handle(e); +} + + diff --git a/body/c_fl_text_display.h b/body/c_fl_text_display.h new file mode 100644 index 0000000..5a39ae1 --- /dev/null +++ b/body/c_fl_text_display.h @@ -0,0 +1,166 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TEXT_DISPLAY_GUARD +#define FL_TEXT_DISPLAY_GUARD + +#include "c_fl_text_buffer.h" + + +typedef void* TEXTDISPLAY; + + +extern "C" TEXTDISPLAY new_fl_text_display(int x, int y, int w, int h, char* label); +extern "C" void free_fl_text_display(TEXTDISPLAY td); + + +extern "C" TEXTBUFFER fl_text_display_get_buffer(TEXTDISPLAY td); +extern "C" void fl_text_display_set_buffer(TEXTDISPLAY td, TEXTBUFFER tb); +extern "C" void fl_text_display_buffer_modified_cb(int p, int i, int d, int r, + const char * t, TEXTDISPLAY td); +extern "C" void fl_text_display_buffer_predelete_cb(int p, int d, TEXTDISPLAY td); + + +extern "C" void fl_text_display_highlight_data(TEXTDISPLAY td, TEXTBUFFER tb, void * st, int len); +extern "C" void fl_text_display_highlight_data2(TEXTDISPLAY td, TEXTBUFFER tb, void * st, int len, + char us, void * cb, void * a); +extern "C" int fl_text_display_position_style(TEXTDISPLAY td, int s, int l, int i); + + +extern "C" double fl_text_display_col_to_x(TEXTDISPLAY td, double c); +extern "C" double fl_text_display_x_to_col(TEXTDISPLAY td, double x); +extern "C" int fl_text_display_in_selection(TEXTDISPLAY td, int x, int y); +extern "C" int fl_text_display_position_to_xy(TEXTDISPLAY td, int p, int * x, int * y); +extern "C" void fl_text_display_find_line_end(TEXTDISPLAY td, int sp, int spils, int &le, int &nls); +extern "C" int fl_text_display_find_x(TEXTDISPLAY td, const char * str, int l, int s, int x); +extern "C" int fl_text_display_position_to_line(TEXTDISPLAY td, int p, int &ln); +extern "C" int fl_text_display_position_to_linecol(TEXTDISPLAY td, int p, int &ln, int &c); +extern "C" int fl_text_display_xy_to_position(TEXTDISPLAY td, int x, int y, int k); +extern "C" void fl_text_display_xy_to_rowcol(TEXTDISPLAY td, int x, int y, int &r, int &c, int k); + + +extern "C" unsigned int fl_text_display_get_cursor_color(TEXTDISPLAY td); +extern "C" void fl_text_display_set_cursor_color(TEXTDISPLAY td, unsigned int c); +extern "C" void fl_text_display_set_cursor_style(TEXTDISPLAY td, int s); +extern "C" void fl_text_display_hide_cursor(TEXTDISPLAY td); +extern "C" void fl_text_display_show_cursor(TEXTDISPLAY td); + + +extern "C" unsigned int fl_text_display_get_text_color(TEXTDISPLAY td); +extern "C" void fl_text_display_set_text_color(TEXTDISPLAY td, unsigned int c); +extern "C" int fl_text_display_get_text_font(TEXTDISPLAY td); +extern "C" void fl_text_display_set_text_font(TEXTDISPLAY td, int f); +extern "C" int fl_text_display_get_text_size(TEXTDISPLAY td); +extern "C" void fl_text_display_set_text_size(TEXTDISPLAY td, int s); + + +extern "C" void fl_text_display_insert(TEXTDISPLAY td, char * i); +extern "C" void fl_text_display_overstrike(TEXTDISPLAY td, char * t); +extern "C" int fl_text_display_get_insert_pos(TEXTDISPLAY td); +extern "C" void fl_text_display_set_insert_pos(TEXTDISPLAY td, int p); +extern "C" void fl_text_display_show_insert_pos(TEXTDISPLAY td); + + +extern "C" int fl_text_display_word_start(TEXTDISPLAY td, int p); +extern "C" int fl_text_display_word_end(TEXTDISPLAY td, int p); +extern "C" void fl_text_display_next_word(TEXTDISPLAY td); +extern "C" void fl_text_display_previous_word(TEXTDISPLAY td); + + +extern "C" void fl_text_display_wrap_mode(TEXTDISPLAY td, int w, int m); +extern "C" int fl_text_display_wrapped_row(TEXTDISPLAY td, int r); +extern "C" int fl_text_display_wrapped_column(TEXTDISPLAY td, int r, int c); +extern "C" int fl_text_display_wrap_uses_character(TEXTDISPLAY td, int lep); +extern "C" void fl_text_display_wrapped_line_counter(TEXTDISPLAY td, void * buf, int startPos, + int maxPos, int maxLines, int spils, int sbo, int &retPos, int &retLines, int &retLineStart, + int &retLineEnd, int cllmnl); + + +extern "C" int fl_text_display_line_start(TEXTDISPLAY td, int s); +extern "C" int fl_text_display_line_end(TEXTDISPLAY td, int s, int p); +extern "C" int fl_text_display_count_lines(TEXTDISPLAY td, int s, int f, int p); +extern "C" int fl_text_display_skip_lines(TEXTDISPLAY td, int s, int l, int p); +extern "C" int fl_text_display_rewind_lines(TEXTDISPLAY td, int s, int l); +extern "C" void fl_text_display_calc_last_char(TEXTDISPLAY td); +extern "C" void fl_text_display_calc_line_starts(TEXTDISPLAY td, int s, int f); +extern "C" void fl_text_display_offset_line_starts(TEXTDISPLAY td, int t); + + +extern "C" void fl_text_display_absolute_top_line_number(TEXTDISPLAY td, int c); +extern "C" int fl_text_display_get_absolute_top_line_number(TEXTDISPLAY td); +extern "C" void fl_text_display_maintain_absolute_top_line_number(TEXTDISPLAY td, int s); +extern "C" int fl_text_display_maintaining_absolute_top_line_number(TEXTDISPLAY td); +extern "C" void fl_text_display_reset_absolute_top_line_number(TEXTDISPLAY td); + + +extern "C" int fl_text_display_empty_vlines(TEXTDISPLAY td); +extern "C" int fl_text_display_longest_vline(TEXTDISPLAY td); +extern "C" int fl_text_display_vline_length(TEXTDISPLAY td, int l); + + +extern "C" unsigned int fl_text_display_get_linenumber_align(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_align(TEXTDISPLAY td, unsigned int a); +extern "C" unsigned int fl_text_display_get_linenumber_bgcolor(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_bgcolor(TEXTDISPLAY td, unsigned int c); +extern "C" unsigned int fl_text_display_get_linenumber_fgcolor(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_fgcolor(TEXTDISPLAY td, unsigned int c); +extern "C" int fl_text_display_get_linenumber_font(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_font(TEXTDISPLAY td, int f); +extern "C" int fl_text_display_get_linenumber_size(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_size(TEXTDISPLAY td, int s); +extern "C" int fl_text_display_get_linenumber_width(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_width(TEXTDISPLAY td, int w); +extern "C" const char * fl_text_display_get_linenumber_format(TEXTDISPLAY td); +extern "C" void fl_text_display_set_linenumber_format(TEXTDISPLAY td, const char * v); + + +extern "C" double fl_text_display_measure_proportional_character(TEXTDISPLAY td, const char * str, + int xpix, int pos); +extern "C" int fl_text_display_measure_vline(TEXTDISPLAY td, int line); +extern "C" double fl_text_display_string_width(TEXTDISPLAY td, const char * str, int len, int s); + + +extern "C" int fl_text_display_move_down(TEXTDISPLAY td); +extern "C" int fl_text_display_move_left(TEXTDISPLAY td); +extern "C" int fl_text_display_move_right(TEXTDISPLAY td); +extern "C" int fl_text_display_move_up(TEXTDISPLAY td); + + +extern "C" void fl_text_display_scroll(TEXTDISPLAY td, int l, int c); +extern "C" int fl_text_display_scroll2(TEXTDISPLAY td, int l, int p); +extern "C" unsigned int fl_text_display_get_scrollbar_align(TEXTDISPLAY td); +extern "C" void fl_text_display_set_scrollbar_align(TEXTDISPLAY td, unsigned int a); +extern "C" int fl_text_display_get_scrollbar_width(TEXTDISPLAY td); +extern "C" void fl_text_display_set_scrollbar_width(TEXTDISPLAY td, int w); +extern "C" void fl_text_display_update_h_scrollbar(TEXTDISPLAY td); +extern "C" void fl_text_display_update_v_scrollbar(TEXTDISPLAY td); + + +extern "C" int fl_text_display_get_shortcut(TEXTDISPLAY td); +extern "C" void fl_text_display_set_shortcut(TEXTDISPLAY td, int s); + + +extern "C" void fl_text_display_resize(TEXTDISPLAY td, int x, int y, int w, int h); + + +extern "C" void fl_text_display_clear_rect(TEXTDISPLAY td, int s, int x, int y, int w, int h); +extern "C" void fl_text_display_display_insert(TEXTDISPLAY td); +extern "C" void fl_text_display_redisplay_range(TEXTDISPLAY td, int s, int f); +extern "C" void fl_text_display_draw(TEXTDISPLAY td); +extern "C" void fl_text_display_draw_cursor(TEXTDISPLAY td, int x, int y); +extern "C" void fl_text_display_draw_line_numbers(TEXTDISPLAY td, int c); +extern "C" void fl_text_display_draw_range(TEXTDISPLAY td, int s, int f); +extern "C" void fl_text_display_draw_string(TEXTDISPLAY td, int s, int x, int y, int r, + const char * str, int n); +extern "C" void fl_text_display_draw_text(TEXTDISPLAY td, int x, int y, int w, int h); +extern "C" void fl_text_display_draw_vline(TEXTDISPLAY td, int line, int left, int right, + int lchar, int rchar); +extern "C" int fl_text_display_handle(TEXTDISPLAY td, int e); + + +#endif + + diff --git a/body/c_fl_text_editor.cpp b/body/c_fl_text_editor.cpp new file mode 100644 index 0000000..0efea0b --- /dev/null +++ b/body/c_fl_text_editor.cpp @@ -0,0 +1,400 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Text_Editor.H> +#include "c_fl_text_editor.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Text_Editor : Fl_Text_Editor { +public: + using Fl_Text_Editor::handle_key; + using Fl_Text_Editor::maybe_do_callback; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Text_Editor : public Fl_Text_Editor { +public: + using Fl_Text_Editor::Fl_Text_Editor; + + friend void fl_text_editor_draw(TEXTEDITOR te); + friend int fl_text_editor_handle(TEXTEDITOR te, int e); + + void draw(); + int handle(int e); +}; + +void My_Text_Editor::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Text_Editor::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TEXTEDITOR new_fl_text_editor(int x, int y, int w, int h, char* label) { + My_Text_Editor *te = new My_Text_Editor(x, y, w, h, label); + return te; +} + +void free_fl_text_editor(TEXTEDITOR te) { + if (fl_inside_callback) { + fl_delete_widget(te); + } else { + delete static_cast<My_Text_Editor*>(te); + } +} + + + + +void fl_text_editor_default(TEXTEDITOR te, int k) { + Fl_Text_Editor::kf_default(k, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_undo(TEXTEDITOR te) { + Fl_Text_Editor::kf_undo(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_cut(TEXTEDITOR te) { + Fl_Text_Editor::kf_cut(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_copy(TEXTEDITOR te) { + Fl_Text_Editor::kf_copy(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_paste(TEXTEDITOR te) { + Fl_Text_Editor::kf_paste(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_delete(TEXTEDITOR te) { + Fl_Text_Editor::kf_delete(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_select_all(TEXTEDITOR te) { + Fl_Text_Editor::kf_select_all(0, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_backspace(TEXTEDITOR te) { + Fl_Text_Editor::kf_backspace(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_insert(TEXTEDITOR te) { + Fl_Text_Editor::kf_insert(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_enter(TEXTEDITOR te) { + Fl_Text_Editor::kf_enter(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ignore(TEXTEDITOR te) { + Fl_Text_Editor::kf_ignore(0, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_home(TEXTEDITOR te) { + Fl_Text_Editor::kf_home(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_end(TEXTEDITOR te) { + Fl_Text_Editor::kf_end(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_page_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_page_down(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_page_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_page_up(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_down(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_left(TEXTEDITOR te) { + Fl_Text_Editor::kf_left(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_right(TEXTEDITOR te) { + Fl_Text_Editor::kf_right(0, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_up(0, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_shift_home(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Home, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_end(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_End, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_page_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Page_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_page_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Page_Up, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_left(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Left, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_right(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Right, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_shift_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_shift_move(FL_Up, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_ctrl_home(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Home, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_end(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_End, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_page_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Page_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_page_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Page_Up, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_left(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Left, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_right(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Right, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_ctrl_move(FL_Up, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_ctrl_shift_home(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Home, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_end(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_End, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_page_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Page_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_page_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Page_Up, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_left(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Left, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_right(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Right, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_ctrl_shift_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_c_s_move(FL_Up, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_meta_home(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Home, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_end(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_End, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_page_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Page_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_page_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Page_Up, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_left(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Left, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_right(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Right, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_meta_move(FL_Up, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_meta_shift_home(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Home, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_end(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_End, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_page_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Page_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_page_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Page_Up, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_down(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Down, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_left(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Left, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_right(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Right, static_cast<Fl_Text_Editor*>(te)); +} + +void fl_text_editor_meta_shift_up(TEXTEDITOR te) { + Fl_Text_Editor::kf_m_s_move(FL_Up, static_cast<Fl_Text_Editor*>(te)); +} + + + + +void fl_text_editor_add_key_binding(TEXTEDITOR te, int k, int s, void * f) { + static_cast<Fl_Text_Editor*>(te)->add_key_binding + (k, s, reinterpret_cast<Fl_Text_Editor::Key_Func>(f)); +} + +void fl_text_editor_remove_all_key_bindings(TEXTEDITOR te) { + static_cast<Fl_Text_Editor*>(te)->remove_all_key_bindings(); +} + +void fl_text_editor_set_default_key_function(TEXTEDITOR te, void * f) { + static_cast<Fl_Text_Editor*>(te)->default_key_function + (reinterpret_cast<Fl_Text_Editor::Key_Func>(f)); +} + + + + +int fl_text_editor_get_insert_mode(TEXTEDITOR te) { + return static_cast<Fl_Text_Editor*>(te)->insert_mode(); +} + +void fl_text_editor_set_insert_mode(TEXTEDITOR te, int i) { + static_cast<Fl_Text_Editor*>(te)->insert_mode(i); +} + +int fl_text_editor_get_tab_nav(TEXTEDITOR te) { +#if FLTK_ABI_VERSION >= 10304 + return static_cast<Fl_Text_Editor*>(te)->tab_nav(); +#else + (void)(te); + return 0; +#endif +} + +void fl_text_editor_set_tab_nav(TEXTEDITOR te, int t) { +#if FLTK_ABI_VERSION >= 10304 + static_cast<Fl_Text_Editor*>(te)->tab_nav(t); +#else + (void)(te); + (void)(t); +#endif +} + + + + +void fl_text_editor_draw(TEXTEDITOR te) { + static_cast<My_Text_Editor*>(te)->Fl_Text_Editor::draw(); +} + +int fl_text_editor_handle(TEXTEDITOR te, int e) { + return static_cast<My_Text_Editor*>(te)->Fl_Text_Editor::handle(e); +} + +int fl_text_editor_handle_key(TEXTEDITOR te) { + return (static_cast<Fl_Text_Editor*>(te)->*(&Friend_Text_Editor::handle_key))(); +} + +void fl_text_editor_maybe_do_callback(TEXTEDITOR te) { + (static_cast<Fl_Text_Editor*>(te)->*(&Friend_Text_Editor::maybe_do_callback))(); +} + + diff --git a/body/c_fl_text_editor.h b/body/c_fl_text_editor.h new file mode 100644 index 0000000..b34681c --- /dev/null +++ b/body/c_fl_text_editor.h @@ -0,0 +1,114 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TEXT_EDITOR_GUARD +#define FL_TEXT_EDITOR_GUARD + + +typedef void* TEXTEDITOR; + + +extern "C" TEXTEDITOR new_fl_text_editor(int x, int y, int w, int h, char* label); +extern "C" void free_fl_text_editor(TEXTEDITOR te); + + +extern "C" void fl_text_editor_default(TEXTEDITOR te, int k); + + +extern "C" void fl_text_editor_undo(TEXTEDITOR te); +extern "C" void fl_text_editor_cut(TEXTEDITOR te); +extern "C" void fl_text_editor_copy(TEXTEDITOR te); +extern "C" void fl_text_editor_paste(TEXTEDITOR te); +extern "C" void fl_text_editor_delete(TEXTEDITOR te); +extern "C" void fl_text_editor_select_all(TEXTEDITOR te); + + +extern "C" void fl_text_editor_backspace(TEXTEDITOR te); +extern "C" void fl_text_editor_insert(TEXTEDITOR te); +extern "C" void fl_text_editor_enter(TEXTEDITOR te); +extern "C" void fl_text_editor_ignore(TEXTEDITOR te); + + +extern "C" void fl_text_editor_home(TEXTEDITOR te); +extern "C" void fl_text_editor_end(TEXTEDITOR te); +extern "C" void fl_text_editor_page_down(TEXTEDITOR te); +extern "C" void fl_text_editor_page_up(TEXTEDITOR te); +extern "C" void fl_text_editor_down(TEXTEDITOR te); +extern "C" void fl_text_editor_left(TEXTEDITOR te); +extern "C" void fl_text_editor_right(TEXTEDITOR te); +extern "C" void fl_text_editor_up(TEXTEDITOR te); + + +extern "C" void fl_text_editor_shift_home(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_end(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_page_down(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_page_up(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_down(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_left(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_right(TEXTEDITOR te); +extern "C" void fl_text_editor_shift_up(TEXTEDITOR te); + + +extern "C" void fl_text_editor_ctrl_home(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_end(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_page_down(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_page_up(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_down(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_left(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_right(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_up(TEXTEDITOR te); + + +extern "C" void fl_text_editor_ctrl_shift_home(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_end(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_page_down(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_page_up(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_down(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_left(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_right(TEXTEDITOR te); +extern "C" void fl_text_editor_ctrl_shift_up(TEXTEDITOR te); + + +extern "C" void fl_text_editor_meta_home(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_end(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_page_down(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_page_up(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_down(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_left(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_right(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_up(TEXTEDITOR te); + + +extern "C" void fl_text_editor_meta_shift_home(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_end(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_page_down(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_page_up(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_down(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_left(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_right(TEXTEDITOR te); +extern "C" void fl_text_editor_meta_shift_up(TEXTEDITOR te); + + +extern "C" void fl_text_editor_add_key_binding(TEXTEDITOR te, int k, int s, void * f); +extern "C" void fl_text_editor_remove_all_key_bindings(TEXTEDITOR te); +extern "C" void fl_text_editor_set_default_key_function(TEXTEDITOR te, void * f); + + +extern "C" int fl_text_editor_get_insert_mode(TEXTEDITOR te); +extern "C" void fl_text_editor_set_insert_mode(TEXTEDITOR te, int i); +extern "C" int fl_text_editor_get_tab_nav(TEXTEDITOR te); +extern "C" void fl_text_editor_set_tab_nav(TEXTEDITOR te, int t); + + +extern "C" void fl_text_editor_draw(TEXTEDITOR te); +extern "C" int fl_text_editor_handle(TEXTEDITOR te, int e); +extern "C" int fl_text_editor_handle_key(TEXTEDITOR te); +extern "C" void fl_text_editor_maybe_do_callback(TEXTEDITOR te); + + +#endif + + diff --git a/body/c_fl_tile.cpp b/body/c_fl_tile.cpp new file mode 100644 index 0000000..feea448 --- /dev/null +++ b/body/c_fl_tile.cpp @@ -0,0 +1,83 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Tile.H> +#include "c_fl_tile.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Tile : public Fl_Tile { +public: + using Fl_Tile::Fl_Tile; + + friend void fl_tile_draw(TILE n); + friend int fl_tile_handle(TILE n, int e); + + void draw(); + int handle(int e); +}; + +void My_Tile::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Tile::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TILE new_fl_tile(int x, int y, int w, int h, char* label) { + My_Tile *b = new My_Tile(x, y, w, h, label); + return b; +} + +void free_fl_tile(TILE t) { + if (fl_inside_callback) { + fl_delete_widget(t); + } else { + delete static_cast<My_Tile*>(t); + } +} + + + + +void fl_tile_position(TILE t, int ox, int oy, int nx, int ny) { + static_cast<Fl_Tile*>(t)->position(ox,oy,nx,ny); +} + +void fl_tile_resize(TILE t, int x, int y, int w, int h) { + static_cast<Fl_Tile*>(t)->resize(x, y, w, h); +} + + + + +void fl_tile_draw(TILE n) { + static_cast<My_Tile*>(n)->Fl_Tile::draw(); +} + +int fl_tile_handle(TILE n, int e) { + return static_cast<My_Tile*>(n)->Fl_Tile::handle(e); +} + + diff --git a/body/c_fl_tile.h b/body/c_fl_tile.h new file mode 100644 index 0000000..3254558 --- /dev/null +++ b/body/c_fl_tile.h @@ -0,0 +1,28 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TILE_GUARD +#define FL_TILE_GUARD + + +typedef void* TILE; + + +extern "C" TILE new_fl_tile(int x, int y, int w, int h, char * label); +extern "C" void free_fl_tile(TILE t); + + +extern "C" void fl_tile_position(TILE t, int ox, int oy, int nx, int ny); +extern "C" void fl_tile_resize(TILE t, int x, int y, int w, int h); + + +extern "C" void fl_tile_draw(TILE n); +extern "C" int fl_tile_handle(TILE n, int e); + + +#endif + + diff --git a/body/c_fl_tiled_image.cpp b/body/c_fl_tiled_image.cpp new file mode 100644 index 0000000..0fbea0f --- /dev/null +++ b/body/c_fl_tiled_image.cpp @@ -0,0 +1,64 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Tiled_Image.H> +#include <FL/Fl_Image.H> +#include "c_fl_tiled_image.h" + + + + +TILEDIMAGE new_fl_tiled_image(void * i, int w, int h) { + Fl_Tiled_Image *t = new Fl_Tiled_Image(static_cast<Fl_Image*>(i), w, h); + return t; +} + +void free_fl_tiled_image(TILEDIMAGE t) { + delete static_cast<Fl_Tiled_Image*>(t); +} + +TILEDIMAGE fl_tiled_image_copy(TILEDIMAGE t, int w, int h) { + // virtual so disable dispatch + return static_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::copy(w, h); +} + +TILEDIMAGE fl_tiled_image_copy2(TILEDIMAGE t) { + return static_cast<Fl_Tiled_Image*>(t)->copy(); +} + + + + +void * fl_tiled_image_get_image(TILEDIMAGE t) { + return static_cast<Fl_Tiled_Image*>(t)->image(); +} + + + + +void fl_tiled_image_color_average(TILEDIMAGE t, int c, float b) { + // virtual so disable dispatch + static_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::color_average(c, b); +} + +void fl_tiled_image_desaturate(TILEDIMAGE t) { + // virtual so disable dispatch + static_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::desaturate(); +} + + + + +void fl_tiled_image_draw(TILEDIMAGE t, int x, int y) { + static_cast<Fl_Tiled_Image*>(t)->draw(x, y); +} + +void fl_tiled_image_draw2(TILEDIMAGE t, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + static_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::draw(x, y, w, h, cx, cy); +} + + diff --git a/body/c_fl_tiled_image.h b/body/c_fl_tiled_image.h new file mode 100644 index 0000000..9eee3dd --- /dev/null +++ b/body/c_fl_tiled_image.h @@ -0,0 +1,33 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TILED_IMAGE_GUARD +#define FL_TILED_IMAGE_GUARD + + +typedef void* TILEDIMAGE; + + +extern "C" TILEDIMAGE new_fl_tiled_image(void * i, int w, int h); +extern "C" void free_fl_tiled_image(TILEDIMAGE t); +extern "C" TILEDIMAGE fl_tiled_image_copy(TILEDIMAGE t, int w, int h); +extern "C" TILEDIMAGE fl_tiled_image_copy2(TILEDIMAGE t); + + +extern "C" void * fl_tiled_image_get_image(TILEDIMAGE t); + + +extern "C" void fl_tiled_image_color_average(TILEDIMAGE t, int c, float b); +extern "C" void fl_tiled_image_desaturate(TILEDIMAGE t); + + +extern "C" void fl_tiled_image_draw(TILEDIMAGE t, int x, int y); +extern "C" void fl_tiled_image_draw2(TILEDIMAGE t, int x, int y, int w, int h, int cx, int cy); + + +#endif + + diff --git a/body/c_fl_toggle_button.cpp b/body/c_fl_toggle_button.cpp new file mode 100644 index 0000000..f87e78a --- /dev/null +++ b/body/c_fl_toggle_button.cpp @@ -0,0 +1,72 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Toggle_Button.H> +#include "c_fl_toggle_button.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Toggle_Button : public Fl_Toggle_Button { +public: + using Fl_Toggle_Button::Fl_Toggle_Button; + + friend void fl_toggle_button_draw(TOGGLEBUTTON b); + friend int fl_toggle_button_handle(TOGGLEBUTTON b, int e); + + void draw(); + int handle(int e); +}; + +void My_Toggle_Button::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Toggle_Button::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +TOGGLEBUTTON new_fl_toggle_button(int x, int y, int w, int h, char* label) { + My_Toggle_Button *b = new My_Toggle_Button(x, y, w, h, label); + return b; +} + +void free_fl_toggle_button(TOGGLEBUTTON b) { + if (fl_inside_callback) { + fl_delete_widget(b); + } else { + delete static_cast<My_Toggle_Button*>(b); + } +} + + + + +void fl_toggle_button_draw(TOGGLEBUTTON b) { + static_cast<My_Toggle_Button*>(b)->Fl_Toggle_Button::draw(); +} + +int fl_toggle_button_handle(TOGGLEBUTTON b, int e) { + return static_cast<My_Toggle_Button*>(b)->Fl_Toggle_Button::handle(e); +} + + diff --git a/body/c_fl_toggle_button.h b/body/c_fl_toggle_button.h new file mode 100644 index 0000000..bdb86b1 --- /dev/null +++ b/body/c_fl_toggle_button.h @@ -0,0 +1,24 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TOGGLE_BUTTON_GUARD +#define FL_TOGGLE_BUTTON_GUARD + + +typedef void* TOGGLEBUTTON; + + +extern "C" TOGGLEBUTTON new_fl_toggle_button(int x, int y, int w, int h, char* label); +extern "C" void free_fl_toggle_button(TOGGLEBUTTON b); + + +extern "C" void fl_toggle_button_draw(TOGGLEBUTTON b); +extern "C" int fl_toggle_button_handle(TOGGLEBUTTON b, int e); + + +#endif + + diff --git a/body/c_fl_tooltip.cpp b/body/c_fl_tooltip.cpp new file mode 100644 index 0000000..8819da4 --- /dev/null +++ b/body/c_fl_tooltip.cpp @@ -0,0 +1,131 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Tooltip.H> +#include <FL/Fl_Widget.H> +#include "c_fl_tooltip.h" + + + + +void * fl_tooltip_get_current(void) { + return Fl_Tooltip::current(); +} + +void fl_tooltip_set_current(void * i) { + Fl_Tooltip::current(static_cast<Fl_Widget*>(i)); +} + +int fl_tooltip_enabled(void) { + return Fl_Tooltip::enabled(); +} + +void fl_tooltip_enable(int v) { + Fl_Tooltip::enable(v); +} + +void fl_tooltip_disable() { + Fl_Tooltip::disable(); +} + +void fl_tooltip_enter_area(void * i, int x, int y, int w, int h, const char * t) { + Fl_Tooltip::enter_area(static_cast<Fl_Widget*>(i),x,y,w,h,t); +} + + + + +float fl_tooltip_get_delay(void) { + return Fl_Tooltip::delay(); +} + +void fl_tooltip_set_delay(float v) { + Fl_Tooltip::delay(v); +} + +float fl_tooltip_get_hoverdelay(void) { + return Fl_Tooltip::hoverdelay(); +} + +void fl_tooltip_set_hoverdelay(float v) { + Fl_Tooltip::hoverdelay(v); +} + + + + +unsigned int fl_tooltip_get_color(void) { + return Fl_Tooltip::color(); +} + +void fl_tooltip_set_color(unsigned int v) { + Fl_Tooltip::color(v); +} + +int fl_tooltip_get_margin_height(void) { + return Fl_Tooltip::margin_height(); +} + +void fl_tooltip_set_margin_height(int v) { +#if FLTK_ABI_VERSION >= 10301 + Fl_Tooltip::margin_height(v); +#else + (void)(v); +#endif +} + +int fl_tooltip_get_margin_width(void) { + return Fl_Tooltip::margin_width(); +} + +void fl_tooltip_set_margin_width(int v) { +#if FLTK_ABI_VERSION >= 10301 + Fl_Tooltip::margin_width(v); +#else + (void)(v); +#endif +} + +int fl_tooltip_get_wrap_width(void) { + return Fl_Tooltip::wrap_width(); +} + +void fl_tooltip_set_wrap_width(int v) { +#if FLTK_ABI_VERSION >= 10301 + Fl_Tooltip::wrap_width(v); +#else + (void)(v); +#endif +} + + + + +unsigned int fl_tooltip_get_textcolor(void) { + return Fl_Tooltip::textcolor(); +} + +void fl_tooltip_set_textcolor(unsigned int v) { + Fl_Tooltip::textcolor(v); +} + +int fl_tooltip_get_font(void) { + return Fl_Tooltip::font(); +} + +void fl_tooltip_set_font(int v) { + Fl_Tooltip::font(v); +} + +int fl_tooltip_get_size(void) { + return Fl_Tooltip::size(); +} + +void fl_tooltip_set_size(int v) { + Fl_Tooltip::size(v); +} + + diff --git a/body/c_fl_tooltip.h b/body/c_fl_tooltip.h new file mode 100644 index 0000000..055a11f --- /dev/null +++ b/body/c_fl_tooltip.h @@ -0,0 +1,45 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_TOOLTIP_GUARD +#define FL_TOOLTIP_GUARD + + +extern "C" void * fl_tooltip_get_current(void); +extern "C" void fl_tooltip_set_current(void * i); +extern "C" int fl_tooltip_enabled(void); +extern "C" void fl_tooltip_enable(int v); +extern "C" void fl_tooltip_disable(); +extern "C" void fl_tooltip_enter_area(void * i, int x, int y, int w, int h, const char * t); + + +extern "C" float fl_tooltip_get_delay(void); +extern "C" void fl_tooltip_set_delay(float v); +extern "C" float fl_tooltip_get_hoverdelay(void); +extern "C" void fl_tooltip_set_hoverdelay(float v); + + +extern "C" unsigned int fl_tooltip_get_color(void); +extern "C" void fl_tooltip_set_color(unsigned int v); +extern "C" int fl_tooltip_get_margin_height(void); +extern "C" void fl_tooltip_set_margin_height(int v); +extern "C" int fl_tooltip_get_margin_width(void); +extern "C" void fl_tooltip_set_margin_width(int v); +extern "C" int fl_tooltip_get_wrap_width(void); +extern "C" void fl_tooltip_set_wrap_width(int v); + + +extern "C" unsigned int fl_tooltip_get_textcolor(void); +extern "C" void fl_tooltip_set_textcolor(unsigned int v); +extern "C" int fl_tooltip_get_font(void); +extern "C" void fl_tooltip_set_font(int v); +extern "C" int fl_tooltip_get_size(void); +extern "C" void fl_tooltip_set_size(int v); + + +#endif + + diff --git a/body/c_fl_valuator.cpp b/body/c_fl_valuator.cpp new file mode 100644 index 0000000..44ab601 --- /dev/null +++ b/body/c_fl_valuator.cpp @@ -0,0 +1,175 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Valuator.H> +#include "c_fl_valuator.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Non-friend protected access + +class Friend_Valuator : Fl_Valuator { +public: + using Fl_Valuator::value_damage; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Valuator : public Fl_Valuator { +public: + using Fl_Valuator::Fl_Valuator; + friend VALUATOR new_fl_valuator(int x, int y, int w, int h, char* label); + + friend void fl_valuator_draw(VALUATOR v); + friend int fl_valuator_handle(VALUATOR v, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Valuator::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Valuator::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Valuator::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +VALUATOR new_fl_valuator(int x, int y, int w, int h, char* label) { + My_Valuator *v = new My_Valuator(x, y, w, h, label); + return v; +} + +void free_fl_valuator(VALUATOR v) { + if (fl_inside_callback) { + fl_delete_widget(v); + } else { + delete static_cast<My_Valuator*>(v); + } +} + + + + +int fl_valuator_format(VALUATOR v, char * buf) { + return static_cast<Fl_Valuator*>(v)->Fl_Valuator::format(buf); +} + + + + +double fl_valuator_clamp(VALUATOR v, double a) { + return static_cast<Fl_Valuator*>(v)->clamp(a); +} + +double fl_valuator_round(VALUATOR v, double a) { + return static_cast<Fl_Valuator*>(v)->round(a); +} + +double fl_valuator_increment(VALUATOR v, double a, int s) { + return static_cast<Fl_Valuator*>(v)->increment(a,s); +} + + + + +double fl_valuator_get_minimum(VALUATOR v) { + return static_cast<Fl_Valuator*>(v)->minimum(); +} + +void fl_valuator_set_minimum(VALUATOR v, double t) { + static_cast<Fl_Valuator*>(v)->minimum(t); +} + +double fl_valuator_get_maximum(VALUATOR v) { + return static_cast<Fl_Valuator*>(v)->maximum(); +} + +void fl_valuator_set_maximum(VALUATOR v, double t) { + static_cast<Fl_Valuator*>(v)->maximum(t); +} + +double fl_valuator_get_step(VALUATOR v) { + return static_cast<Fl_Valuator*>(v)->step(); +} + +void fl_valuator_set_step_top(VALUATOR v, double t) { + static_cast<Fl_Valuator*>(v)->step(t); +} + +void fl_valuator_set_step_bottom(VALUATOR v, int b) { + static_cast<Fl_Valuator*>(v)->step(b); +} + +void fl_valuator_set_step(VALUATOR v, double t, int b) { + static_cast<Fl_Valuator*>(v)->step(t, b); +} + +double fl_valuator_get_value(VALUATOR v) { + return static_cast<Fl_Valuator*>(v)->value(); +} + +void fl_valuator_set_value(VALUATOR v, double t) { + static_cast<Fl_Valuator*>(v)->value(t); +} + +void fl_valuator_bounds(VALUATOR v, double a, double b) { + static_cast<Fl_Valuator*>(v)->bounds(a,b); +} + +void fl_valuator_precision(VALUATOR v, int s) { + static_cast<Fl_Valuator*>(v)->precision(s); +} + +void fl_valuator_range(VALUATOR v, double a, double b) { + static_cast<Fl_Valuator*>(v)->range(a,b); +} + + + + +void fl_valuator_value_damage(VALUATOR v) { + (static_cast<Fl_Valuator*>(v)->*(&Friend_Valuator::value_damage))(); +} + +void fl_valuator_draw(VALUATOR v) { + // The Fl_Valuator draw method doesn't technically exist, so... + (void)(v); + // It is more convenient for this function to exist, however, + // even though it will likely never be called, because it simplifies + // and makes uniform the implementation of the Ada Valuator Draw subprogram. +} + +int fl_valuator_handle(VALUATOR v, int e) { + return static_cast<My_Valuator*>(v)->Fl_Valuator::handle(e); +} + + diff --git a/body/c_fl_valuator.h b/body/c_fl_valuator.h new file mode 100644 index 0000000..81107bc --- /dev/null +++ b/body/c_fl_valuator.h @@ -0,0 +1,48 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_VALUATOR_GUARD +#define FL_VALUATOR_GUARD + + +typedef void* VALUATOR; + + +extern "C" VALUATOR new_fl_valuator(int x, int y, int w, int h, char* label); +extern "C" void free_fl_valuator(VALUATOR v); + + +extern "C" int fl_valuator_format(VALUATOR v, char * buf); + + +extern "C" double fl_valuator_clamp(VALUATOR v, double a); +extern "C" double fl_valuator_round(VALUATOR v, double a); +extern "C" double fl_valuator_increment(VALUATOR v, double a, int s); + + +extern "C" double fl_valuator_get_minimum(VALUATOR v); +extern "C" void fl_valuator_set_minimum(VALUATOR v, double t); +extern "C" double fl_valuator_get_maximum(VALUATOR v); +extern "C" void fl_valuator_set_maximum(VALUATOR v, double t); +extern "C" double fl_valuator_get_step(VALUATOR v); +extern "C" void fl_valuator_set_step_top(VALUATOR v, double t); +extern "C" void fl_valuator_set_step_bottom(VALUATOR v, int b); +extern "C" void fl_valuator_set_step(VALUATOR v, double t, int b); +extern "C" double fl_valuator_get_value(VALUATOR v); +extern "C" void fl_valuator_set_value(VALUATOR v, double t); +extern "C" void fl_valuator_bounds(VALUATOR v, double a, double b); +extern "C" void fl_valuator_precision(VALUATOR v, int s); +extern "C" void fl_valuator_range(VALUATOR v, double a, double b); + + +extern "C" void fl_valuator_value_damage(VALUATOR v); +extern "C" void fl_valuator_draw(VALUATOR v); +extern "C" int fl_valuator_handle(VALUATOR v, int e); + + +#endif + + diff --git a/body/c_fl_value_input.cpp b/body/c_fl_value_input.cpp new file mode 100644 index 0000000..29a7772 --- /dev/null +++ b/body/c_fl_value_input.cpp @@ -0,0 +1,153 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Value_Input.H> +#include "c_fl_value_input.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Value_Input : public Fl_Value_Input { +public: + using Fl_Value_Input::Fl_Value_Input; + + friend void fl_value_input_draw(VALUEINPUT a); + friend int fl_value_input_handle(VALUEINPUT a, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Value_Input::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Value_Input::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Value_Input::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +VALUEINPUT new_fl_value_input(int x, int y, int w, int h, char* label) { + My_Value_Input *a = new My_Value_Input(x, y, w, h, label); + return a; +} + +void free_fl_value_input(VALUEINPUT a) { + if (fl_inside_callback) { + fl_delete_widget(a); + } else { + delete static_cast<My_Value_Input*>(a); + } +} + + + + +void * fl_value_input_get_input(VALUEINPUT v) { + return &(static_cast<Fl_Value_Input*>(v)->input); +} + + + + +unsigned int fl_value_input_get_cursor_color(VALUEINPUT v) { + return static_cast<Fl_Value_Input*>(v)->cursor_color(); +} + +void fl_value_input_set_cursor_color(VALUEINPUT v, unsigned int c) { + static_cast<Fl_Value_Input*>(v)->cursor_color(c); +} + + + + +int fl_value_input_get_shortcut(VALUEINPUT v) { + return static_cast<Fl_Value_Input*>(v)->Fl_Value_Input::shortcut(); +} + +void fl_value_input_set_shortcut(VALUEINPUT v, int k) { + static_cast<Fl_Value_Input*>(v)->Fl_Value_Input::shortcut(k); +} + + + + +int fl_value_input_is_soft(VALUEINPUT a) { + return static_cast<Fl_Value_Input*>(a)->soft(); +} + +void fl_value_input_set_soft(VALUEINPUT a, int t) { + static_cast<Fl_Value_Input*>(a)->soft(t); +} + + + + +unsigned int fl_value_input_get_text_color(VALUEINPUT v) { + return static_cast<Fl_Value_Input*>(v)->textcolor(); +} + +void fl_value_input_set_text_color(VALUEINPUT v, unsigned int c) { + static_cast<Fl_Value_Input*>(v)->textcolor(static_cast<Fl_Color>(c)); +} + +int fl_value_input_get_text_font(VALUEINPUT v) { + return static_cast<Fl_Value_Input*>(v)->textfont(); +} + +void fl_value_input_set_text_font(VALUEINPUT v, int f) { + static_cast<Fl_Value_Input*>(v)->textfont(static_cast<Fl_Font>(f)); +} + +int fl_value_input_get_text_size(VALUEINPUT v) { + return static_cast<Fl_Value_Input*>(v)->textsize(); +} + +void fl_value_input_set_text_size(VALUEINPUT v, int s) { + static_cast<Fl_Value_Input*>(v)->textsize(static_cast<Fl_Fontsize>(s)); +} + + + + +void fl_value_input_resize(VALUEINPUT v, int x, int y, int w, int h) { + static_cast<Fl_Value_Input*>(v)->resize(x, y, w, h); +} + + + + +void fl_value_input_draw(VALUEINPUT a) { + static_cast<My_Value_Input*>(a)->Fl_Value_Input::draw(); +} + +int fl_value_input_handle(VALUEINPUT a, int e) { + return static_cast<My_Value_Input*>(a)->Fl_Value_Input::handle(e); +} + + diff --git a/body/c_fl_value_input.h b/body/c_fl_value_input.h new file mode 100644 index 0000000..f9eeff2 --- /dev/null +++ b/body/c_fl_value_input.h @@ -0,0 +1,50 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_VALUE_INPUT_GUARD +#define FL_VALUE_INPUT_GUARD + + +typedef void* VALUEINPUT; + + +extern "C" VALUEINPUT new_fl_value_input(int x, int y, int w, int h, char* label); +extern "C" void free_fl_value_input(VALUEINPUT a); + + +extern "C" void * fl_value_input_get_input(VALUEINPUT v); + + +extern "C" unsigned int fl_value_input_get_cursor_color(VALUEINPUT v); +extern "C" void fl_value_input_set_cursor_color(VALUEINPUT v, unsigned int c); + + +extern "C" int fl_value_input_get_shortcut(VALUEINPUT v); +extern "C" void fl_value_input_set_shortcut(VALUEINPUT v, int k); + + +extern "C" int fl_value_input_is_soft(VALUEINPUT a); +extern "C" void fl_value_input_set_soft(VALUEINPUT a, int t); + + +extern "C" unsigned int fl_value_input_get_text_color(VALUEINPUT v); +extern "C" void fl_value_input_set_text_color(VALUEINPUT v, unsigned int c); +extern "C" int fl_value_input_get_text_font(VALUEINPUT v); +extern "C" void fl_value_input_set_text_font(VALUEINPUT v, int f); +extern "C" int fl_value_input_get_text_size(VALUEINPUT v); +extern "C" void fl_value_input_set_text_size(VALUEINPUT v, int s); + + +extern "C" void fl_value_input_resize(VALUEINPUT v, int x, int y, int w, int h); + + +extern "C" void fl_value_input_draw(VALUEINPUT a); +extern "C" int fl_value_input_handle(VALUEINPUT a, int e); + + +#endif + + diff --git a/body/c_fl_value_output.cpp b/body/c_fl_value_output.cpp new file mode 100644 index 0000000..2929cc7 --- /dev/null +++ b/body/c_fl_value_output.cpp @@ -0,0 +1,117 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Value_Output.H> +#include "c_fl_value_output.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Value_Output : public Fl_Value_Output { +public: + using Fl_Value_Output::Fl_Value_Output; + + friend void fl_value_output_draw(VALUEOUTPUT a); + friend int fl_value_output_handle(VALUEOUTPUT a, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Value_Output::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Value_Output::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Value_Output::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +VALUEOUTPUT new_fl_value_output(int x, int y, int w, int h, char* label) { + My_Value_Output *a = new My_Value_Output(x, y, w, h, label); + return a; +} + +void free_fl_value_output(VALUEOUTPUT a) { + if (fl_inside_callback) { + fl_delete_widget(a); + } else { + delete static_cast<My_Value_Output*>(a); + } +} + + + + +int fl_value_output_is_soft(VALUEOUTPUT a) { + return static_cast<Fl_Value_Output*>(a)->soft(); +} + +void fl_value_output_set_soft(VALUEOUTPUT a, int t) { + static_cast<Fl_Value_Output*>(a)->soft(t); +} + + + + +unsigned int fl_value_output_get_text_color(VALUEOUTPUT v) { + return static_cast<Fl_Value_Output*>(v)->textcolor(); +} + +void fl_value_output_set_text_color(VALUEOUTPUT v, unsigned int c) { + static_cast<Fl_Value_Output*>(v)->textcolor(static_cast<Fl_Color>(c)); +} + +int fl_value_output_get_text_font(VALUEOUTPUT v) { + return static_cast<Fl_Value_Output*>(v)->textfont(); +} + +void fl_value_output_set_text_font(VALUEOUTPUT v, int f) { + static_cast<Fl_Value_Output*>(v)->textfont(static_cast<Fl_Font>(f)); +} + +int fl_value_output_get_text_size(VALUEOUTPUT v) { + return static_cast<Fl_Value_Output*>(v)->textsize(); +} + +void fl_value_output_set_text_size(VALUEOUTPUT v, int s) { + static_cast<Fl_Value_Output*>(v)->textsize(static_cast<Fl_Fontsize>(s)); +} + + + + +void fl_value_output_draw(VALUEOUTPUT a) { + static_cast<My_Value_Output*>(a)->Fl_Value_Output::draw(); +} + +int fl_value_output_handle(VALUEOUTPUT a, int e) { + return static_cast<My_Value_Output*>(a)->Fl_Value_Output::handle(e); +} + + diff --git a/body/c_fl_value_output.h b/body/c_fl_value_output.h new file mode 100644 index 0000000..e333ff8 --- /dev/null +++ b/body/c_fl_value_output.h @@ -0,0 +1,36 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_VALUE_OUTPUT_GUARD +#define FL_VALUE_OUTPUT_GUARD + + +typedef void* VALUEOUTPUT; + + +extern "C" VALUEOUTPUT new_fl_value_output(int x, int y, int w, int h, char* label); +extern "C" void free_fl_value_output(VALUEOUTPUT a); + + +extern "C" int fl_value_output_is_soft(VALUEOUTPUT a); +extern "C" void fl_value_output_set_soft(VALUEOUTPUT a, int t); + + +extern "C" unsigned int fl_value_output_get_text_color(VALUEOUTPUT v); +extern "C" void fl_value_output_set_text_color(VALUEOUTPUT v, unsigned int c); +extern "C" int fl_value_output_get_text_font(VALUEOUTPUT v); +extern "C" void fl_value_output_set_text_font(VALUEOUTPUT v, int f); +extern "C" int fl_value_output_get_text_size(VALUEOUTPUT v); +extern "C" void fl_value_output_set_text_size(VALUEOUTPUT v, int s); + + +extern "C" void fl_value_output_draw(VALUEOUTPUT a); +extern "C" int fl_value_output_handle(VALUEOUTPUT a, int e); + + +#endif + + diff --git a/body/c_fl_value_slider.cpp b/body/c_fl_value_slider.cpp new file mode 100644 index 0000000..4d881c9 --- /dev/null +++ b/body/c_fl_value_slider.cpp @@ -0,0 +1,106 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Value_Slider.H> +#include "c_fl_value_slider.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + +extern "C" int valuator_format_hook(void * ud, char * buf); + + + + +// Attaching all relevant hooks and friends + +class My_Value_Slider : public Fl_Value_Slider { +public: + using Fl_Value_Slider::Fl_Value_Slider; + + friend void fl_value_slider_draw(VALUESLIDER s); + friend int fl_value_slider_handle(VALUESLIDER s, int e); + + int format(char * buf); + void draw(); + int handle(int e); +}; + +int My_Value_Slider::format(char * buf) { + return valuator_format_hook(this->user_data(), buf); +} + +void My_Value_Slider::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Value_Slider::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +VALUESLIDER new_fl_value_slider(int x, int y, int w, int h, char* label) { + My_Value_Slider *s = new My_Value_Slider(x, y, w, h, label); + return s; +} + +void free_fl_value_slider(VALUESLIDER s) { + if (fl_inside_callback) { + fl_delete_widget(s); + } else { + delete static_cast<My_Value_Slider*>(s); + } +} + + + + +unsigned int fl_value_slider_get_textcolor(VALUESLIDER s) { + return static_cast<Fl_Value_Slider*>(s)->textcolor(); +} + +void fl_value_slider_set_textcolor(VALUESLIDER s, unsigned int t) { + static_cast<Fl_Value_Slider*>(s)->textcolor(t); +} + +int fl_value_slider_get_textfont(VALUESLIDER s) { + return static_cast<Fl_Value_Slider*>(s)->textfont(); +} + +void fl_value_slider_set_textfont(VALUESLIDER s, int t) { + static_cast<Fl_Value_Slider*>(s)->textfont(t); +} + +int fl_value_slider_get_textsize(VALUESLIDER s) { + return static_cast<Fl_Value_Slider*>(s)->textsize(); +} + +void fl_value_slider_set_textsize(VALUESLIDER s, int t) { + static_cast<Fl_Value_Slider*>(s)->textsize(t); +} + + + + +void fl_value_slider_draw(VALUESLIDER s) { + static_cast<My_Value_Slider*>(s)->Fl_Value_Slider::draw(); +} + +int fl_value_slider_handle(VALUESLIDER s, int e) { + return static_cast<My_Value_Slider*>(s)->Fl_Value_Slider::handle(e); +} + + diff --git a/body/c_fl_value_slider.h b/body/c_fl_value_slider.h new file mode 100644 index 0000000..b07a827 --- /dev/null +++ b/body/c_fl_value_slider.h @@ -0,0 +1,32 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_VALUE_SLIDER_GUARD +#define FL_VALUE_SLIDER_GUARD + + +typedef void* VALUESLIDER; + + +extern "C" VALUESLIDER new_fl_value_slider(int x, int y, int w, int h, char* label); +extern "C" void free_fl_value_slider(VALUESLIDER s); + + +extern "C" unsigned int fl_value_slider_get_textcolor(VALUESLIDER s); +extern "C" void fl_value_slider_set_textcolor(VALUESLIDER s, unsigned int t); +extern "C" int fl_value_slider_get_textfont(VALUESLIDER s); +extern "C" void fl_value_slider_set_textfont(VALUESLIDER s, int t); +extern "C" int fl_value_slider_get_textsize(VALUESLIDER s); +extern "C" void fl_value_slider_set_textsize(VALUESLIDER s, int t); + + +extern "C" void fl_value_slider_draw(VALUESLIDER s); +extern "C" int fl_value_slider_handle(VALUESLIDER s, int e); + + +#endif + + diff --git a/body/c_fl_widget.cpp b/body/c_fl_widget.cpp new file mode 100644 index 0000000..4ac39ed --- /dev/null +++ b/body/c_fl_widget.cpp @@ -0,0 +1,481 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Widget.H> +#include <FL/Fl_Image.H> +#include "c_fl_widget.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Widget : Fl_Widget { +public: + using Fl_Widget::draw_backdrop; + using Fl_Widget::draw_box; + using Fl_Widget::draw_focus; + using Fl_Widget::draw_label; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Widget : public Fl_Widget { +public: + using Fl_Widget::Fl_Widget; + friend WIDGET new_fl_widget(int x, int y, int w, int h, char* label); + + friend void fl_widget_draw(WIDGET w); + friend int fl_widget_handle(WIDGET w, int e); + + void draw(); + int handle(int e); +}; + +void My_Widget::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Widget::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +WIDGET new_fl_widget(int x, int y, int w, int h, char* label) { + My_Widget *wd = new My_Widget(x, y, w, h, label); + return wd; +} + +void free_fl_widget(WIDGET w) { + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Widget*>(w); + } +} + + + + +void * fl_widget_get_user_data(WIDGET w) { + return static_cast<Fl_Widget*>(w)->user_data(); +} + +void fl_widget_set_user_data(WIDGET w, void * d) { + static_cast<Fl_Widget*>(w)->user_data(d); +} + + + + +void fl_widget_activate(WIDGET w) { + static_cast<Fl_Widget*>(w)->activate(); +} + +void fl_widget_deactivate(WIDGET w) { + static_cast<Fl_Widget*>(w)->deactivate(); +} + +int fl_widget_active(WIDGET w) { + return static_cast<Fl_Widget*>(w)->active(); +} + +int fl_widget_active_r(WIDGET w) { + return static_cast<Fl_Widget*>(w)->active_r(); +} + +void fl_widget_set_active(WIDGET w) { + static_cast<Fl_Widget*>(w)->set_active(); +} + +void fl_widget_clear_active(WIDGET w) { + static_cast<Fl_Widget*>(w)->clear_active(); +} + + + + +unsigned int fl_widget_changed(WIDGET w) { + return static_cast<Fl_Widget*>(w)->changed(); +} + +void fl_widget_set_changed(WIDGET w) { + static_cast<Fl_Widget*>(w)->set_changed(); +} + +void fl_widget_clear_changed(WIDGET w) { + static_cast<Fl_Widget*>(w)->clear_changed(); +} + +int fl_widget_output(WIDGET w) { + return static_cast<Fl_Widget*>(w)->output(); +} + +void fl_widget_set_output(WIDGET w) { + static_cast<Fl_Widget*>(w)->set_output(); +} + +void fl_widget_clear_output(WIDGET w) { + static_cast<Fl_Widget*>(w)->clear_output(); +} + + + + +int fl_widget_visible(WIDGET w) { + return static_cast<Fl_Widget*>(w)->visible(); +} + +int fl_widget_visible_r(WIDGET w) { + return static_cast<Fl_Widget*>(w)->visible_r(); +} + +void fl_widget_set_visible(WIDGET w) { + static_cast<Fl_Widget*>(w)->set_visible(); +} + +void fl_widget_clear_visible(WIDGET w) { + static_cast<Fl_Widget*>(w)->clear_visible(); +} + +void fl_widget_show(WIDGET w) { + static_cast<Fl_Widget*>(w)->show(); +} + +void fl_widget_hide(WIDGET w) { + static_cast<Fl_Widget*>(w)->hide(); +} + + + + +int fl_widget_get_visible_focus(WIDGET w) { + return static_cast<Fl_Widget*>(w)->visible_focus(); +} + +void fl_widget_set_visible_focus2(WIDGET w) { + static_cast<Fl_Widget*>(w)->set_visible_focus(); +} + +void fl_widget_set_visible_focus(WIDGET w, int f) { + static_cast<Fl_Widget*>(w)->visible_focus(f); +} + +void fl_widget_clear_visible_focus(WIDGET w) { + static_cast<Fl_Widget*>(w)->clear_visible_focus(); +} + +int fl_widget_take_focus(WIDGET w) { + return static_cast<Fl_Widget*>(w)->take_focus(); +} + +int fl_widget_takesevents(WIDGET w) { + return static_cast<Fl_Widget*>(w)->takesevents(); +} + + + + +unsigned int fl_widget_get_color(WIDGET w) { + return static_cast<Fl_Widget*>(w)->color(); +} + +void fl_widget_set_color(WIDGET w, unsigned int b) { + static_cast<Fl_Widget*>(w)->color(b); +} + +unsigned int fl_widget_get_selection_color(WIDGET w) { + return static_cast<Fl_Widget*>(w)->selection_color(); +} + +void fl_widget_set_selection_color(WIDGET w, unsigned int c) { + static_cast<Fl_Widget*>(w)->selection_color(c); +} + +void fl_widget_set_colors(WIDGET w, unsigned int b, unsigned int s) { + static_cast<Fl_Widget*>(w)->color(b, s); +} + + + + +void * fl_widget_get_parent(WIDGET w) { + return static_cast<Fl_Widget*>(w)->parent(); +} + +int fl_widget_contains(WIDGET w, WIDGET i) { + return static_cast<Fl_Widget*>(w)->contains(static_cast<Fl_Widget*>(i)); +} + +int fl_widget_inside(WIDGET w, WIDGET p) { + return static_cast<Fl_Widget*>(w)->inside(static_cast<Fl_Widget*>(p)); +} + +void * fl_widget_window(WIDGET w) { + return static_cast<Fl_Widget*>(w)->window(); +} + +void * fl_widget_top_window(WIDGET w) { + return static_cast<Fl_Widget*>(w)->top_window(); +} + +void * fl_widget_top_window_offset(WIDGET w, int &x, int &y) { + return static_cast<Fl_Widget*>(w)->top_window_offset(x,y); +} + + + + +unsigned int fl_widget_get_align(WIDGET w) { + return static_cast<Fl_Widget*>(w)->align(); +} + +void fl_widget_set_align(WIDGET w, unsigned int a) { + static_cast<Fl_Widget*>(w)->align(a); +} + +int fl_widget_get_box(WIDGET w) { + return static_cast<Fl_Widget*>(w)->box(); +} + +void fl_widget_set_box(WIDGET w, int b) { + static_cast<Fl_Widget*>(w)->box(static_cast<Fl_Boxtype>(b)); +} + +const char * fl_widget_tooltip(WIDGET w) { + return static_cast<Fl_Widget*>(w)->tooltip(); +} + +void fl_widget_copy_tooltip(WIDGET w, const char * t) { + static_cast<Fl_Widget*>(w)->copy_tooltip(t); +} + + + + +const char* fl_widget_get_label(WIDGET w) { + return static_cast<Fl_Widget*>(w)->label(); +} + +void fl_widget_set_label(WIDGET w, const char* t) { + static_cast<Fl_Widget*>(w)->copy_label(t); +} + +unsigned int fl_widget_get_labelcolor(WIDGET w) { + return static_cast<Fl_Widget*>(w)->labelcolor(); +} + +void fl_widget_set_labelcolor(WIDGET w, unsigned int v) { + static_cast<Fl_Widget*>(w)->labelcolor(v); +} + +int fl_widget_get_labelfont(WIDGET w) { + return static_cast<Fl_Widget*>(w)->labelfont(); +} + +void fl_widget_set_labelfont(WIDGET w, int f) { + static_cast<Fl_Widget*>(w)->labelfont(static_cast<Fl_Font>(f)); +} + +int fl_widget_get_labelsize(WIDGET w) { + return static_cast<Fl_Widget*>(w)->labelsize(); +} + +void fl_widget_set_labelsize(WIDGET w, int s) { + static_cast<Fl_Widget*>(w)->labelsize(static_cast<Fl_Fontsize>(s)); +} + +int fl_widget_get_labeltype(WIDGET w) { + return static_cast<Fl_Widget*>(w)->labeltype(); +} + +void fl_widget_set_labeltype(WIDGET w, int l) { + static_cast<Fl_Widget*>(w)->labeltype(static_cast<Fl_Labeltype>(l)); +} + +void fl_widget_measure_label(WIDGET w, int &d, int &h) { + static_cast<Fl_Widget*>(w)->measure_label(d,h); +} + + + + +void fl_widget_set_callback(WIDGET w, void * cb) { + static_cast<Fl_Widget*>(w)->callback(reinterpret_cast<Fl_Callback_p>(cb)); +} + +void fl_widget_default_callback(WIDGET w, void * ud) { + Fl_Widget::default_callback(static_cast<Fl_Widget*>(w), ud); +} + +unsigned char fl_widget_get_when(WIDGET w) { + return static_cast<Fl_Widget*>(w)->when(); +} + +void fl_widget_set_when(WIDGET w, unsigned char c) { + static_cast<Fl_Widget*>(w)->when(c); +} + + + + +int fl_widget_get_x(WIDGET w) { + return static_cast<Fl_Widget*>(w)->x(); +} + +int fl_widget_get_y(WIDGET w) { + return static_cast<Fl_Widget*>(w)->y(); +} + +int fl_widget_get_w(WIDGET w) { + return static_cast<Fl_Widget*>(w)->w(); +} + +int fl_widget_get_h(WIDGET w) { + return static_cast<Fl_Widget*>(w)->h(); +} + +void fl_widget_size(WIDGET w, int d, int h) { + static_cast<Fl_Widget*>(w)->size(d, h); +} + +void fl_widget_resize(WIDGET o, int x, int y, int w, int h) { + static_cast<Fl_Widget*>(o)->resize(x, y, w, h); +} + +void fl_widget_position(WIDGET w, int x, int y) { + static_cast<Fl_Widget*>(w)->position(x, y); +} + + + + +void fl_widget_set_image(WIDGET w, void * img) { + static_cast<Fl_Widget*>(w)->image(static_cast<Fl_Image*>(img)); +} + +void fl_widget_set_deimage(WIDGET w, void * img) { + static_cast<Fl_Widget*>(w)->deimage(static_cast<Fl_Image*>(img)); +} + + + + +unsigned char fl_widget_get_type(WIDGET w) { + return static_cast<Fl_Widget*>(w)->type(); +} + +void fl_widget_set_type(WIDGET w, unsigned char t) { + static_cast<Fl_Widget*>(w)->type(t); +} + + + + +unsigned char fl_widget_damage(WIDGET w) { + return static_cast<Fl_Widget*>(w)->damage(); +} + +void fl_widget_set_damage(WIDGET w, unsigned char m) { + static_cast<Fl_Widget*>(w)->damage(m); +} + +void fl_widget_set_damage2(WIDGET w, unsigned char m, int x, int y, int d, int h) { + static_cast<Fl_Widget*>(w)->damage(m, x, y, d, h); +} + +void fl_widget_clear_damage(WIDGET w, unsigned char m) { + static_cast<Fl_Widget*>(w)->clear_damage(m); +} + +void fl_widget_draw(WIDGET w) { + // The Fl_Widget draw method doesn't technically exist, so... + (void)(w); + // It is more convenient for this function to exist, however, + // even though it will likely never be called, because it simplifies + // and makes uniform the implementation of the Ada Widget Draw subprogram. +} + +void fl_widget_draw_label(WIDGET w) { + void (Fl_Widget::*mydraw)(void) const = &Friend_Widget::draw_label; + (static_cast<Fl_Widget*>(w)->*mydraw)(); +} + +void fl_widget_draw_label2(WIDGET o, int x, int y, int w, int h) { + void (Fl_Widget::*mydraw)(int,int,int,int) const = &Friend_Widget::draw_label; + (static_cast<Fl_Widget*>(o)->*mydraw)(x, y, w, h); +} + +void fl_widget_draw_label3(WIDGET w, int x, int y, int d, int h, unsigned int a) { + static_cast<Fl_Widget*>(w)->draw_label(x, y, d, h, a); +} + +void fl_widget_draw_backdrop(WIDGET w) { + (static_cast<Fl_Widget*>(w)->*(&Friend_Widget::draw_backdrop))(); +} + +void fl_widget_draw_box(WIDGET w) { + void (Fl_Widget::*mydraw)(void) const = &Friend_Widget::draw_box; + (static_cast<Fl_Widget*>(w)->*mydraw)(); +} + +void fl_widget_draw_box2(WIDGET w, int k, unsigned int h) { + void (Fl_Widget::*mydraw)(Fl_Boxtype,Fl_Color) const = &Friend_Widget::draw_box; + (static_cast<Fl_Widget*>(w)->*mydraw)(static_cast<Fl_Boxtype>(k), static_cast<Fl_Color>(h)); +} + +void fl_widget_draw_box3(WIDGET o, int k, int x, int y, int w, int h, unsigned int c) { + void (Fl_Widget::*mydraw)(Fl_Boxtype,int,int,int,int,Fl_Color) const = &Friend_Widget::draw_box; + (static_cast<Fl_Widget*>(o)->*mydraw) + (static_cast<Fl_Boxtype>(k), x, y, w, h, static_cast<Fl_Color>(c)); +} + +void fl_widget_draw_focus(WIDGET w) { + void (Fl_Widget::*mydraw)(void) = &Friend_Widget::draw_focus; + (static_cast<Fl_Widget*>(w)->*mydraw)(); +} + +void fl_widget_draw_focus2(WIDGET o, int k, int x, int y, int w, int h) { + void (Fl_Widget::*mydraw)(Fl_Boxtype,int,int,int,int) const = &Friend_Widget::draw_focus; + (static_cast<Fl_Widget*>(o)->*mydraw)(static_cast<Fl_Boxtype>(k), x, y, w, h); +} + +void fl_widget_redraw(WIDGET w) { + static_cast<Fl_Widget*>(w)->redraw(); +} + +void fl_widget_redraw_label(WIDGET w) { + static_cast<Fl_Widget*>(w)->redraw_label(); +} + +int fl_widget_handle(WIDGET w, int e) { + return static_cast<My_Widget*>(w)->Fl_Widget::handle(e); +} + + + + +int fl_widget_use_accents_menu(WIDGET w) { + return static_cast<Fl_Widget*>(w)->use_accents_menu(); +} + + diff --git a/body/c_fl_widget.h b/body/c_fl_widget.h new file mode 100644 index 0000000..2ac2630 --- /dev/null +++ b/body/c_fl_widget.h @@ -0,0 +1,137 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_WIDGET_GUARD +#define FL_WIDGET_GUARD + + +typedef void* WIDGET; + + +extern "C" WIDGET new_fl_widget(int x, int y, int w, int h, char* label); +extern "C" void free_fl_widget(WIDGET w); + + +extern "C" void * fl_widget_get_user_data(WIDGET w); +extern "C" void fl_widget_set_user_data(WIDGET w, void * d); + + +extern "C" void fl_widget_activate(WIDGET w); +extern "C" void fl_widget_deactivate(WIDGET w); +extern "C" int fl_widget_active(WIDGET w); +extern "C" int fl_widget_active_r(WIDGET w); +extern "C" void fl_widget_set_active(WIDGET w); +extern "C" void fl_widget_clear_active(WIDGET w); + + +extern "C" unsigned int fl_widget_changed(WIDGET w); +extern "C" void fl_widget_set_changed(WIDGET w); +extern "C" void fl_widget_clear_changed(WIDGET w); +extern "C" int fl_widget_output(WIDGET w); +extern "C" void fl_widget_set_output(WIDGET w); +extern "C" void fl_widget_clear_output(WIDGET w); + + +extern "C" int fl_widget_visible(WIDGET w); +extern "C" int fl_widget_visible_r(WIDGET w); +extern "C" void fl_widget_set_visible(WIDGET w); +extern "C" void fl_widget_clear_visible(WIDGET w); +extern "C" void fl_widget_show(WIDGET w); +extern "C" void fl_widget_hide(WIDGET w); + + +extern "C" int fl_widget_get_visible_focus(WIDGET w); +extern "C" void fl_widget_set_visible_focus2(WIDGET w); +extern "C" void fl_widget_set_visible_focus(WIDGET w, int f); +extern "C" void fl_widget_clear_visible_focus(WIDGET w); +extern "C" int fl_widget_take_focus(WIDGET w); +extern "C" int fl_widget_takesevents(WIDGET w); + + +extern "C" unsigned int fl_widget_get_color(WIDGET w); +extern "C" void fl_widget_set_color(WIDGET w, unsigned int b); +extern "C" unsigned int fl_widget_get_selection_color(WIDGET w); +extern "C" void fl_widget_set_selection_color(WIDGET w, unsigned int c); +extern "C" void fl_widget_set_colors(WIDGET w, unsigned int b, unsigned int s); + + +extern "C" void * fl_widget_get_parent(WIDGET w); +extern "C" int fl_widget_contains(WIDGET w, WIDGET i); +extern "C" int fl_widget_inside(WIDGET w, WIDGET p); +extern "C" void * fl_widget_window(WIDGET w); +extern "C" void * fl_widget_top_window(WIDGET w); +extern "C" void * fl_widget_top_window_offset(WIDGET w, int &x, int &y); + + +extern "C" unsigned int fl_widget_get_align(WIDGET w); +extern "C" void fl_widget_set_align(WIDGET w, unsigned int a); +extern "C" int fl_widget_get_box(WIDGET w); +extern "C" void fl_widget_set_box(WIDGET w, int b); +extern "C" const char * fl_widget_tooltip(WIDGET w); +extern "C" void fl_widget_copy_tooltip(WIDGET w, const char * t); + + +extern "C" const char* fl_widget_get_label(WIDGET w); +extern "C" void fl_widget_set_label(WIDGET w, const char* t); +extern "C" unsigned int fl_widget_get_labelcolor(WIDGET w); +extern "C" void fl_widget_set_labelcolor(WIDGET w, unsigned int v); +extern "C" int fl_widget_get_labelfont(WIDGET w); +extern "C" void fl_widget_set_labelfont(WIDGET w, int f); +extern "C" int fl_widget_get_labelsize(WIDGET w); +extern "C" void fl_widget_set_labelsize(WIDGET w, int s); +extern "C" int fl_widget_get_labeltype(WIDGET w); +extern "C" void fl_widget_set_labeltype(WIDGET w, int l); +extern "C" void fl_widget_measure_label(WIDGET w, int &d, int &h); + + +extern "C" void fl_widget_set_callback(WIDGET w, void * cb); +extern "C" void fl_widget_default_callback(WIDGET w, void * ud); +extern "C" unsigned char fl_widget_get_when(WIDGET w); +extern "C" void fl_widget_set_when(WIDGET w, unsigned char c); + + +extern "C" int fl_widget_get_x(WIDGET w); +extern "C" int fl_widget_get_y(WIDGET w); +extern "C" int fl_widget_get_w(WIDGET w); +extern "C" int fl_widget_get_h(WIDGET w); +extern "C" void fl_widget_size(WIDGET w, int d, int h); +extern "C" void fl_widget_resize(WIDGET o, int x, int y, int w, int h); +extern "C" void fl_widget_position(WIDGET w, int x, int y); + + +extern "C" void fl_widget_set_image(WIDGET w, void * img); +extern "C" void fl_widget_set_deimage(WIDGET w, void * img); + + +extern "C" unsigned char fl_widget_get_type(WIDGET w); +extern "C" void fl_widget_set_type(WIDGET w, unsigned char t); + + +extern "C" unsigned char fl_widget_damage(WIDGET w); +extern "C" void fl_widget_set_damage(WIDGET w, unsigned char m); +extern "C" void fl_widget_set_damage2(WIDGET w, unsigned char m, int x, int y, int d, int h); +extern "C" void fl_widget_clear_damage(WIDGET w, unsigned char m); +extern "C" void fl_widget_draw(WIDGET w); +extern "C" void fl_widget_draw_label(WIDGET w); +extern "C" void fl_widget_draw_label2(WIDGET o, int x, int y, int w, int h); +extern "C" void fl_widget_draw_label3(WIDGET w, int x, int y, int d, int h, unsigned int a); +extern "C" void fl_widget_draw_backdrop(WIDGET w); +extern "C" void fl_widget_draw_box(WIDGET w); +extern "C" void fl_widget_draw_box2(WIDGET w, int k, unsigned int h); +extern "C" void fl_widget_draw_box3(WIDGET o, int k, int x, int y, int w, int h, unsigned int c); +extern "C" void fl_widget_draw_focus(WIDGET w); +extern "C" void fl_widget_draw_focus2(WIDGET o, int k, int x, int y, int w, int h); +extern "C" void fl_widget_redraw(WIDGET w); +extern "C" void fl_widget_redraw_label(WIDGET w); +extern "C" int fl_widget_handle(WIDGET w, int e); + + +extern "C" int fl_widget_use_accents_menu(WIDGET w); + + +#endif + + diff --git a/body/c_fl_window.cpp b/body/c_fl_window.cpp new file mode 100644 index 0000000..d0314be --- /dev/null +++ b/body/c_fl_window.cpp @@ -0,0 +1,318 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Window.H> +#include <FL/Fl_RGB_Image.H> +#include "c_fl_window.h" +#include "c_fl.h" + + + + +// Exports from Ada + +extern "C" void widget_draw_hook(void * ud); +extern "C" int widget_handle_hook(void * ud, int e); + + + + +// Non-friend protected access + +class Friend_Window : Fl_Window { +public: + using Fl_Window::flush; + using Fl_Window::force_position; +}; + + + + +// Attaching all relevant hooks and friends + +class My_Window : public Fl_Window { +public: + using Fl_Window::Fl_Window; + + friend void fl_window_draw(WINDOW n); + friend int fl_window_handle(WINDOW n, int e); + + void draw(); + int handle(int e); +}; + +void My_Window::draw() { + widget_draw_hook(this->user_data()); +} + +int My_Window::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +WINDOW new_fl_window(int x, int y, int w, int h, char* label) { + My_Window *n = new My_Window(x, y, w, h, label); + return n; +} + +WINDOW new_fl_window2(int w, int h, char* label) { + My_Window *n = new My_Window(w, h, label); + return n; +} + +void free_fl_window(WINDOW n) { + if (fl_inside_callback) { + fl_delete_widget(n); + } else { + delete static_cast<My_Window*>(n); + } +} + + + + +void fl_window_show(WINDOW n) { + // virtual, so disable dispatch + static_cast<Fl_Window*>(n)->Fl_Window::show(); +} + +void fl_window_show2(WINDOW n, int c, void * v) { + static_cast<Fl_Window*>(n)->show(c, static_cast<char**>(v)); +} + +void fl_window_hide(WINDOW n) { + // virtual, so disable dispatch + static_cast<Fl_Window*>(n)->Fl_Window::hide(); +} + +int fl_window_shown(WINDOW n) { + return static_cast<Fl_Window*>(n)->shown(); +} + +void fl_window_wait_for_expose(WINDOW n) { + static_cast<Fl_Window*>(n)->wait_for_expose(); +} + +void fl_window_iconize(WINDOW n) { + static_cast<Fl_Window*>(n)->iconize(); +} + +void fl_window_make_current(WINDOW n) { + static_cast<Fl_Window*>(n)->make_current(); +} + + + + +unsigned int fl_window_fullscreen_active(WINDOW n) { + return static_cast<Fl_Window*>(n)->fullscreen_active(); +} + +void fl_window_fullscreen(WINDOW n) { + static_cast<Fl_Window*>(n)->fullscreen(); +} + +void fl_window_fullscreen_off(WINDOW n) { + static_cast<Fl_Window*>(n)->fullscreen_off(); +} + +void fl_window_fullscreen_off2(WINDOW n, int x, int y, int w, int h) { + static_cast<Fl_Window*>(n)->fullscreen_off(x,y,w,h); +} + +void fl_window_fullscreen_screens(WINDOW n, int t, int b, int l, int r) { + static_cast<Fl_Window*>(n)->fullscreen_screens(t,b,l,r); +} + + + + +void fl_window_set_icon(WINDOW n, void * img) { + static_cast<Fl_Window*>(n)->icon(static_cast<Fl_RGB_Image*>(img)); +} + +void fl_window_icons(WINDOW n, void * imgs, int count) { + static_cast<Fl_Window*>(n)->icons(static_cast<const Fl_RGB_Image**>(imgs), count); +} + +void fl_window_default_icon(void * img) { + Fl_Window::default_icon(static_cast<Fl_RGB_Image*>(img)); +} + +void fl_window_default_icons(void * imgs, int count) { + Fl_Window::default_icons(static_cast<const Fl_RGB_Image**>(imgs), count); +} + +const char * fl_window_get_iconlabel(WINDOW n) { + return static_cast<Fl_Window*>(n)->iconlabel(); +} + +void fl_window_set_iconlabel(WINDOW n, const char * s) { + static_cast<Fl_Window*>(n)->iconlabel(s); +} + +void fl_window_set_cursor(WINDOW n, int c) { + static_cast<Fl_Window*>(n)->cursor(static_cast<Fl_Cursor>(c)); +} + +void fl_window_set_cursor2(WINDOW n, void * img, int x, int y) { + static_cast<Fl_Window*>(n)->cursor(static_cast<Fl_RGB_Image*>(img),x,y); +} + +void fl_window_set_default_cursor(WINDOW n, int c) { + static_cast<Fl_Window*>(n)->default_cursor(static_cast<Fl_Cursor>(c)); +} + + + + +unsigned int fl_window_get_border(WINDOW n) { + return static_cast<Fl_Window*>(n)->border(); +} + +void fl_window_set_border(WINDOW n, int b) { + static_cast<Fl_Window*>(n)->border(b); +} + +void fl_window_clear_border(WINDOW n) { + static_cast<Fl_Window*>(n)->clear_border(); +} + +unsigned int fl_window_get_override(WINDOW n) { + return static_cast<Fl_Window*>(n)->override(); +} + +void fl_window_set_override(WINDOW n) { + static_cast<Fl_Window*>(n)->set_override(); +} + +unsigned int fl_window_modal(WINDOW n) { + return static_cast<Fl_Window*>(n)->modal(); +} + +unsigned int fl_window_non_modal(WINDOW n) { + return static_cast<Fl_Window*>(n)->non_modal(); +} + +void fl_window_clear_modal_states(WINDOW n) { + static_cast<Fl_Window*>(n)->clear_modal_states(); +} + +void fl_window_set_modal(WINDOW n) { + static_cast<Fl_Window*>(n)->set_modal(); +} + +void fl_window_set_non_modal(WINDOW n) { + static_cast<Fl_Window*>(n)->set_non_modal(); +} + + + + +const char * fl_window_get_label(WINDOW n) { + return static_cast<Fl_Window*>(n)->label(); +} + +void fl_window_copy_label(WINDOW n, char* text) { + static_cast<Fl_Window*>(n)->copy_label(text); +} + +void fl_window_hotspot(WINDOW n, int x, int y, int s) { + static_cast<Fl_Window*>(n)->hotspot(x,y,s); +} + +void fl_window_hotspot2(WINDOW n, void * i, int s) { + static_cast<Fl_Window*>(n)->hotspot(static_cast<Fl_Widget*>(i),s); +} + +void fl_window_shape(WINDOW n, void * p) { + static_cast<Fl_Window*>(n)->shape(static_cast<Fl_Image*>(p)); +} + + + + +void fl_window_size_range(WINDOW n, int lw, int lh, int hw, int hh, int dw, int dh, int a) { + static_cast<Fl_Window*>(n)->size_range(lw, lh, hw, hh, dw, dh, a); +} + +void fl_window_resize(WINDOW n, int x, int y, int w, int h) { + static_cast<Fl_Window*>(n)->resize(x, y, w, h); +} + +int fl_window_get_force_position(WINDOW n) { + int (Fl_Window::*myforce)() const = &Friend_Window::force_position; + return (static_cast<Fl_Window*>(n)->*myforce)(); +} + +void fl_window_set_force_position(WINDOW n, int s) { + void (Fl_Window::*myforce)(int) = &Friend_Window::force_position; + (static_cast<Fl_Window*>(n)->*myforce)(s); +} + +int fl_window_get_x_root(WINDOW n) { + return static_cast<Fl_Window*>(n)->x_root(); +} + +int fl_window_get_y_root(WINDOW n) { + return static_cast<Fl_Window*>(n)->y_root(); +} + +int fl_window_get_decorated_w(WINDOW n) { + return static_cast<Fl_Window*>(n)->decorated_w(); +} + +int fl_window_get_decorated_h(WINDOW n) { + return static_cast<Fl_Window*>(n)->decorated_h(); +} + + + + +const char * fl_window_get_xclass(WINDOW n) { + return static_cast<Fl_Window*>(n)->xclass(); +} + +void fl_window_set_xclass(WINDOW n, const char * c) { + static_cast<Fl_Window*>(n)->xclass(c); +} + +const char * fl_window_get_default_xclass() { + return Fl_Window::default_xclass(); +} + +void fl_window_set_default_xclass(const char * c) { + Fl_Window::default_xclass(c); +} + +unsigned int fl_window_menu_window(WINDOW n) { + return static_cast<Fl_Window*>(n)->menu_window(); +} + +unsigned int fl_window_tooltip_window(WINDOW n) { + return static_cast<Fl_Window*>(n)->tooltip_window(); +} + + + + +void fl_window_draw(WINDOW n) { + static_cast<My_Window*>(n)->Fl_Window::draw(); +} + +void fl_window_flush(WINDOW n) { + (static_cast<Fl_Window*>(n)->*(&Friend_Window::flush))(); +} + +int fl_window_handle(WINDOW n, int e) { + return static_cast<My_Window*>(n)->Fl_Window::handle(e); +} + + diff --git a/body/c_fl_window.h b/body/c_fl_window.h new file mode 100644 index 0000000..337cf77 --- /dev/null +++ b/body/c_fl_window.h @@ -0,0 +1,90 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_WINDOW_GUARD +#define FL_WINDOW_GUARD + + +typedef void* WINDOW; + + +extern "C" WINDOW new_fl_window(int x, int y, int w, int h, char* label); +extern "C" WINDOW new_fl_window2(int w, int h, char* label); +extern "C" void free_fl_window(WINDOW n); + + +extern "C" void fl_window_show(WINDOW n); +extern "C" void fl_window_show2(WINDOW n, int c, void * v); +extern "C" void fl_window_hide(WINDOW n); +extern "C" int fl_window_shown(WINDOW n); +extern "C" void fl_window_wait_for_expose(WINDOW n); +extern "C" void fl_window_iconize(WINDOW n); +extern "C" void fl_window_make_current(WINDOW n); + + +extern "C" unsigned int fl_window_fullscreen_active(WINDOW n); +extern "C" void fl_window_fullscreen(WINDOW n); +extern "C" void fl_window_fullscreen_off(WINDOW n); +extern "C" void fl_window_fullscreen_off2(WINDOW n, int x, int y, int w, int h); +extern "C" void fl_window_fullscreen_screens(WINDOW n, int t, int b, int l, int r); + + +extern "C" void fl_window_set_icon(WINDOW n, void * img); +extern "C" void fl_window_icons(WINDOW n, void * imgs, int count); +extern "C" void fl_window_default_icon(void * img); +extern "C" void fl_window_default_icons(void * imgs, int count); +extern "C" const char * fl_window_get_iconlabel(WINDOW n); +extern "C" void fl_window_set_iconlabel(WINDOW n, const char * s); +extern "C" void fl_window_set_cursor(WINDOW n, int c); +extern "C" void fl_window_set_cursor2(WINDOW n, void * img, int x, int y); +extern "C" void fl_window_set_default_cursor(WINDOW n, int c); + + +extern "C" unsigned int fl_window_get_border(WINDOW n); +extern "C" void fl_window_set_border(WINDOW n, int b); +extern "C" void fl_window_clear_border(WINDOW n); +extern "C" unsigned int fl_window_get_override(WINDOW n); +extern "C" void fl_window_set_override(WINDOW n); +extern "C" unsigned int fl_window_modal(WINDOW n); +extern "C" unsigned int fl_window_non_modal(WINDOW n); +extern "C" void fl_window_set_modal(WINDOW n); +extern "C" void fl_window_set_non_modal(WINDOW n); +extern "C" void fl_window_clear_modal_states(WINDOW n); + + +extern "C" const char * fl_window_get_label(WINDOW n); +extern "C" void fl_window_copy_label(WINDOW n, char* text); +extern "C" void fl_window_hotspot(WINDOW n, int x, int y, int s); +extern "C" void fl_window_hotspot2(WINDOW n, void * i, int s); +extern "C" void fl_window_shape(WINDOW n, void * p); + + +extern "C" void fl_window_size_range(WINDOW n, int lw, int lh, int hw, int hh, int dw, int dh, int a); +extern "C" void fl_window_resize(WINDOW n, int x, int y, int w, int h); +extern "C" int fl_window_get_force_position(WINDOW n); +extern "C" void fl_window_set_force_position(WINDOW n, int s); +extern "C" int fl_window_get_x_root(WINDOW n); +extern "C" int fl_window_get_y_root(WINDOW n); +extern "C" int fl_window_get_decorated_w(WINDOW n); +extern "C" int fl_window_get_decorated_h(WINDOW n); + + +extern "C" const char * fl_window_get_xclass(WINDOW n); +extern "C" void fl_window_set_xclass(WINDOW n, const char * c); +extern "C" const char * fl_window_get_default_xclass(); +extern "C" void fl_window_set_default_xclass(const char * c); +extern "C" unsigned int fl_window_menu_window(WINDOW n); +extern "C" unsigned int fl_window_tooltip_window(WINDOW n); + + +extern "C" void fl_window_draw(WINDOW n); +extern "C" void fl_window_flush(WINDOW n); +extern "C" int fl_window_handle(WINDOW n, int e); + + +#endif + + diff --git a/body/c_fl_wizard.cpp b/body/c_fl_wizard.cpp new file mode 100644 index 0000000..b494cc3 --- /dev/null +++ b/body/c_fl_wizard.cpp @@ -0,0 +1,111 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Wizard.H> +#include "c_fl_wizard.h" +#include "c_fl.h" + + + + +// Exports from Ada + +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_Wizard : public Fl_Wizard { +public: + using Fl_Wizard::Fl_Wizard; + + friend void fl_wizard_draw(WIZARD w); + friend int fl_wizard_handle(WIZARD w, int e); + + void draw(); + void real_draw(); + int handle(int e); +}; + +void My_Wizard::draw() { + widget_draw_hook(this->user_data()); +} + +void My_Wizard::real_draw() { + // required because of Fl_Wizard::draw() being private + // probably a bug in FLTK? + Fl_Widget *kid = value(); + if (damage() & FL_DAMAGE_ALL) { + if (kid) { + draw_box(box(), x(), y(), w(), h(), kid->color()); + draw_child(*kid); + } else { + draw_box(box(), x(), y(), w(), h(), color()); + } + } else if (kid) { + update_child(*kid); + } +} + +int My_Wizard::handle(int e) { + return widget_handle_hook(this->user_data(), e); +} + + + + +// Flattened C API + +WIZARD new_fl_wizard(int x, int y, int w, int h, char* label) { + My_Wizard *g = new My_Wizard(x, y, w, h, label); + return g; +} + +void free_fl_wizard(WIZARD w) { + if (fl_inside_callback) { + fl_delete_widget(w); + } else { + delete static_cast<My_Wizard*>(w); + } +} + + + + +void fl_wizard_next(WIZARD w) { + static_cast<Fl_Wizard*>(w)->next(); +} + +void fl_wizard_prev(WIZARD w) { + static_cast<Fl_Wizard*>(w)->prev(); +} + + + + +void * fl_wizard_get_visible(WIZARD w) { + return static_cast<Fl_Wizard*>(w)->value(); +} + +void fl_wizard_set_visible(WIZARD w, void * i) { + static_cast<Fl_Wizard*>(w)->value(static_cast<Fl_Widget*>(i)); +} + + + + +void fl_wizard_draw(WIZARD w) { + static_cast<My_Wizard*>(w)->real_draw(); +} + +int fl_wizard_handle(WIZARD w, int e) { + return static_cast<My_Wizard*>(w)->Fl_Wizard::handle(e); +} + + diff --git a/body/c_fl_wizard.h b/body/c_fl_wizard.h new file mode 100644 index 0000000..fb710ec --- /dev/null +++ b/body/c_fl_wizard.h @@ -0,0 +1,32 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_WIZARD_GUARD +#define FL_WIZARD_GUARD + + +typedef void* WIZARD; + + +extern "C" WIZARD new_fl_wizard(int x, int y, int w, int h, char* label); +extern "C" void free_fl_wizard(WIZARD w); + + +extern "C" void fl_wizard_next(WIZARD w); +extern "C" void fl_wizard_prev(WIZARD w); + + +extern "C" void * fl_wizard_get_visible(WIZARD w); +extern "C" void fl_wizard_set_visible(WIZARD w, void * i); + + +extern "C" void fl_wizard_draw(WIZARD w); +extern "C" int fl_wizard_handle(WIZARD w, int e); + + +#endif + + diff --git a/body/c_fl_xbm_image.cpp b/body/c_fl_xbm_image.cpp new file mode 100644 index 0000000..2ecd890 --- /dev/null +++ b/body/c_fl_xbm_image.cpp @@ -0,0 +1,22 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_XBM_Image.H> +#include "c_fl_xbm_image.h" + + + + +XBMIMAGE new_fl_xbm_image(const char * f) { + Fl_XBM_Image *b = new Fl_XBM_Image(f); + return b; +} + +void free_fl_xbm_image(XBMIMAGE b) { + delete static_cast<Fl_XBM_Image*>(b); +} + + diff --git a/body/c_fl_xbm_image.h b/body/c_fl_xbm_image.h new file mode 100644 index 0000000..668d3f8 --- /dev/null +++ b/body/c_fl_xbm_image.h @@ -0,0 +1,20 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_XBM_IMAGE_GUARD +#define FL_XBM_IMAGE_GUARD + + +typedef void* XBMIMAGE; + + +extern "C" XBMIMAGE new_fl_xbm_image(const char * f); +extern "C" void free_fl_xbm_image(XBMIMAGE b); + + +#endif + + diff --git a/body/c_fl_xpm_image.cpp b/body/c_fl_xpm_image.cpp new file mode 100644 index 0000000..fcf60c2 --- /dev/null +++ b/body/c_fl_xpm_image.cpp @@ -0,0 +1,22 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_XPM_Image.H> +#include "c_fl_xpm_image.h" + + + + +XPMIMAGE new_fl_xpm_image(const char * f) { + Fl_XPM_Image *j = new Fl_XPM_Image(f); + return j; +} + +void free_fl_xpm_image(XPMIMAGE j) { + delete static_cast<Fl_XPM_Image*>(j); +} + + diff --git a/body/c_fl_xpm_image.h b/body/c_fl_xpm_image.h new file mode 100644 index 0000000..a925c33 --- /dev/null +++ b/body/c_fl_xpm_image.h @@ -0,0 +1,20 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_XPM_IMAGE_GUARD +#define FL_XPM_IMAGE_GUARD + + +typedef void* XPMIMAGE; + + +extern "C" XPMIMAGE new_fl_xpm_image(const char * f); +extern "C" void free_fl_xpm_image(XPMIMAGE j); + + +#endif + + diff --git a/body/fltk-args_marshal.adb b/body/fltk-args_marshal.adb new file mode 100644 index 0000000..f08e025 --- /dev/null +++ b/body/fltk-args_marshal.adb @@ -0,0 +1,56 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Command_Line, + Interfaces.C; + + +package body FLTK.Args_Marshal is + + + package ACom renames Ada.Command_Line; + package IntC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + + function Create_Argv + return ICS.chars_ptr_array + is + Result : ICS.chars_ptr_array (0 .. IntC.size_t (ACom.Argument_Count)); + begin + Result (0) := ICS.New_String (ACom.Command_Name); + for Index in Integer range 1 .. ACom.Argument_Count loop + Result (IntC.size_t (Index)) := ICS.New_String (ACom.Argument (Index)); + end loop; + return Result; + end Create_Argv; + + + procedure Free_Argv + (Argv : in out Interfaces.C.Strings.chars_ptr_array) is + begin + for Ptr of Argv loop + ICS.Free (Ptr); + end loop; + end Free_Argv; + + + procedure Dispatch + (Func : in Show_With_Args_Func; + CObj : in Storage.Integer_Address) + is + Argv : ICS.chars_ptr_array := Create_Argv; + begin + Func (CObj, Argv'Length, Storage.To_Integer (Argv (Argv'First)'Address)); + Free_Argv (Argv); + end Dispatch; + + +end FLTK.Args_Marshal; + + diff --git a/body/fltk-args_marshal.ads b/body/fltk-args_marshal.ads new file mode 100644 index 0000000..b19c182 --- /dev/null +++ b/body/fltk-args_marshal.ads @@ -0,0 +1,46 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + + +private package FLTK.Args_Marshal is + + + function Create_Argv + return Interfaces.C.Strings.chars_ptr_array; + + procedure Free_Argv + (Argv : in out Interfaces.C.Strings.chars_ptr_array); + + + + + -- Used for implementing show(argc,argv) + + -- Dispatch marshalls the data, calls the function, then does cleanup + + type Show_With_Args_Func is access procedure + (CObj : in Storage.Integer_Address; + Argc : in Interfaces.C.int; + Argv : in Storage.Integer_Address); + + procedure Dispatch + (Func : in Show_With_Args_Func; + CObj : in Storage.Integer_Address); + + +private + + + pragma Convention (C, Show_With_Args_Func); + + +end FLTK.Args_Marshal; + + diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb new file mode 100644 index 0000000..8d4f900 --- /dev/null +++ b/body/fltk-asks.adb @@ -0,0 +1,729 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Asks is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Static Attributes -- + + function fl_ask_get_cancel + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_cancel, "fl_ask_get_cancel"); + pragma Inline (fl_ask_get_cancel); + + procedure fl_ask_set_cancel + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_cancel, "fl_ask_set_cancel"); + pragma Inline (fl_ask_set_cancel); + + function fl_ask_get_close + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_close, "fl_ask_get_close"); + pragma Inline (fl_ask_get_close); + + procedure fl_ask_set_close + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_close, "fl_ask_set_close"); + pragma Inline (fl_ask_set_close); + + function fl_ask_get_no + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_no, "fl_ask_get_no"); + pragma Inline (fl_ask_get_no); + + procedure fl_ask_set_no + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_no, "fl_ask_set_no"); + pragma Inline (fl_ask_set_no); + + function fl_ask_get_ok + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_ok, "fl_ask_get_ok"); + pragma Inline (fl_ask_get_ok); + + procedure fl_ask_set_ok + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_ok, "fl_ask_set_ok"); + pragma Inline (fl_ask_set_ok); + + function fl_ask_get_yes + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_yes, "fl_ask_get_yes"); + pragma Inline (fl_ask_get_yes); + + procedure fl_ask_set_yes + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_yes, "fl_ask_set_yes"); + pragma Inline (fl_ask_set_yes); + + + + + -- Simple Messages -- + + procedure fl_ask_alert + (M : in Interfaces.C.char_array); + pragma Import (C, fl_ask_alert, "fl_ask_alert"); + pragma Inline (fl_ask_alert); + + procedure fl_ask_beep + (B : in Interfaces.C.int); + pragma Import (C, fl_ask_beep, "fl_ask_beep"); + pragma Inline (fl_ask_beep); + + function fl_ask_choice + (M, A : in Interfaces.C.char_array; + B, C : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + pragma Import (C, fl_ask_choice, "fl_ask_choice"); + pragma Inline (fl_ask_choice); + + function fl_ask_choice_n + (M, A : in Interfaces.C.char_array; + B, C : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + pragma Import (C, fl_ask_choice_n, "fl_ask_choice_n"); + pragma Inline (fl_ask_choice_n); + + function fl_ask_input + (M, D : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_input, "fl_ask_input"); + pragma Inline (fl_ask_input); + + procedure fl_ask_message + (M : in Interfaces.C.char_array); + pragma Import (C, fl_ask_message, "fl_ask_message"); + pragma Inline (fl_ask_message); + + function fl_ask_password + (M, D : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_password, "fl_ask_password"); + pragma Inline (fl_ask_password); + + + + + -- Choosers -- + + function fl_ask_color_chooser + (N : in Interfaces.C.char_array; + R, G, B : in out Interfaces.C.double; + M : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_ask_color_chooser, "fl_ask_color_chooser"); + pragma Inline (fl_ask_color_chooser); + + function fl_ask_color_chooser2 + (N : in Interfaces.C.char_array; + R, G, B : in out Interfaces.C.unsigned_char; + M : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); + pragma Inline (fl_ask_color_chooser2); + + function fl_ask_show_colormap + (H : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_ask_show_colormap, "fl_ask_show_colormap"); + pragma Inline (fl_ask_show_colormap); + + function fl_ask_dir_chooser + (M, D : in Interfaces.C.char_array; + R : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_dir_chooser, "fl_ask_dir_chooser"); + pragma Inline (fl_ask_dir_chooser); + + function fl_ask_file_chooser + (M, P, D : in Interfaces.C.char_array; + R : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_file_chooser, "fl_ask_file_chooser"); + pragma Inline (fl_ask_file_chooser); + + procedure fl_ask_file_chooser_callback + (CB : in Storage.Integer_Address); + pragma Import (C, fl_ask_file_chooser_callback, "fl_ask_file_chooser_callback"); + pragma Inline (fl_ask_file_chooser_callback); + + procedure fl_ask_file_chooser_ok_label + (L : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_file_chooser_ok_label, "fl_ask_file_chooser_ok_label"); + pragma Inline (fl_ask_file_chooser_ok_label); + + + + + -- Settings -- + + function fl_ask_get_message_hotspot + return Interfaces.C.int; + pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot"); + pragma Inline (fl_ask_get_message_hotspot); + + procedure fl_ask_set_message_hotspot + (V : in Interfaces.C.int); + pragma Import (C, fl_ask_set_message_hotspot, "fl_ask_set_message_hotspot"); + pragma Inline (fl_ask_set_message_hotspot); + + procedure fl_ask_message_font + (F, S : in Interfaces.C.int); + pragma Import (C, fl_ask_message_font, "fl_ask_message_font"); + pragma Inline (fl_ask_message_font); + + function fl_ask_message_icon + return Storage.Integer_Address; + pragma Import (C, fl_ask_message_icon, "fl_ask_message_icon"); + pragma Inline (fl_ask_message_icon); + + procedure fl_ask_message_title + (T : in Interfaces.C.char_array); + pragma Import (C, fl_ask_message_title, "fl_ask_message_title"); + pragma Inline (fl_ask_message_title); + + procedure fl_ask_message_title_default + (T : in Interfaces.C.char_array); + pragma Import (C, fl_ask_message_title_default, "fl_ask_message_title_default"); + pragma Inline (fl_ask_message_title_default); + + + + + --------------------- + -- Callback Hook -- + --------------------- + + procedure File_Chooser_Callback_Hook + (C_Str : in Interfaces.C.Strings.chars_ptr); + + pragma Convention (C, File_Chooser_Callback_Hook); + + procedure File_Chooser_Callback_Hook + (C_Str : in Interfaces.C.Strings.chars_ptr) is + begin + if Chooser_Func /= null then + Chooser_Func (Interfaces.C.Strings.Value (C_Str)); + end if; + end File_Chooser_Callback_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Dialog_String_Final_Controller) + is + use Interfaces.C.Strings; + begin + Free (Cancel_Str); + Free (Close_Str); + Free (No_Str); + Free (OK_Str); + Free (Yes_Str); + Free (Chooser_OK_Str); + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- You can get out of a hole by digging deeper, right? + procedure fl_box_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_box_extra_init, "fl_box_extra_init"); + pragma Inline (fl_box_extra_init); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Static Attributes -- + + function Get_Cancel_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_cancel); + end Get_Cancel_String; + + + procedure Set_Cancel_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Cancel_Str); + Cancel_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_cancel (Cancel_Str); + end Set_Cancel_String; + + + function Get_Close_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_close); + end Get_Close_String; + + + procedure Set_Close_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Close_Str); + Close_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_close (Close_Str); + end Set_Close_String; + + + function Get_No_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_no); + end Get_No_String; + + + procedure Set_No_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (No_Str); + No_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_no (No_Str); + end Set_No_String; + + + function Get_OK_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_ok); + end Get_OK_String; + + + procedure Set_OK_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (OK_Str); + OK_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_ok (OK_Str); + end Set_OK_String; + + + function Get_Yes_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_yes); + end Get_Yes_String; + + + procedure Set_Yes_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Yes_Str); + Yes_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_yes (Yes_Str); + end Set_Yes_String; + + + + + -- Simple Messages -- + + procedure Alert + (Message : String) is + begin + fl_ask_alert (Interfaces.C.To_C (Message)); + end Alert; + + + procedure Beep + (Kind : in Beep_Kind := Default_Beep) is + begin + fl_ask_beep (Beep_Kind'Pos (Kind)); + end Beep; + + + function Choice + (Message, Button1 : in String) + return Choice_Result + is + Result : constant Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.Null_Ptr, + Interfaces.C.Strings.Null_Ptr); + begin + return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Choice; + + + function Choice + (Message, Button1, Button2 : in String) + return Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Result : constant Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.Null_Ptr); + begin + return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Choice; + + + function Choice + (Message, Button1, Button2, Button3 : in String) + return Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); + Result : constant Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); + begin + return Choice_Result'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Choice; + + + function Extended_Choice + (Message, Button1 : in String) + return Extended_Choice_Result + is + Result : constant Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.Null_Ptr, + Interfaces.C.Strings.Null_Ptr); + begin + pragma Assert (Result in -3 .. 2); + return Extended_Choice_Result'Val (Result mod 6); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Extended_Choice; + + + function Extended_Choice + (Message, Button1, Button2 : in String) + return Extended_Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Result : constant Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.Null_Ptr); + begin + pragma Assert (Result in -3 .. 2); + return Extended_Choice_Result'Val (Result mod 6); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Extended_Choice; + + + function Extended_Choice + (Message, Button1, Button2, Button3 : in String) + return Extended_Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); + Result : constant Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); + begin + pragma Assert (Result in -3 .. 2); + return Extended_Choice_Result'Val (Result mod 6); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Extended_Choice; + + + function Text_Input + (Message : in String; + Default : in String := "") + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_input + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Default)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Text_Input; + + + procedure Message_Box + (Message : in String) is + begin + fl_ask_message (Interfaces.C.To_C (Message)); + end Message_Box; + + + function Password + (Message : in String; + Default : in String := "") + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_password + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Default)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Password; + + + + + -- Choosers -- + + function Color_Chooser + (Title : in String; + R, G, B : in out RGB_Float; + Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := + FLTK.Widgets.Groups.Color_Choosers.RGB) + return Confirm_Result + is + C_R : Interfaces.C.double := Interfaces.C.double (R); + C_G : Interfaces.C.double := Interfaces.C.double (G); + C_B : Interfaces.C.double := Interfaces.C.double (B); + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); + begin + if Result = 1 then + R := RGB_Float (C_R); + G := RGB_Float (C_G); + B := RGB_Float (C_B); + return Confirm; + else + pragma Assert (Result = 0); + return Cancel; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_color_chooser returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Color_Chooser; + + + function Color_Chooser + (Title : in String; + R, G, B : in out RGB_Int; + Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := + FLTK.Widgets.Groups.Color_Choosers.RGB) + return Confirm_Result + is + C_R : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (R); + C_G : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (G); + C_B : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (B); + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser2 + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); + begin + if Result = 1 then + R := RGB_Int (C_R); + G := RGB_Int (C_G); + B := RGB_Int (C_B); + return Confirm; + else + pragma Assert (Result = 0); + return Cancel; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_color_chooser returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Color_Chooser; + + + function Show_Colormap + (Old_Hue : in Color) + return Color is + begin + return Color (fl_ask_show_colormap (Interfaces.C.unsigned (Old_Hue))); + end Show_Colormap; + + + function Dir_Chooser + (Message, Default : in String; + Relative : in Boolean := False) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Default), + Boolean'Pos (Relative)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Dir_Chooser; + + + function File_Chooser + (Message, Filter_Pattern, Default : in String; + Relative : in Boolean := False) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Filter_Pattern), + Interfaces.C.To_C (Default), + Boolean'Pos (Relative)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end File_Chooser; + + + procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback) is + begin + Chooser_Func := Func; + end Set_File_Chooser_Callback; + + + procedure Set_File_Chooser_OK_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Chooser_OK_Str); + Chooser_OK_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_file_chooser_ok_label (Chooser_OK_Str); + end Set_File_Chooser_OK_String; + + + + + -- Settings -- + + function Get_Message_Hotspot + return Boolean is + begin + return fl_ask_get_message_hotspot /= 0; + end Get_Message_Hotspot; + + + procedure Set_Message_Hotspot + (To : in Boolean) is + begin + fl_ask_set_message_hotspot (Boolean'Pos (To)); + end Set_Message_Hotspot; + + + procedure Set_Message_Font + (Font : in Font_Kind; + Size : in Font_Size) is + begin + fl_ask_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size)); + end Set_Message_Font; + + + function Get_Message_Icon + return FLTK.Widgets.Boxes.Box_Reference is + begin + return (Data => Icon_Box'Access); + end Get_Message_Icon; + + + procedure Set_Message_Title + (To : in String) is + begin + fl_ask_message_title (Interfaces.C.To_C (To)); + end Set_Message_Title; + + + procedure Set_Message_Title_Default + (To : in String) is + begin + fl_ask_message_title_default (Interfaces.C.To_C (To)); + end Set_Message_Title_Default; + + +begin + + + Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon; + Wrapper (Icon_Box).Needs_Dealloc := False; + fl_box_extra_init + (Storage.To_Integer (Icon_Box'Address), + Interfaces.C.int (Icon_Box.Get_X), + Interfaces.C.int (Icon_Box.Get_Y), + Interfaces.C.int (Icon_Box.Get_W), + Interfaces.C.int (Icon_Box.Get_H), + Interfaces.C.To_C (Icon_Box.Get_Label)); + + + fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address)); + + +end FLTK.Asks; + + diff --git a/body/fltk-box_draw_marshal.adb b/body/fltk-box_draw_marshal.adb new file mode 100644 index 0000000..95a33ba --- /dev/null +++ b/body/fltk-box_draw_marshal.adb @@ -0,0 +1,693 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Static, + Interfaces.C; + +use type + + FLTK.Static.Box_Draw_Function; + + +package body FLTK.Box_Draw_Marshal is + + + package Chk renames Ada.Assertions; + + + + + C_Ptr_Array : array (Box_Kind) of Storage.Integer_Address; + Ada_Access_Array : array (Box_Kind) of FLTK.Static.Box_Draw_Function; + + + + + procedure fl_static_box_draw_marshal + (F : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_static_box_draw_marshal, "fl_static_box_draw_marshal"); + pragma Inline (fl_static_box_draw_marshal); + + + + + generic + Kind : Box_Kind; + procedure Generic_Box_Draw + (X, Y, W, H : in Integer; + Tone : in Color) + with Inline; + + procedure Generic_Box_Draw + (X, Y, W, H : in Integer; + Tone : in Color) is + begin + fl_static_box_draw_marshal + (C_Ptr_Array (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Tone)); + end Generic_Box_Draw; + + procedure No_Box_Draw is new Generic_Box_Draw (No_Box); + procedure Flat_Box_Draw is new Generic_Box_Draw (Flat_Box); + procedure Up_Box_Draw is new Generic_Box_Draw (Up_Box); + procedure Down_Box_Draw is new Generic_Box_Draw (Down_Box); + procedure Up_Frame_Draw is new Generic_Box_Draw (Up_Frame); + procedure Down_Frame_Draw is new Generic_Box_Draw (Down_Frame); + procedure Thin_Up_Box_Draw is new Generic_Box_Draw (Thin_Up_Box); + procedure Thin_Down_Box_Draw is new Generic_Box_Draw (Thin_Down_Box); + procedure Thin_Up_Frame_Draw is new Generic_Box_Draw (Thin_Up_Frame); + procedure Thin_Down_Frame_Draw is new Generic_Box_Draw (Thin_Down_Frame); + procedure Engraved_Box_Draw is new Generic_Box_Draw (Engraved_Box); + procedure Embossed_Box_Draw is new Generic_Box_Draw (Embossed_Box); + procedure Engraved_Frame_Draw is new Generic_Box_Draw (Engraved_Frame); + procedure Embossed_Frame_Draw is new Generic_Box_Draw (Embossed_Frame); + procedure Border_Box_Draw is new Generic_Box_Draw (Border_Box); + procedure Shadow_Box_Draw is new Generic_Box_Draw (Shadow_Box); + procedure Border_Frame_Draw is new Generic_Box_Draw (Border_Frame); + procedure Shadow_Frame_Draw is new Generic_Box_Draw (Shadow_Frame); + procedure Rounded_Box_Draw is new Generic_Box_Draw (Rounded_Box); + procedure RShadow_Box_Draw is new Generic_Box_Draw (RShadow_Box); + procedure Rounded_Frame_Draw is new Generic_Box_Draw (Rounded_Frame); + procedure RFlat_Box_Draw is new Generic_Box_Draw (RFlat_Box); + procedure Round_Up_Box_Draw is new Generic_Box_Draw (Round_Up_Box); + procedure Round_Down_Box_Draw is new Generic_Box_Draw (Round_Down_Box); + procedure Diamond_Up_Box_Draw is new Generic_Box_Draw (Diamond_Up_Box); + procedure Diamond_Down_Box_Draw is new Generic_Box_Draw (Diamond_Down_Box); + procedure Oval_Box_Draw is new Generic_Box_Draw (Oval_Box); + procedure OShadow_Box_Draw is new Generic_Box_Draw (OShadow_Box); + procedure Oval_Frame_Draw is new Generic_Box_Draw (Oval_Frame); + procedure OFlat_Box_Draw is new Generic_Box_Draw (OFlat_Box); + procedure Plastic_Up_Box_Draw is new Generic_Box_Draw (Plastic_Up_Box); + procedure Plastic_Down_Box_Draw is new Generic_Box_Draw (Plastic_Down_Box); + procedure Plastic_Up_Frame_Draw is new Generic_Box_Draw (Plastic_Up_Frame); + procedure Plastic_Down_Frame_Draw is new Generic_Box_Draw (Plastic_Down_Frame); + procedure Plastic_Thin_Up_Box_Draw is new Generic_Box_Draw (Plastic_Thin_Up_Box); + procedure Plastic_Thin_Down_Box_Draw is new Generic_Box_Draw (Plastic_Thin_Down_Box); + procedure Plastic_Round_Up_Box_Draw is new Generic_Box_Draw (Plastic_Round_Up_Box); + procedure Plastic_Round_Down_Box_Draw is new Generic_Box_Draw (Plastic_Round_Down_Box); + procedure Gtk_Up_Box_Draw is new Generic_Box_Draw (Gtk_Up_Box); + procedure Gtk_Down_Box_Draw is new Generic_Box_Draw (Gtk_Down_Box); + procedure Gtk_Up_Frame_Draw is new Generic_Box_Draw (Gtk_Up_Frame); + procedure Gtk_Down_Frame_Draw is new Generic_Box_Draw (Gtk_Down_Frame); + procedure Gtk_Thin_Up_Box_Draw is new Generic_Box_Draw (Gtk_Thin_Up_Box); + procedure Gtk_Thin_Down_Box_Draw is new Generic_Box_Draw (Gtk_Thin_Down_Box); + procedure Gtk_Thin_Up_Frame_Draw is new Generic_Box_Draw (Gtk_Thin_Up_Frame); + procedure Gtk_Thin_Down_Frame_Draw is new Generic_Box_Draw (Gtk_Thin_Down_Frame); + procedure Gtk_Round_Up_Box_Draw is new Generic_Box_Draw (Gtk_Round_Up_Box); + procedure Gtk_Round_Down_Box_Draw is new Generic_Box_Draw (Gtk_Round_Down_Box); + procedure Gleam_Up_Box_Draw is new Generic_Box_Draw (Gleam_Up_Box); + procedure Gleam_Down_Box_Draw is new Generic_Box_Draw (Gleam_Down_Box); + procedure Gleam_Up_Frame_Draw is new Generic_Box_Draw (Gleam_Up_Frame); + procedure Gleam_Down_Frame_Draw is new Generic_Box_Draw (Gleam_Down_Frame); + procedure Gleam_Thin_Up_Box_Draw is new Generic_Box_Draw (Gleam_Thin_Up_Box); + procedure Gleam_Thin_Down_Box_Draw is new Generic_Box_Draw (Gleam_Thin_Down_Box); + procedure Gleam_Round_Up_Box_Draw is new Generic_Box_Draw (Gleam_Round_Up_Box); + procedure Gleam_Round_Down_Box_Draw is new Generic_Box_Draw (Gleam_Round_Down_Box); + procedure Free_Box_Draw is new Generic_Box_Draw (Free_Box); + + + + + generic + Kind : Box_Kind; + procedure Generic_Box_Draw_Hook + (X, Y, W, H : in Interfaces.C.int; + Tone : in Interfaces.C.unsigned) + with Inline, Convention => C; + + procedure Generic_Box_Draw_Hook + (X, Y, W, H : in Interfaces.C.int; + Tone : in Interfaces.C.unsigned) is + begin + pragma Assert (Ada_Access_Array (Kind) /= null); + Ada_Access_Array (Kind) + (Integer (X), Integer (Y), + Integer (W), Integer (H), + Color (Tone)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Box_Draw_Function hook tried to get a null subprogram access"; + end Generic_Box_Draw_Hook; + + procedure No_Box_Hook is new Generic_Box_Draw_Hook (No_Box); + procedure Flat_Box_Hook is new Generic_Box_Draw_Hook (Flat_Box); + procedure Up_Box_Hook is new Generic_Box_Draw_Hook (Up_Box); + procedure Down_Box_Hook is new Generic_Box_Draw_Hook (Down_Box); + procedure Up_Frame_Hook is new Generic_Box_Draw_Hook (Up_Frame); + procedure Down_Frame_Hook is new Generic_Box_Draw_Hook (Down_Frame); + procedure Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Thin_Up_Box); + procedure Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Thin_Down_Box); + procedure Thin_Up_Frame_Hook is new Generic_Box_Draw_Hook (Thin_Up_Frame); + procedure Thin_Down_Frame_Hook is new Generic_Box_Draw_Hook (Thin_Down_Frame); + procedure Engraved_Box_Hook is new Generic_Box_Draw_Hook (Engraved_Box); + procedure Embossed_Box_Hook is new Generic_Box_Draw_Hook (Embossed_Box); + procedure Engraved_Frame_Hook is new Generic_Box_Draw_Hook (Engraved_Frame); + procedure Embossed_Frame_Hook is new Generic_Box_Draw_Hook (Embossed_Frame); + procedure Border_Box_Hook is new Generic_Box_Draw_Hook (Border_Box); + procedure Shadow_Box_Hook is new Generic_Box_Draw_Hook (Shadow_Box); + procedure Border_Frame_Hook is new Generic_Box_Draw_Hook (Border_Frame); + procedure Shadow_Frame_Hook is new Generic_Box_Draw_Hook (Shadow_Frame); + procedure Rounded_Box_Hook is new Generic_Box_Draw_Hook (Rounded_Box); + procedure RShadow_Box_Hook is new Generic_Box_Draw_Hook (RShadow_Box); + procedure Rounded_Frame_Hook is new Generic_Box_Draw_Hook (Rounded_Frame); + procedure RFlat_Box_Hook is new Generic_Box_Draw_Hook (RFlat_Box); + procedure Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Round_Up_Box); + procedure Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Round_Down_Box); + procedure Diamond_Up_Box_Hook is new Generic_Box_Draw_Hook (Diamond_Up_Box); + procedure Diamond_Down_Box_Hook is new Generic_Box_Draw_Hook (Diamond_Down_Box); + procedure Oval_Box_Hook is new Generic_Box_Draw_Hook (Oval_Box); + procedure OShadow_Box_Hook is new Generic_Box_Draw_Hook (OShadow_Box); + procedure Oval_Frame_Hook is new Generic_Box_Draw_Hook (Oval_Frame); + procedure OFlat_Box_Hook is new Generic_Box_Draw_Hook (OFlat_Box); + procedure Plastic_Up_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Up_Box); + procedure Plastic_Down_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Down_Box); + procedure Plastic_Up_Frame_Hook is new Generic_Box_Draw_Hook (Plastic_Up_Frame); + procedure Plastic_Down_Frame_Hook is new Generic_Box_Draw_Hook (Plastic_Down_Frame); + procedure Plastic_Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Thin_Up_Box); + procedure Plastic_Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Thin_Down_Box); + procedure Plastic_Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Round_Up_Box); + procedure Plastic_Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Plastic_Round_Down_Box); + procedure Gtk_Up_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Up_Box); + procedure Gtk_Down_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Down_Box); + procedure Gtk_Up_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Up_Frame); + procedure Gtk_Down_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Down_Frame); + procedure Gtk_Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Up_Box); + procedure Gtk_Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Down_Box); + procedure Gtk_Thin_Up_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Up_Frame); + procedure Gtk_Thin_Down_Frame_Hook is new Generic_Box_Draw_Hook (Gtk_Thin_Down_Frame); + procedure Gtk_Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Round_Up_Box); + procedure Gtk_Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Gtk_Round_Down_Box); + procedure Gleam_Up_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Up_Box); + procedure Gleam_Down_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Down_Box); + procedure Gleam_Up_Frame_Hook is new Generic_Box_Draw_Hook (Gleam_Up_Frame); + procedure Gleam_Down_Frame_Hook is new Generic_Box_Draw_Hook (Gleam_Down_Frame); + procedure Gleam_Thin_Up_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Thin_Up_Box); + procedure Gleam_Thin_Down_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Thin_Down_Box); + procedure Gleam_Round_Up_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Round_Up_Box); + procedure Gleam_Round_Down_Box_Hook is new Generic_Box_Draw_Hook (Gleam_Round_Down_Box); + procedure Free_Box_Hook is new Generic_Box_Draw_Hook (Free_Box); + + + + + function To_Ada + (Kind : in Box_Kind; + Ptr : in Storage.Integer_Address) + return FLTK.Static.Box_Draw_Function is + begin + if Ptr = Null_Pointer then + return null; + end if; + C_Ptr_Array (Kind) := Ptr; + case Kind is + when No_Box => return + (if Ptr = Storage.To_Integer (No_Box_Hook'Address) + then Ada_Access_Array (Kind) + else No_Box_Draw'Access); + when Flat_Box => return + (if Ptr = Storage.To_Integer (Flat_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Flat_Box_Draw'Access); + when Up_Box => return + (if Ptr = Storage.To_Integer (Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Up_Box_Draw'Access); + when Down_Box => return + (if Ptr = Storage.To_Integer (Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Down_Box_Draw'Access); + when Up_Frame => return + (if Ptr = Storage.To_Integer (Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Up_Frame_Draw'Access); + when Down_Frame => return + (if Ptr = Storage.To_Integer (Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Down_Frame_Draw'Access); + when Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Up_Box_Draw'Access); + when Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Down_Box_Draw'Access); + when Thin_Up_Frame => return + (if Ptr = Storage.To_Integer (Thin_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Up_Frame_Draw'Access); + when Thin_Down_Frame => return + (if Ptr = Storage.To_Integer (Thin_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Thin_Down_Frame_Draw'Access); + when Engraved_Box => return + (if Ptr = Storage.To_Integer (Engraved_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Engraved_Box_Draw'Access); + when Embossed_Box => return + (if Ptr = Storage.To_Integer (Embossed_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Embossed_Box_Draw'Access); + when Engraved_Frame => return + (if Ptr = Storage.To_Integer (Engraved_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Engraved_Frame_Draw'Access); + when Embossed_Frame => return + (if Ptr = Storage.To_Integer (Embossed_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Embossed_Frame_Draw'Access); + when Border_Box => return + (if Ptr = Storage.To_Integer (Border_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Border_Box_Draw'Access); + when Shadow_Box => return + (if Ptr = Storage.To_Integer (Shadow_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Shadow_Box_Draw'Access); + when Border_Frame => return + (if Ptr = Storage.To_Integer (Border_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Border_Frame_Draw'Access); + when Shadow_Frame => return + (if Ptr = Storage.To_Integer (Shadow_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Shadow_Frame_Draw'Access); + when Rounded_Box => return + (if Ptr = Storage.To_Integer (Rounded_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Rounded_Box_Draw'Access); + when RShadow_Box => return + (if Ptr = Storage.To_Integer (RShadow_Box_Hook'Address) + then Ada_Access_Array (Kind) + else RShadow_Box_Draw'Access); + when Rounded_Frame => return + (if Ptr = Storage.To_Integer (Rounded_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Rounded_Frame_Draw'Access); + when RFlat_Box => return + (if Ptr = Storage.To_Integer (RFlat_Box_Hook'Address) + then Ada_Access_Array (Kind) + else RFlat_Box_Draw'Access); + when Round_Up_Box => return + (if Ptr = Storage.To_Integer (Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Round_Up_Box_Draw'Access); + when Round_Down_Box => return + (if Ptr = Storage.To_Integer (Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Round_Down_Box_Draw'Access); + when Diamond_Up_Box => return + (if Ptr = Storage.To_Integer (Diamond_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Diamond_Up_Box_Draw'Access); + when Diamond_Down_Box => return + (if Ptr = Storage.To_Integer (Diamond_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Diamond_Down_Box_Draw'Access); + when Oval_Box => return + (if Ptr = Storage.To_Integer (Oval_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Oval_Box_Draw'Access); + when OShadow_Box => return + (if Ptr = Storage.To_Integer (OShadow_Box_Hook'Address) + then Ada_Access_Array (Kind) + else OShadow_Box_Draw'Access); + when Oval_Frame => return + (if Ptr = Storage.To_Integer (Oval_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Oval_Frame_Draw'Access); + when OFlat_Box => return + (if Ptr = Storage.To_Integer (OFlat_Box_Hook'Address) + then Ada_Access_Array (Kind) + else OFlat_Box_Draw'Access); + when Plastic_Up_Box => return + (if Ptr = Storage.To_Integer (Plastic_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Up_Box_Draw'Access); + when Plastic_Down_Box => return + (if Ptr = Storage.To_Integer (Plastic_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Down_Box_Draw'Access); + when Plastic_Up_Frame => return + (if Ptr = Storage.To_Integer (Plastic_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Up_Frame_Draw'Access); + when Plastic_Down_Frame => return + (if Ptr = Storage.To_Integer (Plastic_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Down_Frame_Draw'Access); + when Plastic_Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Plastic_Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Thin_Up_Box_Draw'Access); + when Plastic_Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Plastic_Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Thin_Down_Box_Draw'Access); + when Plastic_Round_Up_Box => return + (if Ptr = Storage.To_Integer (Plastic_Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Round_Up_Box_Draw'Access); + when Plastic_Round_Down_Box => return + (if Ptr = Storage.To_Integer (Plastic_Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Plastic_Round_Down_Box_Draw'Access); + when Gtk_Up_Box => return + (if Ptr = Storage.To_Integer (Gtk_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Up_Box_Draw'Access); + when Gtk_Down_Box => return + (if Ptr = Storage.To_Integer (Gtk_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Down_Box_Draw'Access); + when Gtk_Up_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Up_Frame_Draw'Access); + when Gtk_Down_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Down_Frame_Draw'Access); + when Gtk_Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Up_Box_Draw'Access); + when Gtk_Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Down_Box_Draw'Access); + when Gtk_Thin_Up_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Up_Frame_Draw'Access); + when Gtk_Thin_Down_Frame => return + (if Ptr = Storage.To_Integer (Gtk_Thin_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Thin_Down_Frame_Draw'Access); + when Gtk_Round_Up_Box => return + (if Ptr = Storage.To_Integer (Gtk_Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Round_Up_Box_Draw'Access); + when Gtk_Round_Down_Box => return + (if Ptr = Storage.To_Integer (Gtk_Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gtk_Round_Down_Box_Draw'Access); + when Gleam_Up_Box => return + (if Ptr = Storage.To_Integer (Gleam_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Up_Box_Draw'Access); + when Gleam_Down_Box => return + (if Ptr = Storage.To_Integer (Gleam_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Down_Box_Draw'Access); + when Gleam_Up_Frame => return + (if Ptr = Storage.To_Integer (Gleam_Up_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Up_Frame_Draw'Access); + when Gleam_Down_Frame => return + (if Ptr = Storage.To_Integer (Gleam_Down_Frame_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Down_Frame_Draw'Access); + when Gleam_Thin_Up_Box => return + (if Ptr = Storage.To_Integer (Gleam_Thin_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Thin_Up_Box_Draw'Access); + when Gleam_Thin_Down_Box => return + (if Ptr = Storage.To_Integer (Gleam_Thin_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Thin_Down_Box_Draw'Access); + when Gleam_Round_Up_Box => return + (if Ptr = Storage.To_Integer (Gleam_Round_Up_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Round_Up_Box_Draw'Access); + when Gleam_Round_Down_Box => return + (if Ptr = Storage.To_Integer (Gleam_Round_Down_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Gleam_Round_Down_Box_Draw'Access); + when Free_Box => return + (if Ptr = Storage.To_Integer (Free_Box_Hook'Address) + then Ada_Access_Array (Kind) + else Free_Box_Draw'Access); + end case; + end To_Ada; + + + + + function To_C + (Kind : in Box_Kind; + Func : in FLTK.Static.Box_Draw_Function) + return Storage.Integer_Address is + begin + if Func = null then + return Null_Pointer; + end if; + Ada_Access_Array (Kind) := Func; + case Kind is + when No_Box => return + (if Func = No_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (No_Box_Hook'Address)); + when Flat_Box => return + (if Func = Flat_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Flat_Box_Hook'Address)); + when Up_Box => return + (if Func = Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Up_Box_Hook'Address)); + when Down_Box => return + (if Func = Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Down_Box_Hook'Address)); + when Up_Frame => return + (if Func = Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Up_Frame_Hook'Address)); + when Down_Frame => return + (if Func = Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Down_Frame_Hook'Address)); + when Thin_Up_Box => return + (if Func = Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Up_Box_Hook'Address)); + when Thin_Down_Box => return + (if Func = Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Down_Box_Hook'Address)); + when Thin_Up_Frame => return + (if Func = Thin_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Up_Frame_Hook'Address)); + when Thin_Down_Frame => return + (if Func = Thin_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Thin_Down_Frame_Hook'Address)); + when Engraved_Box => return + (if Func = Engraved_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Engraved_Box_Hook'Address)); + when Embossed_Box => return + (if Func = Embossed_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Embossed_Box_Hook'Address)); + when Engraved_Frame => return + (if Func = Engraved_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Engraved_Frame_Hook'Address)); + when Embossed_Frame => return + (if Func = Embossed_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Embossed_Frame_Hook'Address)); + when Border_Box => return + (if Func = Border_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Border_Box_Hook'Address)); + when Shadow_Box => return + (if Func = Shadow_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Shadow_Box_Hook'Address)); + when Border_Frame => return + (if Func = Border_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Border_Frame_Hook'Address)); + when Shadow_Frame => return + (if Func = Shadow_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Shadow_Frame_Hook'Address)); + when Rounded_Box => return + (if Func = Rounded_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Rounded_Box_Hook'Address)); + when RShadow_Box => return + (if Func = RShadow_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (RShadow_Box_Hook'Address)); + when Rounded_Frame => return + (if Func = Rounded_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Rounded_Frame_Hook'Address)); + when RFlat_Box => return + (if Func = RFlat_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (RFlat_Box_Hook'Address)); + when Round_Up_Box => return + (if Func = Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Round_Up_Box_Hook'Address)); + when Round_Down_Box => return + (if Func = Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Round_Down_Box_Hook'Address)); + when Diamond_Up_Box => return + (if Func = Diamond_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Diamond_Up_Box_Hook'Address)); + when Diamond_Down_Box => return + (if Func = Diamond_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Diamond_Down_Box_Hook'Address)); + when Oval_Box => return + (if Func = Oval_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Oval_Box_Hook'Address)); + when OShadow_Box => return + (if Func = OShadow_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (OShadow_Box_Hook'Address)); + when Oval_Frame => return + (if Func = Oval_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Oval_Frame_Hook'Address)); + when OFlat_Box => return + (if Func = OFlat_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (OFlat_Box_Hook'Address)); + when Plastic_Up_Box => return + (if Func = Plastic_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Up_Box_Hook'Address)); + when Plastic_Down_Box => return + (if Func = Plastic_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Down_Box_Hook'Address)); + when Plastic_Up_Frame => return + (if Func = Plastic_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Up_Frame_Hook'Address)); + when Plastic_Down_Frame => return + (if Func = Plastic_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Down_Frame_Hook'Address)); + when Plastic_Thin_Up_Box => return + (if Func = Plastic_Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Thin_Up_Box_Hook'Address)); + when Plastic_Thin_Down_Box => return + (if Func = Plastic_Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Thin_Down_Box_Hook'Address)); + when Plastic_Round_Up_Box => return + (if Func = Plastic_Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Round_Up_Box_Hook'Address)); + when Plastic_Round_Down_Box => return + (if Func = Plastic_Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Plastic_Round_Down_Box_Hook'Address)); + when Gtk_Up_Box => return + (if Func = Gtk_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Up_Box_Hook'Address)); + when Gtk_Down_Box => return + (if Func = Gtk_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Down_Box_Hook'Address)); + when Gtk_Up_Frame => return + (if Func = Gtk_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Up_Frame_Hook'Address)); + when Gtk_Down_Frame => return + (if Func = Gtk_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Down_Frame_Hook'Address)); + when Gtk_Thin_Up_Box => return + (if Func = Gtk_Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Up_Box_Hook'Address)); + when Gtk_Thin_Down_Box => return + (if Func = Gtk_Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Down_Box_Hook'Address)); + when Gtk_Thin_Up_Frame => return + (if Func = Gtk_Thin_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Up_Frame_Hook'Address)); + when Gtk_Thin_Down_Frame => return + (if Func = Gtk_Thin_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Thin_Down_Frame_Hook'Address)); + when Gtk_Round_Up_Box => return + (if Func = Gtk_Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Round_Up_Box_Hook'Address)); + when Gtk_Round_Down_Box => return + (if Func = Gtk_Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gtk_Round_Down_Box_Hook'Address)); + when Gleam_Up_Box => return + (if Func = Gleam_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Up_Box_Hook'Address)); + when Gleam_Down_Box => return + (if Func = Gleam_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Down_Box_Hook'Address)); + when Gleam_Up_Frame => return + (if Func = Gleam_Up_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Up_Frame_Hook'Address)); + when Gleam_Down_Frame => return + (if Func = Gleam_Down_Frame_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Down_Frame_Hook'Address)); + when Gleam_Thin_Up_Box => return + (if Func = Gleam_Thin_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Thin_Up_Box_Hook'Address)); + when Gleam_Thin_Down_Box => return + (if Func = Gleam_Thin_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Thin_Down_Box_Hook'Address)); + when Gleam_Round_Up_Box => return + (if Func = Gleam_Round_Up_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Round_Up_Box_Hook'Address)); + when Gleam_Round_Down_Box => return + (if Func = Gleam_Round_Down_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Gleam_Round_Down_Box_Hook'Address)); + when Free_Box => return + (if Func = Free_Box_Draw'Access + then C_Ptr_Array (Kind) + else Storage.To_Integer (Free_Box_Hook'Address)); + end case; + end To_C; + + +end FLTK.Box_Draw_Marshal; + + diff --git a/body/fltk-box_draw_marshal.ads b/body/fltk-box_draw_marshal.ads new file mode 100644 index 0000000..373a3a8 --- /dev/null +++ b/body/fltk-box_draw_marshal.ads @@ -0,0 +1,28 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Static; + + +private package FLTK.Box_Draw_Marshal is + + + function To_Ada + (Kind : in Box_Kind; + Ptr : in Storage.Integer_Address) + return FLTK.Static.Box_Draw_Function; + + function To_C + (Kind : in Box_Kind; + Func : in FLTK.Static.Box_Draw_Function) + return Storage.Integer_Address; + + +end FLTK.Box_Draw_Marshal; + + diff --git a/body/fltk-devices-graphics.adb b/body/fltk-devices-graphics.adb new file mode 100644 index 0000000..7c5d160 --- /dev/null +++ b/body/fltk-devices-graphics.adb @@ -0,0 +1,192 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Devices.Graphics is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Color -- + + function fl_graphics_driver_color + (G : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_graphics_driver_color, "fl_graphics_driver_color"); + pragma Inline (fl_graphics_driver_color); + + + + + -- Text -- + + function fl_graphics_driver_descent + (G : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_graphics_driver_descent, "fl_graphics_driver_descent"); + pragma Inline (fl_graphics_driver_descent); + + function fl_graphics_driver_height + (G : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_graphics_driver_height, "fl_graphics_driver_height"); + pragma Inline (fl_graphics_driver_height); + + function fl_graphics_driver_width + (G : in Storage.Integer_Address; + C : in Interfaces.C.unsigned) + return Interfaces.C.double; + pragma Import (C, fl_graphics_driver_width, "fl_graphics_driver_width"); + pragma Inline (fl_graphics_driver_width); + + function fl_graphics_driver_width2 + (G : in Storage.Integer_Address; + S : in Interfaces.C.char_array; + L : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_graphics_driver_width2, "fl_graphics_driver_width2"); + pragma Inline (fl_graphics_driver_width2); + + function fl_graphics_driver_get_font + (G : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_graphics_driver_get_font, "fl_graphics_driver_get_font"); + pragma Inline (fl_graphics_driver_get_font); + + function fl_graphics_driver_size + (G : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_graphics_driver_size, "fl_graphics_driver_size"); + pragma Inline (fl_graphics_driver_size); + + procedure fl_graphics_driver_set_font + (G : in Storage.Integer_Address; + K, S : in Interfaces.C.int); + pragma Import (C, fl_graphics_driver_set_font, "fl_graphics_driver_set_font"); + pragma Inline (fl_graphics_driver_set_font); + + + + + -- Images -- + + procedure fl_graphics_driver_draw_scaled + (G, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_graphics_driver_draw_scaled, "fl_graphics_driver_draw_scaled"); + pragma Inline (fl_graphics_driver_draw_scaled); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Color -- + + function Get_Color + (This : in Graphics_Driver) + return Color is + begin + return Color (fl_graphics_driver_color (This.Void_Ptr)); + end Get_Color; + + + + + -- Text -- + + function Get_Text_Descent + (This : in Graphics_Driver) + return Integer is + begin + return Integer (fl_graphics_driver_descent (This.Void_Ptr)); + end Get_Text_Descent; + + + function Get_Line_Height + (This : in Graphics_Driver) + return Integer is + begin + return Integer (fl_graphics_driver_height (This.Void_Ptr)); + end Get_Line_Height; + + + function Get_Width + (This : in Graphics_Driver; + Char : in Character) + return Long_Float is + begin + return Long_Float (fl_graphics_driver_width (This.Void_Ptr, Character'Pos (Char))); + end Get_Width; + + + function Get_Width + (This : in Graphics_Driver; + Str : in String) + return Long_Float is + begin + return Long_Float (fl_graphics_driver_width2 + (This.Void_Ptr, + Interfaces.C.To_C (Str), + Str'Length)); + end Get_Width; + + + function Get_Font_Kind + (This : in Graphics_Driver) + return Font_Kind is + begin + return Font_Kind'Val (fl_graphics_driver_get_font (This.Void_Ptr)); + end Get_Font_Kind; + + + function Get_Font_Size + (This : in Graphics_Driver) + return Font_Size is + begin + return Font_Size (fl_graphics_driver_size (This.Void_Ptr)); + end Get_Font_Size; + + + procedure Set_Font + (This : in Graphics_Driver; + Face : in Font_Kind; + Size : in Font_Size) is + begin + fl_graphics_driver_set_font (This.Void_Ptr, Font_Kind'Pos (Face), Interfaces.C.int (Size)); + end Set_Font; + + + + + -- Images -- + + procedure Draw_Scaled_Image + (This : in Graphics_Driver; + Img : in FLTK.Images.Image'Class; + X, Y, W, H : in Integer) is + begin + fl_graphics_driver_draw_scaled + (This.Void_Ptr, + Wrapper (Img).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Scaled_Image; + + +end FLTK.Devices.Graphics; + + diff --git a/body/fltk-devices-surface-copy.adb b/body/fltk-devices-surface-copy.adb new file mode 100644 index 0000000..234ef5b --- /dev/null +++ b/body/fltk-devices-surface-copy.adb @@ -0,0 +1,186 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Devices.Surface.Copy is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_copy_surface + (W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_copy_surface, "new_fl_copy_surface"); + pragma Inline (new_fl_copy_surface); + + procedure free_fl_copy_surface + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_copy_surface, "free_fl_copy_surface"); + pragma Inline (free_fl_copy_surface); + + + + + -- Dimensions -- + + function fl_copy_surface_get_w + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_copy_surface_get_w, "fl_copy_surface_get_w"); + pragma Inline (fl_copy_surface_get_w); + + function fl_copy_surface_get_h + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_copy_surface_get_h, "fl_copy_surface_get_h"); + pragma Inline (fl_copy_surface_get_h); + + + + + -- Drawing -- + + procedure fl_copy_surface_draw + (S, W : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_copy_surface_draw, "fl_copy_surface_draw"); + pragma Inline (fl_copy_surface_draw); + + procedure fl_copy_surface_draw_decorated_window + (S, W : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_copy_surface_draw_decorated_window, + "fl_copy_surface_draw_decorated_window"); + pragma Inline (fl_copy_surface_draw_decorated_window); + + + + + -- Surfaces -- + + procedure fl_copy_surface_set_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_copy_surface_set_current, "fl_copy_surface_set_current"); + pragma Inline (fl_copy_surface_set_current); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Copy_Surface) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_copy_surface (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (W, H : in Natural) + return Copy_Surface is + begin + return This : Copy_Surface do + This.Void_Ptr := new_fl_copy_surface + (Interfaces.C.int (W), + Interfaces.C.int (H)); + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Dimensions -- + + function Get_W + (This : in Copy_Surface) + return Integer is + begin + return Integer (fl_copy_surface_get_w (This.Void_Ptr)); + end Get_W; + + + function Get_H + (This : in Copy_Surface) + return Integer is + begin + return Integer (fl_copy_surface_get_h (This.Void_Ptr)); + end Get_H; + + + + + -- Drawing -- + + procedure Draw_Widget + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_copy_surface_draw + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Widget; + + + procedure Draw_Decorated_Window + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_copy_surface_draw_decorated_window + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Decorated_Window; + + + + + -- Surfaces -- + + procedure Set_Current + (This : in out Copy_Surface) is + begin + fl_copy_surface_set_current (This.Void_Ptr); + This.Set_Current_Bookkeep; + end Set_Current; + + +end FLTK.Devices.Surface.Copy; + + diff --git a/body/fltk-devices-surface-display.adb b/body/fltk-devices-surface-display.adb new file mode 100644 index 0000000..8316180 --- /dev/null +++ b/body/fltk-devices-surface-display.adb @@ -0,0 +1,126 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package body FLTK.Devices.Surface.Display is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_display_device + (G : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_display_device, "new_fl_display_device"); + pragma Inline (new_fl_display_device); + + procedure free_fl_display_device + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_display_device, "free_fl_display_device"); + pragma Inline (free_fl_display_device); + + + + + -- Displays -- + + function fl_display_device_display_device + return Storage.Integer_Address; + pragma Import (C, fl_display_device_display_device, "fl_display_device_display_device"); + pragma Inline (fl_display_device_display_device); + + + + + -- Drivers -- + + function fl_surface_device_get_driver + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_surface_device_get_driver, "fl_surface_device_get_driver"); + pragma Inline (fl_surface_device_get_driver); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Display_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_display_device (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Display_Device is + begin + return This : Display_Device do + This.Void_Ptr := new_fl_display_device (Wrapper (Graphics).Void_Ptr); + This.My_Driver := Graphics'Unchecked_Access; + end return; + end Create; + + end Forge; + + + + + ------------------------- + -- Static Attributes -- + ------------------------- + + Platform_Display : aliased Display_Device; + Platform_Graphics : aliased FLTK.Devices.Graphics.Graphics_Driver; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Displays -- + + function Get_Platform_Display + return Display_Device_Reference is + begin + return Ref : Display_Device_Reference (Data => Platform_Display'Access); + end Get_Platform_Display; + + +begin + + + Platform_Display.Void_Ptr := fl_display_device_display_device; + Platform_Display.Needs_Dealloc := False; + + Wrapper (Platform_Graphics).Void_Ptr := + fl_surface_device_get_driver (Platform_Display.Void_Ptr); + Wrapper (Platform_Graphics).Needs_Dealloc := False; + + Platform_Display.My_Driver := Platform_Graphics'Access; + + +end FLTK.Devices.Surface.Display; + + diff --git a/body/fltk-devices-surface-image.adb b/body/fltk-devices-surface-image.adb new file mode 100644 index 0000000..f52387f --- /dev/null +++ b/body/fltk-devices-surface-image.adb @@ -0,0 +1,203 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Devices.Surface.Image is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_image_surface + (W, H, R : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_image_surface, "new_fl_image_surface"); + pragma Inline (new_fl_image_surface); + + procedure free_fl_image_surface + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_image_surface, "free_fl_image_surface"); + pragma Inline (free_fl_image_surface); + + + + + -- Drawing -- + + procedure fl_image_surface_draw + (S, I : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_image_surface_draw, "fl_image_surface_draw"); + pragma Inline (fl_image_surface_draw); + + procedure fl_image_surface_draw_decorated_window + (S, I : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_image_surface_draw_decorated_window, + "fl_image_surface_draw_decorated_window"); + pragma Inline (fl_image_surface_draw_decorated_window); + + + + + -- Images -- + + function fl_image_surface_image + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_surface_image, "fl_image_surface_image"); + pragma Inline (fl_image_surface_image); + + function fl_image_surface_highres_image + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_surface_highres_image, "fl_image_surface_highres_image"); + pragma Inline (fl_image_surface_highres_image); + + + + + -- Surfaces -- + + procedure fl_image_surface_set_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_image_surface_set_current, "fl_image_surface_set_current"); + pragma Inline (fl_image_surface_set_current); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Image_Surface) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_image_surface (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (W, H : in Integer; + Highres : in Boolean := False) + return Image_Surface is + begin + return This : Image_Surface do + This.Void_Ptr := new_fl_image_surface + (Interfaces.C.int (W), + Interfaces.C.int (H), + Boolean'Pos (Highres)); + This.High := Highres; + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Resolution -- + + function Is_Highres + (This : in Image_Surface) + return Boolean is + begin + return This.High; + end Is_Highres; + + + + + -- Drawing -- + + procedure Draw_Widget + (This : in out Image_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_image_surface_draw + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Widget; + + + procedure Draw_Decorated_Window + (This : in out Image_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_image_surface_draw_decorated_window + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Decorated_Window; + + + + + -- Images -- + + function Get_Image + (This : in Image_Surface) + return FLTK.Images.RGB.RGB_Image is + begin + return Img : FLTK.Images.RGB.RGB_Image do + Wrapper (Img).Void_Ptr := fl_image_surface_image (This.Void_Ptr); + end return; + end Get_Image; + + + function Get_Highres_Image + (This : in Image_Surface) + return FLTK.Images.Shared.Shared_Image is + begin + return Img : FLTK.Images.Shared.Shared_Image do + Wrapper (Img).Void_Ptr := fl_image_surface_highres_image (This.Void_Ptr); + end return; + end Get_Highres_Image; + + + + + -- Surfaces -- + + procedure Set_Current + (This : in out Image_Surface) is + begin + fl_image_surface_set_current (This.Void_Ptr); + This.Set_Current_Bookkeep; + end Set_Current; + + +end FLTK.Devices.Surface.Image; + + diff --git a/body/fltk-devices-surface-paged-postscript.adb b/body/fltk-devices-surface-paged-postscript.adb new file mode 100644 index 0000000..07284bb --- /dev/null +++ b/body/fltk-devices-surface-paged-postscript.adb @@ -0,0 +1,528 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Devices.Surface.Paged.Postscript is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Files -- + + function fopen + (Name, Mode : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, fopen, "fopen"); + + function fclose + (Handle : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fclose, "fclose"); + + + + + -- Allocation -- + + function new_fl_postscript_file_device + return Storage.Integer_Address; + pragma Import (C, new_fl_postscript_file_device, "new_fl_postscript_file_device"); + pragma Inline (new_fl_postscript_file_device); + + procedure free_fl_postscript_file_device + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_postscript_file_device, "free_fl_postscript_file_device"); + pragma Inline (free_fl_postscript_file_device); + + + + + -- Static Attributes -- + + function fl_postscript_file_device_get_file_chooser_title + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_postscript_file_device_get_file_chooser_title, + "fl_postscript_file_device_get_file_chooser_title"); + pragma Inline (fl_postscript_file_device_get_file_chooser_title); + + procedure fl_postscript_file_device_set_file_chooser_title + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_postscript_file_device_set_file_chooser_title, + "fl_postscript_file_device_set_file_chooser_title"); + pragma Inline (fl_postscript_file_device_set_file_chooser_title); + + + + + -- Driver -- + + -- function fl_postscript_file_device_get_driver + -- (D : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_postscript_file_device_get_driver, + -- "fl_postscript_file_device_get_driver"); + -- pragma Inline (fl_postscript_file_device_get_driver); + + + + + -- Job Control -- + + function fl_postscript_file_device_start_job + (D : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_start_job, "fl_postscript_file_device_start_job"); + pragma Inline (fl_postscript_file_device_start_job); + + function fl_postscript_file_device_start_job2 + (D : in Storage.Integer_Address; + C : in Interfaces.C.int; + F, T : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_start_job2, "fl_postscript_file_device_start_job2"); + pragma Inline (fl_postscript_file_device_start_job2); + + function fl_postscript_file_device_start_job3 + (D, O : in Storage.Integer_Address; + C, F, L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_start_job3, "fl_postscript_file_device_start_job3"); + pragma Inline (fl_postscript_file_device_start_job3); + + function fl_postscript_file_device_start_job4 + (D : in Storage.Integer_Address; + C, F, L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_start_job4, "fl_postscript_file_device_start_job4"); + pragma Inline (fl_postscript_file_device_start_job4); + + procedure fl_postscript_file_device_end_job + (D : in Storage.Integer_Address); + pragma Import (C, fl_postscript_file_device_end_job, "fl_postscript_file_device_end_job"); + pragma Inline (fl_postscript_file_device_end_job); + + function fl_postscript_file_device_start_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_start_page, "fl_postscript_file_device_start_page"); + pragma Inline (fl_postscript_file_device_start_page); + + function fl_postscript_file_device_end_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_end_page, "fl_postscript_file_device_end_page"); + pragma Inline (fl_postscript_file_device_end_page); + + + + + -- Spacing and Orientation -- + + procedure fl_postscript_file_device_margins + (D : in Storage.Integer_Address; + L, T, R, B : out Interfaces.C.int); + pragma Import (C, fl_postscript_file_device_margins, "fl_postscript_file_device_margins"); + pragma Inline (fl_postscript_file_device_margins); + + function fl_postscript_file_device_printable_rect + (D : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_postscript_file_device_printable_rect, + "fl_postscript_file_device_printable_rect"); + pragma Inline (fl_postscript_file_device_printable_rect); + + procedure fl_postscript_file_device_get_origin + (D : in Storage.Integer_Address; + X, Y : out Interfaces.C.int); + pragma Import (C, fl_postscript_file_device_get_origin, "fl_postscript_file_device_get_origin"); + pragma Inline (fl_postscript_file_device_get_origin); + + procedure fl_postscript_file_device_set_origin + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_postscript_file_device_set_origin, "fl_postscript_file_device_set_origin"); + pragma Inline (fl_postscript_file_device_set_origin); + + procedure fl_postscript_file_device_rotate + (D : in Storage.Integer_Address; + R : in Interfaces.C.C_float); + pragma Import (C, fl_postscript_file_device_rotate, "fl_postscript_file_device_rotate"); + pragma Inline (fl_postscript_file_device_rotate); + + procedure fl_postscript_file_device_scale + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.C_float); + pragma Import (C, fl_postscript_file_device_scale, "fl_postscript_file_device_scale"); + pragma Inline (fl_postscript_file_device_scale); + + procedure fl_postscript_file_device_translate + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_postscript_file_device_translate, "fl_postscript_file_device_translate"); + pragma Inline (fl_postscript_file_device_translate); + + procedure fl_postscript_file_device_untranslate + (D : in Storage.Integer_Address); + pragma Import (C, fl_postscript_file_device_untranslate, + "fl_postscript_file_device_untranslate"); + pragma Inline (fl_postscript_file_device_untranslate); + + + + + ----------------------------- + -- Auxiliary Subprograms -- + ----------------------------- + + procedure Open + (File : in out File_Type; + Name : in String) + is + Result : Storage.Integer_Address; + begin + File.Close; + Result := fopen + (Interfaces.C.To_C (Name), + Interfaces.C.To_C ("w")); + if Result = Null_Pointer then + raise File_Open_Error; + else + File.C_File := Result; + File.Open_State := True; + end if; + end Open; + + + function Is_Open + (File : in File_Type) + return Boolean is + begin + return File.Open_State; + end Is_Open; + + + procedure Close + (File : in out File_Type) + is + Result : Interfaces.C.int; + begin + if File.Is_Open then + Result := fclose (File.C_File); + if Result /= 0 then + raise File_Close_Error; + end if; + File.Open_State := False; + end if; + end Close; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out File_Type) is + begin + This.Close; + end Finalize; + + + procedure Finalize + (This : in out Postscript_File_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_postscript_file_device (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + procedure Finalize + (This : in out Postscript_File_Device_Final_Controller) is + begin + Interfaces.C.Strings.Free (File_Chooser_Title); + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + return Postscript_File_Device is + begin + return This : Postscript_File_Device do + This.Void_Ptr := new_fl_postscript_file_device; + end return; + end Create; + + end Forge; + + + + + ------------------------- + -- Static Attributes -- + ------------------------- + + function Get_File_Chooser_Title + return String is + begin + return Interfaces.C.Strings.Value (fl_postscript_file_device_get_file_chooser_title); + end Get_File_Chooser_Title; + + + procedure Set_File_Chooser_Title + (Value : in String) is + begin + Interfaces.C.Strings.Free (File_Chooser_Title); + File_Chooser_Title := Interfaces.C.Strings.New_String (Value); + fl_postscript_file_device_set_file_chooser_title (File_Chooser_Title); + end Set_File_Chooser_Title; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Driver -- + + function Get_Postscript_Driver + (This : in out Postscript_File_Device) + return FLTK.Devices.Graphics.Graphics_Driver_Reference is + begin + return raise Program_Error with "Get_Postscript_Driver unimplemented"; + end Get_Postscript_Driver; + + + + + -- Job Control -- + + procedure Start_Job + (This : in out Postscript_File_Device; + Count : in Natural := 0) is + begin + if fl_postscript_file_device_start_job + (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure Start_Job + (This : in out Postscript_File_Device; + Count : in Natural := 0; + From, To : out Positive) is + begin + if fl_postscript_file_device_start_job2 + (This.Void_Ptr, + Interfaces.C.int (Count), + Interfaces.C.int (From), + Interfaces.C.int (To)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure Start_Job + (This : in out Postscript_File_Device; + Output : in File_Type'Class; + Count : in Natural := 0; + Format : in Page_Format := A4; + Layout : in Page_Layout := Portrait) + is + Code : constant Interfaces.C.int := fl_postscript_file_device_start_job3 + (This.Void_Ptr, + Output.C_File, + Interfaces.C.int (Count), + To_Cint (Format), + To_Cint (Layout)); + begin + pragma Assert (Code = 0); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_PostScript_File_Device::start_job returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Start_Job; + + + procedure Start_Job + (This : in out Postscript_File_Device; + Count : in Natural := 0; + Format : in Page_Format := A4; + Layout : in Page_Layout := Portrait) + is + Code : constant Interfaces.C.int := fl_postscript_file_device_start_job4 + (This.Void_Ptr, + Interfaces.C.int (Count), + To_Cint (Format), + To_Cint (Layout)); + begin + case Code is + when 1 => raise User_Cancel_Error; + when 2 => raise File_Open_Error; + when others => pragma Assert (Code = 0); + end case; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_PostScript_File_Device::start_job returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Start_Job; + + + procedure End_Job + (This : in out Postscript_File_Device) is + begin + fl_postscript_file_device_end_job (This.Void_Ptr); + end End_Job; + + + procedure Start_Page + (This : in out Postscript_File_Device) is + begin + if fl_postscript_file_device_start_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end Start_Page; + + + procedure End_Page + (This : in out Postscript_File_Device) is + begin + if fl_postscript_file_device_end_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end End_Page; + + + + + -- Spacing and Orientation -- + + procedure Get_Margins + (This : in Postscript_File_Device; + Left, Top, Right, Bottom : out Integer) is + begin + fl_postscript_file_device_margins + (This.Void_Ptr, + Interfaces.C.int (Left), + Interfaces.C.int (Top), + Interfaces.C.int (Right), + Interfaces.C.int (Bottom)); + end Get_Margins; + + + procedure Get_Printable_Rect + (This : in Postscript_File_Device; + W, H : out Integer) is + begin + if fl_postscript_file_device_printable_rect + (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 + then + raise Page_Error; + end if; + end Get_Printable_Rect; + + + procedure Get_Origin + (This : in Postscript_File_Device; + X, Y : out Integer) is + begin + fl_postscript_file_device_get_origin + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Get_Origin; + + + procedure Set_Origin + (This : in out Postscript_File_Device; + X, Y : in Integer) is + begin + fl_postscript_file_device_set_origin + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Set_Origin; + + + procedure Rotate + (This : in out Postscript_File_Device; + Degrees : in Float) is + begin + fl_postscript_file_device_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); + end Rotate; + + + procedure Scale + (This : in out Postscript_File_Device; + Factor : in Float) is + begin + fl_postscript_file_device_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); + end Scale; + + + procedure Scale + (This : in out Postscript_File_Device; + Factor_X, Factor_Y : in Float) is + begin + fl_postscript_file_device_scale + (This.Void_Ptr, + Interfaces.C.C_float (Factor_X), + Interfaces.C.C_float (Factor_Y)); + end Scale; + + + procedure Translate + (This : in out Postscript_File_Device; + Delta_X, Delta_Y : in Integer) is + begin + fl_postscript_file_device_translate + (This.Void_Ptr, + Interfaces.C.int (Delta_X), + Interfaces.C.int (Delta_Y)); + end Translate; + + + procedure Untranslate + (This : in out Postscript_File_Device) is + begin + fl_postscript_file_device_untranslate (This.Void_Ptr); + end Untranslate; + + +end FLTK.Devices.Surface.Paged.Postscript; + + diff --git a/body/fltk-devices-surface-paged-printers.adb b/body/fltk-devices-surface-paged-printers.adb new file mode 100644 index 0000000..8ee0660 --- /dev/null +++ b/body/fltk-devices-surface-paged-printers.adb @@ -0,0 +1,937 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Devices.Surface.Paged.Printers is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_printer + return Storage.Integer_Address; + pragma Import (C, new_fl_printer, "new_fl_printer"); + pragma Inline (new_fl_printer); + + procedure free_fl_printer + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_printer, "free_fl_printer"); + pragma Inline (free_fl_printer); + + + + + -- Static Attributes -- + + function fl_printer_get_dialog_title + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_title, "fl_printer_get_dialog_title"); + pragma Inline (fl_printer_get_dialog_title); + + procedure fl_printer_set_dialog_title + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_title, "fl_printer_set_dialog_title"); + pragma Inline (fl_printer_set_dialog_title); + + function fl_printer_get_dialog_printer + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_printer, "fl_printer_get_dialog_printer"); + pragma Inline (fl_printer_get_dialog_printer); + + procedure fl_printer_set_dialog_printer + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_printer, "fl_printer_set_dialog_printer"); + pragma Inline (fl_printer_set_dialog_printer); + + function fl_printer_get_dialog_range + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_range, "fl_printer_get_dialog_range"); + pragma Inline (fl_printer_get_dialog_range); + + procedure fl_printer_set_dialog_range + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_range, "fl_printer_set_dialog_range"); + pragma Inline (fl_printer_set_dialog_range); + + function fl_printer_get_dialog_copies + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_copies, "fl_printer_get_dialog_copies"); + pragma Inline (fl_printer_get_dialog_copies); + + procedure fl_printer_set_dialog_copies + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_copies, "fl_printer_set_dialog_copies"); + pragma Inline (fl_printer_set_dialog_copies); + + function fl_printer_get_dialog_all + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_all, "fl_printer_get_dialog_all"); + pragma Inline (fl_printer_get_dialog_all); + + procedure fl_printer_set_dialog_all + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_all, "fl_printer_set_dialog_all"); + pragma Inline (fl_printer_set_dialog_all); + + function fl_printer_get_dialog_pages + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_pages, "fl_printer_get_dialog_pages"); + pragma Inline (fl_printer_get_dialog_pages); + + procedure fl_printer_set_dialog_pages + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_pages, "fl_printer_set_dialog_pages"); + pragma Inline (fl_printer_set_dialog_pages); + + function fl_printer_get_dialog_from + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_from, "fl_printer_get_dialog_from"); + pragma Inline (fl_printer_get_dialog_from); + + procedure fl_printer_set_dialog_from + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_from, "fl_printer_set_dialog_from"); + pragma Inline (fl_printer_set_dialog_from); + + function fl_printer_get_dialog_to + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_to, "fl_printer_get_dialog_to"); + pragma Inline (fl_printer_get_dialog_to); + + procedure fl_printer_set_dialog_to + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_to, "fl_printer_set_dialog_to"); + pragma Inline (fl_printer_set_dialog_to); + + function fl_printer_get_dialog_properties + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_properties, "fl_printer_get_dialog_properties"); + pragma Inline (fl_printer_get_dialog_properties); + + procedure fl_printer_set_dialog_properties + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_properties, "fl_printer_set_dialog_properties"); + pragma Inline (fl_printer_set_dialog_properties); + + function fl_printer_get_dialog_copyno + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_copyno, "fl_printer_get_dialog_copyno"); + pragma Inline (fl_printer_get_dialog_copyno); + + procedure fl_printer_set_dialog_copyno + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_copyno, "fl_printer_set_dialog_copyno"); + pragma Inline (fl_printer_set_dialog_copyno); + + function fl_printer_get_dialog_print_button + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_print_button, "fl_printer_get_dialog_print_button"); + pragma Inline (fl_printer_get_dialog_print_button); + + procedure fl_printer_set_dialog_print_button + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_print_button, "fl_printer_set_dialog_print_button"); + pragma Inline (fl_printer_set_dialog_print_button); + + function fl_printer_get_dialog_cancel_button + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_cancel_button, "fl_printer_get_dialog_cancel_button"); + pragma Inline (fl_printer_get_dialog_cancel_button); + + procedure fl_printer_set_dialog_cancel_button + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_cancel_button, "fl_printer_set_dialog_cancel_button"); + pragma Inline (fl_printer_set_dialog_cancel_button); + + function fl_printer_get_dialog_print_to_file + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_dialog_print_to_file, "fl_printer_get_dialog_print_to_file"); + pragma Inline (fl_printer_get_dialog_print_to_file); + + procedure fl_printer_set_dialog_print_to_file + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_dialog_print_to_file, "fl_printer_set_dialog_print_to_file"); + pragma Inline (fl_printer_set_dialog_print_to_file); + + function fl_printer_get_property_title + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_property_title, "fl_printer_get_property_title"); + pragma Inline (fl_printer_get_property_title); + + procedure fl_printer_set_property_title + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_property_title, "fl_printer_set_property_title"); + pragma Inline (fl_printer_set_property_title); + + function fl_printer_get_property_pagesize + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_property_pagesize, "fl_printer_get_property_pagesize"); + pragma Inline (fl_printer_get_property_pagesize); + + procedure fl_printer_set_property_pagesize + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_property_pagesize, "fl_printer_set_property_pagesize"); + pragma Inline (fl_printer_set_property_pagesize); + + function fl_printer_get_property_mode + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_property_mode, "fl_printer_get_property_mode"); + pragma Inline (fl_printer_get_property_mode); + + procedure fl_printer_set_property_mode + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_property_mode, "fl_printer_set_property_mode"); + pragma Inline (fl_printer_set_property_mode); + + function fl_printer_get_property_use + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_property_use, "fl_printer_get_property_use"); + pragma Inline (fl_printer_get_property_use); + + procedure fl_printer_set_property_use + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_property_use, "fl_printer_set_property_use"); + pragma Inline (fl_printer_set_property_use); + + function fl_printer_get_property_save + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_property_save, "fl_printer_get_property_save"); + pragma Inline (fl_printer_get_property_save); + + procedure fl_printer_set_property_save + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_property_save, "fl_printer_set_property_save"); + pragma Inline (fl_printer_set_property_save); + + function fl_printer_get_property_cancel + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_printer_get_property_cancel, "fl_printer_get_property_cancel"); + pragma Inline (fl_printer_get_property_cancel); + + procedure fl_printer_set_property_cancel + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_printer_set_property_cancel, "fl_printer_set_property_cancel"); + pragma Inline (fl_printer_set_property_cancel); + + + + + -- Job Control -- + + function fl_printer_start_job + (D : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_printer_start_job, "fl_printer_start_job"); + pragma Inline (fl_printer_start_job); + + function fl_printer_start_job2 + (D : in Storage.Integer_Address; + C : in Interfaces.C.int; + F, T : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_printer_start_job2, "fl_printer_start_job2"); + pragma Inline (fl_printer_start_job2); + + procedure fl_printer_end_job + (D : in Storage.Integer_Address); + pragma Import (C, fl_printer_end_job, "fl_printer_end_job"); + pragma Inline (fl_printer_end_job); + + function fl_printer_start_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_printer_start_page, "fl_printer_start_page"); + pragma Inline (fl_printer_start_page); + + function fl_printer_end_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_printer_end_page, "fl_printer_end_page"); + pragma Inline (fl_printer_end_page); + + + + + -- Spacing and Orientation -- + + procedure fl_printer_margins + (D : in Storage.Integer_Address; + L, T, R, B : out Interfaces.C.int); + pragma Import (C, fl_printer_margins, "fl_printer_margins"); + pragma Inline (fl_printer_margins); + + function fl_printer_printable_rect + (D : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_printer_printable_rect, "fl_printer_printable_rect"); + pragma Inline (fl_printer_printable_rect); + + procedure fl_printer_get_origin + (D : in Storage.Integer_Address; + X, Y : out Interfaces.C.int); + pragma Import (C, fl_printer_get_origin, "fl_printer_get_origin"); + pragma Inline (fl_printer_get_origin); + + procedure fl_printer_set_origin + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_printer_set_origin, "fl_printer_set_origin"); + pragma Inline (fl_printer_set_origin); + + procedure fl_printer_rotate + (D : in Storage.Integer_Address; + R : in Interfaces.C.C_float); + pragma Import (C, fl_printer_rotate, "fl_printer_rotate"); + pragma Inline (fl_printer_rotate); + + procedure fl_printer_scale + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.C_float); + pragma Import (C, fl_printer_scale, "fl_printer_scale"); + pragma Inline (fl_printer_scale); + + procedure fl_printer_translate + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_printer_translate, "fl_printer_translate"); + pragma Inline (fl_printer_translate); + + procedure fl_printer_untranslate + (D : in Storage.Integer_Address); + pragma Import (C, fl_printer_untranslate, "fl_printer_untranslate"); + pragma Inline (fl_printer_untranslate); + + + + + -- Printing -- + + procedure fl_printer_print_widget + (D, I : in Storage.Integer_Address; + DX, DY : in Interfaces.C.int); + pragma Import (C, fl_printer_print_widget, "fl_printer_print_widget"); + pragma Inline (fl_printer_print_widget); + + procedure fl_printer_print_window_part + (D, I : in Storage.Integer_Address; + X, Y, W, H, DX, DY : in Interfaces.C.int); + pragma Import (C, fl_printer_print_window_part, "fl_printer_print_window_part"); + pragma Inline (fl_printer_print_window_part); + + + + + -- Printer -- + + procedure fl_printer_set_current + (D : in Storage.Integer_Address); + pragma Import (C, fl_printer_set_current, "fl_printer_set_current"); + pragma Inline (fl_printer_set_current); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Printer) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_printer (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + procedure Finalize + (This : in out Printer_Final_Controller) + is + use Interfaces.C.Strings; + begin + Free (Dialog_Title); + Free (Dialog_Printer); + Free (Dialog_Range); + Free (Dialog_Copies); + Free (Dialog_All); + Free (Dialog_Pages); + Free (Dialog_From); + Free (Dialog_To); + Free (Dialog_Properties); + Free (Dialog_Copyno); + Free (Dialog_Print_Button); + Free (Dialog_Cancel_Button); + Free (Dialog_Print_To_File); + Free (Property_Title); + Free (Property_Pagesize); + Free (Property_Mode); + Free (Property_Use); + Free (Property_Save); + Free (Property_Cancel); + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + return Printer is + begin + return This : Printer do + This.Void_Ptr := new_fl_printer; + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + ------------------------- + -- Static Attributes -- + ------------------------- + + function Get_Dialog_Title + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_title); + end Get_Dialog_Title; + + + procedure Set_Dialog_Title + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Title); + Dialog_Title := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_title (Dialog_Title); + end Set_Dialog_Title; + + + function Get_Dialog_Printer + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_printer); + end Get_Dialog_Printer; + + + procedure Set_Dialog_Printer + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Printer); + Dialog_Printer := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_printer (Dialog_Printer); + end Set_Dialog_Printer; + + + function Get_Dialog_Range + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_range); + end Get_Dialog_Range; + + + procedure Set_Dialog_Range + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Range); + Dialog_Range := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_range (Dialog_Range); + end Set_Dialog_Range; + + + function Get_Dialog_Copies + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_copies); + end Get_Dialog_Copies; + + + procedure Set_Dialog_Copies + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Copies); + Dialog_Copies := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_copies (Dialog_Copies); + end Set_Dialog_Copies; + + + function Get_Dialog_All + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_all); + end Get_Dialog_All; + + + procedure Set_Dialog_All + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_All); + Dialog_All := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_all (Dialog_All); + end Set_Dialog_All; + + + function Get_Dialog_Pages + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_pages); + end Get_Dialog_Pages; + + + procedure Set_Dialog_Pages + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Pages); + Dialog_Pages := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_pages (Dialog_Pages); + end Set_Dialog_Pages; + + + function Get_Dialog_From + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_from); + end Get_Dialog_From; + + + procedure Set_Dialog_From + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_From); + Dialog_From := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_from (Dialog_From); + end Set_Dialog_From; + + + function Get_Dialog_To + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_to); + end Get_Dialog_To; + + + procedure Set_Dialog_To + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_To); + Dialog_To := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_to (Dialog_To); + end Set_Dialog_To; + + + function Get_Dialog_Properties + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_properties); + end Get_Dialog_Properties; + + + procedure Set_Dialog_Properties + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Properties); + Dialog_Properties := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_properties (Dialog_Properties); + end Set_Dialog_Properties; + + + function Get_Dialog_Number_Copies + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_copyno); + end Get_Dialog_Number_Copies; + + + procedure Set_Dialog_Number_Copies + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Copyno); + Dialog_Copyno := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_copyno (Dialog_Copyno); + end Set_Dialog_Number_Copies; + + + function Get_Dialog_Print_Button + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_print_button); + end Get_Dialog_Print_Button; + + + procedure Set_Dialog_Print_Button + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Print_Button); + Dialog_Print_Button := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_print_button (Dialog_Print_Button); + end Set_Dialog_Print_Button; + + + function Get_Dialog_Cancel_Button + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_cancel_button); + end Get_Dialog_Cancel_Button; + + + procedure Set_Dialog_Cancel_Button + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Cancel_Button); + Dialog_Cancel_Button := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_cancel_button (Dialog_Cancel_Button); + end Set_Dialog_Cancel_Button; + + + function Get_Dialog_Print_To_File + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_dialog_print_to_file); + end Get_Dialog_Print_To_File; + + + procedure Set_Dialog_Print_To_File + (Value : in String) is + begin + Interfaces.C.Strings.Free (Dialog_Print_To_File); + Dialog_Print_To_File := Interfaces.C.Strings.New_String (Value); + fl_printer_set_dialog_print_to_file (Dialog_Print_To_File); + end Set_Dialog_Print_To_File; + + + function Get_Property_Title + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_property_title); + end Get_Property_Title; + + + procedure Set_Property_Title + (Value : in String) is + begin + Interfaces.C.Strings.Free (Property_Title); + Property_Title := Interfaces.C.Strings.New_String (Value); + fl_printer_set_property_title (Property_Title); + end Set_Property_Title; + + + function Get_Property_Page_Size + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_property_pagesize); + end Get_Property_Page_Size; + + + procedure Set_Property_Page_Size + (Value : in String) is + begin + Interfaces.C.Strings.Free (Property_Pagesize); + Property_Pagesize := Interfaces.C.Strings.New_String (Value); + fl_printer_set_property_pagesize (Property_Pagesize); + end Set_Property_Page_Size; + + + function Get_Property_Mode + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_property_mode); + end Get_Property_Mode; + + + procedure Set_Property_Mode + (Value : in String) is + begin + Interfaces.C.Strings.Free (Property_Mode); + Property_Mode := Interfaces.C.Strings.New_String (Value); + fl_printer_set_property_mode (Property_Mode); + end Set_Property_Mode; + + + function Get_Property_Use + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_property_use); + end Get_Property_Use; + + + procedure Set_Property_Use + (Value : in String) is + begin + Interfaces.C.Strings.Free (Property_Use); + Property_Use := Interfaces.C.Strings.New_String (Value); + fl_printer_set_property_use (Property_Use); + end Set_Property_Use; + + + function Get_Property_Save + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_property_save); + end Get_Property_Save; + + + procedure Set_Property_Save + (Value : in String) is + begin + Interfaces.C.Strings.Free (Property_Save); + Property_Save := Interfaces.C.Strings.New_String (Value); + fl_printer_set_property_save (Property_Save); + end Set_Property_Save; + + + function Get_Property_Cancel + return String is + begin + return Interfaces.C.Strings.Value (fl_printer_get_property_cancel); + end Get_Property_Cancel; + + + procedure Set_Property_Cancel + (Value : in String) is + begin + Interfaces.C.Strings.Free (Property_Cancel); + Property_Cancel := Interfaces.C.Strings.New_String (Value); + fl_printer_set_property_cancel (Property_Cancel); + end Set_Property_Cancel; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Driver -- + + function Get_Original_Driver + (This : in out Printer) + return FLTK.Devices.Graphics.Graphics_Driver_Reference is + begin + return raise Program_Error with "Won't be implemented until Graphics_Drivers taken care of"; + end Get_Original_Driver; + + + + + -- Job Control -- + + procedure Start_Job + (This : in out Printer; + Count : in Natural := 0) is + begin + if fl_printer_start_job + (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure Start_Job + (This : in out Printer; + Count : in Natural := 0; + From, To : out Positive) is + begin + if fl_printer_start_job2 + (This.Void_Ptr, + Interfaces.C.int (Count), + Interfaces.C.int (From), + Interfaces.C.int (To)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure End_Job + (This : in out Printer) is + begin + fl_printer_end_job (This.Void_Ptr); + end End_Job; + + + procedure Start_Page + (This : in out Printer) is + begin + if fl_printer_start_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end Start_Page; + + + procedure End_Page + (This : in out Printer) is + begin + if fl_printer_end_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end End_Page; + + + + + -- Spacing and Orientation -- + + procedure Get_Margins + (This : in Printer; + Left, Top, Right, Bottom : out Integer) is + begin + fl_printer_margins + (This.Void_Ptr, + Interfaces.C.int (Left), + Interfaces.C.int (Top), + Interfaces.C.int (Right), + Interfaces.C.int (Bottom)); + end Get_Margins; + + + procedure Get_Printable_Rect + (This : in Printer; + W, H : out Integer) is + begin + if fl_printer_printable_rect + (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 + then + raise Page_Error; + end if; + end Get_Printable_Rect; + + + procedure Get_Origin + (This : in Printer; + X, Y : out Integer) is + begin + fl_printer_get_origin (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Origin; + + + procedure Set_Origin + (This : in out Printer; + X, Y : in Integer) is + begin + fl_printer_set_origin + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Set_Origin; + + + procedure Rotate + (This : in out Printer; + Degrees : in Float) is + begin + fl_printer_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); + end Rotate; + + + procedure Scale + (This : in out Printer; + Factor : in Float) is + begin + fl_printer_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); + end Scale; + + + procedure Scale + (This : in out Printer; + Factor_X, Factor_Y : in Float) is + begin + fl_printer_scale + (This.Void_Ptr, + Interfaces.C.C_float (Factor_X), + Interfaces.C.C_float (Factor_Y)); + end Scale; + + + procedure Translate + (This : in out Printer; + Delta_X, Delta_Y : in Integer) is + begin + fl_printer_translate + (This.Void_Ptr, + Interfaces.C.int (Delta_X), + Interfaces.C.int (Delta_Y)); + end Translate; + + + procedure Untranslate + (This : in out Printer) is + begin + fl_printer_untranslate (This.Void_Ptr); + end Untranslate; + + + + + -- Printing -- + + procedure Print_Widget + (This : in out Printer; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_printer_print_widget + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Widget; + + + procedure Print_Window_Part + (This : in out Printer; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_printer_print_window_part + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Window_Part; + + + + + -- Printer -- + + procedure Set_Current + (This : in out Printer) is + begin + fl_printer_set_current (This.Void_Ptr); + This.Set_Current_Bookkeep; + end Set_Current; + + +end FLTK.Devices.Surface.Paged.Printers; + + diff --git a/body/fltk-devices-surface-paged.adb b/body/fltk-devices-surface-paged.adb new file mode 100644 index 0000000..fbc8dc6 --- /dev/null +++ b/body/fltk-devices-surface-paged.adb @@ -0,0 +1,557 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Devices.Surface.Paged is + + + package Chk renames Ada.Assertions; + package SU renames Ada.Strings.Unbounded; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_page_format_media : constant Interfaces.C.int; + pragma Import (C, fl_page_format_media); + + fl_page_layout_portrait : constant Interfaces.C.int; + pragma Import (C, fl_page_layout_portrait); + + fl_page_layout_landscape : constant Interfaces.C.int; + pragma Import (C, fl_page_layout_landscape); + + fl_page_layout_reversed : constant Interfaces.C.int; + pragma Import (C, fl_page_layout_reversed); + + fl_page_layout_orientation : constant Interfaces.C.int; + pragma Import (C, fl_page_layout_orientation); + + fl_no_page_formats : constant Interfaces.C.int; + pragma Import (C, fl_no_page_formats); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Static Attributes -- + + procedure fl_paged_device_get_page_format + (Index : in Interfaces.C.int; + Name : out Interfaces.C.Strings.chars_ptr; + Width : out Interfaces.C.int; + Height : out Interfaces.C.int); + pragma Import (C, fl_paged_device_get_page_format, "fl_paged_device_get_page_format"); + pragma Inline (fl_paged_device_get_page_format); + + + + + -- Allocation -- + + function new_fl_paged_device + return Storage.Integer_Address; + pragma Import (C, new_fl_paged_device, "new_fl_paged_device"); + pragma Inline (new_fl_paged_device); + + procedure free_fl_paged_device + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_paged_device, "free_fl_paged_device"); + pragma Inline (free_fl_paged_device); + + + + + -- Job Control -- + + function fl_paged_device_start_job + (D : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_start_job, "fl_paged_device_start_job"); + pragma Inline (fl_paged_device_start_job); + + function fl_paged_device_start_job2 + (D : in Storage.Integer_Address; + C : in Interfaces.C.int; + F, T : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_start_job2, "fl_paged_device_start_job2"); + pragma Inline (fl_paged_device_start_job2); + + procedure fl_paged_device_end_job + (D : in Storage.Integer_Address); + pragma Import (C, fl_paged_device_end_job, "fl_paged_device_end_job"); + pragma Inline (fl_paged_device_end_job); + + function fl_paged_device_start_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_start_page, "fl_paged_device_start_page"); + pragma Inline (fl_paged_device_start_page); + + function fl_paged_device_end_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_end_page, "fl_paged_device_end_page"); + pragma Inline (fl_paged_device_end_page); + + + + + -- Spacing and Orientation -- + + procedure fl_paged_device_margins + (D : in Storage.Integer_Address; + L, T, R, B : out Interfaces.C.int); + pragma Import (C, fl_paged_device_margins, "fl_paged_device_margins"); + pragma Inline (fl_paged_device_margins); + + function fl_paged_device_printable_rect + (D : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_printable_rect, "fl_paged_device_printable_rect"); + pragma Inline (fl_paged_device_printable_rect); + + procedure fl_paged_device_get_origin + (D : in Storage.Integer_Address; + X, Y : out Interfaces.C.int); + pragma Import (C, fl_paged_device_get_origin, "fl_paged_device_get_origin"); + pragma Inline (fl_paged_device_get_origin); + + procedure fl_paged_device_set_origin + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_paged_device_set_origin, "fl_paged_device_set_origin"); + pragma Inline (fl_paged_device_set_origin); + + procedure fl_paged_device_rotate + (D : in Storage.Integer_Address; + R : in Interfaces.C.C_float); + pragma Import (C, fl_paged_device_rotate, "fl_paged_device_rotate"); + pragma Inline (fl_paged_device_rotate); + + procedure fl_paged_device_scale + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.C_float); + pragma Import (C, fl_paged_device_scale, "fl_paged_device_scale"); + pragma Inline (fl_paged_device_scale); + + procedure fl_paged_device_translate + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_paged_device_translate, "fl_paged_device_translate"); + pragma Inline (fl_paged_device_translate); + + procedure fl_paged_device_untranslate + (D : in Storage.Integer_Address); + pragma Import (C, fl_paged_device_untranslate, "fl_paged_device_untranslate"); + pragma Inline (fl_paged_device_untranslate); + + + + + -- Printing -- + + procedure fl_paged_device_print_widget + (D, I : in Storage.Integer_Address; + DX, DY : in Interfaces.C.int); + pragma Import (C, fl_paged_device_print_widget, "fl_paged_device_print_widget"); + pragma Inline (fl_paged_device_print_widget); + + procedure fl_paged_device_print_window + (D, I : in Storage.Integer_Address; + DX, DY : in Interfaces.C.int); + pragma Import (C, fl_paged_device_print_window, "fl_paged_device_print_window"); + pragma Inline (fl_paged_device_print_window); + + procedure fl_paged_device_print_window_part + (D, I : in Storage.Integer_Address; + X, Y, W, H, DX, DY : in Interfaces.C.int); + pragma Import (C, fl_paged_device_print_window_part, "fl_paged_device_print_window_part"); + pragma Inline (fl_paged_device_print_window_part); + + + + + ------------------------ + -- Internal Utility -- + ------------------------ + + function To_Cint + (Value : in Page_Format) + return Interfaces.C.int is + begin + case Value is + when A0 .. Envelope => return Page_Format'Pos (Value); + when Media => return fl_page_format_media; + end case; + end To_Cint; + + + function To_Page_Format + (Value : in Interfaces.C.int) + return Page_Format is + begin + if Value in Page_Format'Pos (A0) .. Page_Format'Pos (Envelope) then + return Page_Format'Val (Value); + else + pragma Assert (Value = fl_page_format_media); + return Media; + end if; + exception + when Chk.Assertion_Error => raise Constraint_Error; + end To_Page_Format; + + + function To_Cint + (Value : in Page_Layout) + return Interfaces.C.int is + begin + case Value is + when Portrait => return fl_page_layout_portrait; + when Landscape => return fl_page_layout_landscape; + when Reversed => return fl_page_layout_reversed; + when Orientation => return fl_page_layout_orientation; + end case; + end To_Cint; + + + function To_Page_Layout + (Value : in Interfaces.C.int) + return Page_Layout is + begin + if Value = fl_page_layout_portrait then + return Portrait; + elsif Value = fl_page_layout_landscape then + return Landscape; + elsif Value = fl_page_layout_reversed then + return Reversed; + else + pragma Assert (Value = fl_page_layout_orientation); + return Orientation; + end if; + exception + when Chk.Assertion_Error => raise Constraint_Error; + end To_Page_Layout; + + + function Get_Page_Formats + return Page_Format_Info_Array + is + C_Name : Interfaces.C.Strings.chars_ptr; + C_Width : Interfaces.C.int; + C_Height : Interfaces.C.int; + begin + return Data : Page_Format_Info_Array (A0 .. To_Page_Format (fl_no_page_formats - 1)) do + for Index in Data'Range loop + fl_paged_device_get_page_format (To_Cint (Index), C_Name, C_Width, C_Height); + if C_Name = Interfaces.C.Strings.Null_Ptr then + Data (Index).My_Name := SU.To_Unbounded_String (""); + else + Data (Index).My_Name := SU.To_Unbounded_String + (Interfaces.C.Strings.Value (C_Name)); + end if; + Data (Index).My_Width := Natural (C_Width); + Data (Index).My_Height := Natural (C_Height); + end loop; + end return; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Paged_Device::NO_PAGE_FORMATS has inconsistent value of " & + Interfaces.C.int'Image (fl_no_page_formats); + end Get_Page_Formats; + + + + + ---------------------------- + -- Datatype Subprograms -- + ---------------------------- + + function Name + (This : in Page_Format_Info) + return String is + begin + return SU.To_String (This.My_Name); + end Name; + + + function Width + (This : in Page_Format_Info) + return Natural is + begin + return This.My_Width; + end Width; + + + function Height + (This : in Page_Format_Info) + return Natural is + begin + return This.My_Height; + end Height; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Paged_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_paged_device (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + return Paged_Device is + begin + return This : Paged_Device do + This.Void_Ptr := new_fl_paged_device; + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Job Control -- + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural := 0) is + begin + if fl_paged_device_start_job + (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural := 0; + From, To : out Positive) is + begin + if fl_paged_device_start_job2 + (This.Void_Ptr, + Interfaces.C.int (Count), + Interfaces.C.int (From), + Interfaces.C.int (To)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure End_Job + (This : in out Paged_Device) is + begin + fl_paged_device_end_job (This.Void_Ptr); + end End_Job; + + + procedure Start_Page + (This : in out Paged_Device) is + begin + if fl_paged_device_start_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end Start_Page; + + + procedure End_Page + (This : in out Paged_Device) is + begin + if fl_paged_device_end_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end End_Page; + + + + + -- Spacing and Orientation -- + + procedure Get_Margins + (This : in Paged_Device; + Left, Top, Right, Bottom : out Integer) is + begin + fl_paged_device_margins + (This.Void_Ptr, + Interfaces.C.int (Left), + Interfaces.C.int (Top), + Interfaces.C.int (Right), + Interfaces.C.int (Bottom)); + end Get_Margins; + + + procedure Get_Printable_Rect + (This : in Paged_Device; + W, H : out Integer) is + begin + if fl_paged_device_printable_rect + (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 + then + raise Page_Error; + end if; + end Get_Printable_Rect; + + + procedure Get_Origin + (This : in Paged_Device; + X, Y : out Integer) is + begin + fl_paged_device_get_origin (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Origin; + + + procedure Set_Origin + (This : in out Paged_Device; + X, Y : in Integer) is + begin + fl_paged_device_set_origin + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Set_Origin; + + + procedure Rotate + (This : in out Paged_Device; + Degrees : in Float) is + begin + fl_paged_device_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); + end Rotate; + + + procedure Scale + (This : in out Paged_Device; + Factor : in Float) is + begin + fl_paged_device_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); + end Scale; + + + procedure Scale + (This : in out Paged_Device; + Factor_X, Factor_Y : in Float) is + begin + fl_paged_device_scale + (This.Void_Ptr, + Interfaces.C.C_float (Factor_X), + Interfaces.C.C_float (Factor_Y)); + end Scale; + + + procedure Translate + (This : in out Paged_Device; + Delta_X, Delta_Y : in Integer) is + begin + fl_paged_device_translate + (This.Void_Ptr, + Interfaces.C.int (Delta_X), + Interfaces.C.int (Delta_Y)); + end Translate; + + + procedure Untranslate + (This : in out Paged_Device) is + begin + fl_paged_device_untranslate (This.Void_Ptr); + end Untranslate; + + + + + -- Printing -- + + procedure Print_Widget + (This : in out Paged_Device; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_paged_device_print_widget + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Widget; + + + procedure Print_Window + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_paged_device_print_window + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Window; + + + procedure Print_Window_Part + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_paged_device_print_window_part + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Window_Part; + + +end FLTK.Devices.Surface.Paged; + + diff --git a/body/fltk-devices-surface.adb b/body/fltk-devices-surface.adb new file mode 100644 index 0000000..b438f68 --- /dev/null +++ b/body/fltk-devices-surface.adb @@ -0,0 +1,190 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package body FLTK.Devices.Surface is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_surface_device + (G : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_surface_device, "new_fl_surface_device"); + pragma Inline (new_fl_surface_device); + + procedure free_fl_surface_device + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_surface_device, "free_fl_surface_device"); + pragma Inline (free_fl_surface_device); + + + + + -- Surfaces -- + + procedure fl_surface_device_set_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_surface_device_set_current, "fl_surface_device_set_current"); + pragma Inline (fl_surface_device_set_current); + + function fl_surface_device_get_surface + return Storage.Integer_Address; + pragma Import (C, fl_surface_device_get_surface, "fl_surface_device_get_surface"); + pragma Inline (fl_surface_device_get_surface); + + + + + -- Drivers -- + + function fl_surface_device_get_driver + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_surface_device_get_driver, "fl_surface_device_get_driver"); + pragma Inline (fl_surface_device_get_driver); + + procedure fl_surface_device_set_driver + (S, G : in Storage.Integer_Address); + pragma Import (C, fl_surface_device_set_driver, "fl_surface_device_set_driver"); + pragma Inline (fl_surface_device_set_driver); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Surface_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_surface_device (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Surface_Device is + begin + return This : Surface_Device do + This.Void_Ptr := new_fl_surface_device (Wrapper (Graphics).Void_Ptr); + This.My_Driver := Graphics'Unchecked_Access; + end return; + end Create; + + end Forge; + + + + + ------------------------- + -- Static Attributes -- + ------------------------- + + Original_Surface : aliased Surface_Device; + Original_Graphics : aliased FLTK.Devices.Graphics.Graphics_Driver; + + Current_Surface : access Surface_Device'Class := Original_Surface'Access; + + + procedure Set_Current_Bookkeep + (Surface : in out Surface_Device'Class) is + begin + Current_Surface := Surface'Unchecked_Access; + end Set_Current_Bookkeep; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Surfaces -- + + function Get_Current + return Surface_Device_Reference is + begin + return Ref : Surface_Device_Reference (Data => Current_Surface); + end Get_Current; + + + procedure Set_Current + (This : in out Surface_Device) is + begin + fl_surface_device_set_current (This.Void_Ptr); + This.Set_Current_Bookkeep; + end Set_Current; + + + function Get_Original + return Surface_Device_Reference is + begin + return Ref : Surface_Device_Reference (Data => Original_Surface'Access); + end Get_Original; + + + + + -- Drivers -- + + function Has_Driver + (This : in Surface_Device) + return Boolean is + begin + return This.My_Driver /= null and then + Wrapper (This.My_Driver.all).Void_Ptr /= Null_Pointer; + end Has_Driver; + + + function Get_Driver + (This : in out Surface_Device) + return FLTK.Devices.Graphics.Graphics_Driver_Reference is + begin + return Ref : FLTK.Devices.Graphics.Graphics_Driver_Reference (Data => This.My_Driver); + end Get_Driver; + + + procedure Set_Driver + (This : in out Surface_Device; + Driver : in out FLTK.Devices.Graphics.Graphics_Driver'Class) is + begin + fl_surface_device_set_driver (This.Void_Ptr, Wrapper (Driver).Void_Ptr); + This.My_Driver := Driver'Unchecked_Access; + end Set_Driver; + + +begin + + + Original_Surface.Void_Ptr := fl_surface_device_get_surface; + Original_Surface.Needs_Dealloc := False; + + Wrapper (Original_Graphics).Void_Ptr := + fl_surface_device_get_driver (Original_Surface.Void_Ptr); + Wrapper (Original_Graphics).Needs_Dealloc := False; + + Original_Surface.My_Driver := Original_Graphics'Access; + + +end FLTK.Devices.Surface; + + diff --git a/body/fltk-draw.adb b/body/fltk-draw.adb new file mode 100644 index 0000000..38ccb80 --- /dev/null +++ b/body/fltk-draw.adb @@ -0,0 +1,1849 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Unchecked_Deallocation, + FLTK.Pixmap_Marshal, + Interfaces.C.Pointers, + Interfaces.C.Strings; + +use type + + Interfaces.C.int; + + +package body FLTK.Draw is + + + package Chk renames Ada.Assertions; + + -- Oh no... Anyway, this is just used for Expand_Text. + package Char_Pointers is new Interfaces.C.Pointers + (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- No Documentation -- + + procedure fl_draw_set_spot + (F, S : in Interfaces.C.int; + X, Y, W, H : in Interfaces.C.int; + Ptr : in Storage.Integer_Address); + pragma Import (C, fl_draw_set_spot, "fl_draw_set_spot"); + pragma Inline (fl_draw_set_spot); + + procedure fl_draw_set_status + (X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_draw_set_status, "fl_draw_set_status"); + pragma Inline (fl_draw_set_status); + + + + + -- Utility -- + + function fl_draw_can_do_alpha_blending + return Interfaces.C.int; + pragma Import (C, fl_draw_can_do_alpha_blending, "fl_draw_can_do_alpha_blending"); + pragma Inline (fl_draw_can_do_alpha_blending); + + function fl_draw_shortcut_label + (Shortcut : in Interfaces.C.unsigned) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_draw_shortcut_label, "fl_draw_shortcut_label"); + pragma Inline (fl_draw_shortcut_label); + + + + + -- Charset Conversion -- + + function fl_draw_latin1_to_local + (T : in Interfaces.C.char_array; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_draw_latin1_to_local, "fl_draw_latin1_to_local"); + pragma Inline (fl_draw_latin1_to_local); + + function fl_draw_local_to_latin1 + (T : in Interfaces.C.char_array; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_draw_local_to_latin1, "fl_draw_local_to_latin1"); + pragma Inline (fl_draw_local_to_latin1); + + function fl_draw_mac_roman_to_local + (T : in Interfaces.C.char_array; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_draw_mac_roman_to_local, "fl_draw_mac_roman_to_local"); + pragma Inline (fl_draw_mac_roman_to_local); + + function fl_draw_local_to_mac_roman + (T : in Interfaces.C.char_array; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_draw_local_to_mac_roman, "fl_draw_local_to_mac_roman"); + pragma Inline (fl_draw_local_to_mac_roman); + + + + + -- Clipping -- + + function fl_draw_clip_box + (X, Y, W, H : in Interfaces.C.int; + BX, BY, BW, BH : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_draw_clip_box, "fl_draw_clip_box"); + pragma Inline (fl_draw_clip_box); + + function fl_draw_not_clipped + (X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_draw_not_clipped, "fl_draw_not_clipped"); + pragma Inline (fl_draw_not_clipped); + + procedure fl_draw_push_clip + (X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_draw_push_clip, "fl_draw_push_clip"); + pragma Inline (fl_draw_push_clip); + + + + + -- Overlay -- + + procedure fl_draw_overlay_rect + (X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_draw_overlay_rect, "fl_draw_overlay_rect"); + pragma Inline (fl_draw_overlay_rect); + + + + + -- Settings -- + + function fl_draw_get_color + return Interfaces.C.unsigned; + pragma Import (C, fl_draw_get_color, "fl_draw_get_color"); + pragma Inline (fl_draw_get_color); + + procedure fl_draw_set_color + (C : in Interfaces.C.unsigned); + pragma Import (C, fl_draw_set_color, "fl_draw_set_color"); + pragma Inline (fl_draw_set_color); + + procedure fl_draw_set_color2 + (R, G, B : in Interfaces.C.unsigned_char); + pragma Import (C, fl_draw_set_color2, "fl_draw_set_color2"); + pragma Inline (fl_draw_set_color2); + + procedure fl_draw_set_cursor + (M : in Interfaces.C.int); + pragma Import (C, fl_draw_set_cursor, "fl_draw_set_cursor"); + pragma Inline (fl_draw_set_cursor); + + procedure fl_draw_set_cursor2 + (M : in Interfaces.C.int; + F, B : in Interfaces.C.unsigned); + pragma Import (C, fl_draw_set_cursor2, "fl_draw_set_cursor2"); + pragma Inline (fl_draw_set_cursor2); + + function fl_draw_get_font + return Interfaces.C.unsigned; + pragma Import (C, fl_draw_get_font, "fl_draw_get_font"); + pragma Inline (fl_draw_get_font); + + function fl_draw_size + return Interfaces.C.int; + pragma Import (C, fl_draw_size, "fl_draw_size"); + pragma Inline (fl_draw_size); + + procedure fl_draw_set_font + (F : in Interfaces.C.unsigned; + S : in Interfaces.C.int); + pragma Import (C, fl_draw_set_font, "fl_draw_set_font"); + pragma Inline (fl_draw_set_font); + + function fl_draw_height + return Interfaces.C.int; + pragma Import (C, fl_draw_height, "fl_draw_height"); + pragma Inline (fl_draw_height); + + function fl_draw_descent + return Interfaces.C.int; + pragma Import (C, fl_draw_descent, "fl_draw_descent"); + pragma Inline (fl_draw_descent); + + function fl_draw_height2 + (F : in Interfaces.C.unsigned; + S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_draw_height2, "fl_draw_height2"); + pragma Inline (fl_draw_height2); + + procedure fl_draw_line_style + (Style : in Interfaces.C.int; + Width : in Interfaces.C.int; + Dashes : in Interfaces.C.char_array); + pragma Import (C, fl_draw_line_style, "fl_draw_line_style"); + pragma Inline (fl_draw_line_style); + + + + + -- Matrix Operations -- + + procedure fl_draw_mult_matrix + (A, B, C, D, X, Y : in Interfaces.C.double); + pragma Import (C, fl_draw_mult_matrix, "fl_draw_mult_matrix"); + pragma Inline (fl_draw_mult_matrix); + + procedure fl_draw_rotate + (D : in Interfaces.C.double); + pragma Import (C, fl_draw_rotate, "fl_draw_rotate"); + pragma Inline (fl_draw_rotate); + + procedure fl_draw_scale + (X : in Interfaces.C.double); + pragma Import (C, fl_draw_scale, "fl_draw_scale"); + pragma Inline (fl_draw_scale); + + procedure fl_draw_scale2 + (X, Y : in Interfaces.C.double); + pragma Import (C, fl_draw_scale2, "fl_draw_scale2"); + pragma Inline (fl_draw_scale2); + + function fl_draw_transform_dx + (X, Y : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_draw_transform_dx, "fl_draw_transform_dx"); + pragma Inline (fl_draw_transform_dx); + + function fl_draw_transform_dy + (X, Y : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_draw_transform_dy, "fl_draw_transform_dy"); + pragma Inline (fl_draw_transform_dy); + + function fl_draw_transform_x + (X, Y : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_draw_transform_x, "fl_draw_transform_x"); + pragma Inline (fl_draw_transform_x); + + function fl_draw_transform_y + (X, Y : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_draw_transform_y, "fl_draw_transform_y"); + pragma Inline (fl_draw_transform_y); + + procedure fl_draw_transformed_vertex + (XF, YF : in Interfaces.C.double); + pragma Import (C, fl_draw_transformed_vertex, "fl_draw_transformed_vertex"); + pragma Inline (fl_draw_transformed_vertex); + + procedure fl_draw_translate + (X, Y : in Interfaces.C.double); + pragma Import (C, fl_draw_translate, "fl_draw_translate"); + pragma Inline (fl_draw_translate); + + procedure fl_draw_vertex + (X, Y : in Interfaces.C.double); + pragma Import (C, fl_draw_vertex, "fl_draw_vertex"); + pragma Inline (fl_draw_vertex); + + + + + -- Image Drawing -- + + procedure fl_draw_draw_image + (Buf : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + D, L : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_image, "fl_draw_draw_image"); + pragma Inline (fl_draw_draw_image); + + procedure fl_draw_draw_image2 + (Call, User : in Storage.Integer_Address; + X, Y, W, H, D : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_image2, "fl_draw_draw_image2"); + pragma Inline (fl_draw_draw_image2); + + procedure fl_draw_draw_image_mono + (Buf : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + D, L : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_image_mono, "fl_draw_draw_image_mono"); + pragma Inline (fl_draw_draw_image_mono); + + procedure fl_draw_draw_image_mono2 + (Call, User : in Storage.Integer_Address; + X, Y, W, H, D : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_image_mono2, "fl_draw_draw_image_mono2"); + pragma Inline (fl_draw_draw_image_mono2); + + function fl_draw_draw_pixmap + (Data : in Storage.Integer_Address; + X, Y : in Interfaces.C.int; + H : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_draw_draw_pixmap, "fl_draw_draw_pixmap"); + pragma Inline (fl_draw_draw_pixmap); + + function fl_draw_read_image + (Buf : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + Alpha : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_draw_read_image, "fl_draw_read_image"); + pragma Inline (fl_draw_read_image); + + + + + -- Special Drawing -- + + function fl_draw_add_symbol + (Name : in Interfaces.C.char_array; + Drawit : in Storage.Integer_Address; + Scalable : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_draw_add_symbol, "fl_draw_add_symbol"); + pragma Inline (fl_draw_add_symbol); + + procedure fl_draw_draw_text + (Str : in Interfaces.C.char_array; + N, X, Y : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_text, "fl_draw_draw_text"); + pragma Inline (fl_draw_draw_text); + + procedure fl_draw_draw_text2 + (Str : in Interfaces.C.char_array; + X, Y, W, H : in Interfaces.C.int; + Ali : in Interfaces.Unsigned_16; + Img : in Storage.Integer_Address; + Sym : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_text2, "fl_draw_draw_text2"); + pragma Inline (fl_draw_draw_text2); + + procedure fl_draw_draw_text3 + (Str : in Interfaces.C.char_array; + X, Y, W, H : in Interfaces.C.int; + Ali : in Interfaces.Unsigned_16; + Func : in Storage.Integer_Address; + Img : in Storage.Integer_Address; + Sym : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_text3, "fl_draw_draw_text3"); + pragma Inline (fl_draw_draw_text3); + + procedure fl_draw_draw_text4 + (Ang : in Interfaces.C.int; + Str : in Interfaces.C.char_array; + N, X, Y : in Interfaces.C.int); + pragma Import (C, fl_draw_draw_text4, "fl_draw_draw_text4"); + pragma Inline (fl_draw_draw_text4); + + procedure fl_draw_rtl_draw + (Str : in Interfaces.C.char_array; + N, X, Y : in Interfaces.C.int); + pragma Import (C, fl_draw_rtl_draw, "fl_draw_rtl_draw"); + pragma Inline (fl_draw_rtl_draw); + + procedure fl_draw_draw_box + (BK : in Interfaces.C.int; + X, Y, W, H : in Interfaces.C.int; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_draw_draw_box, "fl_draw_draw_box"); + pragma Inline (fl_draw_draw_box); + + function fl_draw_draw_symbol + (Lab : in Interfaces.C.char_array; + X, Y, W, H : in Interfaces.C.int; + Hue : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_draw_draw_symbol, "fl_draw_draw_symbol"); + pragma Inline (fl_draw_draw_symbol); + + procedure fl_draw_measure + (Str : in Interfaces.C.char_array; + W, H : in out Interfaces.C.int; + S : in Interfaces.C.int); + pragma Import (C, fl_draw_measure, "fl_draw_measure"); + pragma Inline (fl_draw_measure); + + procedure fl_draw_scroll + (X, Y, W, H : in Interfaces.C.int; + DX, DY : in Interfaces.C.int; + Func, Data : in Storage.Integer_Address); + pragma Import (C, fl_draw_scroll, "fl_draw_scroll"); + pragma Inline (fl_draw_scroll); + + procedure fl_draw_text_extents + (Str : in Interfaces.C.char_array; + N : in Interfaces.C.int; + DX, DY, W, H : out Interfaces.C.int); + pragma Import (C, fl_draw_text_extents, "fl_draw_text_extents"); + pragma Inline (fl_draw_text_extents); + + -- This function in particular is such bullshit. + function fl_draw_expand_text + (Str : in Interfaces.C.char_array; + Buf : out Interfaces.C.Strings.chars_ptr; + Max_Buf : in Interfaces.C.int; + Max_W : in Interfaces.C.double; + N : out Interfaces.C.int; + Width : out Interfaces.C.double; + Wrap, Sym : in Interfaces.C.int) + return Char_Pointers.Pointer; + pragma Import (C, fl_draw_expand_text, "fl_draw_expand_text"); + pragma Inline (fl_draw_expand_text); + + function fl_draw_width + (Str : in Interfaces.C.char_array; + N : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_draw_width, "fl_draw_width"); + pragma Inline (fl_draw_width); + + function fl_draw_width2 + (C : in Interfaces.C.unsigned_long) + return Interfaces.C.double; + pragma Import (C, fl_draw_width2, "fl_draw_width2"); + pragma Inline (fl_draw_width2); + + + + + -- Manual Drawing -- + + procedure fl_draw_arc + (X, Y, R, Start, Finish : in Interfaces.C.double); + pragma Import (C, fl_draw_arc, "fl_draw_arc"); + pragma Inline (fl_draw_arc); + + procedure fl_draw_arc2 + (X, Y, W, H : in Interfaces.C.int; + A1, A2 : in Interfaces.C.double); + pragma Import (C, fl_draw_arc2, "fl_draw_arc2"); + pragma Inline (fl_draw_arc2); + + -- this function does not yet exist + -- procedure fl_draw_chord + -- (X, Y, W, H : in Interfaces.C.int; + -- A1, A2 : in Interfaces.C.double); + -- pragma Import (C, fl_draw_chord, "fl_draw_chord"); + -- pragma Inline (fl_draw_chord); + + procedure fl_draw_circle + (X, Y, R : in Interfaces.C.double); + pragma Import (C, fl_draw_circle, "fl_draw_circle"); + pragma Inline (fl_draw_circle); + + procedure fl_draw_curve + (X0, Y0 : in Interfaces.C.double; + X1, Y1 : in Interfaces.C.double; + X2, Y2 : in Interfaces.C.double; + X3, Y3 : in Interfaces.C.double); + pragma Import (C, fl_draw_curve, "fl_draw_curve"); + pragma Inline (fl_draw_curve); + + procedure fl_draw_frame + (S : in Interfaces.C.char_array; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_draw_frame, "fl_draw_frame"); + pragma Inline (fl_draw_frame); + + procedure fl_draw_line + (X0, Y0 : in Interfaces.C.int; + X1, Y1 : in Interfaces.C.int); + pragma Import (C, fl_draw_line, "fl_draw_line"); + pragma Inline (fl_draw_line); + + procedure fl_draw_line2 + (X0, Y0 : in Interfaces.C.int; + X1, Y1 : in Interfaces.C.int; + X2, Y2 : in Interfaces.C.int); + pragma Import (C, fl_draw_line2, "fl_draw_line2"); + pragma Inline (fl_draw_line2); + + procedure fl_draw_loop + (X0, Y0 : in Interfaces.C.int; + X1, Y1 : in Interfaces.C.int; + X2, Y2 : in Interfaces.C.int); + pragma Import (C, fl_draw_loop, "fl_draw_loop"); + pragma Inline (fl_draw_loop); + + procedure fl_draw_loop2 + (X0, Y0 : in Interfaces.C.int; + X1, Y1 : in Interfaces.C.int; + X2, Y2 : in Interfaces.C.int; + X3, Y3 : in Interfaces.C.int); + pragma Import (C, fl_draw_loop2, "fl_draw_loop2"); + pragma Inline (fl_draw_loop2); + + procedure fl_draw_pie + (X, Y, W, H : in Interfaces.C.int; + A1, A2 : in Interfaces.C.double); + pragma Import (C, fl_draw_pie, "fl_draw_pie"); + pragma Inline (fl_draw_pie); + + procedure fl_draw_point + (X, Y : in Interfaces.C.int); + pragma Import (C, fl_draw_point, "fl_draw_point"); + pragma Inline (fl_draw_point); + + procedure fl_draw_polygon + (X0, Y0 : in Interfaces.C.int; + X1, Y1 : in Interfaces.C.int; + X2, Y2 : in Interfaces.C.int); + pragma Import (C, fl_draw_polygon, "fl_draw_polygon"); + pragma Inline (fl_draw_polygon); + + procedure fl_draw_polygon2 + (X0, Y0 : in Interfaces.C.int; + X1, Y1 : in Interfaces.C.int; + X2, Y2 : in Interfaces.C.int; + X3, Y3 : in Interfaces.C.int); + pragma Import (C, fl_draw_polygon2, "fl_draw_polygon2"); + pragma Inline (fl_draw_polygon2); + + procedure fl_draw_rect + (X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_draw_rect, "fl_draw_rect"); + pragma Inline (fl_draw_rect); + + procedure fl_draw_rect2 + (X, Y, W, H : in Interfaces.C.int; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_draw_rect2, "fl_draw_rect2"); + pragma Inline (fl_draw_rect2); + + procedure fl_draw_rect_fill + (X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_draw_rect_fill, "fl_draw_rect_fill"); + pragma Inline (fl_draw_rect_fill); + + procedure fl_draw_rect_fill2 + (X, Y, W, H : in Interfaces.C.int; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_draw_rect_fill2, "fl_draw_rect_fill2"); + pragma Inline (fl_draw_rect_fill2); + + procedure fl_draw_rect_fill3 + (X, Y, W, H : in Interfaces.C.int; + R, G, B : in Interfaces.C.unsigned_char); + pragma Import (C, fl_draw_rect_fill3, "fl_draw_rect_fill3"); + pragma Inline (fl_draw_rect_fill3); + + procedure fl_draw_xy_line + (X0, Y0, X1 : in Interfaces.C.int); + pragma Import (C, fl_draw_xy_line, "fl_draw_xy_line"); + pragma Inline (fl_draw_xy_line); + + procedure fl_draw_xy_line2 + (X0, Y0, X1, Y2 : in Interfaces.C.int); + pragma Import (C, fl_draw_xy_line2, "fl_draw_xy_line2"); + pragma Inline (fl_draw_xy_line2); + + procedure fl_draw_xy_line3 + (X0, Y0, X1, Y2, X3 : in Interfaces.C.int); + pragma Import (C, fl_draw_xy_line3, "fl_draw_xy_line3"); + pragma Inline (fl_draw_xy_line3); + + procedure fl_draw_yx_line + (X0, Y0, Y1 : in Interfaces.C.int); + pragma Import (C, fl_draw_yx_line, "fl_draw_yx_line"); + pragma Inline (fl_draw_yx_line); + + procedure fl_draw_yx_line2 + (X0, Y0, Y1, X2 : in Interfaces.C.int); + pragma Import (C, fl_draw_yx_line2, "fl_draw_yx_line2"); + pragma Inline (fl_draw_yx_line2); + + procedure fl_draw_yx_line3 + (X0, Y0, Y1, X2, Y3 : in Interfaces.C.int); + pragma Import (C, fl_draw_yx_line3, "fl_draw_yx_line3"); + pragma Inline (fl_draw_yx_line3); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- No Documentation -- + + procedure Set_Spot + (X, Y, W, H : in Integer; + Font : in Font_Kind; + Size : in Font_Size) is + begin + fl_draw_set_spot + (Font_Kind'Pos (Font), + Interfaces.C.int (Size), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Null_Pointer); + end Set_Spot; + + + procedure Set_Spot + (X, Y, W, H : in Integer; + Font : in Font_Kind; + Size : in Font_Size; + Pane : in FLTK.Widgets.Groups.Windows.Window'Class) is + begin + fl_draw_set_spot + (Font_Kind'Pos (Font), + Interfaces.C.int (Size), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Wrapper (Pane).Void_Ptr); + end Set_Spot; + + + procedure Set_Status + (X, Y, W, H : in Integer) is + begin + fl_draw_set_status + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Set_Status; + + + + + -- Utility -- + + function Can_Do_Alpha_Blending + return Boolean + is + Result : constant Interfaces.C.int := fl_draw_can_do_alpha_blending; + begin + if Result = 1 then + return True; + else + pragma Assert (Result = 0); + return False; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_can_do_alpha_blending returned unexpected value of " & + Interfaces.C.int'Image (Result); + end Can_Do_Alpha_Blending; + + + function Shortcut_Label + (Keys : in Key_Combo) + return String is + begin + return Interfaces.C.Strings.Value + (fl_draw_shortcut_label (To_C (Keys))); + end Shortcut_Label; + + + + + -- Charset Conversion -- + + function Latin1_To_Local + (From : in String) + return String is + begin + return Interfaces.C.Strings.Value + (fl_draw_latin1_to_local (Interfaces.C.To_C (From), -1)); + end Latin1_To_Local; + + + function Local_To_Latin1 + (From : in String) + return String is + begin + return Interfaces.C.Strings.Value + (fl_draw_local_to_latin1 (Interfaces.C.To_C (From), -1)); + end Local_To_Latin1; + + + function Mac_Roman_To_Local + (From : in String) + return String is + begin + return Interfaces.C.Strings.Value + (fl_draw_mac_roman_to_local (Interfaces.C.To_C (From), -1)); + end Mac_Roman_To_Local; + + + function Local_To_Mac_Roman + (From : in String) + return String is + begin + return Interfaces.C.Strings.Value + (fl_draw_local_to_mac_roman (Interfaces.C.To_C (From), -1)); + end Local_To_Mac_Roman; + + + + + -- Clipping -- + + function Clip_Box + (X, Y, W, H : in Integer; + BX, BY, BW, BH : out Integer) + return Boolean + is + CX, CY, CW, CH : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_draw_clip_box + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + CX, CY, CW, CH); + begin + BX := Integer (CX); + BY := Integer (CY); + BW := Integer (CW); + BH := Integer (CH); + return Result /= 0; + end Clip_Box; + + + function Clip_Intersects + (X, Y, W, H : in Integer) + return Boolean is + begin + return fl_draw_not_clipped + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)) /= 0; + end Clip_Intersects; + + + procedure Push_Clip + (X, Y, W, H : in Integer) is + begin + fl_draw_push_clip + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Push_Clip; + + + + + -- Overlay -- + + procedure Overlay_Rect + (X, Y, W, H : in Integer) is + begin + fl_draw_overlay_rect + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Overlay_Rect; + + + + + -- Settings -- + + function Get_Color + return Color is + begin + return Color (fl_draw_get_color); + end Get_Color; + + + procedure Set_Color + (To : in Color) is + begin + fl_draw_set_color (Interfaces.C.unsigned (To)); + end Set_Color; + + + procedure Set_Color + (R, G, B : in Color_Component) is + begin + fl_draw_set_color2 + (Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Set_Color; + + + procedure Set_Cursor + (To : in Mouse_Cursor_Kind) is + begin + fl_draw_set_cursor (Cursor_Values (To)); + end Set_Cursor; + + procedure Set_Cursor + (To : in Mouse_Cursor_Kind; + Fore : in Color; + Back : in Color := White_Color) is + begin + fl_draw_set_cursor2 + (Cursor_Values (To), + Interfaces.C.unsigned (Fore), + Interfaces.C.unsigned (Back)); + end Set_Cursor; + + + function Get_Font + return Font_Kind is + begin + return Font_Kind'Val (fl_draw_get_font); + end Get_Font; + + + function Get_Font_Size + return Font_Size is + begin + return Font_Size (fl_draw_size); + end Get_Font_Size; + + + procedure Set_Font + (Kind : in Font_Kind; + Size : in Font_Size) is + begin + fl_draw_set_font (Font_Kind'Pos (Kind), Interfaces.C.int (Size)); + end Set_Font; + + + function Font_Line_Spacing + return Integer is + begin + return Integer (fl_draw_height); + end Font_Line_Spacing; + + + function Font_Descent + return Integer is + begin + return Integer (fl_draw_descent); + end Font_Descent; + + + function Font_Height + (Kind : in Font_Kind; + Size : in Font_Size) + return Natural is + begin + return Natural (fl_draw_height2 (Font_Kind'Pos (Kind), Interfaces.C.int (Size))); + end Font_Height; + + + type Char_Array_Access is access Interfaces.C.char_array; + + procedure Free_Char_Array is new Ada.Unchecked_Deallocation + (Object => Interfaces.C.char_array, + Name => Char_Array_Access); + + Current_Dashes : Char_Array_Access; + + procedure Set_Line_Style + (Line : in Line_Kind := Solid_Line; + Cap : in Cap_Kind := Default_Cap; + Join : in Join_Kind := Default_Join; + Width : in Natural := 0; + Dashes : in Dash_Gap_Array := Empty_Dashes) is + begin + Free_Char_Array (Current_Dashes); + Current_Dashes := new Interfaces.C.char_array (1 .. (Dashes'Length + 1) * 2); + for Index in Integer range 1 .. Dashes'Length loop + Current_Dashes (2 * Interfaces.C.size_t (Index) - 1) := + Interfaces.C.char'Val (Integer (Dashes (Index).Solid)); + Current_Dashes (2 * Interfaces.C.size_t (Index)) := + Interfaces.C.char'Val (Integer (Dashes (Index).Blank)); + end loop; + Current_Dashes (Current_Dashes'Last - 1) := Interfaces.C.char'Val (0); + Current_Dashes (Current_Dashes'Last) := Interfaces.C.char'Val (0); + fl_draw_line_style + (Line_Kind'Pos (Line) + Cap_Kind'Pos (Cap) * 16#100# + Join_Kind'Pos (Join) * 16#1000#, + Interfaces.C.int (Width), + Current_Dashes.all); + end Set_Line_Style; + + + + + -- Matrix Operations -- + + procedure Mult_Matrix + (A, B, C, D, X, Y : in Long_Float) is + begin + fl_draw_mult_matrix + (Interfaces.C.double (A), + Interfaces.C.double (B), + Interfaces.C.double (C), + Interfaces.C.double (D), + Interfaces.C.double (X), + Interfaces.C.double (Y)); + end Mult_Matrix; + + + procedure Rotate + (Angle : in Long_Float) is + begin + fl_draw_rotate (Interfaces.C.double (Angle)); + end Rotate; + + + procedure Scale + (Factor : in Long_Float) is + begin + fl_draw_scale (Interfaces.C.double (Factor)); + end Scale; + + + procedure Scale + (Factor_X, Factor_Y : in Long_Float) is + begin + fl_draw_scale2 + (Interfaces.C.double (Factor_X), + Interfaces.C.double (Factor_Y)); + end Scale; + + + function Transform_DX + (X, Y : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_draw_transform_dx + (Interfaces.C.double (X), + Interfaces.C.double (Y))); + end Transform_DX; + + + function Transform_DY + (X, Y : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_draw_transform_dy + (Interfaces.C.double (X), + Interfaces.C.double (Y))); + end Transform_DY; + + + function Transform_X + (X, Y : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_draw_transform_x + (Interfaces.C.double (X), + Interfaces.C.double (Y))); + end Transform_X; + + + function Transform_Y + (X, Y : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_draw_transform_y + (Interfaces.C.double (X), + Interfaces.C.double (Y))); + end Transform_Y; + + + procedure Transformed_Vertex + (XF, YF : in Long_Float) is + begin + fl_draw_transformed_vertex + (Interfaces.C.double (XF), + Interfaces.C.double (YF)); + end Transformed_Vertex; + + + procedure Translate + (X, Y : in Long_Float) is + begin + fl_draw_translate + (Interfaces.C.double (X), + Interfaces.C.double (Y)); + end Translate; + + + procedure Vertex + (X, Y : in Long_Float) is + begin + fl_draw_vertex + (Interfaces.C.double (X), + Interfaces.C.double (Y)); + end Vertex; + + + + + -- Image Drawing -- + + procedure Draw_Image + (X, Y, W, H : in Integer; + Data : in Color_Component_Array; + Depth : in Positive := 3; + Line_Size : in Natural := 0; + Flip_Horizontal : in Boolean := False; + Flip_Vertical : in Boolean := False) + is + Real_Depth : Integer := Depth; + Real_Line_Data : Integer := Line_Size; + begin + if Flip_Horizontal then + Real_Depth := Real_Depth * (-1); + end if; + if Flip_Vertical then + if Real_Line_Data = 0 then + Real_Line_Data := W * Depth * (-1); + else + Real_Line_Data := Real_Line_Data * (-1); + end if; + end if; + fl_draw_draw_image + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Real_Depth), + Interfaces.C.int (Real_Line_Data)); + end Draw_Image; + + + Image_Func_Ptr : Image_Draw_Function; + + procedure Draw_Image_Hook + (Ignore : in Storage.Integer_Address; + X, Y, W : in Interfaces.C.int; + Buf_Ptr : in Storage.Integer_Address); + pragma Convention (C, Draw_Image_Hook); + + procedure Draw_Image_Hook + (Ignore : in Storage.Integer_Address; + X, Y, W : in Interfaces.C.int; + Buf_Ptr : in Storage.Integer_Address) + is + Data_Buffer : Color_Component_Array (1 .. Size_Type (W)); + for Data_Buffer'Address use Storage.To_Address (Buf_Ptr); + pragma Import (Ada, Data_Buffer); + begin + Image_Func_Ptr (Integer (X), Integer (Y), Data_Buffer); + end Draw_Image_Hook; + + procedure Draw_Image + (X, Y, W, H : in Integer; + Callback : in Image_Draw_Function; + Depth : in Positive := 3) is + begin + Image_Func_Ptr := Callback; + fl_draw_draw_image2 + (Storage.To_Integer (Draw_Image_Hook'Address), + Null_Pointer, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Depth)); + end Draw_Image; + + + procedure Draw_Image_Mono + (X, Y, W, H : in Integer; + Data : in Color_Component_Array; + Depth : in Positive := 1; + Line_Size : in Natural := 0; + Flip_Horizontal : Boolean := False; + Flip_Vertical : Boolean := False) + is + Real_Depth : Integer := Depth; + Real_Line_Data : Integer := Line_Size; + begin + if Flip_Horizontal then + Real_Depth := Real_Depth * (-1); + end if; + if Flip_Vertical then + if Real_Line_Data = 0 then + Real_Line_Data := W * Depth * (-1); + else + Real_Line_Data := Real_Line_Data * (-1); + end if; + end if; + fl_draw_draw_image_mono + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Real_Depth), + Interfaces.C.int (Real_Line_Data)); + end Draw_Image_Mono; + + + Mono_Image_Func_Ptr : Image_Draw_Function; + + procedure Draw_Image_Mono_Hook + (Ignore : in Storage.Integer_Address; + X, Y, W : in Interfaces.C.int; + Buf_Ptr : in Storage.Integer_Address); + pragma Convention (C, Draw_Image_Mono_Hook); + + procedure Draw_Image_Mono_Hook + (Ignore : in Storage.Integer_Address; + X, Y, W : in Interfaces.C.int; + Buf_Ptr : in Storage.Integer_Address) + is + Data_Buffer : Color_Component_Array (1 .. Size_Type (W)); + for Data_Buffer'Address use Storage.To_Address (Buf_Ptr); + pragma Import (Ada, Data_Buffer); + begin + Mono_Image_Func_Ptr (Integer (X), Integer (Y), Data_Buffer); + end Draw_Image_Mono_Hook; + + procedure Draw_Image_Mono + (X, Y, W, H : in Integer; + Callback : in Image_Draw_Function; + Depth : in Positive := 1) is + begin + Mono_Image_Func_Ptr := Callback; + fl_draw_draw_image_mono2 + (Storage.To_Integer (Draw_Image_Mono_Hook'Address), + Null_Pointer, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Depth)); + end Draw_Image_Mono; + + + procedure Draw_Pixmap + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; + X, Y : in Integer; + Tone : in Color := Grey0_Color) + is + C_Data : Pixmap_Marshal.chars_ptr_array_access := + Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels); + Result : constant Interfaces.C.int := fl_draw_draw_pixmap + (Storage.To_Integer (C_Data (C_Data'First)'Address), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.unsigned (Tone)); + begin + pragma Assert (Result /= 0); + Pixmap_Marshal.Free_Recursive (C_Data); + exception + when Chk.Assertion_Error => + Pixmap_Marshal.Free_Recursive (C_Data); + raise Draw_Error with "fl_draw_pixmap could not decode supplied XPM pixmap data"; + end Draw_Pixmap; + + + function Read_Image + (X, Y, W, H : in Integer; + Alpha : in Integer := 0) + return Color_Component_Array + is + My_Len : constant Size_Type := + (if Alpha = 0 + then Size_Type (W) * Size_Type (H) * 3 + else Size_Type (W) * Size_Type (H) * 4); + Result : Color_Component_Array (1 .. My_Len); + Buffer : Storage.Integer_Address; + begin + Buffer := fl_draw_read_image + ((if Result'Length > 0 + then Storage.To_Integer (Result (Result'First)'Address) + else Null_Pointer), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Alpha)); + pragma Assert + ((if Result'Length > 0 + then Buffer = Storage.To_Integer (Result (Result'First)'Address) + else Buffer = Null_Pointer)); + return Result; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_read_image returned unexpected address value that did not " & + "correspond to supplied address value"; + end Read_Image; + + + + + -- Special Drawing -- + + procedure Add_Symbol + (Text : in String; + Callback : in Symbol_Draw_Function; + Scalable : in Boolean) + is + Ret_Val : constant Interfaces.C.int := fl_draw_add_symbol + (Interfaces.C.To_C (Text), + Storage.To_Integer (Callback.all'Address), + Boolean'Pos (Scalable)); + begin + if Ret_Val = 0 then + raise Draw_Error; + else + pragma Assert (Ret_Val = 1); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_add_symbol returned unexpected int value of " & + Interfaces.C.int'Image (Ret_Val); + end Add_Symbol; + + procedure Draw_Text + (X, Y : in Integer; + Text : in String) is + begin + fl_draw_draw_text + (Interfaces.C.To_C (Text), + Text'Length, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw_Text; + + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Symbols : in Boolean := True) is + begin + fl_draw_draw_text2 + (Interfaces.C.To_C (Text), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.Unsigned_16 (Align), + Null_Pointer, + Boolean'Pos (Symbols)); + end Draw_Text; + + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Picture : in FLTK.Images.Image'Class; + Symbols : in Boolean := True) is + begin + fl_draw_draw_text2 + (Interfaces.C.To_C (Text), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.Unsigned_16 (Align), + Wrapper (Picture).Void_Ptr, + Boolean'Pos (Symbols)); + end Draw_Text; + + + Text_Func_Ptr : Text_Draw_Function; + + procedure Draw_Text_Hook + (Ptr : in Storage.Integer_Address; + N, X0, Y0 : in Interfaces.C.int); + + pragma Convention (C, Draw_Text_Hook); + + procedure Draw_Text_Hook + (Ptr : in Storage.Integer_Address; + N, X0, Y0 : in Interfaces.C.int) + is + Data : String (1 .. Integer (N)); + for Data'Address use Storage.To_Address (Ptr); + pragma Import (Ada, Data); + begin + Text_Func_Ptr (Integer (X0), Integer (Y0), Data); + end Draw_Text_Hook; + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Callback : in Text_Draw_Function; + Symbols : in Boolean := True) is + begin + Text_Func_Ptr := Callback; + fl_draw_draw_text3 + (Interfaces.C.To_C (Text), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.Unsigned_16 (Align), + Storage.To_Integer (Draw_Text_Hook'Address), + Null_Pointer, + Boolean'Pos (Symbols)); + end Draw_Text; + + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Callback : in Text_Draw_Function; + Picture : in FLTK.Images.Image'Class; + Symbols : in Boolean := True) is + begin + Text_Func_Ptr := Callback; + fl_draw_draw_text3 + (Interfaces.C.To_C (Text), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.Unsigned_16 (Align), + Storage.To_Integer (Draw_Text_Hook'Address), + Wrapper (Picture).Void_Ptr, + Boolean'Pos (Symbols)); + end Draw_Text; + + + procedure Draw_Text + (X, Y : in Integer; + Text : in String; + Angle : in Integer) is + begin + fl_draw_draw_text4 + (Interfaces.C.int (Angle), + Interfaces.C.To_C (Text), + Text'Length, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw_Text; + + + procedure Draw_Text_Right_Left + (X, Y : in Integer; + Text : in String) is + begin + fl_draw_rtl_draw + (Interfaces.C.To_C (Text), + Text'Length, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw_Text_Right_Left; + + + procedure Draw_Box + (X, Y, W, H : in Integer; + Kind : in Box_Kind; + Hue : in Color) is + begin + fl_draw_draw_box + (Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Symbol + (X, Y, W, H : in Integer; + Name : in String; + Hue : in Color) + is + Ret_Val : constant Interfaces.C.int := fl_draw_draw_symbol + (Interfaces.C.To_C (Name), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + begin + if Ret_Val = 0 then + raise Draw_Error; + else + pragma Assert (Ret_Val = 1); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_draw_symbol returned unexpected int value of " & + Interfaces.C.int'Image (Ret_Val); + end Draw_Symbol; + + + procedure Measure + (Text : in String; + W, H : out Natural; + Symbols : in Boolean := True; + Wrap : in Natural := 0) + is + Result_W : Interfaces.C.int := Interfaces.C.int (Wrap); + Result_H : Interfaces.C.int := 0; + begin + fl_draw_measure + (Interfaces.C.To_C (Text), + Result_W, Result_H, + Boolean'Pos (Symbols)); + W := Natural (Result_W); + H := Natural (Result_H); + end Measure; + + + procedure Scroll_Hook + (Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + + pragma Convention (C, Scroll_Hook); + + procedure Scroll_Hook + (Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int) + is + procedure my_area_draw + (X, Y, W, H : in Integer); + for my_area_draw'Address use Storage.To_Address (Ptr); + pragma Import (Ada, my_area_draw); + begin + my_area_draw (Integer (X), Integer (Y), Integer (W), Integer (H)); + end Scroll_Hook; + + procedure Scroll + (X, Y, W, H : in Integer; + DX, DY : in Integer; + Callback : in Area_Draw_Function) is + begin + fl_draw_scroll + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (DX), + Interfaces.C.int (DY), + Storage.To_Integer (Scroll_Hook'Address), + Storage.To_Integer (Callback.all'Address)); + end Scroll; + + + procedure Text_Extents + (Text : in String; + DX, DY, W, H : out Integer) + is + Result_DX, Result_DY, Result_W, Result_H : Interfaces.C.int; + begin + fl_draw_text_extents + (Interfaces.C.To_C (Text), + Text'Length, + Result_DX, + Result_DY, + Result_W, + Result_H); + DX := Integer (Result_DX); + DY := Integer (Result_DY); + W := Integer (Result_W); + H := Integer (Result_H); + end Text_Extents; + + + function Expand_Text + (Text : in String; + Max_Width : in Long_Float; + Width : out Long_Float; + Last : out Natural; + Wrap : in Boolean; + Symbols : in Boolean := False) + return String + is + Buffer : Interfaces.C.Strings.chars_ptr; + Length : Interfaces.C.int; + Temp : Interfaces.C.char_array := Interfaces.C.To_C (Text); + Result : constant Char_Pointers.Pointer := fl_draw_expand_text + (Temp, Buffer, 0, + Interfaces.C.double (Max_Width), + Length, + Interfaces.C.double (Width), + Boolean'Pos (Wrap), + Boolean'Pos (Symbols)); + use type Char_Pointers.Pointer; + begin + Last := Natural (Result - Temp (Temp'First)'Unchecked_Access); + return Interfaces.C.Strings.Value (Buffer, Interfaces.C.size_t (Length)); + end Expand_Text; + + + function Width + (Text : in String) + return Long_Float is + begin + return Long_Float (fl_draw_width (Interfaces.C.To_C (Text), Text'Length)); + end Width; + + + function Width + (Glyph : in Character) + return Long_Float is + begin + return Long_Float (fl_draw_width2 (Character'Pos (Glyph))); + end Width; + + + function Width + (Glyph : in Wide_Character) + return Long_Float is + begin + return Long_Float (fl_draw_width2 (Wide_Character'Pos (Glyph))); + end Width; + + + function Width + (Glyph : in Wide_Wide_Character) + return Long_Float is + begin + return Long_Float (fl_draw_width2 (Wide_Wide_Character'Pos (Glyph))); + end Width; + + + + + -- Manual Drawing -- + + procedure Arc + (X, Y, R, Start, Finish : in Long_Float) is + begin + fl_draw_arc + (Interfaces.C.double (X), + Interfaces.C.double (Y), + Interfaces.C.double (R), + Interfaces.C.double (Start), + Interfaces.C.double (Finish)); + end Arc; + + + procedure Arc + (X, Y, W, H : in Integer; + Start, Finish : in Long_Float) is + begin + fl_draw_arc2 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.double (Start), + Interfaces.C.double (Finish)); + end Arc; + + + procedure Chord + (X, Y, W, H : in Integer; + Angle1, Angle2 : in Long_Float) is + begin + null; + -- this function does not yet exist + -- fl_draw_chord + -- (Interfaces.C.int (X), + -- Interfaces.C.int (Y), + -- Interfaces.C.int (W), + -- Interfaces.C.int (H), + -- Interfaces.C.double (Angle1), + -- Interfaces.C.double (Angle2)); + end Chord; + + + procedure Circle + (X, Y, R : in Long_Float) is + begin + fl_draw_circle + (Interfaces.C.double (X), + Interfaces.C.double (Y), + Interfaces.C.double (R)); + end Circle; + + + procedure Curve + (X0, Y0 : in Long_Float; + X1, Y1 : in Long_Float; + X2, Y2 : in Long_Float; + X3, Y3 : in Long_Float) is + begin + fl_draw_curve + (Interfaces.C.double (X0), Interfaces.C.double (Y0), + Interfaces.C.double (X1), Interfaces.C.double (Y1), + Interfaces.C.double (X2), Interfaces.C.double (Y2), + Interfaces.C.double (X3), Interfaces.C.double (Y3)); + end Curve; + + + procedure Frame + (X, Y, W, H : in Integer; + Top, Left, Bottom, Right : in Greyscale) is + begin + fl_draw_frame + (Interfaces.C.To_C + (Character (Top) & Character (Left) & Character (Bottom) & Character (Right)), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Frame; + + + procedure Line + (X0, Y0 : in Integer; + X1, Y1 : in Integer) is + begin + fl_draw_line + (Interfaces.C.int (X0), Interfaces.C.int (Y0), + Interfaces.C.int (X1), Interfaces.C.int (Y1)); + end Line; + + + procedure Line + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer) is + begin + fl_draw_line2 + (Interfaces.C.int (X0), Interfaces.C.int (Y0), + Interfaces.C.int (X1), Interfaces.C.int (Y1), + Interfaces.C.int (X2), Interfaces.C.int (Y2)); + end Line; + + + procedure Outline + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer) is + begin + fl_draw_loop + (Interfaces.C.int (X0), Interfaces.C.int (Y0), + Interfaces.C.int (X1), Interfaces.C.int (Y1), + Interfaces.C.int (X2), Interfaces.C.int (Y2)); + end Outline; + + + procedure Outline + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer; + X3, Y3 : in Integer) is + begin + fl_draw_loop2 + (Interfaces.C.int (X0), Interfaces.C.int (Y0), + Interfaces.C.int (X1), Interfaces.C.int (Y1), + Interfaces.C.int (X2), Interfaces.C.int (Y2), + Interfaces.C.int (X3), Interfaces.C.int (Y3)); + end Outline; + + + procedure Pie + (X, Y, W, H : in Integer; + Angle1, Angle2 : in Long_Float) is + begin + fl_draw_pie + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.double (Angle1), + Interfaces.C.double (Angle2)); + end Pie; + + + procedure Point + (X, Y : in Integer) is + begin + fl_draw_point + (Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Point; + + + procedure Polygon + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer) is + begin + fl_draw_polygon + (Interfaces.C.int (X0), Interfaces.C.int (Y0), + Interfaces.C.int (X1), Interfaces.C.int (Y1), + Interfaces.C.int (X2), Interfaces.C.int (Y2)); + end Polygon; + + + procedure Polygon + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer; + X3, Y3 : in Integer) is + begin + fl_draw_polygon2 + (Interfaces.C.int (X0), Interfaces.C.int (Y0), + Interfaces.C.int (X1), Interfaces.C.int (Y1), + Interfaces.C.int (X2), Interfaces.C.int (Y2), + Interfaces.C.int (X3), Interfaces.C.int (Y3)); + end Polygon; + + + procedure Rect + (X, Y, W, H : in Integer) is + begin + fl_draw_rect + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Rect; + + + procedure Rect + (X, Y, W, H : in Integer; + Hue : in Color) is + begin + fl_draw_rect2 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + end Rect; + + + procedure Rect_Fill + (X, Y, W, H : in Integer) is + begin + fl_draw_rect_fill + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Rect_Fill; + + + procedure Rect_Fill + (X, Y, W, H : in Integer; + Hue : in Color) is + begin + fl_draw_rect_fill2 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + end Rect_Fill; + + + procedure Rect_Fill + (X, Y, W, H : in Integer; + R, G, B : in Color_Component) is + begin + fl_draw_rect_fill3 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Rect_Fill; + + + procedure Ecks_Why_Line + (X0, Y0, X1 : in Integer) is + begin + fl_draw_xy_line + (Interfaces.C.int (X0), + Interfaces.C.int (Y0), + Interfaces.C.int (X1)); + end Ecks_Why_Line; + + + procedure Ecks_Why_Line + (X0, Y0, X1, Y2 : in Integer) is + begin + fl_draw_xy_line2 + (Interfaces.C.int (X0), + Interfaces.C.int (Y0), + Interfaces.C.int (X1), + Interfaces.C.int (Y2)); + end Ecks_Why_Line; + + + procedure Ecks_Why_Line + (X0, Y0, X1, Y2, X3 : in Integer) is + begin + fl_draw_xy_line3 + (Interfaces.C.int (X0), + Interfaces.C.int (Y0), + Interfaces.C.int (X1), + Interfaces.C.int (Y2), + Interfaces.C.int (X3)); + end Ecks_Why_Line; + + + procedure Why_Ecks_Line + (X0, Y0, Y1 : in Integer) is + begin + fl_draw_yx_line + (Interfaces.C.int (X0), + Interfaces.C.int (Y0), + Interfaces.C.int (Y1)); + end Why_Ecks_Line; + + + procedure Why_Ecks_Line + (X0, Y0, Y1, X2 : in Integer) is + begin + fl_draw_yx_line2 + (Interfaces.C.int (X0), + Interfaces.C.int (Y0), + Interfaces.C.int (Y1), + Interfaces.C.int (X2)); + end Why_Ecks_Line; + + + procedure Why_Ecks_Line + (X0, Y0, Y1, X2, Y3 : in Integer) is + begin + fl_draw_yx_line3 + (Interfaces.C.int (X0), + Interfaces.C.int (Y0), + Interfaces.C.int (Y1), + Interfaces.C.int (X2), + Interfaces.C.int (Y3)); + end Why_Ecks_Line; + + +end FLTK.Draw; + + diff --git a/body/fltk-environment.adb b/body/fltk-environment.adb new file mode 100644 index 0000000..c510e26 --- /dev/null +++ b/body/fltk-environment.adb @@ -0,0 +1,1130 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Environment is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + root_fl_prefs_system : constant Interfaces.C.int; + pragma Import (C, root_fl_prefs_system, "root_fl_prefs_system"); + + root_fl_prefs_user : constant Interfaces.C.int; + pragma Import (C, root_fl_prefs_user, "root_fl_prefs_user"); + + const_fl_path_max : constant Interfaces.C.int; + pragma Import (C, const_fl_path_max, "const_fl_path_max"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Static -- + + function fl_preferences_new_uuid + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_preferences_new_uuid, "fl_preferences_new_uuid"); + pragma Inline (fl_preferences_new_uuid); + + + + + -- Allocation -- + + function new_fl_pref_database_path + (P, V, A : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_pref_database_path, "new_fl_pref_database_path"); + pragma Inline (new_fl_pref_database_path); + + function new_fl_pref_database_scope + (S : in Interfaces.C.int; + V, A : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_pref_database_scope, "new_fl_pref_database_scope"); + pragma Inline (new_fl_pref_database_scope); + + procedure upref_fl_pref_database + (P : in Storage.Integer_Address); + pragma Import (C, upref_fl_pref_database, "upref_fl_pref_database"); + pragma Inline (upref_fl_pref_database); + + procedure free_fl_pref_database + (E : in Storage.Integer_Address); + pragma Import (C, free_fl_pref_database, "free_fl_pref_database"); + pragma Inline (free_fl_pref_database); + + + + + -- More Allocation -- + + function new_fl_pref_group_copy + (D : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_pref_group_copy, "new_fl_pref_group_copy"); + pragma Inline (new_fl_pref_group_copy); + + function new_fl_pref_group_memory + (N : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_pref_group_memory, "new_fl_pref_group_memory"); + pragma Inline (new_fl_pref_group_memory); + + function new_fl_pref_group_name + (G : in Storage.Integer_Address; + N : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_pref_group_name, "new_fl_pref_group_name"); + pragma Inline (new_fl_pref_group_name); + + function new_fl_pref_group_index + (G : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_pref_group_index, "new_fl_pref_group_index"); + pragma Inline (new_fl_pref_group_index); + + procedure free_fl_pref_group + (G : in Storage.Integer_Address); + pragma Import (C, free_fl_pref_group, "free_fl_pref_group"); + pragma Inline (free_fl_pref_group); + + + + + -- Disk Activity -- + + procedure fl_preferences_flush + (E : in Storage.Integer_Address); + pragma Import (C, fl_preferences_flush, "fl_preferences_flush"); + pragma Inline (fl_preferences_flush); + + function fl_preferences_getuserdatapath + (E : in Storage.Integer_Address; + P : out Interfaces.C.char_array; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_getuserdatapath, "fl_preferences_getuserdatapath"); + pragma Inline (fl_preferences_getuserdatapath); + + + + + -- Deletion -- + + function fl_preferences_deleteentry + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_deleteentry, "fl_preferences_deleteentry"); + pragma Inline (fl_preferences_deleteentry); + + function fl_preferences_deleteallentries + (E : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_preferences_deleteallentries, "fl_preferences_deleteallentries"); + pragma Inline (fl_preferences_deleteallentries); + + function fl_preferences_deletegroup + (P : in Storage.Integer_Address; + G : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_deletegroup, "fl_preferences_deletegroup"); + pragma Inline (fl_preferences_deletegroup); + + function fl_preferences_deleteallgroups + (P : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_preferences_deleteallgroups, "fl_preferences_deleteallgroups"); + pragma Inline (fl_preferences_deleteallgroups); + + function fl_preferences_clear + (E : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_preferences_clear, "fl_preferences_clear"); + pragma Inline (fl_preferences_clear); + + + + + -- Key Values -- + + function fl_preferences_entries + (E : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_preferences_entries, "fl_preferences_entries"); + pragma Inline (fl_preferences_entries); + + function fl_preferences_entry + (E : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_preferences_entry, "fl_preferences_entry"); + pragma Inline (fl_preferences_entry); + + function fl_preferences_entryexists + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_entryexists, "fl_preferences_entryexists"); + pragma Inline (fl_preferences_entryexists); + + function fl_preferences_size + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_size, "fl_preferences_size"); + pragma Inline (fl_preferences_size); + + + + + -- Groups -- + + function fl_preferences_groups + (P : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_preferences_groups, "fl_preferences_groups"); + pragma Inline (fl_preferences_groups); + + function fl_preferences_group + (P : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_preferences_group, "fl_preferences_group"); + pragma Inline (fl_preferences_group); + + function fl_preferences_groupexists + (P : in Storage.Integer_Address; + G : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_groupexists, "fl_preferences_groupexists"); + pragma Inline (fl_preferences_groupexists); + + + + + -- Names -- + + function fl_preferences_name + (P : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_preferences_name, "fl_preferences_name"); + pragma Inline (fl_preferences_name); + + function fl_preferences_path + (P : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_preferences_path, "fl_preferences_path"); + pragma Inline (fl_preferences_path); + + + + + -- Retrieval -- + + function fl_preferences_get_int + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Interfaces.C.int; + D : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_int, "fl_preferences_get_int"); + pragma Inline (fl_preferences_get_int); + + function fl_preferences_get_float + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Interfaces.C.C_float; + D : in Interfaces.C.C_float) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_float, "fl_preferences_get_float"); + pragma Inline (fl_preferences_get_float); + + function fl_preferences_get_double + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Interfaces.C.double; + D : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_double, "fl_preferences_get_double"); + pragma Inline (fl_preferences_get_double); + + function fl_preferences_get_str + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Interfaces.C.Strings.chars_ptr; + D : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_str, "fl_preferences_get_str"); + pragma Inline (fl_preferences_get_str); + + function fl_preferences_get_str_limit + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Interfaces.C.char_array; + D : in Interfaces.C.char_array; + M : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_str_limit, "fl_preferences_get_str_limit"); + pragma Inline (fl_preferences_get_str_limit); + + function fl_preferences_get_void + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : out Storage.Integer_Address; + D : in Storage.Integer_Address; + DS : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_void, "fl_preferences_get_void"); + pragma Inline (fl_preferences_get_void); + + function fl_preferences_get_void_limit + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V, D : in Storage.Integer_Address; + DS, MS : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_get_void_limit, "fl_preferences_get_void_limit"); + pragma Inline (fl_preferences_get_void_limit); + + procedure free_fl_preferences_void_data + (V : in Storage.Integer_Address); + pragma Import (C, free_fl_preferences_void_data, "free_fl_preferences_void_data"); + pragma Inline (free_fl_preferences_void_data); + + + + + -- Storage -- + + function fl_preferences_set_int + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_int, "fl_preferences_set_int"); + pragma Inline (fl_preferences_set_int); + + function fl_preferences_set_float + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : in Interfaces.C.C_float) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_float, "fl_preferences_set_float"); + pragma Inline (fl_preferences_set_float); + + function fl_preferences_set_float_prec + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : in Interfaces.C.C_float; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_float_prec, "fl_preferences_set_float_prec"); + pragma Inline (fl_preferences_set_float_prec); + + function fl_preferences_set_double + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_double, "fl_preferences_set_double"); + pragma Inline (fl_preferences_set_double); + + function fl_preferences_set_double_prec + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : in Interfaces.C.double; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_double_prec, "fl_preferences_set_double_prec"); + pragma Inline (fl_preferences_set_double_prec); + + function fl_preferences_set_str + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + V : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_str, "fl_preferences_set_str"); + pragma Inline (fl_preferences_set_str); + + function fl_preferences_set_void + (E : in Storage.Integer_Address; + K : in Interfaces.C.char_array; + D : in Storage.Integer_Address; + DS : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_preferences_set_void, "fl_preferences_set_void"); + pragma Inline (fl_preferences_set_void); + + + + + ------------------------ + -- Internal Utility -- + ------------------------ + + function To_Cint + (Extent : in Scope) + return Interfaces.C.int is + begin + case Extent is + when Global => + return root_fl_prefs_system; + when User => + return root_fl_prefs_user; + end case; + end To_Cint; + + function To_Scope + (Num : in Interfaces.C.int) + return Scope is + begin + if Num = root_fl_prefs_system then + return Global; + else + pragma Assert (Num = root_fl_prefs_user); + return User; + end if; + exception + when Chk.Assertion_Error => raise Constraint_Error; + end To_Scope; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Database) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_pref_database (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + procedure Finalize + (This : in out Pref_Group) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_pref_group (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + if This.Root_Ptr /= Null_Pointer then + free_fl_pref_database (This.Root_Ptr); + end if; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + + function From_Filesystem + (Directory, Vendor, Application : in String) + return Database is + begin + return This : Database do + This.Void_Ptr := new_fl_pref_database_path + (Interfaces.C.To_C (Directory), + Interfaces.C.To_C (Vendor), + Interfaces.C.To_C (Application)); + end return; + end From_Filesystem; + + + function From_Scope + (Extent : in Scope; + Vendor, Application : in String) + return Database is + begin + return This : Database do + This.Void_Ptr := new_fl_pref_database_scope + (To_Cint (Extent), + Interfaces.C.To_C (Vendor), + Interfaces.C.To_C (Application)); + end return; + end From_Scope; + + + function Root + (From : in Database) + return Pref_Group'Class is + begin + return Result : Pref_Group do + Result.Void_Ptr := new_fl_pref_group_copy (From.Void_Ptr); + Result.Root_Ptr := From.Void_Ptr; + upref_fl_pref_database (Result.Root_Ptr); + end return; + end Root; + + + function In_Memory + (Name : in String) + return Pref_Group is + begin + return Result : Pref_Group do + Result.Void_Ptr := new_fl_pref_group_memory (Interfaces.C.To_C (Name)); + Result.Root_Ptr := Null_Pointer; + end return; + end In_Memory; + + + function By_Name + (From : in Pref_Group; + Name : in String) + return Pref_Group'Class is + begin + return Result : Pref_Group do + Result.Void_Ptr := new_fl_pref_group_name + (From.Void_Ptr, + Interfaces.C.To_C (Name)); + Result.Root_Ptr := From.Root_Ptr; + if Result.Root_Ptr /= Null_Pointer then + upref_fl_pref_database (Result.Root_Ptr); + end if; + end return; + end By_Name; + + + function By_Index + (From : in Pref_Group; + Index : in Positive) + return Pref_Group'Class is + begin + return Result : Pref_Group do + Result.Void_Ptr := new_fl_pref_group_index + (From.Void_Ptr, + Interfaces.C.int (Index - 1)); + Result.Root_Ptr := From.Root_Ptr; + if Result.Root_Ptr /= Null_Pointer then + upref_fl_pref_database (Result.Root_Ptr); + end if; + end return; + end By_Index; + + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Static -- + + function New_UUID + return String + is + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_new_uuid; + begin + return Interfaces.C.Strings.Value (Text); + end New_UUID; + + + + + -- Disk Activity -- + + procedure Flush + (This : in Database) is + begin + fl_preferences_flush (This.Void_Ptr); + end Flush; + + + function Userdata_Path + (This : in Database) + return String + is + Buffer : Interfaces.C.char_array := + (1 .. Interfaces.C.size_t (const_fl_path_max + 1) => ' '); + begin + if fl_preferences_getuserdatapath + (This.Void_Ptr, + Buffer, + const_fl_path_max) = 0 + then + raise Preference_Error; + end if; + return Interfaces.C.To_Ada (Buffer); + end Userdata_Path; + + + + + -- Deletion -- + + procedure Delete_Entry + (This : in out Pref_Group; + Key : in String) is + begin + if fl_preferences_deleteentry (This.Void_Ptr, Interfaces.C.To_C (Key)) = 0 then + raise Preference_Error; + end if; + end Delete_Entry; + + + procedure Delete_All_Entries + (This : in out Pref_Group) is + begin + if fl_preferences_deleteallentries (This.Void_Ptr) = 0 then + raise Preference_Error; + end if; + end Delete_All_Entries; + + + procedure Delete_Group + (This : in out Pref_Group; + Name : in String) is + begin + if fl_preferences_deletegroup (This.Void_Ptr, Interfaces.C.To_C (Name)) = 0 then + raise Preference_Error; + end if; + end Delete_Group; + + + procedure Delete_All_Groups + (This : in out Pref_Group) is + begin + if fl_preferences_deleteallgroups (This.Void_Ptr) = 0 then + raise Preference_Error; + end if; + end Delete_All_Groups; + + + procedure Clear + (This : in out Pref_Group) is + begin + if fl_preferences_clear (This.Void_Ptr) = 0 then + raise Preference_Error; + end if; + end Clear; + + + + + -- Key Values -- + + function Number_Of_Entries + (This : in Pref_Group) + return Natural is + begin + return Natural (fl_preferences_entries (This.Void_Ptr)); + end Number_Of_Entries; + + + function Entry_Key + (This : in Pref_Group; + Index : in Positive) + return String + is + Key : constant Interfaces.C.Strings.chars_ptr := + fl_preferences_entry (This.Void_Ptr, Interfaces.C.int (Index) - 1); + begin + -- no need for dealloc? + if Key = Interfaces.C.Strings.Null_Ptr then + raise Preference_Error; + else + return Interfaces.C.Strings.Value (Key); + end if; + end Entry_Key; + + + function Key_Exists + (This : in Pref_Group; + Key : in String) + return Boolean is + begin + return fl_preferences_entryexists (This.Void_Ptr, Interfaces.C.To_C (Key)) /= 0; + end Key_Exists; + + + function Value_Size + (This : in Pref_Group; + Key : in String) + return Natural is + begin + return Natural (fl_preferences_size (This.Void_Ptr, Interfaces.C.To_C (Key))); + end Value_Size; + + + + + -- Groups -- + + function Number_Of_Groups + (This : in Pref_Group) + return Natural is + begin + return Natural (fl_preferences_groups (This.Void_Ptr)); + end Number_Of_Groups; + + + function Group_Name + (This : in Pref_Group; + Index : in Positive) + return String + is + Name : constant Interfaces.C.Strings.chars_ptr := + fl_preferences_group (This.Void_Ptr, Interfaces.C.int (Index) - 1); + begin + -- no need for dealloc? + if Name = Interfaces.C.Strings.Null_Ptr then + raise Preference_Error; + else + return Interfaces.C.Strings.Value (Name); + end if; + end Group_Name; + + + function Group_Exists + (This : in Pref_Group; + Name : in String) + return Boolean is + begin + return fl_preferences_groupexists (This.Void_Ptr, Interfaces.C.To_C (Name)) /= 0; + end Group_Exists; + + + + + -- Names -- + + function At_Name + (This : in Pref_Group) + return String + is + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_name (This.Void_Ptr); + begin + if Text = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text); + end if; + end At_Name; + + + function At_Path + (This : in Pref_Group) + return String + is + Text : constant Interfaces.C.Strings.chars_ptr := fl_preferences_path (This.Void_Ptr); + begin + if Text = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text); + end if; + end At_Path; + + + + + -- Retrieval -- + + function Get + (This : in Pref_Group; + Key : in String) + return Integer + is + Value : Interfaces.C.int; + begin + if fl_preferences_get_int + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Value, 0) = 0 + then + raise Preference_Error; + end if; + return Integer (Value); + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Integer) + return Integer + is + Value, Ignore : Interfaces.C.int; + begin + Ignore := fl_preferences_get_int + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Value, + Interfaces.C.int (Default)); + return Integer (Value); + end Get; + + + function Get + (This : in Pref_Group; + Key : in String) + return Float + is + Value : Interfaces.C.C_float; + begin + if fl_preferences_get_float + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Value, 0.0) = 0 + then + raise Preference_Error; + end if; + return Float (Value); + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Float) + return Float + is + Value : Interfaces.C.C_float; + Ignore : Interfaces.C.int; + begin + Ignore := fl_preferences_get_float + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Value, + Interfaces.C.C_float (Default)); + return Float (Value); + end Get; + + + function Get + (This : in Pref_Group; + Key : in String) + return Long_Float + is + Value : Interfaces.C.double; + begin + if fl_preferences_get_double + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Value, 0.0) = 0 + then + raise Preference_Error; + end if; + return Long_Float (Value); + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Long_Float) + return Long_Float + is + Value : Interfaces.C.double; + Ignore : Interfaces.C.int; + begin + Ignore := fl_preferences_get_double + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Value, + Interfaces.C.double (Default)); + return Long_Float (Value); + end Get; + + + function Get + (This : in Pref_Group; + Key : in String) + return String + is + Text : Interfaces.C.Strings.chars_ptr; + Check : constant Interfaces.C.int := fl_preferences_get_str + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Text, + Interfaces.C.To_C ("default")); + begin + if Check = 0 then + raise Preference_Error; + end if; + if Text = Interfaces.C.Strings.Null_Ptr then + return ""; + end if; + return Str : constant String := Interfaces.C.Strings.Value (Text) do + Interfaces.C.Strings.Free (Text); + end return; + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in String) + return String + is + Text : Interfaces.C.Strings.chars_ptr; + Ignore : Interfaces.C.int := fl_preferences_get_str + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Text, + Interfaces.C.To_C (Default)); + begin + if Text = Interfaces.C.Strings.Null_Ptr then + return Default; + end if; + return Str : constant String := Interfaces.C.Strings.Value (Text) do + Interfaces.C.Strings.Free (Text); + end return; + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in String; + Max_Length : in Natural) + return String + is + Text : Interfaces.C.char_array := (1 .. Interfaces.C.size_t (Max_Length + 1) => ' '); + Check : constant Interfaces.C.int := fl_preferences_get_str_limit + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Text, + Interfaces.C.To_C (Default), + Interfaces.C.int (Max_Length)); + begin + if Check = 0 then + return Default; + else + return Interfaces.C.To_Ada (Text); + end if; + end Get; + + + function Get + (This : in Pref_Group; + Key : in String) + return Binary_Data + is + Thing : Storage.Integer_Address; + Dummy : Interfaces.C.int := 42; + Check : constant Interfaces.C.int := fl_preferences_get_void + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Thing, + Storage.To_Integer (Dummy'Address), + 1); + begin + if Check = 0 then + free_fl_preferences_void_data (Thing); + raise Preference_Error; + end if; + declare + Length : constant Natural := This.Value_Size (Key) * Natural (c_pointer_size); + Actual : Binary_Data (1 .. Length); + for Actual'Address use Storage.To_Address (Thing); + pragma Import (Ada, Actual); + begin + return Result : constant Binary_Data := Actual do + free_fl_preferences_void_data (Thing); + end return; + end; + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Binary_Data) + return Binary_Data + is + Thing : Storage.Integer_Address; + Ignore : Interfaces.C.int := fl_preferences_get_void + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Thing, + Storage.To_Integer (Default'Address), + Default'Length / Interfaces.C.int (c_pointer_size)); + Length : constant Natural := This.Value_Size (Key) * Natural (c_pointer_size); + Actual : Binary_Data (1 .. Length); + for Actual'Address use Storage.To_Address (Thing); + pragma Import (Ada, Actual); + begin + return Result : constant Binary_Data := Actual do + free_fl_preferences_void_data (Thing); + end return; + end Get; + + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Binary_Data; + Max_Length : in Natural) + return Binary_Data + is + Actual : Binary_Data (1 .. Max_Length); + Ignore : Interfaces.C.int := fl_preferences_get_void_limit + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Storage.To_Integer (Actual'Address), + Storage.To_Integer (Default'Address), + Default'Length / Interfaces.C.int (c_pointer_size), + Interfaces.C.int (Max_Length) / Interfaces.C.int (c_pointer_size)); + Length : constant Natural := This.Value_Size (Key) * Natural (c_pointer_size); + begin + return Actual (1 .. Length); + end Get; + + + + + -- Storage -- + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Integer) is + begin + if fl_preferences_set_int + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Interfaces.C.int (Value)) = 0 + then + raise Preference_Error; + end if; + end Set; + + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Float) is + begin + if fl_preferences_set_float + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Interfaces.C.C_float (Value)) = 0 + then + raise Preference_Error; + end if; + end Set; + + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Float; + Precision : in Natural) is + begin + if fl_preferences_set_float_prec + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Interfaces.C.C_float (Value), + Interfaces.C.int (Precision)) = 0 + then + raise Preference_Error; + end if; + end Set; + + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Long_Float) is + begin + if fl_preferences_set_double + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Interfaces.C.double (Value)) = 0 + then + raise Preference_Error; + end if; + end Set; + + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Long_Float; + Precision : in Natural) is + begin + if fl_preferences_set_double_prec + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Interfaces.C.double (Value), + Interfaces.C.int (Precision)) = 0 + then + raise Preference_Error; + end if; + end Set; + + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in String) is + begin + if fl_preferences_set_str + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Interfaces.C.To_C (Value)) = 0 + then + raise Preference_Error; + end if; + end Set; + + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Binary_Data) is + begin + if fl_preferences_set_void + (This.Void_Ptr, + Interfaces.C.To_C (Key), + Storage.To_Integer (Value'Address), + Value'Length / Interfaces.C.int (c_pointer_size)) = 0 + then + raise Preference_Error; + end if; + end Set; + + +end FLTK.Environment; + + diff --git a/body/fltk-errors.adb b/body/fltk-errors.adb new file mode 100644 index 0000000..32cf2d5 --- /dev/null +++ b/body/fltk-errors.adb @@ -0,0 +1,113 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + + +package body FLTK.Errors is + + + ------------------------ + -- Functions From C -- + ------------------------ + + procedure fl_error_default_warning + (M : in Interfaces.C.char_array); + pragma Import (C, fl_error_default_warning, "fl_error_default_warning"); + pragma Inline (fl_error_default_warning); + + procedure fl_error_default_error + (M : in Interfaces.C.char_array); + pragma Import (C, fl_error_default_error, "fl_error_default_error"); + pragma Inline (fl_error_default_error); + + procedure fl_error_default_fatal + (M : in Interfaces.C.char_array); + pragma Import (C, fl_error_default_fatal, "fl_error_default_fatal"); + pragma Inline (fl_error_default_fatal); + + procedure fl_error_set_hooks; + pragma Import (C, fl_error_set_hooks, "fl_error_set_hooks"); + pragma Inline (fl_error_set_hooks); + + + + + ------------- + -- Hooks -- + ------------- + + procedure Warning_Hook + (C_Mess : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, Warning_Hook, "error_warning_hook"); + + procedure Warning_Hook + (C_Mess : in Interfaces.C.Strings.chars_ptr) is + begin + Current_Warning (Interfaces.C.Strings.Value (C_Mess)); + end Warning_Hook; + + + procedure Error_Hook + (C_Mess : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, Error_Hook, "error_error_hook"); + + procedure Error_Hook + (C_Mess : in Interfaces.C.Strings.chars_ptr) is + begin + Current_Error (Interfaces.C.Strings.Value (C_Mess)); + end Error_Hook; + + + procedure Fatal_Hook + (C_Mess : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, Fatal_Hook, "error_fatal_hook"); + + procedure Fatal_Hook + (C_Mess : in Interfaces.C.Strings.chars_ptr) is + begin + Current_Fatal (Interfaces.C.Strings.Value (C_Mess)); + end Fatal_Hook; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + procedure Default_Warning + (Message : in String) is + begin + fl_error_default_warning (Interfaces.C.To_C (Message)); + end Default_Warning; + + + procedure Default_Error + (Message : in String) is + begin + fl_error_default_error (Interfaces.C.To_C (Message)); + end Default_Error; + + + procedure Default_Fatal + (Message : in String) is + begin + fl_error_default_fatal (Interfaces.C.To_C (Message)); + end Default_Fatal; + + +begin + + + fl_error_set_hooks; + + +end FLTK.Errors; + + diff --git a/body/fltk-events.adb b/body/fltk-events.adb new file mode 100644 index 0000000..7a5932f --- /dev/null +++ b/body/fltk-events.adb @@ -0,0 +1,1090 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Containers.Vectors, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Events is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_button1 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.int; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_left_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_left_mouse, "fl_enum_left_mouse"); + + fl_enum_middle_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_middle_mouse, "fl_enum_middle_mouse"); + + fl_enum_right_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_right_mouse, "fl_enum_right_mouse"); + + fl_enum_back_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_back_mouse, "fl_enum_back_mouse"); + + fl_enum_forward_mouse : constant Interfaces.C.int; + pragma Import (C, fl_enum_forward_mouse, "fl_enum_forward_mouse"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Handlers -- + + procedure fl_event_add_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); + pragma Inline (fl_event_add_handler); + + procedure fl_event_remove_handler + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_remove_handler, "fl_event_remove_handler"); + pragma Inline (fl_event_remove_handler); + + procedure fl_event_add_system_handler + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_event_add_system_handler, "fl_event_add_system_handler"); + pragma Inline (fl_event_add_system_handler); + + procedure fl_event_remove_system_handler + (H : in Storage.Integer_Address); + pragma Import (C, fl_event_remove_system_handler, "fl_event_remove_system_handler"); + pragma Inline (fl_event_remove_system_handler); + + + + + -- Dispatch -- + + procedure fl_event_set_dispatch + (F : in Storage.Integer_Address); + pragma Import (C, fl_event_set_dispatch, "fl_event_set_dispatch"); + pragma Inline (fl_event_set_dispatch); + + function fl_event_handle_dispatch + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle_dispatch, "fl_event_handle_dispatch"); + pragma Inline (fl_event_handle_dispatch); + + function fl_event_handle + (E : in Interfaces.C.int; + W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_handle, "fl_event_handle"); + pragma Inline (fl_event_handle); + + + + + -- Receiving -- + + function fl_event_get_grab + return Storage.Integer_Address; + pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); + pragma Inline (fl_event_get_grab); + + procedure fl_event_set_grab + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); + pragma Inline (fl_event_set_grab); + + function fl_event_get_pushed + return Storage.Integer_Address; + pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); + pragma Inline (fl_event_get_pushed); + + procedure fl_event_set_pushed + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); + pragma Inline (fl_event_set_pushed); + + function fl_event_get_belowmouse + return Storage.Integer_Address; + pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); + pragma Inline (fl_event_get_belowmouse); + + procedure fl_event_set_belowmouse + (T : in Storage.Integer_Address); + pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); + pragma Inline (fl_event_set_belowmouse); + + function fl_event_get_focus + return Storage.Integer_Address; + pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); + pragma Inline (fl_event_get_focus); + + procedure fl_event_set_focus + (To : in Storage.Integer_Address); + pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); + pragma Inline (fl_event_set_focus); + + function fl_event_get_visible_focus + return Interfaces.C.int; + pragma Import (C, fl_event_get_visible_focus, "fl_event_get_visible_focus"); + pragma Inline (fl_event_get_visible_focus); + + procedure fl_event_set_visible_focus + (T : in Interfaces.C.int); + pragma Import (C, fl_event_set_visible_focus, "fl_event_set_visible_focus"); + pragma Inline (fl_event_set_visible_focus); + + + + + -- Clipboard -- + + function fl_event_clipboard_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_text, "fl_event_clipboard_text"); + pragma Inline (fl_event_clipboard_text); + + function fl_event_clipboard_type + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_clipboard_type, "fl_event_clipboard_type"); + pragma Inline (fl_event_clipboard_type); + + + + + -- Multikey -- + + function fl_event_compose + (D : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_compose, "fl_event_compose"); + pragma Inline (fl_event_compose); + + function fl_event_text + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_event_text, "fl_event_text"); + pragma Inline (fl_event_text); + + function fl_event_length + return Interfaces.C.int; + pragma Import (C, fl_event_length, "fl_event_length"); + pragma Inline (fl_event_length); + + function fl_event_test_shortcut + (S : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_event_test_shortcut, "fl_event_test_shortcut"); + pragma Inline (fl_event_test_shortcut); + + + + + -- Modifiers -- + + function fl_event_get + return Interfaces.C.int; + pragma Import (C, fl_event_get, "fl_event_get"); + pragma Inline (fl_event_get); + + function fl_event_state + return Interfaces.C.int; + pragma Import (C, fl_event_state, "fl_event_state"); + pragma Inline (fl_event_state); + + function fl_event_check_state + (S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_check_state, "fl_event_check_state"); + pragma Inline (fl_event_check_state); + + + + + -- Mouse -- + + function fl_event_x + return Interfaces.C.int; + pragma Import (C, fl_event_x, "fl_event_x"); + pragma Inline (fl_event_x); + + function fl_event_x_root + return Interfaces.C.int; + pragma Import (C, fl_event_x_root, "fl_event_x_root"); + pragma Inline (fl_event_x_root); + + function fl_event_y + return Interfaces.C.int; + pragma Import (C, fl_event_y, "fl_event_y"); + pragma Inline (fl_event_y); + + function fl_event_y_root + return Interfaces.C.int; + pragma Import (C, fl_event_y_root, "fl_event_y_root"); + pragma Inline (fl_event_y_root); + + function fl_event_dx + return Interfaces.C.int; + pragma Import (C, fl_event_dx, "fl_event_dx"); + pragma Inline (fl_event_dx); + + function fl_event_dy + return Interfaces.C.int; + pragma Import (C, fl_event_dy, "fl_event_dy"); + pragma Inline (fl_event_dy); + + procedure fl_event_get_mouse + (X, Y : out Interfaces.C.int); + pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); + pragma Inline (fl_event_get_mouse); + + function fl_event_is_click + return Interfaces.C.int; + pragma Import (C, fl_event_is_click, "fl_event_is_click"); + pragma Inline (fl_event_is_click); + + procedure fl_event_set_click + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_click, "fl_event_set_click"); + pragma Inline (fl_event_set_click); + + function fl_event_get_clicks + return Interfaces.C.int; + pragma Import (C, fl_event_get_clicks, "fl_event_get_clicks"); + pragma Inline (fl_event_get_clicks); + + procedure fl_event_set_clicks + (C : in Interfaces.C.int); + pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); + pragma Inline (fl_event_set_clicks); + + function fl_event_button + return Interfaces.C.int; + pragma Import (C, fl_event_button, "fl_event_button"); + pragma Inline (fl_event_button); + + function fl_event_button1 + return Interfaces.C.int; + pragma Import (C, fl_event_button1, "fl_event_button1"); + pragma Inline (fl_event_button1); + + function fl_event_button2 + return Interfaces.C.int; + pragma Import (C, fl_event_button2, "fl_event_button2"); + pragma Inline (fl_event_button2); + + function fl_event_button3 + return Interfaces.C.int; + pragma Import (C, fl_event_button3, "fl_event_button3"); + pragma Inline (fl_event_button3); + + function fl_event_button4 + return Interfaces.C.int; + pragma Import (C, fl_event_button4, "fl_event_button4"); + pragma Inline (fl_event_button4); + + function fl_event_button5 + return Interfaces.C.int; + pragma Import (C, fl_event_button5, "fl_event_button5"); + pragma Inline (fl_event_button5); + + function fl_event_buttons + return Interfaces.C.int; + pragma Import (C, fl_event_buttons, "fl_event_buttons"); + pragma Inline (fl_event_buttons); + + function fl_event_inside2 + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_event_inside2, "fl_event_inside2"); + pragma Inline (fl_event_inside2); + + function fl_event_inside + (X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_inside, "fl_event_inside"); + pragma Inline (fl_event_inside); + + + + + -- Keyboard -- + + function fl_event_key + return Interfaces.C.int; + pragma Import (C, fl_event_key, "fl_event_key"); + pragma Inline (fl_event_key); + + function fl_event_original_key + return Interfaces.C.int; + pragma Import (C, fl_event_original_key, "fl_event_original_key"); + pragma Inline (fl_event_original_key); + + function fl_event_key_during + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_key_during, "fl_event_key_during"); + pragma Inline (fl_event_key_during); + + function fl_event_get_key + (K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_event_get_key, "fl_event_get_key"); + pragma Inline (fl_event_get_key); + + function fl_event_ctrl + return Interfaces.C.int; + pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); + pragma Inline (fl_event_ctrl); + + function fl_event_alt + return Interfaces.C.int; + pragma Import (C, fl_event_alt, "fl_event_alt"); + pragma Inline (fl_event_alt); + + function fl_event_command + return Interfaces.C.int; + pragma Import (C, fl_event_command, "fl_event_command"); + pragma Inline (fl_event_command); + + function fl_event_shift + return Interfaces.C.int; + pragma Import (C, fl_event_shift, "fl_event_shift"); + pragma Inline (fl_event_shift); + + + + + ------------- + -- Hooks -- + ------------- + + -- This is handled on the Ada side since otherwise marshalling the + -- types from C++ to Ada would be extremely difficult. This hook is + -- passed during package init. + package Handler_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Event_Handler); + + Handlers : Handler_Vectors.Vector; + + function Event_Handler_Hook + (Num : in Interfaces.C.int) + return Interfaces.C.int; + pragma Convention (C, Event_Handler_Hook); + + function Event_Handler_Hook + (Num : in Interfaces.C.int) + return Interfaces.C.int is + begin + for Call of reverse Handlers loop + if Call (Event_Kind'Val (Num)) /= Not_Handled then + return Event_Outcome'Pos (Handled); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Event_Handler hook received unexpected event int value of " & + Interfaces.C.int'Image (Num); + end Event_Handler_Hook; + + + -- This is handled on the Ada side because otherwise there would be + -- no way to specify which callback to remove in FLTK once one was + -- added. This is because Fl::remove_system_handler does not pay + -- attention to the void * data. This hook is passed during package init. + package System_Handler_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => System_Handler); + + System_Handlers : System_Handler_Vectors.Vector; + + function System_Handler_Hook + (E, U : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Convention (C, System_Handler_Hook); + + function System_Handler_Hook + (E, U : in Storage.Integer_Address) + return Interfaces.C.int is + begin + for Call of reverse System_Handlers loop + if Call (System_Event (Storage.To_Address (E))) = Handled then + return Event_Outcome'Pos (Handled); + end if; + end loop; + return Event_Outcome'Pos (Not_Handled); + end System_Handler_Hook; + + + function Dispatch_Hook + (Num : in Interfaces.C.int; + Ptr : in Storage.Integer_Address) + return Interfaces.C.int + is + Ada_Ptr : Storage.Integer_Address; + Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Ptr /= Null_Pointer then + Ada_Ptr := fl_widget_get_user_data (Ptr); + pragma Assert (Ada_Ptr /= Null_Pointer); + Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); + end if; + return Event_Outcome'Pos (Current_Dispatch (Event_Kind'Val (Num), Actual_Window)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Window passed to Event_Dispatch hook did not have user_data pointer back to Ada"; + when Constraint_Error => raise Internal_FLTK_Error with + "Event_Dispatch hook received unexpected event int value of " & + Interfaces.C.int'Image (Num); + end Dispatch_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out FLTK_Events_Final_Controller) is + begin + fl_event_remove_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + fl_event_remove_system_handler (Storage.To_Integer (System_Handler_Hook'Address)); + end Finalize; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Handlers -- + + procedure Add_Handler + (Func : in not null Event_Handler) is + begin + Handlers.Append (Func); + end Add_Handler; + + + procedure Remove_Handler + (Func : in not null Event_Handler) is + begin + for I in reverse Handlers.First_Index .. Handlers.Last_Index loop + if Handlers (I) = Func then + Handlers.Delete (I); + return; + end if; + end loop; + end Remove_Handler; + + + procedure Add_System_Handler + (Func : in not null System_Handler) is + begin + System_Handlers.Append (Func); + end Add_System_Handler; + + + procedure Remove_System_Handler + (Func : in not null System_Handler) is + begin + for I in reverse System_Handlers.First_Index .. System_Handlers.Last_Index loop + if System_Handlers (I) = Func then + System_Handlers.Delete (I); + return; + end if; + end loop; + end Remove_System_Handler; + + + + + -- Dispatch -- + + function Get_Dispatch + return Event_Dispatch is + begin + return Current_Dispatch; + end Get_Dispatch; + + + procedure Set_Dispatch + (Func : in Event_Dispatch) is + begin + Current_Dispatch := Func; + if Current_Dispatch /= null then + fl_event_set_dispatch (Storage.To_Integer (Dispatch_Hook'Address)); + else + fl_event_set_dispatch (Null_Pointer); + end if; + end Set_Dispatch; + + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_event_handle_dispatch + (Event_Kind'Pos (Event), + Wrapper (Origin).Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::handle returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Handle_Dispatch; + + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_event_handle + (Event_Kind'Pos (Event), + Wrapper (Origin).Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::handle_ returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Handle; + + + + + -- Receiving -- + + function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Grab_Ptr : Storage.Integer_Address := fl_event_get_grab; + Actual_Grab : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Grab_Ptr /= Null_Pointer then + Grab_Ptr := fl_widget_get_user_data (Grab_Ptr); + pragma Assert (Grab_Ptr /= Null_Pointer); + Actual_Grab := Window_Convert.To_Pointer (Storage.To_Address (Grab_Ptr)); + end if; + return Actual_Grab; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::grab did not have user_data reference back to Ada"; + end Get_Grab; + + + procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class) is + begin + fl_event_set_grab (Wrapper (To).Void_Ptr); + end Set_Grab; + + + procedure Release_Grab is + begin + fl_event_set_grab (Null_Pointer); + end Release_Grab; + + + function Get_Pushed + return access FLTK.Widgets.Widget'Class + is + Pushed_Ptr : Storage.Integer_Address := fl_event_get_pushed; + Actual_Pushed : access FLTK.Widgets.Widget'Class; + begin + if Pushed_Ptr /= Null_Pointer then + Pushed_Ptr := fl_widget_get_user_data (Pushed_Ptr); + pragma Assert (Pushed_Ptr /= Null_Pointer); + Actual_Pushed := Widget_Convert.To_Pointer (Storage.To_Address (Pushed_Ptr)); + end if; + return Actual_Pushed; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::pushed did not have user_data reference back to Ada"; + end Get_Pushed; + + + procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_pushed (Wrapper (To).Void_Ptr); + end Set_Pushed; + + + function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class + is + Below_Ptr : Storage.Integer_Address := fl_event_get_belowmouse; + Actual_Below : access FLTK.Widgets.Widget'Class; + begin + if Below_Ptr /= Null_Pointer then + Below_Ptr := fl_widget_get_user_data (Below_Ptr); + pragma Assert (Below_Ptr /= Null_Pointer); + Actual_Below := Widget_Convert.To_Pointer (Storage.To_Address (Below_Ptr)); + end if; + return Actual_Below; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::belowmouse did not have user_data reference back to Ada"; + end Get_Below_Mouse; + + + procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_belowmouse (Wrapper (To).Void_Ptr); + end Set_Below_Mouse; + + + function Get_Focus + return access FLTK.Widgets.Widget'Class + is + Focus_Ptr : Storage.Integer_Address := fl_event_get_focus; + Actual_Focus : access FLTK.Widgets.Widget'Class; + begin + if Focus_Ptr /= Null_Pointer then + Focus_Ptr := fl_widget_get_user_data (Focus_Ptr); + pragma Assert (Focus_Ptr /= Null_Pointer); + Actual_Focus := Widget_Convert.To_Pointer (Storage.To_Address (Focus_Ptr)); + end if; + return Actual_Focus; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::focus did not have user_data reference back to Ada"; + end Get_Focus; + + + procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_event_set_focus (Wrapper (To).Void_Ptr); + end Set_Focus; + + + function Has_Visible_Focus + return Boolean is + begin + return fl_event_get_visible_focus /= 0; + end Has_Visible_Focus; + + + procedure Set_Visible_Focus + (To : in Boolean) is + begin + fl_event_set_visible_focus (Boolean'Pos (To)); + end Set_Visible_Focus; + + + + + -- Clipboard -- + + function Clipboard_Text + return String + is + Text_Ptr : constant Interfaces.C.Strings.chars_ptr := fl_event_clipboard_text; + begin + if Text_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text_Ptr); + end if; + end Clipboard_Text; + + + function Clipboard_Kind + return String + is + Text_Ptr : constant Interfaces.C.Strings.chars_ptr := fl_event_clipboard_type; + begin + if Text_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text_Ptr); + end if; + end Clipboard_Kind; + + + + + -- Multikey -- + + function Compose + (Del : out Natural) + return Boolean is + begin + return fl_event_compose (Interfaces.C.int (Del)) /= 0; + end Compose; + + + function Text + return String + is + Str : constant Interfaces.C.Strings.chars_ptr := fl_event_text; + begin + if Str = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); + end if; + end Text; + + + function Text_Length + return Natural is + begin + return Natural (fl_event_length); + end Text_Length; + + + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean is + begin + return fl_event_test_shortcut (To_C (Shortcut)) /= 0; + end Test_Shortcut; + + + + + -- Modifiers -- + + function Last + return Event_Kind + is + Value : constant Interfaces.C.int := fl_event_get; + begin + return Event_Kind'Val (Value); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event returned unexpected int value of " & Interfaces.C.int'Image (Value); + end Last; + + + function Last_Modifier + return Modifier is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_state)); + end Last_Modifier; + + + function Last_Modifier + (Had : in Modifier) + return Boolean is + begin + return fl_event_check_state (Interfaces.C.int (To_C (Had))) /= 0; + end Last_Modifier; + + + + + -- Mouse -- + + function Mouse_X + return Integer is + begin + return Integer (fl_event_x); + end Mouse_X; + + + function Mouse_X_Root + return Integer is + begin + return Integer (fl_event_x_root); + end Mouse_X_Root; + + + function Mouse_Y + return Integer is + begin + return Integer (fl_event_y); + end Mouse_Y; + + + function Mouse_Y_Root + return Integer is + begin + return Integer (fl_event_y_root); + end Mouse_Y_Root; + + + + function Mouse_DX + return Integer is + begin + return Integer (fl_event_dx); + end Mouse_DX; + + + function Mouse_DY + return Integer is + begin + return Integer (fl_event_dy); + end Mouse_DY; + + + procedure Get_Mouse + (X, Y : out Integer) is + begin + fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Mouse; + + + function Is_Click + return Boolean is + begin + return fl_event_is_click /= 0; + end Is_Click; + + + procedure Clear_Click is + begin + fl_event_set_click (0); + end Clear_Click; + + + function Is_Multi_Click + return Boolean is + begin + return fl_event_get_clicks /= 0; + end Is_Multi_Click; + + + function Get_Clicks + return Natural + is + Raw : constant Interfaces.C.int := fl_event_get_clicks; + begin + if Is_Click then + return Positive (Raw + 1); + else + return 0; + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event_clicks returned unexpected int value of " & + Interfaces.C.int'Image (Raw); + end Get_Clicks; + + + procedure Set_Clicks + (To : in Natural) is + begin + if To = 0 then + fl_event_set_clicks (0); + Clear_Click; + elsif To = 1 then + fl_event_set_clicks (0); + else + fl_event_set_clicks (Interfaces.C.int (To) - 1); + end if; + end Set_Clicks; + + + function Last_Button + return Mouse_Button + is + Code : constant Interfaces.C.int := fl_event_button; + begin + pragma Assert (Last = Push or Last = Release); + if Code = fl_enum_left_mouse then + return Left_Button; + elsif Code = fl_enum_middle_mouse then + return Middle_Button; + elsif Code = fl_enum_right_mouse then + return Right_Button; + elsif Code = fl_enum_back_mouse then + return Back_Button; + elsif Code = fl_enum_forward_mouse then + return Forward_Button; + else + raise Internal_FLTK_Error with "Fl::event_button returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::event_button was called when the most recent event was not Push or Release"; + end Last_Button; + + + function Mouse_Left + return Boolean is + begin + return fl_event_button1 /= 0; + end Mouse_Left; + + + function Mouse_Middle + return Boolean is + begin + return fl_event_button2 /= 0; + end Mouse_Middle; + + + function Mouse_Right + return Boolean is + begin + return fl_event_button3 /= 0; + end Mouse_Right; + + + function Mouse_Back + return Boolean is + begin + return fl_event_button4 /= 0; + end Mouse_Back; + + + function Mouse_Forward + return Boolean is + begin + return fl_event_button5 /= 0; + end Mouse_Forward; + + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean) + is + type Cint_Mod is mod 2 ** Interfaces.C.int'Size; + Mask : constant Interfaces.C.int := fl_event_buttons; + begin + Left := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button1)) /= 0; + Middle := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button2)) /= 0; + Right := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button3)) /= 0; + Back := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button4)) /= 0; + Forward := (Cint_Mod (Mask) and Cint_Mod (fl_enum_button5)) /= 0; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::event_buttons returned unexpected int value of " & + Interfaces.C.int'Image (Mask); + end Mouse_Buttons; + + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean is + begin + return fl_event_inside2 (Wrapper (Child).Void_Ptr) /= 0; + end Is_Inside; + + + function Is_Inside + (X, Y, W, H : in Integer) + return Boolean is + begin + return fl_event_inside + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)) /= 0; + end Is_Inside; + + + + + -- Keyboard -- + + function Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_key)); + end Last_Key; + + + function Original_Last_Key + return Keypress is + begin + return To_Ada (Interfaces.C.unsigned (fl_event_original_key)); + end Original_Last_Key; + + + function Pressed_During + (Key : in Keypress) + return Boolean is + begin + return fl_event_key_during (Interfaces.C.int (To_C (Key))) /= 0; + end Pressed_During; + + + function Key_Now + (Key : in Keypress) + return Boolean is + begin + return fl_event_get_key (Interfaces.C.int (To_C (Key))) /= 0; + end Key_Now; + + + function Key_Ctrl + return Boolean is + begin + return fl_event_ctrl /= 0; + end Key_Ctrl; + + + function Key_Alt + return Boolean is + begin + return fl_event_alt /= 0; + end Key_Alt; + + + function Key_Command + return Boolean is + begin + return fl_event_command /= 0; + end Key_Command; + + + function Key_Shift + return Boolean is + begin + return fl_event_shift /= 0; + end Key_Shift; + + +begin + + + fl_event_add_handler (Storage.To_Integer (Event_Handler_Hook'Address)); + fl_event_add_system_handler (Storage.To_Integer (System_Handler_Hook'Address), Null_Pointer); + + +end FLTK.Events; + + diff --git a/body/fltk-file_choosers.adb b/body/fltk-file_choosers.adb new file mode 100644 index 0000000..ef33753 --- /dev/null +++ b/body/fltk-file_choosers.adb @@ -0,0 +1,1326 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.File_Choosers is + + + package Chk renames Ada.Assertions; + + package File_Chooser_Convert is new System.Address_To_Access_Conversions (File_Chooser'Class); + package Widget_Convert is new System.Address_To_Access_Conversions (Widgets.Widget'Class); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- User Data -- + + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + pragma Inline (fl_widget_get_user_data); + + -- procedure fl_widget_set_user_data + -- (W, D : in Storage.Integer_Address); + -- pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); + -- pragma Inline (fl_widget_set_user_data); + + -- function fl_file_chooser_get_user_data + -- (F : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_file_chooser_get_user_data, "fl_file_chooser_get_user_data"); + -- pragma Inline (fl_file_chooser_get_user_data); + + procedure fl_file_chooser_set_user_data + (F, U : in Storage.Integer_Address); + pragma Import (C, fl_file_chooser_set_user_data, "fl_file_chooser_set_user_data"); + pragma Inline (fl_file_chooser_set_user_data); + + + + + -- Sorting -- + + procedure file_chooser_setup_sort_hook; + pragma Import (C, file_chooser_setup_sort_hook, "file_chooser_setup_sort_hook"); + pragma Inline (file_chooser_setup_sort_hook); + + + + + -- Allocation -- + + function new_fl_file_chooser + (N, P : in Interfaces.C.char_array; + K : in Interfaces.C.int; + T : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_file_chooser, "new_fl_file_chooser"); + pragma Inline (new_fl_file_chooser); + + procedure free_fl_file_chooser + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_file_chooser, "free_fl_file_chooser"); + pragma Inline (free_fl_file_chooser); + + + + + -- Buttons -- + + function fl_file_chooser_newbutton + (F : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_chooser_newbutton, "fl_file_chooser_newbutton"); + pragma Inline (fl_file_chooser_newbutton); + + function fl_file_chooser_previewbutton + (F : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_chooser_previewbutton, "fl_file_chooser_previewbutton"); + pragma Inline (fl_file_chooser_previewbutton); + + function fl_file_chooser_showhiddenbutton + (F : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_chooser_showhiddenbutton, "fl_file_chooser_showhiddenbutton"); + pragma Inline (fl_file_chooser_showhiddenbutton); + + + + + -- Static Labels -- + + function fl_file_chooser_get_add_favorites_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_add_favorites_label, + "fl_file_chooser_get_add_favorites_label"); + pragma Inline (fl_file_chooser_get_add_favorites_label); + + procedure fl_file_chooser_set_add_favorites_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_add_favorites_label, + "fl_file_chooser_set_add_favorites_label"); + pragma Inline (fl_file_chooser_set_add_favorites_label); + + function fl_file_chooser_get_all_files_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_all_files_label, "fl_file_chooser_get_all_files_label"); + pragma Inline (fl_file_chooser_get_all_files_label); + + procedure fl_file_chooser_set_all_files_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_all_files_label, "fl_file_chooser_set_all_files_label"); + pragma Inline (fl_file_chooser_set_all_files_label); + + function fl_file_chooser_get_custom_filter_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_custom_filter_label, + "fl_file_chooser_get_custom_filter_label"); + pragma Inline (fl_file_chooser_get_custom_filter_label); + + procedure fl_file_chooser_set_custom_filter_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_custom_filter_label, + "fl_file_chooser_set_custom_filter_label"); + pragma Inline (fl_file_chooser_set_custom_filter_label); + + function fl_file_chooser_get_existing_file_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_existing_file_label, + "fl_file_chooser_get_existing_file_label"); + pragma Inline (fl_file_chooser_get_existing_file_label); + + procedure fl_file_chooser_set_existing_file_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_existing_file_label, + "fl_file_chooser_set_existing_file_label"); + pragma Inline (fl_file_chooser_set_existing_file_label); + + function fl_file_chooser_get_favorites_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_favorites_label, "fl_file_chooser_get_favorites_label"); + pragma Inline (fl_file_chooser_get_favorites_label); + + procedure fl_file_chooser_set_favorites_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_favorites_label, "fl_file_chooser_set_favorites_label"); + pragma Inline (fl_file_chooser_set_favorites_label); + + function fl_file_chooser_get_filename_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_filename_label, "fl_file_chooser_get_filename_label"); + pragma Inline (fl_file_chooser_get_filename_label); + + procedure fl_file_chooser_set_filename_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_filename_label, "fl_file_chooser_set_filename_label"); + pragma Inline (fl_file_chooser_set_filename_label); + + function fl_file_chooser_get_filesystems_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_filesystems_label, + "fl_file_chooser_get_filesystems_label"); + pragma Inline (fl_file_chooser_get_filesystems_label); + + procedure fl_file_chooser_set_filesystems_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_filesystems_label, + "fl_file_chooser_set_filesystems_label"); + pragma Inline (fl_file_chooser_set_filesystems_label); + + function fl_file_chooser_get_hidden_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_hidden_label, "fl_file_chooser_get_hidden_label"); + pragma Inline (fl_file_chooser_get_hidden_label); + + procedure fl_file_chooser_set_hidden_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_hidden_label, "fl_file_chooser_set_hidden_label"); + pragma Inline (fl_file_chooser_set_hidden_label); + + function fl_file_chooser_get_manage_favorites_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_manage_favorites_label, + "fl_file_chooser_get_manage_favorites_label"); + pragma Inline (fl_file_chooser_get_manage_favorites_label); + + procedure fl_file_chooser_set_manage_favorites_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_manage_favorites_label, + "fl_file_chooser_set_manage_favorites_label"); + pragma Inline (fl_file_chooser_set_manage_favorites_label); + + function fl_file_chooser_get_new_directory_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_new_directory_label, + "fl_file_chooser_get_new_directory_label"); + pragma Inline (fl_file_chooser_get_new_directory_label); + + procedure fl_file_chooser_set_new_directory_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_new_directory_label, + "fl_file_chooser_set_new_directory_label"); + pragma Inline (fl_file_chooser_set_new_directory_label); + + function fl_file_chooser_get_new_directory_tooltip + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_new_directory_tooltip, + "fl_file_chooser_get_new_directory_tooltip"); + pragma Inline (fl_file_chooser_get_new_directory_tooltip); + + procedure fl_file_chooser_set_new_directory_tooltip + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_new_directory_tooltip, + "fl_file_chooser_set_new_directory_tooltip"); + pragma Inline (fl_file_chooser_set_new_directory_tooltip); + + function fl_file_chooser_get_preview_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_preview_label, "fl_file_chooser_get_preview_label"); + pragma Inline (fl_file_chooser_get_preview_label); + + procedure fl_file_chooser_set_preview_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_preview_label, "fl_file_chooser_set_preview_label"); + pragma Inline (fl_file_chooser_set_preview_label); + + function fl_file_chooser_get_save_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_save_label, "fl_file_chooser_get_save_label"); + pragma Inline (fl_file_chooser_get_save_label); + + procedure fl_file_chooser_set_save_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_save_label, "fl_file_chooser_set_save_label"); + pragma Inline (fl_file_chooser_set_save_label); + + function fl_file_chooser_get_show_label + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_show_label, "fl_file_chooser_get_show_label"); + pragma Inline (fl_file_chooser_get_show_label); + + procedure fl_file_chooser_set_show_label + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_show_label, "fl_file_chooser_set_show_label"); + pragma Inline (fl_file_chooser_set_show_label); + + + + + -- Callback and Extra -- + + function fl_file_chooser_add_extra + (F, W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_chooser_add_extra, "fl_file_chooser_add_extra"); + pragma Inline (fl_file_chooser_add_extra); + + procedure fl_file_chooser_callback + (F, C, U : in Storage.Integer_Address); + pragma Import (C, fl_file_chooser_callback, "fl_file_chooser_callback"); + pragma Inline (fl_file_chooser_callback); + + + + + -- Settings -- + + function fl_file_chooser_get_color + (F : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_file_chooser_get_color, "fl_file_chooser_get_color"); + pragma Inline (fl_file_chooser_get_color); + + procedure fl_file_chooser_set_color + (F : in Storage.Integer_Address; + V : in Interfaces.C.unsigned); + pragma Import (C, fl_file_chooser_set_color, "fl_file_chooser_set_color"); + pragma Inline (fl_file_chooser_set_color); + + function fl_file_chooser_get_iconsize + (F : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_file_chooser_get_iconsize, "fl_file_chooser_get_iconsize"); + pragma Inline (fl_file_chooser_get_iconsize); + + procedure fl_file_chooser_set_iconsize + (F : in Storage.Integer_Address; + V : in Interfaces.C.unsigned_char); + pragma Import (C, fl_file_chooser_set_iconsize, "fl_file_chooser_set_iconsize"); + pragma Inline (fl_file_chooser_set_iconsize); + + function fl_file_chooser_get_label + (F : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_label, "fl_file_chooser_get_label"); + pragma Inline (fl_file_chooser_get_label); + + procedure fl_file_chooser_set_label + (F : in Storage.Integer_Address; + V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_label, "fl_file_chooser_set_label"); + pragma Inline (fl_file_chooser_set_label); + + function fl_file_chooser_get_ok_label + (F : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_ok_label, "fl_file_chooser_get_ok_label"); + pragma Inline (fl_file_chooser_get_ok_label); + + procedure fl_file_chooser_set_ok_label + (F : in Storage.Integer_Address; + V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_ok_label, "fl_file_chooser_set_ok_label"); + pragma Inline (fl_file_chooser_set_ok_label); + + function fl_file_chooser_get_preview + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_get_preview, "fl_file_chooser_get_preview"); + pragma Inline (fl_file_chooser_get_preview); + + procedure fl_file_chooser_set_preview + (F : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_file_chooser_set_preview, "fl_file_chooser_set_preview"); + pragma Inline (fl_file_chooser_set_preview); + + function fl_file_chooser_get_textcolor + (F : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_file_chooser_get_textcolor, "fl_file_chooser_get_textcolor"); + pragma Inline (fl_file_chooser_get_textcolor); + + procedure fl_file_chooser_set_textcolor + (F : in Storage.Integer_Address; + V : in Interfaces.C.unsigned); + pragma Import (C, fl_file_chooser_set_textcolor, "fl_file_chooser_set_textcolor"); + pragma Inline (fl_file_chooser_set_textcolor); + + function fl_file_chooser_get_textfont + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_get_textfont, "fl_file_chooser_get_textfont"); + pragma Inline (fl_file_chooser_get_textfont); + + procedure fl_file_chooser_set_textfont + (F : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_file_chooser_set_textfont, "fl_file_chooser_set_textfont"); + pragma Inline (fl_file_chooser_set_textfont); + + function fl_file_chooser_get_textsize + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_get_textsize, "fl_file_chooser_get_textsize"); + pragma Inline (fl_file_chooser_get_textsize); + + procedure fl_file_chooser_set_textsize + (F : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_file_chooser_set_textsize, "fl_file_chooser_set_textsize"); + pragma Inline (fl_file_chooser_set_textsize); + + function fl_file_chooser_get_type + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_get_type, "fl_file_chooser_get_type"); + pragma Inline (fl_file_chooser_get_type); + + procedure fl_file_chooser_set_type + (F : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_file_chooser_set_type, "fl_file_chooser_set_type"); + pragma Inline (fl_file_chooser_set_type); + + + + + -- File Selection -- + + function fl_file_chooser_count + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_count, "fl_file_chooser_count"); + pragma Inline (fl_file_chooser_count); + + function fl_file_chooser_get_directory + (F : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_directory, "fl_file_chooser_get_directory"); + pragma Inline (fl_file_chooser_get_directory); + + procedure fl_file_chooser_set_directory + (F : in Storage.Integer_Address; + V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_directory, "fl_file_chooser_set_directory"); + pragma Inline (fl_file_chooser_set_directory); + + function fl_file_chooser_get_filter + (F : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_filter, "fl_file_chooser_get_filter"); + pragma Inline (fl_file_chooser_get_filter); + + procedure fl_file_chooser_set_filter + (F : in Storage.Integer_Address; + V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_file_chooser_set_filter, "fl_file_chooser_set_filter"); + pragma Inline (fl_file_chooser_set_filter); + + function fl_file_chooser_get_filter_value + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_get_filter_value, "fl_file_chooser_get_filter_value"); + pragma Inline (fl_file_chooser_get_filter_value); + + procedure fl_file_chooser_set_filter_value + (F : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_file_chooser_set_filter_value, "fl_file_chooser_set_filter_value"); + pragma Inline (fl_file_chooser_set_filter_value); + + procedure fl_file_chooser_rescan + (F : in Storage.Integer_Address); + pragma Import (C, fl_file_chooser_rescan, "fl_file_chooser_rescan"); + pragma Inline (fl_file_chooser_rescan); + + procedure fl_file_chooser_rescan_keep_filename + (F : in Storage.Integer_Address); + pragma Import (C, fl_file_chooser_rescan_keep_filename, "fl_file_chooser_rescan_keep_filename"); + pragma Inline (fl_file_chooser_rescan_keep_filename); + + function fl_file_chooser_get_value + (F : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_chooser_get_value, "fl_file_chooser_get_value"); + pragma Inline (fl_file_chooser_get_value); + + procedure fl_file_chooser_set_value + (F : in Storage.Integer_Address; + V : in Interfaces.C.char_array); + pragma Import (C, fl_file_chooser_set_value, "fl_file_chooser_set_value"); + pragma Inline (fl_file_chooser_set_value); + + + + + -- Visibility -- + + procedure fl_file_chooser_show + (F : in Storage.Integer_Address); + pragma Import (C, fl_file_chooser_show, "fl_file_chooser_show"); + pragma Inline (fl_file_chooser_show); + + procedure fl_file_chooser_hide + (F : in Storage.Integer_Address); + pragma Import (C, fl_file_chooser_hide, "fl_file_chooser_hide"); + pragma Inline (fl_file_chooser_hide); + + function fl_file_chooser_shown + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_shown, "fl_file_chooser_shown"); + pragma Inline (fl_file_chooser_shown); + + function fl_file_chooser_visible + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_chooser_visible, "fl_file_chooser_visible"); + pragma Inline (fl_file_chooser_visible); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + function File_Chooser_Sort_Hook + (A, B : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + + pragma Export (C, File_Chooser_Sort_Hook, "file_chooser_sort_hook"); + + function File_Chooser_Sort_Hook + (A, B : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int is + begin + return Filenames.Comparison'Pos (Sort_Method + (Interfaces.C.Strings.Value (A), + Interfaces.C.Strings.Value (B))) - 1; + end File_Chooser_Sort_Hook; + + + procedure File_Chooser_Callback_Hook + (Ignore, User_Data : in Storage.Integer_Address); + pragma Convention (C, File_Chooser_Callback_Hook); + + procedure File_Chooser_Callback_Hook + (Ignore, User_Data : in Storage.Integer_Address) + is + Ada_Obj : constant access File_Chooser'Class := + File_Chooser_Convert.To_Pointer (Storage.To_Address (User_Data)); + begin + if Ada_Obj.My_Callback /= null then + Ada_Obj.My_Callback (Ada_Obj.all); + end if; + end File_Chooser_Callback_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out File_Chooser) + is + use Interfaces.C.Strings; + begin + Free (This.My_Label); + Free (This.My_OK_Label); + end Extra_Final; + + + procedure Finalize + (This : in out File_Chooser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_file_chooser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + procedure Finalize + (This : in out File_Chooser_Final_Controller) + is + use Interfaces.C.Strings; + begin + Free (Add_Favorites_Label); + Free (All_Files_Label); + Free (Custom_Filter_Label); + Free (Existing_File_Label); + Free (Favorites_Label); + Free (Filename_Label); + Free (Filesystems_Label); + Free (Hidden_Label); + Free (Manage_Favorites_Label); + Free (New_Directory_Label); + Free (New_Directory_Tooltip); + Free (Preview_Label); + Free (Save_Label); + Free (Show_Label); + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Bypassing border checkpoints + procedure fl_button_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_button_extra_init, "fl_button_extra_init"); + pragma Inline (fl_button_extra_init); + + + -- Refracting off language boundaries + procedure fl_check_button_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_check_button_extra_init, "fl_check_button_extra_init"); + pragma Inline (fl_check_button_extra_init); + + + procedure Extra_Init + (This : in out File_Chooser) is + begin + Wrapper (This.New_Butt).Void_Ptr := fl_file_chooser_newbutton (This.Void_Ptr); + Wrapper (This.New_Butt).Needs_Dealloc := False; + fl_button_extra_init + (Storage.To_Integer (This.New_Butt'Address), + Interfaces.C.int (This.New_Butt.Get_X), + Interfaces.C.int (This.New_Butt.Get_Y), + Interfaces.C.int (This.New_Butt.Get_W), + Interfaces.C.int (This.New_Butt.Get_H), + Interfaces.C.To_C (This.New_Butt.Get_Label)); + + Wrapper (This.Preview_Butt).Void_Ptr := fl_file_chooser_previewbutton (This.Void_Ptr); + Wrapper (This.Preview_Butt).Needs_Dealloc := False; + fl_check_button_extra_init + (Storage.To_Integer (This.Preview_Butt'Address), + Interfaces.C.int (This.Preview_Butt.Get_X), + Interfaces.C.int (This.Preview_Butt.Get_Y), + Interfaces.C.int (This.Preview_Butt.Get_W), + Interfaces.C.int (This.Preview_Butt.Get_H), + Interfaces.C.To_C (This.Preview_Butt.Get_Label)); + + Wrapper (This.Hidden_Butt).Void_Ptr := fl_file_chooser_showhiddenbutton (This.Void_Ptr); + Wrapper (This.Hidden_Butt).Needs_Dealloc := False; + fl_check_button_extra_init + (Storage.To_Integer (This.Hidden_Butt'Address), + Interfaces.C.int (This.Hidden_Butt.Get_X), + Interfaces.C.int (This.Hidden_Butt.Get_Y), + Interfaces.C.int (This.Hidden_Butt.Get_W), + Interfaces.C.int (This.Hidden_Butt.Get_H), + Interfaces.C.To_C (This.Hidden_Butt.Get_Label)); + + fl_file_chooser_set_user_data + (This.Void_Ptr, + Storage.To_Integer (This'Address)); + fl_file_chooser_callback + (This.Void_Ptr, + Storage.To_Integer (File_Chooser_Callback_Hook'Address), + Storage.To_Integer (This'Address)); + end Extra_Init; + + + package body Forge is + + function Create + (Title : in String; + Pattern : in String; + Pathname : in String; + Kind : in Chooser_Kind := Single) + return File_Chooser is + begin + return This : File_Chooser do + This.Void_Ptr := new_fl_file_chooser + (Interfaces.C.To_C (Pathname), + Interfaces.C.To_C (Pattern), + Chooser_Kind'Pos (Kind), + Interfaces.C.To_C (Title)); + Extra_Init (This); + end return; + end Create; + + end Forge; + + + + + ------------------ + -- Attributes -- + ------------------ + + -- Buttons -- + + function New_Button + (This : in out File_Chooser) + return FLTK.Widgets.Buttons.Button_Reference is + begin + return (Data => This.New_Butt'Unchecked_Access); + end New_Button; + + + function Preview_Button + (This : in out File_Chooser) + return FLTK.Widgets.Buttons.Light.Check.Check_Button_Reference is + begin + return (Data => This.Preview_Butt'Unchecked_Access); + end Preview_Button; + + + function Show_Hidden_Button + (This : in out File_Chooser) + return FLTK.Widgets.Buttons.Light.Check.Check_Button_Reference is + begin + return (Data => This.Hidden_Butt'Unchecked_Access); + end Show_Hidden_Button; + + + + + ------------------------- + -- Static Attributes -- + ------------------------- + + -- Static Labels -- + + function Get_Add_Favorites_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_add_favorites_label); + end Get_Add_Favorites_Label; + + + procedure Set_Add_Favorites_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Add_Favorites_Label); + Add_Favorites_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_add_favorites_label (Add_Favorites_Label); + end Set_Add_Favorites_Label; + + + function Get_All_Files_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_all_files_label); + end Get_All_Files_Label; + + + procedure Set_All_Files_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (All_Files_Label); + All_Files_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_all_files_label (All_Files_Label); + end Set_All_Files_Label; + + + function Get_Custom_Filter_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_custom_filter_label); + end Get_Custom_Filter_Label; + + + procedure Set_Custom_Filter_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Custom_Filter_Label); + Custom_Filter_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_custom_filter_label (Custom_Filter_Label); + end Set_Custom_Filter_Label; + + + function Get_Existing_File_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_existing_file_label); + end Get_Existing_File_Label; + + + procedure Set_Existing_File_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Existing_File_Label); + Existing_File_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_existing_file_label (Existing_File_Label); + end Set_Existing_File_Label; + + + function Get_Favorites_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_favorites_label); + end Get_Favorites_Label; + + + procedure Set_Favorites_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Favorites_Label); + Favorites_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_favorites_label (Favorites_Label); + end Set_Favorites_Label; + + + function Get_Filename_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_filename_label); + end Get_Filename_Label; + + + procedure Set_Filename_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Filename_Label); + Filename_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_filename_label (Filename_Label); + end Set_Filename_Label; + + + function Get_Filesystems_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_filesystems_label); + end Get_Filesystems_Label; + + + procedure Set_Filesystems_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Filesystems_Label); + Filesystems_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_filesystems_label (Filesystems_Label); + end Set_Filesystems_Label; + + + function Get_Hidden_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_hidden_label); + end Get_Hidden_Label; + + + procedure Set_Hidden_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Hidden_Label); + Hidden_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_hidden_label (Hidden_Label); + end Set_Hidden_Label; + + + function Get_Manage_Favorites_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_manage_favorites_label); + end Get_Manage_Favorites_Label; + + + procedure Set_Manage_Favorites_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Manage_Favorites_Label); + Manage_Favorites_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_manage_favorites_label (Manage_Favorites_Label); + end Set_Manage_Favorites_Label; + + + function Get_New_Directory_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_new_directory_label); + end Get_New_Directory_Label; + + + procedure Set_New_Directory_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (New_Directory_Label); + New_Directory_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_new_directory_label (New_Directory_Label); + end Set_New_Directory_Label; + + + function Get_New_Directory_Tooltip + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_new_directory_tooltip); + end Get_New_Directory_Tooltip; + + + procedure Set_New_Directory_Tooltip + (Value : in String) is + begin + Interfaces.C.Strings.Free (New_Directory_Tooltip); + New_Directory_Tooltip := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_new_directory_tooltip (New_Directory_Tooltip); + end Set_New_Directory_Tooltip; + + + function Get_Preview_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_preview_label); + end Get_Preview_Label; + + + procedure Set_Preview_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Preview_Label); + Preview_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_preview_label (Preview_Label); + end Set_Preview_Label; + + + function Get_Save_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_save_label); + end Get_Save_Label; + + + procedure Set_Save_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Save_Label); + Save_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_save_label (Save_Label); + end Set_Save_Label; + + + function Get_Show_Label + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_show_label); + end Get_Show_Label; + + procedure Set_Show_Label + (Value : in String) is + begin + Interfaces.C.Strings.Free (Show_Label); + Show_Label := Interfaces.C.Strings.New_String (Value); + fl_file_chooser_set_show_label (Show_Label); + end Set_Show_Label; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Callback and Extra -- + + procedure Add_Extra + (This : in out File_Chooser; + Item : in out Widgets.Widget'Class) + is + Ignore : Storage.Integer_Address := + fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); + begin + null; + end Add_Extra; + + + procedure Remove_Extra + (This : in out File_Chooser) + is + Ignore : Storage.Integer_Address := fl_file_chooser_add_extra (This.Void_Ptr, Null_Pointer); + begin + null; + end Remove_Extra; + + + function Eject_Extra + (This : in out File_Chooser; + Item : in out Widgets.Widget'Class) + return access Widgets.Widget'Class + is + C_Addr : Storage.Integer_Address := + fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); + Ada_Obj : access Widgets.Widget'Class; + begin + if C_Addr /= Null_Pointer then + C_Addr := fl_widget_get_user_data (C_Addr); + pragma Assert (C_Addr /= Null_Pointer); + Ada_Obj := Widget_Convert.To_Pointer (Storage.To_Address (C_Addr)); + end if; + return Ada_Obj; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::add_extra returned Widget with no user_data reference back to Ada"; + end Eject_Extra; + + + procedure Set_Callback + (This : in out File_Chooser; + Func : in Chooser_Callback) is + begin + This.My_Callback := Func; + end Set_Callback; + + + + + -- Settings -- + + function Get_Background_Color + (This : in File_Chooser) + return Color is + begin + return Color (fl_file_chooser_get_color (This.Void_Ptr)); + end Get_Background_Color; + + + procedure Set_Background_Color + (This : in out File_Chooser; + Value : in Color) is + begin + fl_file_chooser_set_color (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Background_Color; + + + function Get_Icon_Size + (This : in File_Chooser) + return Icon_Size is + begin + return Icon_Size (fl_file_chooser_get_iconsize (This.Void_Ptr)); + end Get_Icon_Size; + + + procedure Set_Icon_Size + (This : in out File_Chooser; + Value : in Icon_Size) is + begin + fl_file_chooser_set_iconsize (This.Void_Ptr, Interfaces.C.unsigned_char (Value)); + end Set_Icon_Size; + + + function Get_Label + (This : in File_Chooser) + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_label (This.Void_Ptr)); + end Get_Label; + + + procedure Set_Label + (This : in out File_Chooser; + Text : in String) is + begin + Interfaces.C.Strings.Free (This.My_Label); + This.My_Label := Interfaces.C.Strings.New_String (Text); + fl_file_chooser_set_label (This.Void_Ptr, This.My_Label); + end Set_Label; + + + function Get_OK_Label + (This : in File_Chooser) + return String is + begin + return Interfaces.C.Strings.Value (fl_file_chooser_get_ok_label (This.Void_Ptr)); + end Get_OK_Label; + + + procedure Set_OK_Label + (This : in out File_Chooser; + Text : in String) is + begin + Interfaces.C.Strings.Free (This.My_OK_Label); + This.My_OK_Label := Interfaces.C.Strings.New_String (Text); + fl_file_chooser_set_ok_label (This.Void_Ptr, This.My_OK_Label); + end Set_OK_Label; + + + function Has_Preview + (This : in File_Chooser) + return Boolean + is + Ret : constant Interfaces.C.int := fl_file_chooser_get_preview (This.Void_Ptr); + begin + pragma Assert (Ret in 0 .. 1); + return Boolean'Val (Ret); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::preview returned unexpected int value of " & + Interfaces.C.int'Image (Ret); + end Has_Preview; + + + procedure Set_Preview + (This : in out File_Chooser; + Value : in Boolean) is + begin + fl_file_chooser_set_preview (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Preview; + + + function Get_Text_Color + (This : in File_Chooser) + return Color is + begin + return Color (fl_file_chooser_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out File_Chooser; + Value : in Color) is + begin + fl_file_chooser_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in File_Chooser) + return Font_Kind is + begin + return Font_Kind'Val (fl_file_chooser_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out File_Chooser; + Font : in Font_Kind) is + begin + fl_file_chooser_set_textfont (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in File_Chooser) + return Font_Size is + begin + return Font_Size (fl_file_chooser_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out File_Chooser; + Size : in Font_Size) is + begin + fl_file_chooser_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + function Get_Kind + (This : in File_Chooser) + return Chooser_Kind + is + Ret : constant Interfaces.C.int := fl_file_chooser_get_type (This.Void_Ptr); + begin + pragma Assert (Ret in 0 .. Chooser_Kind'Pos (Chooser_Kind'Last)); + return Chooser_Kind'Val (Ret); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::type returned unexpected int value of " & + Interfaces.C.int'Image (Ret); + end Get_Kind; + + + procedure Set_Kind + (This : in out File_Chooser; + Kind : in Chooser_Kind) is + begin + fl_file_chooser_set_type (This.Void_Ptr, Chooser_Kind'Pos (Kind)); + end Set_Kind; + + + + + -- File Selection -- + + function Number_Selected + (This : in File_Chooser) + return Natural is + begin + return Natural (fl_file_chooser_count (This.Void_Ptr)); + end Number_Selected; + + + function Get_Directory + (This : in File_Chooser) + return String + is + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_directory (This.Void_Ptr); + begin + if C_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (C_Ptr); + end if; + end Get_Directory; + + + procedure Set_Directory + (This : in out File_Chooser; + Value : in String) + is + use Interfaces.C; + C_Arr : aliased char_array := To_C (Value); + begin + if Value = "" then + fl_file_chooser_set_directory (This.Void_Ptr, Strings.Null_Ptr); + else + fl_file_chooser_set_directory + (This.Void_Ptr, + Strings.To_Chars_Ptr (C_Arr'Unchecked_Access)); + end if; + end Set_Directory; + + + function Get_Filter + (This : in File_Chooser) + return String + is + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_filter (This.Void_Ptr); + begin + if C_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (C_Ptr); + end if; + end Get_Filter; + + + procedure Set_Filter + (This : in out File_Chooser; + Value : in String) + is + use Interfaces.C; + C_Arr : aliased char_array := To_C (Value); + begin + if Value = "" then + fl_file_chooser_set_filter (This.Void_Ptr, Strings.Null_Ptr); + else + fl_file_chooser_set_filter + (This.Void_Ptr, + Strings.To_Chars_Ptr (C_Arr'Unchecked_Access)); + end if; + end Set_Filter; + + + function Get_Filter_Index + (This : in File_Chooser) + return Positive is + begin + return Positive (fl_file_chooser_get_filter_value (This.Void_Ptr) + 1); + end Get_Filter_Index; + + + procedure Set_Filter_Index + (This : in out File_Chooser; + Value : in Positive) is + begin + fl_file_chooser_set_filter_value (This.Void_Ptr, Interfaces.C.int (Value) - 1); + end Set_Filter_Index; + + + procedure Rescan + (This : in out File_Chooser) is + begin + fl_file_chooser_rescan (This.Void_Ptr); + end Rescan; + + + procedure Rescan_Keep_Filename + (This : in out File_Chooser) is + begin + fl_file_chooser_rescan_keep_filename (This.Void_Ptr); + end Rescan_Keep_Filename; + + + function Get_Selected + (This : in File_Chooser; + Index : in Positive := 1) + return String + is + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_value (This.Void_Ptr, Interfaces.C.int (Index)); + begin + if C_Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (C_Ptr); + end if; + end Get_Selected; + + + procedure Set_Selected + (This : in out File_Chooser; + Value : in String) is + begin + fl_file_chooser_set_value (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Selected; + + + + + -- Visibility -- + + procedure Show + (This : in out File_Chooser) is + begin + fl_file_chooser_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out File_Chooser) is + begin + fl_file_chooser_hide (This.Void_Ptr); + end Hide; + + + function Is_Shown + (This : in File_Chooser) + return Boolean is + begin + return fl_file_chooser_shown (This.Void_Ptr) /= 0; + end Is_Shown; + + + function Is_Visible + (This : in File_Chooser) + return Boolean is + begin + return fl_file_chooser_visible (This.Void_Ptr) /= 0; + end Is_Visible; + + +begin + + file_chooser_setup_sort_hook; + +end FLTK.File_Choosers; + + diff --git a/body/fltk-filenames.adb b/body/fltk-filenames.adb new file mode 100644 index 0000000..9e41b7d --- /dev/null +++ b/body/fltk-filenames.adb @@ -0,0 +1,518 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Filenames is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + error_bsize : constant Interfaces.C.int; + pragma Import (C, error_bsize, "error_bsize"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Data Structures -- + + procedure free_filename_file_list + (L : in Storage.Integer_Address; + N : in Interfaces.C.int); + pragma Import (C, free_filename_file_list, "free_filename_file_list"); + pragma Inline (free_filename_file_list); + + function filename_dname + (L : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_dname, "filename_dname"); + pragma Inline (filename_dname); + + + + + -- C API -- + + procedure filename_decode_uri + (URI : in Interfaces.C.char_array); + pragma Import (C, filename_decode_uri, "filename_decode_uri"); + pragma Inline (filename_decode_uri); + + function filename_absolute + (To : out Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_absolute, "filename_absolute"); + pragma Inline (filename_absolute); + + function filename_expand + (To : out Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_expand, "filename_expand"); + pragma Inline (filename_expand); + + function filename_ext + (Buf : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_ext, "filename_ext"); + pragma Inline (filename_ext); + + function filename_isdir + (Name : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_isdir, "filename_isdir"); + pragma Inline (filename_isdir); + + function filename_list + (D : in Interfaces.C.char_array; + L : out Storage.Integer_Address; + F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, filename_list, "filename_list"); + pragma Inline (filename_list); + + function filename_match + (Name, Pattern : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_match, "filename_match"); + pragma Inline (filename_match); + + function filename_name + (Name : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_name, "filename_name"); + pragma Inline (filename_name); + + function filename_relative + (To : out Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_relative, "filename_relative"); + pragma Inline (filename_relative); + + function filename_setext + (To : in Interfaces.C.char_array; + Len : in Interfaces.C.int; + Ext : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_setext, "filename_setext"); + pragma Inline (filename_setext); + + function filename_open_uri + (U : in Interfaces.C.char_array; + M : out Interfaces.C.char_array; + Len : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, filename_open_uri, "filename_open_uri"); + pragma Inline (filename_open_uri); + + + + + -- Sorting -- + + function filename_alphasort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_alphasort, "filename_alphasort"); + + function filename_casealphasort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_casealphasort, "filename_casealphasort"); + + function filename_numericsort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_numericsort, "filename_numericsort"); + + function filename_casenumericsort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_casenumericsort, "filename_casenumericsort"); + + + + + ----------------------------- + -- Auxiliary Subprograms -- + ----------------------------- + + -- Sorting -- + + function Alpha_Sort + (A, B : in String) + return Comparison + is + Result : constant Interfaces.C.int := + filename_alphasort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + pragma Assert + (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); + return Comparison'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_alphasort returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Alpha_Sort; + + + function Case_Alpha_Sort + (A, B : in String) + return Comparison + is + Result : constant Interfaces.C.int := + filename_casealphasort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + pragma Assert + (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); + return Comparison'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_casealphasort returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Case_Alpha_Sort; + + + function Numeric_Sort + (A, B : in String) + return Comparison + is + Result : constant Interfaces.C.int := + filename_numericsort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + pragma Assert + (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); + return Comparison'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_numericsort returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Numeric_Sort; + + + function Case_Numeric_Sort + (A, B : in String) + return Comparison + is + Result : constant Interfaces.C.int := + filename_casenumericsort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + pragma Assert + (Result in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last)); + return Comparison'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Wrapper of fl_casenumericsort returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Case_Numeric_Sort; + + + + + -- Datatypes -- + + procedure Finalize + (This : in out File_List) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_filename_file_list (This.Void_Ptr, This.Entries); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + function Length + (This : in File_List) + return Natural is + begin + return Natural (This.Entries); + end Length; + + + function Item + (This : in File_List; + Index : in Positive) + return Path_String is + begin + return Interfaces.C.Strings.Value + (filename_dname (This.Void_Ptr, Interfaces.C.int (Index) - 1)); + end Item; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Uniform Resource Identifiers -- + + function Decode_URI + (URI : in Path_String) + return Path_String + is + C_Ptr : constant Interfaces.C.char_array := Interfaces.C.To_C (URI); + begin + filename_decode_uri (C_Ptr); + return Interfaces.C.To_Ada (C_Ptr); + end Decode_URI; + + + procedure Open_URI + (URI : in Path_String) + is + Message : Interfaces.C.char_array (1 .. Interfaces.C.size_t (error_bsize)) := + (others => Interfaces.C.char'Val (0)); + Result : constant Interfaces.C.int := filename_open_uri + (Interfaces.C.To_C (URI), + Message, + error_bsize); + begin + if Result = 0 then + raise Open_URI_Error with "Error: " & Interfaces.C.To_Ada (Message); + else + pragma Assert (Result = 1); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_open_uri returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Open_URI; + + + + + -- Pathnames -- + + function Absolute + (Name : in Path_String) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Ignore : constant Interfaces.C.int := filename_absolute + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + return Interfaces.C.To_Ada (Result); + end Absolute; + + + function Absolute + (Name : in Path_String; + Changed : out Boolean) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : constant Interfaces.C.int := filename_absolute + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + Changed := Code /= 0; + return Interfaces.C.To_Ada (Result); + end Absolute; + + + function Relative + (Name : in Path_String) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Ignore : constant Interfaces.C.int := filename_relative + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + return Interfaces.C.To_Ada (Result); + end Relative; + + + function Relative + (Name : in Path_String; + Changed : out Boolean) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : constant Interfaces.C.int := filename_relative + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + Changed := Code /= 0; + return Interfaces.C.To_Ada (Result); + end Relative; + + + function Expand + (Name : in Path_String) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Ignore : constant Interfaces.C.int := filename_expand + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + return Interfaces.C.To_Ada (Result); + end Expand; + + + function Expand + (Name : in Path_String; + Changed : out Boolean) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : constant Interfaces.C.int := filename_expand + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + Changed := Code /= 0; + return Interfaces.C.To_Ada (Result); + end Expand; + + + + + -- Filenames -- + + function Base_Name + (Name : in Path_String) + return Path_String + is + Data : constant Interfaces.C.char_array := Interfaces.C.To_C (Name); + begin + return Interfaces.C.Strings.Value (filename_name (Data)); + end Base_Name; + + + function Extension + (Name : in Path_String) + return Path_String + is + Data : constant Interfaces.C.char_array := Interfaces.C.To_C (Name); + Result : constant Interfaces.C.Strings.chars_ptr := filename_ext (Data); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Extension; + + + function Set_Extension + (Name : in Path_String; + Suffix : in String) + return Path_String + is + Data : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Result : Interfaces.C.Strings.chars_ptr; + begin + Data (1 .. Name'Length) := Interfaces.C.To_C (Name); + Result := filename_setext + (Data, + Data'Length, + Interfaces.C.To_C (Suffix)); + return Interfaces.C.Strings.Value (Result); + end Set_Extension; + + + + + -- Directories -- + + function Is_Directory + (Name : in Path_String) + return Boolean is + begin + return filename_isdir (Interfaces.C.To_C (Name)) /= 0; + end Is_Directory; + + + Current_Sort : Compare_Function; + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int; + + pragma Convention (C, Compare_Hook); + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int + is + Result : constant Comparison := Current_Sort + (Interfaces.C.Strings.Value (filename_dname (DA, 0)), + Interfaces.C.Strings.Value (filename_dname (DB, 0))); + begin + return Comparison'Pos (Result) - 1; + end Compare_Hook; + + function Get_Listing + (Name : in Path_String; + Sort : in not null Compare_Function := Numeric_Sort'Access) + return File_List is + begin + Current_Sort := Sort; + return This : File_List do + This.Entries := filename_list + (Interfaces.C.To_C (Name), + This.Void_Ptr, + Storage.To_Integer (Compare_Hook'Address)); + end return; + end Get_Listing; + + + + + -- Patterns -- + + function Match + (Input, Pattern : in String) + return Boolean is + begin + return filename_match (Interfaces.C.To_C (Input), Interfaces.C.To_C (Pattern)) /= 0; + end Match; + + +end FLTK.Filenames; + + diff --git a/body/fltk-help_dialogs.adb b/body/fltk-help_dialogs.adb new file mode 100644 index 0000000..d316662 --- /dev/null +++ b/body/fltk-help_dialogs.adb @@ -0,0 +1,387 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Args_Marshal, + Interfaces.C.Strings; + +use type + + Interfaces.C.int; + + +package body FLTK.Help_Dialogs is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_help_dialog + return Storage.Integer_Address; + pragma Import (C, new_fl_help_dialog, "new_fl_help_dialog"); + pragma Inline (new_fl_help_dialog); + + procedure free_fl_help_dialog + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_help_dialog, "free_fl_help_dialog"); + pragma Inline (free_fl_help_dialog); + + + + + -- Visibility -- + + procedure fl_help_dialog_show + (D : in Storage.Integer_Address); + pragma Import (C, fl_help_dialog_show, "fl_help_dialog_show"); + pragma Inline (fl_help_dialog_show); + + procedure fl_help_dialog_show2 + (D : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_help_dialog_show2, "fl_help_dialog_show2"); + pragma Inline (fl_help_dialog_show2); + + procedure fl_help_dialog_hide + (D : in Storage.Integer_Address); + pragma Import (C, fl_help_dialog_hide, "fl_help_dialog_hide"); + pragma Inline (fl_help_dialog_hide); + + function fl_help_dialog_visible + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_dialog_visible, "fl_help_dialog_visible"); + pragma Inline (fl_help_dialog_visible); + + + + + -- Topline -- + + procedure fl_help_dialog_set_topline_number + (D : in Storage.Integer_Address; + N : in Interfaces.C.int); + pragma Import (C, fl_help_dialog_set_topline_number, "fl_help_dialog_set_topline_number"); + pragma Inline (fl_help_dialog_set_topline_number); + + procedure fl_help_dialog_set_topline_target + (D : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_help_dialog_set_topline_target, "fl_help_dialog_set_topline_target"); + pragma Inline (fl_help_dialog_set_topline_target); + + + + + -- Content -- + + procedure fl_help_dialog_load + (D : in Storage.Integer_Address; + N : in Interfaces.C.char_array); + pragma Import (C, fl_help_dialog_load, "fl_help_dialog_load"); + pragma Inline (fl_help_dialog_load); + + function fl_help_dialog_get_value + (D : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_dialog_get_value, "fl_help_dialog_get_value"); + pragma Inline (fl_help_dialog_get_value); + + procedure fl_help_dialog_set_value + (D : in Storage.Integer_Address; + V : in Interfaces.C.char_array); + pragma Import (C, fl_help_dialog_set_value, "fl_help_dialog_set_value"); + pragma Inline (fl_help_dialog_set_value); + + + + + -- Settings -- + + function fl_help_dialog_get_textsize + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_dialog_get_textsize, "fl_help_dialog_get_textsize"); + pragma Inline (fl_help_dialog_get_textsize); + + procedure fl_help_dialog_set_textsize + (D : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_help_dialog_set_textsize, "fl_help_dialog_set_textsize"); + pragma Inline (fl_help_dialog_set_textsize); + + + + + -- Dimensions -- + + function fl_help_dialog_get_x + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_dialog_get_x, "fl_help_dialog_get_x"); + pragma Inline (fl_help_dialog_get_x); + + function fl_help_dialog_get_y + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_dialog_get_y, "fl_help_dialog_get_y"); + pragma Inline (fl_help_dialog_get_y); + + function fl_help_dialog_get_w + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_dialog_get_w, "fl_help_dialog_get_w"); + pragma Inline (fl_help_dialog_get_w); + + function fl_help_dialog_get_h + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_dialog_get_h, "fl_help_dialog_get_h"); + pragma Inline (fl_help_dialog_get_h); + + procedure fl_help_dialog_resize + (D : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_help_dialog_resize, "fl_help_dialog_resize"); + pragma Inline (fl_help_dialog_resize); + + procedure fl_help_dialog_position + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_help_dialog_position, "fl_help_dialog_position"); + pragma Inline (fl_help_dialog_position); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Help_Dialog) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_help_dialog (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + return Help_Dialog is + begin + return This : Help_Dialog do + This.Void_Ptr := new_fl_help_dialog; + end return; + end Create; + + + function Create + (X, Y, W, H : in Integer) + return Help_Dialog is + begin + return This : Help_Dialog do + This.Void_Ptr := new_fl_help_dialog; + This.Resize (X, Y, W, H); + end return; + end Create; + + + pragma Inline (Create); + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out Help_Dialog) is + begin + fl_help_dialog_show (This.Void_Ptr); + end Show; + + + procedure Show_With_Args + (This : in out Help_Dialog) is + begin + FLTK.Args_Marshal.Dispatch (fl_help_dialog_show2'Access, This.Void_Ptr); + end Show_With_Args; + + + procedure Hide + (This : in out Help_Dialog) is + begin + fl_help_dialog_hide (This.Void_Ptr); + end Hide; + + + function Is_Visible + (This : in Help_Dialog) + return Boolean is + begin + return fl_help_dialog_visible (This.Void_Ptr) = 1; + end Is_Visible; + + + + + -- Topline -- + + procedure Set_Topline_Number + (This : in out Help_Dialog; + Line : in Positive) is + begin + fl_help_dialog_set_topline_number (This.Void_Ptr, Interfaces.C.int (Line) - 1); + end Set_Topline_Number; + + + procedure Set_Topline_Target + (This : in out Help_Dialog; + Value : in String) is + begin + fl_help_dialog_set_topline_target (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Topline_Target; + + + + + -- Content -- + + procedure Load + (This : in out Help_Dialog; + Name : in String) is + begin + fl_help_dialog_load (This.Void_Ptr, Interfaces.C.To_C (Name)); + end Load; + + + function Get_Content + (This : in Help_Dialog) + return String + is + Raw_Chars : constant Interfaces.C.Strings.chars_ptr := + fl_help_dialog_get_value (This.Void_Ptr); + use type Interfaces.C.Strings.chars_ptr; + begin + if Raw_Chars = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Raw_Chars); + end if; + end Get_Content; + + + procedure Set_Content + (This : in out Help_Dialog; + Value : in String) is + begin + fl_help_dialog_set_value (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Content; + + + + + -- Settings -- + + function Get_Text_Size + (This : in Help_Dialog) + return Font_Size is + begin + return Font_Size (fl_help_dialog_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Help_Dialog; + Size : in Font_Size) is + begin + fl_help_dialog_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Dimensions -- + + function Get_X + (This : in Help_Dialog) + return Integer is + begin + return Integer (fl_help_dialog_get_x (This.Void_Ptr)); + end Get_X; + + + function Get_Y + (This : in Help_Dialog) + return Integer is + begin + return Integer (fl_help_dialog_get_y (This.Void_Ptr)); + end Get_Y; + + + function Get_W + (This : in Help_Dialog) + return Integer is + begin + return Integer (fl_help_dialog_get_w (This.Void_Ptr)); + end Get_W; + + + function Get_H + (This : in Help_Dialog) + return Integer is + begin + return Integer (fl_help_dialog_get_h (This.Void_Ptr)); + end Get_H; + + + procedure Resize + (This : in out Help_Dialog; + X, Y, W, H : in Integer) is + begin + fl_help_dialog_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Reposition + (This : in out Help_Dialog; + X, Y : in Integer) is + begin + fl_help_dialog_position + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Reposition; + + +end FLTK.Help_Dialogs; + + diff --git a/body/fltk-images-bitmaps-xbm.adb b/body/fltk-images-bitmaps-xbm.adb new file mode 100644 index 0000000..0115b1b --- /dev/null +++ b/body/fltk-images-bitmaps-xbm.adb @@ -0,0 +1,73 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.Bitmaps.XBM is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_xbm_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_xbm_image, "new_fl_xbm_image"); + pragma Inline (new_fl_xbm_image); + + procedure free_fl_xbm_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_xbm_image, "free_fl_xbm_image"); + pragma Inline (free_fl_xbm_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out XBM_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_xbm_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return XBM_Image is + begin + return This : XBM_Image do + This.Void_Ptr := new_fl_xbm_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.Bitmaps.XBM; + + diff --git a/body/fltk-images-bitmaps.adb b/body/fltk-images-bitmaps.adb new file mode 100644 index 0000000..5b59c13 --- /dev/null +++ b/body/fltk-images-bitmaps.adb @@ -0,0 +1,298 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.Bitmaps is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_bitmap + (D : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_bitmap, "new_fl_bitmap"); + pragma Inline (new_fl_bitmap); + + procedure free_fl_bitmap + (I : in Storage.Integer_Address); + pragma Import (C, free_fl_bitmap, "free_fl_bitmap"); + pragma Inline (free_fl_bitmap); + + + + + -- Copying -- + + function fl_bitmap_copy + (I : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_bitmap_copy, "fl_bitmap_copy"); + pragma Inline (fl_bitmap_copy); + + function fl_bitmap_copy2 + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_bitmap_copy2, "fl_bitmap_copy2"); + pragma Inline (fl_bitmap_copy2); + + + + + -- Activity -- + + procedure fl_bitmap_uncache + (I : in Storage.Integer_Address); + pragma Import (C, fl_bitmap_uncache, "fl_bitmap_uncache"); + pragma Inline (fl_bitmap_uncache); + + + + + -- Pixel Data -- + + function fl_bitmap_data + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_bitmap_data, "fl_bitmap_data"); + pragma Inline (fl_bitmap_data); + + + + + -- Drawing -- + + procedure fl_bitmap_draw2 + (I : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_bitmap_draw2, "fl_bitmap_draw2"); + pragma Inline (fl_bitmap_draw2); + + procedure fl_bitmap_draw + (I : in Storage.Integer_Address; + X, Y, W, H, CX, CY : in Interfaces.C.int); + pragma Import (C, fl_bitmap_draw, "fl_bitmap_draw"); + pragma Inline (fl_bitmap_draw); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out Bitmap) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_bitmap (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Data : in Color_Component_Array; + Width, Height : in Natural) + return Bitmap is + begin + return This : Bitmap do + This.Void_Ptr := new_fl_bitmap + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Contracts -- + + function Bytes_Needed + (Bits : in Natural) + return Natural is + begin + return Integer (Float'Ceiling + (Float (Bits) / Float (Color_Component_Array'Component_Size))); + end Bytes_Needed; + + + + + -- Copying -- + + function Copy + (This : in Bitmap; + Width, Height : in Natural) + return Bitmap'Class is + begin + return Copied : Bitmap do + Copied.Void_Ptr := fl_bitmap_copy + (This.Void_Ptr, + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + end return; + end Copy; + + + function Copy + (This : in Bitmap) + return Bitmap'Class is + begin + return Copied : Bitmap do + Copied.Void_Ptr := fl_bitmap_copy2 (This.Void_Ptr); + end return; + end Copy; + + + + + -- Activity -- + + procedure Uncache + (This : in out Bitmap) is + begin + fl_bitmap_uncache (This.Void_Ptr); + end Uncache; + + + + + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Size_Type is + begin + return Size_Type (Bytes_Needed (This.Get_W)) * Size_Type (This.Get_H); + end Data_Size; + + + function Get_Datum + (This : in Bitmap; + Place : in Positive_Size) + return Color_Component + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Place); + end Get_Datum; + + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive_Size; + Value : in Color_Component) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place) := Value; + end Set_Datum; + + + function Slice + (This : in Bitmap; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Low .. High); + end Slice; + + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive_Size; + Values : in Color_Component_Array) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place .. Place + Values'Length - 1) := Values; + end Overwrite; + + + function All_Data + (This : in Bitmap) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data; + end All_Data; + + + + + -- Drawing -- + + procedure Draw + (This : in Bitmap; + X, Y : in Integer) is + begin + fl_bitmap_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw; + + + procedure Draw + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is + begin + fl_bitmap_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); + end Draw; + + +end FLTK.Images.Bitmaps; + + diff --git a/body/fltk-images-pixmaps-gif.adb b/body/fltk-images-pixmaps-gif.adb new file mode 100644 index 0000000..fb8dca8 --- /dev/null +++ b/body/fltk-images-pixmaps-gif.adb @@ -0,0 +1,73 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.Pixmaps.GIF is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_gif_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_gif_image, "new_fl_gif_image"); + pragma Inline (new_fl_gif_image); + + procedure free_fl_gif_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_gif_image, "free_fl_gif_image"); + pragma Inline (free_fl_gif_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out GIF_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_gif_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return GIF_Image is + begin + return This : GIF_Image do + This.Void_Ptr := new_fl_gif_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.Pixmaps.GIF; + + diff --git a/body/fltk-images-pixmaps-xpm.adb b/body/fltk-images-pixmaps-xpm.adb new file mode 100644 index 0000000..d9cff25 --- /dev/null +++ b/body/fltk-images-pixmaps-xpm.adb @@ -0,0 +1,73 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.Pixmaps.XPM is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_xpm_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_xpm_image, "new_fl_xpm_image"); + pragma Inline (new_fl_xpm_image); + + procedure free_fl_xpm_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_xpm_image, "free_fl_xpm_image"); + pragma Inline (free_fl_xpm_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out XPM_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_xpm_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return XPM_Image is + begin + return This : XPM_Image do + This.Void_Ptr := new_fl_xpm_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.Pixmaps.XPM; + + diff --git a/body/fltk-images-pixmaps.adb b/body/fltk-images-pixmaps.adb new file mode 100644 index 0000000..8487459 --- /dev/null +++ b/body/fltk-images-pixmaps.adb @@ -0,0 +1,235 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Pixmap_Marshal; + + +package body FLTK.Images.Pixmaps is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_pixmap + (D : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_pixmap, "new_fl_pixmap"); + pragma Inline (new_fl_pixmap); + + procedure free_fl_pixmap + (I : in Storage.Integer_Address); + pragma Import (C, free_fl_pixmap, "free_fl_pixmap"); + pragma Inline (free_fl_pixmap); + + + + + -- Copying -- + + function fl_pixmap_copy + (I : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_pixmap_copy, "fl_pixmap_copy"); + pragma Inline (fl_pixmap_copy); + + function fl_pixmap_copy2 + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_pixmap_copy2, "fl_pixmap_copy2"); + pragma Inline (fl_pixmap_copy2); + + + + + -- Colors -- + + procedure fl_pixmap_color_average + (I : in Storage.Integer_Address; + C : in Interfaces.C.int; + B : in Interfaces.C.C_float); + pragma Import (C, fl_pixmap_color_average, "fl_pixmap_color_average"); + pragma Inline (fl_pixmap_color_average); + + procedure fl_pixmap_desaturate + (I : in Storage.Integer_Address); + pragma Import (C, fl_pixmap_desaturate, "fl_pixmap_desaturate"); + pragma Inline (fl_pixmap_desaturate); + + + + + -- Activity -- + + procedure fl_pixmap_uncache + (I : in Storage.Integer_Address); + pragma Import (C, fl_pixmap_uncache, "fl_pixmap_uncache"); + pragma Inline (fl_pixmap_uncache); + + + + + -- Drawing -- + + procedure fl_pixmap_draw2 + (I : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_pixmap_draw2, "fl_pixmap_draw2"); + pragma Inline (fl_pixmap_draw2); + + procedure fl_pixmap_draw + (I : in Storage.Integer_Address; + X, Y, W, H, CX, CY : in Interfaces.C.int); + pragma Import (C, fl_pixmap_draw, "fl_pixmap_draw"); + pragma Inline (fl_pixmap_draw); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out Pixmap) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + Pixmap_Marshal.Free_Recursive (This.Loose_Ptr); + free_fl_pixmap (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap is + begin + return This : Pixmap do + This.Loose_Ptr := Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels); + This.Void_Ptr := new_fl_pixmap + (Storage.To_Integer (This.Loose_Ptr (This.Loose_Ptr'First)'Address)); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + + function Copy + (This : in Pixmap; + Width, Height : in Natural) + return Pixmap'Class is + begin + return Copied : Pixmap do + Copied.Void_Ptr := fl_pixmap_copy + (This.Void_Ptr, + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + end return; + end Copy; + + + function Copy + (This : in Pixmap) + return Pixmap'Class is + begin + return Copied : Pixmap do + Copied.Void_Ptr := fl_pixmap_copy2 (This.Void_Ptr); + end return; + end Copy; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Pixmap; + Col : in Color; + Amount : in Blend) is + begin + fl_pixmap_color_average + (This.Void_Ptr, + Interfaces.C.int (Col), + Interfaces.C.C_float (Amount)); + end Color_Average; + + + procedure Desaturate + (This : in out Pixmap) is + begin + fl_pixmap_desaturate (This.Void_Ptr); + end Desaturate; + + + + + -- Activity -- + + procedure Uncache + (This : in out Pixmap) is + begin + fl_pixmap_uncache (This.Void_Ptr); + end Uncache; + + + + + -- Drawing -- + + procedure Draw + (This : in Pixmap; + X, Y : in Integer) is + begin + fl_pixmap_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw; + + + procedure Draw + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is + begin + fl_pixmap_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); + end Draw; + + +end FLTK.Images.Pixmaps; + + diff --git a/body/fltk-images-rgb-bmp.adb b/body/fltk-images-rgb-bmp.adb new file mode 100644 index 0000000..23ffe01 --- /dev/null +++ b/body/fltk-images-rgb-bmp.adb @@ -0,0 +1,73 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.RGB.BMP is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_bmp_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_bmp_image, "new_fl_bmp_image"); + pragma Inline (new_fl_bmp_image); + + procedure free_fl_bmp_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_bmp_image, "free_fl_bmp_image"); + pragma Inline (free_fl_bmp_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out BMP_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_bmp_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return BMP_Image is + begin + return This : BMP_Image do + This.Void_Ptr := new_fl_bmp_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.RGB.BMP; + + diff --git a/body/fltk-images-rgb-jpeg.adb b/body/fltk-images-rgb-jpeg.adb new file mode 100644 index 0000000..61d06e6 --- /dev/null +++ b/body/fltk-images-rgb-jpeg.adb @@ -0,0 +1,96 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.RGB.JPEG is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_jpeg_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_jpeg_image, "new_fl_jpeg_image"); + pragma Inline (new_fl_jpeg_image); + + function new_fl_jpeg_image2 + (N : in Interfaces.C.char_array; + D : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_jpeg_image2, "new_fl_jpeg_image2"); + pragma Inline (new_fl_jpeg_image2); + + procedure free_fl_jpeg_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_jpeg_image, "free_fl_jpeg_image"); + pragma Inline (free_fl_jpeg_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out JPEG_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_jpeg_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return JPEG_Image is + begin + return This : JPEG_Image do + This.Void_Ptr := new_fl_jpeg_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + + function Create + (Name : in String := ""; + Data : in Color_Component_Array) + return JPEG_Image is + begin + return This : JPEG_Image do + This.Void_Ptr := new_fl_jpeg_image2 + (Interfaces.C.To_C (Name), + (if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer)); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.RGB.JPEG; + + diff --git a/body/fltk-images-rgb-png.adb b/body/fltk-images-rgb-png.adb new file mode 100644 index 0000000..1f6e7b9 --- /dev/null +++ b/body/fltk-images-rgb-png.adb @@ -0,0 +1,98 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.RGB.PNG is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_png_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_png_image, "new_fl_png_image"); + pragma Inline (new_fl_png_image); + + function new_fl_png_image2 + (N : in Interfaces.C.char_array; + D : in Storage.Integer_Address; + S : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_png_image2, "new_fl_png_image2"); + pragma Inline (new_fl_png_image2); + + procedure free_fl_png_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_png_image, "free_fl_png_image"); + pragma Inline (free_fl_png_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out PNG_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_png_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return PNG_Image is + begin + return This : PNG_Image do + This.Void_Ptr := new_fl_png_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + + function Create + (Name : in String := ""; + Data : in Color_Component_Array) + return PNG_Image is + begin + return This : PNG_Image do + This.Void_Ptr := new_fl_png_image2 + (Interfaces.C.To_C (Name), + (if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), + Data'Length); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.RGB.PNG; + + diff --git a/body/fltk-images-rgb-pnm.adb b/body/fltk-images-rgb-pnm.adb new file mode 100644 index 0000000..4ddb06f --- /dev/null +++ b/body/fltk-images-rgb-pnm.adb @@ -0,0 +1,73 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.RGB.PNM is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_pnm_image + (F : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_pnm_image, "new_fl_pnm_image"); + pragma Inline (new_fl_pnm_image); + + procedure free_fl_pnm_image + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_pnm_image, "free_fl_pnm_image"); + pragma Inline (free_fl_pnm_image); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out PNM_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_pnm_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String) + return PNM_Image is + begin + return This : PNM_Image do + This.Void_Ptr := new_fl_pnm_image + (Interfaces.C.To_C (Filename)); + Raise_Fail_Errors (This); + end return; + end Create; + + end Forge; + + +end FLTK.Images.RGB.PNM; + + diff --git a/body/fltk-images-rgb.adb b/body/fltk-images-rgb.adb new file mode 100644 index 0000000..71d2520 --- /dev/null +++ b/body/fltk-images-rgb.adb @@ -0,0 +1,388 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.RGB is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_rgb_image + (Data : in Storage.Integer_Address; + W, H, D, L : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_rgb_image, "new_fl_rgb_image"); + pragma Inline (new_fl_rgb_image); + + function new_fl_rgb_image2 + (P : in Storage.Integer_Address; + C : in Interfaces.C.unsigned) + return Storage.Integer_Address; + pragma Import (C, new_fl_rgb_image2, "new_fl_rgb_image2"); + pragma Inline (new_fl_rgb_image2); + + procedure free_fl_rgb_image + (I : in Storage.Integer_Address); + pragma Import (C, free_fl_rgb_image, "free_fl_rgb_image"); + pragma Inline (free_fl_rgb_image); + + + + + -- Static Settings -- + + function fl_rgb_image_get_max_size + return Interfaces.C.size_t; + pragma Import (C, fl_rgb_image_get_max_size, "fl_rgb_image_get_max_size"); + pragma Inline (fl_rgb_image_get_max_size); + + procedure fl_rgb_image_set_max_size + (V : in Interfaces.C.size_t); + pragma Import (C, fl_rgb_image_set_max_size, "fl_rgb_image_set_max_size"); + pragma Inline (fl_rgb_image_set_max_size); + + + + + -- Copying -- + + function fl_rgb_image_copy + (I : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_rgb_image_copy, "fl_rgb_image_copy"); + pragma Inline (fl_rgb_image_copy); + + function fl_rgb_image_copy2 + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_rgb_image_copy2, "fl_rgb_image_copy2"); + pragma Inline (fl_rgb_image_copy2); + + + + + -- Colors -- + + procedure fl_rgb_image_color_average + (I : in Storage.Integer_Address; + C : in Interfaces.C.int; + B : in Interfaces.C.C_float); + pragma Import (C, fl_rgb_image_color_average, "fl_rgb_image_color_average"); + pragma Inline (fl_rgb_image_color_average); + + procedure fl_rgb_image_desaturate + (I : in Storage.Integer_Address); + pragma Import (C, fl_rgb_image_desaturate, "fl_rgb_image_desaturate"); + pragma Inline (fl_rgb_image_desaturate); + + + + + -- Activity -- + + procedure fl_rgb_image_uncache + (I : in Storage.Integer_Address); + pragma Import (C, fl_rgb_image_uncache, "fl_rgb_image_uncache"); + pragma Inline (fl_rgb_image_uncache); + + + + + -- Pixel Data -- + + function fl_rgb_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_rgb_image_data, "fl_rgb_image_data"); + pragma Inline (fl_rgb_image_data); + + + + + -- Drawing -- + + procedure fl_rgb_image_draw2 + (I : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_rgb_image_draw2, "fl_rgb_image_draw2"); + pragma Inline (fl_rgb_image_draw2); + + procedure fl_rgb_image_draw + (I : in Storage.Integer_Address; + X, Y, W, H, CX, CY : in Interfaces.C.int); + pragma Import (C, fl_rgb_image_draw, "fl_rgb_image_draw"); + pragma Inline (fl_rgb_image_draw); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out RGB_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_rgb_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Data : in Color_Component_Array; + Width, Height : in Natural; + Depth : in Natural := 3; + Line_Size : in Natural := 0) + return RGB_Image is + begin + return This : RGB_Image do + This.Void_Ptr := new_fl_rgb_image + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), + Interfaces.C.int (Width), + Interfaces.C.int (Height), + Interfaces.C.int (Depth), + Interfaces.C.int (Line_Size)); + end return; + end Create; + + + function Create + (Data : in FLTK.Images.Pixmaps.Pixmap'Class; + Background : in Color := Background_Color) + return RGB_Image is + begin + return This : RGB_Image do + This.Void_Ptr := new_fl_rgb_image2 + (Wrapper (Data).Void_Ptr, + Interfaces.C.unsigned (Background)); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Static Settings -- + + function Get_Max_Size + return Size_Type is + begin + return Size_Type (fl_rgb_image_get_max_size); + end Get_Max_Size; + + + procedure Set_Max_Size + (Value : in Size_Type) is + begin + fl_rgb_image_set_max_size (Interfaces.C.size_t (Value)); + end Set_Max_Size; + + + + + -- Copying -- + + function Copy + (This : in RGB_Image; + Width, Height : in Natural) + return RGB_Image'Class is + begin + return Copied : RGB_Image do + Copied.Void_Ptr := fl_rgb_image_copy + (This.Void_Ptr, + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + end return; + end Copy; + + + function Copy + (This : in RGB_Image) + return RGB_Image'Class is + begin + return Copied : RGB_Image do + Copied.Void_Ptr := fl_rgb_image_copy2 (This.Void_Ptr); + end return; + end Copy; + + + + + -- Colors -- + + procedure Color_Average + (This : in out RGB_Image; + Col : in Color; + Amount : in Blend) is + begin + fl_rgb_image_color_average + (This.Void_Ptr, + Interfaces.C.int (Col), + Interfaces.C.C_float (Amount)); + end Color_Average; + + + procedure Desaturate + (This : in out RGB_Image) is + begin + fl_rgb_image_desaturate (This.Void_Ptr); + end Desaturate; + + + + + -- Activity -- + + procedure Uncache + (This : in out RGB_Image) is + begin + fl_rgb_image_uncache (This.Void_Ptr); + end Uncache; + + + + + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Size_Type + is + Per_Line : constant Natural := This.Get_Line_Size; + begin + if Per_Line = 0 then + return Size_Type (This.Get_W) * Size_Type (This.Get_D) * Size_Type (This.Get_H); + else + return Size_Type (Per_Line) * Size_Type (This.Get_H); + end if; + end Data_Size; + + + function Get_Datum + (This : in RGB_Image; + Place : in Positive_Size) + return Color_Component + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Place); + end Get_Datum; + + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive_Size; + Value : in Color_Component) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place) := Value; + end Set_Datum; + + + function Slice + (This : in RGB_Image; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Low .. High); + end Slice; + + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive_Size; + Values : in Color_Component_Array) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place .. Place + Values'Length - 1) := Values; + end Overwrite; + + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data; + end All_Data; + + + + + -- Drawing -- + + procedure Draw + (This : in RGB_Image; + X, Y : in Integer) is + begin + fl_rgb_image_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw; + + + procedure Draw + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is + begin + fl_rgb_image_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); + end Draw; + + +end FLTK.Images.RGB; + + diff --git a/body/fltk-images-shared.adb b/body/fltk-images-shared.adb new file mode 100644 index 0000000..b8de511 --- /dev/null +++ b/body/fltk-images-shared.adb @@ -0,0 +1,385 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Images.Shared is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function fl_shared_image_get + (F : in Interfaces.C.char_array; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_shared_image_get, "fl_shared_image_get"); + pragma Inline (fl_shared_image_get); + + function fl_shared_image_get2 + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_shared_image_get2, "fl_shared_image_get2"); + pragma Inline (fl_shared_image_get2); + + function fl_shared_image_find + (N : in Interfaces.C.char_array; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_shared_image_find, "fl_shared_image_find"); + pragma Inline (fl_shared_image_find); + + procedure fl_shared_image_release + (I : in Storage.Integer_Address); + pragma Import (C, fl_shared_image_release, "fl_shared_image_release"); + pragma Inline (fl_shared_image_release); + + + + + -- Copying -- + + function fl_shared_image_copy + (I : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_shared_image_copy, "fl_shared_image_copy"); + pragma Inline (fl_shared_image_copy); + + function fl_shared_image_copy2 + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_shared_image_copy2, "fl_shared_image_copy2"); + pragma Inline (fl_shared_image_copy2); + + + + + -- Colors -- + + procedure fl_shared_image_color_average + (I : in Storage.Integer_Address; + C : in Interfaces.C.int; + B : in Interfaces.C.C_float); + pragma Import (C, fl_shared_image_color_average, "fl_shared_image_color_average"); + pragma Inline (fl_shared_image_color_average); + + procedure fl_shared_image_desaturate + (I : in Storage.Integer_Address); + pragma Import (C, fl_shared_image_desaturate, "fl_shared_image_desaturate"); + pragma Inline (fl_shared_image_desaturate); + + + + + -- Activity -- + + function fl_shared_image_num_images + return Interfaces.C.int; + pragma Import (C, fl_shared_image_num_images, "fl_shared_image_num_images"); + pragma Inline (fl_shared_image_num_images); + + function fl_shared_image_name + (I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_shared_image_name, "fl_shared_image_name"); + pragma Inline (fl_shared_image_name); + + function fl_shared_image_original + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_shared_image_original, "fl_shared_image_original"); + pragma Inline (fl_shared_image_original); + + function fl_shared_image_refcount + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_shared_image_refcount, "fl_shared_image_refcount"); + pragma Inline (fl_shared_image_refcount); + + procedure fl_shared_image_reload + (I : in Storage.Integer_Address); + pragma Import (C, fl_shared_image_reload, "fl_shared_image_reload"); + pragma Inline (fl_shared_image_reload); + + procedure fl_shared_image_uncache + (I : in Storage.Integer_Address); + pragma Import (C, fl_shared_image_uncache, "fl_shared_image_uncache"); + pragma Inline (fl_shared_image_uncache); + + + + + -- Drawing -- + + procedure fl_shared_image_scaling_algorithm + (A : in Interfaces.C.int); + pragma Import (C, fl_shared_image_scaling_algorithm, "fl_shared_image_scaling_algorithm"); + pragma Inline (fl_shared_image_scaling_algorithm); + + procedure fl_shared_image_scale + (I : in Storage.Integer_Address; + W, H, P, E : in Interfaces.C.int); + pragma Import (C, fl_shared_image_scale, "fl_shared_image_scale"); + pragma Inline (fl_shared_image_scale); + + procedure fl_shared_image_draw + (I : in Storage.Integer_Address; + X, Y, W, H, CX, CY : in Interfaces.C.int); + pragma Import (C, fl_shared_image_draw, "fl_shared_image_draw"); + pragma Inline (fl_shared_image_draw); + + procedure fl_shared_image_draw2 + (I : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_shared_image_draw2, "fl_shared_image_draw2"); + pragma Inline (fl_shared_image_draw2); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out Shared_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + fl_shared_image_release (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Filename : in String; + W, H : in Integer) + return Shared_Image is + begin + return This : Shared_Image do + This.Void_Ptr := fl_shared_image_get + (Interfaces.C.To_C (Filename), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end return; + end Create; + + + function Create + (From : in FLTK.Images.RGB.RGB_Image'Class) + return Shared_Image is + begin + return This : Shared_Image do + This.Void_Ptr := fl_shared_image_get2 (Wrapper (From).Void_Ptr); + end return; + end Create; + + + function Find + (Name : in String; + W, H : in Integer := 0) + return Shared_Image is + begin + return This : Shared_Image do + This.Void_Ptr := fl_shared_image_find + (Interfaces.C.To_C (Name), + Interfaces.C.int (W), + Interfaces.C.int (H)); + if This.Void_Ptr = Null_Pointer then + raise No_Image_Error; + end if; + end return; + end Find; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + + function Copy + (This : in Shared_Image; + Width, Height : in Natural) + return Shared_Image'Class is + begin + return Copied : Shared_Image do + Copied.Void_Ptr := fl_shared_image_copy + (This.Void_Ptr, + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + end return; + end Copy; + + + function Copy + (This : in Shared_Image) + return Shared_Image'Class is + begin + return Copied : Shared_Image do + Copied.Void_Ptr := fl_shared_image_copy2 (This.Void_Ptr); + end return; + end Copy; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Shared_Image; + Col : in Color; + Amount : in Blend) is + begin + fl_shared_image_color_average + (This.Void_Ptr, + Interfaces.C.int (Col), + Interfaces.C.C_float (Amount)); + end Color_Average; + + + procedure Desaturate + (This : in out Shared_Image) is + begin + fl_shared_image_desaturate (This.Void_Ptr); + end Desaturate; + + + + + -- Activity -- + + function Number_Of_Images + return Natural is + begin + return Natural (fl_shared_image_num_images); + end Number_Of_Images; + + + function Name + (This : in Shared_Image) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_shared_image_name (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Name; + + + function Original + (This : in Shared_Image) + return Boolean is + begin + return fl_shared_image_original (This.Void_Ptr) /= 0; + end Original; + + + function Reference_Count + (This : in Shared_Image) + return Natural is + begin + return Natural (fl_shared_image_refcount (This.Void_Ptr)); + end Reference_Count; + + + procedure Reload + (This : in out Shared_Image) is + begin + fl_shared_image_reload (This.Void_Ptr); + end Reload; + + + procedure Uncache + (This : in out Shared_Image) is + begin + fl_shared_image_uncache (This.Void_Ptr); + end Uncache; + + + + + -- Drawing -- + + procedure Set_Scaling_Algorithm + (To : in Scaling_Kind) is + begin + fl_shared_image_scaling_algorithm (Scaling_Kind'Pos (To)); + end Set_Scaling_Algorithm; + + + procedure Scale + (This : in out Shared_Image; + W, H : in Integer; + Proportional : in Boolean := True; + Can_Expand : in Boolean := False) is + begin + fl_shared_image_scale + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H), + Boolean'Pos (Proportional), + Boolean'Pos (Can_Expand)); + end Scale; + + + procedure Draw + (This : in Shared_Image; + X, Y, W, H : in Integer; + CX, CY : in Integer := 0) is + begin + fl_shared_image_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (CX), + Interfaces.C.int (CY)); + end Draw; + + + procedure Draw + (This : in Shared_Image; + X, Y : in Integer) is + begin + fl_shared_image_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw; + + +end FLTK.Images.Shared; + + diff --git a/body/fltk-images-tiled.adb b/body/fltk-images-tiled.adb new file mode 100644 index 0000000..cb0d935 --- /dev/null +++ b/body/fltk-images-tiled.adb @@ -0,0 +1,257 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Images.Tiled is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_tiled_image + (T : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_tiled_image, "new_fl_tiled_image"); + pragma Inline (new_fl_tiled_image); + + procedure free_fl_tiled_image + (T : in Storage.Integer_Address); + pragma Import (C, free_fl_tiled_image, "free_fl_tiled_image"); + pragma Inline (free_fl_tiled_image); + + + + + -- Copying -- + + function fl_tiled_image_copy + (T : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_tiled_image_copy, "fl_tiled_image_copy"); + pragma Inline (fl_tiled_image_copy); + + function fl_tiled_image_copy2 + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_tiled_image_copy2, "fl_tiled_image_copy2"); + pragma Inline (fl_tiled_image_copy2); + + + + + -- Miscellaneous -- + + function fl_tiled_image_get_image + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_tiled_image_get_image, "fl_tiled_image_get_image"); + pragma Inline (fl_tiled_image_get_image); + + + + + -- Colors -- + + procedure fl_tiled_image_color_average + (T : in Storage.Integer_Address; + C : in Interfaces.C.int; + B : in Interfaces.C.C_float); + pragma Import (C, fl_tiled_image_color_average, "fl_tiled_image_color_average"); + pragma Inline (fl_tiled_image_color_average); + + procedure fl_tiled_image_desaturate + (T : in Storage.Integer_Address); + pragma Import (C, fl_tiled_image_desaturate, "fl_tiled_image_desaturate"); + pragma Inline (fl_tiled_image_desaturate); + + + + + -- Drawing -- + + procedure fl_tiled_image_draw + (T : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_tiled_image_draw, "fl_tiled_image_draw"); + pragma Inline (fl_tiled_image_draw); + + procedure fl_tiled_image_draw2 + (T : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + CX, CY : in Interfaces.C.int); + pragma Import (C, fl_tiled_image_draw2, "fl_tiled_image_draw2"); + pragma Inline (fl_tiled_image_draw2); + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out Tiled_Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_tiled_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (From : in out Image'Class; + W, H : in Integer := 0) + return Tiled_Image is + begin + return This : Tiled_Image do + This.Void_Ptr := new_fl_tiled_image + (From.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + This.Dummy.Void_Ptr := fl_tiled_image_get_image (This.Void_Ptr); + This.Dummy.Needs_Dealloc := False; + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + + function Copy + (This : in Tiled_Image; + Width, Height : in Natural) + return Tiled_Image'Class is + begin + return Copied : Tiled_Image do + Copied.Void_Ptr := fl_tiled_image_copy + (This.Void_Ptr, + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + Copied.Dummy.Void_Ptr := fl_tiled_image_get_image (Copied.Void_Ptr); + Copied.Dummy.Needs_Dealloc := False; + end return; + end Copy; + + + function Copy + (This : in Tiled_Image) + return Tiled_Image'Class is + begin + return Copied : Tiled_Image do + Copied.Void_Ptr := fl_tiled_image_copy2 (This.Void_Ptr); + Copied.Dummy.Void_Ptr := fl_tiled_image_get_image (Copied.Void_Ptr); + Copied.Dummy.Needs_Dealloc := False; + end return; + end Copy; + + + + + -- Miscellaneous -- + + procedure Inactive + (This : in out Tiled_Image) is + begin + This.Dummy.Void_Ptr := fl_tiled_image_get_image (This.Void_Ptr); + This.Dummy.Needs_Dealloc := False; + Image (This).Inactive; + end Inactive; + + + function Tile + (This : in out Tiled_Image) + return Image_Reference is + begin + return (Data => This.Dummy'Unchecked_Access); + end Tile; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Tiled_Image; + Hue : in Color; + Amount : in Blend) is + begin + This.Dummy.Void_Ptr := fl_tiled_image_get_image (This.Void_Ptr); + This.Dummy.Needs_Dealloc := False; + fl_tiled_image_color_average + (This.Void_Ptr, + Interfaces.C.int (Hue), + Interfaces.C.C_float (Amount)); + end Color_Average; + + + procedure Desaturate + (This : in out Tiled_Image) is + begin + This.Dummy.Void_Ptr := fl_tiled_image_get_image (This.Void_Ptr); + This.Dummy.Needs_Dealloc := False; + fl_tiled_image_desaturate (This.Void_Ptr); + end Desaturate; + + + + + -- Drawing -- + + procedure Draw + (This : in Tiled_Image; + X, Y : in Integer) is + begin + fl_tiled_image_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw; + + + procedure Draw + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer) is + begin + fl_tiled_image_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); + end Draw; + + +end FLTK.Images.Tiled; + + diff --git a/body/fltk-images.adb b/body/fltk-images.adb new file mode 100644 index 0000000..3d5dce7 --- /dev/null +++ b/body/fltk-images.adb @@ -0,0 +1,410 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Images is + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_image_err_no_image : constant Interfaces.C.int; + pragma Import (C, fl_image_err_no_image, "fl_image_err_no_image"); + + fl_image_err_file_access : constant Interfaces.C.int; + pragma Import (C, fl_image_err_file_access, "fl_image_err_file_access"); + + fl_image_err_format : constant Interfaces.C.int; + pragma Import (C, fl_image_err_format, "fl_image_err_format"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_image + (W, H, D : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_image, "new_fl_image"); + pragma Inline (new_fl_image); + + procedure free_fl_image + (I : in Storage.Integer_Address); + pragma Import (C, free_fl_image, "free_fl_image"); + pragma Inline (free_fl_image); + + + + + -- Errors -- + + function fl_image_fail + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_fail, "fl_image_fail"); + + + + + -- Copying -- + + function fl_image_get_rgb_scaling + return Interfaces.C.int; + pragma Import (C, fl_image_get_rgb_scaling, "fl_image_get_rgb_scaling"); + pragma Inline (fl_image_get_rgb_scaling); + + procedure fl_image_set_rgb_scaling + (T : in Interfaces.C.int); + pragma Import (C, fl_image_set_rgb_scaling, "fl_image_set_rgb_scaling"); + pragma Inline (fl_image_set_rgb_scaling); + + function fl_image_copy + (I : in Storage.Integer_Address; + W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_image_copy, "fl_image_copy"); + pragma Inline (fl_image_copy); + + function fl_image_copy2 + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_copy2, "fl_image_copy2"); + pragma Inline (fl_image_copy2); + + + + + -- Colors -- + + procedure fl_image_color_average + (I : in Storage.Integer_Address; + C : in Interfaces.C.int; + B : in Interfaces.C.C_float); + pragma Import (C, fl_image_color_average, "fl_image_color_average"); + pragma Inline (fl_image_color_average); + + procedure fl_image_desaturate + (I : in Storage.Integer_Address); + pragma Import (C, fl_image_desaturate, "fl_image_desaturate"); + pragma Inline (fl_image_desaturate); + + + + + -- Activity -- + + procedure fl_image_inactive + (I : in Storage.Integer_Address); + pragma Import (C, fl_image_inactive, "fl_image_inactive"); + pragma Inline (fl_image_inactive); + + procedure fl_image_uncache + (I : in Storage.Integer_Address); + pragma Import (C, fl_image_uncache, "fl_image_uncache"); + pragma Inline (fl_image_uncache); + + + + + -- Dimensions -- + + function fl_image_w + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_w, "fl_image_w"); + pragma Inline (fl_image_w); + + function fl_image_h + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_h, "fl_image_h"); + pragma Inline (fl_image_h); + + function fl_image_d + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_d, "fl_image_d"); + pragma Inline (fl_image_d); + + function fl_image_ld + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_ld, "fl_image_ld"); + pragma Inline (fl_image_ld); + + + + + -- Drawing -- + + procedure fl_image_draw + (I : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_image_draw, "fl_image_draw"); + pragma Inline (fl_image_draw); + + procedure fl_image_draw2 + (I : in Storage.Integer_Address; + X, Y, W, H, CX, CY : in Interfaces.C.int); + pragma Import (C, fl_image_draw2, "fl_image_draw2"); + pragma Inline (fl_image_draw2); + + procedure fl_image_draw_empty + (I : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_image_draw_empty, "fl_image_draw_empty"); + pragma Inline (fl_image_draw_empty); + + + + + ------------------------ + -- Internal Utility -- + ------------------------ + + procedure Raise_Fail_Errors + (This : in Image'Class) + is + Result : constant Interfaces.C.int := fl_image_fail (This.Void_Ptr); + begin + if Result = fl_image_err_no_image and This.Is_Empty then + raise No_Image_Error; + elsif Result = fl_image_err_file_access then + raise File_Access_Error; + elsif Result = fl_image_err_format then + raise Format_Error; + end if; + end Raise_Fail_Errors; + + + + + ------------------- + -- Destructors -- + ------------------- + + overriding procedure Finalize + (This : in out Image) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_image (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Width, Height, Depth : in Natural) + return Image is + begin + return This : Image do + This.Void_Ptr := new_fl_image + (Interfaces.C.int (Width), + Interfaces.C.int (Height), + Interfaces.C.int (Depth)); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + + function Get_Copy_Algorithm + return Scaling_Kind is + begin + return Scaling_Kind'Val (fl_image_get_rgb_scaling); + end Get_Copy_Algorithm; + + + procedure Set_Copy_Algorithm + (To : in Scaling_Kind) is + begin + fl_image_set_rgb_scaling (Scaling_Kind'Pos (To)); + end Set_Copy_Algorithm; + + + function Copy + (This : in Image; + Width, Height : in Natural) + return Image'Class is + begin + return Copied : Image do + Copied.Void_Ptr := fl_image_copy + (This.Void_Ptr, + Interfaces.C.int (Width), + Interfaces.C.int (Height)); + end return; + end Copy; + + + function Copy + (This : in Image) + return Image'Class is + begin + return Copied : Image do + Copied.Void_Ptr := fl_image_copy2 (This.Void_Ptr); + end return; + end Copy; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Image; + Col : in Color; + Amount : in Blend) is + begin + fl_image_color_average + (This.Void_Ptr, + Interfaces.C.int (Col), + Interfaces.C.C_float (Amount)); + end Color_Average; + + + procedure Desaturate + (This : in out Image) is + begin + fl_image_desaturate (This.Void_Ptr); + end Desaturate; + + + + + -- Activity -- + + procedure Inactive + (This : in out Image) is + begin + fl_image_inactive (This.Void_Ptr); + end Inactive; + + + function Is_Empty + (This : in Image) + return Boolean is + begin + return fl_image_count (This.Void_Ptr) = 0 or This.Get_W = 0 or This.Get_H = 0; + end Is_Empty; + + + procedure Uncache + (This : in out Image) is + begin + fl_image_uncache (This.Void_Ptr); + end Uncache; + + + + + -- Dimensions -- + + function Get_W + (This : in Image) + return Natural is + begin + return Natural (fl_image_w (This.Void_Ptr)); + end Get_W; + + + function Get_H + (This : in Image) + return Natural is + begin + return Natural (fl_image_h (This.Void_Ptr)); + end Get_H; + + + function Get_D + (This : in Image) + return Natural is + begin + return Natural (fl_image_d (This.Void_Ptr)); + end Get_D; + + + function Get_Line_Size + (This : in Image) + return Natural is + begin + return Natural (fl_image_ld (This.Void_Ptr)); + end Get_Line_Size; + + + + + -- Drawing -- + + procedure Draw + (This : in Image; + X, Y : in Integer) is + begin + fl_image_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw; + + + procedure Draw + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is + begin + fl_image_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); + end Draw; + + + procedure Draw_Empty + (This : in Image; + X, Y : in Integer) is + begin + fl_image_draw_empty + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw_Empty; + + +end FLTK.Images; + + diff --git a/body/fltk-label_draw_marshal.adb b/body/fltk-label_draw_marshal.adb new file mode 100644 index 0000000..c5a2031 --- /dev/null +++ b/body/fltk-label_draw_marshal.adb @@ -0,0 +1,113 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Labels, + FLTK.Registry, + FLTK.Static, + Interfaces.C; + +use type + + FLTK.Static.Label_Draw_Function, + FLTK.Static.Label_Measure_Function; + + +package body FLTK.Label_Draw_Marshal is + + + package Chk renames Ada.Assertions; + + + + + Draw_Array : array (Label_Kind) of FLTK.Static.Label_Draw_Function; + Measure_Array : array (Label_Kind) of FLTK.Static.Label_Measure_Function; + + + + + procedure Label_Draw_Hook + (L : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + A : in Interfaces.Unsigned_16) + with Convention => C; + + procedure Label_Draw_Hook + (L : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + A : in Interfaces.Unsigned_16) + is + My_Label : access FLTK.Labels.Label'Class; + begin + pragma Assert (FLTK.Registry.Label_Store.Contains (L)); + My_Label := FLTK.Registry.Label_Store.Element (L); + Draw_Array (My_Label.Get_Kind) + (My_Label.all, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Alignment (A)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Label_Draw_Hook was handed Label with no back reference to Ada in registry"; + end Label_Draw_Hook; + + + procedure Label_Measure_Hook + (L : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + with Convention => C; + + procedure Label_Measure_Hook + (L : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + is + My_Label : access FLTK.Labels.Label'Class; + begin + pragma Assert (FLTK.Registry.Label_Store.Contains (L)); + My_Label := FLTK.Registry.Label_Store.Element (L); + Measure_Array (My_Label.Get_Kind) + (My_Label.all, + Integer (W), Integer (H)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Label_Measure_Hook was handed Label with no back reference to Ada in registry"; + end Label_Measure_Hook; + + + + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Draw_Function) + return Storage.Integer_Address is + begin + if Func = null then + return Null_Pointer; + end if; + Draw_Array (Kind) := Func; + return Storage.To_Integer (Label_Draw_Hook'Address); + end To_C; + + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Measure_Function) + return Storage.Integer_Address is + begin + if Func = null then + return Null_Pointer; + end if; + Measure_Array (Kind) := Func; + return Storage.To_Integer (Label_Measure_Hook'Address); + end To_C; + + +end FLTK.Label_Draw_Marshal; + + diff --git a/body/fltk-label_draw_marshal.ads b/body/fltk-label_draw_marshal.ads new file mode 100644 index 0000000..77d3885 --- /dev/null +++ b/body/fltk-label_draw_marshal.ads @@ -0,0 +1,28 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Static; + + +private package FLTK.Label_Draw_Marshal is + + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Draw_Function) + return Storage.Integer_Address; + + function To_C + (Kind : in Label_Kind; + Func : in FLTK.Static.Label_Measure_Function) + return Storage.Integer_Address; + + +end FLTK.Label_Draw_Marshal; + + diff --git a/body/fltk-labels.adb b/body/fltk-labels.adb new file mode 100644 index 0000000..1cbf6fc --- /dev/null +++ b/body/fltk-labels.adb @@ -0,0 +1,389 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Registry, + Interfaces.C.Strings; + +use type + + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Labels is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_label + (V : in Interfaces.C.Strings.chars_ptr; + F : in Interfaces.C.int; + S : in Interfaces.C.int; + H : in Interfaces.C.unsigned; + K : in Interfaces.C.int; + P : in Interfaces.C.unsigned) + return Storage.Integer_Address; + pragma Import (C, new_fl_label, "new_fl_label"); + pragma Inline (new_fl_label); + + procedure free_fl_label + (L : in Storage.Integer_Address); + pragma Import (C, free_fl_label, "free_fl_label"); + pragma Inline (free_fl_label); + + + + + -- Attributes -- + + function fl_label_get_value + (L : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_label_get_value, "fl_label_get_value"); + pragma Inline (fl_label_get_value); + + procedure fl_label_set_value + (L : in Storage.Integer_Address; + V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_label_set_value, "fl_label_set_value"); + pragma Inline (fl_label_set_value); + + function fl_label_get_font + (L : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_label_get_font, "fl_label_get_font"); + pragma Inline (fl_label_get_font); + + procedure fl_label_set_font + (L : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_label_set_font, "fl_label_set_font"); + pragma Inline (fl_label_set_font); + + function fl_label_get_size + (L : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_label_get_size, "fl_label_get_size"); + pragma Inline (fl_label_get_size); + + procedure fl_label_set_size + (L : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_label_set_size, "fl_label_set_size"); + pragma Inline (fl_label_set_size); + + function fl_label_get_color + (L : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_label_get_color, "fl_label_get_color"); + pragma Inline (fl_label_get_color); + + procedure fl_label_set_color + (L : in Storage.Integer_Address; + H : in Interfaces.C.unsigned); + pragma Import (C, fl_label_set_color, "fl_label_set_color"); + pragma Inline (fl_label_set_color); + + function fl_label_get_type + (L : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_label_get_type, "fl_label_get_type"); + pragma Inline (fl_label_get_type); + + procedure fl_label_set_type + (L : in Storage.Integer_Address; + K : in Interfaces.C.int); + pragma Import (C, fl_label_set_type, "fl_label_set_type"); + pragma Inline (fl_label_set_type); + + function fl_label_get_align + (L : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_label_get_align, "fl_label_get_align"); + pragma Inline (fl_label_get_align); + + procedure fl_label_set_align + (L : in Storage.Integer_Address; + P : in Interfaces.C.unsigned); + pragma Import (C, fl_label_set_align, "fl_label_set_align"); + pragma Inline (fl_label_set_align); + + procedure fl_label_set_image + (L, I : in Storage.Integer_Address); + pragma Import (C, fl_label_set_image, "fl_label_set_image"); + pragma Inline (fl_label_set_image); + + procedure fl_label_set_deimage + (L, I : in Storage.Integer_Address); + pragma Import (C, fl_label_set_deimage, "fl_label_set_deimage"); + pragma Inline (fl_label_set_deimage); + + + + + -- Drawing -- + + procedure fl_label_draw + (L : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + P : in Interfaces.C.unsigned); + pragma Import (C, fl_label_draw, "fl_label_draw"); + pragma Inline (fl_label_draw); + + procedure fl_label_measure + (L : in Storage.Integer_Address; + W, H : out Interfaces.C.int); + pragma Import (C, fl_label_measure, "fl_label_measure"); + pragma Inline (fl_label_measure); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Label) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + FLTK.Registry.Label_Store.Delete (This.Void_Ptr); + free_fl_label (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + Interfaces.C.Strings.Free (This.My_Text); + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Value : in String; + Font : in Font_Kind := Helvetica; + Size : in Font_Size := Normal_Size; + Hue : in Color := Foreground_Color; + Kind : in Label_Kind := Normal_Label; + Place : in Alignment := Align_Center; + Active : access FLTK.Images.Image'Class := null; + Inactive : access FLTK.Images.Image'Class := null) + return Label is + begin + return This : Label do + This.My_Text := Interfaces.C.Strings.New_String (Value); + This.Void_Ptr := new_fl_label + (This.My_Text, -- Interfaces.C.Strings.chars_ptr + Font_Kind'Pos (Font), -- Interfaces.C.int + Interfaces.C.int (Size), + Interfaces.C.unsigned (Hue), + Label_Kind'Pos (Kind), -- Interfaces.C.int + Interfaces.C.unsigned (Place)); + This.Set_Active (Active); + This.Set_Inactive (Inactive); + FLTK.Registry.Label_Store.Insert (This.Void_Ptr, This'Unchecked_Access); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + + function Get_Value + (This : in Label) + return String + is + Text : constant Interfaces.C.Strings.chars_ptr := fl_label_get_value (This.Void_Ptr); + begin + if Text = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Text); + end if; + end Get_Value; + + + procedure Set_Value + (This : in out Label; + Text : in String) is + begin + Interfaces.C.Strings.Free (This.My_Text); + This.My_Text := Interfaces.C.Strings.New_String (Text); + fl_label_set_value (This.Void_Ptr, This.My_Text); + end Set_Value; + + + function Get_Font + (This : in Label) + return Font_Kind is + begin + return Font_Kind'Val (fl_label_get_font (This.Void_Ptr)); + end Get_Font; + + + procedure Set_Font + (This : in out Label; + Font : in Font_Kind) is + begin + fl_label_set_font (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Font; + + + function Get_Size + (This : in Label) + return Font_Size is + begin + return Font_Size (fl_label_get_size (This.Void_Ptr)); + end Get_Size; + + + procedure Set_Size + (This : in out Label; + Size : in Font_Size) is + begin + fl_label_set_size (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Size; + + + function Get_Color + (This : in Label) + return Color is + begin + return Color (fl_label_get_color (This.Void_Ptr)); + end Get_Color; + + + procedure Set_Color + (This : in out Label; + Hue : in Color) is + begin + fl_label_set_color (This.Void_Ptr, Interfaces.C.unsigned (Hue)); + end Set_Color; + + + function Get_Kind + (This : in Label) + return Label_Kind is + begin + return Label_Kind'Val (fl_label_get_type (This.Void_Ptr)); + end Get_Kind; + + + procedure Set_Kind + (This : in out Label; + Kind : in Label_Kind) is + begin + fl_label_set_type (This.Void_Ptr, Label_Kind'Pos (Kind)); + end Set_Kind; + + + function Get_Alignment + (This : in Label) + return Alignment is + begin + return Alignment (fl_label_get_align (This.Void_Ptr)); + end Get_Alignment; + + + procedure Set_Alignment + (This : in out Label; + Place : in Alignment) is + begin + fl_label_set_align (This.Void_Ptr, Interfaces.C.unsigned (Place)); + end Set_Alignment; + + + function Get_Active + (This : in Label) + return access FLTK.Images.Image'Class is + begin + return This.My_Active; + end Get_Active; + + + procedure Set_Active + (This : in out Label; + Pic : access FLTK.Images.Image'Class) is + begin + if Pic /= null then + fl_label_set_image (This.Void_Ptr, Wrapper (Pic.all).Void_Ptr); + else + fl_label_set_image (This.Void_Ptr, Null_Pointer); + end if; + This.My_Active := Pic; + end Set_Active; + + + function Get_Inactive + (This : in Label) + return access FLTK.Images.Image'Class is + begin + return This.My_Inactive; + end Get_Inactive; + + + procedure Set_Inactive + (This : in out Label; + Pic : access FLTK.Images.Image'Class) is + begin + if Pic /= null then + fl_label_set_deimage (This.Void_Ptr, Wrapper (Pic.all).Void_Ptr); + else + fl_label_set_deimage (This.Void_Ptr, Null_Pointer); + end if; + This.My_Inactive := Pic; + end Set_Inactive; + + + + + -- Drawing -- + + procedure Draw + (This : in out Label; + X, Y, W, H : in Integer; + Place : in Alignment) is + begin + fl_label_draw + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Place)); + end Draw; + + + procedure Measure + (This : in Label; + W, H : out Integer) is + begin + fl_label_measure + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Measure; + + +end FLTK.Labels; + + diff --git a/body/fltk-menu_items.adb b/body/fltk-menu_items.adb new file mode 100644 index 0000000..d75dd4a --- /dev/null +++ b/body/fltk-menu_items.adb @@ -0,0 +1,646 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widget_Callback_Conversions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Menu_Items is + + + package Callback_Convert renames FLTK.Widget_Callback_Conversions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_menu_item + (T : in Interfaces.C.char_array; + C : in Storage.Integer_Address; + S, F : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu_item, "new_fl_menu_item"); + pragma Inline (new_fl_menu_item); + + procedure free_fl_menu_item + (MI : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_item, "free_fl_menu_item"); + pragma Inline (free_fl_menu_item); + + + + + -- Callback -- + + function fl_menu_item_get_user_data + (MI : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_item_get_user_data, "fl_menu_item_get_user_data"); + pragma Inline (fl_menu_item_get_user_data); + + procedure fl_menu_item_set_callback + (MI, C : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_set_callback, "fl_menu_item_set_callback"); + pragma Inline (fl_menu_item_set_callback); + + procedure fl_menu_item_do_callback + (MI, W : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_do_callback, "fl_menu_item_do_callback"); + pragma Inline (fl_menu_item_do_callback); + + + + + -- Settings -- + + function fl_menu_item_checkbox + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_checkbox, "fl_menu_item_checkbox"); + pragma Inline (fl_menu_item_checkbox); + + function fl_menu_item_radio + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_radio, "fl_menu_item_radio"); + pragma Inline (fl_menu_item_radio); + + function fl_menu_item_submenu + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_submenu, "fl_menu_item_submenu"); + pragma Inline (fl_menu_item_submenu); + + function fl_menu_item_value + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_value, "fl_menu_item_value"); + pragma Inline (fl_menu_item_value); + + procedure fl_menu_item_set + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_set, "fl_menu_item_set"); + pragma Inline (fl_menu_item_set); + + procedure fl_menu_item_clear + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_clear, "fl_menu_item_clear"); + pragma Inline (fl_menu_item_clear); + + procedure fl_menu_item_setonly + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_setonly, "fl_menu_item_setonly"); + pragma Inline (fl_menu_item_setonly); + + + + + -- Label -- + + function fl_menu_item_get_label + (MI : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_menu_item_get_label, "fl_menu_item_get_label"); + pragma Inline (fl_menu_item_get_label); + + procedure fl_menu_item_set_label + (MI : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_item_set_label, "fl_menu_item_set_label"); + pragma Inline (fl_menu_item_set_label); + + procedure fl_menu_item_set_label2 + (MI : in Storage.Integer_Address; + K : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_item_set_label2, "fl_menu_item_set_label2"); + pragma Inline (fl_menu_item_set_label2); + + function fl_menu_item_get_labelcolor + (MI : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_menu_item_get_labelcolor, "fl_menu_item_get_labelcolor"); + pragma Inline (fl_menu_item_get_labelcolor); + + procedure fl_menu_item_set_labelcolor + (MI : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_menu_item_set_labelcolor, "fl_menu_item_set_labelcolor"); + pragma Inline (fl_menu_item_set_labelcolor); + + function fl_menu_item_get_labelfont + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_labelfont, "fl_menu_item_get_labelfont"); + pragma Inline (fl_menu_item_get_labelfont); + + procedure fl_menu_item_set_labelfont + (MI : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_labelfont, "fl_menu_item_set_labelfont"); + pragma Inline (fl_menu_item_set_labelfont); + + function fl_menu_item_get_labelsize + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_labelsize, "fl_menu_item_get_labelsize"); + pragma Inline (fl_menu_item_get_labelsize); + + procedure fl_menu_item_set_labelsize + (MI : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_labelsize, "fl_menu_item_set_labelsize"); + pragma Inline (fl_menu_item_set_labelsize); + + function fl_menu_item_get_labeltype + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_labeltype, "fl_menu_item_get_labeltype"); + pragma Inline (fl_menu_item_get_labeltype); + + procedure fl_menu_item_set_labeltype + (MI : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_labeltype, "fl_menu_item_set_labeltype"); + pragma Inline (fl_menu_item_set_labeltype); + + + + + -- Shortcut and Flags -- + + function fl_menu_item_get_shortcut + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_shortcut, "fl_menu_item_get_shortcut"); + pragma Inline (fl_menu_item_get_shortcut); + + procedure fl_menu_item_set_shortcut + (MI : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_shortcut, "fl_menu_item_set_shortcut"); + pragma Inline (fl_menu_item_set_shortcut); + + function fl_menu_item_get_flags + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_flags, "fl_menu_item_get_flags"); + pragma Inline (fl_menu_item_get_flags); + + procedure fl_menu_item_set_flags + (MI : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_flags, "fl_menu_item_set_flags"); + pragma Inline (fl_menu_item_set_flags); + + + + + -- Image -- + + procedure fl_menu_item_image + (MI, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_image, "fl_menu_item_image"); + pragma Inline (fl_menu_item_image); + + + + + -- Activity and Visibility -- + + procedure fl_menu_item_activate + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_activate, "fl_menu_item_activate"); + pragma Inline (fl_menu_item_activate); + + procedure fl_menu_item_deactivate + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_deactivate, "fl_menu_item_deactivate"); + pragma Inline (fl_menu_item_deactivate); + + procedure fl_menu_item_show + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_show, "fl_menu_item_show"); + pragma Inline (fl_menu_item_show); + + procedure fl_menu_item_hide + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_hide, "fl_menu_item_hide"); + pragma Inline (fl_menu_item_hide); + + function fl_menu_item_active + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_active, "fl_menu_item_active"); + pragma Inline (fl_menu_item_active); + + function fl_menu_item_visible + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_visible, "fl_menu_item_visible"); + pragma Inline (fl_menu_item_visible); + + function fl_menu_item_activevisible + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_activevisible, "fl_menu_item_activevisible"); + pragma Inline (fl_menu_item_activevisible); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Menu_Item) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_menu_item (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Text : in String; + Action : in FLTK.Widgets.Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Menu_Item is + begin + return This : Menu_Item do + This.Void_Ptr := new_fl_menu_item + (Interfaces.C.To_C (Text), + Callback_Convert.To_Address (Action), + Interfaces.C.int (To_C (Shortcut)), + MFlag_To_Cint (Flags)); + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Callback -- + + function Get_Callback + (This : in Menu_Item) + return FLTK.Widgets.Widget_Callback is + begin + return Callback_Convert.To_Access (fl_menu_item_get_user_data (This.Void_Ptr)); + end Get_Callback; + + + procedure Set_Callback + (This : in out Menu_Item; + Func : in FLTK.Widgets.Widget_Callback) is + begin + -- Coordinating callback vs userdata is done in C++ + fl_menu_item_set_callback + (This.Void_Ptr, + Callback_Convert.To_Address (Func)); + end Set_Callback; + + + procedure Do_Callback + (This : in out Menu_Item; + Widget : in out FLTK.Widgets.Widget'Class) is + begin + fl_menu_item_do_callback (This.Void_Ptr, Wrapper (Widget).Void_Ptr); + end Do_Callback; + + + + + -- Settings -- + + function Has_Checkbox + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_checkbox (This.Void_Ptr) /= 0; + end Has_Checkbox; + + + function Is_Radio + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_radio (This.Void_Ptr) /= 0; + end Is_Radio; + + + function Is_Submenu + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_submenu (This.Void_Ptr) /= 0; + end Is_Submenu; + + + function Get_State + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_value (This.Void_Ptr) /= 0; + end Get_State; + + + procedure Set_State + (This : in out Menu_Item; + To : in Boolean) is + begin + if To then + fl_menu_item_set (This.Void_Ptr); + else + fl_menu_item_clear (This.Void_Ptr); + end if; + end Set_State; + + + procedure Set + (This : in out Menu_Item) is + begin + fl_menu_item_set (This.Void_Ptr); + end Set; + + + procedure Clear + (This : in out Menu_Item) is + begin + fl_menu_item_clear (This.Void_Ptr); + end Clear; + + + procedure Set_Only + (This : in out Menu_Item) is + begin + fl_menu_item_setonly (This.Void_Ptr); + end Set_Only; + + + + + -- Label -- + + function Get_Label + (This : in Menu_Item) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Label; + + + procedure Set_Label + (This : in out Menu_Item; + Text : in String) is + begin + fl_menu_item_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Label + (This : in out Menu_Item; + Kind : in Label_Kind; + Text : in String) is + begin + fl_menu_item_set_label2 (This.Void_Ptr, Label_Kind'Pos (Kind), Interfaces.C.To_C (Text)); + end Set_Label; + + + function Get_Label_Color + (This : in Menu_Item) + return Color is + begin + return Color (fl_menu_item_get_labelcolor (This.Void_Ptr)); + end Get_Label_Color; + + + procedure Set_Label_Color + (This : in out Menu_Item; + To : in Color) is + begin + fl_menu_item_set_labelcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Label_Color; + + + function Get_Label_Font + (This : in Menu_Item) + return Font_Kind + is + Result : constant Interfaces.C.int := fl_menu_item_get_labelfont (This.Void_Ptr); + begin + return Font_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labelfont returned unexpected Font value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Font; + + + procedure Set_Label_Font + (This : in out Menu_Item; + To : in Font_Kind) is + begin + fl_menu_item_set_labelfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Label_Font; + + + function Get_Label_Size + (This : in Menu_Item) + return Font_Size + is + Result : constant Interfaces.C.int := fl_menu_item_get_labelsize (This.Void_Ptr); + begin + return Font_Size (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labelsize returned unexpected Size value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Size; + + + procedure Set_Label_Size + (This : in out Menu_Item; + To : in Font_Size) is + begin + fl_menu_item_set_labelsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Label_Size; + + + function Get_Label_Kind + (This : in Menu_Item) + return Label_Kind + is + Result : constant Interfaces.C.int := fl_menu_item_get_labeltype (This.Void_Ptr); + begin + return Label_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labeltype returned unexpected Kind value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Kind; + + + procedure Set_Label_Kind + (This : in out Menu_Item; + To : in Label_Kind) is + begin + fl_menu_item_set_labeltype (This.Void_Ptr, Label_Kind'Pos (To)); + end Set_Label_Kind; + + + + + -- Shortcut and Flags -- + + function Get_Shortcut + (This : in Menu_Item) + return Key_Combo is + begin + return To_Ada (Interfaces.C.unsigned (fl_menu_item_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Menu_Item; + To : in Key_Combo) is + begin + fl_menu_item_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); + end Set_Shortcut; + + + function Get_Flags + (This : in Menu_Item) + return Menu_Flag is + begin + return Cint_To_MFlag (fl_menu_item_get_flags (This.Void_Ptr)); + end Get_Flags; + + + procedure Set_Flags + (This : in out Menu_Item; + To : in Menu_Flag) is + begin + fl_menu_item_set_flags (This.Void_Ptr, MFlag_To_Cint (To)); + end Set_Flags; + + + + + -- Image -- + + function Get_Image + (This : in Menu_Item) + return access FLTK.Images.Image'Class is + begin + return This.Current_Image; + end Get_Image; + + + procedure Set_Image + (This : in out Menu_Item; + Pict : in out FLTK.Images.Image'Class) is + begin + fl_menu_item_image (This.Void_Ptr, Wrapper (Pict).Void_Ptr); + This.Current_Image := Pict'Unchecked_Access; + end Set_Image; + + + + + -- Activity and Visibility -- + + procedure Activate + (This : in out Menu_Item) is + begin + fl_menu_item_activate (This.Void_Ptr); + end Activate; + + + procedure Deactivate + (This : in out Menu_Item) is + begin + fl_menu_item_deactivate (This.Void_Ptr); + end Deactivate; + + + procedure Show + (This : in out Menu_Item) is + begin + fl_menu_item_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Menu_Item) is + begin + fl_menu_item_hide (This.Void_Ptr); + end Hide; + + + function Is_Active + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_active (This.Void_Ptr) /= 0; + end Is_Active; + + + function Is_Visible + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_visible (This.Void_Ptr) /= 0; + end Is_Visible; + + + function Is_Active_And_Visible + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_activevisible (This.Void_Ptr) /= 0; + end Is_Active_And_Visible; + + +end FLTK.Menu_Items; + + diff --git a/body/fltk-pixmap_marshal.adb b/body/fltk-pixmap_marshal.adb new file mode 100644 index 0000000..966e29b --- /dev/null +++ b/body/fltk-pixmap_marshal.adb @@ -0,0 +1,98 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Strings.Fixed, + Ada.Strings.Unbounded, + Ada.Unchecked_Deallocation, + FLTK.Images.Pixmaps; + + +package body FLTK.Pixmap_Marshal is + + + package SU renames Ada.Strings.Unbounded; + package Pix renames FLTK.Images.Pixmaps; + package C renames Interfaces.C; + package CS renames Interfaces.C.Strings; + + + + + function To_Coltype + (Value : in Pix.Color_Kind) + return Character is + begin + case Value is + when Pix.Colorful => return 'c'; + when Pix.Monochrome => return 'm'; + when Pix.Greyscale => return 'g'; + when Pix.Symbolic => return 's'; + end case; + end To_Coltype; + + + + + function Marshal_Data + (Values : in Pix.Header; + Colors : in Pix.Color_Definition_Array; + Pixels : in Pix.Pixmap_Data) + return chars_ptr_array_access + is + C_Data : constant chars_ptr_array_access := new CS.chars_ptr_array + (1 .. C.size_t (1 + Colors'Length + Pixels'Length (1))); + begin + -- Header values line + C_Data (1) := CS.New_String (Ada.Strings.Fixed.Trim + ((Positive'Image (Values.Width) & Positive'Image (Values.Height) & + Positive'Image (Values.Colors) & Positive'Image (Values.Per_Pixel)), + Ada.Strings.Left)); + + -- Color definition lines + for Place in 1 .. Colors'Length loop + C_Data (C.size_t (Place + 1)) := CS.New_String + (SU.To_String (Colors (Colors'First + Place - 1).Name) & " " & + To_Coltype (Colors (Colors'First + Place - 1).Kind) & " " & + SU.To_String (Colors (Colors'First + Place - 1).Value)); + end loop; + + -- Pixel data lines + for Place in 1 .. Pixels'Length (1) loop + declare + Line : String (1 .. Pixels'Length (2)); + for Line'Address use Pixels (Pixels'First (1) + Place - 1, 1)'Address; + pragma Import (Ada, Line); + begin + C_Data (C.size_t (Place + 1 + Colors'Length)) := CS.New_String (Line); + end; + end loop; + + return C_Data; + end Marshal_Data; + + + + + procedure Free is new Ada.Unchecked_Deallocation + (Interfaces.C.Strings.chars_ptr_array, chars_ptr_array_access); + + procedure Free_Recursive + (This : in out chars_ptr_array_access) is + begin + if This /= null then + for Item of This.all loop + CS.Free (Item); + end loop; + Free (This); + end if; + end Free_Recursive; + + +end FLTK.Pixmap_Marshal; + + diff --git a/body/fltk-pixmap_marshal.ads b/body/fltk-pixmap_marshal.ads new file mode 100644 index 0000000..d12b0f8 --- /dev/null +++ b/body/fltk-pixmap_marshal.ads @@ -0,0 +1,44 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Images.Pixmaps; + +with + + Interfaces.C.Strings; + + +private package FLTK.Pixmap_Marshal is + + + type chars_ptr_array_access is access all Interfaces.C.Strings.chars_ptr_array; + + + + + -- From Ada to C char * -- + + -- Note the resulting chars_ptr_array_access must be deallocated manually. + + function To_Coltype + (Value : in FLTK.Images.Pixmaps.Color_Kind) + return Character; + + function Marshal_Data + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data) + return chars_ptr_array_access; + + procedure Free_Recursive + (This : in out chars_ptr_array_access); + + +end FLTK.Pixmap_Marshal; + + diff --git a/body/fltk-registry.ads b/body/fltk-registry.ads new file mode 100644 index 0000000..9911925 --- /dev/null +++ b/body/fltk-registry.ads @@ -0,0 +1,32 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Containers.Ordered_Maps, + FLTK.Labels; + + +private package FLTK.Registry is + + + -- It finally became untenable to keep only ad hoc back-references to Ada + -- when some crucial structs and objects don't have handy built-in space + -- for user data already available. + + + type Label_Access is access all FLTK.Labels.Label'Class; + + package Label_Backref_Maps is new Ada.Containers.Ordered_Maps + (Key_Type => Storage.Integer_Address, + Element_Type => Label_Access); + + Label_Store : Label_Backref_Maps.Map; + + +end FLTK.Registry; + + diff --git a/body/fltk-screen.adb b/body/fltk-screen.adb new file mode 100644 index 0000000..6b8118e --- /dev/null +++ b/body/fltk-screen.adb @@ -0,0 +1,404 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Screen is + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_mode_rgb : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb, "fl_enum_mode_rgb"); + + fl_enum_mode_rgb8 : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_rgb8, "fl_enum_mode_rgb8"); + + fl_enum_mode_double : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_double, "fl_enum_mode_double"); + + fl_enum_mode_index : constant Interfaces.C.int; + pragma Import (C, fl_enum_mode_index, "fl_enum_mode_index"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Environment -- + + procedure fl_screen_display + (V : in Interfaces.C.char_array); + pragma Import (C, fl_screen_display, "fl_screen_display"); + pragma Inline (fl_screen_display); + + function fl_screen_visual + (F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_screen_visual, "fl_screen_visual"); + pragma Inline (fl_screen_visual); + + + + + -- Basic Dimensions -- + + function fl_screen_x + return Interfaces.C.int; + pragma Import (C, fl_screen_x, "fl_screen_x"); + pragma Inline (fl_screen_x); + + function fl_screen_y + return Interfaces.C.int; + pragma Import (C, fl_screen_y, "fl_screen_y"); + pragma Inline (fl_screen_y); + + function fl_screen_w + return Interfaces.C.int; + pragma Import (C, fl_screen_w, "fl_screen_w"); + pragma Inline (fl_screen_w); + + function fl_screen_h + return Interfaces.C.int; + pragma Import (C, fl_screen_h, "fl_screen_h"); + pragma Inline (fl_screen_h); + + + + + -- Pixel Density -- + + function fl_screen_count + return Interfaces.C.int; + pragma Import (C, fl_screen_count, "fl_screen_count"); + pragma Inline (fl_screen_count); + + procedure fl_screen_dpi + (H, V : out Interfaces.C.C_float; + N : in Interfaces.C.int); + pragma Import (C, fl_screen_dpi, "fl_screen_dpi"); + pragma Inline (fl_screen_dpi); + + + + + -- Position Lookup -- + + function fl_screen_num + (X, Y : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_screen_num, "fl_screen_num"); + pragma Inline (fl_screen_num); + + function fl_screen_num2 + (X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_screen_num2, "fl_screen_num2"); + pragma Inline (fl_screen_num2); + + + + + -- Bounding Boxes -- + + procedure fl_screen_work_area + (X, Y, W, H : out Interfaces.C.int; + PX, PY : in Interfaces.C.int); + pragma Import (C, fl_screen_work_area, "fl_screen_work_area"); + pragma Inline (fl_screen_work_area); + + procedure fl_screen_work_area2 + (X, Y, W, H : out Interfaces.C.int; + N : in Interfaces.C.int); + pragma Import (C, fl_screen_work_area2, "fl_screen_work_area2"); + pragma Inline (fl_screen_work_area2); + + procedure fl_screen_work_area3 + (X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_screen_work_area3, "fl_screen_work_area3"); + pragma Inline (fl_screen_work_area3); + + procedure fl_screen_xywh + (X, Y, W, H : out Interfaces.C.int; + PX, PY : in Interfaces.C.int); + pragma Import (C, fl_screen_xywh, "fl_screen_xywh"); + pragma Inline (fl_screen_xywh); + + procedure fl_screen_xywh2 + (X, Y, W, H : out Interfaces.C.int; + N : in Interfaces.C.int); + pragma Import (C, fl_screen_xywh2, "fl_screen_xywh2"); + pragma Inline (fl_screen_xywh2); + + procedure fl_screen_xywh3 + (X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_screen_xywh3, "fl_screen_xywh3"); + pragma Inline (fl_screen_xywh3); + + procedure fl_screen_xywh4 + (X, Y, W, H : out Interfaces.C.int; + PX, PY, PW, PH : in Interfaces.C.int); + pragma Import (C, fl_screen_xywh4, "fl_screen_xywh4"); + pragma Inline (fl_screen_xywh4); + + + + + -- Drawing -- + + function fl_screen_get_damage + return Interfaces.C.int; + pragma Import (C, fl_screen_get_damage, "fl_screen_get_damage"); + pragma Inline (fl_screen_get_damage); + + procedure fl_screen_set_damage + (V : in Interfaces.C.int); + pragma Import (C, fl_screen_set_damage, "fl_screen_set_damage"); + pragma Inline (fl_screen_set_damage); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Environment -- + + procedure Set_Display_String + (Value : in String) is + begin + fl_screen_display (Interfaces.C.To_C (Value)); + end Set_Display_String; + + + procedure Set_Visual_Mode + (Value : in Visual_Mode) + is + Ignore : Boolean := Set_Visual_Mode (Value); + begin + null; + end Set_Visual_Mode; + + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean is + begin + return fl_screen_visual + ((case Value is + when RGB => fl_enum_mode_rgb, + when RGB_24bit => fl_enum_mode_rgb8, + when Double_Buffer => fl_enum_mode_double + fl_enum_mode_index, + when Double_RGB => fl_enum_mode_double + fl_enum_mode_rgb, + when Double_RGB_24bit => fl_enum_mode_double + fl_enum_mode_rgb8)) /= 0; + end Set_Visual_Mode; + + + + + -- Basic Dimensions -- + + function Get_X return Integer is + begin + return Integer (fl_screen_x); + end Get_X; + + + function Get_Y return Integer is + begin + return Integer (fl_screen_y); + end Get_Y; + + + function Get_W return Integer is + begin + return Integer (fl_screen_w); + end Get_W; + + + function Get_H return Integer is + begin + return Integer (fl_screen_h); + end Get_H; + + + + + -- Pixel Density -- + + function Count return Integer is + begin + return Integer (fl_screen_count); + end Count; + + + -- Screen numbers in the range 1 .. Get_Count + procedure DPI + (Horizontal, Vertical : out Float; + Screen_Number : in Integer := 1) is + begin + fl_screen_dpi + (Interfaces.C.C_float (Horizontal), + Interfaces.C.C_float (Vertical), + Interfaces.C.int (Screen_Number) - 1); + end DPI; + + + + + -- Position Lookup -- + + function Containing + (X, Y : in Integer) + return Integer is + begin + return Integer (fl_screen_num + (Interfaces.C.int (X), + Interfaces.C.int (Y))); + end Containing; + + + function Containing + (X, Y, W, H : in Integer) + return Integer is + begin + return Integer (fl_screen_num2 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H))); + end Containing; + + + + + -- Bounding Boxes -- + + procedure Work_Area + (X, Y, W, H : out Integer; + Pos_X, Pos_Y : in Integer) is + begin + fl_screen_work_area + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Pos_X), + Interfaces.C.int (Pos_Y)); + end Work_Area; + + + procedure Work_Area + (X, Y, W, H : out Integer; + Screen_Num : in Integer) is + begin + fl_screen_work_area2 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Screen_Num)); + end Work_Area; + + + procedure Work_Area + (X, Y, W, H : out Integer) is + begin + fl_screen_work_area3 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Work_Area; + + + procedure Bounding_Rect + (X, Y, W, H : out Integer; + Pos_X, Pos_Y : in Integer) is + begin + fl_screen_xywh + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Pos_X), + Interfaces.C.int (Pos_Y)); + end Bounding_Rect; + + + procedure Bounding_Rect + (X, Y, W, H : out Integer; + Screen_Num : in Integer) is + begin + fl_screen_xywh2 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Screen_Num)); + end Bounding_Rect; + + + procedure Bounding_Rect + (X, Y, W, H : out Integer) is + begin + fl_screen_xywh3 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Bounding_Rect; + + + procedure Bounding_Rect + (X, Y, W, H : out Integer; + PX, PY, PW, PH : in Integer) is + begin + fl_screen_xywh4 + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (PX), + Interfaces.C.int (PY), + Interfaces.C.int (PW), + Interfaces.C.int (PH)); + end Bounding_Rect; + + + + + -- Drawing -- + + function Is_Damaged + return Boolean is + begin + return fl_screen_get_damage /= 0; + end Is_Damaged; + + + procedure Set_Damaged + (To : in Boolean) is + begin + fl_screen_set_damage (Boolean'Pos (To)); + end Set_Damaged; + + +end FLTK.Screen; + + diff --git a/body/fltk-static.adb b/body/fltk-static.adb new file mode 100644 index 0000000..663a7c7 --- /dev/null +++ b/body/fltk-static.adb @@ -0,0 +1,1525 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Containers.Vectors, + Interfaces.C.Strings, + System.Address_To_Access_Conversions, + FLTK.Box_Draw_Marshal, + FLTK.Label_Draw_Marshal, + FLTK.Static_Callback_Conversions; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Static is + + + package Chk renames Ada.Assertions; + package Conv renames FLTK.Static_Callback_Conversions; + + + + + ----------------- + -- Operators -- + ----------------- + + type File_Mode_Bitmask is mod 2 ** Interfaces.C.int'Size; + + function FMode_To_Bits is new + Ada.Unchecked_Conversion (File_Mode, File_Mode_Bitmask); + + function Bits_To_FMode is new + Ada.Unchecked_Conversion (File_Mode_Bitmask, File_Mode); + + + function "+" + (Left, Right : in File_Mode) + return File_Mode is + begin + return Bits_To_FMode (FMode_To_Bits (Left) or FMode_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in File_Mode) + return File_Mode is + begin + return Bits_To_FMode (FMode_To_Bits (Left) and not FMode_To_Bits (Right)); + end "-"; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Command Line Arguments -- + + function fl_static_arg + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_arg, "fl_static_arg"); + pragma Inline (fl_static_arg); + + procedure fl_static_args + (C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_static_args, "fl_static_args"); + pragma Inline (fl_static_args); + + function fl_static_args2 + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int; + H : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_args2, "fl_static_args2"); + pragma Inline (fl_static_args2); + + + + + -- Thread Notify -- + + function fl_static_add_awake_handler + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_add_awake_handler, "fl_static_add_awake_handler"); + pragma Inline (fl_static_add_awake_handler); + + function fl_static_get_awake_handler + (H, F : out Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_get_awake_handler, "fl_static_get_awake_handler"); + pragma Inline (fl_static_get_awake_handler); + + function fl_static_awake2 + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_awake2, "fl_static_awake2"); + pragma Inline (fl_static_awake2); + + procedure fl_static_awake + (M : in Storage.Integer_Address); + pragma Import (C, fl_static_awake, "fl_static_awake"); + pragma Inline (fl_static_awake); + + + + + -- Pre-Eventloop Callbacks -- + + procedure fl_static_add_check + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_check, "fl_static_add_check"); + pragma Inline (fl_static_add_check); + + function fl_static_has_check + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_has_check, "fl_static_has_check"); + pragma Inline (fl_static_has_check); + + procedure fl_static_remove_check + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_remove_check, "fl_static_remove_check"); + pragma Inline (fl_static_remove_check); + + + + + -- Timer Callbacks -- + + procedure fl_static_add_timeout + (S : in Interfaces.C.double; + H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_timeout, "fl_static_add_timeout"); + pragma Inline (fl_static_add_timeout); + + function fl_static_has_timeout + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_has_timeout, "fl_static_has_timeout"); + pragma Inline (fl_static_has_timeout); + + procedure fl_static_remove_timeout + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_remove_timeout, "fl_static_remove_timeout"); + pragma Inline (fl_static_remove_timeout); + + procedure fl_static_repeat_timeout + (S : in Interfaces.C.double; + H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_repeat_timeout, "fl_static_repeat_timeout"); + pragma Inline (fl_static_repeat_timeout); + + + + + -- Clipboard Callbacks -- + + procedure fl_static_add_clipboard_notify + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_clipboard_notify, "fl_static_add_clipboard_notify"); + pragma Inline (fl_static_add_clipboard_notify); + + procedure fl_static_remove_clipboard_notify + (H : in Storage.Integer_Address); + pragma Import (C, fl_static_remove_clipboard_notify, "fl_static_remove_clipboard_notify"); + pragma Inline (fl_static_remove_clipboard_notify); + + + + + -- File Descriptor Waiting Callbacks -- + + procedure fl_static_add_fd + (D : in Interfaces.C.int; + H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_fd, "fl_static_add_fd"); + pragma Inline (fl_static_add_fd); + + procedure fl_static_add_fd2 + (D, M : in Interfaces.C.int; + H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_fd2, "fl_static_add_fd2"); + pragma Inline (fl_static_add_fd2); + + procedure fl_static_remove_fd + (D : in Interfaces.C.int); + pragma Import (C, fl_static_remove_fd, "fl_static_remove_fd"); + pragma Inline (fl_static_remove_fd); + + procedure fl_static_remove_fd2 + (D, M : in Interfaces.C.int); + pragma Import (C, fl_static_remove_fd2, "fl_static_remove_fd2"); + pragma Inline (fl_static_remove_fd2); + + + + + -- Idle Callbacks -- + + procedure fl_static_add_idle + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_add_idle, "fl_static_add_idle"); + pragma Inline (fl_static_add_idle); + + function fl_static_has_idle + (H, F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_has_idle, "fl_static_has_idle"); + pragma Inline (fl_static_has_idle); + + procedure fl_static_remove_idle + (H, F : in Storage.Integer_Address); + pragma Import (C, fl_static_remove_idle, "fl_static_remove_idle"); + pragma Inline (fl_static_remove_idle); + + + + + -- Custom Colors -- + + function fl_static_get_color2 + (C : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_color2, "fl_static_get_color2"); + pragma Inline (fl_static_get_color2); + + procedure fl_static_get_color + (C : in Interfaces.C.unsigned; + R, G, B : out Interfaces.C.unsigned_char); + pragma Import (C, fl_static_get_color, "fl_static_get_color"); + pragma Inline (fl_static_get_color); + + procedure fl_static_set_color2 + (T, F : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_color2, "fl_static_set_color2"); + pragma Inline (fl_static_set_color2); + + procedure fl_static_set_color + (C : in Interfaces.C.unsigned; + R, G, B : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_set_color, "fl_static_set_color"); + pragma Inline (fl_static_set_color); + + procedure fl_static_free_color + (C : in Interfaces.C.unsigned; + B : in Interfaces.C.int); + pragma Import (C, fl_static_free_color, "fl_static_free_color"); + pragma Inline (fl_static_free_color); + + function fl_static_get_box_color + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_static_get_box_color, "fl_static_get_box_color"); + pragma Inline (fl_static_get_box_color); + + procedure fl_static_set_box_color + (T : in Interfaces.C.unsigned); + pragma Import (C, fl_static_set_box_color, "fl_static_set_box_color"); + pragma Inline (fl_static_set_box_color); + + procedure fl_static_foreground + (R, G, B : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_foreground, "fl_static_foreground"); + pragma Inline (fl_static_foreground); + + procedure fl_static_background + (R, G, B : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_background, "fl_static_background"); + pragma Inline (fl_static_background); + + procedure fl_static_background2 + (R, G, B : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_background2, "fl_static_background2"); + pragma Inline (fl_static_background2); + + + + + -- Custom Fonts -- + + function fl_static_get_font + (K : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_static_get_font, "fl_static_get_font"); + pragma Inline (fl_static_get_font); + + function fl_static_get_font_name + (K : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_static_get_font_name, "fl_static_get_font_name"); + pragma Inline (fl_static_get_font_name); + + procedure fl_static_set_font + (T, F : in Interfaces.C.int); + pragma Import (C, fl_static_set_font, "fl_static_set_font"); + pragma Inline (fl_static_set_font); + + procedure fl_static_set_font2 + (T : in Interfaces.C.int; + S : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_static_set_font2, "fl_static_set_font2"); + pragma Inline (fl_static_set_font2); + + function fl_static_get_font_sizes + (F : in Interfaces.C.int; + A : out Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_static_get_font_sizes, "fl_static_get_font_sizes"); + pragma Inline (fl_static_get_font_sizes); + + function fl_static_font_size_array_get + (A : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_font_size_array_get, "fl_static_font_size_array_get"); + pragma Inline (fl_static_font_size_array_get); + + function fl_static_set_fonts + return Interfaces.C.int; + pragma Import (C, fl_static_set_fonts, "fl_static_set_fonts"); + pragma Inline (fl_static_set_fonts); + + + + + -- Box_Kind Attributes -- + + function fl_static_box_dh + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_box_dh, "fl_static_box_dh"); + pragma Inline (fl_static_box_dh); + + function fl_static_box_dw + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_box_dw, "fl_static_box_dw"); + pragma Inline (fl_static_box_dw); + + function fl_static_box_dx + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_box_dx, "fl_static_box_dx"); + pragma Inline (fl_static_box_dx); + + function fl_static_box_dy + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_box_dy, "fl_static_box_dy"); + pragma Inline (fl_static_box_dy); + + function fl_static_get_boxtype + (T : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_static_get_boxtype, "fl_static_get_boxtype"); + pragma Inline (fl_static_get_boxtype); + + procedure fl_static_set_boxtype + (T, F : in Interfaces.C.int); + pragma Import (C, fl_static_set_boxtype, "fl_static_set_boxtype"); + pragma Inline (fl_static_set_boxtype); + + procedure fl_static_set_boxtype2 + (T : in Interfaces.C.int; + F : in Storage.Integer_Address; + DX, DY, DW, DH : in Interfaces.C.unsigned_char); + pragma Import (C, fl_static_set_boxtype2, "fl_static_set_boxtype2"); + pragma Inline (fl_static_set_boxtype2); + + function fl_static_draw_box_active + return Interfaces.C.int; + pragma Import (C, fl_static_draw_box_active, "fl_static_draw_box_active"); + pragma Inline (fl_static_draw_box_active); + + + + + -- Label_Kind Attributes -- + + procedure fl_static_set_labeltype + (K : in Interfaces.C.int; + D, M : in Storage.Integer_Address); + pragma Import (C, fl_static_set_labeltype, "fl_static_set_labeltype"); + pragma Inline (fl_static_set_labeltype); + + + + + -- Clipboard / Selection -- + + procedure fl_static_copy + (T : in Interfaces.C.char_array; + L, K : in Interfaces.C.int); + pragma Import (C, fl_static_copy, "fl_static_copy"); + pragma Inline (fl_static_copy); + + procedure fl_static_paste + (R : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_static_paste, "fl_static_paste"); + pragma Inline (fl_static_paste); + + procedure fl_static_selection + (O : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L : in Interfaces.C.int); + pragma Import (C, fl_static_selection, "fl_static_selection"); + pragma Inline (fl_static_selection); + + function fl_static_clipboard_contains + (K : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_static_clipboard_contains, "fl_static_clipboard_contains"); + pragma Inline (fl_static_clipboard_contains); + + + + + -- Dragon Drop -- + + function fl_static_dnd + return Interfaces.C.int; + pragma Import (C, fl_static_dnd, "fl_static_dnd"); + pragma Inline (fl_static_dnd); + + function fl_static_get_dnd_text_ops + return Interfaces.C.int; + pragma Import (C, fl_static_get_dnd_text_ops, "fl_static_get_dnd_text_ops"); + pragma Inline (fl_static_get_dnd_text_ops); + + procedure fl_static_set_dnd_text_ops + (T : in Interfaces.C.int); + pragma Import (C, fl_static_set_dnd_text_ops, "fl_static_set_dnd_text_ops"); + pragma Inline (fl_static_set_dnd_text_ops); + + + + + -- Windows -- + + procedure fl_static_default_atclose + (W, U : in Storage.Integer_Address); + pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose"); + pragma Inline (fl_static_default_atclose); + + function fl_static_get_first_window + return Storage.Integer_Address; + pragma Import (C, fl_static_get_first_window, "fl_static_get_first_window"); + pragma Inline (fl_static_get_first_window); + + procedure fl_static_set_first_window + (T : in Storage.Integer_Address); + pragma Import (C, fl_static_set_first_window, "fl_static_set_first_window"); + pragma Inline (fl_static_set_first_window); + + function fl_static_next_window + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_static_next_window, "fl_static_next_window"); + pragma Inline (fl_static_next_window); + + function fl_static_modal + return Storage.Integer_Address; + pragma Import (C, fl_static_modal, "fl_static_modal"); + pragma Inline (fl_static_modal); + + + + + -- Queue -- + + function fl_static_readqueue + return Storage.Integer_Address; + pragma Import (C, fl_static_readqueue, "fl_static_readqueue"); + pragma Inline (fl_static_readqueue); + + + + + -- Schemes -- + + function fl_static_get_scheme + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_static_get_scheme, "fl_static_get_scheme"); + pragma Inline (fl_static_get_scheme); + + procedure fl_static_set_scheme + (S : in Interfaces.C.char_array); + pragma Import (C, fl_static_set_scheme, "fl_static_set_scheme"); + pragma Inline (fl_static_set_scheme); + + function fl_static_is_scheme + (S : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_static_is_scheme, "fl_static_is_scheme"); + pragma Inline (fl_static_is_scheme); + + + + + -- Library Options -- + + function fl_static_get_option + (O : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_static_get_option, "fl_static_get_option"); + pragma Inline (fl_static_get_option); + + procedure fl_static_set_option + (O, T : in Interfaces.C.int); + pragma Import (C, fl_static_set_option, "fl_static_set_option"); + pragma Inline (fl_static_set_option); + + + + + -- Scrollbars -- + + function fl_static_get_scrollbar_size + return Interfaces.C.int; + pragma Import (C, fl_static_get_scrollbar_size, "fl_static_get_scrollbar_size"); + pragma Inline (fl_static_get_scrollbar_size); + + procedure fl_static_set_scrollbar_size + (S : in Interfaces.C.int); + pragma Import (C, fl_static_set_scrollbar_size, "fl_static_set_scrollbar_size"); + pragma Inline (fl_static_set_scrollbar_size); + + + + + -- User Data -- + + package Widget_Convert is new System.Address_To_Access_Conversions + (FLTK.Widgets.Widget'Class); + package Window_Convert is new System.Address_To_Access_Conversions + (FLTK.Widgets.Groups.Windows.Window'Class); + + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + Current_Args_Handler : Args_Handler; + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Convention (C, Args_Hook); + + function Args_Hook + (C : in Interfaces.C.int; + V : in Storage.Integer_Address; + I : in out Interfaces.C.int) + return Interfaces.C.int + is + Result : Natural; + begin + pragma Assert (I < C and V /= Null_Pointer); + Result := Current_Args_Handler (Positive (I)); + I := I + Interfaces.C.int (Result); + return Interfaces.C.int (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied unexpected int i value of " & + Interfaces.C.int'Image (I); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Args_Handler callback was supplied irregular argc and argv values of " & + Interfaces.C.int'Image (C) & " and " & Storage.Integer_Address'Image (V); + end Args_Hook; + + + procedure Awake_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Awake_Hook); + + procedure Awake_Hook + (U : in Storage.Integer_Address) is + begin + if U /= Null_Pointer then + Conv.To_Awake_Access (U).all; + end if; + end Awake_Hook; + + + procedure Timeout_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Timeout_Hook); + + procedure Timeout_Hook + (U : in Storage.Integer_Address) is + begin + Conv.To_Timeout_Access (U).all; + end Timeout_Hook; + + + -- This is handled on the Ada side because otherwise there would be + -- no way to specify which callback to remove in FLTK once one was + -- added. This is because Fl::remove_clipboard_notify does not pay + -- attention to the void * data. This hook is passed during package init. + package Clipboard_Notify_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Clipboard_Notify_Handler); + + Current_Clip_Notes : Clipboard_Notify_Vectors.Vector; + + procedure Clipboard_Notify_Hook + (S : in Interfaces.C.int; + U : in Storage.Integer_Address); + pragma Convention (C, Clipboard_Notify_Hook); + + procedure Clipboard_Notify_Hook + (S : in Interfaces.C.int; + U : in Storage.Integer_Address) is + begin + pragma Assert (S in + Buffer_Kind'Pos (Buffer_Kind'First) .. Buffer_Kind'Pos (Buffer_Kind'Last)); + for Call of Current_Clip_Notes loop + Call.all (Buffer_Kind'Val (S)); + end loop; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Clipboard_Notify_Hook was passed unexpected Buffer_Kind int value of " & + Interfaces.C.int'Image (S); + end Clipboard_Notify_Hook; + + + procedure FD_Hook + (FD : in Interfaces.C.int; + U : in Storage.Integer_Address); + pragma Convention (C, FD_Hook); + + procedure FD_Hook + (FD : in Interfaces.C.int; + U : in Storage.Integer_Address) is + begin + Conv.To_File_Access (U).all (File_Descriptor (FD)); + end FD_Hook; + + + procedure Idle_Hook + (U : in Storage.Integer_Address); + pragma Convention (C, Idle_Hook); + + procedure Idle_Hook + (U : in Storage.Integer_Address) is + begin + Conv.To_Idle_Access (U).all; + end Idle_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out FLTK_Static_Final_Controller) is + begin + FLTK.Args_Marshal.Free_Argv (The_Argv); + for Override of Font_Overrides loop + Interfaces.C.Strings.Free (Override); + end loop; + fl_static_remove_clipboard_notify (Storage.To_Integer (Clipboard_Notify_Hook'Address)); + end Finalize; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Command Line Arguments -- + + function Parse_Arg + (Index : in Positive) + return Natural + is + Count : Interfaces.C.int := Interfaces.C.int (Index); + begin + return Natural (fl_static_arg + (The_Argv'Length, + Storage.To_Integer (The_Argv (The_Argv'First)'Address), + Count)); + end Parse_Arg; + + + procedure Parse_Args is + begin + fl_static_args (The_Argv'Length, Storage.To_Integer (The_Argv (The_Argv'First)'Address)); + end Parse_Args; + + + procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null) + is + My_Count : Interfaces.C.int := 1; + Result : Interfaces.C.int; + begin + Current_Args_Handler := Func; + Result := fl_static_args2 + (The_Argv'Length, + Storage.To_Integer (The_Argv (The_Argv'First)'Address), + My_Count, + (if Func = null then Null_Pointer else Storage.To_Integer (Args_Hook'Address))); + Count := Integer (My_Count) - 1; + if Result = 0 then + raise Argument_Error with + "Fl::args could not recognise switch at argument number " & + Interfaces.C.int'Image (My_Count); + else + pragma Assert (Result > 0); + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::args produced unexpected i parameter of " & Interfaces.C.int'Image (My_Count); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::args returned unexpected int value of " & Interfaces.C.int'Image (Result); + end Parse_Args; + + + + + -- Thread Notify -- + + procedure Add_Awake_Handler + (Func : in Awake_Handler) + is + Result : constant Interfaces.C.int := fl_static_add_awake_handler + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); + begin + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::add_awake_handler_ failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with + "Fl::add_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; + end Add_Awake_Handler; + + + function Get_Awake_Handler + return Awake_Handler + is + Hook, Func : Storage.Integer_Address; + Result : constant Interfaces.C.int := fl_static_get_awake_handler (Hook, Func); + begin + pragma Assert (Result = 0); + return Conv.To_Awake_Access (Func); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with + "Fl::get_awake_handler_ invoked without prior awake setup"; + else + raise Internal_FLTK_Error with + "Fl::get_awake_handler_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; + end Get_Awake_Handler; + + + procedure Awake + (Func : in Awake_Handler) + is + Result : constant Interfaces.C.int := fl_static_awake2 + (Storage.To_Integer (Awake_Hook'Address), + Conv.To_Address (Func)); + begin + pragma Assert (Result = 0); + exception + when Chk.Assertion_Error => + if Result = -1 then + raise Tasking_Error with "Fl::awake failed to register Awake_Handler callback"; + else + raise Internal_FLTK_Error with "Fl::awake returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end if; + end Awake; + + + procedure Awake is + begin + fl_static_awake (Null_Pointer); + end Awake; + + + + + -- Pre-Eventloop Callbacks -- + + procedure Add_Check + (Func : in not null Timeout_Handler) is + begin + fl_static_add_check + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); + end Add_Check; + + + function Has_Check + (Func : in not null Timeout_Handler) + return Boolean is + begin + return fl_static_has_check + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))) /= 0; + end Has_Check; + + + procedure Remove_Check + (Func : in not null Timeout_Handler) is + begin + fl_static_remove_check + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); + end Remove_Check; + + + + + -- Timer Callbacks -- + + procedure Add_Timeout + (Seconds : in Long_Float; + Func : in not null Timeout_Handler) is + begin + fl_static_add_timeout + (Interfaces.C.double (Seconds), + Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); + end Add_Timeout; + + + function Has_Timeout + (Func : in not null Timeout_Handler) + return Boolean is + begin + return fl_static_has_timeout + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))) /= 0; + end Has_Timeout; + + + procedure Remove_Timeout + (Func : in not null Timeout_Handler) is + begin + fl_static_remove_timeout + (Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); + end Remove_Timeout; + + + procedure Repeat_Timeout + (Seconds : in Long_Float; + Func : in not null Timeout_Handler) is + begin + fl_static_repeat_timeout + (Interfaces.C.double (Seconds), + Storage.To_Integer (Timeout_Hook'Address), + Conv.To_Address (Timeout_Handler'(Func))); + end Repeat_Timeout; + + + + + -- Clipboard Callbacks -- + + procedure Add_Clipboard_Notify + (Func : in not null Clipboard_Notify_Handler) is + begin + Current_Clip_Notes.Append (Func); + end Add_Clipboard_Notify; + + + procedure Remove_Clipboard_Notify + (Func : in not null Clipboard_Notify_Handler) is + begin + for Index in reverse Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop + if Current_Clip_Notes (Index) = Func then + Current_Clip_Notes.Delete (Index); + return; + end if; + end loop; + end Remove_Clipboard_Notify; + + + + + -- File Descriptor Waiting Callbacks -- + + procedure Add_File_Descriptor + (FD : in File_Descriptor; + Func : in not null File_Handler) is + begin + fl_static_add_fd + (Interfaces.C.int (FD), + Storage.To_Integer (FD_Hook'Address), + Conv.To_Address (Func)); + end Add_File_Descriptor; + + + procedure Add_File_Descriptor + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler) is + begin + fl_static_add_fd2 + (Interfaces.C.int (FD), + FMode_To_Cint (Mode), + Storage.To_Integer (FD_Hook'Address), + Conv.To_Address (Func)); + end Add_File_Descriptor; + + + procedure Remove_File_Descriptor + (FD : in File_Descriptor) is + begin + fl_static_remove_fd (Interfaces.C.int (FD)); + end Remove_File_Descriptor; + + + procedure Remove_File_Descriptor + (FD : in File_Descriptor; + Mode : in File_Mode) is + begin + fl_static_remove_fd2 (Interfaces.C.int (FD), FMode_To_Cint (Mode)); + end Remove_File_Descriptor; + + + + + -- Idle Callbacks -- + + procedure Add_Idle + (Func : in not null Idle_Handler) is + begin + fl_static_add_idle + (Storage.To_Integer (Idle_Hook'Address), + Conv.To_Address (Idle_Handler'(Func))); + end Add_Idle; + + + function Has_Idle + (Func : in not null Idle_Handler) + return Boolean is + begin + return fl_static_has_idle + (Storage.To_Integer (Idle_Hook'Address), + Conv.To_Address (Idle_Handler'(Func))) /= 0; + end Has_Idle; + + + procedure Remove_Idle + (Func : in not null Idle_Handler) is + begin + fl_static_remove_idle + (Storage.To_Integer (Idle_Hook'Address), + Conv.To_Address (Idle_Handler'(Func))); + end Remove_Idle; + + + + + -- Custom Colors -- + + function Get_Color + (From : in Color) + return Color is + begin + return Color (fl_static_get_color2 (Interfaces.C.unsigned (From))); + end Get_Color; + + + procedure Get_Color + (From : in Color; + R, G, B : out Color_Component) is + begin + fl_static_get_color + (Interfaces.C.unsigned (From), + Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Get_Color; + + + procedure Set_Color + (Target, Source : in Color) is + begin + fl_static_set_color2 + (Interfaces.C.unsigned (Target), + Interfaces.C.unsigned (Source)); + end Set_Color; + + + procedure Set_Color + (Target : in Color; + R, G, B : in Color_Component) is + begin + fl_static_set_color + (Interfaces.C.unsigned (Target), + Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Set_Color; + + + procedure Free_Color + (Value : in Color; + Overlay : in Boolean := False) is + begin + fl_static_free_color + (Interfaces.C.unsigned (Value), + Boolean'Pos (Overlay)); + end Free_Color; + + + function Get_Box_Color + (Tone : in Color) + return Color is + begin + return Color (fl_static_get_box_color (Interfaces.C.unsigned (Tone))); + end Get_Box_Color; + + + procedure Set_Box_Color + (Tone : in Color) is + begin + fl_static_set_box_color (Interfaces.C.unsigned (Tone)); + end Set_Box_Color; + + + procedure Set_Foreground + (R, G, B : in Color_Component) is + begin + fl_static_foreground + (Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Set_Foreground; + + + procedure Set_Background + (R, G, B : in Color_Component) is + begin + fl_static_background + (Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Set_Background; + + + procedure Set_Alt_Background + (R, G, B : in Color_Component) is + begin + fl_static_background2 + (Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B)); + end Set_Alt_Background; + + + + + -- Custom Fonts -- + + function Font_Image + (Kind : in Font_Kind) + return String is + begin + -- should never get a null string in return since it's from an enum + return Interfaces.C.Strings.Value (fl_static_get_font (Font_Kind'Pos (Kind))); + end Font_Image; + + + function Font_Family_Image + (Kind : in Font_Kind) + return String is + begin + -- should never get a null string in return since it's from an enum + return Interfaces.C.Strings.Value (fl_static_get_font_name (Font_Kind'Pos (Kind))); + end Font_Family_Image; + + + procedure Set_Font_Kind + (Target, Source : in Font_Kind) is + begin + fl_static_set_font (Font_Kind'Pos (Target), Font_Kind'Pos (Source)); + end Set_Font_Kind; + + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String) is + begin + Interfaces.C.Strings.Free (Font_Overrides (Target)); + Font_Overrides (Target) := Interfaces.C.Strings.New_String (Source); + fl_static_set_font2 (Font_Kind'Pos (Target), Font_Overrides (Target)); + end Set_Font_Kind; + + + function Font_Sizes + (Kind : in Font_Kind) + return Font_Size_Array + is + Ptr : Storage.Integer_Address; + Arr : Font_Size_Array + (1 .. Integer (fl_static_get_font_sizes (Font_Kind'Pos (Kind), Ptr))); + begin + -- This array copying avoids any worry that the static buffer will be overwritten. + for I in 1 .. Arr'Length loop + Arr (I) := Font_Size (fl_static_font_size_array_get (Ptr, Interfaces.C.int (I))); + end loop; + return Arr; + end Font_Sizes; + + + procedure Setup_Fonts + (How_Many_Set_Up : out Natural) + is + Result : constant Interfaces.C.int := fl_static_set_fonts; + begin + How_Many_Set_Up := Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::set_fonts returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Setup_Fonts; + + + + + -- Box_Kind Attributes -- + + function Get_Box_Height_Offset + (Kind : in Box_Kind) + return Integer is + begin + return Integer (fl_static_box_dh (Box_Kind'Pos (Kind))); + end Get_Box_Height_Offset; + + + function Get_Box_Width_Offset + (Kind : in Box_Kind) + return Integer is + begin + return Integer (fl_static_box_dw (Box_Kind'Pos (Kind))); + end Get_Box_Width_Offset; + + + function Get_Box_X_Offset + (Kind : in Box_Kind) + return Integer is + begin + return Integer (fl_static_box_dx (Box_Kind'Pos (Kind))); + end Get_Box_X_Offset; + + + function Get_Box_Y_Offset + (Kind : in Box_Kind) + return Integer is + begin + return Integer (fl_static_box_dy (Box_Kind'Pos (Kind))); + end Get_Box_Y_Offset; + + + procedure Set_Box_Kind + (To, From : in Box_Kind) is + begin + fl_static_set_boxtype (Box_Kind'Pos (To), Box_Kind'Pos (From)); + end Set_Box_Kind; + + + function Draw_Box_Active + return Boolean is + begin + return fl_static_draw_box_active /= 0; + end Draw_Box_Active; + + + function Get_Box_Draw_Function + (Kind : in Box_Kind) + return Box_Draw_Function is + begin + return FLTK.Box_Draw_Marshal.To_Ada (Kind, fl_static_get_boxtype (Box_Kind'Pos (Kind))); + end Get_Box_Draw_Function; + + + procedure Set_Box_Draw_Function + (Kind : in Box_Kind; + Func : in Box_Draw_Function; + Offset_X, Offset_Y : in Byte_Integer := 0; + Offset_W, Offset_H : in Byte_Integer := 0) is + begin + fl_static_set_boxtype2 + (Box_Kind'Pos (Kind), + FLTK.Box_Draw_Marshal.To_C (Kind, Func), + Interfaces.C.unsigned_char (Offset_X), + Interfaces.C.unsigned_char (Offset_Y), + Interfaces.C.unsigned_char (Offset_W), + Interfaces.C.unsigned_char (Offset_H)); + end Set_Box_Draw_Function; + + + + + -- Label_Kind Attributes -- + + procedure Set_Label_Kind + (Target, Source : in Label_Kind) is + begin + -- As of FLTK 1.3.11 there is no definition given for this function + -- so this is null to avoid linker errors. + null; + end Set_Label_Kind; + + + procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function) is + begin + fl_static_set_labeltype + (Label_Kind'Pos (Kind), + FLTK.Label_Draw_Marshal.To_C (Kind, Draw_Func), + FLTK.Label_Draw_Marshal.To_C (Kind, Measure_Func)); + end Set_Label_Draw_Function; + + + + + -- Clipboard / Selection -- + + procedure Copy + (Text : in String; + Dest : in Buffer_Kind) is + begin + fl_static_copy + (Interfaces.C.To_C (Text), + Text'Length, + Buffer_Kind'Pos (Dest)); + end Copy; + + + procedure Paste + (Receiver : in FLTK.Widgets.Widget'Class; + Source : in Buffer_Kind) is + begin + fl_static_paste + (Wrapper (Receiver).Void_Ptr, + Buffer_Kind'Pos (Source)); + end Paste; + + + procedure Selection + (Owner : in FLTK.Widgets.Widget'Class; + Text : in String) is + begin + fl_static_selection + (Wrapper (Owner).Void_Ptr, + Interfaces.C.To_C (Text), + Text'Length); + end Selection; + + + function Clipboard_Contains + (Kind : in String) + return Boolean is + begin + return fl_static_clipboard_contains (Interfaces.C.To_C (Kind)) /= 0; + end Clipboard_Contains; + + + + + -- Dragon Drop -- + + procedure Drag_Drop_Start is + Ignore : Interfaces.C.int := fl_static_dnd; + begin + null; + end Drag_Drop_Start; + + + function Get_Drag_Drop_Text_Support + return Boolean is + begin + return fl_static_get_dnd_text_ops /= 0; + end Get_Drag_Drop_Text_Support; + + + procedure Set_Drag_Drop_Text_Support + (To : in Boolean) is + begin + fl_static_set_dnd_text_ops (Boolean'Pos (To)); + end Set_Drag_Drop_Text_Support; + + + + + -- Windows -- + + procedure Default_Window_Close + (Item : in out FLTK.Widgets.Widget'Class) is + begin + pragma Assert (Wrapper (Item).Void_Ptr /= Null_Pointer); + fl_static_default_atclose + (Wrapper (Item).Void_Ptr, + fl_widget_get_user_data (Wrapper (Item).Void_Ptr)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl::default_atclose received uninitialised widget"; + end Default_Window_Close; + + + function Get_First_Window + return access FLTK.Widgets.Groups.Windows.Window'Class + is + First_Ptr : Storage.Integer_Address := fl_static_get_first_window; + Actual_First : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if First_Ptr /= Null_Pointer then + First_Ptr := fl_widget_get_user_data (First_Ptr); + pragma Assert (First_Ptr /= Null_Pointer); + Actual_First := Window_Convert.To_Pointer (Storage.To_Address (First_Ptr)); + end if; + return Actual_First; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::first_window did not have user_data reference back to Ada"; + end Get_First_Window; + + + procedure Set_First_Window + (To : in FLTK.Widgets.Groups.Windows.Window'Class) is + begin + fl_static_set_first_window (Wrapper (To).Void_Ptr); + end Set_First_Window; + + + function Get_Next_Window + (From : in FLTK.Widgets.Groups.Windows.Window'Class) + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Next_Ptr : Storage.Integer_Address := fl_static_next_window (Wrapper (From).Void_Ptr); + Actual_Next : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Next_Ptr /= Null_Pointer then + Next_Ptr := fl_widget_get_user_data (Next_Ptr); + pragma Assert (Next_Ptr /= Null_Pointer); + Actual_Next := Window_Convert.To_Pointer (Storage.To_Address (Next_Ptr)); + end if; + return Actual_Next; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::next_window did not have user_data reference back to Ada"; + end Get_Next_Window; + + + function Get_Top_Modal + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Modal_Ptr : Storage.Integer_Address := fl_static_modal; + Actual_Modal : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Modal_Ptr /= Null_Pointer then + Modal_Ptr := fl_widget_get_user_data (Modal_Ptr); + pragma Assert (Modal_Ptr /= Null_Pointer); + Actual_Modal := Window_Convert.To_Pointer (Storage.To_Address (Modal_Ptr)); + end if; + return Actual_Modal; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::modal did not have user_data reference back to Ada"; + end Get_Top_Modal; + + + + + -- Queue -- + + function Read_Queue + return access FLTK.Widgets.Widget'Class + is + Queue_Ptr : Storage.Integer_Address := fl_static_readqueue; + Actual_Queue : access FLTK.Widgets.Widget'Class; + begin + if Queue_Ptr /= Null_Pointer then + Queue_Ptr := fl_widget_get_user_data (Queue_Ptr); + pragma Assert (Queue_Ptr /= Null_Pointer); + Actual_Queue := Widget_Convert.To_Pointer (Storage.To_Address (Queue_Ptr)); + end if; + return Actual_Queue; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl::readqueue did not have user_data reference back to Ada"; + end Read_Queue; + + + + + -- Schemes -- + + function Get_Scheme + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_static_get_scheme; + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Scheme; + + + procedure Set_Scheme + (To : in String) is + begin + -- A copy of the Scheme string is stored in FLTK + fl_static_set_scheme (Interfaces.C.To_C (To)); + end Set_Scheme; + + + function Is_Scheme + (Scheme : in String) + return Boolean + is + Result : constant Interfaces.C.int := fl_static_is_scheme (Interfaces.C.To_C (Scheme)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::is_scheme returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Scheme; + + + + + -- Library Options -- + + function Get_Option + (Opt : in Option) + return Boolean is + begin + return fl_static_get_option (Option'Pos (Opt)) /= 0; + end Get_Option; + + + procedure Set_Option + (Opt : in Option; + To : in Boolean) is + begin + fl_static_set_option (Option'Pos (Opt), Boolean'Pos (To)); + end Set_Option; + + + + + -- Scrollbars -- + + function Get_Default_Scrollbar_Size + return Natural + is + Result : constant Interfaces.C.int := fl_static_get_scrollbar_size; + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl::scrollbar_size returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Default_Scrollbar_Size; + + + procedure Set_Default_Scrollbar_Size + (To : in Natural) is + begin + fl_static_set_scrollbar_size (Interfaces.C.int (To)); + end Set_Default_Scrollbar_Size; + + +begin + + + fl_static_add_clipboard_notify + (Storage.To_Integer (Clipboard_Notify_Hook'Address), Null_Pointer); + + +end FLTK.Static; + + diff --git a/body/fltk-static_callback_conversions.adb b/body/fltk-static_callback_conversions.adb new file mode 100644 index 0000000..ceb0e62 --- /dev/null +++ b/body/fltk-static_callback_conversions.adb @@ -0,0 +1,176 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Unchecked_Conversion, + FLTK.Static; + +use type + + FLTK.Static.Awake_Handler, + FLTK.Static.Timeout_Handler, + FLTK.Static.Idle_Handler, + FLTK.Static.Clipboard_Notify_Handler, + FLTK.Static.File_Handler; + + +package body FLTK.Static_Callback_Conversions is + + + function To_Awake_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Awake_Handler + is + function Raw is new Ada.Unchecked_Conversion + (Storage.Integer_Address, FLTK.Static.Awake_Handler); + begin + if Addy = Null_Pointer then + return null; + else + return Raw (Addy); + end if; + end To_Awake_Access; + + + function To_Address + (Call : in FLTK.Static.Awake_Handler) + return Storage.Integer_Address + is + function Raw is new Ada.Unchecked_Conversion + (FLTK.Static.Awake_Handler, Storage.Integer_Address); + begin + if Call = null then + return Null_Pointer; + else + return Raw (Call); + end if; + end To_Address; + + + function To_Timeout_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Timeout_Handler + is + function Raw is new Ada.Unchecked_Conversion + (Storage.Integer_Address, FLTK.Static.Timeout_Handler); + begin + if Addy = Null_Pointer then + return null; + else + return Raw (Addy); + end if; + end To_Timeout_Access; + + + function To_Address + (Call : in FLTK.Static.Timeout_Handler) + return Storage.Integer_Address + is + function Raw is new Ada.Unchecked_Conversion + (FLTK.Static.Timeout_Handler, Storage.Integer_Address); + begin + if Call = null then + return Null_Pointer; + else + return Raw (Call); + end if; + end To_Address; + + + function To_Idle_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Idle_Handler + is + function Raw is new Ada.Unchecked_Conversion + (Storage.Integer_Address, FLTK.Static.Idle_Handler); + begin + if Addy = Null_Pointer then + return null; + else + return Raw (Addy); + end if; + end To_Idle_Access; + + + function To_Address + (Call : in FLTK.Static.Idle_Handler) + return Storage.Integer_Address + is + function Raw is new Ada.Unchecked_Conversion + (FLTK.Static.Idle_Handler, Storage.Integer_Address); + begin + if Call = null then + return Null_Pointer; + else + return Raw (Call); + end if; + end To_Address; + + + function To_Clipboard_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Clipboard_Notify_Handler + is + function Raw is new Ada.Unchecked_Conversion + (Storage.Integer_Address, FLTK.Static.Clipboard_Notify_Handler); + begin + if Addy = Null_Pointer then + return null; + else + return Raw (Addy); + end if; + end To_Clipboard_Access; + + + function To_Address + (Call : in FLTK.Static.Clipboard_Notify_Handler) + return Storage.Integer_Address + is + function Raw is new Ada.Unchecked_Conversion + (FLTK.Static.Clipboard_Notify_Handler, Storage.Integer_Address); + begin + if Call = null then + return Null_Pointer; + else + return Raw (Call); + end if; + end To_Address; + + + function To_File_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.File_Handler + is + function Raw is new Ada.Unchecked_Conversion + (Storage.Integer_Address, FLTK.Static.File_Handler); + begin + if Addy = Null_Pointer then + return null; + else + return Raw (Addy); + end if; + end To_File_Access; + + + function To_Address + (Call : in FLTK.Static.File_Handler) + return Storage.Integer_Address + is + function Raw is new Ada.Unchecked_Conversion + (FLTK.Static.File_Handler, Storage.Integer_Address); + begin + if Call = null then + return Null_Pointer; + else + return Raw (Call); + end if; + end To_Address; + + +end FLTK.Static_Callback_Conversions; + + diff --git a/body/fltk-static_callback_conversions.ads b/body/fltk-static_callback_conversions.ads new file mode 100644 index 0000000..1e10c03 --- /dev/null +++ b/body/fltk-static_callback_conversions.ads @@ -0,0 +1,58 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Static; + + +private package FLTK.Static_Callback_Conversions is + + + function To_Awake_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Awake_Handler; + + function To_Address + (Call : in FLTK.Static.Awake_Handler) + return Storage.Integer_Address; + + function To_Timeout_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Timeout_Handler; + + function To_Address + (Call : in FLTK.Static.Timeout_Handler) + return Storage.Integer_Address; + + function To_Idle_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Idle_Handler; + + function To_Address + (Call : in FLTK.Static.Idle_Handler) + return Storage.Integer_Address; + + function To_Clipboard_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.Clipboard_Notify_Handler; + + function To_Address + (Call : in FLTK.Static.Clipboard_Notify_Handler) + return Storage.Integer_Address; + + function To_File_Access + (Addy : in Storage.Integer_Address) + return FLTK.Static.File_Handler; + + function To_Address + (Call : in FLTK.Static.File_Handler) + return Storage.Integer_Address; + + +end FLTK.Static_Callback_Conversions; + + diff --git a/body/fltk-text_buffers.adb b/body/fltk-text_buffers.adb new file mode 100644 index 0000000..a870ece --- /dev/null +++ b/body/fltk-text_buffers.adb @@ -0,0 +1,1413 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings, + Ada.Strings.Unbounded, + Ada.Containers; + +use + + Ada.Strings.Unbounded; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr, + Ada.Containers.Count_Type; + + +package body FLTK.Text_Buffers is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Errors -- + + function strerror + (Errnum : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, strerror, "strerror"); + + + + + -- Allocation -- + + function new_fl_text_buffer + (RS, PGS : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_text_buffer, "new_fl_text_buffer"); + pragma Inline (new_fl_text_buffer); + + procedure free_fl_text_buffer + (TB : in Storage.Integer_Address); + pragma Import (C, free_fl_text_buffer, "free_fl_text_buffer"); + pragma Inline (free_fl_text_buffer); + + + + + -- Callbacks -- + + procedure fl_text_buffer_add_modify_callback + (TB, CB, UD : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_add_modify_callback, + "fl_text_buffer_add_modify_callback"); + pragma Inline (fl_text_buffer_add_modify_callback); + + procedure fl_text_buffer_add_predelete_callback + (TB, CB, UD : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_add_predelete_callback, + "fl_text_buffer_add_predelete_callback"); + pragma Inline (fl_text_buffer_add_predelete_callback); + + procedure fl_text_buffer_call_modify_callbacks + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_call_modify_callbacks, + "fl_text_buffer_call_modify_callbacks"); + pragma Inline (fl_text_buffer_call_modify_callbacks); + + procedure fl_text_buffer_call_predelete_callbacks + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_call_predelete_callbacks, + "fl_text_buffer_call_predelete_callbacks"); + pragma Inline (fl_text_buffer_call_predelete_callbacks); + + + + + -- Files -- + + function fl_text_buffer_loadfile + (TB : in Storage.Integer_Address; + N : in Interfaces.C.char_array; + B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_loadfile, "fl_text_buffer_loadfile"); + pragma Inline (fl_text_buffer_loadfile); + + function fl_text_buffer_appendfile + (TB : in Storage.Integer_Address; + N : in Interfaces.C.char_array; + B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_appendfile, "fl_text_buffer_appendfile"); + pragma Inline (fl_text_buffer_appendfile); + + function fl_text_buffer_insertfile + (TB : in Storage.Integer_Address; + N : in Interfaces.C.char_array; + P, B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_insertfile, "fl_text_buffer_insertfile"); + pragma Inline (fl_text_buffer_insertfile); + + function fl_text_buffer_outputfile + (TB : in Storage.Integer_Address; + N : in Interfaces.C.char_array; + F, T : in Interfaces.C.int; + B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_outputfile, "fl_text_buffer_outputfile"); + pragma Inline (fl_text_buffer_outputfile); + + function fl_text_buffer_savefile + (TB : in Storage.Integer_Address; + N : in Interfaces.C.char_array; + B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_savefile, "fl_text_buffer_savefile"); + pragma Inline (fl_text_buffer_savefile); + + + + + -- Modification -- + + procedure fl_text_buffer_insert + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int; + I : in Interfaces.C.char_array); + pragma Import (C, fl_text_buffer_insert, "fl_text_buffer_insert"); + pragma Inline (fl_text_buffer_insert); + + procedure fl_text_buffer_append + (TB : in Storage.Integer_Address; + I : in Interfaces.C.char_array); + pragma Import (C, fl_text_buffer_append, "fl_text_buffer_append"); + pragma Inline (fl_text_buffer_append); + + procedure fl_text_buffer_replace + (TB : in Storage.Integer_Address; + S, F : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_text_buffer_replace, "fl_text_buffer_replace"); + pragma Inline (fl_text_buffer_replace); + + procedure fl_text_buffer_remove + (TB : in Storage.Integer_Address; + S, F : in Interfaces.C.int); + pragma Import (C, fl_text_buffer_remove, "fl_text_buffer_remove"); + pragma Inline (fl_text_buffer_remove); + + function fl_text_buffer_get_text + (TB : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_buffer_get_text, "fl_text_buffer_get_text"); + pragma Inline (fl_text_buffer_get_text); + + procedure fl_text_buffer_set_text + (TB : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_text_buffer_set_text, "fl_text_buffer_set_text"); + pragma Inline (fl_text_buffer_set_text); + + function fl_text_buffer_byte_at + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.char; + pragma Import (C, fl_text_buffer_byte_at, "fl_text_buffer_byte_at"); + pragma Inline (fl_text_buffer_byte_at); + + function fl_text_buffer_char_at + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_buffer_char_at, "fl_text_buffer_char_at"); + pragma Inline (fl_text_buffer_char_at); + + function fl_text_buffer_text_range + (TB : in Storage.Integer_Address; + S, F : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_buffer_text_range, "fl_text_buffer_text_range"); + pragma Inline (fl_text_buffer_text_range); + + function fl_text_buffer_next_char + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_next_char, "fl_text_buffer_next_char"); + pragma Inline (fl_text_buffer_next_char); + + function fl_text_buffer_prev_char + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_prev_char, "fl_text_buffer_prev_char"); + pragma Inline (fl_text_buffer_prev_char); + + + + + -- Measurement -- + + function fl_text_buffer_count_displayed_characters + (TB : in Storage.Integer_Address; + S, F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_count_displayed_characters, + "fl_text_buffer_count_displayed_characters"); + pragma Inline (fl_text_buffer_count_displayed_characters); + + function fl_text_buffer_count_lines + (TB : in Storage.Integer_Address; + S, F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_count_lines, "fl_text_buffer_count_lines"); + pragma Inline (fl_text_buffer_count_lines); + + function fl_text_buffer_length + (TB : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_length, "fl_text_buffer_length"); + pragma Inline (fl_text_buffer_length); + + function fl_text_buffer_get_tab_distance + (TB : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_get_tab_distance, "fl_text_buffer_get_tab_distance"); + pragma Inline (fl_text_buffer_get_tab_distance); + + procedure fl_text_buffer_set_tab_distance + (TB : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_text_buffer_set_tab_distance, "fl_text_buffer_set_tab_distance"); + pragma Inline (fl_text_buffer_set_tab_distance); + + + + + -- Selection -- + + function fl_text_buffer_selection_position + (TB : in Storage.Integer_Address; + S, E : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_selection_position, "fl_text_buffer_selection_position"); + pragma Inline (fl_text_buffer_selection_position); + + function fl_text_buffer_secondary_selection_position + (TB : in Storage.Integer_Address; + S, E : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_secondary_selection_position, + "fl_text_buffer_secondary_selection_position"); + pragma Inline (fl_text_buffer_secondary_selection_position); + + procedure fl_text_buffer_select + (TB : in Storage.Integer_Address; + S, E : in Interfaces.C.int); + pragma Import (C, fl_text_buffer_select, "fl_text_buffer_select"); + pragma Inline (fl_text_buffer_select); + + procedure fl_text_buffer_secondary_select + (TB : in Storage.Integer_Address; + S, E : in Interfaces.C.int); + pragma Import (C, fl_text_buffer_secondary_select, "fl_text_buffer_secondary_select"); + pragma Inline (fl_text_buffer_secondary_select); + + function fl_text_buffer_selected + (TB : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_selected, "fl_text_buffer_selected"); + pragma Inline (fl_text_buffer_selected); + + function fl_text_buffer_secondary_selected + (TB : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_secondary_selected, "fl_text_buffer_secondary_selected"); + pragma Inline (fl_text_buffer_secondary_selected); + + function fl_text_buffer_selection_text + (TB : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_buffer_selection_text, "fl_text_buffer_selection_text"); + pragma Inline (fl_text_buffer_selection_text); + + function fl_text_buffer_secondary_selection_text + (TB : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_buffer_secondary_selection_text, + "fl_text_buffer_secondary_selection_text"); + pragma Inline (fl_text_buffer_secondary_selection_text); + + procedure fl_text_buffer_replace_selection + (TB : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_text_buffer_replace_selection, "fl_text_buffer_replace_selection"); + pragma Inline (fl_text_buffer_replace_selection); + + procedure fl_text_buffer_replace_secondary_selection + (TB : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_text_buffer_replace_secondary_selection, + "fl_text_buffer_replace_secondary_selection"); + pragma Inline (fl_text_buffer_replace_secondary_selection); + + procedure fl_text_buffer_remove_selection + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_remove_selection, "fl_text_buffer_remove_selection"); + pragma Inline (fl_text_buffer_remove_selection); + + procedure fl_text_buffer_remove_secondary_selection + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_remove_secondary_selection, + "fl_text_buffer_remove_secondary_selection"); + pragma Inline (fl_text_buffer_remove_secondary_selection); + + procedure fl_text_buffer_unselect + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_unselect, "fl_text_buffer_unselect"); + pragma Inline (fl_text_buffer_unselect); + + procedure fl_text_buffer_secondary_unselect + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_secondary_unselect, "fl_text_buffer_secondary_unselect"); + pragma Inline (fl_text_buffer_secondary_unselect); + + + + + -- Highlighting -- + + procedure fl_text_buffer_highlight + (TB : in Storage.Integer_Address; + F, T : in Interfaces.C.int); + pragma Import (C, fl_text_buffer_highlight, "fl_text_buffer_highlight"); + pragma Inline (fl_text_buffer_highlight); + + function fl_text_buffer_highlight_text + (TB : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_buffer_highlight_text, "fl_text_buffer_highlight_text"); + pragma Inline (fl_text_buffer_highlight_text); + + procedure fl_text_buffer_unhighlight + (TB : in Storage.Integer_Address); + pragma Import (C, fl_text_buffer_unhighlight, "fl_text_buffer_unhighlight"); + pragma Inline (fl_text_buffer_unhighlight); + + + + + -- Search -- + + function fl_text_buffer_findchar_forward + (TB : in Storage.Integer_Address; + SP : in Interfaces.C.int; + IT : in Interfaces.C.unsigned; + FP : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_findchar_forward, "fl_text_buffer_findchar_forward"); + pragma Inline (fl_text_buffer_findchar_forward); + + function fl_text_buffer_findchar_backward + (TB : in Storage.Integer_Address; + SP : in Interfaces.C.int; + IT : in Interfaces.C.unsigned; + FP : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_findchar_backward, "fl_text_buffer_findchar_backward"); + pragma Inline (fl_text_buffer_findchar_backward); + + function fl_text_buffer_search_forward + (TB : in Storage.Integer_Address; + SP : in Interfaces.C.int; + IT : in Interfaces.C.char_array; + FP : out Interfaces.C.int; + CA : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_search_forward, "fl_text_buffer_search_forward"); + pragma Inline (fl_text_buffer_search_forward); + + function fl_text_buffer_search_backward + (TB : in Storage.Integer_Address; + SP : in Interfaces.C.int; + IT : in Interfaces.C.char_array; + FP : out Interfaces.C.int; + CA : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_search_backward, "fl_text_buffer_search_backward"); + pragma Inline (fl_text_buffer_search_backward); + + + + + -- Navigation -- + + function fl_text_buffer_word_start + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_word_start, "fl_text_buffer_word_start"); + pragma Inline (fl_text_buffer_word_start); + + function fl_text_buffer_word_end + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_word_end, "fl_text_buffer_word_end"); + pragma Inline (fl_text_buffer_word_end); + + function fl_text_buffer_line_start + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_line_start, "fl_text_buffer_line_start"); + pragma Inline (fl_text_buffer_line_start); + + function fl_text_buffer_line_end + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_line_end, "fl_text_buffer_line_end"); + pragma Inline (fl_text_buffer_line_end); + + function fl_text_buffer_line_text + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_buffer_line_text, "fl_text_buffer_line_text"); + pragma Inline (fl_text_buffer_line_text); + + function fl_text_buffer_skip_lines + (TB : in Storage.Integer_Address; + S, L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_skip_lines, "fl_text_buffer_skip_lines"); + pragma Inline (fl_text_buffer_skip_lines); + + function fl_text_buffer_rewind_lines + (TB : in Storage.Integer_Address; + S, L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_rewind_lines, "fl_text_buffer_rewind_lines"); + pragma Inline (fl_text_buffer_rewind_lines); + + function fl_text_buffer_skip_displayed_characters + (TB : in Storage.Integer_Address; + S, N : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_skip_displayed_characters, + "fl_text_buffer_skip_displayed_characters"); + pragma Inline (fl_text_buffer_skip_displayed_characters); + + + + + -- Miscellaneous -- + + procedure fl_text_buffer_canundo + (TB : in Storage.Integer_Address; + F : in Interfaces.C.char); + pragma Import (C, fl_text_buffer_canundo, "fl_text_buffer_canundo"); + pragma Inline (fl_text_buffer_canundo); + + procedure fl_text_buffer_copy + (TB, TB2 : in Storage.Integer_Address; + S, F, I : in Interfaces.C.int); + pragma Import (C, fl_text_buffer_copy, "fl_text_buffer_copy"); + pragma Inline (fl_text_buffer_copy); + + function fl_text_buffer_utf8_align + (TB : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_buffer_utf8_align, "fl_text_buffer_utf8_align"); + pragma Inline (fl_text_buffer_utf8_align); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + procedure Modify_Callback_Hook + (Pos : in Interfaces.C.int; + Inserted, Deleted, Restyled : in Interfaces.C.int; + Text : in Interfaces.C.Strings.chars_ptr; + UD : in Storage.Integer_Address) + is + Action : Modification; + Place : constant Position := Position (Pos); + Length : Natural; + Deleted_Text : Unbounded_String := To_Unbounded_String (""); + + Ada_Text_Buffer : constant access Text_Buffer := + Text_Buffer_Convert.To_Pointer (Storage.To_Address (UD)); + begin + if Ada_Text_Buffer.CB_Active then + if Inserted > 0 then + Length := Natural (Inserted); + Action := Insert; + elsif Deleted > 0 then + Length := Natural (Deleted); + Action := Delete; + if Text /= Interfaces.C.Strings.Null_Ptr then + Deleted_Text := To_Unbounded_String (Interfaces.C.Strings.Value (Text)); + end if; + elsif Restyled > 0 then + Length := Natural (Restyled); + Action := Restyle; + else + Length := 0; + Action := None; + end if; + + for CB of Ada_Text_Buffer.Modify_CBs loop + CB.all (Action, Place, Length, To_String (Deleted_Text)); + end loop; + end if; + end Modify_Callback_Hook; + + + procedure Predelete_Callback_Hook + (Pos, Deleted : in Interfaces.C.int; + UD : in Storage.Integer_Address) + is + Place : constant Position := Position (Pos); + Length : constant Natural := Natural (Deleted); + + Ada_Text_Buffer : constant access Text_Buffer := + Text_Buffer_Convert.To_Pointer (Storage.To_Address (UD)); + begin + if Ada_Text_Buffer.CB_Active then + for CB of Ada_Text_Buffer.Predelete_CBs loop + CB.all (Place, Length); + end loop; + end if; + end Predelete_Callback_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Text_Buffer) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_text_buffer (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Requested_Size : in Natural := 0; + Preferred_Gap_Size : in Natural := 1024) + return Text_Buffer is + begin + return This : Text_Buffer do + This.Void_Ptr := new_fl_text_buffer + (Interfaces.C.int (Requested_Size), + Interfaces.C.int (Preferred_Gap_Size)); + fl_text_buffer_add_modify_callback + (This.Void_Ptr, + Storage.To_Integer (Modify_Callback_Hook'Address), + Storage.To_Integer (This'Address)); + fl_text_buffer_add_predelete_callback + (This.Void_Ptr, + Storage.To_Integer (Predelete_Callback_Hook'Address), + Storage.To_Integer (This'Address)); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Callbacks -- + + procedure Add_Modify_Callback + (This : in out Text_Buffer; + Func : in Modify_Callback) is + begin + This.Modify_CBs.Append (Func); + end Add_Modify_Callback; + + + procedure Add_Predelete_Callback + (This : in out Text_Buffer; + Func : in Predelete_Callback) is + begin + This.Predelete_CBs.Append (Func); + end Add_Predelete_Callback; + + + procedure Remove_Modify_Callback + (This : in out Text_Buffer; + Func : in Modify_Callback) is + begin + for I in reverse This.Modify_CBs.First_Index .. This.Modify_CBs.Last_Index loop + if This.Modify_CBs.Element (I) = Func then + This.Modify_CBs.Delete (I); + return; + end if; + end loop; + end Remove_Modify_Callback; + + + procedure Remove_Predelete_Callback + (This : in out Text_Buffer; + Func : in Predelete_Callback) is + begin + for I in reverse This.Predelete_CBs.First_Index .. This.Predelete_CBs.Last_Index loop + if This.Predelete_CBs.Element (I) = Func then + This.Predelete_CBs.Delete (I); + return; + end if; + end loop; + end Remove_Predelete_Callback; + + + procedure Call_Modify_Callbacks + (This : in out Text_Buffer) is + begin + fl_text_buffer_call_modify_callbacks (This.Void_Ptr); + end Call_Modify_Callbacks; + + + procedure Call_Predelete_Callbacks + (This : in out Text_Buffer) is + begin + fl_text_buffer_call_predelete_callbacks (This.Void_Ptr); + end Call_Predelete_Callbacks; + + + procedure Enable_Callbacks + (This : in out Text_Buffer) is + begin + This.CB_Active := True; + end Enable_Callbacks; + + + procedure Disable_Callbacks + (This : in out Text_Buffer) is + begin + This.CB_Active := False; + end Disable_Callbacks; + + + + + -- Files -- + + procedure Load_File + (This : in out Text_Buffer; + Name : in String; + Buffer : in Natural := 128 * 1024) + is + Err_No : constant Interfaces.C.int := fl_text_buffer_loadfile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Buffer)); + begin + if Err_No /= 0 then + raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); + end if; + end Load_File; + + + procedure Append_File + (This : in out Text_Buffer; + Name : in String; + Buffer : in Natural := 128 * 1024) + is + Err_No : constant Interfaces.C.int := fl_text_buffer_appendfile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Buffer)); + begin + if Err_No /= 0 then + raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); + end if; + end Append_File; + + + procedure Insert_File + (This : in out Text_Buffer; + Name : in String; + Place : in Position; + Buffer : in Natural := 128 * 1024) + is + Err_No : constant Interfaces.C.int := fl_text_buffer_insertfile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Place), + Interfaces.C.int (Buffer)); + begin + if Err_No /= 0 then + raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); + end if; + end Insert_File; + + + procedure Output_File + (This : in Text_Buffer; + Name : in String; + Start, Finish : in Position; + Buffer : in Natural := 128 * 1024) + is + Err_No : constant Interfaces.C.int := fl_text_buffer_outputfile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Start), + Interfaces.C.int (Finish), + Interfaces.C.int (Buffer)); + begin + if Err_No /= 0 then + raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); + end if; + end Output_File; + + + procedure Save_File + (This : in Text_Buffer; + Name : in String; + Buffer : in Natural := 128 * 1024) + is + Err_No : constant Interfaces.C.int := fl_text_buffer_savefile + (This.Void_Ptr, + Interfaces.C.To_C (Name), + Interfaces.C.int (Buffer)); + begin + if Err_No /= 0 then + raise Storage_Error with Interfaces.C.Strings.Value (strerror (Err_No)); + end if; + end Save_File; + + + + + -- Modification -- + + procedure Insert_Text + (This : in out Text_Buffer; + Place : in Position; + Text : in String) is + begin + fl_text_buffer_insert + (This.Void_Ptr, + Interfaces.C.int (Place), + Interfaces.C.To_C (Text)); + end Insert_Text; + + + procedure Append_Text + (This : in out Text_Buffer; + Text : in String) is + begin + fl_text_buffer_append + (This.Void_Ptr, + Interfaces.C.To_C (Text)); + end Append_Text; + + + procedure Replace_Text + (This : in out Text_Buffer; + Start, Finish : in Position; + Text : in String) is + begin + fl_text_buffer_replace + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish), + Interfaces.C.To_C (Text)); + end Replace_Text; + + + procedure Remove_Text + (This : in out Text_Buffer; + Start, Finish : in Position) is + begin + fl_text_buffer_remove + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Remove_Text; + + + function Get_Entire_Text + (This : in Text_Buffer) + return String + is + Raw : Interfaces.C.Strings.chars_ptr := + fl_text_buffer_get_text (This.Void_Ptr); + begin + if Raw = Interfaces.C.Strings.Null_Ptr then + return ""; + else + declare + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); + begin + Interfaces.C.Strings.Free (Raw); + return Ada_String; + end; + end if; + end Get_Entire_Text; + + + procedure Set_Entire_Text + (This : in out Text_Buffer; + Text : in String) is + begin + fl_text_buffer_set_text (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Set_Entire_Text; + + + function Byte_At + (This : in Text_Buffer; + Place : in Position) + return Character is + begin + return Character'Val (Interfaces.C.char'Pos + (fl_text_buffer_byte_at (This.Void_Ptr, Interfaces.C.int (Place)))); + end Byte_At; + + + function Character_At + (This : in Text_Buffer; + Place : in Position) + return Character is + begin + return Character'Val (fl_text_buffer_char_at + (This.Void_Ptr, + Interfaces.C.int (Place))); + end Character_At; + + + function Text_At + (This : in Text_Buffer; + Start, Finish : in Position) + return String + is + C_Str : Interfaces.C.Strings.chars_ptr := fl_text_buffer_text_range + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + begin + if C_Str = Interfaces.C.Strings.Null_Ptr then + return ""; + else + declare + The_Text : constant String := Interfaces.C.Strings.Value (C_Str); + begin + Interfaces.C.Strings.Free (C_Str); + return The_Text; + end; + end if; + end Text_At; + + + function Next_Char + (This : in Text_Buffer; + Place : in Position) + return Character is + begin + return Character'Val (fl_text_buffer_next_char + (This.Void_Ptr, + Interfaces.C.int (Place))); + end Next_Char; + + + function Prev_Char + (This : in Text_Buffer; + Place : in Position) + return Character is + begin + return Character'Val (fl_text_buffer_prev_char + (This.Void_Ptr, + Interfaces.C.int (Place))); + end Prev_Char; + + + + + -- Measurement -- + + function Count_Displayed_Characters + (This : in Text_Buffer; + Start, Finish : in Position) + return Integer is + begin + return Integer (fl_text_buffer_count_displayed_characters + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish))); + end Count_Displayed_Characters; + + + function Count_Lines + (This : in Text_Buffer; + Start, Finish : in Position) + return Integer is + begin + return Integer (fl_text_buffer_count_lines + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish))); + end Count_Lines; + + + function Length + (This : in Text_Buffer) + return Natural is + begin + return Natural (fl_text_buffer_length (This.Void_Ptr)); + end Length; + + + function Get_Tab_Width + (This : in Text_Buffer) + return Natural is + begin + return Natural (fl_text_buffer_get_tab_distance (This.Void_Ptr)); + end Get_Tab_Width; + + + procedure Set_Tab_Width + (This : in out Text_Buffer; + To : in Natural) is + begin + fl_text_buffer_set_tab_distance (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Tab_Width; + + + + + -- Selection -- + + function Get_Selection + (This : in Text_Buffer; + Start, Finish : out Position) + return Boolean + is + S, F : Interfaces.C.int; + begin + if fl_text_buffer_selection_position (This.Void_Ptr, S, F) /= 0 then + Start := Position (S); + Finish := Position (F); + return True; + else + return False; + end if; + end Get_Selection; + + + function Get_Secondary_Selection + (This : in Text_Buffer; + Start, Finish : out Position) + return Boolean + is + S, F : Interfaces.C.int; + begin + if fl_text_buffer_secondary_selection_position (This.Void_Ptr, S, F) /= 0 then + Start := Position (S); + Finish := Position (F); + return True; + else + return False; + end if; + end Get_Secondary_Selection; + + + procedure Set_Selection + (This : in out Text_Buffer; + Start, Finish : in Position) is + begin + fl_text_buffer_select + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Set_Selection; + + + procedure Set_Secondary_Selection + (This : in out Text_Buffer; + Start, Finish : in Position) is + begin + fl_text_buffer_secondary_select + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Set_Secondary_Selection; + + + function Has_Selection + (This : in Text_Buffer) + return Boolean is + begin + return fl_text_buffer_selected (This.Void_Ptr) /= 0; + end Has_Selection; + + + function Has_Secondary_Selection + (This : in Text_Buffer) + return Boolean is + begin + return fl_text_buffer_secondary_selected (This.Void_Ptr) /= 0; + end Has_Secondary_Selection; + + + function Selection_Text + (This : in Text_Buffer) + return String + is + Raw : Interfaces.C.Strings.chars_ptr := + fl_text_buffer_selection_text (This.Void_Ptr); + begin + if Raw = Interfaces.C.Strings.Null_Ptr then + return ""; + else + declare + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); + begin + Interfaces.C.Strings.Free (Raw); + return Ada_String; + end; + end if; + end Selection_Text; + + + function Secondary_Selection_Text + (This : in Text_Buffer) + return String + is + Raw : Interfaces.C.Strings.chars_ptr := + fl_text_buffer_secondary_selection_text (This.Void_Ptr); + begin + if Raw = Interfaces.C.Strings.Null_Ptr then + return ""; + else + declare + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); + begin + Interfaces.C.Strings.Free (Raw); + return Ada_String; + end; + end if; + end Secondary_Selection_Text; + + + procedure Replace_Selection + (This : in out Text_Buffer; + Text : in String) is + begin + fl_text_buffer_replace_selection (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Replace_Selection; + + + procedure Replace_Secondary_Selection + (This : in out Text_Buffer; + Text : in String) is + begin + fl_text_buffer_replace_secondary_selection (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Replace_Secondary_Selection; + + + procedure Remove_Selection + (This : in out Text_Buffer) is + begin + fl_text_buffer_remove_selection (This.Void_Ptr); + end Remove_Selection; + + + procedure Remove_Secondary_Selection + (This : in out Text_Buffer) is + begin + fl_text_buffer_remove_secondary_selection (This.Void_Ptr); + end Remove_Secondary_Selection; + + + procedure Unselect + (This : in out Text_Buffer) is + begin + fl_text_buffer_unselect (This.Void_Ptr); + end Unselect; + + + procedure Secondary_Unselect + (This : in out Text_Buffer) is + begin + fl_text_buffer_secondary_unselect (This.Void_Ptr); + end Secondary_Unselect; + + + + + -- Highlighting -- + + procedure Get_Highlight + (This : in Text_Buffer; + Start, Finish : out Position) is + begin + Start := This.High_From; + Finish := This.High_To; + end Get_Highlight; + + + procedure Set_Highlight + (This : in out Text_Buffer; + Start, Finish : in Position) is + begin + This.High_From := Start; + This.High_To := Finish; + fl_text_buffer_highlight + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Set_Highlight; + + + function Get_Highlighted_Text + (This : in Text_Buffer) + return String + is + Raw : Interfaces.C.Strings.chars_ptr := + fl_text_buffer_highlight_text (This.Void_Ptr); + begin + if Raw = Interfaces.C.Strings.Null_Ptr then + return ""; + else + declare + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); + begin + Interfaces.C.Strings.Free (Raw); + return Ada_String; + end; + end if; + end Get_Highlighted_Text; + + + procedure Unhighlight + (This : in out Text_Buffer) is + begin + fl_text_buffer_unhighlight (This.Void_Ptr); + end Unhighlight; + + + + + -- Search -- + + function Findchar_Forward + (This : in Text_Buffer; + Start_At : in Position; + Item : in Character; + Found_At : out Position) + return Boolean + is + Place : Interfaces.C.int; + begin + if fl_text_buffer_findchar_forward + (This.Void_Ptr, + Interfaces.C.int (Start_At), + Character'Pos (Item), + Place) /= 0 + then + Found_At := Position (Place); + return True; + else + return False; + end if; + end Findchar_Forward; + + + function Findchar_Backward + (This : in Text_Buffer; + Start_At : in Position; + Item : in Character; + Found_At : out Position) + return Boolean + is + Place : Interfaces.C.int; + begin + if fl_text_buffer_findchar_backward + (This.Void_Ptr, + Interfaces.C.int (Start_At), + Character'Pos (Item), + Place) /= 0 + then + Found_At := Position (Place); + return True; + else + return False; + end if; + end Findchar_Backward; + + + function Search_Forward + (This : in Text_Buffer; + Start_At : in Position; + Item : in String; + Found_At : out Position; + Match_Case : in Boolean := False) + return Boolean + is + Place : Interfaces.C.int; + begin + if fl_text_buffer_search_forward + (This.Void_Ptr, + Interfaces.C.int (Start_At), + Interfaces.C.To_C (Item), + Place, + Boolean'Pos (Match_Case)) /= 0 + then + Found_At := Position (Place); + return True; + else + return False; + end if; + end Search_Forward; + + + function Search_Backward + (This : in Text_Buffer; + Start_At : in Position; + Item : in String; + Found_At : out Position; + Match_Case : in Boolean := False) + return Boolean + is + Place : Interfaces.C.int; + begin + if fl_text_buffer_search_backward + (This.Void_Ptr, + Interfaces.C.int (Start_At), + Interfaces.C.To_C (Item), + Place, + Boolean'Pos (Match_Case)) /= 0 + then + Found_At := Position (Place); + return True; + else + return False; + end if; + end Search_Backward; + + + + + -- Navigation -- + + function Word_Start + (This : in Text_Buffer; + Place : in Position) + return Position is + begin + return Position (fl_text_buffer_word_start (This.Void_Ptr, Interfaces.C.int (Place))); + end Word_Start; + + + function Word_End + (This : in Text_Buffer; + Place : in Position) + return Position is + begin + return Position (fl_text_buffer_word_end (This.Void_Ptr, Interfaces.C.int (Place))); + end Word_End; + + + function Line_Start + (This : in Text_Buffer; + Place : in Position) + return Position is + begin + return Position (fl_text_buffer_line_start (This.Void_Ptr, Interfaces.C.int (Place))); + end Line_Start; + + + function Line_End + (This : in Text_Buffer; + Place : in Position) + return Position is + begin + return Position (fl_text_buffer_line_end (This.Void_Ptr, Interfaces.C.int (Place))); + end Line_End; + + + function Line_Text + (This : in Text_Buffer; + Place : in Position) + return String + is + Raw : Interfaces.C.Strings.chars_ptr := fl_text_buffer_line_text + (This.Void_Ptr, + Interfaces.C.int (Place)); + begin + if Raw = Interfaces.C.Strings.Null_Ptr then + return ""; + else + declare + Ada_String : constant String := Interfaces.C.Strings.Value (Raw); + begin + Interfaces.C.Strings.Free (Raw); + return Ada_String; + end; + end if; + end Line_Text; + + + function Skip_Lines + (This : in out Text_Buffer; + Start : in Position; + Lines : in Natural) + return Position is + begin + return Natural (fl_text_buffer_skip_lines + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines))); + end Skip_Lines; + + + function Rewind_Lines + (This : in out Text_Buffer; + Start : in Position; + Lines : in Natural) + return Position is + begin + return Natural (fl_text_buffer_rewind_lines + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines))); + end Rewind_Lines; + + + function Skip_Displayed_Characters + (This : in Text_Buffer; + Start : in Position; + Chars : in Natural) + return Position is + begin + return Natural (fl_text_buffer_skip_displayed_characters + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Chars))); + end Skip_Displayed_Characters; + + + + + -- Miscellaneous -- + + procedure Can_Undo + (This : in out Text_Buffer; + Flag : in Boolean) is + begin + fl_text_buffer_canundo (This.Void_Ptr, Interfaces.C.char'Val (Boolean'Pos (Flag))); + end Can_Undo; + + + procedure Copy + (This : in out Text_Buffer; + From : in Text_Buffer; + Start, Finish : in Position; + Insert_Pos : in Position) is + begin + fl_text_buffer_copy + (This.Void_Ptr, + From.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish), + Interfaces.C.int (Insert_Pos)); + end Copy; + + + function UTF8_Align + (This : in Text_Buffer; + Place : in Position) + return Position is + begin + return Position (fl_text_buffer_utf8_align (This.Void_Ptr, Interfaces.C.int (Place))); + end UTF8_Align; + + +end FLTK.Text_Buffers; + + diff --git a/body/fltk-tooltips.adb b/body/fltk-tooltips.adb new file mode 100644 index 0000000..8382bb4 --- /dev/null +++ b/body/fltk-tooltips.adb @@ -0,0 +1,391 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int; + + +package body FLTK.Tooltips is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Activity -- + + function fl_tooltip_get_current + return Storage.Integer_Address; + pragma Import (C, fl_tooltip_get_current, "fl_tooltip_get_current"); + pragma Inline (fl_tooltip_get_current); + + procedure fl_tooltip_set_current + (I : in Storage.Integer_Address); + pragma Import (C, fl_tooltip_set_current, "fl_tooltip_set_current"); + pragma Inline (fl_tooltip_set_current); + + function fl_tooltip_enabled + return Interfaces.C.int; + pragma Import (C, fl_tooltip_enabled, "fl_tooltip_enabled"); + pragma Inline (fl_tooltip_enabled); + + procedure fl_tooltip_enable + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_enable, "fl_tooltip_enable"); + pragma Inline (fl_tooltip_enable); + + procedure fl_tooltip_disable; + pragma Import (C, fl_tooltip_disable, "fl_tooltip_disable"); + pragma Inline (fl_tooltip_disable); + + procedure fl_tooltip_enter_area + (I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_tooltip_enter_area, "fl_tooltip_enter_area"); + pragma Inline (fl_tooltip_enter_area); + + + + + -- Delay -- + + function fl_tooltip_get_delay + return Interfaces.C.C_float; + pragma Import (C, fl_tooltip_get_delay, "fl_tooltip_get_delay"); + pragma Inline (fl_tooltip_get_delay); + + procedure fl_tooltip_set_delay + (V : in Interfaces.C.C_float); + pragma Import (C, fl_tooltip_set_delay, "fl_tooltip_set_delay"); + pragma Inline (fl_tooltip_set_delay); + + function fl_tooltip_get_hoverdelay + return Interfaces.C.C_float; + pragma Import (C, fl_tooltip_get_hoverdelay, "fl_tooltip_get_hoverdelay"); + pragma Inline (fl_tooltip_get_hoverdelay); + + procedure fl_tooltip_set_hoverdelay + (V : in Interfaces.C.C_float); + pragma Import (C, fl_tooltip_set_hoverdelay, "fl_tooltip_set_hoverdelay"); + pragma Inline (fl_tooltip_set_hoverdelay); + + + + + -- Color, Margins, Wrap -- + + function fl_tooltip_get_color + return Interfaces.C.unsigned; + pragma Import (C, fl_tooltip_get_color, "fl_tooltip_get_color"); + pragma Inline (fl_tooltip_get_color); + + procedure fl_tooltip_set_color + (V : in Interfaces.C.unsigned); + pragma Import (C, fl_tooltip_set_color, "fl_tooltip_set_color"); + pragma Inline (fl_tooltip_set_color); + + function fl_tooltip_get_margin_height + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_margin_height, "fl_tooltip_get_margin_height"); + pragma Inline (fl_tooltip_get_margin_height); + + procedure fl_tooltip_set_margin_height + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_margin_height, "fl_tooltip_set_margin_height"); + pragma Inline (fl_tooltip_set_margin_height); + + function fl_tooltip_get_margin_width + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_margin_width, "fl_tooltip_get_margin_width"); + pragma Inline (fl_tooltip_get_margin_width); + + procedure fl_tooltip_set_margin_width + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_margin_width, "fl_tooltip_set_margin_width"); + pragma Inline (fl_tooltip_set_margin_width); + + function fl_tooltip_get_wrap_width + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_wrap_width, "fl_tooltip_get_wrap_width"); + pragma Inline (fl_tooltip_get_wrap_width); + + procedure fl_tooltip_set_wrap_width + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_wrap_width, "fl_tooltip_set_wrap_width"); + pragma Inline (fl_tooltip_set_wrap_width); + + + + + -- Text Settings -- + + function fl_tooltip_get_textcolor + return Interfaces.C.unsigned; + pragma Import (C, fl_tooltip_get_textcolor, "fl_tooltip_get_textcolor"); + pragma Inline (fl_tooltip_get_textcolor); + + procedure fl_tooltip_set_textcolor + (V : in Interfaces.C.unsigned); + pragma Import (C, fl_tooltip_set_textcolor, "fl_tooltip_set_textcolor"); + pragma Inline (fl_tooltip_set_textcolor); + + function fl_tooltip_get_font + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_font, "fl_tooltip_get_font"); + pragma Inline (fl_tooltip_get_font); + + procedure fl_tooltip_set_font + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_font, "fl_tooltip_set_font"); + pragma Inline (fl_tooltip_set_font); + + function fl_tooltip_get_size + return Interfaces.C.int; + pragma Import (C, fl_tooltip_get_size, "fl_tooltip_get_size"); + pragma Inline (fl_tooltip_get_size); + + procedure fl_tooltip_set_size + (V : in Interfaces.C.int); + pragma Import (C, fl_tooltip_set_size, "fl_tooltip_set_size"); + pragma Inline (fl_tooltip_set_size); + + + + + -- User Data -- + + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + pragma Inline (fl_widget_get_user_data); + + package Widget_Convert is new + System.Address_To_Access_Conversions (FLTK.Widgets.Widget'Class); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Activity -- + + function Get_Target + return access FLTK.Widgets.Widget'Class + is + Widget_Ptr : Storage.Integer_Address := fl_tooltip_get_current; + Actual_Widget : access FLTK.Widgets.Widget'Class; + begin + if Widget_Ptr /= Null_Pointer then + Widget_Ptr := fl_widget_get_user_data (Widget_Ptr); + pragma Assert (Widget_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Tooltip::current did not have user_data reference back to Ada"; + end Get_Target; + + + procedure Set_Target + (To : in FLTK.Widgets.Widget'Class) is + begin + fl_tooltip_set_current (Wrapper (To).Void_Ptr); + end Set_Target; + + + function Is_Enabled + return Boolean is + begin + return fl_tooltip_enabled /= 0; + end Is_Enabled; + + + procedure Set_Enabled + (To : in Boolean := True) is + begin + fl_tooltip_enable (Boolean'Pos (To)); + end Set_Enabled; + + + procedure Disable is + begin + fl_tooltip_disable; + end Disable; + + + procedure Enter_Area + (Item : in FLTK.Widgets.Widget'Class; + X, Y, W, H : in Integer; + Tip : in String) is + begin + fl_tooltip_enter_area + (Wrapper (Item).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Tip)); + end Enter_Area; + + + + + -- Delay -- + + function Get_Delay + return Float is + begin + return Float (fl_tooltip_get_delay); + end Get_Delay; + + + procedure Set_Delay + (To : in Float) is + begin + fl_tooltip_set_delay (Interfaces.C.C_float (To)); + end Set_Delay; + + + function Get_Hover_Delay + return Float is + begin + return Float (fl_tooltip_get_hoverdelay); + end Get_Hover_Delay; + + + procedure Set_Hover_Delay + (To : in Float) is + begin + fl_tooltip_set_hoverdelay (Interfaces.C.C_float (To)); + end Set_Hover_Delay; + + + + + -- Color, Margins, Wrap -- + + function Get_Background_Color + return Color is + begin + return Color (fl_tooltip_get_color); + end Get_Background_Color; + + + procedure Set_Background_Color + (To : in Color) is + begin + fl_tooltip_set_color (Interfaces.C.unsigned (To)); + end Set_Background_Color; + + + function Get_Margin_Height + return Natural is + begin + return Natural (fl_tooltip_get_margin_height); + end Get_Margin_Height; + + + procedure Set_Margin_Height + (To : in Natural) is + begin + fl_tooltip_set_margin_height (Interfaces.C.int (To)); + end Set_Margin_Height; + + + function Get_Margin_Width + return Natural is + begin + return Natural (fl_tooltip_get_margin_width); + end Get_Margin_Width; + + + procedure Set_Margin_Width + (To : in Natural) is + begin + fl_tooltip_set_margin_width (Interfaces.C.int (To)); + end Set_Margin_Width; + + + function Get_Wrap_Width + return Natural is + begin + return Natural (fl_tooltip_get_wrap_width); + end Get_Wrap_Width; + + + procedure Set_Wrap_Width + (To : in Natural) is + begin + fl_tooltip_set_wrap_width (Interfaces.C.int (To)); + end Set_Wrap_Width; + + + + + -- Text Settings -- + + function Get_Text_Color + return Color is + begin + return Color (fl_tooltip_get_textcolor); + end Get_Text_Color; + + + procedure Set_Text_Color + (To : in Color) is + begin + fl_tooltip_set_textcolor (Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + return Font_Kind is + begin + return Font_Kind'Val (fl_tooltip_get_font); + end Get_Text_Font; + + + procedure Set_Text_Font + (To : in Font_Kind) is + begin + fl_tooltip_set_font (Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + return Font_Size is + begin + return Font_Size (fl_tooltip_get_size); + end Get_Text_Size; + + + procedure Set_Text_Size + (To : in Font_Size) is + begin + fl_tooltip_set_size (Interfaces.C.int (To)); + end Set_Text_Size; + + +end FLTK.Tooltips; + + diff --git a/body/fltk-widget_callback_conversions.adb b/body/fltk-widget_callback_conversions.adb new file mode 100644 index 0000000..29f920e --- /dev/null +++ b/body/fltk-widget_callback_conversions.adb @@ -0,0 +1,52 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Unchecked_Conversion, + FLTK.Widgets; + +use type + + FLTK.Widgets.Widget_Callback; + + +package body FLTK.Widget_Callback_Conversions is + + + function To_Access + (Addy : in Storage.Integer_Address) + return FLTK.Widgets.Widget_Callback + is + function Raw is new Ada.Unchecked_Conversion + (Storage.Integer_Address, FLTK.Widgets.Widget_Callback); + begin + if Addy = Null_Pointer then + return null; + else + return Raw (Addy); + end if; + end To_Access; + + + function To_Address + (Call : in FLTK.Widgets.Widget_Callback) + return Storage.Integer_Address + is + function Raw is new Ada.Unchecked_Conversion + (FLTK.Widgets.Widget_Callback, Storage.Integer_Address); + begin + if Call = null then + return Null_Pointer; + else + return Raw (Call); + end if; + end To_Address; + + +end FLTK.Widget_Callback_Conversions; + + diff --git a/body/fltk-widget_callback_conversions.ads b/body/fltk-widget_callback_conversions.ads new file mode 100644 index 0000000..09932b4 --- /dev/null +++ b/body/fltk-widget_callback_conversions.ads @@ -0,0 +1,26 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets; + + +private package FLTK.Widget_Callback_Conversions is + + + function To_Access + (Addy : in Storage.Integer_Address) + return FLTK.Widgets.Widget_Callback; + + function To_Address + (Call : in FLTK.Widgets.Widget_Callback) + return Storage.Integer_Address; + + +end FLTK.Widget_Callback_Conversions; + + diff --git a/body/fltk-widgets-boxes.adb b/body/fltk-widgets-boxes.adb new file mode 100644 index 0000000..efe6e54 --- /dev/null +++ b/body/fltk-widgets-boxes.adb @@ -0,0 +1,221 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Boxes is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_box + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_box, "new_fl_box"); + pragma Inline (new_fl_box); + + function new_fl_box2 + (K, X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_box2, "new_fl_box2"); + pragma Inline (new_fl_box2); + + procedure free_fl_box + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_box, "free_fl_box"); + pragma Inline (free_fl_box); + + + + + -- Drawing, Events -- + + procedure fl_box_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_box_draw, "fl_box_draw"); + pragma Inline (fl_box_draw); + + function fl_box_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_box_handle, "fl_box_handle"); + pragma Inline (fl_box_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Box) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Box) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_box (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Hole successfully dug out of + procedure box_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, box_extra_init_hook, "box_extra_init_hook"); + + procedure box_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Box : Box; + for My_Box'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Box); + begin + Extra_Init + (My_Box, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end box_extra_init_hook; + + + procedure Extra_Init + (This : in out Box; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Box) is + begin + This.Draw_Ptr := fl_box_draw'Address; + This.Handle_Ptr := fl_box_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Box is + begin + return This : Box do + This.Void_Ptr := new_fl_box + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Box is + begin + return This : Box := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Box is + begin + return This : Box do + This.Void_Ptr := new_fl_box2 + (Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Box is + begin + return This : Box := Create (Kind, X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Drawing, Events -- + + procedure Draw + (This : in out Box) is + begin + Widget (This).Draw; + end Draw; + + + function Handle + (This : in out Box; + Event : in Event_Kind) + return Event_Outcome is + begin + return Widget (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Boxes; + + diff --git a/body/fltk-widgets-buttons-enter.adb b/body/fltk-widgets-buttons-enter.adb new file mode 100644 index 0000000..35e0391 --- /dev/null +++ b/body/fltk-widgets-buttons-enter.adb @@ -0,0 +1,158 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Enter is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_return_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_return_button, "new_fl_return_button"); + pragma Inline (new_fl_return_button); + + procedure free_fl_return_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_return_button, "free_fl_return_button"); + pragma Inline (free_fl_return_button); + + + + + -- Drawing, Events -- + + procedure fl_return_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_return_button_draw, "fl_return_button_draw"); + pragma Inline (fl_return_button_draw); + + function fl_return_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_return_button_handle, "fl_return_button_handle"); + pragma Inline (fl_return_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Enter_Button) is + begin + Extra_Final (Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Enter_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_return_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Enter_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Enter_Button) is + begin + This.Draw_Ptr := fl_return_button_draw'Address; + This.Handle_Ptr := fl_return_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Enter_Button is + begin + return This : Enter_Button do + This.Void_Ptr := new_fl_return_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Enter_Button is + begin + return This : Enter_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Drawing, Events -- + + procedure Draw + (This : in out Enter_Button) is + begin + Button (This).Draw; + end Draw; + + + function Handle + (This : in out Enter_Button; + Event : in Event_Kind) + return Event_Outcome is + begin + return Button (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Buttons.Enter; + + diff --git a/body/fltk-widgets-buttons-light-check.adb b/body/fltk-widgets-buttons-light-check.adb new file mode 100644 index 0000000..c3f1971 --- /dev/null +++ b/body/fltk-widgets-buttons-light-check.adb @@ -0,0 +1,158 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C.Strings; + + +package body FLTK.Widgets.Buttons.Light.Check is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_check_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_check_button, "new_fl_check_button"); + pragma Inline (new_fl_check_button); + + procedure free_fl_check_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_check_button, "free_fl_check_button"); + pragma Inline (free_fl_check_button); + + + + + -- Drawing, Events -- + + procedure fl_check_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_check_button_draw, "fl_check_button_draw"); + pragma Inline (fl_check_button_draw); + + function fl_check_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_check_button_handle, "fl_check_button_handle"); + pragma Inline (fl_check_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Check_Button) is + begin + Extra_Final (Light_Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Check_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_check_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Arrived at the flip side + procedure check_button_extra_init_hook + (Ada_Obj : Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, check_button_extra_init_hook, "check_button_extra_init_hook"); + + procedure check_button_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Check_Button : Check_Button; + for My_Check_Button'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Check_Button); + begin + Extra_Init + (My_Check_Button, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end check_button_extra_init_hook; + + + procedure Extra_Init + (This : in out Check_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Light_Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Check_Button) is + begin + This.Draw_Ptr := fl_check_button_draw'Address; + This.Handle_Ptr := fl_check_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Check_Button is + begin + return This : Check_Button do + This.Void_Ptr := new_fl_check_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Check_Button is + begin + return This : Check_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Buttons.Light.Check; + + diff --git a/body/fltk-widgets-buttons-light-radio.adb b/body/fltk-widgets-buttons-light-radio.adb new file mode 100644 index 0000000..d65e1b0 --- /dev/null +++ b/body/fltk-widgets-buttons-light-radio.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Light.Radio is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_radio_light_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_radio_light_button, "new_fl_radio_light_button"); + pragma Inline (new_fl_radio_light_button); + + procedure free_fl_radio_light_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_radio_light_button, "free_fl_radio_light_button"); + pragma Inline (free_fl_radio_light_button); + + + + + -- Drawing, Events -- + + procedure fl_radio_light_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_radio_light_button_draw, "fl_radio_light_button_draw"); + pragma Inline (fl_radio_light_button_draw); + + function fl_radio_light_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_radio_light_button_handle, "fl_radio_light_button_handle"); + pragma Inline (fl_radio_light_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Radio_Light_Button) is + begin + Extra_Final (Light_Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Radio_Light_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_radio_light_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Radio_Light_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Light_Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Radio_Light_Button) is + begin + This.Draw_Ptr := fl_radio_light_button_draw'Address; + This.Handle_Ptr := fl_radio_light_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Light_Button is + begin + return This : Radio_Light_Button do + This.Void_Ptr := new_fl_radio_light_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Light_Button is + begin + return This : Radio_Light_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Buttons.Light.Radio; + + diff --git a/body/fltk-widgets-buttons-light-round-radio.adb b/body/fltk-widgets-buttons-light-round-radio.adb new file mode 100644 index 0000000..05745e1 --- /dev/null +++ b/body/fltk-widgets-buttons-light-round-radio.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Light.Round.Radio is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_radio_round_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_radio_round_button, "new_fl_radio_round_button"); + pragma Inline (new_fl_radio_round_button); + + procedure free_fl_radio_round_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_radio_round_button, "free_fl_radio_round_button"); + pragma Inline (free_fl_radio_round_button); + + + + + -- Drawing, Events -- + + procedure fl_radio_round_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_radio_round_button_draw, "fl_radio_round_button_draw"); + pragma Inline (fl_radio_round_button_draw); + + function fl_radio_round_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_radio_round_button_handle, "fl_radio_round_button_handle"); + pragma Inline (fl_radio_round_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Radio_Round_Button) is + begin + Extra_Final (Round_Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Radio_Round_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_radio_round_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Radio_Round_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Round_Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Radio_Round_Button) is + begin + This.Draw_Ptr := fl_radio_round_button_draw'Address; + This.Handle_Ptr := fl_radio_round_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Round_Button is + begin + return This : Radio_Round_Button do + This.Void_Ptr := new_fl_radio_round_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Round_Button is + begin + return This : Radio_Round_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Buttons.Light.Round.Radio; + + diff --git a/body/fltk-widgets-buttons-light-round.adb b/body/fltk-widgets-buttons-light-round.adb new file mode 100644 index 0000000..5798bf3 --- /dev/null +++ b/body/fltk-widgets-buttons-light-round.adb @@ -0,0 +1,133 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Light.Round is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_round_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_round_button, "new_fl_round_button"); + pragma Inline (new_fl_round_button); + + procedure free_fl_round_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_round_button, "free_fl_round_button"); + pragma Inline (free_fl_round_button); + + + + + -- Drawing, Events -- + + procedure fl_round_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_round_button_draw, "fl_round_button_draw"); + pragma Inline (fl_round_button_draw); + + function fl_round_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_round_button_handle, "fl_round_button_handle"); + pragma Inline (fl_round_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Round_Button) is + begin + Extra_Final (Light_Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Round_Button) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_round_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Round_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Light_Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Round_Button) is + begin + This.Draw_Ptr := fl_round_button_draw'Address; + This.Handle_Ptr := fl_round_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Round_Button is + begin + return This : Round_Button do + This.Void_Ptr := new_fl_round_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Round_Button is + begin + return This : Round_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Buttons.Light.Round; + + diff --git a/body/fltk-widgets-buttons-light.adb b/body/fltk-widgets-buttons-light.adb new file mode 100644 index 0000000..4da348f --- /dev/null +++ b/body/fltk-widgets-buttons-light.adb @@ -0,0 +1,158 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Light is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_light_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_light_button, "new_fl_light_button"); + pragma Inline (new_fl_light_button); + + procedure free_fl_light_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_light_button, "free_fl_light_button"); + pragma Inline (free_fl_light_button); + + + + + -- Drawing, Events -- + + procedure fl_light_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_light_button_draw, "fl_light_button_draw"); + pragma Inline (fl_light_button_draw); + + function fl_light_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_light_button_handle, "fl_light_button_handle"); + pragma Inline (fl_light_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Light_Button) is + begin + Extra_Final (Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Light_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_light_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Light_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Light_Button) is + begin + This.Draw_Ptr := fl_light_button_draw'Address; + This.Handle_Ptr := fl_light_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Light_Button is + begin + return This : Light_Button do + This.Void_Ptr := new_fl_light_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Light_Button is + begin + return This : Light_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Drawing, Events -- + + procedure Draw + (This : in out Light_Button) is + begin + Button (This).Draw; + end Draw; + + + function Handle + (This : in out Light_Button; + Event : in Event_Kind) + return Event_Outcome is + begin + return Button (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Buttons.Light; + + diff --git a/body/fltk-widgets-buttons-radio.adb b/body/fltk-widgets-buttons-radio.adb new file mode 100644 index 0000000..28dfb3d --- /dev/null +++ b/body/fltk-widgets-buttons-radio.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Radio is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_radio_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_radio_button, "new_fl_radio_button"); + pragma Inline (new_fl_radio_button); + + procedure free_fl_radio_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_radio_button, "free_fl_radio_button"); + pragma Inline (free_fl_radio_button); + + + + + -- Drawing, Events -- + + procedure fl_radio_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_radio_button_draw, "fl_radio_button_draw"); + pragma Inline (fl_radio_button_draw); + + function fl_radio_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_radio_button_handle, "fl_radio_button_handle"); + pragma Inline (fl_radio_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Radio_Button) is + begin + Extra_Final (Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Radio_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_radio_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Radio_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Radio_Button) is + begin + This.Draw_Ptr := fl_radio_button_draw'Address; + This.Handle_Ptr := fl_radio_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Button is + begin + return This : Radio_Button do + This.Void_Ptr := new_fl_radio_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Button is + begin + return This : Radio_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Buttons.Radio; + + diff --git a/body/fltk-widgets-buttons-repeat.adb b/body/fltk-widgets-buttons-repeat.adb new file mode 100644 index 0000000..51e75a4 --- /dev/null +++ b/body/fltk-widgets-buttons-repeat.adb @@ -0,0 +1,172 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Repeat is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_repeat_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_repeat_button, "new_fl_repeat_button"); + pragma Inline (new_fl_repeat_button); + + procedure free_fl_repeat_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_repeat_button, "free_fl_repeat_button"); + pragma Inline (free_fl_repeat_button); + + + + + -- Activity -- + + procedure fl_repeat_button_deactivate + (B : in Storage.Integer_Address); + pragma Import (C, fl_repeat_button_deactivate, "fl_repeat_button_deactivate"); + pragma Inline (fl_repeat_button_deactivate); + + + + + -- Drawing, Events -- + + procedure fl_repeat_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_repeat_button_draw, "fl_repeat_button_draw"); + pragma Inline (fl_repeat_button_draw); + + function fl_repeat_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_repeat_button_handle, "fl_repeat_button_handle"); + pragma Inline (fl_repeat_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Repeat_Button) is + begin + Extra_Final (Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Repeat_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_repeat_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Repeat_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Repeat_Button) is + begin + This.Draw_Ptr := fl_repeat_button_draw'Address; + This.Handle_Ptr := fl_repeat_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Repeat_Button is + begin + return This : Repeat_Button do + This.Void_Ptr := new_fl_repeat_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Repeat_Button is + begin + return This : Repeat_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Activity -- + + procedure Deactivate + (This : in out Repeat_Button) is + begin + fl_repeat_button_deactivate (This.Void_Ptr); + end Deactivate; + + + + + -- Events -- + + function Handle + (This : in out Repeat_Button; + Event : in Event_Kind) + return Event_Outcome is + begin + return Button (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Buttons.Repeat; + + diff --git a/body/fltk-widgets-buttons-toggle.adb b/body/fltk-widgets-buttons-toggle.adb new file mode 100644 index 0000000..1b96ea7 --- /dev/null +++ b/body/fltk-widgets-buttons-toggle.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Buttons.Toggle is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_toggle_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_toggle_button, "new_fl_toggle_button"); + pragma Inline (new_fl_toggle_button); + + procedure free_fl_toggle_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_toggle_button, "free_fl_toggle_button"); + pragma Inline (free_fl_toggle_button); + + + + + -- Drawing, Events -- + + procedure fl_toggle_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_toggle_button_draw, "fl_toggle_button_draw"); + pragma Inline (fl_toggle_button_draw); + + function fl_toggle_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_toggle_button_handle, "fl_toggle_button_handle"); + pragma Inline (fl_toggle_button_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Toggle_Button) is + begin + Extra_Final (Button (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Toggle_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_toggle_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Toggle_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Button (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Toggle_Button) is + begin + This.Draw_Ptr := fl_toggle_button_draw'Address; + This.Handle_Ptr := fl_toggle_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Toggle_Button is + begin + return This : Toggle_Button do + This.Void_Ptr := new_fl_toggle_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Toggle_Button is + begin + return This : Toggle_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Buttons.Toggle; + + diff --git a/body/fltk-widgets-buttons.adb b/body/fltk-widgets-buttons.adb new file mode 100644 index 0000000..2d1e169 --- /dev/null +++ b/body/fltk-widgets-buttons.adb @@ -0,0 +1,325 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C.Strings; + + +package body FLTK.Widgets.Buttons is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_button, "new_fl_button"); + pragma Inline (new_fl_button); + + procedure free_fl_button + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_button, "free_fl_button"); + pragma Inline (free_fl_button); + + + + + -- State -- + + function fl_button_get_state + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_button_get_state, "fl_button_get_state"); + pragma Inline (fl_button_get_state); + + procedure fl_button_set_state + (B : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_button_set_state, "fl_button_set_state"); + pragma Inline (fl_button_set_state); + + procedure fl_button_set_only + (B : in Storage.Integer_Address); + pragma Import (C, fl_button_set_only, "fl_button_set_only"); + pragma Inline (fl_button_set_only); + + + + + -- Settings -- + + function fl_button_get_down_box + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_button_get_down_box, "fl_button_get_down_box"); + pragma Inline (fl_button_get_down_box); + + procedure fl_button_set_down_box + (B : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_button_set_down_box, "fl_button_set_down_box"); + pragma Inline (fl_button_set_down_box); + + function fl_button_get_shortcut + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_button_get_shortcut, "fl_button_get_shortcut"); + pragma Inline (fl_button_get_shortcut); + + procedure fl_button_set_shortcut + (B : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_button_set_shortcut, "fl_button_set_shortcut"); + pragma Inline (fl_button_set_shortcut); + + + + + -- Drawing, Events -- + + procedure fl_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_button_draw, "fl_button_draw"); + pragma Inline (fl_button_draw); + + function fl_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_button_handle, "fl_button_handle"); + pragma Inline (fl_button_handle); + + + + + -- Miscellaneous -- + + procedure fl_button_simulate_key_action + (B : in Storage.Integer_Address); + pragma Import (C, fl_button_simulate_key_action, "fl_button_simulate_key_action"); + pragma Inline (fl_button_simulate_key_action); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Button) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Mobius strip traversal complete + procedure button_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, button_extra_init_hook, "button_extra_init_hook"); + + procedure button_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Button : Button; + for My_Button'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Button); + begin + Extra_Init + (My_Button, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end button_extra_init_hook; + + + procedure Extra_Init + (This : in out Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Button) is + begin + This.Draw_Ptr := fl_button_draw'Address; + This.Handle_Ptr := fl_button_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Button is + begin + return This : Button do + This.Void_Ptr := new_fl_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Button is + begin + return This : Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- State -- + + function Is_On + (This : in Button) + return Boolean is + begin + return This.Get_State = On; + end Is_On; + + + function Get_State + (This : in Button) + return State is + begin + return State'Val (fl_button_get_state (This.Void_Ptr)); + end Get_State; + + + procedure Set_State + (This : in out Button; + St : in State) is + begin + fl_button_set_state (This.Void_Ptr, State'Pos (St)); + end Set_State; + + + procedure Set_Only + (This : in out Button) is + begin + fl_button_set_only (This.Void_Ptr); + end Set_Only; + + + + + -- Settings -- + + function Get_Down_Box + (This : in Button) + return Box_Kind is + begin + return Box_Kind'Val (fl_button_get_down_box (This.Void_Ptr)); + end Get_Down_Box; + + + procedure Set_Down_Box + (This : in out Button; + To : in Box_Kind) is + begin + fl_button_set_down_box (This.Void_Ptr, Box_Kind'Pos (To)); + end Set_Down_Box; + + + function Get_Shortcut + (This : in Button) + return Key_Combo is + begin + return To_Ada (Interfaces.C.unsigned (fl_button_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Button; + Key : in Key_Combo) is + begin + fl_button_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (Key))); + end Set_Shortcut; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Button) is + begin + Widget (This).Draw; + end Draw; + + + function Handle + (This : in out Button; + Event : in Event_Kind) + return Event_Outcome is + begin + return Widget (This).Handle (Event); + end Handle; + + + + + -- Miscellaneous -- + + procedure Simulate_Key_Action + (This : in out Button) is + begin + fl_button_simulate_key_action (This.Void_Ptr); + end Simulate_Key_Action; + + +end FLTK.Widgets.Buttons; + + diff --git a/body/fltk-widgets-charts.adb b/body/fltk-widgets-charts.adb new file mode 100644 index 0000000..b4a4bfe --- /dev/null +++ b/body/fltk-widgets-charts.adb @@ -0,0 +1,475 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Charts is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_chart + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_chart, "new_fl_chart"); + pragma Inline (new_fl_chart); + + procedure free_fl_chart + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_chart, "free_fl_chart"); + pragma Inline (free_fl_chart); + + + + + -- Data -- + + procedure fl_chart_add + (C : in Storage.Integer_Address; + V : in Interfaces.C.double; + L : in Interfaces.C.char_array; + P : in Interfaces.C.unsigned); + pragma Import (C, fl_chart_add, "fl_chart_add"); + pragma Inline (fl_chart_add); + + procedure fl_chart_insert + (C : in Storage.Integer_Address; + I : in Interfaces.C.int; + V : in Interfaces.C.double; + L : in Interfaces.C.char_array; + P : in Interfaces.C.unsigned); + pragma Import (C, fl_chart_insert, "fl_chart_insert"); + pragma Inline (fl_chart_insert); + + procedure fl_chart_replace + (C : in Storage.Integer_Address; + I : in Interfaces.C.int; + V : in Interfaces.C.double; + L : in Interfaces.C.char_array; + P : in Interfaces.C.unsigned); + pragma Import (C, fl_chart_replace, "fl_chart_replace"); + pragma Inline (fl_chart_replace); + + procedure fl_chart_clear + (C : in Storage.Integer_Address); + pragma Import (C, fl_chart_clear, "fl_chart_clear"); + pragma Inline (fl_chart_clear); + + + + + -- Settings -- + + function fl_chart_get_autosize + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_chart_get_autosize, "fl_chart_get_autosize"); + pragma Inline (fl_chart_get_autosize); + + procedure fl_chart_set_autosize + (C : in Storage.Integer_Address; + A : in Interfaces.C.int); + pragma Import (C, fl_chart_set_autosize, "fl_chart_set_autosize"); + pragma Inline (fl_chart_set_autosize); + + procedure fl_chart_get_bounds + (C : in Storage.Integer_Address; + L, U : out Interfaces.C.double); + pragma Import (C, fl_chart_get_bounds, "fl_chart_get_bounds"); + pragma Inline (fl_chart_get_bounds); + + procedure fl_chart_set_bounds + (C : in Storage.Integer_Address; + L, U : in Interfaces.C.double); + pragma Import (C, fl_chart_set_bounds, "fl_chart_set_bounds"); + pragma Inline (fl_chart_set_bounds); + + function fl_chart_get_maxsize + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_chart_get_maxsize, "fl_chart_get_maxsize"); + pragma Inline (fl_chart_get_maxsize); + + procedure fl_chart_set_maxsize + (C : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_chart_set_maxsize, "fl_chart_set_maxsize"); + pragma Inline (fl_chart_set_maxsize); + + function fl_chart_size + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_chart_size, "fl_chart_size"); + pragma Inline (fl_chart_size); + + + + + -- Text Settings -- + + function fl_chart_get_textcolor + (C : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_chart_get_textcolor, "fl_chart_get_textcolor"); + pragma Inline (fl_chart_get_textcolor); + + procedure fl_chart_set_textcolor + (C : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_chart_set_textcolor, "fl_chart_set_textcolor"); + pragma Inline (fl_chart_set_textcolor); + + function fl_chart_get_textfont + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_chart_get_textfont, "fl_chart_get_textfont"); + pragma Inline (fl_chart_get_textfont); + + procedure fl_chart_set_textfont + (C : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_chart_set_textfont, "fl_chart_set_textfont"); + pragma Inline (fl_chart_set_textfont); + + function fl_chart_get_textsize + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_chart_get_textsize, "fl_chart_get_textsize"); + pragma Inline (fl_chart_get_textsize); + + procedure fl_chart_set_textsize + (C : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_chart_set_textsize, "fl_chart_set_textsize"); + pragma Inline (fl_chart_set_textsize); + + + + + -- Dimensions -- + + procedure fl_chart_size2 + (C : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_chart_size2, "fl_chart_size2"); + pragma Inline (fl_chart_size2); + + + + + -- Drawing, Events -- + + procedure fl_chart_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_chart_draw, "fl_chart_draw"); + pragma Inline (fl_chart_draw); + + function fl_chart_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_chart_handle, "fl_chart_handle"); + pragma Inline (fl_chart_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Chart) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Chart) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_chart (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Chart; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Chart) is + begin + This.Draw_Ptr := fl_chart_draw'Address; + This.Handle_Ptr := fl_chart_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Chart is + begin + return This : Chart do + This.Void_Ptr := new_fl_chart + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Chart is + begin + return This : Chart := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Data -- + + procedure Add + (This : in out Chart; + Data_Value : in Long_Float; + Data_Label : in String := ""; + Data_Color : in Color := Foreground_Color) is + begin + fl_chart_add + (This.Void_Ptr, + Interfaces.C.double (Data_Value), + Interfaces.C.To_C (Data_Label), + Interfaces.C.unsigned (Data_Color)); + end Add; + + + procedure Insert + (This : in out Chart; + Position : in Natural; + Data_Value : in Long_Float; + Data_Label : in String := ""; + Data_Color : in Color := Foreground_Color) is + begin + fl_chart_insert + (This.Void_Ptr, + Interfaces.C.int (Position), + Interfaces.C.double (Data_Value), + Interfaces.C.To_C (Data_Label), + Interfaces.C.unsigned (Data_Color)); + end Insert; + + + procedure Replace + (This : in out Chart; + Position : in Natural; + Data_Value : in Long_Float; + Data_Label : in String := ""; + Data_Color : in Color := Foreground_Color) is + begin + fl_chart_replace + (This.Void_Ptr, + Interfaces.C.int (Position), + Interfaces.C.double (Data_Value), + Interfaces.C.To_C (Data_Label), + Interfaces.C.unsigned (Data_Color)); + end Replace; + + + procedure Clear + (This : in out Chart) is + begin + fl_chart_clear (This.Void_Ptr); + end Clear; + + + + + -- Settings -- + + function Will_Autosize + (This : in Chart) + return Boolean is + begin + return fl_chart_get_autosize (This.Void_Ptr) /= 0; + end Will_Autosize; + + + procedure Set_Autosize + (This : in out Chart; + To : in Boolean) is + begin + fl_chart_set_autosize (This.Void_Ptr, Boolean'Pos (To)); + end Set_Autosize; + + + procedure Get_Bounds + (This : in Chart; + Lower, Upper : out Long_Float) is + begin + fl_chart_get_bounds + (This.Void_Ptr, + Interfaces.C.double (Lower), + Interfaces.C.double (Upper)); + end Get_Bounds; + + + procedure Set_Bounds + (This : in out Chart; + Lower, Upper : in Long_Float) is + begin + fl_chart_set_bounds + (This.Void_Ptr, + Interfaces.C.double (Lower), + Interfaces.C.double (Upper)); + end Set_Bounds; + + + function Get_Maximum_Size + (This : in Chart) + return Natural is + begin + return Natural (fl_chart_get_maxsize (This.Void_Ptr)); + end Get_Maximum_Size; + + + procedure Set_Maximum_Size + (This : in out Chart; + To : in Natural) is + begin + fl_chart_set_maxsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Maximum_Size; + + + function Get_Size + (This : in Chart) + return Natural is + begin + return Natural (fl_chart_size (This.Void_Ptr)); + end Get_Size; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Chart) + return Color is + begin + return Color (fl_chart_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Chart; + To : in Color) is + begin + fl_chart_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Chart) + return Font_Kind is + begin + return Font_Kind'Val (fl_chart_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Chart; + To : in Font_Kind) is + begin + fl_chart_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Chart) + return Font_Size is + begin + return Font_Size (fl_chart_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Chart; + To : in Font_Size) is + begin + fl_chart_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Chart; + W, H : in Integer) is + begin + fl_chart_size2 (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)); + end Resize; + + + + + -- Drawing -- + + procedure Draw + (This : in out Chart) is + begin + Widget (This).Draw; + end Draw; + + +end FLTK.Widgets.Charts; + + diff --git a/body/fltk-widgets-clocks-updated-round.adb b/body/fltk-widgets-clocks-updated-round.adb new file mode 100644 index 0000000..a91584e --- /dev/null +++ b/body/fltk-widgets-clocks-updated-round.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Clocks.Updated.Round is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_round_clock + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_round_clock, "new_fl_round_clock"); + pragma Inline (new_fl_round_clock); + + procedure free_fl_round_clock + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_round_clock, "free_fl_round_clock"); + pragma Inline (free_fl_round_clock); + + + + + -- Drawing, Events -- + + procedure fl_round_clock_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_round_clock_draw, "fl_round_clock_draw"); + pragma Inline (fl_round_clock_draw); + + function fl_round_clock_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_round_clock_handle, "fl_round_clock_handle"); + pragma Inline (fl_round_clock_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Round_Clock) is + begin + Extra_Final (Updated_Clock (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Round_Clock) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_round_clock (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Round_Clock; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Updated_Clock (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Round_Clock) is + begin + This.Draw_Ptr := fl_round_clock_draw'Address; + This.Handle_Ptr := fl_round_clock_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Round_Clock is + begin + return This : Round_Clock do + This.Void_Ptr := new_fl_round_clock + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Round_Clock is + begin + return This : Round_Clock := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Clocks.Updated.Round; + + diff --git a/body/fltk-widgets-clocks-updated.adb b/body/fltk-widgets-clocks-updated.adb new file mode 100644 index 0000000..63337f1 --- /dev/null +++ b/body/fltk-widgets-clocks-updated.adb @@ -0,0 +1,190 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Clocks.Updated is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_clock + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_clock, "new_fl_clock"); + pragma Inline (new_fl_clock); + + function new_fl_clock2 + (K : in Interfaces.C.unsigned_char; + X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_clock2, "new_fl_clock2"); + pragma Inline (new_fl_clock2); + + procedure free_fl_clock + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_clock, "free_fl_clock"); + pragma Inline (free_fl_clock); + + + + + -- Drawing, Events -- + + procedure fl_clock_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_clock_draw, "fl_clock_draw"); + pragma Inline (fl_clock_draw); + + function fl_clock_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_clock_handle, "fl_clock_handle"); + pragma Inline (fl_clock_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Updated_Clock) is + begin + Extra_Final (Clock (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Updated_Clock) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_clock (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Updated_Clock; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Clock (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Updated_Clock) is + begin + This.Draw_Ptr := fl_clock_draw'Address; + This.Handle_Ptr := fl_clock_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock is + begin + return This : Updated_Clock do + This.Void_Ptr := new_fl_clock + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock is + begin + return This : Updated_Clock := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock is + begin + return This : Updated_Clock do + This.Void_Ptr := new_fl_clock2 + (Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock is + begin + return This : Updated_Clock := Create (Kind, X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Events -- + + function Handle + (This : in out Updated_Clock; + Event : in Event_Kind) + return Event_Outcome is + begin + return Clock (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Clocks.Updated; + + diff --git a/body/fltk-widgets-clocks.adb b/body/fltk-widgets-clocks.adb new file mode 100644 index 0000000..dc2ee6d --- /dev/null +++ b/body/fltk-widgets-clocks.adb @@ -0,0 +1,275 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Clocks is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_clock_output + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_clock_output, "new_fl_clock_output"); + pragma Inline (new_fl_clock_output); + + procedure free_fl_clock_output + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_clock_output, "free_fl_clock_output"); + pragma Inline (free_fl_clock_output); + + + + + -- Individual Values -- + + function fl_clock_output_get_hour + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_clock_output_get_hour, "fl_clock_output_get_hour"); + pragma Inline (fl_clock_output_get_hour); + + function fl_clock_output_get_minute + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_clock_output_get_minute, "fl_clock_output_get_minute"); + pragma Inline (fl_clock_output_get_minute); + + function fl_clock_output_get_second + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_clock_output_get_second, "fl_clock_output_get_second"); + pragma Inline (fl_clock_output_get_second); + + + + + -- Full Value -- + + function fl_clock_output_get_value + (C : in Storage.Integer_Address) + return Interfaces.C.unsigned_long; + pragma Import (C, fl_clock_output_get_value, "fl_clock_output_get_value"); + pragma Inline (fl_clock_output_get_value); + + procedure fl_clock_output_set_value + (C : in Storage.Integer_Address; + V : in Interfaces.C.unsigned_long); + pragma Import (C, fl_clock_output_set_value, "fl_clock_output_set_value"); + pragma Inline (fl_clock_output_set_value); + + procedure fl_clock_output_set_value2 + (C : in Storage.Integer_Address; + H, M, S : in Interfaces.C.int); + pragma Import (C, fl_clock_output_set_value2, "fl_clock_output_set_value2"); + pragma Inline (fl_clock_output_set_value2); + + + + + -- Drawing, Events -- + + procedure fl_clock_output_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_clock_output_draw, "fl_clock_output_draw"); + pragma Inline (fl_clock_output_draw); + + procedure fl_clock_output_draw2 + (C : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_clock_output_draw2, "fl_clock_output_draw2"); + pragma Inline (fl_clock_output_draw2); + + function fl_clock_output_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_clock_output_handle, "fl_clock_output_handle"); + pragma Inline (fl_clock_output_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Clock) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Clock) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_clock_output (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Clock; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Clock) is + begin + This.Draw_Ptr := fl_clock_output_draw'Address; + This.Handle_Ptr := fl_clock_output_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Clock is + begin + return This : Clock do + This.Void_Ptr := new_fl_clock_output + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Clock is + begin + return This : Clock := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Individual Values -- + + function Get_Hour + (This : in Clock) + return Hour is + begin + return Hour (fl_clock_output_get_hour (This.Void_Ptr)); + end Get_Hour; + + + function Get_Minute + (This : in Clock) + return Minute is + begin + return Minute (fl_clock_output_get_minute (This.Void_Ptr)); + end Get_Minute; + + + function Get_Second + (This : in Clock) + return Second is + begin + return Second (fl_clock_output_get_second (This.Void_Ptr)); + end Get_Second; + + + + + -- Full Value -- + + function Get_Time + (This : in Clock) + return Time_Value is + begin + return Time_Value (fl_clock_output_get_value (This.Void_Ptr)); + end Get_Time; + + + procedure Set_Time + (This : in out Clock; + To : in Time_Value) is + begin + fl_clock_output_set_value (This.Void_Ptr, Interfaces.C.unsigned_long (To)); + end Set_Time; + + + procedure Set_Time + (This : in out Clock; + Hours : in Hour; + Minutes : in Minute; + Seconds : in Second) is + begin + fl_clock_output_set_value2 + (This.Void_Ptr, + Interfaces.C.int (Hours), + Interfaces.C.int (Minutes), + Interfaces.C.int (Seconds)); + end Set_Time; + + + + + -- Drawing -- + + procedure Draw + (This : in out Clock) is + begin + Widget (This).Draw; + end Draw; + + + procedure Draw + (This : in out Clock; + X, Y, W, H : in Integer) is + begin + fl_clock_output_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw; + + +end FLTK.Widgets.Clocks; + + diff --git a/body/fltk-widgets-groups-browsers-check.adb b/body/fltk-widgets-groups-browsers-check.adb new file mode 100644 index 0000000..c519f31 --- /dev/null +++ b/body/fltk-widgets-groups-browsers-check.adb @@ -0,0 +1,532 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Browsers.Check is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_check_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_check_browser, "new_fl_check_browser"); + pragma Inline (new_fl_check_browser); + + procedure free_fl_check_browser + (C : in Storage.Integer_Address); + pragma Import (C, free_fl_check_browser, "free_fl_check_browser"); + pragma Inline (free_fl_check_browser); + + + + + -- Items -- + + function fl_check_browser_add + (C : in Storage.Integer_Address; + S : in Interfaces.C.char_array; + B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_add, "fl_check_browser_add"); + pragma Inline (fl_check_browser_add); + + function fl_check_browser_remove + (C : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_remove, "fl_check_browser_remove"); + pragma Inline (fl_check_browser_remove); + + procedure fl_check_browser_clear + (C : in Storage.Integer_Address); + pragma Import (C, fl_check_browser_clear, "fl_check_browser_clear"); + pragma Inline (fl_check_browser_clear); + + function fl_check_browser_nitems + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_nitems, "fl_check_browser_nitems"); + pragma Inline (fl_check_browser_nitems); + + + + + -- Checkmarking -- + + procedure fl_check_browser_check_all + (C : in Storage.Integer_Address); + pragma Import (C, fl_check_browser_check_all, "fl_check_browser_check_all"); + pragma Inline (fl_check_browser_check_all); + + procedure fl_check_browser_check_none + (C : in Storage.Integer_Address); + pragma Import (C, fl_check_browser_check_none, "fl_check_browser_check_none"); + pragma Inline (fl_check_browser_check_none); + + function fl_check_browser_get_checked + (C : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_get_checked, "fl_check_browser_get_checked"); + pragma Inline (fl_check_browser_get_checked); + + procedure fl_check_browser_set_checked + (C : in Storage.Integer_Address; + I, B : in Interfaces.C.int); + pragma Import (C, fl_check_browser_set_checked, "fl_check_browser_set_checked"); + pragma Inline (fl_check_browser_set_checked); + + function fl_check_browser_nchecked + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_nchecked, "fl_check_browser_nchecked"); + pragma Inline (fl_check_browser_nchecked); + + + + + -- Text Selection -- + + function fl_check_browser_text + (C : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_check_browser_text, "fl_check_browser_text"); + pragma Inline (fl_check_browser_text); + + function fl_check_browser_value + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_value, "fl_check_browser_value"); + pragma Inline (fl_check_browser_value); + + + + + -- Optional Overrides -- + + function fl_check_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_full_width, "fl_check_browser_full_width"); + pragma Inline (fl_check_browser_full_width); + + function fl_check_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_full_height, "fl_check_browser_full_height"); + pragma Inline (fl_check_browser_full_height); + + function fl_check_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_incr_height, "fl_check_browser_incr_height"); + pragma Inline (fl_check_browser_incr_height); + + function fl_check_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_item_quick_height, "fl_check_browser_item_quick_height"); + pragma Inline (fl_check_browser_item_quick_height); + + + + + -- Item Implementation -- + + function fl_check_browser_item_width + (C, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_item_width, "fl_check_browser_item_width"); + pragma Inline (fl_check_browser_item_width); + + function fl_check_browser_item_height + (C, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_item_height, "fl_check_browser_item_height"); + pragma Inline (fl_check_browser_item_height); + + function fl_check_browser_item_first + (C : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_check_browser_item_first, "fl_check_browser_item_first"); + pragma Inline (fl_check_browser_item_first); + + -- Missing item_last + + function fl_check_browser_item_next + (C, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_check_browser_item_next, "fl_check_browser_item_next"); + pragma Inline (fl_check_browser_item_next); + + function fl_check_browser_item_prev + (C, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_check_browser_item_prev, "fl_check_browser_item_prev"); + pragma Inline (fl_check_browser_item_prev); + + -- Missing item_at + + procedure fl_check_browser_item_select + (C, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_check_browser_item_select, "fl_check_browser_item_select"); + pragma Inline (fl_check_browser_item_select); + + function fl_check_browser_item_selected + (C, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_item_selected, "fl_check_browser_item_selected"); + pragma Inline (fl_check_browser_item_selected); + + -- Missing item_swap and item_text + + procedure fl_check_browser_item_draw + (C, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_check_browser_item_draw, "fl_check_browser_item_draw"); + pragma Inline (fl_check_browser_item_draw); + + + + + -- Drawing, Events -- + + procedure fl_check_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_check_browser_draw, "fl_check_browser_draw"); + pragma Inline (fl_check_browser_draw); + + function fl_check_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_check_browser_handle, "fl_check_browser_handle"); + pragma Inline (fl_check_browser_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Check_Browser) is + begin + Extra_Final (Browser (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Check_Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_check_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Check_Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Browser (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Check_Browser) is + begin + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_check_browser_full_width'Address, + Full_List_Height_Ptr => fl_check_browser_full_height'Address, + Average_Item_Height_Ptr => fl_check_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_check_browser_item_quick_height'Address); + This.Draw_Ptr := fl_check_browser_draw'Address; + This.Handle_Ptr := fl_check_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Check_Browser is + begin + return This : Check_Browser do + This.Void_Ptr := new_fl_check_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Check_Browser is + begin + return This : Check_Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Items -- + + procedure Add + (This : in out Check_Browser; + Text : in String; + Checked : in Boolean := False) + is + Ignore : Interfaces.C.int := fl_check_browser_add + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Boolean'Pos (Checked)); + begin + null; + end Add; + + + procedure Remove + (This : in out Check_Browser; + Index : in Positive) + is + Ignore : Interfaces.C.int := fl_check_browser_remove + (This.Void_Ptr, + Interfaces.C.int (Index)); + begin + null; + end Remove; + + + procedure Clear + (This : in out Check_Browser) is + begin + fl_check_browser_clear (This.Void_Ptr); + end Clear; + + + function Number_Of_Items + (This : in Check_Browser) + return Natural is + begin + return Natural (fl_check_browser_nitems (This.Void_Ptr)); + end Number_Of_Items; + + + + + -- Checkmarking -- + + procedure Check_All + (This : in out Check_Browser) is + begin + fl_check_browser_check_all (This.Void_Ptr); + end Check_All; + + + procedure Check_None + (This : in out Check_Browser) is + begin + fl_check_browser_check_none (This.Void_Ptr); + end Check_None; + + + function Is_Checked + (This : in Check_Browser; + Index : in Positive) + return Boolean is + begin + return fl_check_browser_get_checked (This.Void_Ptr, Interfaces.C.int (Index)) /= 0; + end Is_Checked; + + + procedure Set_Checked + (This : in out Check_Browser; + Index : in Positive; + State : in Boolean := True) is + begin + fl_check_browser_set_checked + (This.Void_Ptr, + Interfaces.C.int (Index), + Boolean'Pos (State)); + end Set_Checked; + + + function Number_Checked + (This : in Check_Browser) + return Natural is + begin + return Natural (fl_check_browser_nchecked (This.Void_Ptr)); + end Number_Checked; + + + + + -- Text Selection -- + + function Item_Text + (This : in Check_Browser; + Index : in Positive) + return String is + begin + return Interfaces.C.Strings.Value + (fl_check_browser_text (This.Void_Ptr, Interfaces.C.int (Index))); + end Item_Text; + + + function Selected_Index + (This : in Check_Browser) + return Positive is + begin + return Positive (fl_check_browser_value (This.Void_Ptr)); + end Selected_Index; + + + + + -- Item Implementation -- + + function Item_Width + (This : in Check_Browser; + Item : in Item_Cursor) + return Integer is + begin + return Integer (fl_check_browser_item_width + (This.Void_Ptr, + Cursor_To_Address (Item))); + end Item_Width; + + + function Item_Height + (This : in Check_Browser; + Item : in Item_Cursor) + return Integer is + begin + return Integer (fl_check_browser_item_height + (This.Void_Ptr, + Cursor_To_Address (Item))); + end Item_Height; + + + function Item_First + (This : in Check_Browser) + return Item_Cursor is + begin + return Address_To_Cursor (fl_check_browser_item_first (This.Void_Ptr)); + end Item_First; + + + -- Note that Item_Last is not implemented + + + function Item_Next + (This : in Check_Browser; + Item : in Item_Cursor) + return Item_Cursor is + begin + return Address_To_Cursor (fl_check_browser_item_next + (This.Void_Ptr, + Cursor_To_Address (Item))); + end Item_Next; + + + function Item_Previous + (This : in Check_Browser; + Item : in Item_Cursor) + return Item_Cursor is + begin + return Address_To_Cursor (fl_check_browser_item_prev + (This.Void_Ptr, + Cursor_To_Address (Item))); + end Item_Previous; + + + -- Note that Item_At is not implemented + + + procedure Item_Select + (This : in out Check_Browser; + Item : in Item_Cursor; + State : in Boolean := True) is + begin + fl_check_browser_item_select + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (State)); + end Item_Select; + + + function Item_Selected + (This : in Check_Browser; + Item : in Item_Cursor) + return Boolean is + begin + return fl_check_browser_item_selected (This.Void_Ptr, Cursor_To_Address (Item)) /= 0; + end Item_Selected; + + + -- Note that Item_Swap and Item_Text are not implemented + + + procedure Item_Draw + (This : in Check_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer) is + begin + fl_check_browser_item_draw + (This.Void_Ptr, + Cursor_To_Address (Item), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Item_Draw; + + +end FLTK.Widgets.Groups.Browsers.Check; + + diff --git a/body/fltk-widgets-groups-browsers-textline-choice.adb b/body/fltk-widgets-groups-browsers-textline-choice.adb new file mode 100644 index 0000000..13ed7dd --- /dev/null +++ b/body/fltk-widgets-groups-browsers-textline-choice.adb @@ -0,0 +1,257 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + + +package body FLTK.Widgets.Groups.Browsers.Textline.Choice is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_select_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_select_browser, "new_fl_select_browser"); + pragma Inline (new_fl_select_browser); + + procedure free_fl_select_browser + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_select_browser, "free_fl_select_browser"); + pragma Inline (free_fl_select_browser); + + + + + -- Item Implementation -- + + function fl_select_browser_item_width + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_item_width, "fl_select_browser_item_width"); + pragma Inline (fl_select_browser_item_width); + + function fl_select_browser_item_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_item_height, "fl_select_browser_item_height"); + pragma Inline (fl_select_browser_item_height); + + function fl_select_browser_item_first + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_select_browser_item_first, "fl_select_browser_item_first"); + pragma Inline (fl_select_browser_item_first); + + function fl_select_browser_item_last + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_select_browser_item_last, "fl_select_browser_item_last"); + pragma Inline (fl_select_browser_item_last); + + function fl_select_browser_item_next + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_select_browser_item_next, "fl_select_browser_item_next"); + pragma Inline (fl_select_browser_item_next); + + function fl_select_browser_item_prev + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_select_browser_item_prev, "fl_select_browser_item_prev"); + pragma Inline (fl_select_browser_item_prev); + + function fl_select_browser_item_at + (B : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_select_browser_item_at, "fl_select_browser_item_at"); + pragma Inline (fl_select_browser_item_at); + + procedure fl_select_browser_item_select + (B, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_select_browser_item_select, "fl_select_browser_item_select"); + pragma Inline (fl_select_browser_item_select); + + function fl_select_browser_item_selected + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_item_selected, "fl_select_browser_item_selected"); + pragma Inline (fl_select_browser_item_selected); + + procedure fl_select_browser_item_swap + (B, X, Y : in Storage.Integer_Address); + pragma Import (C, fl_select_browser_item_swap, "fl_select_browser_item_swap"); + pragma Inline (fl_select_browser_item_swap); + + function fl_select_browser_item_text + (B, I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_select_browser_item_text, "fl_select_browser_item_text"); + pragma Inline (fl_select_browser_item_text); + + procedure fl_select_browser_item_draw + (B, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_select_browser_item_draw, "fl_select_browser_item_draw"); + pragma Inline (fl_select_browser_item_draw); + + + + + -- List Implementation -- + + function fl_select_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_full_width, "fl_select_browser_full_width"); + pragma Inline (fl_select_browser_full_width); + + function fl_select_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_full_height, "fl_select_browser_full_height"); + pragma Inline (fl_select_browser_full_height); + + function fl_select_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_incr_height, "fl_select_browser_incr_height"); + pragma Inline (fl_select_browser_incr_height); + + function fl_select_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_item_quick_height, "fl_select_browser_item_quick_height"); + pragma Inline (fl_select_browser_item_quick_height); + + + + + -- Drawing, Events -- + + procedure fl_select_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_select_browser_draw, "fl_select_browser_draw"); + pragma Inline (fl_select_browser_draw); + + function fl_select_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_select_browser_handle, "fl_select_browser_handle"); + pragma Inline (fl_select_browser_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Choice_Browser) is + begin + Extra_Final (Textline_Browser (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Choice_Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_select_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Choice_Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Textline_Browser (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Choice_Browser) is + begin + This.Item_Override_Ptrs := + (Item_Width_Ptr => fl_select_browser_item_width'Address, + Item_Height_Ptr => fl_select_browser_item_height'Address, + Item_First_Ptr => fl_select_browser_item_first'Address, + Item_Last_Ptr => fl_select_browser_item_last'Address, + Item_Next_Ptr => fl_select_browser_item_next'Address, + Item_Previous_Ptr => fl_select_browser_item_prev'Address, + Item_At_Ptr => fl_select_browser_item_at'Address, + Item_Select_Ptr => fl_select_browser_item_select'Address, + Item_Selected_Ptr => fl_select_browser_item_selected'Address, + Item_Swap_Ptr => fl_select_browser_item_swap'Address, + Item_Text_Ptr => fl_select_browser_item_text'Address, + Item_Draw_Ptr => fl_select_browser_item_draw'Address); + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_select_browser_full_width'Address, + Full_List_Height_Ptr => fl_select_browser_full_height'Address, + Average_Item_Height_Ptr => fl_select_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_select_browser_item_quick_height'Address); + This.Draw_Ptr := fl_select_browser_draw'Address; + This.Handle_Ptr := fl_select_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Choice_Browser is + begin + return This : Choice_Browser do + This.Void_Ptr := new_fl_select_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Choice_Browser is + begin + return This : Choice_Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Groups.Browsers.Textline.Choice; + + diff --git a/body/fltk-widgets-groups-browsers-textline-file.adb b/body/fltk-widgets-groups-browsers-textline-file.adb new file mode 100644 index 0000000..d22cfc1 --- /dev/null +++ b/body/fltk-widgets-groups-browsers-textline-file.adb @@ -0,0 +1,555 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Groups.Browsers.Textline.File is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Errors, File Data -- + + function get_error_message + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, get_error_message, "get_error_message"); + pragma Inline (get_error_message); + + function filename_dname + (L : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_dname, "filename_dname"); + pragma Inline (filename_dname); + + + + + -- Allocation -- + + function new_fl_file_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_file_browser, "new_fl_file_browser"); + pragma Inline (new_fl_file_browser); + + procedure free_fl_file_browser + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_file_browser, "free_fl_file_browser"); + pragma Inline (free_fl_file_browser); + + + + + -- Directory -- + + function fl_file_browser_load + (B : in Storage.Integer_Address; + D : in Interfaces.C.char_array; + S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_load, "fl_file_browser_load"); + pragma Inline (fl_file_browser_load); + + + + + -- Settings -- + + function fl_file_browser_get_filetype + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_get_filetype, "fl_file_browser_get_filetype"); + pragma Inline (fl_file_browser_get_filetype); + + procedure fl_file_browser_set_filetype + (B : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_file_browser_set_filetype, "fl_file_browser_set_filetype"); + pragma Inline (fl_file_browser_set_filetype); + + function fl_file_browser_get_filter + (B : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_browser_get_filter, "fl_file_browser_get_filter"); + pragma Inline (fl_file_browser_get_filter); + + procedure fl_file_browser_set_filter + (B : in Storage.Integer_Address; + F : in Interfaces.C.char_array); + pragma Import (C, fl_file_browser_set_filter, "fl_file_browser_set_filter"); + pragma Inline (fl_file_browser_set_filter); + + function fl_file_browser_get_iconsize + (B : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_file_browser_get_iconsize, "fl_file_browser_get_iconsize"); + pragma Inline (fl_file_browser_get_iconsize); + + procedure fl_file_browser_set_iconsize + (B : in Storage.Integer_Address; + I : in Interfaces.C.unsigned_char); + pragma Import (C, fl_file_browser_set_iconsize, "fl_file_browser_set_iconsize"); + pragma Inline (fl_file_browser_set_iconsize); + + function fl_file_browser_get_textsize + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_get_textsize, "fl_file_browser_get_textsize"); + pragma Inline (fl_file_browser_get_textsize); + + procedure fl_file_browser_set_textsize + (B : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_file_browser_set_textsize, "fl_file_browser_set_textsize"); + pragma Inline (fl_file_browser_set_textsize); + + + + + -- Item Implementation -- + + function fl_file_browser_item_width + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_item_width, "fl_file_browser_item_width"); + pragma Inline (fl_file_browser_item_width); + + function fl_file_browser_item_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_item_height, "fl_file_browser_item_height"); + pragma Inline (fl_file_browser_item_height); + + function fl_file_browser_item_first + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_browser_item_first, "fl_file_browser_item_first"); + pragma Inline (fl_file_browser_item_first); + + function fl_file_browser_item_last + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_browser_item_last, "fl_file_browser_item_last"); + pragma Inline (fl_file_browser_item_last); + + function fl_file_browser_item_next + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_browser_item_next, "fl_file_browser_item_next"); + pragma Inline (fl_file_browser_item_next); + + function fl_file_browser_item_prev + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_file_browser_item_prev, "fl_file_browser_item_prev"); + pragma Inline (fl_file_browser_item_prev); + + function fl_file_browser_item_at + (B : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_file_browser_item_at, "fl_file_browser_item_at"); + pragma Inline (fl_file_browser_item_at); + + procedure fl_file_browser_item_select + (B, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_file_browser_item_select, "fl_file_browser_item_select"); + pragma Inline (fl_file_browser_item_select); + + function fl_file_browser_item_selected + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_item_selected, "fl_file_browser_item_selected"); + pragma Inline (fl_file_browser_item_selected); + + procedure fl_file_browser_item_swap + (B, X, Y : in Storage.Integer_Address); + pragma Import (C, fl_file_browser_item_swap, "fl_file_browser_item_swap"); + pragma Inline (fl_file_browser_item_swap); + + function fl_file_browser_item_text + (B, I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_browser_item_text, "fl_file_browser_item_text"); + pragma Inline (fl_file_browser_item_text); + + procedure fl_file_browser_item_draw + (B, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_file_browser_item_draw, "fl_file_browser_item_draw"); + pragma Inline (fl_file_browser_item_draw); + + + + + -- List Implementation -- + + function fl_file_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_full_width, "fl_file_browser_full_width"); + pragma Inline (fl_file_browser_full_width); + + function fl_file_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_full_height, "fl_file_browser_full_height"); + pragma Inline (fl_file_browser_full_height); + + function fl_file_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_incr_height, "fl_file_browser_incr_height"); + pragma Inline (fl_file_browser_incr_height); + + function fl_file_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_item_quick_height, "fl_file_browser_item_quick_height"); + pragma Inline (fl_file_browser_item_quick_height); + + + + + -- Drawing, Events -- + + procedure fl_file_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_file_browser_draw, "fl_file_browser_draw"); + pragma Inline (fl_file_browser_draw); + + function fl_file_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_file_browser_handle, "fl_file_browser_handle"); + pragma Inline (fl_file_browser_handle); + + + + + ------------- + -- Hooks -- + ------------- + + Current_Sort : FLTK.Filenames.Compare_Function; + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int; + + pragma Convention (C, Compare_Hook); + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int + is + Result : constant FLTK.Filenames.Comparison := Current_Sort + (Interfaces.C.Strings.Value (filename_dname (DA, 0)), + Interfaces.C.Strings.Value (filename_dname (DB, 0))); + begin + return FLTK.Filenames.Comparison'Pos (Result) - 1; + end Compare_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out File_Browser) is + begin + Extra_Final (Textline_Browser (This)); + end Extra_Final; + + + procedure Finalize + (This : in out File_Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_file_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out File_Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Textline_Browser (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out File_Browser) is + begin + This.Item_Override_Ptrs := + (Item_Width_Ptr => fl_file_browser_item_width'Address, + Item_Height_Ptr => fl_file_browser_item_height'Address, + Item_First_Ptr => fl_file_browser_item_first'Address, + Item_Last_Ptr => fl_file_browser_item_last'Address, + Item_Next_Ptr => fl_file_browser_item_next'Address, + Item_Previous_Ptr => fl_file_browser_item_prev'Address, + Item_At_Ptr => fl_file_browser_item_at'Address, + Item_Select_Ptr => fl_file_browser_item_select'Address, + Item_Selected_Ptr => fl_file_browser_item_selected'Address, + Item_Swap_Ptr => fl_file_browser_item_swap'Address, + Item_Text_Ptr => fl_file_browser_item_text'Address, + Item_Draw_Ptr => fl_file_browser_item_draw'Address); + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_file_browser_full_width'Address, + Full_List_Height_Ptr => fl_file_browser_full_height'Address, + Average_Item_Height_Ptr => fl_file_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_file_browser_item_quick_height'Address); + This.Draw_Ptr := fl_file_browser_draw'Address; + This.Handle_Ptr := fl_file_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return File_Browser is + begin + return This : File_Browser do + This.Void_Ptr := new_fl_file_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return File_Browser is + begin + return This : File_Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Directory -- + + function Load + (This : in out File_Browser; + Dir : in String; + Sort : in not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access) + return Natural + is + Msg : Interfaces.C.Strings.chars_ptr; + Code : Interfaces.C.int; + begin + Current_Sort := Sort; + Code := fl_file_browser_load + (This.Void_Ptr, + Interfaces.C.To_C (Dir), + Storage.To_Integer (Compare_Hook'Address)); + if Code = 0 then + Msg := get_error_message; + if Msg /= Interfaces.C.Strings.Null_Ptr then + raise Browser_Load_Error with Interfaces.C.Strings.Value (Msg); + end if; + end if; + return Natural (Code); + end Load; + + + procedure Load + (This : in out File_Browser; + Dir : in String; + Sort : in not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access) + is + Ignore : constant Natural := This.Load (Dir, Sort); + begin + null; + end Load; + + + + + -- Settings -- + + function Get_File_Kind + (This : in File_Browser) + return File_Kind + is + Code : constant Interfaces.C.int := fl_file_browser_get_filetype (This.Void_Ptr); + begin + pragma Assert (Code in File_Kind'Pos (File_Kind'First) .. File_Kind'Pos (File_Kind'Last)); + return File_Kind'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Browser::filetype returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Get_File_Kind; + + + procedure Set_File_Kind + (This : in out File_Browser; + Value : in File_Kind) is + begin + fl_file_browser_set_filetype (This.Void_Ptr, File_Kind'Pos (Value)); + end Set_File_Kind; + + + function Get_Filter + (This : in File_Browser) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := + fl_file_browser_get_filter (This.Void_Ptr); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Filter; + + + procedure Set_Filter + (This : in out File_Browser; + Value : in String) is + begin + fl_file_browser_set_filter (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Filter; + + + function Get_Icon_Size + (This : in File_Browser) + return Icon_Size is + begin + return Icon_Size (fl_file_browser_get_iconsize (This.Void_Ptr)); + end Get_Icon_Size; + + + procedure Set_Icon_Size + (This : in out File_Browser; + Value : in Icon_Size) is + begin + fl_file_browser_set_iconsize (This.Void_Ptr, Interfaces.C.unsigned_char (Value)); + end Set_Icon_Size; + + + function Get_Text_Size + (This : in File_Browser) + return Font_Size is + begin + return Font_Size (fl_file_browser_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out File_Browser; + Size : in Font_Size) is + begin + fl_file_browser_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- List Implementation -- + + function Full_List_Height + (This : in File_Browser) + return Integer is + begin + return Textline_Browser (This).Full_List_Height; + end Full_List_Height; + + + function Average_Item_Height + (This : in File_Browser) + return Integer is + begin + return Textline_Browser (This).Average_Item_Height; + end Average_Item_Height; + + + + + -- Item Implementation -- + + function Item_Width + (This : in File_Browser; + Item : in Item_Cursor) + return Integer is + begin + return Textline_Browser (This).Item_Width (Item); + end Item_Width; + + + function Item_Height + (This : in File_Browser; + Item : in Item_Cursor) + return Integer is + begin + return Textline_Browser (This).Item_Height (Item); + end Item_Height; + + + procedure Item_Draw + (This : in File_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer) is + begin + Textline_Browser (This).Item_Draw (Item, X, Y, W, H); + end Item_Draw; + + +end FLTK.Widgets.Groups.Browsers.Textline.File; + + diff --git a/body/fltk-widgets-groups-browsers-textline-hold.adb b/body/fltk-widgets-groups-browsers-textline-hold.adb new file mode 100644 index 0000000..facfe68 --- /dev/null +++ b/body/fltk-widgets-groups-browsers-textline-hold.adb @@ -0,0 +1,257 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + + +package body FLTK.Widgets.Groups.Browsers.Textline.Hold is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_hold_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_hold_browser, "new_fl_hold_browser"); + pragma Inline (new_fl_hold_browser); + + procedure free_fl_hold_browser + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_hold_browser, "free_fl_hold_browser"); + pragma Inline (free_fl_hold_browser); + + + + + -- Item Implementation -- + + function fl_hold_browser_item_width + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_item_width, "fl_hold_browser_item_width"); + pragma Inline (fl_hold_browser_item_width); + + function fl_hold_browser_item_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_item_height, "fl_hold_browser_item_height"); + pragma Inline (fl_hold_browser_item_height); + + function fl_hold_browser_item_first + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_hold_browser_item_first, "fl_hold_browser_item_first"); + pragma Inline (fl_hold_browser_item_first); + + function fl_hold_browser_item_last + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_hold_browser_item_last, "fl_hold_browser_item_last"); + pragma Inline (fl_hold_browser_item_last); + + function fl_hold_browser_item_next + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_hold_browser_item_next, "fl_hold_browser_item_next"); + pragma Inline (fl_hold_browser_item_next); + + function fl_hold_browser_item_prev + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_hold_browser_item_prev, "fl_hold_browser_item_prev"); + pragma Inline (fl_hold_browser_item_prev); + + function fl_hold_browser_item_at + (B : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_hold_browser_item_at, "fl_hold_browser_item_at"); + pragma Inline (fl_hold_browser_item_at); + + procedure fl_hold_browser_item_select + (B, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_hold_browser_item_select, "fl_hold_browser_item_select"); + pragma Inline (fl_hold_browser_item_select); + + function fl_hold_browser_item_selected + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_item_selected, "fl_hold_browser_item_selected"); + pragma Inline (fl_hold_browser_item_selected); + + procedure fl_hold_browser_item_swap + (B, X, Y : in Storage.Integer_Address); + pragma Import (C, fl_hold_browser_item_swap, "fl_hold_browser_item_swap"); + pragma Inline (fl_hold_browser_item_swap); + + function fl_hold_browser_item_text + (B, I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_hold_browser_item_text, "fl_hold_browser_item_text"); + pragma Inline (fl_hold_browser_item_text); + + procedure fl_hold_browser_item_draw + (B, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_hold_browser_item_draw, "fl_hold_browser_item_draw"); + pragma Inline (fl_hold_browser_item_draw); + + + + + -- List Implementation -- + + function fl_hold_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_full_width, "fl_hold_browser_full_width"); + pragma Inline (fl_hold_browser_full_width); + + function fl_hold_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_full_height, "fl_hold_browser_full_height"); + pragma Inline (fl_hold_browser_full_height); + + function fl_hold_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_incr_height, "fl_hold_browser_incr_height"); + pragma Inline (fl_hold_browser_incr_height); + + function fl_hold_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_item_quick_height, "fl_hold_browser_item_quick_height"); + pragma Inline (fl_hold_browser_item_quick_height); + + + + + -- Drawing, Events -- + + procedure fl_hold_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_hold_browser_draw, "fl_hold_browser_draw"); + pragma Inline (fl_hold_browser_draw); + + function fl_hold_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_hold_browser_handle, "fl_hold_browser_handle"); + pragma Inline (fl_hold_browser_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Hold_Browser) is + begin + Extra_Final (Textline_Browser (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Hold_Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_hold_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Hold_Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Textline_Browser (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Hold_Browser) is + begin + This.Item_Override_Ptrs := + (Item_Width_Ptr => fl_hold_browser_item_width'Address, + Item_Height_Ptr => fl_hold_browser_item_height'Address, + Item_First_Ptr => fl_hold_browser_item_first'Address, + Item_Last_Ptr => fl_hold_browser_item_last'Address, + Item_Next_Ptr => fl_hold_browser_item_next'Address, + Item_Previous_Ptr => fl_hold_browser_item_prev'Address, + Item_At_Ptr => fl_hold_browser_item_at'Address, + Item_Select_Ptr => fl_hold_browser_item_select'Address, + Item_Selected_Ptr => fl_hold_browser_item_selected'Address, + Item_Swap_Ptr => fl_hold_browser_item_swap'Address, + Item_Text_Ptr => fl_hold_browser_item_text'Address, + Item_Draw_Ptr => fl_hold_browser_item_draw'Address); + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_hold_browser_full_width'Address, + Full_List_Height_Ptr => fl_hold_browser_full_height'Address, + Average_Item_Height_Ptr => fl_hold_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_hold_browser_item_quick_height'Address); + This.Draw_Ptr := fl_hold_browser_draw'Address; + This.Handle_Ptr := fl_hold_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Hold_Browser is + begin + return This : Hold_Browser do + This.Void_Ptr := new_fl_hold_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Hold_Browser is + begin + return This : Hold_Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Groups.Browsers.Textline.Hold; + + diff --git a/body/fltk-widgets-groups-browsers-textline-multi.adb b/body/fltk-widgets-groups-browsers-textline-multi.adb new file mode 100644 index 0000000..e5c7f7a --- /dev/null +++ b/body/fltk-widgets-groups-browsers-textline-multi.adb @@ -0,0 +1,257 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + + +package body FLTK.Widgets.Groups.Browsers.Textline.Multi is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_multi_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_multi_browser, "new_fl_multi_browser"); + pragma Inline (new_fl_multi_browser); + + procedure free_fl_multi_browser + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_multi_browser, "free_fl_multi_browser"); + pragma Inline (free_fl_multi_browser); + + + + + -- Item Implementation -- + + function fl_multi_browser_item_width + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_item_width, "fl_multi_browser_item_width"); + pragma Inline (fl_multi_browser_item_width); + + function fl_multi_browser_item_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_item_height, "fl_multi_browser_item_height"); + pragma Inline (fl_multi_browser_item_height); + + function fl_multi_browser_item_first + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_multi_browser_item_first, "fl_multi_browser_item_first"); + pragma Inline (fl_multi_browser_item_first); + + function fl_multi_browser_item_last + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_multi_browser_item_last, "fl_multi_browser_item_last"); + pragma Inline (fl_multi_browser_item_last); + + function fl_multi_browser_item_next + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_multi_browser_item_next, "fl_multi_browser_item_next"); + pragma Inline (fl_multi_browser_item_next); + + function fl_multi_browser_item_prev + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_multi_browser_item_prev, "fl_multi_browser_item_prev"); + pragma Inline (fl_multi_browser_item_prev); + + function fl_multi_browser_item_at + (B : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_multi_browser_item_at, "fl_multi_browser_item_at"); + pragma Inline (fl_multi_browser_item_at); + + procedure fl_multi_browser_item_select + (B, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_multi_browser_item_select, "fl_multi_browser_item_select"); + pragma Inline (fl_multi_browser_item_select); + + function fl_multi_browser_item_selected + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_item_selected, "fl_multi_browser_item_selected"); + pragma Inline (fl_multi_browser_item_selected); + + procedure fl_multi_browser_item_swap + (B, X, Y : in Storage.Integer_Address); + pragma Import (C, fl_multi_browser_item_swap, "fl_multi_browser_item_swap"); + pragma Inline (fl_multi_browser_item_swap); + + function fl_multi_browser_item_text + (B, I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_multi_browser_item_text, "fl_multi_browser_item_text"); + pragma Inline (fl_multi_browser_item_text); + + procedure fl_multi_browser_item_draw + (B, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_multi_browser_item_draw, "fl_multi_browser_item_draw"); + pragma Inline (fl_multi_browser_item_draw); + + + + + -- List Implementation -- + + function fl_multi_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_full_width, "fl_multi_browser_full_width"); + pragma Inline (fl_multi_browser_full_width); + + function fl_multi_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_full_height, "fl_multi_browser_full_height"); + pragma Inline (fl_multi_browser_full_height); + + function fl_multi_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_incr_height, "fl_multi_browser_incr_height"); + pragma Inline (fl_multi_browser_incr_height); + + function fl_multi_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_item_quick_height, "fl_multi_browser_item_quick_height"); + pragma Inline (fl_multi_browser_item_quick_height); + + + + + -- Drawing, Events -- + + procedure fl_multi_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_multi_browser_draw, "fl_multi_browser_draw"); + pragma Inline (fl_multi_browser_draw); + + function fl_multi_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_multi_browser_handle, "fl_multi_browser_handle"); + pragma Inline (fl_multi_browser_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Multi_Browser) is + begin + Extra_Final (Textline_Browser (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Multi_Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_multi_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Multi_Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Textline_Browser (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Multi_Browser) is + begin + This.Item_Override_Ptrs := + (Item_Width_Ptr => fl_multi_browser_item_width'Address, + Item_Height_Ptr => fl_multi_browser_item_height'Address, + Item_First_Ptr => fl_multi_browser_item_first'Address, + Item_Last_Ptr => fl_multi_browser_item_last'Address, + Item_Next_Ptr => fl_multi_browser_item_next'Address, + Item_Previous_Ptr => fl_multi_browser_item_prev'Address, + Item_At_Ptr => fl_multi_browser_item_at'Address, + Item_Select_Ptr => fl_multi_browser_item_select'Address, + Item_Selected_Ptr => fl_multi_browser_item_selected'Address, + Item_Swap_Ptr => fl_multi_browser_item_swap'Address, + Item_Text_Ptr => fl_multi_browser_item_text'Address, + Item_Draw_Ptr => fl_multi_browser_item_draw'Address); + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_multi_browser_full_width'Address, + Full_List_Height_Ptr => fl_multi_browser_full_height'Address, + Average_Item_Height_Ptr => fl_multi_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_multi_browser_item_quick_height'Address); + This.Draw_Ptr := fl_multi_browser_draw'Address; + This.Handle_Ptr := fl_multi_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Multi_Browser is + begin + return This : Multi_Browser do + This.Void_Ptr := new_fl_multi_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Multi_Browser is + begin + return This : Multi_Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Groups.Browsers.Textline.Multi; + + diff --git a/body/fltk-widgets-groups-browsers-textline.adb b/body/fltk-widgets-groups-browsers-textline.adb new file mode 100644 index 0000000..e75ea6f --- /dev/null +++ b/body/fltk-widgets-groups-browsers-textline.adb @@ -0,0 +1,1253 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Unchecked_Deallocation, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Groups.Browsers.Textline is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Errors -- + + function get_error_message + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, get_error_message, "get_error_message"); + pragma Inline (get_error_message); + + + + + -- Allocation -- + + function new_fl_browser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_browser, "new_fl_browser"); + pragma Inline (new_fl_browser); + + procedure free_fl_browser + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_browser, "free_fl_browser"); + pragma Inline (free_fl_browser); + + + + + -- Lines -- + + procedure fl_browser_add + (B : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + D : in Storage.Integer_Address); + pragma Import (C, fl_browser_add, "fl_browser_add"); + pragma Inline (fl_browser_add); + + procedure fl_browser_insert + (B : in Storage.Integer_Address; + L : in Interfaces.C.int; + T : in Interfaces.C.char_array; + D : in Storage.Integer_Address); + pragma Import (C, fl_browser_insert, "fl_browser_insert"); + pragma Inline (fl_browser_insert); + + procedure fl_browser_move + (B : in Storage.Integer_Address; + T, F : in Interfaces.C.int); + pragma Import (C, fl_browser_move, "fl_browser_move"); + pragma Inline (fl_browser_move); + + procedure fl_browser_swap + (B : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_browser_swap, "fl_browser_swap"); + pragma Inline (fl_browser_swap); + + procedure fl_browser_remove + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_remove, "fl_browser_remove"); + pragma Inline (fl_browser_remove); + + procedure fl_browser_clear + (B : in Storage.Integer_Address); + pragma Import (C, fl_browser_clear, "fl_browser_clear"); + pragma Inline (fl_browser_clear); + + function fl_browser_size + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_size, "fl_browser_size"); + pragma Inline (fl_browser_size); + + + + + -- Text Loading -- + + function fl_browser_load + (B : in Storage.Integer_Address; + F : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_browser_load, "fl_browser_load"); + pragma Inline (fl_browser_load); + + function fl_browser_get_text + (B : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_browser_get_text, "fl_browser_get_text"); + pragma Inline (fl_browser_get_text); + + procedure fl_browser_set_text + (B : in Storage.Integer_Address; + L : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_browser_set_text, "fl_browser_set_text"); + pragma Inline (fl_browser_set_text); + + function fl_browser_get_textsize + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_get_textsize, "fl_browser_get_textsize"); + pragma Inline (fl_browser_get_textsize); + + procedure fl_browser_set_textsize + (B : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_browser_set_textsize, "fl_browser_set_textsize"); + pragma Inline (fl_browser_set_textsize); + + + + + -- Columns, Formatting -- + + function fl_browser_get_column_char + (B : in Storage.Integer_Address) + return Interfaces.C.char; + pragma Import (C, fl_browser_get_column_char, "fl_browser_get_column_char"); + pragma Inline (fl_browser_get_column_char); + + procedure fl_browser_set_column_char + (B : in Storage.Integer_Address; + C : in Interfaces.C.char); + pragma Import (C, fl_browser_set_column_char, "fl_browser_set_column_char"); + pragma Inline (fl_browser_set_column_char); + + procedure fl_browser_set_column_widths + (B, W : in Storage.Integer_Address); + pragma Import (C, fl_browser_set_column_widths, "fl_browser_set_column_widths"); + pragma Inline (fl_browser_set_column_widths); + + function fl_browser_get_format_char + (B : in Storage.Integer_Address) + return Interfaces.C.char; + pragma Import (C, fl_browser_get_format_char, "fl_browser_get_format_char"); + pragma Inline (fl_browser_get_format_char); + + procedure fl_browser_set_format_char + (B : in Storage.Integer_Address; + C : in Interfaces.C.char); + pragma Import (C, fl_browser_set_format_char, "fl_browser_set_format_char"); + pragma Inline (fl_browser_set_format_char); + + + + + -- Line Positions -- + + function fl_browser_get_topline + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_get_topline, "fl_browser_get_topline"); + pragma Inline (fl_browser_get_topline); + + procedure fl_browser_set_topline + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_set_topline, "fl_browser_set_topline"); + pragma Inline (fl_browser_set_topline); + + procedure fl_browser_middleline + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_middleline, "fl_browser_middleline"); + pragma Inline (fl_browser_middleline); + + procedure fl_browser_bottomline + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_bottomline, "fl_browser_bottomline"); + pragma Inline (fl_browser_bottomline); + + procedure fl_browser_lineposition + (B : in Storage.Integer_Address; + L, P : in Interfaces.C.int); + pragma Import (C, fl_browser_lineposition, "fl_browser_lineposition"); + pragma Inline (fl_browser_lineposition); + + + + + -- Selection -- + + function fl_browser_select + (B : in Storage.Integer_Address; + L, V : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_browser_select, "fl_browser_select"); + pragma Inline (fl_browser_select); + + function fl_browser_selected + (B : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_browser_selected, "fl_browser_selected"); + pragma Inline (fl_browser_selected); + + function fl_browser_value + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_value, "fl_browser_value"); + pragma Inline (fl_browser_value); + + + + + -- Visibility -- + + function fl_browser_visible + (B : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_browser_visible, "fl_browser_visible"); + pragma Inline (fl_browser_visible); + + procedure fl_browser_make_visible + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_make_visible, "fl_browser_make_visible"); + pragma Inline (fl_browser_make_visible); + + function fl_browser_displayed + (B : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_browser_displayed, "fl_browser_displayed"); + pragma Inline (fl_browser_displayed); + + procedure fl_browser_show_line + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_show_line, "fl_browser_show_line"); + pragma Inline (fl_browser_show_line); + + procedure fl_browser_hide_line + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_hide_line, "fl_browser_hide_line"); + pragma Inline (fl_browser_hide_line); + + procedure fl_browser_show + (B : in Storage.Integer_Address); + pragma Import (C, fl_browser_show, "fl_browser_show"); + pragma Inline (fl_browser_show); + + procedure fl_browser_hide + (B : in Storage.Integer_Address); + pragma Import (C, fl_browser_hide, "fl_browser_hide"); + pragma Inline (fl_browser_hide); + + + + + -- Dimensions -- + + procedure fl_browser_set_size + (B : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_browser_set_size, "fl_browser_set_size"); + pragma Inline (fl_browser_set_size); + + + + + -- Icons -- + + procedure fl_browser_set_icon + (B : in Storage.Integer_Address; + L : in Interfaces.C.int; + C : in Storage.Integer_Address); + pragma Import (C, fl_browser_set_icon, "fl_browser_set_icon"); + pragma Inline (fl_browser_set_icon); + + procedure fl_browser_remove_icon + (B : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_browser_remove_icon, "fl_browser_remove_icon"); + pragma Inline (fl_browser_remove_icon); + + + + + -- Item Implementation -- + + function fl_browser_item_width + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_item_width, "fl_browser_item_width"); + pragma Inline (fl_browser_item_width); + + function fl_browser_item_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_item_height, "fl_browser_item_height"); + pragma Inline (fl_browser_item_height); + + function fl_browser_item_first + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_browser_item_first, "fl_browser_item_first"); + pragma Inline (fl_browser_item_first); + + function fl_browser_item_last + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_browser_item_last, "fl_browser_item_last"); + pragma Inline (fl_browser_item_last); + + function fl_browser_item_next + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_browser_item_next, "fl_browser_item_next"); + pragma Inline (fl_browser_item_next); + + function fl_browser_item_prev + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_browser_item_prev, "fl_browser_item_prev"); + pragma Inline (fl_browser_item_prev); + + function fl_browser_item_at + (B : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_browser_item_at, "fl_browser_item_at"); + pragma Inline (fl_browser_item_at); + + procedure fl_browser_item_select + (B, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_browser_item_select, "fl_browser_item_select"); + pragma Inline (fl_browser_item_select); + + function fl_browser_item_selected + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_item_selected, "fl_browser_item_selected"); + pragma Inline (fl_browser_item_selected); + + procedure fl_browser_item_swap + (B, X, Y : in Storage.Integer_Address); + pragma Import (C, fl_browser_item_swap, "fl_browser_item_swap"); + pragma Inline (fl_browser_item_swap); + + function fl_browser_item_text + (B, I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_browser_item_text, "fl_browser_item_text"); + pragma Inline (fl_browser_item_text); + + procedure fl_browser_item_draw + (B, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_browser_item_draw, "fl_browser_item_draw"); + pragma Inline (fl_browser_item_draw); + + + + + -- List Implementation -- + + function fl_browser_full_width + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_full_width, "fl_browser_full_width"); + pragma Inline (fl_browser_full_width); + + function fl_browser_full_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_full_height, "fl_browser_full_height"); + pragma Inline (fl_browser_full_height); + + function fl_browser_incr_height + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_incr_height, "fl_browser_incr_height"); + pragma Inline (fl_browser_incr_height); + + function fl_browser_item_quick_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_item_quick_height, "fl_browser_item_quick_height"); + pragma Inline (fl_browser_item_quick_height); + + + + + -- Line Numbers -- + + function fl_browser_lineno + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_browser_lineno, "fl_browser_lineno"); + pragma Inline (fl_browser_lineno); + + + + + -- Drawing, Events -- + + procedure fl_browser_draw + (B : in Storage.Integer_Address); + pragma Import (C, fl_browser_draw, "fl_browser_draw"); + pragma Inline (fl_browser_draw); + + function fl_browser_handle + (B : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_browser_handle, "fl_browser_handle"); + pragma Inline (fl_browser_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Free is new Ada.Unchecked_Deallocation + (Object => C_Col_Widths, + Name => C_Col_Widths_Access); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => FLTK.Images.Image'Class, + Name => Image_Access); + + + procedure Extra_Final + (This : in out Textline_Browser) is + begin + Free (This.Columns); + for Icon_Ptr of This.Icons loop + Free (Icon_Ptr); + end loop; + Extra_Final (Browser (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Textline_Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Textline_Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Browser (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Textline_Browser) is + begin + This.Item_Override_Ptrs := + (Item_Width_Ptr => fl_browser_item_width'Address, + Item_Height_Ptr => fl_browser_item_height'Address, + Item_First_Ptr => fl_browser_item_first'Address, + Item_Last_Ptr => fl_browser_item_last'Address, + Item_Next_Ptr => fl_browser_item_next'Address, + Item_Previous_Ptr => fl_browser_item_prev'Address, + Item_At_Ptr => fl_browser_item_at'Address, + Item_Select_Ptr => fl_browser_item_select'Address, + Item_Selected_Ptr => fl_browser_item_selected'Address, + Item_Swap_Ptr => fl_browser_item_swap'Address, + Item_Text_Ptr => fl_browser_item_text'Address, + Item_Draw_Ptr => fl_browser_item_draw'Address); + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_browser_full_width'Address, + Full_List_Height_Ptr => fl_browser_full_height'Address, + Average_Item_Height_Ptr => fl_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_browser_item_quick_height'Address); + This.Draw_Ptr := fl_browser_draw'Address; + This.Handle_Ptr := fl_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Textline_Browser is + begin + return This : Textline_Browser do + This.Void_Ptr := new_fl_browser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Textline_Browser is + begin + return This : Textline_Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Lines -- + + procedure Add + (This : in out Textline_Browser; + Text : in String) is + begin + fl_browser_add + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Null_Pointer); + end Add; + + + procedure Insert + (This : in out Textline_Browser; + Above : in Positive; + Text : in String) is + begin + fl_browser_insert + (This.Void_Ptr, + Interfaces.C.int (Above), + Interfaces.C.To_C (Text), + Null_Pointer); + end Insert; + + + procedure Move + (This : in out Textline_Browser; + From, To : in Positive) is + begin + fl_browser_move + (This.Void_Ptr, + Interfaces.C.int (To), + Interfaces.C.int (From)); + end Move; + + + procedure Swap + (This : in out Textline_Browser; + A, B : in Positive) is + begin + fl_browser_swap + (This.Void_Ptr, + Interfaces.C.int (A), + Interfaces.C.int (B)); + end Swap; + + + procedure Remove + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_remove + (This.Void_Ptr, + Interfaces.C.int (Line)); + end Remove; + + + procedure Clear + (This : in out Textline_Browser) is + begin + fl_browser_clear (This.Void_Ptr); + end Clear; + + + function Number_Of_Lines + (This : in Textline_Browser) + return Natural is + begin + return Natural (fl_browser_size (This.Void_Ptr)); + end Number_Of_Lines; + + + + + -- Text Loading -- + + procedure Load + (This : in out Textline_Browser; + File : in String) + is + Msg : Interfaces.C.Strings.chars_ptr; + Code : constant Interfaces.C.int := + fl_browser_load (This.Void_Ptr, Interfaces.C.To_C (File)); + begin + if Code = 0 then + Msg := get_error_message; + if Msg = Interfaces.C.Strings.Null_Ptr then + raise Browser_Load_Error; + else + raise Browser_Load_Error with Interfaces.C.Strings.Value (Msg); + end if; + else + pragma Assert (Code = 1); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::load returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Load; + + + function Get_Line_Text + (This : in Textline_Browser; + Line : in Positive) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_browser_get_text + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Line_Text; + + + procedure Set_Line_Text + (This : in out Textline_Browser; + Line : in Positive; + Text : in String) is + begin + fl_browser_set_text + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.To_C (Text)); + end Set_Line_Text; + + + function Get_Text_Size + (This : in Textline_Browser) + return Font_Size is + begin + return Font_Size (fl_browser_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Textline_Browser; + Size : in Font_Size) is + begin + fl_browser_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Columns, Formatting -- + + function Get_Column_Character + (This : in Textline_Browser) + return Character is + begin + return Interfaces.C.To_Ada (fl_browser_get_column_char (This.Void_Ptr)); + end Get_Column_Character; + + + procedure Set_Column_Character + (This : in out Textline_Browser; + Value : in Character) is + begin + fl_browser_set_column_char (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Column_Character; + + + function Get_Column_Widths + (This : in Textline_Browser) + return Column_Widths is + begin + if This.Columns = null then + return Result : Column_Widths (1 .. 0); + else + return Result : Column_Widths (This.Columns'First .. This.Columns'Last - 1) do + for Index in Result'Range loop + Result (Index) := Integer (This.Columns (Index)); + end loop; + end return; + end if; + end Get_Column_Widths; + + + procedure Set_Column_Widths + (This : in out Textline_Browser; + Widths : in Column_Widths) is + begin + Free (This.Columns); + This.Columns := new C_Col_Widths (1 .. Widths'Length + 1); + for Index in This.Columns'Range loop + This.Columns (Index) := Interfaces.C.int (Widths (Widths'First + Index - 1)); + end loop; + This.Columns (This.Columns'Last) := 0; + fl_browser_set_column_widths (This.Void_Ptr, Storage.To_Integer (This.Columns.all'Address)); + end Set_Column_Widths; + + + function Get_Format_Character + (This : in Textline_Browser) + return Character is + begin + return Interfaces.C.To_Ada (fl_browser_get_format_char (This.Void_Ptr)); + end Get_Format_Character; + + + procedure Set_Format_Character + (This : in out Textline_Browser; + Value : in Character) is + begin + fl_browser_set_format_char (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Format_Character; + + + + + -- Line Positions -- + + function Get_Top_Line + (This : in Textline_Browser) + return Positive is + begin + return Positive (fl_browser_get_topline (This.Void_Ptr)); + end Get_Top_Line; + + + procedure Set_Top_Line + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_set_topline (This.Void_Ptr, Interfaces.C.int (Line)); + end Set_Top_Line; + + + procedure Set_Middle_Line + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_middleline (This.Void_Ptr, Interfaces.C.int (Line)); + end Set_Middle_Line; + + + procedure Set_Bottom_Line + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_bottomline (This.Void_Ptr, Interfaces.C.int (Line)); + end Set_Bottom_Line; + + + procedure Set_Line_Position + (This : in out Textline_Browser; + Line : in Positive; + Place : in Line_Position) is + begin + fl_browser_lineposition (This.Void_Ptr, Interfaces.C.int (Line), Line_Position'Pos (Place)); + end Set_Line_Position; + + + + + -- Selection -- + + function Set_Select + (This : in out Textline_Browser; + Line : in Positive; + State : in Boolean := True) + return Boolean + is + Code : constant Interfaces.C.int := fl_browser_select + (This.Void_Ptr, + Interfaces.C.int (Line), + Boolean'Pos (State)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::select returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Set_Select; + + + procedure Set_Select + (This : in out Textline_Browser; + Line : in Positive; + State : in Boolean := True) + is + Code : constant Interfaces.C.int := fl_browser_select + (This.Void_Ptr, + Interfaces.C.int (Line), + Boolean'Pos (State)); + begin + pragma Assert (Code in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::select returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Set_Select; + + + function Is_Selected + (This : in Textline_Browser; + Line : in Positive) + return Boolean + is + Code : constant Interfaces.C.int := fl_browser_selected + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::selected returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Is_Selected; + + + function Selected_Index + (This : in Textline_Browser) + return Natural is + begin + return Natural (fl_browser_value (This.Void_Ptr)); + end Selected_Index; + + + + + -- Visibility -- + + function Is_Visible + (This : in Textline_Browser; + Line : in Positive) + return Boolean is + begin + return fl_browser_visible (This.Void_Ptr, Interfaces.C.int (Line)) /= 0; + end Is_Visible; + + + procedure Make_Visible + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_make_visible (This.Void_Ptr, Interfaces.C.int (Line)); + end Make_Visible; + + + function Is_Displayed + (This : in Textline_Browser; + Line : in Positive) + return Boolean + is + Code : constant Interfaces.C.int := fl_browser_displayed + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser::displayed returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Is_Displayed; + + + procedure Show_Line + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_show_line (This.Void_Ptr, Interfaces.C.int (Line)); + end Show_Line; + + + procedure Hide_Line + (This : in out Textline_Browser; + Line : in Positive) is + begin + fl_browser_hide_line (This.Void_Ptr, Interfaces.C.int (Line)); + end Hide_Line; + + + procedure Show + (This : in out Textline_Browser) is + begin + fl_browser_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Textline_Browser) is + begin + fl_browser_hide (This.Void_Ptr); + end Hide; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Textline_Browser; + W, H : in Integer) is + begin + fl_browser_set_size + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Icons -- + + function Has_Icon + (This : in Textline_Browser; + Line : in Positive) + return Boolean is + begin + return Line <= This.Icons.Last_Index and then This.Icons.Element (Line) /= null; + end Has_Icon; + + + function Get_Icon + (This : in Textline_Browser; + Line : in Positive) + return FLTK.Images.Image_Reference is + begin + return Ref : FLTK.Images.Image_Reference (Data => This.Icons.Element (Line)); + end Get_Icon; + + + procedure Set_Icon + (This : in out Textline_Browser; + Line : in Positive; + Icon : in FLTK.Images.Image'Class) is + begin + fl_browser_set_icon (This.Void_Ptr, Interfaces.C.int (Line), Wrapper (Icon).Void_Ptr); + if Line > This.Icons.Last_Index then + This.Icons.Append (null, Ada.Containers.Count_Type (Line - This.Icons.Last_Index - 1)); + This.Icons.Append (new FLTK.Images.Image); + Wrapper (This.Icons.Element (Line).all).Needs_Dealloc := False; + elsif This.Icons.Element (Line) = null then + This.Icons.Replace_Element (Line, new FLTK.Images.Image); + Wrapper (This.Icons.Element (Line).all).Needs_Dealloc := False; + end if; + Wrapper (This.Icons.Element (Line).all).Void_Ptr := Wrapper (Icon).Void_Ptr; + end Set_Icon; + + + procedure Remove_Icon + (This : in out Textline_Browser; + Line : in Positive) + is + Ptr : Image_Access; + begin + fl_browser_remove_icon (This.Void_Ptr, Interfaces.C.int (Line)); + if Line <= This.Icons.Last_Index then + Ptr := This.Icons.Element (Line); + Free (Ptr); + This.Icons.Replace_Element (Line, null); + end if; + end Remove_Icon; + + + + + -- List Implementation -- + + function Full_List_Height + (This : in Textline_Browser) + return Integer is + begin + return Browser (This).Full_List_Height; + end Full_List_Height; + + + function Average_Item_Height + (This : in Textline_Browser) + return Integer is + begin + return Browser (This).Average_Item_Height; + end Average_Item_Height; + + + + + -- Item Implementation -- + + function Item_Width + (This : in Textline_Browser; + Item : in Item_Cursor) + return Integer + is + function my_item_width + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + for my_item_width'Address use This.Item_Override_Ptrs (Item_Width_Ptr); + pragma Import (Ada, my_item_width); + begin + return Integer (my_item_width (This.Void_Ptr, Cursor_To_Address (Item))); + end Item_Width; + + + function Item_Height + (This : in Textline_Browser; + Item : in Item_Cursor) + return Integer + is + function my_item_height + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + for my_item_height'Address use This.Item_Override_Ptrs (Item_Height_Ptr); + pragma Import (Ada, my_item_height); + begin + return Integer (my_item_height (This.Void_Ptr, Cursor_To_Address (Item))); + end Item_Height; + + + function Item_First + (This : in Textline_Browser) + return Item_Cursor + is + function my_item_first + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + for my_item_first'Address use This.Item_Override_Ptrs (Item_First_Ptr); + pragma Import (Ada, my_item_first); + begin + return Address_To_Cursor (my_item_first (This.Void_Ptr)); + end Item_First; + + + function Item_Last + (This : in Textline_Browser) + return Item_Cursor + is + function my_item_last + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + for my_item_last'Address use This.Item_Override_Ptrs (Item_Last_Ptr); + pragma Import (Ada, my_item_last); + begin + return Address_To_Cursor (my_item_last (This.Void_Ptr)); + end Item_Last; + + + function Item_Next + (This : in Textline_Browser; + Item : in Item_Cursor) + return Item_Cursor + is + function my_item_next + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + for my_item_next'Address use This.Item_Override_Ptrs (Item_Next_Ptr); + pragma Import (Ada, my_item_next); + begin + return Address_To_Cursor (my_item_next (This.Void_Ptr, Cursor_To_Address (Item))); + end Item_Next; + + + function Item_Previous + (This : in Textline_Browser; + Item : in Item_Cursor) + return Item_Cursor + is + function my_item_prev + (B, I : in Storage.Integer_Address) + return Storage.Integer_Address; + for my_item_prev'Address use This.Item_Override_Ptrs (Item_Previous_Ptr); + pragma Import (Ada, my_item_prev); + begin + return Address_To_Cursor (my_item_prev (This.Void_Ptr, Cursor_To_Address (Item))); + end Item_Previous; + + + function Item_At + (This : in Textline_Browser; + Index : in Positive) + return Item_Cursor + is + function my_item_at + (B : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Storage.Integer_Address; + for my_item_at'Address use This.Item_Override_Ptrs (Item_At_Ptr); + pragma Import (Ada, my_item_at); + begin + return Address_To_Cursor (my_item_at (This.Void_Ptr, Interfaces.C.int (Index))); + end Item_At; + + + procedure Item_Select + (This : in out Textline_Browser; + Item : in Item_Cursor; + State : in Boolean := True) + is + procedure my_item_select + (B, I : in Storage.Integer_Address; + V : in Interfaces.C.int); + for my_item_select'Address use This.Item_Override_Ptrs (Item_Select_Ptr); + pragma Import (Ada, my_item_select); + begin + my_item_select (This.Void_Ptr, Cursor_To_Address (Item), Boolean'Pos (State)); + end Item_Select; + + + function Item_Selected + (This : in Textline_Browser; + Item : in Item_Cursor) + return Boolean + is + function my_item_selected + (B, I : in Storage.Integer_Address) + return Interfaces.C.int; + for my_item_selected'Address use This.Item_Override_Ptrs (Item_Selected_Ptr); + pragma Import (Ada, my_item_selected); + Code : constant Interfaces.C.int := + my_item_selected (This.Void_Ptr, Cursor_To_Address (Item)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Dispatched item_selected function returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Item_Selected; + + + procedure Item_Swap + (This : in out Textline_Browser; + A, B : in Item_Cursor) + is + procedure my_item_swap + (B, X, Y : in Storage.Integer_Address); + for my_item_swap'Address use This.Item_Override_Ptrs (Item_Swap_Ptr); + pragma Import (Ada, my_item_swap); + begin + my_item_swap (This.Void_Ptr, Cursor_To_Address (A), Cursor_To_Address (B)); + end Item_Swap; + + + function Item_Text + (This : in Textline_Browser; + Item : in Item_Cursor) + return String + is + function my_item_text + (B, I : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + for my_item_text'Address use This.Item_Override_Ptrs (Item_Text_Ptr); + pragma Import (Ada, my_item_text); + begin + return Interfaces.C.Strings.Value (my_item_text (This.Void_Ptr, Cursor_To_Address (Item))); + end Item_Text; + + + procedure Item_Draw + (This : in Textline_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer) + is + procedure my_item_draw + (B, I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + for my_item_draw'Address use This.Item_Override_Ptrs (Item_Draw_Ptr); + pragma Import (Ada, my_item_draw); + begin + my_item_draw + (This.Void_Ptr, + Cursor_To_Address (Item), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Item_Draw; + + + + + -- Line Numbers -- + + function Line_Number + (This : in Textline_Browser; + Item : in Item_Cursor) + return Natural is + begin + return Natural (fl_browser_lineno (This.Void_Ptr, Cursor_To_Address (Item))); + end Line_Number; + + +end FLTK.Widgets.Groups.Browsers.Textline; + + diff --git a/body/fltk-widgets-groups-browsers.adb b/body/fltk-widgets-groups-browsers.adb new file mode 100644 index 0000000..13cdba7 --- /dev/null +++ b/body/fltk-widgets-groups-browsers.adb @@ -0,0 +1,1377 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C, + System.Address_To_Access_Conversions; + + +package body FLTK.Widgets.Groups.Browsers is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- 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 -- + ------------------------ + + -- Allocation -- + + 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); + + + + + -- Attributes -- + + 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); + + + + + -- Items -- + + 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); + + + + + -- Scrollbar Settings -- + + 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); + + + + + -- Text Settings -- + + 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); + + + + + -- Dimensions, Redrawing -- + + 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); + + + + + -- Optional Overrides -- + + 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); + + + + + -- Cache Invalidation -- + + 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); + + + + + -- Drawing, Events -- + + 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 (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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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 : constant access 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. + + 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 : constant access Browser'Class := + Browser_Convert.To_Pointer (Storage.To_Address (Ada_Addr)); + begin + Interfaces.C.Strings.Free (Ada_Object.Text_Store (Ada_Object.Current)); + Ada_Object.Text_Store (Ada_Object.Current) := Interfaces.C.Strings.New_String + (Ada_Object.Item_Text (Address_To_Cursor (Item_Ptr))); + return C_Char_Is_Not_A_String : constant Interfaces.C.Strings.chars_ptr := + Ada_Object.Text_Store (Ada_Object.Current) + do + Ada_Object.Current := Ada_Object.Current + 1; + if Ada_Object.Current > Ada_Object.Text_Store'Last then + Ada_Object.Current := Ada_Object.Text_Store'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 : constant access 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; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Browser) is + begin + Extra_Final (Group (This)); + for Index in This.Text_Store'Range loop + Interfaces.C.Strings.Free (This.Text_Store (Index)); + end loop; + end Extra_Final; + + + procedure Finalize + (This : in out Browser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_abstract_browser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Boarding the Titanic... + procedure fl_scrollbar_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_scrollbar_extra_init, "fl_scrollbar_extra_init"); + pragma Inline (fl_scrollbar_extra_init); + + + procedure Extra_Init + (This : in out Browser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Widget (This.Horizon).Void_Ptr := fl_abstract_browser_hscrollbar (This.Void_Ptr); + Widget (This.Horizon).Needs_Dealloc := False; + fl_scrollbar_extra_init + (Storage.To_Integer (This.Horizon'Address), + Interfaces.C.int (This.Horizon.Get_X), + Interfaces.C.int (This.Horizon.Get_Y), + Interfaces.C.int (This.Horizon.Get_W), + Interfaces.C.int (This.Horizon.Get_H), + Interfaces.C.To_C (This.Horizon.Get_Label)); + Widget (This.Vertigo).Void_Ptr := fl_abstract_browser_scrollbar (This.Void_Ptr); + Widget (This.Vertigo).Needs_Dealloc := False; + fl_scrollbar_extra_init + (Storage.To_Integer (This.Vertigo'Address), + Interfaces.C.int (This.Vertigo.Get_X), + Interfaces.C.int (This.Vertigo.Get_Y), + Interfaces.C.int (This.Vertigo.Get_W), + Interfaces.C.int (This.Vertigo.Get_H), + Interfaces.C.To_C (This.Vertigo.Get_Label)); + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Browser) is + begin + This.Wide_High_Ptrs := + (Full_List_Width_Ptr => fl_abstract_browser_full_width'Address, + Full_List_Height_Ptr => fl_abstract_browser_full_height'Address, + Average_Item_Height_Ptr => fl_abstract_browser_incr_height'Address, + Item_Quick_Height_Ptr => fl_abstract_browser_item_quick_height'Address); + This.Draw_Ptr := fl_abstract_browser_draw'Address; + This.Handle_Ptr := fl_abstract_browser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Browser is + begin + return This : 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)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Browser is + begin + return This : Browser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + + function H_Bar + (This : in out Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Horizon'Unchecked_Access); + end H_Bar; + + + function V_Bar + (This : in out Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Vertigo'Unchecked_Access); + end V_Bar; + + + + + -- Items -- + + function Set_Select + (This : in out Browser; + Item : in Item_Cursor; + State : in Boolean := True; + Do_Callbacks : in Boolean := False) + return Boolean + is + Code : constant Interfaces.C.int := fl_abstract_browser_select + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (State), + Boolean'Pos (Do_Callbacks)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Set_Select; + + + procedure Set_Select + (This : in out Browser; + Item : in Item_Cursor; + State : in Boolean := True; + Do_Callbacks : in Boolean := False) + is + Code : constant Interfaces.C.int := fl_abstract_browser_select + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (State), + Boolean'Pos (Do_Callbacks)); + begin + pragma Assert (Code in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select returned unexpected int value of " & Interfaces.C.int'Image (Code); + end Set_Select; + + + function Select_Only + (This : in out Browser; + Item : in Item_Cursor; + Do_Callbacks : in Boolean := False) + return Boolean + is + Code : constant Interfaces.C.int := fl_abstract_browser_select_only + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (Do_Callbacks)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select_only returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Select_Only; + + + procedure Select_Only + (This : in out Browser; + Item : in Item_Cursor; + Do_Callbacks : in Boolean := False) + is + Code : constant Interfaces.C.int := fl_abstract_browser_select_only + (This.Void_Ptr, + Cursor_To_Address (Item), + Boolean'Pos (Do_Callbacks)); + begin + pragma Assert (Code in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::select_only returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Select_Only; + + + function Current_Selection + (This : in 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 Browser; + Do_Callbacks : in Boolean := False) + return Boolean + is + Code : constant Interfaces.C.int := fl_abstract_browser_deselect + (This.Void_Ptr, + Boolean'Pos (Do_Callbacks)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::deselect returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Deselect; + + + procedure Deselect + (This : in out Browser; + Do_Callbacks : in Boolean := False) + is + Code : constant Interfaces.C.int := fl_abstract_browser_deselect + (This.Void_Ptr, + Boolean'Pos (Do_Callbacks)); + begin + pragma Assert (Code in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::deselect returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Deselect; + + + procedure Display + (This : in out 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 Browser; + Item : in Item_Cursor) + return Boolean + is + Code : constant Interfaces.C.int := fl_abstract_browser_displayed + (This.Void_Ptr, Cursor_To_Address (Item)); + begin + pragma Assert (Code in 0 .. 1); + return Boolean'Val (Code); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Browser_::displayed returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Is_Displayed; + + + function Find_Item + (This : in 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 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 Browser; + Order : in Sort_Order) + is + Code : constant 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 Settings -- + + function Get_Scrollbar_Mode + (This : in 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 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 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 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 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 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 Browser) is + begin + fl_abstract_browser_scrollbar_left (This.Void_Ptr); + end Set_Vertical_Left; + + + procedure Set_Vertical_Right + (This : in out Browser) is + begin + fl_abstract_browser_scrollbar_right (This.Void_Ptr); + end Set_Vertical_Right; + + + function Get_Scrollbar_Size + (This : in 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 Browser; + Value : in Integer) is + begin + fl_abstract_browser_set_scrollbar_size + (This.Void_Ptr, + Interfaces.C.int (Value)); + end Set_Scrollbar_Size; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in 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 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 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 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 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 Browser; + Size : in Font_Size) is + begin + fl_abstract_browser_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Dimensions, Redrawing -- + + procedure Resize + (This : in out 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 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 Browser) + return Integer is + begin + return Integer (fl_abstract_browser_leftedge (This.Void_Ptr)); + end Left_Edge; + + + procedure Redraw_Line + (This : in out 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 Browser) is + begin + fl_abstract_browser_redraw_lines (This.Void_Ptr); + end Redraw_List; + + + + + -- Optional Overrides -- + + function Full_List_Width + (This : in Browser) + return Integer + is + function my_full_width + (V : in Storage.Integer_Address) + return Interfaces.C.int; + for my_full_width'Address use This.Wide_High_Ptrs (Full_List_Width_Ptr); + pragma Import (Ada, my_full_width); + begin + return Integer (my_full_width (This.Void_Ptr)); + end Full_List_Width; + + + function Full_List_Height + (This : in Browser) + return Integer + is + function my_full_height + (V : in Storage.Integer_Address) + return Interfaces.C.int; + for my_full_height'Address use This.Wide_High_Ptrs (Full_List_Height_Ptr); + pragma Import (Ada, my_full_height); + begin + return Integer (my_full_height (This.Void_Ptr)); + end Full_List_Height; + + + function Average_Item_Height + (This : in Browser) + return Integer + is + function my_incr_height + (V : in Storage.Integer_Address) + return Interfaces.C.int; + for my_incr_height'Address use This.Wide_High_Ptrs (Average_Item_Height_Ptr); + pragma Import (Ada, my_incr_height); + begin + return Integer (my_incr_height (This.Void_Ptr)); + end Average_Item_Height; + + + function Item_Quick_Height + (This : in Browser; + Item : in Item_Cursor) + return Integer + is + function my_item_quick_height + (V, I : Storage.Integer_Address) + return Interfaces.C.int; + for my_item_quick_height'Address use This.Wide_High_Ptrs (Item_Quick_Height_Ptr); + pragma Import (Ada, my_item_quick_height); + begin + return Integer (my_item_quick_height + (This.Void_Ptr, + Cursor_To_Address (Item))); + end Item_Quick_Height; + + + + + -- Mandatory Overrides -- + + function Item_Width + (This : in Browser; + Item : in Item_Cursor) + return Integer is + begin + return raise Program_Error with "Browser Item_Width must be overridden"; + end Item_Width; + + function Item_Height + (This : in Browser; + Item : in Item_Cursor) + return Integer is + begin + return raise Program_Error with "Browser Item_Height must be overridden"; + end Item_Height; + + function Item_First + (This : in Browser) + return Item_Cursor is + begin + return raise Program_Error with "Browser Item_First must be overridden"; + end Item_First; + + function Item_Last + (This : in Browser) + return Item_Cursor is + begin + return raise Program_Error with "Browser Item_Last must be overridden"; + end Item_Last; + + function Item_Next + (This : in Browser; + Item : in Item_Cursor) + return Item_Cursor is + begin + return raise Program_Error with "Browser Item_Next must be overridden"; + end Item_Next; + + function Item_Previous + (This : in Browser; + Item : in Item_Cursor) + return Item_Cursor is + begin + return raise Program_Error with "Browser Item_Previous must be overridden"; + end Item_Previous; + + function Item_At + (This : in Browser; + Index : in Positive) + return Item_Cursor is + begin + return raise Program_Error with "Browser Item_At must be overridden"; + end Item_At; + + procedure Item_Select + (This : in out Browser; + Item : in Item_Cursor; + State : in Boolean := True) is + begin + raise Program_Error with "Browser Item_Select must be overridden"; + end Item_Select; + + function Item_Selected + (This : in Browser; + Item : in Item_Cursor) + return Boolean is + begin + return raise Program_Error with "Browser Item_Selected must be overridden"; + end Item_Selected; + + procedure Item_Swap + (This : in out Browser; + A, B : in Item_Cursor) is + begin + raise Program_Error with "Browser Item_Swap must be overridden"; + end Item_Swap; + + function Item_Text + (This : in Browser; + Item : in Item_Cursor) + return String is + begin + return raise Program_Error with "Browser Item_Text must be overridden"; + end Item_Text; + + procedure Item_Draw + (This : in Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer) is + begin + raise Program_Error with "Browser Item_Draw must be overridden"; + end Item_Draw; + + + + + -- Cache Invalidation -- + + procedure New_List + (This : in out Browser) is + begin + fl_abstract_browser_new_list (This.Void_Ptr); + end New_List; + + + procedure Inserting + (This : in out 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 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 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 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; + + +end FLTK.Widgets.Groups.Browsers; + + diff --git a/body/fltk-widgets-groups-color_choosers.adb b/body/fltk-widgets-groups-color_choosers.adb new file mode 100644 index 0000000..cce0f08 --- /dev/null +++ b/body/fltk-widgets-groups-color_choosers.adb @@ -0,0 +1,423 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Color_Choosers is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_color_chooser + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_color_chooser, "new_fl_color_chooser"); + pragma Inline (new_fl_color_chooser); + + procedure free_fl_color_chooser + (W : in Storage.Integer_Address); + pragma Import (C, free_fl_color_chooser, "free_fl_color_chooser"); + pragma Inline (free_fl_color_chooser); + + + + + -- RGB Color -- + + function fl_color_chooser_r + (N : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_color_chooser_r, "fl_color_chooser_r"); + pragma Inline (fl_color_chooser_r); + + function fl_color_chooser_g + (N : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_color_chooser_g, "fl_color_chooser_g"); + pragma Inline (fl_color_chooser_g); + + function fl_color_chooser_b + (N : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_color_chooser_b, "fl_color_chooser_b"); + pragma Inline (fl_color_chooser_b); + + function fl_color_chooser_rgb + (N : in Storage.Integer_Address; + R, G, B : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_color_chooser_rgb, "fl_color_chooser_rgb"); + pragma Inline (fl_color_chooser_rgb); + + + + + -- HSV Color -- + + function fl_color_chooser_hue + (N : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_color_chooser_hue, "fl_color_chooser_hue"); + pragma Inline (fl_color_chooser_hue); + + function fl_color_chooser_saturation + (N : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_color_chooser_saturation, "fl_color_chooser_saturation"); + pragma Inline (fl_color_chooser_saturation); + + function fl_color_chooser_value + (N : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_color_chooser_value, "fl_color_chooser_value"); + pragma Inline (fl_color_chooser_value); + + function fl_color_chooser_hsv + (N : in Storage.Integer_Address; + H, S, V : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_color_chooser_hsv, "fl_color_chooser_hsv"); + pragma Inline (fl_color_chooser_hsv); + + + + + -- RGB / HSV Conversion -- + + procedure fl_color_chooser_hsv2rgb + (H, S, V : in Interfaces.C.double; + R, G, B : out Interfaces.C.double); + pragma Import (C, fl_color_chooser_hsv2rgb, "fl_color_chooser_hsv2rgb"); + pragma Inline (fl_color_chooser_hsv2rgb); + + procedure fl_color_chooser_rgb2hsv + (R, G, B : in Interfaces.C.double; + H, S, V : out Interfaces.C.double); + pragma Import (C, fl_color_chooser_rgb2hsv, "fl_color_chooser_rgb2hsv"); + pragma Inline (fl_color_chooser_rgb2hsv); + + + + + -- Settings -- + + function fl_color_chooser_get_mode + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_color_chooser_get_mode, "fl_color_chooser_get_mode"); + pragma Inline (fl_color_chooser_get_mode); + + procedure fl_color_chooser_set_mode + (N : in Storage.Integer_Address; + M : in Interfaces.C.int); + pragma Import (C, fl_color_chooser_set_mode, "fl_color_chooser_set_mode"); + pragma Inline (fl_color_chooser_set_mode); + + + + + -- Drawing, Events -- + + procedure fl_color_chooser_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_color_chooser_draw, "fl_color_chooser_draw"); + pragma Inline (fl_color_chooser_draw); + + function fl_color_chooser_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_color_chooser_handle, "fl_color_chooser_handle"); + pragma Inline (fl_color_chooser_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Color_Chooser) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Color_Chooser) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_color_chooser (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Color_Chooser; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Color_Chooser) is + begin + This.Draw_Ptr := fl_color_chooser_draw'Address; + This.Handle_Ptr := fl_color_chooser_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Color_Chooser is + begin + return This : Color_Chooser do + This.Void_Ptr := new_fl_color_chooser + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Color_Chooser is + begin + return This : Color_Chooser := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- RGB Color -- + + function Get_Red + (This : in Color_Chooser) + return Long_Float is + begin + return Long_Float (fl_color_chooser_r (This.Void_Ptr)); + end Get_Red; + + + function Get_Green + (This : in Color_Chooser) + return Long_Float is + begin + return Long_Float (fl_color_chooser_g (This.Void_Ptr)); + end Get_Green; + + + function Get_Blue + (This : in Color_Chooser) + return Long_Float is + begin + return Long_Float (fl_color_chooser_b (This.Void_Ptr)); + end Get_Blue; + + + procedure Set_RGB + (This : in out Color_Chooser; + R, G, B : in Long_Float) + is + Result : constant Interfaces.C.int := fl_color_chooser_rgb + (This.Void_Ptr, + Interfaces.C.double (R), + Interfaces.C.double (G), + Interfaces.C.double (B)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser::rgb returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_RGB; + + + function Set_RGB + (This : in out Color_Chooser; + R, G, B : in Long_Float) + return Boolean + is + Result : constant Interfaces.C.int := fl_color_chooser_rgb + (This.Void_Ptr, + Interfaces.C.double (R), + Interfaces.C.double (G), + Interfaces.C.double (B)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser::rgb returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_RGB; + + + + + -- HSV Color -- + + function Get_Hue + (This : in Color_Chooser) + return Long_Float is + begin + return Long_Float (fl_color_chooser_hue (This.Void_Ptr)); + end Get_Hue; + + + function Get_Saturation + (This : in Color_Chooser) + return Long_Float is + begin + return Long_Float (fl_color_chooser_saturation (This.Void_Ptr)); + end Get_Saturation; + + + function Get_Value + (This : in Color_Chooser) + return Long_Float is + begin + return Long_Float (fl_color_chooser_value (This.Void_Ptr)); + end Get_Value; + + + procedure Set_HSV + (This : in out Color_Chooser; + H, S, V : in Long_Float) + is + Result : constant Interfaces.C.int := fl_color_chooser_hsv + (This.Void_Ptr, + Interfaces.C.double (H), + Interfaces.C.double (S), + Interfaces.C.double (V)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser:hsv returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_HSV; + + + function Set_HSV + (This : in out Color_Chooser; + H, S, V : in Long_Float) + return Boolean + is + Result : constant Interfaces.C.int := fl_color_chooser_hsv + (This.Void_Ptr, + Interfaces.C.double (H), + Interfaces.C.double (S), + Interfaces.C.double (V)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Color_Chooser::hsv returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_HSV; + + + + + -- RGB / HSV Conversion -- + + procedure HSV_To_RGB + (H, S, V : in Long_Float; + R, G, B : out Long_Float) is + begin + fl_color_chooser_hsv2rgb + (Interfaces.C.double (H), + Interfaces.C.double (S), + Interfaces.C.double (V), + Interfaces.C.double (R), + Interfaces.C.double (G), + Interfaces.C.double (B)); + end HSV_To_RGB; + + + procedure RGB_To_HSV + (R, G, B : in Long_Float; + H, S, V : out Long_Float) is + begin + fl_color_chooser_rgb2hsv + (Interfaces.C.double (R), + Interfaces.C.double (G), + Interfaces.C.double (B), + Interfaces.C.double (H), + Interfaces.C.double (S), + Interfaces.C.double (V)); + end RGB_To_HSV; + + + + + -- Settings -- + + function Get_Mode + (This : in Color_Chooser) + return Color_Mode is + begin + return Color_Mode'Val (fl_color_chooser_get_mode (This.Void_Ptr)); + end Get_Mode; + + + procedure Set_Mode + (This : in out Color_Chooser; + To : in Color_Mode) is + begin + fl_color_chooser_set_mode (This.Void_Ptr, Color_Mode'Pos (To)); + end Set_Mode; + + +end FLTK.Widgets.Groups.Color_Choosers; + + diff --git a/body/fltk-widgets-groups-help_views.adb b/body/fltk-widgets-groups-help_views.adb new file mode 100644 index 0000000..d31e532 --- /dev/null +++ b/body/fltk-widgets-groups-help_views.adb @@ -0,0 +1,650 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Help_Views is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_help_view + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_help_view, "new_fl_help_view"); + pragma Inline (new_fl_help_view); + + procedure free_fl_help_view + (V : in Storage.Integer_Address); + pragma Import (C, free_fl_help_view, "free_fl_help_view"); + pragma Inline (free_fl_help_view); + + + + + -- Selection -- + + procedure fl_help_view_clear_selection + (V : in Storage.Integer_Address); + pragma Import (C, fl_help_view_clear_selection, "fl_help_view_clear_selection"); + pragma Inline (fl_help_view_clear_selection); + + procedure fl_help_view_select_all + (V : in Storage.Integer_Address); + pragma Import (C, fl_help_view_select_all, "fl_help_view_select_all"); + pragma Inline (fl_help_view_select_all); + + + + + -- Position -- + + function fl_help_view_find + (V : in Storage.Integer_Address; + S : in Interfaces.C.char_array; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_help_view_find, "fl_help_view_find"); + pragma Inline (fl_help_view_find); + + function fl_help_view_get_leftline + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_leftline, "fl_help_view_get_leftline"); + pragma Inline (fl_help_view_get_leftline); + + procedure fl_help_view_set_leftline + (V : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_leftline, "fl_help_view_set_leftline"); + pragma Inline (fl_help_view_set_leftline); + + function fl_help_view_get_topline + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_topline, "fl_help_view_get_topline"); + pragma Inline (fl_help_view_get_topline); + + procedure fl_help_view_set_topline + (V : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_topline, "fl_help_view_set_topline"); + pragma Inline (fl_help_view_set_topline); + + procedure fl_help_view_set_topline_target + (V : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_help_view_set_topline_target, "fl_help_view_set_topline_target"); + pragma Inline (fl_help_view_set_topline_target); + + + + + -- Content -- + + function fl_help_view_directory + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_directory, "fl_help_view_directory"); + pragma Inline (fl_help_view_directory); + + function fl_help_view_filename + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_filename, "fl_help_view_filename"); + pragma Inline (fl_help_view_filename); + + function fl_help_view_load + (V : in Storage.Integer_Address; + F : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_help_view_load, "fl_help_view_load"); + pragma Inline (fl_help_view_load); + + function fl_help_view_title + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_title, "fl_help_view_title"); + pragma Inline (fl_help_view_title); + + function fl_help_view_get_value + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_get_value, "fl_help_view_get_value"); + pragma Inline (fl_help_view_get_value); + + procedure fl_help_view_set_value + (V : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_help_view_set_value, "fl_help_view_set_value"); + pragma Inline (fl_help_view_set_value); + + procedure fl_help_view_link + (V, F : in Storage.Integer_Address); + pragma Import (C, fl_help_view_link, "fl_help_view_link"); + pragma Inline (fl_help_view_link); + + + + + -- Settings -- + + function fl_help_view_get_scrollbar_size + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_scrollbar_size, "fl_help_view_get_scrollbar_size"); + pragma Inline (fl_help_view_get_scrollbar_size); + + procedure fl_help_view_set_scrollbar_size + (V : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_scrollbar_size, "fl_help_view_set_scrollbar_size"); + pragma Inline (fl_help_view_set_scrollbar_size); + + function fl_help_view_get_size + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_size, "fl_help_view_get_size"); + pragma Inline (fl_help_view_get_size); + + procedure fl_help_view_set_size + (V : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_size, "fl_help_view_set_size"); + pragma Inline (fl_help_view_set_size); + + procedure fl_help_view_resize + (V : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_help_view_resize, "fl_help_view_resize"); + pragma Inline (fl_help_view_resize); + + function fl_help_view_get_textcolor + (V : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_help_view_get_textcolor, "fl_help_view_get_textcolor"); + pragma Inline (fl_help_view_get_textcolor); + + procedure fl_help_view_set_textcolor + (V : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_help_view_set_textcolor, "fl_help_view_set_textcolor"); + pragma Inline (fl_help_view_set_textcolor); + + function fl_help_view_get_textfont + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_textfont, "fl_help_view_get_textfont"); + pragma Inline (fl_help_view_get_textfont); + + procedure fl_help_view_set_textfont + (V : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_textfont, "fl_help_view_set_textfont"); + pragma Inline (fl_help_view_set_textfont); + + function fl_help_view_get_textsize + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_textsize, "fl_help_view_get_textsize"); + pragma Inline (fl_help_view_get_textsize); + + procedure fl_help_view_set_textsize + (V : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_textsize, "fl_help_view_set_textsize"); + pragma Inline (fl_help_view_set_textsize); + + + + + -- Drawing, Events -- + + procedure fl_help_view_draw + (V : in Storage.Integer_Address); + pragma Import (C, fl_help_view_draw, "fl_help_view_draw"); + pragma Inline (fl_help_view_draw); + + function fl_help_view_handle + (V : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_help_view_handle, "fl_help_view_handle"); + pragma Inline (fl_help_view_handle); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + package Help_View_Convert is new System.Address_To_Access_Conversions (Help_View'Class); + + function Link_Callback_Hook + (V : in Storage.Integer_Address; + S : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.Strings.chars_ptr; + + pragma Convention (C, Link_Callback_Hook); + + function Link_Callback_Hook + (V : in Storage.Integer_Address; + S : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.Strings.chars_ptr + is + User_Data : constant Storage.Integer_Address := fl_widget_get_user_data (V); + Ada_Help_View : access Help_View'Class; + begin + pragma Assert (User_Data /= Null_Pointer); + Ada_Help_View := Help_View_Convert.To_Pointer (Storage.To_Address (User_Data)); + if Ada_Help_View.Zelda = null then + return S; + end if; + Interfaces.C.Strings.Free (Ada_Help_View.Hilda); + Ada_Help_View.Hilda := Interfaces.C.Strings.New_String + (Ada_Help_View.Zelda (Ada_Help_View.all, Interfaces.C.Strings.Value (S))); + if Interfaces.C.Strings.Value (Ada_Help_View.Hilda) = "" then + return Interfaces.C.Strings.Null_Ptr; + else + return Ada_Help_View.Hilda; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Help_View::link callback hook received Widget with no user_data reference " & + "back to Ada"; + end Link_Callback_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Help_View) is + begin + Interfaces.C.Strings.Free (This.Hilda); + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Help_View) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_help_view (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Help_View; + X, Y, W, H : in Integer; + Text : in String) is + begin + fl_help_view_link (This.Void_Ptr, Storage.To_Integer (Link_Callback_Hook'Address)); + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Help_View) is + begin + This.Draw_Ptr := fl_help_view_draw'Address; + This.Handle_Ptr := fl_help_view_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Help_View is + begin + return This : Help_View do + This.Void_Ptr := new_fl_help_view + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Help_View is + begin + return This : Help_View := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Selection -- + + procedure Clear_Selection + (This : in out Help_View) is + begin + fl_help_view_clear_selection (This.Void_Ptr); + end Clear_Selection; + + + procedure Select_All + (This : in out Help_View) is + begin + fl_help_view_select_all (This.Void_Ptr); + end Select_All; + + + + + -- Position -- + + function Find + (This : in Help_View; + Item : in String; + From : in Position := 1) + return Extended_Position is + begin + return Extended_Position (fl_help_view_find + (This.Void_Ptr, + Interfaces.C.To_C (Item), + Interfaces.C.int (From) - 1) + 1); + end Find; + + + function Get_Leftline_Pixel + (This : in Help_View) + return Natural is + begin + return Natural (fl_help_view_get_leftline (This.Void_Ptr)); + end Get_Leftline_Pixel; + + + procedure Set_Leftline_Pixel + (This : in out Help_View; + Value : in Natural) is + begin + fl_help_view_set_leftline (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Leftline_Pixel; + + + function Get_Topline_Pixel + (This : in Help_View) + return Natural is + begin + return Natural (fl_help_view_get_topline (This.Void_Ptr)); + end Get_Topline_Pixel; + + + procedure Set_Topline_Pixel + (This : in out Help_View; + Value : in Natural) is + begin + fl_help_view_set_topline (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Topline_Pixel; + + + procedure Set_Topline_Target + (This : in out Help_View; + Value : in String) is + begin + fl_help_view_set_topline_target (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Topline_Target; + + + + + -- Content -- + + function Current_Directory + (This : in Help_View) + return String is + begin + return Interfaces.C.Strings.Value (fl_help_view_directory (This.Void_Ptr)); + end Current_Directory; + + + function Current_File + (This : in Help_View) + return String is + begin + return Interfaces.C.Strings.Value (fl_help_view_filename (This.Void_Ptr)); + end Current_File; + + + procedure Load + (This : in out Help_View; + Name : in String) + is + Code : constant Interfaces.C.int := + fl_help_view_load (This.Void_Ptr, Interfaces.C.To_C (Name)); + begin + if Code = -1 then + raise Load_Help_Error; + else + pragma Assert (Code = 0); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Help_View::load returned unexpected int value of " & + Interfaces.C.int'Image (Code); + end Load; + + + function Document_Title + (This : in Help_View) + return String + is + Raw_Chars : constant Interfaces.C.Strings.chars_ptr := fl_help_view_title (This.Void_Ptr); + use type Interfaces.C.Strings.chars_ptr; + begin + if Raw_Chars = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Raw_Chars); + end if; + end Document_Title; + + + function Get_Content + (This : in Help_View) + return String + is + Raw_Chars : constant Interfaces.C.Strings.chars_ptr := + fl_help_view_get_value (This.Void_Ptr); + use type Interfaces.C.Strings.chars_ptr; + begin + if Raw_Chars = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Raw_Chars); + end if; + end Get_Content; + + + procedure Set_Content + (This : in out Help_View; + Value : in String) is + begin + fl_help_view_set_value (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Content; + + + procedure Set_Link_Callback + (This : in out Help_View; + Func : in Link_Callback) is + begin + This.Zelda := Func; + end Set_Link_Callback; + + + + + -- Settings -- + + function Get_Scrollbar_Size + (This : in Help_View) + return Natural is + begin + return Natural (fl_help_view_get_scrollbar_size (This.Void_Ptr)); + end Get_Scrollbar_Size; + + + procedure Set_Scrollbar_Size + (This : in out Help_View; + Value : in Natural) is + begin + fl_help_view_set_scrollbar_size (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Scrollbar_Size; + + + function Get_Size + (This : in Help_View) + return Integer is + begin + return Integer (fl_help_view_get_size (This.Void_Ptr)); + end Get_Size; + + + procedure Resize + (This : in out Help_View; + W, H : in Integer) is + begin + fl_help_view_set_size + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Resize + (This : in out Help_View; + X, Y, W, H : in Integer) is + begin + fl_help_view_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + function Get_Text_Color + (This : in Help_View) + return Color is + begin + return Color (fl_help_view_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Help_View; + Value : in Color) is + begin + fl_help_view_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Help_View) + return Font_Kind is + begin + return Font_Kind'Val (fl_help_view_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Help_View; + Font : in Font_Kind) is + begin + fl_help_view_set_textfont (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Help_View) + return Font_Size is + begin + return Font_Size (fl_help_view_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Help_View; + Size : in Font_Size) is + begin + fl_help_view_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Help_View) is + begin + Group (This).Draw; + end Draw; + + + function Handle + (This : in out Help_View; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Help_Views; + + diff --git a/body/fltk-widgets-groups-input_choices.adb b/body/fltk-widgets-groups-input_choices.adb new file mode 100644 index 0000000..9119768 --- /dev/null +++ b/body/fltk-widgets-groups-input_choices.adb @@ -0,0 +1,501 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Groups.Input_Choices is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_input_choice + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_input_choice, "new_fl_input_choice"); + pragma Inline (new_fl_input_choice); + + procedure free_fl_input_choice + (W : in Storage.Integer_Address); + pragma Import (C, free_fl_input_choice, "free_fl_input_choice"); + pragma Inline (free_fl_input_choice); + + + + + -- Attributes -- + + function fl_input_choice_input + (N : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_input_choice_input, "fl_input_choice_input"); + pragma Inline (fl_input_choice_input); + + function fl_input_choice_menubutton + (N : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_input_choice_menubutton, "fl_input_choice_menubutton"); + pragma Inline (fl_input_choice_menubutton); + + + + + -- Menu Items -- + + procedure fl_input_choice_clear + (N : in Storage.Integer_Address); + pragma Import (C, fl_input_choice_clear, "fl_input_choice_clear"); + pragma Inline (fl_input_choice_clear); + + + + + -- Settings -- + + function fl_input_choice_changed + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_choice_changed, "fl_input_choice_changed"); + pragma Inline (fl_input_choice_changed); + + procedure fl_input_choice_clear_changed + (N : in Storage.Integer_Address); + pragma Import (C, fl_input_choice_clear_changed, "fl_input_choice_clear_changed"); + pragma Inline (fl_input_choice_clear_changed); + + procedure fl_input_choice_set_changed + (N : in Storage.Integer_Address); + pragma Import (C, fl_input_choice_set_changed, "fl_input_choice_set_changed"); + pragma Inline (fl_input_choice_set_changed); + + function fl_input_choice_get_down_box + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_choice_get_down_box, "fl_input_choice_get_down_box"); + pragma Inline (fl_input_choice_get_down_box); + + procedure fl_input_choice_set_down_box + (N : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_choice_set_down_box, "fl_input_choice_set_down_box"); + pragma Inline (fl_input_choice_set_down_box); + + function fl_input_choice_get_textcolor + (N : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_input_choice_get_textcolor, "fl_input_choice_get_textcolor"); + pragma Inline (fl_input_choice_get_textcolor); + + procedure fl_input_choice_set_textcolor + (N : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_input_choice_set_textcolor, "fl_input_choice_set_textcolor"); + pragma Inline (fl_input_choice_set_textcolor); + + function fl_input_choice_get_textfont + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_choice_get_textfont, "fl_input_choice_get_textfont"); + pragma Inline (fl_input_choice_get_textfont); + + procedure fl_input_choice_set_textfont + (N : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_choice_set_textfont, "fl_input_choice_set_textfont"); + pragma Inline (fl_input_choice_set_textfont); + + function fl_input_choice_get_textsize + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_choice_get_textsize, "fl_input_choice_get_textsize"); + pragma Inline (fl_input_choice_get_textsize); + + procedure fl_input_choice_set_textsize + (N : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_choice_set_textsize, "fl_input_choice_set_textsize"); + pragma Inline (fl_input_choice_set_textsize); + + function fl_input_choice_get_value + (N : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_input_choice_get_value, "fl_input_choice_get_value"); + pragma Inline (fl_input_choice_get_value); + + procedure fl_input_choice_set_value + (N : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_input_choice_set_value, "fl_input_choice_set_value"); + pragma Inline (fl_input_choice_set_value); + + procedure fl_input_choice_set_value2 + (N : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_choice_set_value2, "fl_input_choice_set_value2"); + pragma Inline (fl_input_choice_set_value2); + + + + + -- Dimensions -- + + procedure fl_input_choice_resize + (N : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_input_choice_resize, "fl_input_choice_resize"); + pragma Inline (fl_input_choice_resize); + + + + + -- Drawing, Events -- + + procedure fl_input_choice_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_input_choice_draw, "fl_input_choice_draw"); + pragma Inline (fl_input_choice_draw); + + function fl_input_choice_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_choice_handle, "fl_input_choice_handle"); + pragma Inline (fl_input_choice_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Input_Choice) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Input_Choice) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_input_choice (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Translocation initiating... + procedure fl_text_input_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_text_input_extra_init, "fl_text_input_extra_init"); + pragma Inline (fl_text_input_extra_init); + + + -- Crossing the streams + procedure fl_menu_button_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_menu_button_extra_init, "fl_menu_button_extra_init"); + pragma Inline (fl_menu_button_extra_init); + + + procedure Extra_Init + (This : in out Input_Choice; + X, Y, W, H : in Integer; + Text : in String) is + begin + Wrapper (This.My_Input).Void_Ptr := fl_input_choice_input (This.Void_Ptr); + Wrapper (This.My_Input).Needs_Dealloc := False; + fl_text_input_extra_init + (Storage.To_Integer (This.My_Input'Address), + Interfaces.C.int (This.My_Input.Get_X), + Interfaces.C.int (This.My_Input.Get_Y), + Interfaces.C.int (This.My_Input.Get_W), + Interfaces.C.int (This.My_Input.Get_H), + Interfaces.C.To_C (This.My_Input.Get_Label)); + Wrapper (This.My_Menu_Button).Void_Ptr := fl_input_choice_menubutton (This.Void_Ptr); + Wrapper (This.My_Menu_Button).Needs_Dealloc := False; + fl_menu_button_extra_init + (Storage.To_Integer (This.My_Menu_Button'Address), + Interfaces.C.int (This.My_Menu_Button.Get_X), + Interfaces.C.int (This.My_Menu_Button.Get_Y), + Interfaces.C.int (This.My_Menu_Button.Get_W), + Interfaces.C.int (This.My_Menu_Button.Get_H), + Interfaces.C.To_C (This.My_Menu_Button.Get_Label)); + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Input_Choice) is + begin + This.Draw_Ptr := fl_input_choice_draw'Address; + This.Handle_Ptr := fl_input_choice_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Input_Choice is + begin + return This : Input_Choice do + This.Void_Ptr := new_fl_input_choice + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Input_Choice is + begin + return This : Input_Choice := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + + function Text_Field + (This : in out Input_Choice) + return FLTK.Widgets.Inputs.Text.Text_Input_Reference is + begin + return (Data => This.My_Input'Unchecked_Access); + end Text_Field; + + + function Button_Menu + (This : in out Input_Choice) + return FLTK.Widgets.Menus.Menu_Buttons.Menu_Button_Reference is + begin + return (Data => This.My_Menu_Button'Unchecked_Access); + end Button_Menu; + + + + + -- Menu Items -- + + function Has_Item + (This : in Input_Choice; + Place : in FLTK.Widgets.Menus.Index) + return Boolean is + begin + return This.My_Menu_Button.Has_Item (Place); + end Has_Item; + + + function Item + (This : in Input_Choice; + Place : in FLTK.Widgets.Menus.Index) + return FLTK.Menu_Items.Menu_Item_Reference is + begin + return This.My_Menu_Button.Item (Place); + end Item; + + + procedure Use_Same_Items + (This : in out Input_Choice; + Donor : in FLTK.Widgets.Menus.Menu'Class) is + begin + This.My_Menu_Button.Use_Same_Items (Donor); + end Use_Same_Items; + + + procedure Clear + (This : in out Input_Choice) is + begin + fl_input_choice_clear (This.Void_Ptr); + end Clear; + + + + + -- Settings -- + + function Has_Changed + (This : in Input_Choice) + return Boolean is + begin + return fl_input_choice_changed (This.Void_Ptr) /= 0; + end Has_Changed; + + + procedure Clear_Changed + (This : in out Input_Choice) is + begin + fl_input_choice_clear_changed (This.Void_Ptr); + end Clear_Changed; + + + procedure Set_Changed + (This : in out Input_Choice; + To : in Boolean) is + begin + if To then + fl_input_choice_set_changed (This.Void_Ptr); + end if; + end Set_Changed; + + + function Get_Down_Box + (This : in Input_Choice) + return Box_Kind is + begin + return Box_Kind'Val (fl_input_choice_get_down_box (This.Void_Ptr)); + end Get_Down_Box; + + + procedure Set_Down_Box + (This : in out Input_Choice; + To : in Box_Kind) is + begin + fl_input_choice_set_down_box (This.Void_Ptr, Box_Kind'Pos (To)); + end Set_Down_Box; + + + function Get_Text_Color + (This : in Input_Choice) + return Color is + begin + return Color (fl_input_choice_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Input_Choice; + To : in Color) is + begin + fl_input_choice_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Input_Choice) + return Font_Kind is + begin + return Font_Kind'Val (fl_input_choice_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Input_Choice; + To : in Font_Kind) is + begin + fl_input_choice_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Input_Choice) + return Font_Size is + begin + return Font_Size (fl_input_choice_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Input_Choice; + To : in Font_Size) is + begin + fl_input_choice_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + function Get_Input + (This : in Input_Choice) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_choice_get_value (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + -- pointer to internal buffer so no free necessary + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Input; + + + procedure Set_Input + (This : in out Input_Choice; + To : in String) is + begin + fl_input_choice_set_value (This.Void_Ptr, Interfaces.C.To_C (To)); + end Set_Input; + + + procedure Set_Item + (This : in out Input_Choice; + Num : in Integer) is + begin + fl_input_choice_set_value2 (This.Void_Ptr, Interfaces.C.int (Num)); + end Set_Item; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Input_Choice; + X, Y, W, H : in Integer) is + begin + fl_input_choice_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + +end FLTK.Widgets.Groups.Input_Choices; + + diff --git a/body/fltk-widgets-groups-packed.adb b/body/fltk-widgets-groups-packed.adb new file mode 100644 index 0000000..d832a35 --- /dev/null +++ b/body/fltk-widgets-groups-packed.adb @@ -0,0 +1,207 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Widgets.Groups.Packed is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_pack + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_pack, "new_fl_pack"); + pragma Inline (new_fl_pack); + + procedure free_fl_pack + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_pack, "free_fl_pack"); + pragma Inline (free_fl_pack); + + + + + -- Settings -- + + function fl_pack_get_spacing + (P : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_pack_get_spacing, "fl_pack_get_spacing"); + pragma Inline (fl_pack_get_spacing); + + procedure fl_pack_set_spacing + (P : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_pack_set_spacing, "fl_pack_set_spacing"); + pragma Inline (fl_pack_set_spacing); + + + + + -- Drawing, Events -- + + procedure fl_pack_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_pack_draw, "fl_pack_draw"); + pragma Inline (fl_pack_draw); + + function fl_pack_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_pack_handle, "fl_pack_handle"); + pragma Inline (fl_pack_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Packed_Group) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Packed_Group) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_pack (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Packed_Group; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Packed_Group) is + begin + This.Draw_Ptr := fl_pack_draw'Address; + This.Handle_Ptr := fl_pack_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Packed_Group is + begin + return This : Packed_Group do + This.Void_Ptr := new_fl_pack + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Packed_Group is + begin + return This : Packed_Group := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Settings -- + + function Get_Spacing + (This : in Packed_Group) + return Integer is + begin + return Integer (fl_pack_get_spacing (This.Void_Ptr)); + end Get_Spacing; + + + procedure Set_Spacing + (This : in out Packed_Group; + To : in Integer) is + begin + fl_pack_set_spacing (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Spacing; + + + function Get_Kind + (This : in Packed_Group) + return Pack_Kind + is + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + begin + return Pack_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Pack::type returned unexpected unsigned char value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Kind; + + + procedure Set_Kind + (This : in out Packed_Group; + Kind : in Pack_Kind) is + begin + fl_widget_set_type (This.Void_Ptr, Pack_Kind'Pos (Kind)); + end Set_Kind; + + + + + -- Drawing -- + + procedure Draw + (This : in out Packed_Group) is + begin + Group (This).Draw; + end Draw; + + +end FLTK.Widgets.Groups.Packed; + + diff --git a/body/fltk-widgets-groups-scrolls.adb b/body/fltk-widgets-groups-scrolls.adb new file mode 100644 index 0000000..65498a6 --- /dev/null +++ b/body/fltk-widgets-groups-scrolls.adb @@ -0,0 +1,505 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Characters.Latin_1, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.unsigned_char; + + +package body FLTK.Widgets.Groups.Scrolls is + + + package Latin renames Ada.Characters.Latin_1; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_scroll + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_scroll, "new_fl_scroll"); + pragma Inline (new_fl_scroll); + + procedure free_fl_scroll + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_scroll, "free_fl_scroll"); + pragma Inline (free_fl_scroll); + + + + + -- Attributes -- + + function fl_scroll_hscrollbar + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_scroll_hscrollbar, "fl_scroll_hscrollbar"); + pragma Inline (fl_scroll_hscrollbar); + + function fl_scroll_scrollbar + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_scroll_scrollbar, "fl_scroll_scrollbar"); + pragma Inline (fl_scroll_scrollbar); + + + + + -- Scrolling -- + + procedure fl_scroll_to + (S : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_scroll_to, "fl_scroll_to"); + pragma Inline (fl_scroll_to); + + function fl_scroll_xposition + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_scroll_xposition, "fl_scroll_xposition"); + pragma Inline (fl_scroll_xposition); + + function fl_scroll_yposition + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_scroll_yposition, "fl_scroll_yposition"); + pragma Inline (fl_scroll_yposition); + + + + + -- Scrollbar Settings -- + + function fl_scroll_get_size + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_scroll_get_size, "fl_scroll_get_size"); + pragma Inline (fl_scroll_get_size); + + procedure fl_scroll_set_size + (S : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_scroll_set_size, "fl_scroll_set_size"); + pragma Inline (fl_scroll_set_size); + + + + + -- Dimensions -- + + procedure fl_scroll_resize + (S : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_scroll_resize, "fl_scroll_resize"); + pragma Inline (fl_scroll_resize); + + procedure fl_scroll_recalc_scrollbars + (Addr : in Storage.Integer_Address; + CB_X, CB_Y, CB_W, CB_H : out Interfaces.C.int; + IB_X, IB_Y, IB_W, IB_H : out Interfaces.C.int; + IC_X, IC_Y, IC_W, IC_H : out Interfaces.C.int; + CH_Need, CV_Need : out Interfaces.C.int; + HS_X, HS_Y, HS_W, HS_H : out Interfaces.C.int; + HS_Size, HS_Total, HS_First, HS_Pos : out Interfaces.C.int; + VS_X, VS_Y, VS_W, VS_H : out Interfaces.C.int; + VS_Size, VS_Total, VS_First, VS_Pos : out Interfaces.C.int; + SSize : out Interfaces.C.int); + pragma Import (C, fl_scroll_recalc_scrollbars, "fl_scroll_recalc_scrollbars"); + pragma Inline (fl_scroll_recalc_scrollbars); + + + + + -- Drawing, Events -- + + procedure fl_scroll_bbox + (S : in Storage.Integer_Address; + X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_scroll_bbox, "fl_scroll_bbox"); + pragma Inline (fl_scroll_bbox); + + procedure fl_scroll_draw + (S : in Storage.Integer_Address); + pragma Import (C, fl_scroll_draw, "fl_scroll_draw"); + pragma Inline (fl_scroll_draw); + + function fl_scroll_handle + (S : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_scroll_handle, "fl_scroll_handle"); + pragma Inline (fl_scroll_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Scroll) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Scroll) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_scroll (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Quite right sir, stop the boat! + procedure scroll_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, scroll_extra_init_hook, "scroll_extra_init_hook"); + + procedure scroll_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Scroll : Scroll; + for My_Scroll'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Scroll); + begin + Extra_Init + (My_Scroll, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end scroll_extra_init_hook; + + + -- Hold on, I know a shortcut + procedure fl_scrollbar_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_scrollbar_extra_init, "fl_scrollbar_extra_init"); + pragma Inline (fl_scrollbar_extra_init); + + + procedure Extra_Init + (This : in out Scroll; + X, Y, W, H : in Integer; + Text : in String) is + begin + Widget (This.Horizon).Void_Ptr := fl_scroll_hscrollbar (This.Void_Ptr); + Widget (This.Horizon).Needs_Dealloc := False; + fl_scrollbar_extra_init + (Storage.To_Integer (This.Horizon'Address), + Interfaces.C.int (This.Horizon.Get_X), + Interfaces.C.int (This.Horizon.Get_Y), + Interfaces.C.int (This.Horizon.Get_W), + Interfaces.C.int (This.Horizon.Get_H), + Interfaces.C.To_C (This.Horizon.Get_Label)); + Widget (This.Vertigo).Void_Ptr := fl_scroll_scrollbar (This.Void_Ptr); + Widget (This.Vertigo).Needs_Dealloc := False; + fl_scrollbar_extra_init + (Storage.To_Integer (This.Vertigo'Address), + Interfaces.C.int (This.Vertigo.Get_X), + Interfaces.C.int (This.Vertigo.Get_Y), + Interfaces.C.int (This.Vertigo.Get_W), + Interfaces.C.int (This.Vertigo.Get_H), + Interfaces.C.To_C (This.Vertigo.Get_Label)); + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Scroll) is + begin + This.Draw_Ptr := fl_scroll_draw'Address; + This.Handle_Ptr := fl_scroll_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Scroll is + begin + return This : Scroll do + This.Void_Ptr := new_fl_scroll + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Scroll is + begin + return This : Scroll := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + + function H_Bar + (This : in out Scroll) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Horizon'Unchecked_Access); + end H_Bar; + + + function V_Bar + (This : in out Scroll) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Vertigo'Unchecked_Access); + end V_Bar; + + + + + -- Contents -- + + procedure Clear + (This : in out Scroll) is + begin + -- Can't use the actual clear method here because that would + -- delete the widgets from memory, and the binding is meant to + -- handle that, not the library. + This.Remove (This.Horizon); + This.Remove (This.Vertigo); + Group (This).Clear; + This.Add (This.Horizon); + This.Add (This.Vertigo); + end Clear; + + + + + -- Scrolling -- + + procedure Scroll_To + (This : in out Scroll; + X, Y : in Integer) is + begin + fl_scroll_to (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); + end Scroll_To; + + + function Get_Scroll_X + (This : in Scroll) + return Integer is + begin + return Integer (fl_scroll_xposition (This.Void_Ptr)); + end Get_Scroll_X; + + + function Get_Scroll_Y + (This : in Scroll) + return Integer is + begin + return Integer (fl_scroll_yposition (This.Void_Ptr)); + end Get_Scroll_Y; + + + + + -- Scrollbar Settings -- + + function Get_Scrollbar_Size + (This : in Scroll) + return Integer is + begin + return Integer (fl_scroll_get_size (This.Void_Ptr)); + end Get_Scrollbar_Size; + + + procedure Set_Scrollbar_Size + (This : in out Scroll; + To : in Integer) is + begin + fl_scroll_set_size (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Scrollbar_Size; + + + function Get_Kind + (This : in Scroll) + return Scroll_Kind + is + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + begin + return Scroll_Kind'Val (Result - 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Scroll::type returned unexpected unsigned char value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Kind; + + + procedure Set_Kind + (This : in out Scroll; + Mode : in Scroll_Kind) is + begin + fl_widget_set_type (This.Void_Ptr, Scroll_Kind'Pos (Mode)); + end Set_Kind; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Scroll; + X, Y, W, H : in Integer) is + begin + fl_scroll_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Recalculate_Scrollbars + (This : in Scroll; + Data : out Scroll_Info) + is + C_Scroll_Size, + C_H_Need, C_V_Need, + C_H_Data_Size, C_V_Data_Size, + C_H_Data_Total, C_V_Data_Total : Interfaces.C.int; + begin + fl_scroll_recalc_scrollbars + (This.Void_Ptr, + + -- child LRTB region that will be reworked into XYWH in C++ + Interfaces.C.int (Data.Child_Box.X), Interfaces.C.int (Data.Child_Box.Y), + Interfaces.C.int (Data.Child_Box.W), Interfaces.C.int (Data.Child_Box.H), + + -- innerbox XYWH region + Interfaces.C.int (Data.Inner_Ex.X), Interfaces.C.int (Data.Inner_Ex.Y), + Interfaces.C.int (Data.Inner_Ex.W), Interfaces.C.int (Data.Inner_Ex.H), + + -- innerchild XYWH region + Interfaces.C.int (Data.Inner_Inc.X), Interfaces.C.int (Data.Inner_Inc.Y), + Interfaces.C.int (Data.Inner_Inc.W), Interfaces.C.int (Data.Inner_Inc.H), + + -- raw hneeded/vneeded values to be converted into Booleans + C_H_Need, C_V_Need, + + -- hscroll data + Interfaces.C.int (Data.H_Data.X), Interfaces.C.int (Data.H_Data.Y), + Interfaces.C.int (Data.H_Data.W), Interfaces.C.int (Data.H_Data.H), + C_H_Data_Size, C_H_Data_Total, + Interfaces.C.int (Data.H_Data.First), Interfaces.C.int (Data.H_Data.Position), + + -- vscroll data + Interfaces.C.int (Data.V_Data.X), Interfaces.C.int (Data.V_Data.Y), + Interfaces.C.int (Data.V_Data.W), Interfaces.C.int (Data.V_Data.H), + C_V_Data_Size, C_V_Data_Total, + Interfaces.C.int (Data.V_Data.First), Interfaces.C.int (Data.V_Data.Position), + + -- scrollsize + C_Scroll_Size); + + Data.H_Needed := C_H_Need /= 0; + Data.V_Needed := C_V_Need /= 0; + Data.H_Data.Size := Natural (C_H_Data_Size); + Data.H_Data.Total := Natural (C_H_Data_Total); + Data.V_Data.Size := Natural (C_V_Data_Size); + Data.V_Data.Total := Natural (C_V_Data_Total); + Data.Scroll_Size := Natural (C_Scroll_Size); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Scroll::recalc_scrollbars returned unexpected int values of " & Latin.LF & + Latin.HT & "hscroll.size = " & Interfaces.C.int'Image (C_H_Data_Size) & Latin.LF & + Latin.HT & "hscroll.total = " & Interfaces.C.int'Image (C_H_Data_Total) & Latin.LF & + Latin.HT & "vscroll.size = " & Interfaces.C.int'Image (C_V_Data_Size) & Latin.LF & + Latin.HT & "vscroll.total = " & Interfaces.C.int'Image (C_V_Data_Total) & Latin.LF & + Latin.HT & "scrollsize = " & Interfaces.C.int'Image (C_Scroll_Size); + end Recalculate_Scrollbars; + + + + + -- Drawing, Events -- + + procedure Bounding_Box + (This : in Scroll; + X, Y, W, H : out Integer) is + begin + fl_scroll_bbox + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Bounding_Box; + + + procedure Draw + (This : in out Scroll) is + begin + Group (This).Draw; + end Draw; + + + function Handle + (This : in out Scroll; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Scrolls; + + diff --git a/body/fltk-widgets-groups-spinners.adb b/body/fltk-widgets-groups-spinners.adb new file mode 100644 index 0000000..d9501ee --- /dev/null +++ b/body/fltk-widgets-groups-spinners.adb @@ -0,0 +1,558 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + +use type + + Interfaces.C.unsigned_char, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Groups.Spinners is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_spinner + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_spinner, "new_fl_spinner"); + pragma Inline (new_fl_spinner); + + procedure free_fl_spinner + (W : in Storage.Integer_Address); + pragma Import (C, free_fl_spinner, "free_fl_spinner"); + pragma Inline (free_fl_spinner); + + + + + -- Settings -- + + function fl_spinner_get_color + (S : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_spinner_get_color, "fl_spinner_get_color"); + pragma Inline (fl_spinner_get_color); + + procedure fl_spinner_set_color + (S : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_spinner_set_color, "fl_spinner_set_color"); + pragma Inline (fl_spinner_set_color); + + function fl_spinner_get_selection_color + (S : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_spinner_get_selection_color, "fl_spinner_get_selection_color"); + pragma Inline (fl_spinner_get_selection_color); + + procedure fl_spinner_set_selection_color + (S : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_spinner_set_selection_color, "fl_spinner_set_selection_color"); + pragma Inline (fl_spinner_set_selection_color); + + function fl_spinner_get_textcolor + (S : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_spinner_get_textcolor, "fl_spinner_get_textcolor"); + pragma Inline (fl_spinner_get_textcolor); + + procedure fl_spinner_set_textcolor + (S : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_spinner_set_textcolor, "fl_spinner_set_textcolor"); + pragma Inline (fl_spinner_set_textcolor); + + function fl_spinner_get_textfont + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_spinner_get_textfont, "fl_spinner_get_textfont"); + pragma Inline (fl_spinner_get_textfont); + + procedure fl_spinner_set_textfont + (S : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_spinner_set_textfont, "fl_spinner_set_textfont"); + pragma Inline (fl_spinner_set_textfont); + + function fl_spinner_get_textsize + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_spinner_get_textsize, "fl_spinner_get_textsize"); + pragma Inline (fl_spinner_get_textsize); + + procedure fl_spinner_set_textsize + (S : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_spinner_set_textsize, "fl_spinner_set_textsize"); + pragma Inline (fl_spinner_set_textsize); + + + + + -- Values -- + + function fl_spinner_get_minimum + (S : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_spinner_get_minimum, "fl_spinner_get_minimum"); + pragma Inline (fl_spinner_get_minimum); + + procedure fl_spinner_set_minimum + (S : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_spinner_set_minimum, "fl_spinner_set_minimum"); + pragma Inline (fl_spinner_set_minimum); + + function fl_spinner_get_maximum + (S : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_spinner_get_maximum, "fl_spinner_get_maximum"); + pragma Inline (fl_spinner_get_maximum); + + procedure fl_spinner_set_maximum + (S : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_spinner_set_maximum, "fl_spinner_set_maximum"); + pragma Inline (fl_spinner_set_maximum); + + procedure fl_spinner_range + (S : in Storage.Integer_Address; + A, B : in Interfaces.C.double); + pragma Import (C, fl_spinner_range, "fl_spinner_range"); + pragma Inline (fl_spinner_range); + + function fl_spinner_get_step + (S : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_spinner_get_step, "fl_spinner_get_step"); + pragma Inline (fl_spinner_get_step); + + procedure fl_spinner_set_step + (S : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_spinner_set_step, "fl_spinner_set_step"); + pragma Inline (fl_spinner_set_step); + + function fl_spinner_get_value + (S : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_spinner_get_value, "fl_spinner_get_value"); + pragma Inline (fl_spinner_get_value); + + procedure fl_spinner_set_value + (S : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_spinner_set_value, "fl_spinner_set_value"); + pragma Inline (fl_spinner_set_value); + + + + + -- Formatting -- + + function fl_spinner_get_format + (S : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_spinner_get_format, "fl_spinner_get_format"); + pragma Inline (fl_spinner_get_format); + + procedure fl_spinner_set_format + (S : in Storage.Integer_Address; + F : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_spinner_set_format, "fl_spinner_set_format"); + pragma Inline (fl_spinner_set_format); + + function fl_spinner_get_type + (S : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_spinner_get_type, "fl_spinner_get_type"); + pragma Inline (fl_spinner_get_type); + + procedure fl_spinner_set_type + (S : in Storage.Integer_Address; + T : in Interfaces.C.unsigned_char); + pragma Import (C, fl_spinner_set_type, "fl_spinner_set_type"); + pragma Inline (fl_spinner_set_type); + + + + + -- Dimensions -- + + procedure fl_spinner_resize + (S : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_spinner_resize, "fl_spinner_resize"); + pragma Inline (fl_spinner_resize); + + + + + -- Drawing, Events -- + + procedure fl_spinner_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_spinner_draw, "fl_spinner_draw"); + pragma Inline (fl_spinner_draw); + + function fl_spinner_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_spinner_handle, "fl_spinner_handle"); + pragma Inline (fl_spinner_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Spinner) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Spinner) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_spinner (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Spinner; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Spinner) is + begin + This.Draw_Ptr := fl_spinner_draw'Address; + This.Handle_Ptr := fl_spinner_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Spinner is + begin + return This : Spinner do + This.Void_Ptr := new_fl_spinner + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Spinner is + begin + return This : Spinner := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Settings -- + + function Get_Background_Color + (This : in Spinner) + return Color is + begin + return Color (fl_spinner_get_color (This.Void_Ptr)); + end Get_Background_Color; + + + procedure Set_Background_Color + (This : in out Spinner; + To : in Color) is + begin + fl_spinner_set_color (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Background_Color; + + + function Get_Selection_Color + (This : in Spinner) + return Color is + begin + return Color (fl_spinner_get_selection_color (This.Void_Ptr)); + end Get_Selection_Color; + + + procedure Set_Selection_Color + (This : in out Spinner; + To : in Color) is + begin + fl_spinner_set_selection_color (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Selection_Color; + + + function Get_Text_Color + (This : in Spinner) + return Color is + begin + return Color (fl_spinner_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Spinner; + To : in Color) is + begin + fl_spinner_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Spinner) + return Font_Kind is + begin + return Font_Kind'Val (fl_spinner_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Spinner; + To : in Font_Kind) is + begin + fl_spinner_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Spinner) + return Font_Size is + begin + return Font_Size (fl_spinner_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Spinner; + To : in Font_Size) is + begin + fl_spinner_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + + + -- Values -- + + function Get_Minimum + (This : in Spinner) + return Long_Float is + begin + return Long_Float (fl_spinner_get_minimum (This.Void_Ptr)); + end Get_Minimum; + + + procedure Set_Minimum + (This : in out Spinner; + To : in Long_Float) is + begin + fl_spinner_set_minimum (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Minimum; + + + function Get_Maximum + (This : in Spinner) + return Long_Float is + begin + return Long_Float (fl_spinner_get_maximum (This.Void_Ptr)); + end Get_Maximum; + + + procedure Set_Maximum + (This : in out Spinner; + To : in Long_Float) is + begin + fl_spinner_set_maximum (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Maximum; + + + procedure Get_Range + (This : in Spinner; + Min, Max : out Long_Float) is + begin + Min := Long_Float (fl_spinner_get_minimum (This.Void_Ptr)); + Max := Long_Float (fl_spinner_get_maximum (This.Void_Ptr)); + end Get_Range; + + + procedure Set_Range + (This : in out Spinner; + Min, Max : in Long_Float) is + begin + fl_spinner_range + (This.Void_Ptr, + Interfaces.C.double (Min), + Interfaces.C.double (Max)); + end Set_Range; + + + function Get_Step + (This : in Spinner) + return Long_Float is + begin + return Long_Float (fl_spinner_get_step (This.Void_Ptr)); + end Get_Step; + + + procedure Set_Step + (This : in out Spinner; + To : in Long_Float) is + begin + fl_spinner_set_step (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Step; + + + function Get_Value + (This : in Spinner) + return Long_Float is + begin + return Long_Float (fl_spinner_get_value (This.Void_Ptr)); + end Get_Value; + + + procedure Set_Value + (This : in out Spinner; + To : in Long_Float) is + begin + fl_spinner_set_value (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Value; + + + + + -- Formatting -- + + function Get_Format + (This : in Spinner) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_spinner_get_format (This.Void_Ptr); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Format; + + + procedure Set_Format + (This : in out Spinner; + To : in String) is + begin + Interfaces.C.Strings.Free (This.Format_Str); + This.Format_Str := Interfaces.C.Strings.New_String (To); + fl_spinner_set_format (This.Void_Ptr, This.Format_Str); + end Set_Format; + + + function Get_Kind + (This : in Spinner) + return Spinner_Kind + is + Result : constant Interfaces.C.unsigned_char := fl_spinner_get_type (This.Void_Ptr); + begin + return Spinner_Kind'Val (Result - 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Spinner::type returned unexpected unsigned char value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Kind; + + + procedure Set_Kind + (This : in out Spinner; + To : in Spinner_Kind) is + begin + fl_spinner_set_type (This.Void_Ptr, Spinner_Kind'Pos (To) + 1); + end Set_Kind; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Spinner; + X, Y, W, H : in Integer) is + begin + fl_spinner_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Events -- + + function Handle + (This : in out Spinner; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Spinners; + + diff --git a/body/fltk-widgets-groups-tabbed.adb b/body/fltk-widgets-groups-tabbed.adb new file mode 100644 index 0000000..28c4c04 --- /dev/null +++ b/body/fltk-widgets-groups-tabbed.adb @@ -0,0 +1,319 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C; + + +package body FLTK.Widgets.Groups.Tabbed is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_tabs + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_tabs, "new_fl_tabs"); + pragma Inline (new_fl_tabs); + + procedure free_fl_tabs + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_tabs, "free_fl_tabs"); + pragma Inline (free_fl_tabs); + + + + + -- Child Area -- + + procedure fl_tabs_client_area + (T : in Storage.Integer_Address; + X, Y, W, H : out Interfaces.C.int; + I : in Interfaces.C.int); + pragma Import (C, fl_tabs_client_area, "fl_tabs_client_area"); + pragma Inline (fl_tabs_client_area); + + + + + -- Operation -- + + function fl_tabs_get_push + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_tabs_get_push, "fl_tabs_get_push"); + pragma Inline (fl_tabs_get_push); + + procedure fl_tabs_set_push + (T, I : in Storage.Integer_Address); + pragma Import (C, fl_tabs_set_push, "fl_tabs_set_push"); + pragma Inline (fl_tabs_set_push); + + function fl_tabs_get_value + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_tabs_get_value, "fl_tabs_get_value"); + pragma Inline (fl_tabs_get_value); + + procedure fl_tabs_set_value + (T, V : in Storage.Integer_Address); + pragma Import (C, fl_tabs_set_value, "fl_tabs_set_value"); + pragma Inline (fl_tabs_set_value); + + function fl_tabs_which + (T : in Storage.Integer_Address; + X, Y : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_tabs_which, "fl_tabs_which"); + pragma Inline (fl_tabs_which); + + + + + -- Drawing, Events -- + + procedure fl_tabs_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_tabs_draw, "fl_tabs_draw"); + pragma Inline (fl_tabs_draw); + + procedure fl_tabs_redraw_tabs + (T : in Storage.Integer_Address); + pragma Import (C, fl_tabs_redraw_tabs, "fl_tabs_redraw_tabs"); + pragma Inline (fl_tabs_redraw_tabs); + + function fl_tabs_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_tabs_handle, "fl_tabs_handle"); + pragma Inline (fl_tabs_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Tabbed_Group) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Tabbed_Group) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_tabs (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Tabbed_Group; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Tabbed_Group) is + begin + This.Draw_Ptr := fl_tabs_draw'Address; + This.Handle_Ptr := fl_tabs_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Tabbed_Group is + begin + return This : Tabbed_Group do + This.Void_Ptr := new_fl_tabs + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Tabbed_Group is + begin + return This : Tabbed_Group := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Child Area -- + + procedure Get_Client_Area + (This : in Tabbed_Group; + Tab_Height : in Natural; + X, Y, W, H : out Integer) is + begin + fl_tabs_client_area + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Tab_Height)); + end Get_Client_Area; + + + + + -- Operation -- + + function Get_Push + (This : in Tabbed_Group) + return access Widget'Class + is + Push_Ptr : Storage.Integer_Address := fl_tabs_get_push (This.Void_Ptr); + Actual_Widget : access Widget'Class; + begin + if Push_Ptr /= Null_Pointer then + Push_Ptr := fl_widget_get_user_data (Push_Ptr); + pragma Assert (Push_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Push_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Tabs::push returned Widget with no user_data reference back to Ada"; + end Get_Push; + + + procedure Set_Push + (This : in out Tabbed_Group; + Item : in out Widget'Class) is + begin + fl_tabs_set_push (This.Void_Ptr, Item.Void_Ptr); + end Set_Push; + + + function Get_Visible + (This : in Tabbed_Group) + return access Widget'Class + is + Visible_Ptr : Storage.Integer_Address := fl_tabs_get_value (This.Void_Ptr); + Actual_Widget : access Widget'Class; + begin + if Visible_Ptr /= Null_Pointer then + Visible_Ptr := fl_widget_get_user_data (Visible_Ptr); + pragma Assert (Visible_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Visible_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Tabs::value returned Widget with no user_data reference back to Ada"; + end Get_Visible; + + + procedure Set_Visible + (This : in out Tabbed_Group; + Item : in out Widget'Class) is + begin + fl_tabs_set_value (This.Void_Ptr, Item.Void_Ptr); + end Set_Visible; + + + function Get_Which + (This : in Tabbed_Group; + Event_X, Event_Y : in Integer) + return access Widget'Class + is + Which_Ptr : Storage.Integer_Address := + fl_tabs_which (This.Void_Ptr, Interfaces.C.int (Event_X), Interfaces.C.int (Event_Y)); + Actual_Widget : access Widget'Class; + begin + if Which_Ptr /= Null_Pointer then + Which_Ptr := fl_widget_get_user_data (Which_Ptr); + pragma Assert (Which_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Which_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Tabs::which returned Widget with no user_data reference back to Ada"; + end Get_Which; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Tabbed_Group) is + begin + Group (This).Draw; + end Draw; + + + procedure Redraw_Tabs + (This : in out Tabbed_Group) is + begin + fl_tabs_redraw_tabs (This.Void_Ptr); + end Redraw_Tabs; + + + function Handle + (This : in out Tabbed_Group; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Tabbed; + + diff --git a/body/fltk-widgets-groups-tables-row.adb b/body/fltk-widgets-groups-tables-row.adb new file mode 100644 index 0000000..0a7250a --- /dev/null +++ b/body/fltk-widgets-groups-tables-row.adb @@ -0,0 +1,392 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Tables.Row is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_table_row + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_table_row, "new_fl_table_row"); + pragma Inline (new_fl_table_row); + + procedure free_fl_table_row + (T : in Storage.Integer_Address); + pragma Import (C, free_fl_table_row, "free_fl_table_row"); + pragma Inline (free_fl_table_row); + + + + + -- Rows -- + + function fl_table_row_get_rows + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_row_get_rows, "fl_table_row_get_rows"); + pragma Inline (fl_table_row_get_rows); + + procedure fl_table_row_set_rows + (T : in Storage.Integer_Address; + R : in Interfaces.C.int); + pragma Import (C, fl_table_row_set_rows, "fl_table_row_set_rows"); + pragma Inline (fl_table_row_set_rows); + + + + + -- Selection -- + + function fl_table_row_row_selected + (T : in Storage.Integer_Address; + R : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_row_row_selected, "fl_table_row_row_selected"); + pragma Inline (fl_table_row_row_selected); + + function fl_table_row_select_row + (T : in Storage.Integer_Address; + R, F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_row_select_row, "fl_table_row_select_row"); + pragma Inline (fl_table_row_select_row); + + procedure fl_table_row_select_all_rows + (T : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_table_row_select_all_rows, "fl_table_row_select_all_rows"); + pragma Inline (fl_table_row_select_all_rows); + + function fl_table_row_get_type + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_row_get_type, "fl_table_row_get_type"); + pragma Inline (fl_table_row_get_type); + + procedure fl_table_row_set_type + (T : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_table_row_set_type, "fl_table_row_set_type"); + pragma Inline (fl_table_row_set_type); + + + + + -- Drawing, Events -- + + procedure fl_table_row_draw + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_row_draw, "fl_table_row_draw"); + pragma Inline (fl_table_row_draw); + + procedure fl_table_row_draw_cell + (T : in Storage.Integer_Address; + E, R, C, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_table_row_draw_cell, "fl_table_row_draw_cell"); + pragma Inline (fl_table_row_draw_cell); + + function fl_table_row_find_cell + (T : in Storage.Integer_Address; + E, R, C : in Interfaces.C.int; + X, Y, W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_row_find_cell, "fl_table_row_find_cell"); + pragma Inline (fl_table_row_find_cell); + + function fl_table_row_handle + (T : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_row_handle, "fl_table_row_handle"); + pragma Inline (fl_table_row_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Row_Table) is + begin + Extra_Final (Table (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Row_Table) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_table_row (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Row_Table; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Table (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Row_Table) is + begin + This.Draw_Ptr := fl_table_row_draw'Address; + This.Handle_Ptr := fl_table_row_handle'Address; + This.Draw_Cell_Ptr := fl_table_row_draw_cell'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Row_Table is + begin + return This : Row_Table do + This.Void_Ptr := new_fl_table_row + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Row_Table is + begin + return This : Row_Table := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Contents Modification -- + + procedure Clear + (This : in out Row_Table) is + begin + This.Set_Rows (0); -- Set_Rows is reimplemented. + This.Set_Columns (0); + This.Playing_Area.Clear; + end Clear; + + + + + -- Rows -- + + function Get_Rows + (This : in Row_Table) + return Natural + is + Result : constant Interfaces.C.int := fl_table_row_get_rows (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::rows returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Rows; + + + procedure Set_Rows + (This : in out Row_Table; + Value : in Natural) is + begin + fl_table_row_set_rows (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Rows; + + + + + -- Selection -- + + function Is_Row_Selected + (This : in Row_Table; + Row : in Positive) + return Boolean + is + Result : constant Interfaces.C.int := fl_table_row_row_selected + (This.Void_Ptr, Interfaces.C.int (Row) - 1); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table_Row::row_selected returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Row_Selected; + + + procedure Select_Row + (This : in out Row_Table; + Row : in Positive; + Value : in Selection_State := Selected) + is + Result : constant Interfaces.C.int := fl_table_row_select_row + (This.Void_Ptr, + Interfaces.C.int (Row) - 1, + Selection_State'Pos (Value)); + begin + if Result = -1 then + raise Range_Error with "Row = " & Positive'Image (Row); + else + pragma Assert (Result in 0 .. 1); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table_Row::select_row returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Select_Row; + + + function Select_Row + (This : in out Row_Table; + Row : in Positive; + Value : in Selection_State := Selected) + return Boolean + is + Result : constant Interfaces.C.int := fl_table_row_select_row + (This.Void_Ptr, + Interfaces.C.int (Row) - 1, + Selection_State'Pos (Value)); + begin + if Result = -1 then + raise Range_Error with "Row = " & Positive'Image (Row); + else + return Boolean'Val (Result); + end if; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table_Row::select_row returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Select_Row; + + + procedure Select_All_Rows + (This : in out Row_Table; + Value : in Selection_State := Selected) is + begin + fl_table_row_select_all_rows (This.Void_Ptr, Selection_State'Pos (Value)); + end Select_All_Rows; + + + function Get_Row_Select_Mode + (This : in Row_Table) + return Row_Select_Mode + is + Result : constant Interfaces.C.int := fl_table_row_get_type (This.Void_Ptr); + begin + return Row_Select_Mode'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table_Row::type returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Row_Select_Mode; + + + procedure Set_Row_Select_Mode + (This : in out Row_Table; + Value : in Row_Select_Mode) is + begin + fl_table_row_set_type (This.Void_Ptr, Row_Select_Mode'Pos (Value)); + end Set_Row_Select_Mode; + + + + + -- Drawing, Events -- + + procedure Cell_Dimensions + (This : in Row_Table; + Context : in Table_Context; + Row, Column : in Positive; + X, Y, W, H : out Integer) + is + Result : constant Interfaces.C.int := fl_table_row_find_cell + (This.Void_Ptr, + To_Cint (Context), + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Column) - 1, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + begin + if Result = -1 then + raise Range_Error with + "Row = " & Integer'Image (Row) & ", Column = " & Integer'Image (Column); + else + pragma Assert (Result = 0); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table_Row::find_cell returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Cell_Dimensions; + + + function Handle + (This : in out Row_Table; + Event : in Event_Kind) + return Event_Outcome is + begin + return Table (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Tables.Row; + + diff --git a/body/fltk-widgets-groups-tables.adb b/body/fltk-widgets-groups-tables.adb new file mode 100644 index 0000000..8417cd6 --- /dev/null +++ b/body/fltk-widgets-groups-tables.adb @@ -0,0 +1,2003 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Characters.Latin_1, + Interfaces.C, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Tables is + + + package Chk renames Ada.Assertions; + package Latin renames Ada.Characters.Latin_1; + + + + + ------------------------ + -- Constants From C -- + ------------------------ + + fl_context_none : constant Interfaces.C.int; + pragma Import (C, fl_context_none, "fl_context_none"); + + fl_context_startpage : constant Interfaces.C.int; + pragma Import (C, fl_context_startpage, "fl_context_startpage"); + + fl_context_endpage : constant Interfaces.C.int; + pragma Import (C, fl_context_endpage, "fl_context_endpage"); + + fl_context_row_header : constant Interfaces.C.int; + pragma Import (C, fl_context_row_header, "fl_context_row_header"); + + fl_context_col_header : constant Interfaces.C.int; + pragma Import (C, fl_context_col_header, "fl_context_col_header"); + + fl_context_cell : constant Interfaces.C.int; + pragma Import (C, fl_context_cell, "fl_context_cell"); + + fl_context_table : constant Interfaces.C.int; + pragma Import (C, fl_context_table, "fl_context_table"); + + fl_context_rc_resize : constant Interfaces.C.int; + pragma Import (C, fl_context_rc_resize, "fl_context_rc_resize"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_table + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_table, "new_fl_table"); + pragma Inline (new_fl_table); + + procedure free_fl_table + (T : in Storage.Integer_Address); + pragma Import (C, free_fl_table, "free_fl_table"); + pragma Inline (free_fl_table); + + + + + -- Attributes -- + + function fl_table_hscrollbar + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_table_hscrollbar, "fl_table_hscrollbar"); + pragma Inline (fl_table_hscrollbar); + + function fl_table_vscrollbar + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_table_vscrollbar, "fl_table_vscrollbar"); + pragma Inline (fl_table_vscrollbar); + + function fl_table_table + (T : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_table_table, "fl_table_table"); + pragma Inline (fl_table_table); + + + + + -- Contents Modification -- + + procedure fl_table_add + (T, W : in Storage.Integer_Address); + pragma Import (C, fl_table_add, "fl_table_add"); + pragma Inline (fl_table_add); + + procedure fl_table_insert + (T, W : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_table_insert, "fl_table_insert"); + pragma Inline (fl_table_insert); + + procedure fl_table_insert2 + (T, W, B : in Storage.Integer_Address); + pragma Import (C, fl_table_insert2, "fl_table_insert2"); + pragma Inline (fl_table_insert2); + + procedure fl_table_remove + (T, W : in Storage.Integer_Address); + pragma Import (C, fl_table_remove, "fl_table_remove"); + pragma Inline (fl_table_remove); + + + + + -- Contents Query -- + + function fl_table_child + (T : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_table_child, "fl_table_child"); + pragma Inline (fl_table_child); + + function fl_table_find + (T, W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_find, "fl_table_find"); + pragma Inline (fl_table_find); + + function fl_table_children + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_children, "fl_table_children"); + pragma Inline (fl_table_children); + + function fl_table_is_fltk_container + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_is_fltk_container, "fl_table_is_fltk_container"); + pragma Inline (fl_table_is_fltk_container); + + + + + -- Current -- + + procedure fl_table_begin + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_begin, "fl_table_begin"); + pragma Inline (fl_table_begin); + + procedure fl_table_end + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_end, "fl_table_end"); + pragma Inline (fl_table_end); + + + + + -- Callbacks -- + + procedure fl_table_set_callback + (T, F : in Storage.Integer_Address); + pragma Import (C, fl_table_set_callback, "fl_table_set_callback"); + pragma Inline (fl_table_set_callback); + + function fl_table_callback_col + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_callback_col, "fl_table_callback_col"); + pragma Inline (fl_table_callback_col); + + function fl_table_callback_row + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_callback_row, "fl_table_callback_row"); + pragma Inline (fl_table_callback_row); + + function fl_table_callback_context + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_callback_context, "fl_table_callback_context"); + pragma Inline (fl_table_callback_context); + + procedure fl_table_do_callback + (T : in Storage.Integer_Address; + X, R, C : in Interfaces.C.int); + pragma Import (C, fl_table_do_callback, "fl_table_do_callback"); + pragma Inline (fl_table_do_callback); + + procedure fl_table_when + (T : in Storage.Integer_Address; + W : in Interfaces.C.unsigned_char); + pragma Import (C, fl_table_when, "fl_table_when"); + pragma Inline (fl_table_when); + + procedure fl_table_scroll_cb + (S, T : in Storage.Integer_Address); + pragma Import (C, fl_table_scroll_cb, "fl_table_scroll_cb"); + pragma Inline (fl_table_scroll_cb); + + + + + -- Columns -- + + function fl_table_get_col_header + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_col_header, "fl_table_get_col_header"); + pragma Inline (fl_table_get_col_header); + + procedure fl_table_set_col_header + (T : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_table_set_col_header, "fl_table_set_col_header"); + pragma Inline (fl_table_set_col_header); + + function fl_table_get_col_header_color + (T : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_table_get_col_header_color, "fl_table_get_col_header_color"); + pragma Inline (fl_table_get_col_header_color); + + procedure fl_table_set_col_header_color + (T : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_table_set_col_header_color, "fl_table_set_col_header_color"); + pragma Inline (fl_table_set_col_header_color); + + function fl_table_get_col_header_height + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_col_header_height, "fl_table_get_col_header_height"); + pragma Inline (fl_table_get_col_header_height); + + procedure fl_table_set_col_header_height + (T : in Storage.Integer_Address; + H : in Interfaces.C.int); + pragma Import (C, fl_table_set_col_header_height, "fl_table_set_col_header_height"); + pragma Inline (fl_table_set_col_header_height); + + function fl_table_get_col_width + (T : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_get_col_width, "fl_table_get_col_width"); + pragma Inline (fl_table_get_col_width); + + procedure fl_table_set_col_width + (T : in Storage.Integer_Address; + C, W : in Interfaces.C.int); + pragma Import (C, fl_table_set_col_width, "fl_table_set_col_width"); + pragma Inline (fl_table_set_col_width); + + procedure fl_table_col_width_all + (T : in Storage.Integer_Address; + W : in Interfaces.C.int); + pragma Import (C, fl_table_col_width_all, "fl_table_col_width_all"); + pragma Inline (fl_table_col_width_all); + + function fl_table_get_cols + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_cols, "fl_table_get_cols"); + pragma Inline (fl_table_get_cols); + + procedure fl_table_set_cols + (T : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_table_set_cols, "fl_table_set_cols"); + pragma Inline (fl_table_set_cols); + + function fl_table_get_col_position + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_col_position, "fl_table_get_col_position"); + pragma Inline (fl_table_get_col_position); + + procedure fl_table_set_col_position + (T : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_table_set_col_position, "fl_table_set_col_position"); + pragma Inline (fl_table_set_col_position); + + function fl_table_col_scroll_position + (T : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.long; + pragma Import (C, fl_table_col_scroll_position, "fl_table_col_scroll_position"); + pragma Inline (fl_table_col_scroll_position); + + function fl_table_get_col_resize + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_col_resize, "fl_table_get_col_resize"); + pragma Inline (fl_table_get_col_resize); + + procedure fl_table_set_col_resize + (T : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_table_set_col_resize, "fl_table_set_col_resize"); + pragma Inline (fl_table_set_col_resize); + + function fl_table_get_col_resize_min + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_col_resize_min, "fl_table_get_col_resize_min"); + pragma Inline (fl_table_get_col_resize_min); + + procedure fl_table_set_col_resize_min + (T : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_table_set_col_resize_min, "fl_table_set_col_resize_min"); + pragma Inline (fl_table_set_col_resize_min); + + + + + -- Rows -- + + function fl_table_get_row_header + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_row_header, "fl_table_get_row_header"); + pragma Inline (fl_table_get_row_header); + + procedure fl_table_set_row_header + (T : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_table_set_row_header, "fl_table_set_row_header"); + pragma Inline (fl_table_set_row_header); + + function fl_table_get_row_header_color + (T : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_table_get_row_header_color, "fl_table_get_row_header_color"); + pragma Inline (fl_table_get_row_header_color); + + procedure fl_table_set_row_header_color + (T : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_table_set_row_header_color, "fl_table_set_row_header_color"); + pragma Inline (fl_table_set_row_header_color); + + function fl_table_get_row_header_width + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_row_header_width, "fl_table_get_row_header_width"); + pragma Inline (fl_table_get_row_header_width); + + procedure fl_table_set_row_header_width + (T : in Storage.Integer_Address; + W : in Interfaces.C.int); + pragma Import (C, fl_table_set_row_header_width, "fl_table_set_row_header_width"); + pragma Inline (fl_table_set_row_header_width); + + function fl_table_get_row_height + (T : in Storage.Integer_Address; + R : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_get_row_height, "fl_table_get_row_height"); + pragma Inline (fl_table_get_row_height); + + procedure fl_table_set_row_height + (T : in Storage.Integer_Address; + R, H : in Interfaces.C.int); + pragma Import (C, fl_table_set_row_height, "fl_table_set_row_height"); + pragma Inline (fl_table_set_row_height); + + procedure fl_table_row_height_all + (T : in Storage.Integer_Address; + H : in Interfaces.C.int); + pragma Import (C, fl_table_row_height_all, "fl_table_row_height_all"); + pragma Inline (fl_table_row_height_all); + + function fl_table_get_rows + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_rows, "fl_table_get_rows"); + pragma Inline (fl_table_get_rows); + + procedure fl_table_set_rows + (T : in Storage.Integer_Address; + R : in Interfaces.C.int); + pragma Import (C, fl_table_set_rows, "fl_table_set_rows"); + pragma Inline (fl_table_set_rows); + + function fl_table_get_row_position + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_row_position, "fl_table_get_row_position"); + pragma Inline (fl_table_get_row_position); + + procedure fl_table_set_row_position + (T : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_table_set_row_position, "fl_table_set_row_position"); + pragma Inline (fl_table_set_row_position); + + function fl_table_row_scroll_position + (T : in Storage.Integer_Address; + R : in Interfaces.C.int) + return Interfaces.C.long; + pragma Import (C, fl_table_row_scroll_position, "fl_table_row_scroll_position"); + pragma Inline (fl_table_row_scroll_position); + + function fl_table_get_row_resize + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_row_resize, "fl_table_get_row_resize"); + pragma Inline (fl_table_get_row_resize); + + procedure fl_table_set_row_resize + (T : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_table_set_row_resize, "fl_table_set_row_resize"); + pragma Inline (fl_table_set_row_resize); + + function fl_table_get_row_resize_min + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_row_resize_min, "fl_table_get_row_resize_min"); + pragma Inline (fl_table_get_row_resize_min); + + procedure fl_table_set_row_resize_min + (T : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_table_set_row_resize_min, "fl_table_set_row_resize_min"); + pragma Inline (fl_table_set_row_resize_min); + + function fl_table_get_top_row + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_top_row, "fl_table_get_top_row"); + pragma Inline (fl_table_get_top_row); + + procedure fl_table_set_top_row + (T : in Storage.Integer_Address; + R : in Interfaces.C.int); + pragma Import (C, fl_table_set_top_row, "fl_table_set_top_row"); + pragma Inline (fl_table_set_top_row); + + + + + -- Selection -- + + procedure fl_table_change_cursor + (T : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_table_change_cursor, "fl_table_change_cursor"); + pragma Inline (fl_table_change_cursor); + + function fl_table_cursor2rowcol + (T : in Storage.Integer_Address; + R, C, F : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_cursor2rowcol, "fl_table_cursor2rowcol"); + pragma Inline (fl_table_cursor2rowcol); + + procedure fl_table_visible_cells + (T : in Storage.Integer_Address; + R1, R2, C1, C2 : out Interfaces.C.int); + pragma Import (C, fl_table_visible_cells, "fl_table_visible_cells"); + pragma Inline (fl_table_visible_cells); + + procedure fl_table_get_selection + (T : in Storage.Integer_Address; + RT, CL, RB, CR : out Interfaces.C.int); + pragma Import (C, fl_table_get_selection, "fl_table_get_selection"); + pragma Inline (fl_table_get_selection); + + procedure fl_table_set_selection + (T : in Storage.Integer_Address; + RT, CL, RB, CR : in Interfaces.C.int); + pragma Import (C, fl_table_set_selection, "fl_table_set_selection"); + pragma Inline (fl_table_set_selection); + + function fl_table_is_selected + (T : in Storage.Integer_Address; + R, C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_is_selected, "fl_table_is_selected"); + pragma Inline (fl_table_is_selected); + + function fl_table_move_cursor + (T : in Storage.Integer_Address; + R, C, S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_move_cursor, "fl_table_move_cursor"); + pragma Inline (fl_table_move_cursor); + + function fl_table_get_tab_cell_nav + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_tab_cell_nav, "fl_table_get_tab_cell_nav"); + pragma Inline (fl_table_get_tab_cell_nav); + + procedure fl_table_set_tab_cell_nav + (T : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_table_set_tab_cell_nav, "fl_table_set_tab_cell_nav"); + pragma Inline (fl_table_set_tab_cell_nav); + + function fl_table_get_table_box + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_table_box, "fl_table_get_table_box"); + pragma Inline (fl_table_get_table_box); + + procedure fl_table_set_table_box + (T : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_table_set_table_box, "fl_table_set_table_box"); + pragma Inline (fl_table_set_table_box); + + + + + -- Dimensions -- + + function fl_table_get_scrollbar_size + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_get_scrollbar_size, "fl_table_get_scrollbar_size"); + pragma Inline (fl_table_get_scrollbar_size); + + procedure fl_table_set_scrollbar_size + (T : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_table_set_scrollbar_size, "fl_table_set_scrollbar_size"); + pragma Inline (fl_table_set_scrollbar_size); + + procedure fl_table_resize + (T : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_table_resize, "fl_table_resize"); + pragma Inline (fl_table_resize); + + function fl_table_is_interactive_resize + (T : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_table_is_interactive_resize, "fl_table_is_interactive_resize"); + pragma Inline (fl_table_is_interactive_resize); + + procedure fl_table_init_sizes + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_init_sizes, "fl_table_init_sizes"); + pragma Inline (fl_table_init_sizes); + + procedure fl_table_recalc_dimensions + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_recalc_dimensions, "fl_table_recalc_dimensions"); + pragma Inline (fl_table_recalc_dimensions); + + procedure fl_table_table_resized + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_table_resized, "fl_table_table_resized"); + pragma Inline (fl_table_table_resized); + + procedure fl_table_table_scrolled + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_table_scrolled, "fl_table_table_scrolled"); + pragma Inline (fl_table_table_scrolled); + + + + + -- Drawing, Events -- + + procedure fl_table_draw + (T : in Storage.Integer_Address); + pragma Import (C, fl_table_draw, "fl_table_draw"); + pragma Inline (fl_table_draw); + + procedure fl_table_draw_cell + (T : in Storage.Integer_Address; + E, R, C, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_table_draw_cell, "fl_table_draw_cell"); + pragma Inline (fl_table_draw_cell); + + procedure fl_table_redraw_range + (T : in Storage.Integer_Address; + RT, RB, CL, CR : in Interfaces.C.int); + pragma Import (C, fl_table_redraw_range, "fl_table_redraw_range"); + pragma Inline (fl_table_redraw_range); + + procedure fl_table_damage_zone + (T : in Storage.Integer_Address; + RT, CL, RB, CR, RR, RC : in Interfaces.C.int); + pragma Import (C, fl_table_damage_zone, "fl_table_damage_zone"); + pragma Inline (fl_table_damage_zone); + + function fl_table_find_cell + (T : in Storage.Integer_Address; + E, R, C : in Interfaces.C.int; + X, Y, W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_find_cell, "fl_table_find_cell"); + pragma Inline (fl_table_find_cell); + + procedure fl_table_get_bounds + (T : in Storage.Integer_Address; + E : in Interfaces.C.int; + X, Y, W, H : out Interfaces.C.int); + pragma Import (C, fl_table_get_bounds, "fl_table_get_bounds"); + pragma Inline (fl_table_get_bounds); + + function fl_table_row_col_clamp + (T : in Storage.Integer_Address; + E : in Interfaces.C.int; + R, C : in out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_row_col_clamp, "fl_table_row_col_clamp"); + pragma Inline (fl_table_row_col_clamp); + + function fl_table_handle + (T : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_table_handle, "fl_table_handle"); + pragma Inline (fl_table_handle); + + + + + ------------------------ + -- Internal Utility -- + ------------------------ + + function To_Cint + (Context : in Table_Context) + return Interfaces.C.int is + begin + case Context is + when No_Context => return fl_context_none; + when Start_Page => return fl_context_startpage; + when End_Page => return fl_context_endpage; + when Row_Header => return fl_context_row_header; + when Column_Header => return fl_context_col_header; + when Within_Cell => return fl_context_cell; + when Dead_Zone => return fl_context_table; + when Row_Column_Resize => return fl_context_rc_resize; + end case; + end To_Cint; + + + function To_Context + (Value : in Interfaces.C.int) + return Table_Context is + begin + if Value = fl_context_none then + return No_Context; + elsif Value = fl_context_startpage then + return Start_Page; + elsif Value = fl_context_endpage then + return End_Page; + elsif Value = fl_context_row_header then + return Row_Header; + elsif Value = fl_context_col_header then + return Column_Header; + elsif Value = fl_context_cell then + return Within_Cell; + elsif Value = fl_context_table then + return Dead_Zone; + elsif Value = fl_context_rc_resize then + return Row_Column_Resize; + else + raise Constraint_Error; + end if; + end To_Context; + + + + + ---------------------- + -- Exported Hooks -- + ---------------------- + + package Table_Convert is new System.Address_To_Access_Conversions (Table'Class); + + procedure Table_Draw_Cell_Hook + (UD : in Storage.Integer_Address; + E, R, C, X, Y, W, H : in Interfaces.C.int); + pragma Export (C, Table_Draw_Cell_Hook, "table_draw_cell_hook"); + + procedure Table_Draw_Cell_Hook + (UD : in Storage.Integer_Address; + E, R, C, X, Y, W, H : in Interfaces.C.int) + is + Ada_Table : access Table'Class; + Context : Table_Context; + Row, Column : Natural; + begin + pragma Assert (UD /= Null_Pointer); + Ada_Table := Table_Convert.To_Pointer (Storage.To_Address (UD)); + Context := To_Context (E); + case Context is + when Row_Header => + Row := Positive (R + 1); + Column := Natural (C); + when Column_Header => + Row := Natural (R); + Column := Positive (C + 1); + when Within_Cell => + Row := Positive (R + 1); + Column := Positive (C + 1); + when others => + Row := Natural (R); + Column := Natural (C); + end case; + Ada_Table.Draw_Cell + (Context, Row, Column, + Integer (X), Integer (Y), Integer (W), Integer (H)); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "User data null pointer passed to Fl_Table::draw_cell override hook"; + when Constraint_Error => raise Internal_FLTK_Error with + "Unexpected int values passed to Fl_Table::draw_cell override hook of" & Latin.LF & + Latin.HT & "row = " & Interfaces.C.int'Image (R) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C); + end Table_Draw_Cell_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Table) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Table) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_table (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Engage silent drive! + procedure fl_scrollbar_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_scrollbar_extra_init, "fl_scrollbar_extra_init"); + pragma Inline (fl_scrollbar_extra_init); + + + -- Conducting Penrose experiment + procedure fl_scroll_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_scroll_extra_init, "fl_scroll_extra_init"); + pragma Inline (fl_scroll_extra_init); + + + procedure Extra_Init + (This : in out Table; + X, Y, W, H : in Integer; + Text : in String) is + begin + Widget (This.Horizon).Void_Ptr := fl_table_hscrollbar (This.Void_Ptr); + Widget (This.Horizon).Needs_Dealloc := False; + fl_scrollbar_extra_init + (Storage.To_Integer (This.Horizon'Address), + Interfaces.C.int (This.Horizon.Get_X), + Interfaces.C.int (This.Horizon.Get_Y), + Interfaces.C.int (This.Horizon.Get_W), + Interfaces.C.int (This.Horizon.Get_H), + Interfaces.C.To_C (This.Horizon.Get_Label)); + This.Horizon.Set_Callback (Scroll_Callback'Access); + + Widget (This.Vertigo).Void_Ptr := fl_table_vscrollbar (This.Void_Ptr); + Widget (This.Vertigo).Needs_Dealloc := False; + fl_scrollbar_extra_init + (Storage.To_Integer (This.Vertigo'Address), + Interfaces.C.int (This.Vertigo.Get_X), + Interfaces.C.int (This.Vertigo.Get_Y), + Interfaces.C.int (This.Vertigo.Get_W), + Interfaces.C.int (This.Vertigo.Get_H), + Interfaces.C.To_C (This.Vertigo.Get_Label)); + This.Vertigo.Set_Callback (Scroll_Callback'Access); + + Widget (This.Playing_Area).Void_Ptr := fl_table_table (This.Void_Ptr); + Widget (This.Playing_Area).Needs_Dealloc := False; + fl_scroll_extra_init + (Storage.To_Integer (This.Playing_Area'Address), + Interfaces.C.int (This.Playing_Area.Get_X), + Interfaces.C.int (This.Playing_Area.Get_Y), + Interfaces.C.int (This.Playing_Area.Get_W), + Interfaces.C.int (This.Playing_Area.Get_H), + Interfaces.C.To_C (This.Playing_Area.Get_Label)); + + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Table) is + begin + This.Draw_Ptr := fl_table_draw'Address; + This.Handle_Ptr := fl_table_handle'Address; + This.Draw_Cell_Ptr := fl_table_draw_cell'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Table is + begin + return This : Table do + This.Void_Ptr := new_fl_table + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Table is + begin + return This : Table := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + + function H_Bar + (This : in out Table) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Horizon'Unchecked_Access); + end H_Bar; + + + function V_Bar + (This : in out Table) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference is + begin + return (Data => This.Vertigo'Unchecked_Access); + end V_Bar; + + + function Scroll_Area + (This : in out Table) + return Scrolls.Scroll_Reference is + begin + return (Data => This.Playing_Area'Unchecked_Access); + end Scroll_Area; + + + + + -- Contents Modification -- + + procedure Add + (This : in out Table; + Item : in out Widget'Class) is + begin + fl_table_add (This.Void_Ptr, Item.Void_Ptr); + end Add; + + + procedure Insert + (This : in out Table; + Item : in out Widget'Class; + Place : in Index) is + begin + fl_table_insert + (This.Void_Ptr, + Item.Void_Ptr, + Interfaces.C.int (Place) - 1); + end Insert; + + + procedure Insert + (This : in out Table; + Item : in out Widget'Class; + Before : in Widget'Class) is + begin + fl_table_insert2 + (This.Void_Ptr, + Item.Void_Ptr, + Before.Void_Ptr); + end Insert; + + + procedure Remove + (This : in out Table; + Item : in out Widget'Class) is + begin + fl_table_remove (This.Void_Ptr, Item.Void_Ptr); + end Remove; + + + procedure Clear + (This : in out Table) is + begin + This.Set_Rows (0); + This.Set_Columns (0); + This.Playing_Area.Clear; + end Clear; + + + + + -- Contents Query -- + + function Has_Child + (This : in Table; + Place : in Index) + return Boolean is + begin + return Place in 1 .. This.Number_Of_Children; + end Has_Child; + + + function Has_Child + (Place : in Cursor) + return Boolean is + begin + return Place.My_Container.Has_Child (Place.My_Index); + end Has_Child; + + + function Child + (This : in Table; + Place : in Index) + return Widget_Reference + is + Widget_Ptr : Storage.Integer_Address := + fl_table_child (This.Void_Ptr, Interfaces.C.int (Place) - 1); + Actual_Widget : access Widget'Class; + begin + Widget_Ptr := fl_widget_get_user_data (Widget_Ptr); + pragma Assert (Widget_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); + return (Data => Actual_Widget); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table::child returned a widget with no user data reference back to Ada"; + end Child; + + + function Child + (This : in Table; + Place : in Cursor) + return Widget_Reference is + begin + return This.Child (Place.My_Index); + end Child; + + + function Find + (This : in Table; + Item : in Widget'Class) + return Extended_Index + is + Result : constant Interfaces.C.int := fl_table_find (This.Void_Ptr, Item.Void_Ptr); + begin + if Result = fl_table_children (This.Void_Ptr) then + return No_Index; + end if; + return Extended_Index (Result + 1); + end Find; + + + function Number_Of_Children + (This : in Table) + return Natural is + begin + return Natural (fl_table_children (This.Void_Ptr)); + end Number_Of_Children; + + + function Used_As_Container + (This : in Table) + return Boolean is + begin + return fl_table_is_fltk_container (This.Void_Ptr) /= 0; + end Used_As_Container; + + + + + -- Current -- + + procedure Begin_Current + (This : in out Table) is + begin + fl_table_begin (This.Void_Ptr); + end Begin_Current; + + + procedure End_Current + (This : in out Table) is + begin + fl_table_end (This.Void_Ptr); + end End_Current; + + + + + -- Callbacks -- + + procedure Set_Callback + (This : in out Table; + Func : in Widget_Callback) is + begin + if Func /= null then + This.Callback := Func; + fl_table_set_callback (This.Void_Ptr, Storage.To_Integer (Callback_Hook'Address)); + end if; + end Set_Callback; + + + function Callback_Column + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_callback_col (This.Void_Ptr); + begin + return Positive (Result + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::callback_col returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Callback_Column; + + + function Callback_Row + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_callback_row (This.Void_Ptr); + begin + return Positive (Result + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::callback_row returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Callback_Row; + + + function Callback_Context + (This : in Table) + return Table_Context + is + Result : constant Interfaces.C.int := fl_table_callback_context (This.Void_Ptr); + begin + return To_Context (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::callback_context returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Callback_Context; + + + procedure Do_Callback + (This : in out Table; + Context : in Table_Context; + Row, Column : in Positive) is + begin + fl_table_do_callback + (This.Void_Ptr, + To_Cint (Context), + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Column) - 1); + end Do_Callback; + + + procedure Set_When + (This : in out Table; + Value : in Callback_Flag) is + begin + fl_table_when (This.Void_Ptr, Flag_To_UChar (Value)); + end Set_When; + + + procedure Scroll_Callback + (Item : in out Widget'Class) is + begin + fl_table_scroll_cb (Item.Void_Ptr, Item.Parent.Void_Ptr); + end Scroll_Callback; + + + + + -- Columns -- + + function Column_Headers_Enabled + (This : in Table) + return Boolean is + begin + return fl_table_get_col_header (This.Void_Ptr) /= 0; + end Column_Headers_Enabled; + + + procedure Set_Column_Headers + (This : in out Table; + Value : in Boolean) is + begin + fl_table_set_col_header (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Column_Headers; + + + function Get_Column_Header_Color + (This : in Table) + return Color is + begin + return Color (fl_table_get_col_header_color (This.Void_Ptr)); + end Get_Column_Header_Color; + + + procedure Set_Column_Header_Color + (This : in out Table; + Value : in Color) is + begin + fl_table_set_col_header_color (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Column_Header_Color; + + + function Get_Column_Header_Height + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_col_header_height (This.Void_Ptr); + begin + return Positive (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::col_header_height returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Column_Header_Height; + + + procedure Set_Column_Header_Height + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_col_header_height (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Column_Header_Height; + + + function Get_Column_Width + (This : in Table; + Column : in Positive) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_col_width + (This.Void_Ptr, Interfaces.C.int (Column) - 1); + begin + return Positive (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::col_width returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Column_Width; + + + procedure Set_Column_Width + (This : in out Table; + Column : in Positive; + Value : in Positive) is + begin + fl_table_set_col_width + (This.Void_Ptr, + Interfaces.C.int (Column) - 1, + Interfaces.C.int (Value)); + end Set_Column_Width; + + + procedure Set_All_Columns_Width + (This : in out Table; + Value : in Positive) is + begin + fl_table_col_width_all (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_All_Columns_Width; + + + function Get_Columns + (This : in Table) + return Natural + is + Result : constant Interfaces.C.int := fl_table_get_cols (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::cols returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Columns; + + + procedure Set_Columns + (This : in out Table; + Value : in Natural) is + begin + fl_table_set_cols (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Columns; + + + function Get_Column_Position + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_col_position (This.Void_Ptr); + begin + return Positive (Result + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::col_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Column_Position; + + + procedure Set_Column_Position + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_col_position (This.Void_Ptr, Interfaces.C.int (Value) - 1); + end Set_Column_Position; + + + function Get_Column_Scroll_Position + (This : in Table; + Column : in Positive) + return Long_Integer is + begin + return Long_Integer (fl_table_col_scroll_position + (This.Void_Ptr, + Interfaces.C.int (Column) - 1)); + end Get_Column_Scroll_Position; + + + function Column_Resize_Allowed + (This : in Table) + return Boolean is + begin + return fl_table_get_col_resize (This.Void_Ptr) /= 0; + end Column_Resize_Allowed; + + + procedure Set_Column_Resize + (This : in out Table; + Value : in Boolean) is + begin + fl_table_set_col_resize (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Column_Resize; + + + function Get_Column_Resize_Minimum + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_col_resize_min (This.Void_Ptr); + begin + return Positive (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::col_resize_min returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Column_Resize_Minimum; + + + procedure Set_Column_Resize_Minimum + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_col_resize_min (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Column_Resize_Minimum; + + + + + -- Rows -- + + function Row_Headers_Enabled + (This : in Table) + return Boolean is + begin + return fl_table_get_row_header (This.Void_Ptr) /= 0; + end Row_Headers_Enabled; + + + procedure Set_Row_Headers + (This : in out Table; + Value : in Boolean) is + begin + fl_table_set_row_header (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Row_Headers; + + + function Get_Row_Header_Color + (This : in Table) + return Color is + begin + return Color (fl_table_get_row_header_color (This.Void_Ptr)); + end Get_Row_Header_Color; + + + procedure Set_Row_Header_Color + (This : in out Table; + Value : in Color) is + begin + fl_table_set_row_header_color (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Row_Header_Color; + + + function Get_Row_Header_Width + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_row_header_width (This.Void_Ptr); + begin + return Positive (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::row_header_width returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Row_Header_Width; + + + procedure Set_Row_Header_Width + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_row_header_width (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Row_Header_Width; + + + function Get_Row_Height + (This : in Table; + Row : in Positive) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_row_height + (This.Void_Ptr, Interfaces.C.int (Row) - 1); + begin + return Positive (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::row_height returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Row_Height; + + + procedure Set_Row_Height + (This : in out Table; + Row : in Positive; + Value : in Positive) is + begin + fl_table_set_row_height + (This.Void_Ptr, + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Value)); + end Set_Row_Height; + + + procedure Set_All_Rows_Height + (This : in out Table; + Value : in Positive) is + begin + fl_table_row_height_all (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_All_Rows_Height; + + + function Get_Rows + (This : in Table) + return Natural + is + Result : constant Interfaces.C.int := fl_table_get_rows (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::rows returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Rows; + + + procedure Set_Rows + (This : in out Table; + Value : in Natural) is + begin + fl_table_set_rows (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Rows; + + + function Get_Row_Position + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_row_position (This.Void_Ptr); + begin + return Positive (Result + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::row_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Row_Position; + + + procedure Set_Row_Position + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_row_position (This.Void_Ptr, Interfaces.C.int (Value) - 1); + end Set_Row_Position; + + + function Get_Row_Scroll_Position + (This : in Table; + Row : in Positive) + return Long_Integer is + begin + return Long_Integer (fl_table_row_scroll_position + (This.Void_Ptr, + Interfaces.C.int (Row) - 1)); + end Get_Row_Scroll_Position; + + + function Row_Resize_Allowed + (This : in Table) + return Boolean is + begin + return fl_table_get_row_resize (This.Void_Ptr) /= 0; + end Row_Resize_Allowed; + + + procedure Set_Row_Resize + (This : in out Table; + Value : in Boolean) is + begin + fl_table_set_row_resize (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Row_Resize; + + + function Get_Row_Resize_Minimum + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_row_resize_min (This.Void_Ptr); + begin + return Positive (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::row_resize_min returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Row_Resize_Minimum; + + + procedure Set_Row_Resize_Minimum + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_row_resize_min (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Row_Resize_Minimum; + + + function Get_Top_Row + (This : in Table) + return Positive + is + Result : constant Interfaces.C.int := fl_table_get_top_row (This.Void_Ptr); + begin + return Positive (Result + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::top_row returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Top_Row; + + + procedure Set_Top_Row + (This : in out Table; + Value : in Positive) is + begin + fl_table_set_top_row (This.Void_Ptr, Interfaces.C.int (Value) - 1); + end Set_Top_Row; + + + + + -- Selection -- + + procedure Set_Cursor_Kind + (This : in out Table; + Kind : in Mouse_Cursor_Kind) is + begin + fl_table_change_cursor (This.Void_Ptr, Cursor_Values (Kind)); + end Set_Cursor_Kind; + + + procedure Cursor_To_Row_Column + (This : in Table; + Row, Column : out Positive; + Context : out Table_Context; + Resize : out Resize_Flag) + is + C_Row, C_Column, C_Flag : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_table_cursor2rowcol + (This.Void_Ptr, C_Row, C_Column, C_Flag); + begin + Row := Positive (C_Row + 1); + Column := Positive (C_Column + 1); + Context := To_Context (Result); + Resize := Resize_Flag'Val (C_Flag); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::cursor2rowcol returned unexpected values with" & Latin.LF & + Latin.HT & "row = " & Interfaces.C.int'Image (C_Row) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column) & Latin.LF & + Latin.HT & "context = " & Interfaces.C.int'Image (Result) & Latin.LF & + Latin.HT & "resize = " & Interfaces.C.int'Image (C_Flag); + end Cursor_To_Row_Column; + + + procedure Get_Visible_Cells + (This : in Table; + Row_Top : out Positive; + Column_Left : out Positive; + Row_Bottom : out Natural; + Column_Right : out Natural) + is + C_Row_Top, C_Row_Bottom, C_Column_Left, C_Column_Right : Interfaces.C.int; + begin + fl_table_visible_cells + (This.Void_Ptr, + C_Row_Top, C_Row_Bottom, + C_Column_Left, C_Column_Right); + Row_Top := Positive (C_Row_Top + 1); + Row_Bottom := Positive (C_Row_Bottom + 1); + Column_Left := Natural (C_Column_Left + 1); + Column_Right := Natural (C_Column_Right + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::visible_cells returned unexpected values with" & Latin.LF & + Latin.HT & "row_top = " & Interfaces.C.int'Image (C_Row_Top) & Latin.LF & + Latin.HT & "row_bottom = " & Interfaces.C.int'Image (C_Row_Bottom) & Latin.LF & + Latin.HT & "column_left = " & Interfaces.C.int'Image (C_Column_Left) & Latin.LF & + Latin.HT & "column_right = " & Interfaces.C.int'Image (C_Column_Right); + end Get_Visible_Cells; + + + procedure Get_Selection + (This : in Table; + Row_Top : out Positive; + Column_Left : out Positive; + Row_Bottom : out Positive; + Column_Right : out Positive) + is + C_Row_Top, C_Column_Left, C_Row_Bottom, C_Column_Right : Interfaces.C.int; + begin + fl_table_get_selection + (This.Void_Ptr, + C_Row_Top, C_Column_Left, + C_Row_Bottom, C_Column_Right); + Row_Top := Positive (C_Row_Top + 1); + Column_Left := Positive (C_Column_Left + 1); + Row_Bottom := Positive (C_Row_Bottom + 1); + Column_Right := Positive (C_Column_Right + 1); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::get_selection returned unexpected values with" & Latin.LF & + Latin.HT & "row_top = " & Interfaces.C.int'Image (C_Row_Top) & Latin.LF & + Latin.HT & "column_left = " & Interfaces.C.int'Image (C_Column_Left) & Latin.LF & + Latin.HT & "row_bottom = " & Interfaces.C.int'Image (C_Row_Bottom) & Latin.LF & + Latin.HT & "column_right = " & Interfaces.C.int'Image (C_Column_Right); + end Get_Selection; + + + procedure Set_Selection + (This : in out Table; + Row_Top : in Positive; + Column_Left : in Positive; + Row_Bottom : in Positive; + Column_Right : in Positive) is + begin + fl_table_set_selection + (This.Void_Ptr, + Interfaces.C.int (Row_Top) - 1, + Interfaces.C.int (Column_Left) - 1, + Interfaces.C.int (Row_Bottom) - 1, + Interfaces.C.int (Column_Right) - 1); + end Set_Selection; + + + function Is_Selected + (This : in Table; + Row, Column : in Positive) + return Boolean + is + Result : constant Interfaces.C.int := fl_table_is_selected + (This.Void_Ptr, + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Column) - 1); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::is_selected returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Selected; + + + procedure Move_Cursor + (This : in out Table; + Row, Column : in Positive; + Shift_Select : in Boolean := True) + is + Result : constant Interfaces.C.int := fl_table_move_cursor + (This.Void_Ptr, + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Column) - 1, + Boolean'Pos (Shift_Select)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table::move_cursor returned unexpected value of " & + Interfaces.C.int'Image (Result); + end Move_Cursor; + + + function Move_Cursor + (This : in out Table; + Row, Column : in Positive; + Shift_Select : in Boolean := True) + return Boolean + is + Result : constant Interfaces.C.int := fl_table_move_cursor + (This.Void_Ptr, + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Column) - 1, + Boolean'Pos (Shift_Select)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::move_cursor returned unexpected value of " & + Interfaces.C.int'Image (Result); + end Move_Cursor; + + + function Get_Tab_Mode + (This : in Table) + return Tab_Navigation + is + Result : constant Interfaces.C.int := fl_table_get_tab_cell_nav (This.Void_Ptr); + begin + return Tab_Navigation'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::tab_cell_nav returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Tab_Mode; + + + procedure Set_Tab_Mode + (This : in out Table; + Value : in Tab_Navigation) is + begin + fl_table_set_tab_cell_nav (This.Void_Ptr, Tab_Navigation'Pos (Value)); + end Set_Tab_Mode; + + + function Get_Table_Box + (This : in Table) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_table_get_table_box (This.Void_Ptr); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::table_box returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Table_Box; + + + procedure Set_Table_Box + (This : in out Table; + Box : in Box_Kind) is + begin + fl_table_set_table_box (This.Void_Ptr, Box_Kind'Pos (Box)); + end Set_Table_Box; + + + + + -- Dimensions -- + + function Get_Scrollbar_Size + (This : in Table) + return Integer is + begin + return Integer (fl_table_get_scrollbar_size (This.Void_Ptr)); + end Get_Scrollbar_Size; + + + procedure Set_Scrollbar_Size + (This : in out Table; + Value : in Integer) is + begin + fl_table_set_scrollbar_size (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Scrollbar_Size; + + + procedure Resize + (This : in out Table; + X, Y, W, H : in Integer) is + begin + fl_table_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + function Is_Interactive_Resize + (This : in Table) + return Boolean + is + Result : constant Interfaces.C.int := fl_table_is_interactive_resize (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Table::is_interactive_resize returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Interactive_Resize; + + + procedure Reset_Sizes + (This : in out Table) is + begin + fl_table_init_sizes (This.Void_Ptr); + end Reset_Sizes; + + + procedure Recalculate_Dimensions + (This : in out Table) is + begin + fl_table_recalc_dimensions (This.Void_Ptr); + end Recalculate_Dimensions; + + + procedure Table_Resized + (This : in out Table) is + begin + fl_table_table_resized (This.Void_Ptr); + end Table_Resized; + + + procedure Table_Scrolled + (This : in out Table) is + begin + fl_table_table_scrolled (This.Void_Ptr); + end Table_Scrolled; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Table) is + begin + Group (This).Draw; + end Draw; + + + procedure Draw_Cell + (This : in out Table; + Context : in Table_Context; + Row, Column : in Natural := 0; + X, Y, W, H : in Integer := 0) + is + procedure my_draw_cell + (T : in Storage.Integer_Address; + E, R, C, X, Y, W, H : in Interfaces.C.int); + for my_draw_cell'Address use This.Draw_Cell_Ptr; + pragma Import (Ada, my_draw_cell); + + C_Row, C_Column : Interfaces.C.int; + begin + case Context is + when Row_Header => + C_Row := Interfaces.C.int (Row) - 1; + C_Column := Interfaces.C.int (Column); + when Column_Header => + C_Row := Interfaces.C.int (Row); + C_Column := Interfaces.C.int (Column) - 1; + when Within_Cell => + C_Row := Interfaces.C.int (Row) - 1; + C_Column := Interfaces.C.int (Column) - 1; + when others => + C_Row := Interfaces.C.int (Row); + C_Column := Interfaces.C.int (Column); + end case; + my_draw_cell + (This.Void_Ptr, + To_Cint (Context), + C_Row, C_Column, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Cell; + + + procedure Redraw_Range + (This : in out Table; + Row_Top : in Positive; + Column_Left : in Positive; + Row_Bottom : in Positive; + Column_Right : in Positive) is + begin + fl_table_redraw_range + (This.Void_Ptr, + Interfaces.C.int (Row_Top) - 1, + Interfaces.C.int (Row_Bottom) - 1, + Interfaces.C.int (Column_Left) - 1, + Interfaces.C.int (Column_Right) - 1); + end Redraw_Range; + + + procedure Damage_Zone + (This : in out Table; + Row_Top : in Positive; + Column_Left : in Positive; + Row_Bottom : in Positive; + Column_Right : in Positive; + Reach_Row : in Positive := 1; + Reach_Column : in Positive := 1) is + begin + fl_table_damage_zone + (This.Void_Ptr, + Interfaces.C.int (Row_Top) - 1, + Interfaces.C.int (Column_Left) - 1, + Interfaces.C.int (Row_Bottom) - 1, + Interfaces.C.int (Column_Right) - 1, + Interfaces.C.int (Reach_Row) - 1, + Interfaces.C.int (Reach_Column) - 1); + end Damage_Zone; + + + procedure Cell_Dimensions + (This : in Table; + Context : in Table_Context; + Row, Column : in Positive; + X, Y, W, H : out Integer) + is + Result : constant Interfaces.C.int := fl_table_find_cell + (This.Void_Ptr, + To_Cint (Context), + Interfaces.C.int (Row) - 1, + Interfaces.C.int (Column) - 1, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + begin + if Result = -1 then + raise Range_Error with + "Row = " & Integer'Image (Row) & ", Column = " & Integer'Image (Column); + else + pragma Assert (Result = 0); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table::find_cell returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Cell_Dimensions; + + + procedure Bounding_Region + (This : in Table; + Context : in Table_Context; + X, Y, W, H : out Integer) is + begin + fl_table_get_bounds + (This.Void_Ptr, + To_Cint (Context), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Bounding_Region; + + + procedure Row_Column_Clamp + (This : in Table; + Context : in Table_Context; + Row, Column : in out Integer) + is + C_Row : Interfaces.C.int := Interfaces.C.int (Row) - 1; + C_Column : Interfaces.C.int := Interfaces.C.int (Column) - 1; + Result : constant Interfaces.C.int := fl_table_row_col_clamp + (This.Void_Ptr, + To_Cint (Context), + C_Row, C_Column); + begin + pragma Assert (Result in 0 .. 1); + Row := Integer (C_Row) + 1; + Column := Integer (C_Column) + 1; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table::row_col_clamp returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Row_Column_Clamp; + + + function Row_Column_Clamp + (This : in Table; + Context : in Table_Context; + Row, Column : in out Integer) + return Boolean + is + C_Row : Interfaces.C.int := Interfaces.C.int (Row) - 1; + C_Column : Interfaces.C.int := Interfaces.C.int (Column) - 1; + Result : constant Interfaces.C.int := fl_table_row_col_clamp + (This.Void_Ptr, + To_Cint (Context), + C_Row, C_Column); + begin + pragma Assert (Result in 0 .. 1); + Row := Integer (C_Row) + 1; + Column := Integer (C_Column) + 1; + return Boolean'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Table::row_col_clamp returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Row_Column_Clamp; + + + function Handle + (This : in out Table; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Tables; + + diff --git a/body/fltk-widgets-groups-text_displays-text_editors.adb b/body/fltk-widgets-groups-text_displays-text_editors.adb new file mode 100644 index 0000000..c2722b6 --- /dev/null +++ b/body/fltk-widgets-groups-text_displays-text_editors.adb @@ -0,0 +1,1275 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Characters.Latin_1, + FLTK.Events; + + +package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is + + + package Chk renames Ada.Assertions; + package Latin renames Ada.Characters.Latin_1; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_text_editor + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_text_editor, "new_fl_text_editor"); + pragma Inline (new_fl_text_editor); + + procedure free_fl_text_editor + (TE : in Storage.Integer_Address); + pragma Import (C, free_fl_text_editor, "free_fl_text_editor"); + pragma Inline (free_fl_text_editor); + + + + + -- Default Key Function -- + + procedure fl_text_editor_default + (TE : in Storage.Integer_Address; + K : in Interfaces.C.int); + pragma Import (C, fl_text_editor_default, "fl_text_editor_default"); + pragma Inline (fl_text_editor_default); + + + + + -- Operation Key Functions -- + + procedure fl_text_editor_undo + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_undo, "fl_text_editor_undo"); + pragma Inline (fl_text_editor_undo); + + procedure fl_text_editor_cut + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_cut, "fl_text_editor_cut"); + pragma Inline (fl_text_editor_cut); + + procedure fl_text_editor_copy + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_copy, "fl_text_editor_copy"); + pragma Inline (fl_text_editor_copy); + + procedure fl_text_editor_paste + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_paste, "fl_text_editor_paste"); + pragma Inline (fl_text_editor_paste); + + procedure fl_text_editor_delete + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_delete, "fl_text_editor_delete"); + pragma Inline (fl_text_editor_delete); + + procedure fl_text_editor_select_all + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_select_all, "fl_text_editor_select_all"); + pragma Inline (fl_text_editor_select_all); + + + + + -- Special Key Functions -- + + procedure fl_text_editor_backspace + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_backspace, "fl_text_editor_backspace"); + pragma Inline (fl_text_editor_backspace); + + procedure fl_text_editor_insert + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_insert, "fl_text_editor_insert"); + pragma Inline (fl_text_editor_insert); + + procedure fl_text_editor_enter + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_enter, "fl_text_editor_enter"); + pragma Inline (fl_text_editor_enter); + + procedure fl_text_editor_ignore + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ignore, "fl_text_editor_ignore"); + pragma Inline (fl_text_editor_ignore); + + + + + -- Movement Key Functions -- + + procedure fl_text_editor_home + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_home, "fl_text_editor_home"); + pragma Inline (fl_text_editor_home); + + procedure fl_text_editor_end + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_end, "fl_text_editor_end"); + pragma Inline (fl_text_editor_end); + + procedure fl_text_editor_page_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_page_down, "fl_text_editor_page_down"); + pragma Inline (fl_text_editor_page_down); + + procedure fl_text_editor_page_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_page_up, "fl_text_editor_page_up"); + pragma Inline (fl_text_editor_page_up); + + procedure fl_text_editor_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_down, "fl_text_editor_down"); + pragma Inline (fl_text_editor_down); + + procedure fl_text_editor_left + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_left, "fl_text_editor_left"); + pragma Inline (fl_text_editor_left); + + procedure fl_text_editor_right + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_right, "fl_text_editor_right"); + pragma Inline (fl_text_editor_right); + + procedure fl_text_editor_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_up, "fl_text_editor_up"); + pragma Inline (fl_text_editor_up); + + + + + -- Shift Key Functions -- + + procedure fl_text_editor_shift_home + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_home, "fl_text_editor_shift_home"); + pragma Inline (fl_text_editor_shift_home); + + procedure fl_text_editor_shift_end + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_end, "fl_text_editor_shift_end"); + pragma Inline (fl_text_editor_shift_end); + + procedure fl_text_editor_shift_page_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_page_down, "fl_text_editor_shift_page_down"); + pragma Inline (fl_text_editor_shift_page_down); + + procedure fl_text_editor_shift_page_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_page_up, "fl_text_editor_shift_page_up"); + pragma Inline (fl_text_editor_shift_page_up); + + procedure fl_text_editor_shift_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_down, "fl_text_editor_shift_down"); + pragma Inline (fl_text_editor_shift_down); + + procedure fl_text_editor_shift_left + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_left, "fl_text_editor_shift_left"); + pragma Inline (fl_text_editor_shift_left); + + procedure fl_text_editor_shift_right + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_right, "fl_text_editor_shift_right"); + pragma Inline (fl_text_editor_shift_right); + + procedure fl_text_editor_shift_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_shift_up, "fl_text_editor_shift_up"); + pragma Inline (fl_text_editor_shift_up); + + + + + -- Control Key Functions -- + + procedure fl_text_editor_ctrl_home + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_home, "fl_text_editor_ctrl_home"); + pragma Inline (fl_text_editor_ctrl_home); + + procedure fl_text_editor_ctrl_end + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_end, "fl_text_editor_ctrl_end"); + pragma Inline (fl_text_editor_ctrl_end); + + procedure fl_text_editor_ctrl_page_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_page_down, "fl_text_editor_ctrl_page_down"); + pragma Inline (fl_text_editor_ctrl_page_down); + + procedure fl_text_editor_ctrl_page_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_page_up, "fl_text_editor_ctrl_page_up"); + pragma Inline (fl_text_editor_ctrl_page_up); + + procedure fl_text_editor_ctrl_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_down, "fl_text_editor_ctrl_down"); + pragma Inline (fl_text_editor_ctrl_down); + + procedure fl_text_editor_ctrl_left + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_left, "fl_text_editor_ctrl_left"); + pragma Inline (fl_text_editor_ctrl_left); + + procedure fl_text_editor_ctrl_right + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_right, "fl_text_editor_ctrl_right"); + pragma Inline (fl_text_editor_ctrl_right); + + procedure fl_text_editor_ctrl_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_up, "fl_text_editor_ctrl_up"); + pragma Inline (fl_text_editor_ctrl_up); + + + + + -- Control Shift Key Functions -- + + procedure fl_text_editor_ctrl_shift_home + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_home, "fl_text_editor_ctrl_shift_home"); + pragma Inline (fl_text_editor_ctrl_shift_home); + + procedure fl_text_editor_ctrl_shift_end + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_end, "fl_text_editor_ctrl_shift_end"); + pragma Inline (fl_text_editor_ctrl_shift_end); + + procedure fl_text_editor_ctrl_shift_page_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_page_down, "fl_text_editor_ctrl_shift_page_down"); + pragma Inline (fl_text_editor_ctrl_shift_page_down); + + procedure fl_text_editor_ctrl_shift_page_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_page_up, "fl_text_editor_ctrl_shift_page_up"); + pragma Inline (fl_text_editor_ctrl_shift_page_up); + + procedure fl_text_editor_ctrl_shift_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_down, "fl_text_editor_ctrl_shift_down"); + pragma Inline (fl_text_editor_ctrl_shift_down); + + procedure fl_text_editor_ctrl_shift_left + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_left, "fl_text_editor_ctrl_shift_left"); + pragma Inline (fl_text_editor_ctrl_shift_left); + + procedure fl_text_editor_ctrl_shift_right + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_right, "fl_text_editor_ctrl_shift_right"); + pragma Inline (fl_text_editor_ctrl_shift_right); + + procedure fl_text_editor_ctrl_shift_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_ctrl_shift_up, "fl_text_editor_ctrl_shift_up"); + pragma Inline (fl_text_editor_ctrl_shift_up); + + + + + -- Meta Key Functions -- + + procedure fl_text_editor_meta_home + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_home, "fl_text_editor_meta_home"); + pragma Inline (fl_text_editor_meta_home); + + procedure fl_text_editor_meta_end + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_end, "fl_text_editor_meta_end"); + pragma Inline (fl_text_editor_meta_end); + + procedure fl_text_editor_meta_page_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_page_down, "fl_text_editor_meta_page_down"); + pragma Inline (fl_text_editor_meta_page_down); + + procedure fl_text_editor_meta_page_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_page_up, "fl_text_editor_meta_page_up"); + pragma Inline (fl_text_editor_meta_page_up); + + procedure fl_text_editor_meta_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_down, "fl_text_editor_meta_down"); + pragma Inline (fl_text_editor_meta_down); + + procedure fl_text_editor_meta_left + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_left, "fl_text_editor_meta_left"); + pragma Inline (fl_text_editor_meta_left); + + procedure fl_text_editor_meta_right + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_right, "fl_text_editor_meta_right"); + pragma Inline (fl_text_editor_meta_right); + + procedure fl_text_editor_meta_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_up, "fl_text_editor_meta_up"); + pragma Inline (fl_text_editor_meta_up); + + + + + -- Meta Shift Key Functions -- + + procedure fl_text_editor_meta_shift_home + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_home, "fl_text_editor_meta_shift_home"); + pragma Inline (fl_text_editor_meta_shift_home); + + procedure fl_text_editor_meta_shift_end + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_end, "fl_text_editor_meta_shift_end"); + pragma Inline (fl_text_editor_meta_shift_end); + + procedure fl_text_editor_meta_shift_page_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_page_down, "fl_text_editor_meta_shift_page_down"); + pragma Inline (fl_text_editor_meta_shift_page_down); + + procedure fl_text_editor_meta_shift_page_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_page_up, "fl_text_editor_meta_shift_page_up"); + pragma Inline (fl_text_editor_meta_shift_page_up); + + procedure fl_text_editor_meta_shift_down + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_down, "fl_text_editor_meta_shift_down"); + pragma Inline (fl_text_editor_meta_shift_down); + + procedure fl_text_editor_meta_shift_left + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_left, "fl_text_editor_meta_shift_left"); + pragma Inline (fl_text_editor_meta_shift_left); + + procedure fl_text_editor_meta_shift_right + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_right, "fl_text_editor_meta_shift_right"); + pragma Inline (fl_text_editor_meta_shift_right); + + procedure fl_text_editor_meta_shift_up + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_meta_shift_up, "fl_text_editor_meta_shift_up"); + pragma Inline (fl_text_editor_meta_shift_up); + + + + + -- Key Binding Modification -- + + -- procedure fl_text_editor_add_key_binding + -- (TE : in Storage.Integer_Address; + -- K, S : in Interfaces.C.int; + -- F : in Storage.Integer_Address); + -- pragma Import (C, fl_text_editor_add_key_binding, "fl_text_editor_add_key_binding"); + -- pragma Inline (fl_text_editor_add_key_binding); + + procedure fl_text_editor_remove_all_key_bindings + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_remove_all_key_bindings, + "fl_text_editor_remove_all_key_bindings"); + pragma Inline (fl_text_editor_remove_all_key_bindings); + + procedure fl_text_editor_set_default_key_function + (TE, F : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_set_default_key_function, + "fl_text_editor_set_default_key_function"); + pragma Inline (fl_text_editor_set_default_key_function); + + + + + -- Settings -- + + function fl_text_editor_get_insert_mode + (TE : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_editor_get_insert_mode, "fl_text_editor_get_insert_mode"); + pragma Inline (fl_text_editor_get_insert_mode); + + procedure fl_text_editor_set_insert_mode + (TE : in Storage.Integer_Address; + I : in Interfaces.C.int); + pragma Import (C, fl_text_editor_set_insert_mode, "fl_text_editor_set_insert_mode"); + pragma Inline (fl_text_editor_set_insert_mode); + + function fl_text_editor_get_tab_nav + (TE : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_editor_get_tab_nav, "fl_text_editor_get_tab_nav"); + pragma Inline (fl_text_editor_get_tab_nav); + + procedure fl_text_editor_set_tab_nav + (TE : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_text_editor_set_tab_nav, "fl_text_editor_set_tab_nav"); + pragma Inline (fl_text_editor_set_tab_nav); + + + + + -- Drawing, Events -- + + procedure fl_text_editor_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_draw, "fl_text_editor_draw"); + pragma Inline (fl_text_editor_draw); + + function fl_text_editor_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_editor_handle, "fl_text_editor_handle"); + pragma Inline (fl_text_editor_handle); + + function fl_text_editor_handle_key + (TE : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_editor_handle_key, "fl_text_editor_handle_key"); + pragma Inline (fl_text_editor_handle_key); + + procedure fl_text_editor_maybe_do_callback + (TE : in Storage.Integer_Address); + pragma Import (C, fl_text_editor_maybe_do_callback, "fl_text_editor_maybe_do_callback"); + pragma Inline (fl_text_editor_maybe_do_callback); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + function Key_Func_Hook + (K : in Interfaces.C.int; + E : in Storage.Integer_Address) + return Interfaces.C.int + is + Editor_Ptr : constant Storage.Integer_Address := fl_widget_get_user_data (E); + Ada_Editor : access Text_Editor'Class; + + Extra_Keys : constant Modifier := FLTK.Events.Last_Modifier; + Actual_Key : constant Keypress := FLTK.Events.Last_Key; + -- fuck you FLTK, give me the real code + Ada_Key : constant Key_Combo := Extra_Keys + Actual_Key; + + -- For whatever reason, if a regular key function is used then FLTK will + -- give you the key code, but if a default key function is used instead it + -- will give you the first character in the textual representation, which + -- is not ideal. This is why we have to grab the Last_Key manually. + begin + pragma Assert (Editor_Ptr /= Null_Pointer); + Ada_Editor := Editor_Convert.To_Pointer (Storage.To_Address (Editor_Ptr)); + for B of Global_Key_Bindings loop + if B.Key = Ada_Key and B.Func /= null then + B.Func (Ada_Editor.all); + return Event_Outcome'Pos (Handled); + end if; + end loop; + for B of Ada_Editor.Bindings loop + if B.Key = Ada_Key then + B.Func (Ada_Editor.all); + return Event_Outcome'Pos (Handled); + end if; + end loop; + if Ada_Editor.Default_Func /= null then + Ada_Editor.Default_Func (Ada_Editor.all, Ada_Key); + return Event_Outcome'Pos (Handled); + end if; + return Event_Outcome'Pos (Not_Handled); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Editor C++ object had no user data reference back to the " & + "corresponding Ada object in the Key_Func hook"; + end Key_Func_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Text_Editor) is + begin + Extra_Final (Text_Display (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Text_Editor) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_text_editor (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + if This.Raw_Buffer /= Null_Pointer then + free_fl_text_buffer (This.Raw_Buffer); -- buffer is reference counted + This.Raw_Buffer := Null_Pointer; + end if; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Text_Editor; + X, Y, W, H : in Integer; + Text : in String) is + begin + for B of Default_Key_Bindings loop + This.Bindings.Append (B); + end loop; + This.Default_Func := KF_Default'Access; + + -- change things over so key bindings are all handled from the Ada side + fl_text_editor_remove_all_key_bindings (This.Void_Ptr); + fl_text_editor_set_default_key_function + (This.Void_Ptr, Storage.To_Integer (Key_Func_Hook'Address)); + + Extra_Init (Text_Display (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Text_Editor) is + begin + This.Draw_Ptr := fl_text_editor_draw'Address; + This.Handle_Ptr := fl_text_editor_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Text_Editor is + begin + return This : Text_Editor do + This.Void_Ptr := new_fl_text_editor + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Text_Editor is + begin + return This : Text_Editor := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Default Key Function -- + + procedure KF_Default + (This : in out Text_Editor'Class; + Key : in Key_Combo) is + begin + fl_text_editor_default + (This.Void_Ptr, + Interfaces.C.int (Key.Keycode)); + end KF_Default; + + + + + -- Operation Key Functions -- + + procedure KF_Undo + (This : in out Text_Editor'Class) is + begin + fl_text_editor_undo (This.Void_Ptr); + end KF_Undo; + + + procedure KF_Cut + (This : in out Text_Editor'Class) is + begin + fl_text_editor_cut (This.Void_Ptr); + end KF_Cut; + + + procedure KF_Copy + (This : in out Text_Editor'Class) is + begin + fl_text_editor_copy (This.Void_Ptr); + end KF_Copy; + + + procedure KF_Paste + (This : in out Text_Editor'Class) is + begin + fl_text_editor_paste (This.Void_Ptr); + end KF_Paste; + + + procedure KF_Delete + (This : in out Text_Editor'Class) is + begin + fl_text_editor_delete (This.Void_Ptr); + end KF_Delete; + + + procedure KF_Select_All + (This : in out Text_Editor'Class) is + begin + fl_text_editor_select_all (This.Void_Ptr); + end KF_Select_All; + + + + + -- Special Key Functions -- + + procedure KF_Backspace + (This : in out Text_Editor'Class) is + begin + fl_text_editor_backspace (This.Void_Ptr); + end KF_Backspace; + + + procedure KF_Insert + (This : in out Text_Editor'Class) is + begin + fl_text_editor_insert (This.Void_Ptr); + end KF_Insert; + + + procedure KF_Enter + (This : in out Text_Editor'Class) is + begin + fl_text_editor_enter (This.Void_Ptr); + end KF_Enter; + + + procedure KF_Ignore + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ignore (This.Void_Ptr); + end KF_Ignore; + + + procedure KF_Tab + (This : in out Text_Editor'Class) is + begin + This.Insert_Text (Latin.HT & ""); + end KF_Tab; + + + + + -- Movement Key Functions -- + + procedure KF_Home + (This : in out Text_Editor'Class) is + begin + fl_text_editor_home (This.Void_Ptr); + end KF_Home; + + + procedure KF_End + (This : in out Text_Editor'Class) is + begin + fl_text_editor_end (This.Void_Ptr); + end KF_End; + + + procedure KF_Page_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_page_down (This.Void_Ptr); + end KF_Page_Down; + + + procedure KF_Page_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_page_up (This.Void_Ptr); + end KF_Page_Up; + + + procedure KF_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_down (This.Void_Ptr); + end KF_Down; + + + procedure KF_Left + (This : in out Text_Editor'Class) is + begin + fl_text_editor_left (This.Void_Ptr); + end KF_Left; + + + procedure KF_Right + (This : in out Text_Editor'Class) is + begin + fl_text_editor_right (This.Void_Ptr); + end KF_Right; + + + procedure KF_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_up (This.Void_Ptr); + end KF_Up; + + + + + -- Shift Key Functions -- + + procedure KF_Shift_Home + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_home (This.Void_Ptr); + end KF_Shift_Home; + + + procedure KF_Shift_End + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_end (This.Void_Ptr); + end KF_Shift_End; + + + procedure KF_Shift_Page_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_page_down (This.Void_Ptr); + end KF_Shift_Page_Down; + + + procedure KF_Shift_Page_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_page_up (This.Void_Ptr); + end KF_Shift_Page_Up; + + + procedure KF_Shift_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_down (This.Void_Ptr); + end KF_Shift_Down; + + + procedure KF_Shift_Left + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_left (This.Void_Ptr); + end KF_Shift_Left; + + + procedure KF_Shift_Right + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_right (This.Void_Ptr); + end KF_Shift_Right; + + + procedure KF_Shift_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_shift_up (This.Void_Ptr); + end KF_Shift_Up; + + + + + -- Control Key Functions -- + + procedure KF_Ctrl_Home + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_home (This.Void_Ptr); + end KF_Ctrl_Home; + + + procedure KF_Ctrl_End + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_end (This.Void_Ptr); + end KF_Ctrl_End; + + + procedure KF_Ctrl_Page_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_page_down (This.Void_Ptr); + end KF_Ctrl_Page_Down; + + + procedure KF_Ctrl_Page_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_page_up (This.Void_Ptr); + end KF_Ctrl_Page_Up; + + + procedure KF_Ctrl_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_down (This.Void_Ptr); + end KF_Ctrl_Down; + + + procedure KF_Ctrl_Left + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_left (This.Void_Ptr); + end KF_Ctrl_Left; + + + procedure KF_Ctrl_Right + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_right (This.Void_Ptr); + end KF_Ctrl_Right; + + + procedure KF_Ctrl_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_up (This.Void_Ptr); + end KF_Ctrl_Up; + + + + + -- Control Shift Key Functions -- + + procedure KF_Ctrl_Shift_Home + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_home (This.Void_Ptr); + end KF_Ctrl_Shift_Home; + + + procedure KF_Ctrl_Shift_End + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_end (This.Void_Ptr); + end KF_Ctrl_Shift_End; + + + procedure KF_Ctrl_Shift_Page_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_page_down (This.Void_Ptr); + end KF_Ctrl_Shift_Page_Down; + + + procedure KF_Ctrl_Shift_Page_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_page_up (This.Void_Ptr); + end KF_Ctrl_Shift_Page_Up; + + + procedure KF_Ctrl_Shift_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_down (This.Void_Ptr); + end KF_Ctrl_Shift_Down; + + + procedure KF_Ctrl_Shift_Left + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_left (This.Void_Ptr); + end KF_Ctrl_Shift_Left; + + + procedure KF_Ctrl_Shift_Right + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_right (This.Void_Ptr); + end KF_Ctrl_Shift_Right; + + + procedure KF_Ctrl_Shift_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_ctrl_shift_up (This.Void_Ptr); + end KF_Ctrl_Shift_Up; + + + + + -- Meta Key Functions -- + + procedure KF_Meta_Home + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_home (This.Void_Ptr); + end KF_Meta_Home; + + + procedure KF_Meta_End + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_end (This.Void_Ptr); + end KF_Meta_End; + + + procedure KF_Meta_Page_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_page_down (This.Void_Ptr); + end KF_Meta_Page_Down; + + + procedure KF_Meta_Page_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_page_up (This.Void_Ptr); + end KF_Meta_Page_Up; + + + procedure KF_Meta_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_down (This.Void_Ptr); + end KF_Meta_Down; + + + procedure KF_Meta_Left + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_left (This.Void_Ptr); + end KF_Meta_Left; + + + procedure KF_Meta_Right + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_right (This.Void_Ptr); + end KF_Meta_Right; + + + procedure KF_Meta_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_up (This.Void_Ptr); + end KF_Meta_Up; + + + + + -- Meta Shift Key Functions -- + + procedure KF_Meta_Shift_Home + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_home (This.Void_Ptr); + end KF_Meta_Shift_Home; + + + procedure KF_Meta_Shift_End + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_end (This.Void_Ptr); + end KF_Meta_Shift_End; + + + procedure KF_Meta_Shift_Page_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_page_down (This.Void_Ptr); + end KF_Meta_Shift_Page_Down; + + + procedure KF_Meta_Shift_Page_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_page_up (This.Void_Ptr); + end KF_Meta_Shift_Page_Up; + + + procedure KF_Meta_Shift_Down + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_down (This.Void_Ptr); + end KF_Meta_Shift_Down; + + + procedure KF_Meta_Shift_Left + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_left (This.Void_Ptr); + end KF_Meta_Shift_Left; + + + procedure KF_Meta_Shift_Right + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_right (This.Void_Ptr); + end KF_Meta_Shift_Right; + + + procedure KF_Meta_Shift_Up + (This : in out Text_Editor'Class) is + begin + fl_text_editor_meta_shift_up (This.Void_Ptr); + end KF_Meta_Shift_Up; + + + + + -- Key Binding Modification -- + + procedure Add_Key_Binding + (This : in out Text_Editor; + Key : in Key_Combo; + Func : in Key_Func) is + begin + if Func /= null then + This.Bindings.Append ((Key, Func)); + end if; + end Add_Key_Binding; + + + procedure Add_Key_Binding + (This : in out Text_Editor; + Bind : in Key_Binding) is + begin + if Bind.Func /= null then + This.Bindings.Append (Bind); + end if; + end Add_Key_Binding; + + + procedure Add_Key_Bindings + (This : in out Text_Editor; + Bind : in Key_Binding_Array) is + begin + for Item of Bind loop + if Item.Func /= null then + This.Bindings.Append (Item); + end if; + end loop; + end Add_Key_Bindings; + + + function Get_Bound_Key_Function + (This : in Text_Editor; + Key : in Key_Combo) + return Key_Func is + begin + for I in 1 .. Integer (This.Bindings.Length) loop + if This.Bindings.Element (I).Key = Key then + return This.Bindings.Element (I).Func; + end if; + end loop; + return null; + end Get_Bound_Key_Function; + + + function Get_All_Bound_Key_Functions + (This : in Text_Editor) + return Key_Binding_Array is + begin + return Result : Key_Binding_Array (1 .. Integer (This.Bindings.Length)) do + for Place in Result'Range loop + Result (Place) := This.Bindings.Element (Place); + end loop; + end return; + end Get_All_Bound_Key_Functions; + + + procedure Remove_Key_Binding + (This : in out Text_Editor; + Key : in Key_Combo) is + begin + for I in reverse 1 .. Integer (This.Bindings.Length) loop + if This.Bindings.Element (I).Key = Key then + This.Bindings.Delete (I); + end if; + end loop; + end Remove_Key_Binding; + + + procedure Remove_Key_Binding + (This : in out Text_Editor; + Bind : in Key_Binding) is + begin + for I in reverse 1 .. Integer (This.Bindings.Length) loop + if This.Bindings.Element (I) = Bind then + This.Bindings.Delete (I); + end if; + end loop; + end Remove_Key_Binding; + + + procedure Remove_Key_Bindings + (This : in out Text_Editor; + Bind : in Key_Binding_Array) is + begin + for Item of Bind loop + This.Remove_Key_Binding (Item); + end loop; + end Remove_Key_Bindings; + + + procedure Remove_All_Key_Bindings + (This : in out Text_Editor) is + begin + This.Bindings.Clear; + end Remove_All_Key_Bindings; + + + function Get_Default_Key_Function + (This : in Text_Editor) + return Default_Key_Func is + begin + return This.Default_Func; + end Get_Default_Key_Function; + + + procedure Set_Default_Key_Function + (This : in out Text_Editor; + Func : in Default_Key_Func) is + begin + This.Default_Func := Func; + end Set_Default_Key_Function; + + + + + -- Settings -- + + function Get_Insert_Mode + (This : in Text_Editor) + return Insert_Mode + is + Result : constant Interfaces.C.int := fl_text_editor_get_insert_mode (This.Void_Ptr); + begin + return Insert_Mode'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Editor::insert_mode returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Insert_Mode; + + + procedure Set_Insert_Mode + (This : in out Text_Editor; + To : in Insert_Mode) is + begin + fl_text_editor_set_insert_mode (This.Void_Ptr, Insert_Mode'Pos (To)); + end Set_Insert_Mode; + + + function Get_Tab_Mode + (This : in Text_Editor) + return Tab_Navigation + is + Result : constant Interfaces.C.int := fl_text_editor_get_tab_nav (This.Void_Ptr); + begin + return Tab_Navigation'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Editor::tab_nav returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Tab_Mode; + + + procedure Set_Tab_Mode + (This : in out Text_Editor; + To : in Tab_Navigation) is + begin + fl_text_editor_set_tab_nav (This.Void_Ptr, Tab_Navigation'Pos (To)); + end Set_Tab_Mode; + + + + + -- Events -- + + function Handle + (This : in out Text_Editor; + Event : in Event_Kind) + return Event_Outcome is + begin + return Text_Display (This).Handle (Event); + end Handle; + + + function Handle_Key + (This : in out Text_Editor) + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_text_editor_handle_key (This.Void_Ptr); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Editor::handle_key returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Handle_Key; + + + procedure Maybe_Do_Callback + (This : in out Text_Editor) is + begin + fl_text_editor_maybe_do_callback (This.Void_Ptr); + end Maybe_Do_Callback; + + +end FLTK.Widgets.Groups.Text_Displays.Text_Editors; + + diff --git a/body/fltk-widgets-groups-text_displays.adb b/body/fltk-widgets-groups-text_displays.adb new file mode 100644 index 0000000..ac1f6e9 --- /dev/null +++ b/body/fltk-widgets-groups-text_displays.adb @@ -0,0 +1,2341 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Characters.Latin_1, + Ada.Unchecked_Conversion, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Groups.Text_Displays is + + + package Chk renames Ada.Assertions; + package Latin renames Ada.Characters.Latin_1; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_text_display + (X, Y, W, H : in Interfaces.C.int; + Label : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_text_display, "new_fl_text_display"); + pragma Inline (new_fl_text_display); + + procedure free_fl_text_display + (TD : in Storage.Integer_Address); + pragma Import (C, free_fl_text_display, "free_fl_text_display"); + pragma Inline (free_fl_text_display); + + + + + -- Buffers -- + + -- function fl_text_display_get_buffer + -- (TD : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_text_display_get_buffer, "fl_text_display_get_buffer"); + -- pragma Inline (fl_text_display_get_buffer); + + procedure fl_text_display_set_buffer + (TD, TB : in Storage.Integer_Address); + pragma Import (C, fl_text_display_set_buffer, "fl_text_display_set_buffer"); + pragma Inline (fl_text_display_set_buffer); + + procedure fl_text_display_buffer_modified_cb + (P, I, D, R : in Interfaces.C.int; + T : in Interfaces.C.Strings.chars_ptr; + TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_buffer_modified_cb, "fl_text_display_buffer_modified_cb"); + pragma Inline (fl_text_display_buffer_modified_cb); + + procedure fl_text_display_buffer_predelete_cb + (P, D : in Interfaces.C.int; + TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_buffer_predelete_cb, "fl_text_display_buffer_predelete_cb"); + pragma Inline (fl_text_display_buffer_predelete_cb); + + + + + -- Highlighting -- + + procedure fl_text_display_highlight_data + (TD, TB, ST : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_text_display_highlight_data, "fl_text_display_highlight_data"); + pragma Inline (fl_text_display_highlight_data); + + procedure fl_text_display_highlight_data2 + (TD, TB, ST : in Storage.Integer_Address; + L : in Interfaces.C.int; + C : in Interfaces.C.char; + B, A : in Storage.Integer_Address); + pragma Import (C, fl_text_display_highlight_data2, "fl_text_display_highlight_data2"); + pragma Inline (fl_text_display_highlight_data2); + + function fl_text_display_position_style + (TD : in Storage.Integer_Address; + S, L, I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_style, "fl_text_display_position_style"); + pragma Inline (fl_text_display_position_style); + + + + + -- Measurement Conversion -- + + function fl_text_display_col_to_x + (TD : in Storage.Integer_Address; + C : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_text_display_col_to_x, "fl_text_display_col_to_x"); + pragma Inline (fl_text_display_col_to_x); + + function fl_text_display_x_to_col + (TD : in Storage.Integer_Address; + X : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_text_display_x_to_col, "fl_text_display_x_to_col"); + pragma Inline (fl_text_display_x_to_col); + + function fl_text_display_in_selection + (TD : in Storage.Integer_Address; + X, Y : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_in_selection, "fl_text_display_in_selection"); + pragma Inline (fl_text_display_in_selection); + + function fl_text_display_position_to_xy + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int; + X, Y : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_to_xy, "fl_text_display_position_to_xy"); + pragma Inline (fl_text_display_position_to_xy); + + procedure fl_text_display_find_line_end + (TD : in Storage.Integer_Address; + SP, SPILS : in Interfaces.C.int; + LE, NLS : out Interfaces.C.int); + pragma Import (C, fl_text_display_find_line_end, "fl_text_display_find_line_end"); + pragma Inline (fl_text_display_find_line_end); + + function fl_text_display_find_x + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L, S, X : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_find_x, "fl_text_display_find_x"); + pragma Inline (fl_text_display_find_x); + + function fl_text_display_position_to_line + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int; + LN : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_to_line, "fl_text_display_position_to_line"); + pragma Inline (fl_text_display_position_to_line); + + function fl_text_display_position_to_linecol + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int; + LN, C : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_position_to_linecol, "fl_text_display_position_to_linecol"); + pragma Inline (fl_text_display_position_to_linecol); + + function fl_text_display_xy_to_position + (TD : in Storage.Integer_Address; + X, Y, K : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_xy_to_position, "fl_text_display_xy_to_position"); + pragma Inline (fl_text_display_xy_to_position); + + procedure fl_text_display_xy_to_rowcol + (TD : in Storage.Integer_Address; + X, Y : in Interfaces.C.int; + R, C : out Interfaces.C.int; + K : in Interfaces.C.int); + pragma Import (C, fl_text_display_xy_to_rowcol, "fl_text_display_xy_to_rowcol"); + pragma Inline (fl_text_display_xy_to_rowcol); + + + + + -- Cursors -- + + function fl_text_display_get_cursor_color + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_display_get_cursor_color, "fl_text_display_get_cursor_color"); + pragma Inline (fl_text_display_get_cursor_color); + + procedure fl_text_display_set_cursor_color + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_text_display_set_cursor_color, "fl_text_display_set_cursor_color"); + pragma Inline (fl_text_display_set_cursor_color); + + procedure fl_text_display_set_cursor_style + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_cursor_style, "fl_text_display_set_cursor_style"); + pragma Inline (fl_text_display_set_cursor_style); + + procedure fl_text_display_hide_cursor + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_hide_cursor, "fl_text_display_hide_cursor"); + pragma Inline (fl_text_display_hide_cursor); + + procedure fl_text_display_show_cursor + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_show_cursor, "fl_text_display_show_cursor"); + pragma Inline (fl_text_display_show_cursor); + + + + + -- Text Settings -- + + function fl_text_display_get_text_color + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_display_get_text_color, "fl_text_display_get_text_color"); + pragma Inline (fl_text_display_get_text_color); + + procedure fl_text_display_set_text_color + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_text_display_set_text_color, "fl_text_display_set_text_color"); + pragma Inline (fl_text_display_set_text_color); + + function fl_text_display_get_text_font + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_text_font, "fl_text_display_get_text_font"); + pragma Inline (fl_text_display_get_text_font); + + procedure fl_text_display_set_text_font + (TD : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_text_font, "fl_text_display_set_text_font"); + pragma Inline (fl_text_display_set_text_font); + + function fl_text_display_get_text_size + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_text_size, "fl_text_display_get_text_size"); + pragma Inline (fl_text_display_get_text_size); + + procedure fl_text_display_set_text_size + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_text_size, "fl_text_display_set_text_size"); + pragma Inline (fl_text_display_set_text_size); + + + + + -- Text Insert -- + + procedure fl_text_display_insert + (TD : in Storage.Integer_Address; + I : in Interfaces.C.char_array); + pragma Import (C, fl_text_display_insert, "fl_text_display_insert"); + pragma Inline (fl_text_display_insert); + + procedure fl_text_display_overstrike + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_text_display_overstrike, "fl_text_display_overstrike"); + pragma Inline (fl_text_display_overstrike); + + function fl_text_display_get_insert_pos + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_insert_pos, "fl_text_display_get_insert_pos"); + pragma Inline (fl_text_display_get_insert_pos); + + procedure fl_text_display_set_insert_pos + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_insert_pos, "fl_text_display_set_insert_pos"); + pragma Inline (fl_text_display_set_insert_pos); + + procedure fl_text_display_show_insert_pos + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_show_insert_pos, "fl_text_display_show_insert_pos"); + pragma Inline (fl_text_display_show_insert_pos); + + + + + -- Words -- + + function fl_text_display_word_start + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_word_start, "fl_text_display_word_start"); + pragma Inline (fl_text_display_word_start); + + function fl_text_display_word_end + (TD : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_word_end, "fl_text_display_word_end"); + pragma Inline (fl_text_display_word_end); + + procedure fl_text_display_next_word + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_next_word, "fl_text_display_next_word"); + pragma Inline (fl_text_display_next_word); + + procedure fl_text_display_previous_word + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_previous_word, "fl_text_display_previous_word"); + pragma Inline (fl_text_display_previous_word); + + + + + -- Wrapping -- + + procedure fl_text_display_wrap_mode + (TD : in Storage.Integer_Address; + W, M : in Interfaces.C.int); + pragma Import (C, fl_text_display_wrap_mode, "fl_text_display_wrap_mode"); + pragma Inline (fl_text_display_wrap_mode); + + function fl_text_display_wrapped_row + (TD : in Storage.Integer_Address; + R : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_wrapped_row, "fl_text_display_wrapped_row"); + pragma Inline (fl_text_display_wrapped_row); + + function fl_text_display_wrapped_column + (TD : in Storage.Integer_Address; + R, C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_wrapped_column, "fl_text_display_wrapped_column"); + pragma Inline (fl_text_display_wrapped_column); + + function fl_text_display_wrap_uses_character + (TD : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_wrap_uses_character, "fl_text_display_wrap_uses_character"); + pragma Inline (fl_text_display_wrap_uses_character); + + procedure fl_text_display_wrapped_line_counter + (TD, Buf : in Storage.Integer_Address; + SP, MP, ML, SPILS, SBO : in Interfaces.C.int; + RP, RL, RLS, RLE : out Interfaces.C.int; + CLLMNL : in Interfaces.C.int); + pragma Import (C, fl_text_display_wrapped_line_counter, "fl_text_display_wrapped_line_counter"); + pragma Inline (fl_text_display_wrapped_line_counter); + + + + + -- Lines -- + + function fl_text_display_line_start + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_line_start, "fl_text_display_line_start"); + pragma Inline (fl_text_display_line_start); + + function fl_text_display_line_end + (TD : in Storage.Integer_Address; + S, P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_line_end, "fl_text_display_line_end"); + pragma Inline (fl_text_display_line_end); + + function fl_text_display_count_lines + (TD : in Storage.Integer_Address; + S, F, P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_count_lines, "fl_text_display_count_lines"); + pragma Inline (fl_text_display_count_lines); + + function fl_text_display_skip_lines + (TD : in Storage.Integer_Address; + S, L, P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_skip_lines, "fl_text_display_skip_lines"); + pragma Inline (fl_text_display_skip_lines); + + function fl_text_display_rewind_lines + (TD : in Storage.Integer_Address; + S, L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_rewind_lines, "fl_text_display_rewind_lines"); + pragma Inline (fl_text_display_rewind_lines); + + procedure fl_text_display_calc_last_char + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_calc_last_char, "fl_text_display_calc_last_char"); + pragma Inline (fl_text_display_calc_last_char); + + procedure fl_text_display_calc_line_starts + (TD : in Storage.Integer_Address; + S, F : in Interfaces.C.int); + pragma Import (C, fl_text_display_calc_line_starts, "fl_text_display_calc_line_starts"); + pragma Inline (fl_text_display_calc_line_starts); + + procedure fl_text_display_offset_line_starts + (TD : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_text_display_offset_line_starts, "fl_text_display_offset_line_starts"); + pragma Inline (fl_text_display_offset_line_starts); + + + + + -- Absolute Lines -- + + procedure fl_text_display_absolute_top_line_number + (TD : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_text_display_absolute_top_line_number, + "fl_text_display_absolute_top_line_number"); + pragma Inline (fl_text_display_absolute_top_line_number); + + function fl_text_display_get_absolute_top_line_number + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_absolute_top_line_number, + "fl_text_display_get_absolute_top_line_number"); + pragma Inline (fl_text_display_get_absolute_top_line_number); + + procedure fl_text_display_maintain_absolute_top_line_number + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_text_display_maintain_absolute_top_line_number, + "fl_text_display_maintain_absolute_top_line_number"); + pragma Inline (fl_text_display_maintain_absolute_top_line_number); + + function fl_text_display_maintaining_absolute_top_line_number + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_maintaining_absolute_top_line_number, + "fl_text_display_maintaining_absolute_top_line_number"); + pragma Inline (fl_text_display_maintaining_absolute_top_line_number); + + procedure fl_text_display_reset_absolute_top_line_number + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_reset_absolute_top_line_number, + "fl_text_display_reset_absolute_top_line_number"); + pragma Inline (fl_text_display_reset_absolute_top_line_number); + + + + + -- Visible Lines -- + + function fl_text_display_empty_vlines + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_empty_vlines, "fl_text_display_empty_vlines"); + pragma Inline (fl_text_display_empty_vlines); + + function fl_text_display_longest_vline + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_longest_vline, "fl_text_display_longest_vline"); + pragma Inline (fl_text_display_longest_vline); + + function fl_text_display_vline_length + (TD : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_vline_length, "fl_text_display_vline_length"); + pragma Inline (fl_text_display_vline_length); + + + + + -- Line Numbers -- + + function fl_text_display_get_linenumber_align + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_display_get_linenumber_align, + "fl_text_display_get_linenumber_align"); + pragma Inline (fl_text_display_get_linenumber_align); + + procedure fl_text_display_set_linenumber_align + (TD : in Storage.Integer_Address; + A : in Interfaces.C.unsigned); + pragma Import (C, fl_text_display_set_linenumber_align, + "fl_text_display_set_linenumber_align"); + pragma Inline (fl_text_display_set_linenumber_align); + + function fl_text_display_get_linenumber_bgcolor + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_display_get_linenumber_bgcolor, + "fl_text_display_get_linenumber_bgcolor"); + pragma Inline (fl_text_display_get_linenumber_bgcolor); + + procedure fl_text_display_set_linenumber_bgcolor + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_text_display_set_linenumber_bgcolor, + "fl_text_display_set_linenumber_bgcolor"); + pragma Inline (fl_text_display_set_linenumber_bgcolor); + + function fl_text_display_get_linenumber_fgcolor + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_display_get_linenumber_fgcolor, + "fl_text_display_get_linenumber_fgcolor"); + pragma Inline (fl_text_display_get_linenumber_fgcolor); + + procedure fl_text_display_set_linenumber_fgcolor + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_text_display_set_linenumber_fgcolor, + "fl_text_display_set_linenumber_fgcolor"); + pragma Inline (fl_text_display_set_linenumber_fgcolor); + + function fl_text_display_get_linenumber_font + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_linenumber_font, + "fl_text_display_get_linenumber_font"); + pragma Inline (fl_text_display_get_linenumber_font); + + procedure fl_text_display_set_linenumber_font + (TD : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_linenumber_font, + "fl_text_display_set_linenumber_font"); + pragma Inline (fl_text_display_set_linenumber_font); + + function fl_text_display_get_linenumber_size + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_linenumber_size, + "fl_text_display_get_linenumber_size"); + pragma Inline (fl_text_display_get_linenumber_size); + + procedure fl_text_display_set_linenumber_size + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_linenumber_size, + "fl_text_display_set_linenumber_size"); + pragma Inline (fl_text_display_set_linenumber_size); + + function fl_text_display_get_linenumber_width + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_linenumber_width, + "fl_text_display_get_linenumber_width"); + pragma Inline (fl_text_display_get_linenumber_width); + + procedure fl_text_display_set_linenumber_width + (TD : in Storage.Integer_Address; + W : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_linenumber_width, + "fl_text_display_set_linenumber_width"); + pragma Inline (fl_text_display_set_linenumber_width); + + function fl_text_display_get_linenumber_format + (TD : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_text_display_get_linenumber_format, + "fl_text_display_get_linenumber_format"); + pragma Inline (fl_text_display_get_linenumber_format); + + procedure fl_text_display_set_linenumber_format + (TD : in Storage.Integer_Address; + V : in Interfaces.C.char_array); + pragma Import (C, fl_text_display_set_linenumber_format, + "fl_text_display_set_linenumber_format"); + pragma Inline (fl_text_display_set_linenumber_format); + + + + + -- Text Measurement -- + + function fl_text_display_measure_proportional_character + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + X, P : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_text_display_measure_proportional_character, + "fl_text_display_measure_proportional_character"); + pragma Inline (fl_text_display_measure_proportional_character); + + function fl_text_display_measure_vline + (TD : in Storage.Integer_Address; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_measure_vline, "fl_text_display_measure_vline"); + pragma Inline (fl_text_display_measure_vline); + + function fl_text_display_string_width + (TD : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L, S : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_text_display_string_width, "fl_text_display_string_width"); + pragma Inline (fl_text_display_string_width); + + + + + -- Movement -- + + function fl_text_display_move_down + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_move_down, "fl_text_display_move_down"); + pragma Inline (fl_text_display_move_down); + + function fl_text_display_move_left + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_move_left, "fl_text_display_move_left"); + pragma Inline (fl_text_display_move_left); + + function fl_text_display_move_right + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_move_right, "fl_text_display_move_right"); + pragma Inline (fl_text_display_move_right); + + function fl_text_display_move_up + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_move_up, "fl_text_display_move_up"); + pragma Inline (fl_text_display_move_up); + + + + + -- Scrolling -- + + procedure fl_text_display_scroll + (TD : in Storage.Integer_Address; + L, C : in Interfaces.C.int); + pragma Import (C, fl_text_display_scroll, "fl_text_display_scroll"); + pragma Inline (fl_text_display_scroll); + + function fl_text_display_scroll2 + (TD : in Storage.Integer_Address; + L, P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_scroll2, "fl_text_display_scroll2"); + pragma Inline (fl_text_display_scroll2); + + function fl_text_display_get_scrollbar_align + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_text_display_get_scrollbar_align, "fl_text_display_get_scrollbar_align"); + pragma Inline (fl_text_display_get_scrollbar_align); + + procedure fl_text_display_set_scrollbar_align + (TD : in Storage.Integer_Address; + A : in Interfaces.C.unsigned); + pragma Import (C, fl_text_display_set_scrollbar_align, "fl_text_display_set_scrollbar_align"); + pragma Inline (fl_text_display_set_scrollbar_align); + + function fl_text_display_get_scrollbar_width + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_scrollbar_width, "fl_text_display_get_scrollbar_width"); + pragma Inline (fl_text_display_get_scrollbar_width); + + procedure fl_text_display_set_scrollbar_width + (TD : in Storage.Integer_Address; + W : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_scrollbar_width, "fl_text_display_set_scrollbar_width"); + pragma Inline (fl_text_display_set_scrollbar_width); + + procedure fl_text_display_update_h_scrollbar + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_update_h_scrollbar, "fl_text_display_update_h_scrollbar"); + pragma Inline (fl_text_display_update_h_scrollbar); + + procedure fl_text_display_update_v_scrollbar + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_update_v_scrollbar, "fl_text_display_update_v_scrollbar"); + pragma Inline (fl_text_display_update_v_scrollbar); + + + + + -- Shortcuts -- + + function fl_text_display_get_shortcut + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_text_display_get_shortcut, "fl_text_display_get_shortcut"); + pragma Inline (fl_text_display_get_shortcut); + + procedure fl_text_display_set_shortcut + (TD : in Storage.Integer_Address; + V : in Interfaces.C.int); + pragma Import (C, fl_text_display_set_shortcut, "fl_text_display_set_shortcut"); + pragma Inline (fl_text_display_set_shortcut); + + + + + -- Dimensions -- + + procedure fl_text_display_resize + (TD : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_text_display_resize, "fl_text_display_resize"); + pragma Inline (fl_text_display_resize); + + + + + -- Drawing, Events -- + + procedure fl_text_display_clear_rect + (TD : in Storage.Integer_Address; + S, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_text_display_clear_rect, "fl_text_display_clear_rect"); + pragma Inline (fl_text_display_clear_rect); + + procedure fl_text_display_display_insert + (TD : in Storage.Integer_Address); + pragma Import (C, fl_text_display_display_insert, "fl_text_display_display_insert"); + pragma Inline (fl_text_display_display_insert); + + procedure fl_text_display_redisplay_range + (TD : in Storage.Integer_Address; + S, F : in Interfaces.C.int); + pragma Import (C, fl_text_display_redisplay_range, "fl_text_display_redisplay_range"); + pragma Inline (fl_text_display_redisplay_range); + + procedure fl_text_display_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_text_display_draw, "fl_text_display_draw"); + pragma Inline (fl_text_display_draw); + + procedure fl_text_display_draw_cursor + (TD : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_cursor, "fl_text_display_draw_cursor"); + pragma Inline (fl_text_display_draw_cursor); + + procedure fl_text_display_draw_line_numbers + (TD : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_line_numbers, "fl_text_display_draw_line_numbers"); + pragma Inline (fl_text_display_draw_line_numbers); + + procedure fl_text_display_draw_range + (TD : in Storage.Integer_Address; + S, F : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_range, "fl_text_display_draw_range"); + pragma Inline (fl_text_display_draw_range); + + procedure fl_text_display_draw_string + (TD : in Storage.Integer_Address; + S, X, Y, R : in Interfaces.C.int; + T : in Interfaces.C.char_array; + N : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_string, "fl_text_display_draw_string"); + pragma Inline (fl_text_display_draw_string); + + procedure fl_text_display_draw_text + (TD : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_text, "fl_text_display_draw_text"); + pragma Inline (fl_text_display_draw_text); + + procedure fl_text_display_draw_vline + (TD : in Storage.Integer_Address; + N, L, R, LC, RC : in Interfaces.C.int); + pragma Import (C, fl_text_display_draw_vline, "fl_text_display_draw_vline"); + pragma Inline (fl_text_display_draw_vline); + + function fl_text_display_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_display_handle, "fl_text_display_handle"); + pragma Inline (fl_text_display_handle); + + + + + ------------------------ + -- Internal Utility -- + ------------------------ + + function UChar_To_Mask is new Ada.Unchecked_Conversion + (Interfaces.C.unsigned_char, Styles.Style_Mask); + + function Cint_To_Style_Info + (Value : in Interfaces.C.int) + return Styles.Style_Info is + begin + return + (Mask => UChar_To_Mask (Interfaces.C.unsigned_char ((Value / 256) mod 256)), + Index => Styles.Style_Index (Character'Val (Value mod 256))); + end Cint_To_Style_Info; + + + function Mask_To_UChar is new Ada.Unchecked_Conversion + (Styles.Style_Mask, Interfaces.C.unsigned_char); + + function Style_Info_To_Cint + (Value : in Styles.Style_Info) + return Interfaces.C.int is + begin + return Interfaces.C.int (Mask_To_UChar (Value.Mask)) * 256 + + Character'Pos (Character (Value.Index)); + end Style_Info_To_Cint; + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + procedure Style_Hook + (C : in Interfaces.C.int; + D : in Storage.Integer_Address) + is + use Styles; -- for maximum stylin' + + Ada_Widget : constant access Text_Display'Class := + Text_Display_Convert.To_Pointer (Storage.To_Address (D)); + begin + if Ada_Widget.Style_Callback /= null then + Ada_Widget.Style_Callback (Character'Val (C), Text_Display (Ada_Widget.all)); + end if; + end Style_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Text_Display) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Text_Display) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_text_display (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + if This.Raw_Buffer /= Null_Pointer then + free_fl_text_buffer (This.Raw_Buffer); -- buffer is reference counted + This.Raw_Buffer := Null_Pointer; + end if; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Text_Display; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Text_Display) is + begin + This.Draw_Ptr := fl_text_display_draw'Address; + This.Handle_Ptr := fl_text_display_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Text_Display is + begin + return This : Text_Display do + This.Void_Ptr := new_fl_text_display + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Text_Display is + begin + return This : Text_Display := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Buffers -- + + function Get_Buffer + (This : in Text_Display) + return FLTK.Text_Buffers.Text_Buffer_Reference is + begin + return Ref : FLTK.Text_Buffers.Text_Buffer_Reference (This.Buffer); + end Get_Buffer; + + + procedure Set_Buffer + (This : in out Text_Display; + Buff : in out FLTK.Text_Buffers.Text_Buffer) is + begin + This.Buffer := Buff'Unchecked_Access; + fl_text_display_set_buffer (This.Void_Ptr, Wrapper (Buff).Void_Ptr); + if This.Raw_Buffer /= Null_Pointer then + free_fl_text_buffer (This.Raw_Buffer); + end if; + This.Raw_Buffer := Wrapper (Buff).Void_Ptr; + upref_fl_text_buffer (This.Raw_Buffer); + end Set_Buffer; + + + procedure Buffer_Modified_Callback + (This : in out Text_Display; + Action : in FLTK.Text_Buffers.Modification; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural; + Deleted_Text : in String) + is + Bytes_Inserted, Bytes_Deleted, Bytes_Restyled : Interfaces.C.int := 0; + C_Text : aliased Interfaces.C.char_array := Interfaces.C.To_C (Deleted_Text); + use type FLTK.Text_Buffers.Modification; + begin + case Action is + when FLTK.Text_Buffers.Insert => Bytes_Inserted := Interfaces.C.int (Length); + when FLTK.Text_Buffers.Restyle => Bytes_Restyled := Interfaces.C.int (Length); + when FLTK.Text_Buffers.Delete => Bytes_Deleted := Interfaces.C.int (Length); + when FLTK.Text_Buffers.None => null; + end case; + fl_text_display_buffer_modified_cb + (Interfaces.C.int (Place), + Bytes_Inserted, + Bytes_Deleted, + Bytes_Restyled, + (if Action = FLTK.Text_Buffers.Delete + then Interfaces.C.Strings.To_Chars_Ptr (C_Text'Unchecked_Access) + else Interfaces.C.Strings.Null_Ptr), + This.Void_Ptr); + end Buffer_Modified_Callback; + + + procedure Buffer_Predelete_Callback + (This : in out Text_Display; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural) is + begin + fl_text_display_buffer_predelete_cb + (Interfaces.C.int (Place), + Interfaces.C.int (Length), + This.Void_Ptr); + end Buffer_Predelete_Callback; + + + + + -- Highlighting -- + + procedure Highlight_Data + (This : in out Text_Display; + Buff : in out FLTK.Text_Buffers.Text_Buffer; + Table : in Styles.Style_Array) is + begin + fl_text_display_highlight_data + (This.Void_Ptr, + Wrapper (Buff).Void_Ptr, + (if Table'Length > 0 + then Storage.To_Integer (Table (Table'First)'Address) + else Null_Pointer), + Table'Length); + end Highlight_Data; + + + procedure Highlight_Data + (This : in out Text_Display; + Buff : in out FLTK.Text_Buffers.Text_Buffer; + Table : in Styles.Style_Array; + Unfinished : in Character; + Callback : in Styles.Unfinished_Style_Callback) is + begin + This.Style_Callback := Callback; + fl_text_display_highlight_data2 + (This.Void_Ptr, + Wrapper (Buff).Void_Ptr, + (if Table'Length > 0 + then Storage.To_Integer (Table (Table'First)'Address) + else Null_Pointer), + Table'Length, + Interfaces.C.To_C (Unfinished), + Storage.To_Integer (Style_Hook'Address), + Storage.To_Integer (This'Address)); + end Highlight_Data; + + + function Position_Style + (This : in Text_Display; + Line_Start : in Natural; + Line_Length : in Natural; + Line_Index : in Natural) + return Styles.Style_Info + is + Result : constant Interfaces.C.int := fl_text_display_position_style + (This.Void_Ptr, + Interfaces.C.int (Line_Start), + Interfaces.C.int (Line_Length), + Interfaces.C.int (Line_Index)); + begin + return Cint_To_Style_Info (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_style returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_Style; + + + + + -- Measurement Conversion -- + + function Col_To_X + (This : in Text_Display; + Col_Num : in Integer) + return Integer is + begin + return Integer (Interfaces.C.double'Rounding + (fl_text_display_col_to_x (This.Void_Ptr, Interfaces.C.double (Col_Num)))); + end Col_To_X; + + + function X_To_Col + (This : in Text_Display; + X_Pos : in Integer) + return Integer is + begin + return Integer (Interfaces.C.double'Rounding + (fl_text_display_x_to_col (This.Void_Ptr, Interfaces.C.double (X_Pos)))); + end X_To_Col; + + + function In_Selection + (This : in Text_Display; + X, Y : in Integer) + return Boolean is + begin + return fl_text_display_in_selection + (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)) /= 0; + end In_Selection; + + + procedure Position_To_XY + (This : in Text_Display; + Pos : in Integer; + X, Y : out Integer; + Vert_Out : out Boolean) is + begin + Vert_Out := fl_text_display_position_to_xy + (This.Void_Ptr, + Interfaces.C.int (Pos), + Interfaces.C.int (X), + Interfaces.C.int (Y)) /= 0; + end Position_To_XY; + + + procedure Find_Line_End + (This : in Text_Display; + Start : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Line_End : out Natural; + Next_Line_Start : out Natural) + is + C_Line_End, C_Next_Line_Start : Interfaces.C.int; + begin + fl_text_display_find_line_end + (This.Void_Ptr, + Interfaces.C.int (Start), + Boolean'Pos (Start_Pos_Is_Line_Start), + C_Line_End, C_Next_Line_Start); + Line_End := Natural (C_Line_End); + Next_Line_Start := Natural (C_Next_Line_Start); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::find_line_end returned unexpected int values of" & Latin.LF & + Latin.HT & "lineEnd = " & Interfaces.C.int'Image (C_Line_End) & Latin.LF & + Latin.HT & "nextLineStart = " & Interfaces.C.int'Image (C_Next_Line_Start); + end Find_Line_End; + + + function Find_Character + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index; + X : in Integer) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_find_x + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Text'Length, + Character'Pos (Character (Style)), + Interfaces.C.int (X)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::find_x returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Find_Character; + + + function Position_To_Line + (This : in Text_Display; + Position : in Natural) + return Natural + is + C_Line_Num : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_line + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num); + begin + pragma Assert (Result >= 0); + return Natural (C_Line_Num); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line; + + + function Position_To_Line + (This : in Text_Display; + Position : in Natural; + Displayed : out Boolean) + return Natural + is + C_Line_Num : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_line + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num); + begin + pragma Assert (Result >= 0); + Displayed := Result /= 0; + return Natural (C_Line_Num); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_line returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line; + + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural) + is + C_Line_Num, C_Column : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_linecol + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num, C_Column); + begin + Line := Natural (C_Line_Num); + Column := Natural (C_Column); + pragma Assert (Result >= 0); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int values of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line_Column; + + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural; + Displayed : out Boolean) + is + C_Line_Num, C_Column : Interfaces.C.int; + Result : constant Interfaces.C.int := fl_text_display_position_to_linecol + (This.Void_Ptr, + Interfaces.C.int (Position), + C_Line_Num, C_Column); + begin + Line := Natural (C_Line_Num); + Column := Natural (C_Column); + pragma Assert (Result >= 0); + Displayed := Result /= 0; + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int values of" & Latin.LF & + Latin.HT & "lineNum = " & Interfaces.C.int'Image (C_Line_Num) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column); + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::position_to_linecol returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Position_To_Line_Column; + + + function XY_To_Position + (This : in Text_Display; + X, Y : in Integer; + Kind : in Position_Kind := Character_Position) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_xy_to_position + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Position_Kind'Pos (Kind)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::xy_to_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end XY_To_Position; + + + procedure XY_To_Row_Column + (This : in Text_Display; + X, Y : in Integer; + Row, Column : out Natural; + Kind : in Position_Kind := Character_Position) + is + C_Row, C_Column : Interfaces.C.int; + begin + fl_text_display_xy_to_rowcol + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + C_Row, C_Column, + Position_Kind'Pos (Kind)); + Row := Natural (C_Row); + Column := Natural (C_Column); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::xy_to_rowcol returned unexpected int values of" & Latin.LF & + Latin.HT & "row = " & Interfaces.C.int'Image (C_Row) & Latin.LF & + Latin.HT & "column = " & Interfaces.C.int'Image (C_Column); + end XY_To_Row_Column; + + + + + -- Cursors -- + + function Get_Cursor_Color + (This : in Text_Display) + return Color is + begin + return Color (fl_text_display_get_cursor_color (This.Void_Ptr)); + end Get_Cursor_Color; + + + procedure Set_Cursor_Color + (This : in out Text_Display; + Col : in Color) is + begin + fl_text_display_set_cursor_color (This.Void_Ptr, Interfaces.C.unsigned (Col)); + end Set_Cursor_Color; + + + procedure Set_Cursor_Style + (This : in out Text_Display; + Style : in Cursor_Style) is + begin + fl_text_display_set_cursor_style (This.Void_Ptr, Cursor_Style'Pos (Style)); + end Set_Cursor_Style; + + + procedure Hide_Cursor + (This : in out Text_Display) is + begin + fl_text_display_hide_cursor (This.Void_Ptr); + end Hide_Cursor; + + + procedure Show_Cursor + (This : in out Text_Display) is + begin + fl_text_display_show_cursor (This.Void_Ptr); + end Show_Cursor; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Text_Display) + return Color is + begin + return Color (fl_text_display_get_text_color (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Text_Display; + Col : in Color) is + begin + fl_text_display_set_text_color (This.Void_Ptr, Interfaces.C.unsigned (Col)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Text_Display) + return Font_Kind is + begin + return Font_Kind'Val (fl_text_display_get_text_font (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Text_Display; + Font : in Font_Kind) is + begin + fl_text_display_set_text_font (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Text_Display) + return Font_Size is + begin + return Font_Size (fl_text_display_get_text_size (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Text_Display; + Size : in Font_Size) is + begin + fl_text_display_set_text_size (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Text Insert -- + + procedure Insert_Text + (This : in out Text_Display; + Item : in String) is + begin + fl_text_display_insert (This.Void_Ptr, Interfaces.C.To_C (Item)); + end Insert_Text; + + + procedure Overstrike + (This : in out Text_Display; + Text : in String) is + begin + fl_text_display_overstrike (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Overstrike; + + + function Get_Insert_Position + (This : in Text_Display) + return Natural is + begin + return Natural (fl_text_display_get_insert_pos (This.Void_Ptr)); + end Get_Insert_Position; + + + procedure Set_Insert_Position + (This : in out Text_Display; + Pos : in Natural) is + begin + fl_text_display_set_insert_pos (This.Void_Ptr, Interfaces.C.int (Pos)); + end Set_Insert_Position; + + + procedure Show_Insert_Position + (This : in out Text_Display) is + begin + fl_text_display_show_insert_pos (This.Void_Ptr); + end Show_Insert_Position; + + + + + -- Words -- + + function Word_Start + (This : in out Text_Display; + Pos : in Natural) + return Natural is + begin + return Natural (fl_text_display_word_start + (This.Void_Ptr, + Interfaces.C.int (Pos))); + end Word_Start; + + + function Word_End + (This : in out Text_Display; + Pos : in Natural) + return Natural is + begin + return Natural (fl_text_display_word_end + (This.Void_Ptr, + Interfaces.C.int (Pos))); + end Word_End; + + + procedure Next_Word + (This : in out Text_Display) is + begin + fl_text_display_next_word (This.Void_Ptr); + end Next_Word; + + + procedure Previous_Word + (This : in out Text_Display) is + begin + fl_text_display_previous_word (This.Void_Ptr); + end Previous_Word; + + + + + -- Wrapping -- + + procedure Set_Wrap_Mode + (This : in out Text_Display; + Mode : in Wrap_Mode; + Margin : in Natural := 0) is + begin + fl_text_display_wrap_mode + (This.Void_Ptr, + Wrap_Mode'Pos (Mode), + Interfaces.C.int (Margin)); + end Set_Wrap_Mode; + + + function Wrapped_Row + (This : in Text_Display; + Row : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_wrapped_row + (This.Void_Ptr, + Interfaces.C.int (Row)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrapped_row returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Wrapped_Row; + + + function Wrapped_Column + (This : in Text_Display; + Row, Column : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_wrapped_column + (This.Void_Ptr, + Interfaces.C.int (Row), + Interfaces.C.int (Column)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrapped_column returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Wrapped_Column; + + + function Wrap_Uses_Character + (This : in Text_Display; + Line_End : in Natural) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_wrap_uses_character + (This.Void_Ptr, + Interfaces.C.int (Line_End)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrap_uses_character returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Wrap_Uses_Character; + + + procedure Count_Wrapped_Lines + (This : in Text_Display; + Buffer : in FLTK.Text_Buffers.Text_Buffer; + Start : in Natural; + Max_Position, Max_Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Style_Offset : in Natural; + Finish, Line_Count : out Natural; + End_Count_Line_Start : out Natural; + Last_Line_End : out Natural; + Count_Last_Missing_Newline : in Boolean := True) + is + C_Finish, C_Line_Count, C_End_Count_Line_Start, C_Last_Line_End : Interfaces.C.int; + begin + fl_text_display_wrapped_line_counter + (This.Void_Ptr, + Wrapper (Buffer).Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Max_Position), + Interfaces.C.int (Max_Lines), + Boolean'Pos (Start_Pos_Is_Line_Start), + Interfaces.C.int (Style_Offset), + C_Finish, + C_Line_Count, + C_End_Count_Line_Start, + C_Last_Line_End, + Boolean'Pos (Count_Last_Missing_Newline)); + Finish := Natural (C_Finish); + Line_Count := Natural (C_Line_Count); + End_Count_Line_Start := Natural (C_End_Count_Line_Start); + Last_Line_End := Natural (C_Last_Line_End); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::wrapped_line_counter returned unexpected int values of" & Latin.LF & + Latin.HT & "retPos = " & Interfaces.C.int'Image (C_Finish) & Latin.LF & + Latin.HT & "retLines = " & Interfaces.C.int'Image (C_Line_Count) & Latin.LF & + Latin.HT & "retLineStart = " & Interfaces.C.int'Image (C_End_Count_Line_Start) & Latin.LF & + Latin.HT & "retLineEnd = " & Interfaces.C.int'Image (C_Last_Line_End); + end Count_Wrapped_Lines; + + + + + -- Lines -- + + function Line_Start + (This : in Text_Display; + Pos : in Natural) + return Natural is + begin + return Natural (fl_text_display_line_start + (This.Void_Ptr, + Interfaces.C.int (Pos))); + end Line_Start; + + + function Line_End + (This : in Text_Display; + Pos : in Natural; + Start_Pos_Is_Line_Start : in Boolean := False) + return Natural is + begin + return Natural (fl_text_display_line_end + (This.Void_Ptr, + Interfaces.C.int (Pos), + Boolean'Pos (Start_Pos_Is_Line_Start))); + end Line_End; + + + function Count_Lines + (This : in Text_Display; + Start, Finish : in Natural; + Start_Pos_Is_Line_Start : in Boolean := False) + return Natural is + begin + return Natural (fl_text_display_count_lines + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish), + Boolean'Pos (Start_Pos_Is_Line_Start))); + end Count_Lines; + + + function Skip_Lines + (This : in Text_Display; + Start, Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean := False) + return Natural is + begin + return Natural (fl_text_display_skip_lines + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines), + Boolean'Pos (Start_Pos_Is_Line_Start))); + end Skip_Lines; + + + function Rewind_Lines + (This : in Text_Display; + Start, Lines : in Natural) + return Natural is + begin + return Natural (fl_text_display_rewind_lines + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Lines))); + end Rewind_Lines; + + + procedure Calculate_Last_Character + (This : in out Text_Display) is + begin + fl_text_display_calc_last_char (This.Void_Ptr); + end Calculate_Last_Character; + + + procedure Calculate_Line_Starts + (This : in out Text_Display; + Start, Finish : in Natural) is + begin + fl_text_display_calc_line_starts + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Calculate_Line_Starts; + + + procedure Offset_Line_Starts + (This : in out Text_Display; + New_Top : in Natural) is + begin + fl_text_display_offset_line_starts + (This.Void_Ptr, + Interfaces.C.int (New_Top)); + end Offset_Line_Starts; + + + + + -- Absolute Lines -- + + procedure Redo_Absolute_Top_Line + (This : in out Text_Display; + Old_First : in Natural) is + begin + fl_text_display_absolute_top_line_number (This.Void_Ptr, Interfaces.C.int (Old_First)); + end Redo_Absolute_Top_Line; + + + function Get_Absolute_Top_Line + (This : in Text_Display) + return Natural + is + Result : constant Interfaces.C.int := + fl_text_display_get_absolute_top_line_number (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::get_absolute_top_line_number returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Absolute_Top_Line; + + + procedure Maintain_Absolute_Top_Line + (This : in out Text_Display; + State : in Boolean := True) is + begin + fl_text_display_maintain_absolute_top_line_number (This.Void_Ptr, Boolean'Pos (State)); + end Maintain_Absolute_Top_Line; + + + function Maintaining_Absolute_Top_Line + (This : in Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_maintaining_absolute_top_line_number + (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::maintaining_absolute_top_line_number returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Maintaining_Absolute_Top_Line; + + + procedure Reset_Absolute_Top_Line + (This : in out Text_Display) is + begin + fl_text_display_reset_absolute_top_line_number (This.Void_Ptr); + end Reset_Absolute_Top_Line; + + + + + -- Visible Lines -- + + function Has_Empty_Visible_Lines + (This : in Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_empty_vlines (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::empty_vlines returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Has_Empty_Visible_Lines; + + + function Get_Longest_Visible_Line + (This : in Text_Display) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_longest_vline (This.Void_Ptr); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::longest_vline returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Longest_Visible_Line; + + + function Visible_Line_Length + (This : in Text_Display; + Line : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_vline_length + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::vline_length returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Visible_Line_Length; + + + + + -- Line Numbers -- + + function Get_Linenumber_Alignment + (This : in Text_Display) + return Alignment is + begin + return Alignment (fl_text_display_get_linenumber_align (This.Void_Ptr)); + end Get_Linenumber_Alignment; + + + procedure Set_Linenumber_Alignment + (This : in out Text_Display; + To : in Alignment) is + begin + fl_text_display_set_linenumber_align + (This.Void_Ptr, + Interfaces.C.unsigned (To)); + end Set_Linenumber_Alignment; + + + function Get_Linenumber_Back_Color + (This : in Text_Display) + return Color is + begin + return Color (fl_text_display_get_linenumber_bgcolor (This.Void_Ptr)); + end Get_Linenumber_Back_Color; + + + procedure Set_Linenumber_Back_Color + (This : in out Text_Display; + To : in Color) is + begin + fl_text_display_set_linenumber_bgcolor + (This.Void_Ptr, + Interfaces.C.unsigned (To)); + end Set_Linenumber_Back_Color; + + + function Get_Linenumber_Fore_Color + (This : in Text_Display) + return Color is + begin + return Color (fl_text_display_get_linenumber_fgcolor (This.Void_Ptr)); + end Get_Linenumber_Fore_Color; + + + procedure Set_Linenumber_Fore_Color + (This : in out Text_Display; + To : in Color) is + begin + fl_text_display_set_linenumber_fgcolor + (This.Void_Ptr, + Interfaces.C.unsigned (To)); + end Set_Linenumber_Fore_Color; + + + function Get_Linenumber_Font + (This : in Text_Display) + return Font_Kind is + begin + return Font_Kind'Val (fl_text_display_get_linenumber_font (This.Void_Ptr)); + end Get_Linenumber_Font; + + + procedure Set_Linenumber_Font + (This : in out Text_Display; + To : in Font_Kind) is + begin + fl_text_display_set_linenumber_font + (This.Void_Ptr, + Font_Kind'Pos (To)); + end Set_Linenumber_Font; + + + function Get_Linenumber_Size + (This : in Text_Display) + return Font_Size is + begin + return Font_Size (fl_text_display_get_linenumber_size (This.Void_Ptr)); + end Get_Linenumber_Size; + + + procedure Set_Linenumber_Size + (This : in out Text_Display; + To : in Font_Size) is + begin + fl_text_display_set_linenumber_size + (This.Void_Ptr, + Interfaces.C.int (To)); + end Set_Linenumber_Size; + + + function Get_Linenumber_Width + (This : in Text_Display) + return Natural is + begin + return Natural (fl_text_display_get_linenumber_width (This.Void_Ptr)); + end Get_Linenumber_Width; + + + procedure Set_Linenumber_Width + (This : in out Text_Display; + Width : in Natural) is + begin + fl_text_display_set_linenumber_width + (This.Void_Ptr, + Interfaces.C.int (Width)); + end Set_Linenumber_Width; + + + function Get_Linenumber_Format + (This : in Text_Display) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := + fl_text_display_get_linenumber_format (This.Void_Ptr); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Linenumber_Format; + + + procedure Set_Linenumber_Format + (This : in out Text_Display; + Value : in String) is + begin + fl_text_display_set_linenumber_format (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Linenumber_Format; + + + + + -- Text Measurement -- + + function Measure_Character + (This : in Text_Display; + Text : in String; + X : in Integer; + Index : in Positive) + return Long_Float is + begin + return Long_Float (fl_text_display_measure_proportional_character + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.int (X), + Interfaces.C.int (Index) - 1)); + end Measure_Character; + + + function Measure_Visible_Line + (This : in Text_Display; + Line : in Natural) + return Natural + is + Result : constant Interfaces.C.int := fl_text_display_measure_vline + (This.Void_Ptr, + Interfaces.C.int (Line)); + begin + return Natural (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::measure_vline returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Measure_Visible_Line; + + + function Measure_String + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index) + return Long_Float is + begin + return Long_Float (fl_text_display_string_width + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Text'Length, + Character'Pos (Character (Style)))); + end Measure_String; + + + + + -- Movement -- + + procedure Move_Down + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_down returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Down; + + + function Move_Down + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_down (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_down returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Down; + + + procedure Move_Left + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_left returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Left; + + + function Move_Left + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_left (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_left returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Left; + + + procedure Move_Right + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_right returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Right; + + + function Move_Right + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_right (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_right returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Right; + + + procedure Move_Up + (This : in out Text_Display) + is + Result : constant Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_up returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Up; + + + function Move_Up + (This : in out Text_Display) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_move_up (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::move_up returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Move_Up; + + + + + -- Scrolling -- + + procedure Scroll_To + (This : in out Text_Display; + Line : in Natural; + Column : in Natural := 0) is + begin + fl_text_display_scroll + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.int (Column)); + end Scroll_To; + + + function Scroll_To + (This : in out Text_Display; + Line : in Natural; + Pixel : in Natural := 0) + return Boolean + is + Result : constant Interfaces.C.int := fl_text_display_scroll2 + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.int (Pixel)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Text_Display::scroll_ returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Scroll_To; + + + function Get_Scrollbar_Alignment + (This : in Text_Display) + return Alignment is + begin + return Alignment (fl_text_display_get_scrollbar_align (This.Void_Ptr)); + end Get_Scrollbar_Alignment; + + + procedure Set_Scrollbar_Alignment + (This : in out Text_Display; + Align : in Alignment) is + begin + fl_text_display_set_scrollbar_align + (This.Void_Ptr, + Interfaces.C.unsigned (Align)); + end Set_Scrollbar_Alignment; + + + function Get_Scrollbar_Width + (This : in Text_Display) + return Natural is + begin + return Natural (fl_text_display_get_scrollbar_width (This.Void_Ptr)); + end Get_Scrollbar_Width; + + + procedure Set_Scrollbar_Width + (This : in out Text_Display; + Width : in Natural) is + begin + fl_text_display_set_scrollbar_width + (This.Void_Ptr, + Interfaces.C.int (Width)); + end Set_Scrollbar_Width; + + + procedure Update_Horizontal_Scrollbar + (This : in out Text_Display) is + begin + fl_text_display_update_h_scrollbar (This.Void_Ptr); + end Update_Horizontal_Scrollbar; + + + procedure Update_Vertical_Scrollbar + (This : in out Text_Display) is + begin + fl_text_display_update_v_scrollbar (This.Void_Ptr); + end Update_Vertical_Scrollbar; + + + + + -- Shortcuts -- + + function Get_Shortcut + (This : in Text_Display) + return Key_Combo is + begin + return To_Ada (Interfaces.C.unsigned (fl_text_display_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Text_Display; + Value : in Key_Combo) is + begin + fl_text_display_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (Value))); + end Set_Shortcut; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Text_Display; + X, Y, W, H : in Integer) is + begin + fl_text_display_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Drawing, Events -- + + procedure Clear_Rect + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y, W, H : in Integer) is + begin + fl_text_display_clear_rect + (This.Void_Ptr, + Style_Info_To_Cint (Style), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Clear_Rect; + + + procedure Display_Insert + (This : in out Text_Display) is + begin + fl_text_display_display_insert (This.Void_Ptr); + end Display_Insert; + + + procedure Redisplay_Range + (This : in out Text_Display; + Start, Finish : in Natural) is + begin + fl_text_display_redisplay_range + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Redisplay_Range; + + + procedure Draw + (This : in out Text_Display) is + begin + Group (This).Draw; + end Draw; + + + procedure Draw_Cursor + (This : in out Text_Display; + X, Y : in Integer) is + begin + fl_text_display_draw_cursor + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Draw_Cursor; + + + procedure Draw_Line_Numbers + (This : in out Text_Display; + Clear : in Boolean := False) is + begin + fl_text_display_draw_line_numbers (This.Void_Ptr, Boolean'Pos (Clear)); + end Draw_Line_Numbers; + + + procedure Draw_Range + (This : in out Text_Display; + Start, Finish : in Natural) is + begin + fl_text_display_draw_range + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + end Draw_Range; + + + procedure Draw_String + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y : in Integer; + Right : in Integer; + Text : in String; + Num_Chars : in Natural) is + begin + fl_text_display_draw_string + (This.Void_Ptr, + Style_Info_To_Cint (Style), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (Right), + Interfaces.C.To_C (Text), + Interfaces.C.int (Num_Chars)); + end Draw_String; + + + procedure Draw_Text + (This : in out Text_Display; + X, Y, W, H : in Integer) is + begin + fl_text_display_draw_text + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Text; + + + procedure Draw_Visible_Line + (This : in out Text_Display; + Line : in Natural; + Left_Clip, Right_Clip : in Integer; + Left_Char, Right_Char : in Natural) is + begin + fl_text_display_draw_vline + (This.Void_Ptr, + Interfaces.C.int (Line), + Interfaces.C.int (Left_Clip), + Interfaces.C.int (Right_Clip), + Interfaces.C.int (Left_Char), + Interfaces.C.int (Right_Char)); + end Draw_Visible_Line; + + + function Handle + (This : in out Text_Display; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Text_Displays; + + diff --git a/body/fltk-widgets-groups-tiled.adb b/body/fltk-widgets-groups-tiled.adb new file mode 100644 index 0000000..a169e0e --- /dev/null +++ b/body/fltk-widgets-groups-tiled.adb @@ -0,0 +1,196 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Widgets.Groups.Tiled is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_tile + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_tile, "new_fl_tile"); + pragma Inline (new_fl_tile); + + procedure free_fl_tile + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_tile, "free_fl_tile"); + pragma Inline (free_fl_tile); + + + + + -- Dimensions -- + + procedure fl_tile_position + (T : in Storage.Integer_Address; + OX, OY, NX, NY : in Interfaces.C.int); + pragma Import (C, fl_tile_position, "fl_tile_position"); + pragma Inline (fl_tile_position); + + procedure fl_tile_resize + (T : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_tile_resize, "fl_tile_resize"); + pragma Inline (fl_tile_resize); + + + + + -- Drawing, Events -- + + procedure fl_tile_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_tile_draw, "fl_tile_draw"); + pragma Inline (fl_tile_draw); + + function fl_tile_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_tile_handle, "fl_tile_handle"); + pragma Inline (fl_tile_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Tiled_Group) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Tiled_Group) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_tile (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Tiled_Group; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Tiled_Group) is + begin + This.Draw_Ptr := fl_tile_draw'Address; + This.Handle_Ptr := fl_tile_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Tiled_Group is + begin + return This : Tiled_Group do + This.Void_Ptr := new_fl_tile + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Tiled_Group is + begin + return This : Tiled_Group := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Dimensions -- + + procedure Position + (This : in out Tiled_Group; + Old_X, Old_Y : in Integer; + New_X, New_Y : in Integer) is + begin + fl_tile_position + (This.Void_Ptr, + Interfaces.C.int (Old_X), Interfaces.C.int (Old_Y), + Interfaces.C.int (New_X), Interfaces.C.int (New_Y)); + end Position; + + + procedure Resize + (This : in out Tiled_Group; + X, Y, W, H : in Integer) is + begin + fl_tile_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Events -- + + function Handle + (This : in out Tiled_Group; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Tiled; + + diff --git a/body/fltk-widgets-groups-windows-double-cairo.adb b/body/fltk-widgets-groups-windows-double-cairo.adb new file mode 100644 index 0000000..1560c20 --- /dev/null +++ b/body/fltk-widgets-groups-windows-double-cairo.adb @@ -0,0 +1,259 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C, + System.Address_To_Access_Conversions; + + +package body FLTK.Widgets.Groups.Windows.Double.Cairo is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_cairo_window + (W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_cairo_window, "new_fl_cairo_window"); + pragma Inline (new_fl_cairo_window); + + procedure free_fl_cairo_window + (W : in Storage.Integer_Address); + pragma Import (C, free_fl_cairo_window, "free_fl_cairo_window"); + pragma Inline (free_fl_cairo_window); + + + + + -- Cairo Callback -- + + procedure fl_cairo_window_set_draw_cb + (W, F : in Storage.Integer_Address); + pragma Import (C, fl_cairo_window_set_draw_cb, "fl_cairo_window_set_draw_cb"); + pragma Inline (fl_cairo_window_set_draw_cb); + + + + + -- Drawing, Events -- + + procedure fl_cairo_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_cairo_window_draw, "fl_cairo_window_draw"); + pragma Inline (fl_cairo_window_draw); + + function fl_cairo_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_cairo_window_handle, "fl_cairo_window_handle"); + pragma Inline (fl_cairo_window_handle); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + package Cairo_Convert is new System.Address_To_Access_Conversions (Cairo_Window'Class); + + + procedure Cairo_Draw_Hook + (C_Addr, Cairo_Addr : in Storage.Integer_Address); + + pragma Convention (C, Cairo_Draw_Hook); + + procedure Cairo_Draw_Hook + (C_Addr, Cairo_Addr : in Storage.Integer_Address) + is + Ada_Addr : constant System.Address := + Storage.To_Address (fl_widget_get_user_data (C_Addr)); + Ada_Object : constant access Cairo_Window'Class := + Cairo_Convert.To_Pointer (Ada_Addr); + begin + pragma Assert (Ada_Object /= null); + if Ada_Object.My_Func /= null then + Ada_Object.My_Func (Cairo_Window (Ada_Object.all), Storage.To_Address (Cairo_Addr)); + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Cairo_Window draw hook received Widget with no user_data reference back to Ada"; + end Cairo_Draw_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Cairo_Window) is + begin + Extra_Final (Double_Window (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Cairo_Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_cairo_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Cairo_Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + fl_cairo_window_set_draw_cb (This.Void_Ptr, Storage.To_Integer (Cairo_Draw_Hook'Address)); + Extra_Init (Double_Window (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Cairo_Window) is + begin + This.Draw_Ptr := fl_cairo_window_draw'Address; + This.Handle_Ptr := fl_cairo_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Cairo_Window is + begin + return This : Cairo_Window do + This.Void_Ptr := new_fl_cairo_window + (Interfaces.C.int (W), + Interfaces.C.int (H)); + This.Reposition (X, Y); + This.Set_Label (Text); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Cairo_Window is + begin + return This : Cairo_Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String) + return Cairo_Window is + begin + return This : Cairo_Window do + This.Void_Ptr := new_fl_cairo_window + (Interfaces.C.int (W), + Interfaces.C.int (H)); + This.Set_Label (Text); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String) + return Cairo_Window is + begin + return This : Cairo_Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer) + return Cairo_Window is + begin + return This : Cairo_Window do + This.Void_Ptr := new_fl_cairo_window + (Interfaces.C.int (W), + Interfaces.C.int (H)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, This.Get_Label); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer) + return Cairo_Window is + begin + return This : Cairo_Window := Create (W, H) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Cairo Callback -- + + procedure Set_Cairo_Draw + (This : in out Cairo_Window; + Func : in Cairo_Callback) is + begin + This.My_Func := Func; + end Set_Cairo_Draw; + + + + + -- Drawing -- + + procedure Draw + (This : in out Cairo_Window) is + begin + Double_Window (This).Draw; + end Draw; + + +end FLTK.Widgets.Groups.Windows.Double.Cairo; + + diff --git a/body/fltk-widgets-groups-windows-double-overlay.adb b/body/fltk-widgets-groups-windows-double-overlay.adb new file mode 100644 index 0000000..94542af --- /dev/null +++ b/body/fltk-widgets-groups-windows-double-overlay.adb @@ -0,0 +1,323 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Args_Marshal, + Interfaces.C, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Windows.Double.Overlay is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_overlay_window + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_overlay_window, "new_fl_overlay_window"); + pragma Inline (new_fl_overlay_window); + + function new_fl_overlay_window2 + (W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_overlay_window2, "new_fl_overlay_window2"); + pragma Inline (new_fl_overlay_window2); + + procedure free_fl_overlay_window + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_overlay_window, "free_fl_overlay_window"); + pragma Inline (free_fl_overlay_window); + + + + + -- Visibility -- + + procedure fl_overlay_window_show + (W : in Storage.Integer_Address); + pragma Import (C, fl_overlay_window_show, "fl_overlay_window_show"); + pragma Inline (fl_overlay_window_show); + + procedure fl_overlay_window_show2 + (W : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_overlay_window_show2, "fl_overlay_window_show2"); + pragma Inline (fl_overlay_window_show2); + + procedure fl_overlay_window_hide + (W : in Storage.Integer_Address); + pragma Import (C, fl_overlay_window_hide, "fl_overlay_window_hide"); + pragma Inline (fl_overlay_window_hide); + + procedure fl_overlay_window_flush + (W : in Storage.Integer_Address); + pragma Import (C, fl_overlay_window_flush, "fl_overlay_window_flush"); + pragma Inline (fl_overlay_window_flush); + + + + + -- Settings -- + + function fl_overlay_window_can_do_overlay + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_overlay_window_can_do_overlay, "fl_overlay_window_can_do_overlay"); + pragma Inline (fl_overlay_window_can_do_overlay); + + procedure fl_overlay_window_resize + (OW : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_overlay_window_resize, "fl_overlay_window_resize"); + pragma Inline (fl_overlay_window_resize); + + + + + -- Drawing, Events -- + + procedure fl_overlay_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_overlay_window_draw, "fl_overlay_window_draw"); + pragma Inline (fl_overlay_window_draw); + + procedure fl_overlay_window_redraw_overlay + (W : in Storage.Integer_Address); + pragma Import (C, fl_overlay_window_redraw_overlay, "fl_overlay_window_redraw_overlay"); + pragma Inline (fl_overlay_window_redraw_overlay); + + function fl_overlay_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_overlay_window_handle, "fl_overlay_window_handle"); + pragma Inline (fl_overlay_window_handle); + + + + + ---------------------- + -- Exported Hooks -- + ---------------------- + + package Over_Convert is new System.Address_To_Access_Conversions (Overlay_Window'Class); + + procedure Overlay_Window_Draw_Overlay_Hook + (U : in Storage.Integer_Address); + pragma Export (C, Overlay_Window_Draw_Overlay_Hook, "overlay_window_draw_overlay_hook"); + + procedure Overlay_Window_Draw_Overlay_Hook + (U : in Storage.Integer_Address) + is + Overlay_Widget : constant access Overlay_Window'Class := + Over_Convert.To_Pointer (Storage.To_Address (U)); + begin + Overlay_Widget.Draw_Overlay; + end Overlay_Window_Draw_Overlay_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Overlay_Window) is + begin + Extra_Final (Double_Window (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Overlay_Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_overlay_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Overlay_Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Double_Window (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Overlay_Window) is + begin + This.Draw_Ptr := fl_overlay_window_draw'Address; + This.Handle_Ptr := fl_overlay_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Overlay_Window is + begin + return This : Overlay_Window do + This.Void_Ptr := new_fl_overlay_window + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Overlay_Window is + begin + return This : Overlay_Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String := "") + return Overlay_Window is + begin + return This : Overlay_Window do + This.Void_Ptr := new_fl_overlay_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return Overlay_Window is + begin + return This : Overlay_Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out Overlay_Window) is + begin + fl_overlay_window_show (This.Void_Ptr); + end Show; + + + procedure Show_With_Args + (This : in out Overlay_Window) is + begin + FLTK.Args_Marshal.Dispatch (fl_overlay_window_show2'Access, This.Void_Ptr); + end Show_With_Args; + + + procedure Hide + (This : in out Overlay_Window) is + begin + fl_overlay_window_hide (This.Void_Ptr); + end Hide; + + + procedure Flush + (This : in out Overlay_Window) is + begin + fl_overlay_window_flush (This.Void_Ptr); + end Flush; + + + + + -- Settings -- + + function Can_Do_Overlay + (This : in Overlay_Window) + return Boolean is + begin + return fl_overlay_window_can_do_overlay (This.Void_Ptr) /= 0; + end Can_Do_Overlay; + + + procedure Resize + (This : in out Overlay_Window; + X, Y, W, H : in Integer) is + begin + fl_overlay_window_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Drawing, Events -- + + procedure Draw_Overlay + (This : in out Overlay_Window) is + begin + raise Program_Error with "You must override Draw_Overlay"; + end Draw_Overlay; + + + procedure Redraw_Overlay + (This : in out Overlay_Window) is + begin + fl_overlay_window_redraw_overlay (This.Void_Ptr); + end Redraw_Overlay; + + +end FLTK.Widgets.Groups.Windows.Double.Overlay; + + diff --git a/body/fltk-widgets-groups-windows-double.adb b/body/fltk-widgets-groups-windows-double.adb new file mode 100644 index 0000000..9c388e0 --- /dev/null +++ b/body/fltk-widgets-groups-windows-double.adb @@ -0,0 +1,272 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Args_Marshal, + Interfaces.C; + + +package body FLTK.Widgets.Groups.Windows.Double is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_double_window + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_double_window, "new_fl_double_window"); + pragma Inline (new_fl_double_window); + + function new_fl_double_window2 + (X, Y : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_double_window2, "new_fl_double_window2"); + pragma Inline (new_fl_double_window2); + + procedure free_fl_double_window + (W : in Storage.Integer_Address); + pragma Import (C, free_fl_double_window, "free_fl_double_window"); + pragma Inline (free_fl_double_window); + + + + + -- Visibility -- + + procedure fl_double_window_show + (W : in Storage.Integer_Address); + pragma Import (C, fl_double_window_show, "fl_double_window_show"); + pragma Inline (fl_double_window_show); + + procedure fl_double_window_show2 + (W : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_double_window_show2, "fl_double_window_show2"); + pragma Inline (fl_double_window_show2); + + procedure fl_double_window_hide + (W : in Storage.Integer_Address); + pragma Import (C, fl_double_window_hide, "fl_double_window_hide"); + pragma Inline (fl_double_window_hide); + + procedure fl_double_window_flush + (W : in Storage.Integer_Address); + pragma Import (C, fl_double_window_flush, "fl_double_window_flush"); + pragma Inline (fl_double_window_flush); + + procedure fl_double_window_flush2 + (W : in Storage.Integer_Address; + E : in Interfaces.C.int); + pragma Import (C, fl_double_window_flush2, "fl_double_window_flush2"); + pragma Inline (fl_double_window_flush2); + + + + + -- Dimensions -- + + procedure fl_double_window_resize + (DW : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_double_window_resize, "fl_double_window_resize"); + pragma Inline (fl_double_window_resize); + + + + + -- Drawing, Events -- + + procedure fl_double_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_double_window_draw, "fl_double_window_draw"); + pragma Inline (fl_double_window_draw); + + function fl_double_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_double_window_handle, "fl_double_window_handle"); + pragma Inline (fl_double_window_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Double_Window) is + begin + Extra_Final (Window (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Double_Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_double_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Double_Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Window (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Double_Window) is + begin + This.Draw_Ptr := fl_double_window_draw'Address; + This.Handle_Ptr := fl_double_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Double_Window is + begin + return This : Double_Window do + This.Void_Ptr := new_fl_double_window + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Double_Window is + begin + return This : Double_Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String := "") + return Double_Window is + begin + return This : Double_Window do + This.Void_Ptr := new_fl_double_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return Double_Window is + begin + return This : Double_Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out Double_Window) is + begin + fl_double_window_show (This.Void_Ptr); + end Show; + + + procedure Show_With_Args + (This : in out Double_Window) is + begin + FLTK.Args_Marshal.Dispatch (fl_double_window_show2'Access, This.Void_Ptr); + end Show_With_Args; + + + procedure Hide + (This : in out Double_Window) is + begin + fl_double_window_hide (This.Void_Ptr); + end Hide; + + + procedure Flush + (This : in out Double_Window) is + begin + fl_double_window_flush (This.Void_Ptr); + end Flush; + + + procedure Flush_All + (This : in out Double_Window) is + begin + fl_double_window_flush2 (This.Void_Ptr, 1); + end Flush_All; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Double_Window; + X, Y, W, H : in Integer) is + begin + fl_double_window_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + +end FLTK.Widgets.Groups.Windows.Double; + + diff --git a/body/fltk-widgets-groups-windows-opengl.adb b/body/fltk-widgets-groups-windows-opengl.adb new file mode 100644 index 0000000..df61bd9 --- /dev/null +++ b/body/fltk-widgets-groups-windows-opengl.adb @@ -0,0 +1,585 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Args_Marshal, + Interfaces.C; + +use type + + Interfaces.C.int, + Interfaces.C.signed_char, + Interfaces.C.unsigned; + + +package body FLTK.Widgets.Groups.Windows.OpenGL is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_gl_window + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_gl_window, "new_fl_gl_window"); + pragma Inline (new_fl_gl_window); + + function new_fl_gl_window2 + (W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_gl_window2, "new_fl_gl_window2"); + pragma Inline (new_fl_gl_window2); + + procedure free_fl_gl_window + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_gl_window, "free_fl_gl_window"); + pragma Inline (free_fl_gl_window); + + + + + -- Visibility -- + + procedure fl_gl_window_show + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_show, "fl_gl_window_show"); + pragma Inline (fl_gl_window_show); + + procedure fl_gl_window_show2 + (S : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_show2, "fl_gl_window_show2"); + pragma Inline (fl_gl_window_show2); + + procedure fl_gl_window_hide + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_hide, "fl_gl_window_hide"); + pragma Inline (fl_gl_window_hide); + + procedure fl_gl_window_hide_overlay + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_hide_overlay, "fl_gl_window_hide_overlay"); + pragma Inline (fl_gl_window_hide_overlay); + + procedure fl_gl_window_flush + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_flush, "fl_gl_window_flush"); + pragma Inline (fl_gl_window_flush); + + + + + -- Dimensions -- + + function fl_gl_window_pixel_h + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_gl_window_pixel_h, "fl_gl_window_pixel_h"); + pragma Inline (fl_gl_window_pixel_h); + + function fl_gl_window_pixel_w + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_gl_window_pixel_w, "fl_gl_window_pixel_w"); + pragma Inline (fl_gl_window_pixel_w); + + function fl_gl_window_pixels_per_unit + (S : in Storage.Integer_Address) + return Interfaces.C.C_float; + pragma Import (C, fl_gl_window_pixels_per_unit, "fl_gl_window_pixels_per_unit"); + pragma Inline (fl_gl_window_pixels_per_unit); + + procedure fl_gl_window_resize + (G : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_gl_window_resize, "fl_gl_window_resize"); + pragma Inline (fl_gl_window_resize); + + + + + -- OpenGL Modes -- + + function fl_gl_window_get_mode + (S : in Storage.Integer_Address) + return Mode_Mask; + pragma Import (C, fl_gl_window_get_mode, "fl_gl_window_get_mode"); + pragma Inline (fl_gl_window_get_mode); + + procedure fl_gl_window_set_mode + (S : in Storage.Integer_Address; + M : in Mode_Mask); + pragma Import (C, fl_gl_window_set_mode, "fl_gl_window_set_mode"); + pragma Inline (fl_gl_window_set_mode); + + function fl_gl_window_static_can_do + (M : in Mode_Mask) + return Interfaces.C.int; + pragma Import (C, fl_gl_window_static_can_do, "fl_gl_window_static_can_do"); + pragma Inline (fl_gl_window_static_can_do); + + function fl_gl_window_can_do + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_gl_window_can_do, "fl_gl_window_can_do"); + pragma Inline (fl_gl_window_can_do); + + function fl_gl_window_can_do_overlay + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_gl_window_can_do_overlay, "fl_gl_window_can_do_overlay"); + pragma Inline (fl_gl_window_can_do_overlay); + + + + + -- OpenGL Contexts -- + + function fl_gl_window_get_context + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_gl_window_get_context, "fl_gl_window_get_context"); + pragma Inline (fl_gl_window_get_context); + + procedure fl_gl_window_set_context + (S, P : in Storage.Integer_Address; + D : in Interfaces.C.int); + pragma Import (C, fl_gl_window_set_context, "fl_gl_window_set_context"); + pragma Inline (fl_gl_window_set_context); + + function fl_gl_window_context_valid + (S : in Storage.Integer_Address) + return Interfaces.C.signed_char; + pragma Import (C, fl_gl_window_context_valid, "fl_gl_window_context_valid"); + pragma Inline (fl_gl_window_context_valid); + + procedure fl_gl_window_set_context_valid + (S : in Storage.Integer_Address; + V : in Interfaces.C.signed_char); + pragma Import (C, fl_gl_window_set_context_valid, "fl_gl_window_set_context_valid"); + pragma Inline (fl_gl_window_set_context_valid); + + function fl_gl_window_valid + (S : in Storage.Integer_Address) + return Interfaces.C.signed_char; + pragma Import (C, fl_gl_window_valid, "fl_gl_window_valid"); + pragma Inline (fl_gl_window_valid); + + procedure fl_gl_window_set_valid + (S : in Storage.Integer_Address; + V : in Interfaces.C.signed_char); + pragma Import (C, fl_gl_window_set_valid, "fl_gl_window_set_valid"); + pragma Inline (fl_gl_window_set_valid); + + procedure fl_gl_window_invalidate + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_invalidate, "fl_gl_window_invalidate"); + pragma Inline (fl_gl_window_invalidate); + + procedure fl_gl_window_make_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_make_current, "fl_gl_window_make_current"); + pragma Inline (fl_gl_window_make_current); + + procedure fl_gl_window_make_overlay_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_make_overlay_current, "fl_gl_window_make_overlay_current"); + pragma Inline (fl_gl_window_make_overlay_current); + + + + + -- Drawing, Events -- + + procedure fl_gl_window_ortho + (W : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_ortho, "fl_gl_window_ortho"); + pragma Inline (fl_gl_window_ortho); + + procedure fl_gl_window_redraw_overlay + (W : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_redraw_overlay, "fl_gl_window_redraw_overlay"); + pragma Inline (fl_gl_window_redraw_overlay); + + procedure fl_gl_window_swap_buffers + (W : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_swap_buffers, "fl_gl_window_swap_buffers"); + pragma Inline (fl_gl_window_swap_buffers); + + procedure fl_gl_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_gl_window_draw, "fl_gl_window_draw"); + pragma Inline (fl_gl_window_draw); + + function fl_gl_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_gl_window_handle, "fl_gl_window_handle"); + pragma Inline (fl_gl_window_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out GL_Window) is + begin + Extra_Final (Window (This)); + end Extra_Final; + + + procedure Finalize + (This : in out GL_Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_gl_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out GL_Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Window (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out GL_Window) is + begin + This.Draw_Ptr := fl_gl_window_draw'Address; + This.Handle_Ptr := fl_gl_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return GL_Window is + begin + return This : GL_Window do + This.Void_Ptr := new_fl_gl_window + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return GL_Window is + begin + return This : GL_Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String := "") + return GL_Window is + begin + return This : GL_Window do + This.Void_Ptr := new_fl_gl_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return GL_Window is + begin + return This : GL_Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out GL_Window) is + begin + fl_gl_window_show (This.Void_Ptr); + end Show; + + + procedure Show_With_Args + (This : in out GL_Window) is + begin + FLTK.Args_Marshal.Dispatch (fl_gl_window_show2'Access, This.Void_Ptr); + end Show_With_Args; + + + procedure Hide + (This : in out GL_Window) is + begin + fl_gl_window_hide (This.Void_Ptr); + end Hide; + + + procedure Hide_Overlay + (This : in out GL_Window) is + begin + fl_gl_window_hide_overlay (This.Void_Ptr); + end Hide_Overlay; + + + procedure Flush + (This : in out GL_Window) is + begin + fl_gl_window_flush (This.Void_Ptr); + end Flush; + + + + + -- Dimensions -- + + function Pixel_H + (This : in GL_Window) + return Integer is + begin + return Integer (fl_gl_window_pixel_h (This.Void_Ptr)); + end Pixel_H; + + + function Pixel_W + (This : in GL_Window) + return Integer is + begin + return Integer (fl_gl_window_pixel_w (This.Void_Ptr)); + end Pixel_W; + + + function Pixels_Per_Unit + (This : in GL_Window) + return Float is + begin + return Float (fl_gl_window_pixels_per_unit (This.Void_Ptr)); + end Pixels_Per_Unit; + + + procedure Resize + (This : in out GL_Window; + X, Y, W, H : in Integer) is + begin + fl_gl_window_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- OpenGL Modes -- + + function Get_Mode + (This : in GL_Window) + return Mode_Mask is + begin + return fl_gl_window_get_mode (This.Void_Ptr); + end Get_Mode; + + + procedure Set_Mode + (This : in out GL_Window; + Mask : in Mode_Mask) is + begin + fl_gl_window_set_mode (This.Void_Ptr, Mask); + end Set_Mode; + + + function Can_Do + (Mask : in Mode_Mask) + return Boolean is + begin + return fl_gl_window_static_can_do (Mask) /= 0; + end Can_Do; + + + function Can_Do + (This : in GL_Window) + return Boolean is + begin + return fl_gl_window_can_do (This.Void_Ptr) /= 0; + end Can_Do; + + + function Can_Do_Overlay + (This : in GL_Window) + return Boolean is + begin + return fl_gl_window_can_do_overlay (This.Void_Ptr) /= 0; + end Can_Do_Overlay; + + + + + -- OpenGL Contexts -- + + function Get_Context + (This : in GL_Window) + return System.Address is + begin + return Storage.To_Address (fl_gl_window_get_context (This.Void_Ptr)); + end Get_Context; + + + procedure Set_Context + (This : in out GL_Window; + Struct : in System.Address; + Destroy : in Boolean := False) is + begin + fl_gl_window_set_context + (This.Void_Ptr, Storage.To_Integer (Struct), Boolean'Pos (Destroy)); + end Set_Context; + + + function Get_Context_Valid + (This : in GL_Window) + return Boolean is + begin + return fl_gl_window_context_valid (This.Void_Ptr) /= 0; + end Get_Context_Valid; + + + procedure Set_Context_Valid + (This : in out GL_Window; + Value : in Boolean) is + begin + fl_gl_window_set_context_valid (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Context_Valid; + + + function Get_Valid + (This : in GL_Window) + return Boolean is + begin + return fl_gl_window_valid (This.Void_Ptr) /= 0; + end Get_Valid; + + + procedure Set_Valid + (This : in out GL_Window; + Value : in Boolean) is + begin + fl_gl_window_set_valid (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Valid; + + + procedure Invalidate + (This : in out GL_Window) is + begin + fl_gl_window_invalidate (This.Void_Ptr); + end Invalidate; + + + procedure Make_Current + (This : in out GL_Window) is + begin + fl_gl_window_make_current (This.Void_Ptr); + end Make_Current; + + + procedure Make_Overlay_Current + (This : in out GL_Window) is + begin + fl_gl_window_make_overlay_current (This.Void_Ptr); + end Make_Overlay_Current; + + + + + -- Drawing, Events -- + + procedure Ortho + (This : in out GL_Window) is + begin + fl_gl_window_ortho (This.Void_Ptr); + end Ortho; + + + procedure Redraw_Overlay + (This : in out GL_Window) is + begin + fl_gl_window_redraw_overlay (This.Void_Ptr); + end Redraw_Overlay; + + + procedure Swap_Buffers + (This : in out GL_Window) is + begin + fl_gl_window_swap_buffers (This.Void_Ptr); + end Swap_Buffers; + + + procedure Draw + (This : in out GL_Window) is + begin + Window (This).Draw; + end Draw; + + + function Handle + (This : in out GL_Window; + Event : in Event_Kind) + return Event_Outcome is + begin + return Window (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Windows.OpenGL; + + diff --git a/body/fltk-widgets-groups-windows-single-menu.adb b/body/fltk-widgets-groups-windows-single-menu.adb new file mode 100644 index 0000000..a6997c9 --- /dev/null +++ b/body/fltk-widgets-groups-windows-single-menu.adb @@ -0,0 +1,284 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.unsigned; + + +package body FLTK.Widgets.Groups.Windows.Single.Menu is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_menu_window + (X, Y, W, H : in Interfaces.C.int; + Label : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu_window, "new_fl_menu_window"); + pragma Inline (new_fl_menu_window); + + function new_fl_menu_window2 + (W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu_window2, "new_fl_menu_window2"); + pragma Inline (new_fl_menu_window2); + + procedure free_fl_menu_window + (M : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_window, "free_fl_menu_window"); + pragma Inline (free_fl_menu_window); + + + + + -- Visibility -- + + procedure fl_menu_window_show + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_show, "fl_menu_window_show"); + pragma Inline (fl_menu_window_show); + + procedure fl_menu_window_hide + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_hide, "fl_menu_window_hide"); + pragma Inline (fl_menu_window_hide); + + procedure fl_menu_window_flush + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_flush, "fl_menu_window_flush"); + pragma Inline (fl_menu_window_flush); + + procedure fl_menu_window_erase + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_erase, "fl_menu_window_erase"); + pragma Inline (fl_menu_window_erase); + + + + + -- Overlay -- + + procedure fl_menu_window_set_overlay + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_set_overlay, "fl_menu_window_set_overlay"); + pragma Inline (fl_menu_window_set_overlay); + + procedure fl_menu_window_clear_overlay + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_clear_overlay, "fl_menu_window_clear_overlay"); + pragma Inline (fl_menu_window_clear_overlay); + + function fl_menu_window_overlay + (M : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_menu_window_overlay, "fl_menu_window_overlay"); + pragma Inline (fl_menu_window_overlay); + + + + + -- Drawing, Events -- + + procedure fl_menu_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_menu_window_draw, "fl_menu_window_draw"); + pragma Inline (fl_menu_window_draw); + + function fl_menu_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_window_handle, "fl_menu_window_handle"); + pragma Inline (fl_menu_window_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Menu_Window) is + begin + Extra_Final (Single_Window (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Menu_Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_menu_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Menu_Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Single_Window (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Menu_Window) is + begin + This.Draw_Ptr := fl_menu_window_draw'Address; + This.Handle_Ptr := fl_menu_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Window is + begin + return This : Menu_Window do + This.Void_Ptr := new_fl_menu_window + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Window is + begin + return This : Menu_Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String := "") + return Menu_Window is + begin + return This : Menu_Window do + This.Void_Ptr := new_fl_menu_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return Menu_Window is + begin + return This : Menu_Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out Menu_Window) is + begin + fl_menu_window_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Menu_Window) is + begin + fl_menu_window_hide (This.Void_Ptr); + end Hide; + + + procedure Flush + (This : in out Menu_Window) is + begin + fl_menu_window_flush (This.Void_Ptr); + end Flush; + + + procedure Erase + (This : in out Menu_Window) is + begin + fl_menu_window_erase (This.Void_Ptr); + end Erase; + + + + + -- Overlay -- + + function Is_Overlay + (This : in Menu_Window) + return Boolean is + begin + return fl_menu_window_overlay (This.Void_Ptr) /= 0; + end Is_Overlay; + + + procedure Set_Overlay + (This : in out Menu_Window; + Value : in Boolean := True) is + begin + if Value then + fl_menu_window_set_overlay (This.Void_Ptr); + else + fl_menu_window_clear_overlay (This.Void_Ptr); + end if; + end Set_Overlay; + + + procedure Clear_Overlay + (This : in out Menu_Window) is + begin + fl_menu_window_clear_overlay (This.Void_Ptr); + end Clear_Overlay; + + +end FLTK.Widgets.Groups.Windows.Single.Menu; + + diff --git a/body/fltk-widgets-groups-windows-single.adb b/body/fltk-widgets-groups-windows-single.adb new file mode 100644 index 0000000..6788d1a --- /dev/null +++ b/body/fltk-widgets-groups-windows-single.adb @@ -0,0 +1,240 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Args_Marshal, + Interfaces.C; + + +package body FLTK.Widgets.Groups.Windows.Single is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_single_window + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_single_window, "new_fl_single_window"); + pragma Inline (new_fl_single_window); + + function new_fl_single_window2 + (W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_single_window2, "new_fl_single_window2"); + pragma Inline (new_fl_single_window2); + + procedure free_fl_single_window + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_single_window, "free_fl_single_window"); + pragma Inline (free_fl_single_window); + + + + + -- Visibility -- + + procedure fl_single_window_show + (S : in Storage.Integer_Address); + pragma Import (C, fl_single_window_show, "fl_single_window_show"); + pragma Inline (fl_single_window_show); + + procedure fl_single_window_show2 + (S : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_single_window_show2, "fl_single_window_show2"); + pragma Inline (fl_single_window_show2); + + procedure fl_single_window_flush + (S : in Storage.Integer_Address); + pragma Import (C, fl_single_window_flush, "fl_single_window_flush"); + pragma Inline (fl_single_window_flush); + + + + + -- Current -- + + procedure fl_single_window_make_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_single_window_make_current, "fl_single_window_make_current"); + pragma Inline (fl_single_window_make_current); + + + + + -- Drawing, Events -- + + procedure fl_single_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_single_window_draw, "fl_single_window_draw"); + pragma Inline (fl_single_window_draw); + + function fl_single_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_single_window_handle, "fl_single_window_handle"); + pragma Inline (fl_single_window_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Single_Window) is + begin + Extra_Final (Window (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Single_Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_single_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Single_Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Window (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Single_Window) is + begin + This.Draw_Ptr := fl_single_window_draw'Address; + This.Handle_Ptr := fl_single_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Single_Window is + begin + return This : Single_Window do + This.Void_Ptr := new_fl_single_window + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Single_Window is + begin + return This : Single_Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String := "") + return Single_Window is + begin + return This : Single_Window do + This.Void_Ptr := new_fl_single_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return Single_Window is + begin + return This : Single_Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out Single_Window) is + begin + fl_single_window_show (This.Void_Ptr); + end Show; + + + procedure Show_With_Args + (This : in out Single_Window) is + begin + FLTK.Args_Marshal.Dispatch (fl_single_window_show2'Access, This.Void_Ptr); + end Show_With_Args; + + + procedure Flush + (This : in out Single_Window) is + begin + fl_single_window_flush (This.Void_Ptr); + end Flush; + + + + + -- Current -- + + procedure Make_Current + (This : in out Single_Window) is + begin + fl_single_window_make_current (This.Void_Ptr); + end Make_Current; + + +end FLTK.Widgets.Groups.Windows.Single; + + diff --git a/body/fltk-widgets-groups-windows.adb b/body/fltk-widgets-groups-windows.adb new file mode 100644 index 0000000..55f3506 --- /dev/null +++ b/body/fltk-widgets-groups-windows.adb @@ -0,0 +1,1088 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings, + FLTK.Args_Marshal; + +use type + + Interfaces.C.int, + Interfaces.C.unsigned, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Groups.Windows is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_window + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_window, "new_fl_window"); + pragma Inline (new_fl_window); + + function new_fl_window2 + (W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_window2, "new_fl_window2"); + pragma Inline (new_fl_window2); + + procedure free_fl_window + (W : in Storage.Integer_Address); + pragma Import (C, free_fl_window, "free_fl_window"); + pragma Inline (free_fl_window); + + + + + -- Visibility -- + + procedure fl_window_show + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_show, "fl_window_show"); + pragma Inline (fl_window_show); + + procedure fl_window_show2 + (W : in Storage.Integer_Address; + C : in Interfaces.C.int; + V : in Storage.Integer_Address); + pragma Import (C, fl_window_show2, "fl_window_show2"); + pragma Inline (fl_window_show2); + + procedure fl_window_hide + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_hide, "fl_window_hide"); + pragma Inline (fl_window_hide); + + function fl_window_shown + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_shown, "fl_window_shown"); + pragma Inline (fl_window_shown); + + procedure fl_window_wait_for_expose + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_wait_for_expose, "fl_window_wait_for_expose"); + pragma Inline (fl_window_wait_for_expose); + + procedure fl_window_iconize + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_iconize, "fl_window_iconize"); + pragma Inline (fl_window_iconize); + + procedure fl_window_make_current + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_make_current, "fl_window_make_current"); + pragma Inline (fl_window_make_current); + + + + + -- Fullscreen -- + + function fl_window_fullscreen_active + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_fullscreen_active, "fl_window_fullscreen_active"); + pragma Inline (fl_window_fullscreen_active); + + procedure fl_window_fullscreen + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_fullscreen, "fl_window_fullscreen"); + pragma Inline (fl_window_fullscreen); + + procedure fl_window_fullscreen_off + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_fullscreen_off, "fl_window_fullscreen_off"); + pragma Inline (fl_window_fullscreen_off); + + procedure fl_window_fullscreen_off2 + (N : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_window_fullscreen_off2, "fl_window_fullscreen_off2"); + pragma Inline (fl_window_fullscreen_off2); + + procedure fl_window_fullscreen_screens + (W : in Storage.Integer_Address; + T, B, L, R : in Interfaces.C.int); + pragma Import (C, fl_window_fullscreen_screens, "fl_window_fullscreen_screens"); + pragma Inline (fl_window_fullscreen_screens); + + + + + -- Icons, Cursors -- + + procedure fl_window_set_icon + (W, P : in Storage.Integer_Address); + pragma Import (C, fl_window_set_icon, "fl_window_set_icon"); + pragma Inline (fl_window_set_icon); + + procedure fl_window_icons + (W, P : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_icons, "fl_window_icons"); + pragma Inline (fl_window_icons); + + procedure fl_window_default_icon + (P : in Storage.Integer_Address); + pragma Import (C, fl_window_default_icon, "fl_window_default_icon"); + pragma Inline (fl_window_default_icon); + + procedure fl_window_default_icons + (P : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_default_icons, "fl_window_default_icons"); + pragma Inline (fl_window_default_icons); + + function fl_window_get_iconlabel + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_iconlabel, "fl_window_get_iconlabel"); + pragma Inline (fl_window_get_iconlabel); + + procedure fl_window_set_iconlabel + (W : in Storage.Integer_Address; + S : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_iconlabel, "fl_window_set_iconlabel"); + pragma Inline (fl_window_set_iconlabel); + + procedure fl_window_set_cursor + (W : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_set_cursor, "fl_window_set_cursor"); + pragma Inline (fl_window_set_cursor); + + procedure fl_window_set_cursor2 + (W, P : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_window_set_cursor2, "fl_window_set_cursor2"); + pragma Inline (fl_window_set_cursor2); + + procedure fl_window_set_default_cursor + (W : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_window_set_default_cursor, "fl_window_set_default_cursor"); + pragma Inline (fl_window_set_default_cursor); + + + + + -- Settings -- + + function fl_window_get_border + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_get_border, "fl_window_get_border"); + pragma Inline (fl_window_get_border); + + procedure fl_window_set_border + (W : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_window_set_border, "fl_window_set_border"); + pragma Inline (fl_window_set_border); + + procedure fl_window_clear_border + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_clear_border, "fl_window_clear_border"); + pragma Inline (fl_window_clear_border); + + function fl_window_get_override + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_get_override, "fl_window_get_override"); + pragma Inline (fl_window_get_override); + + procedure fl_window_set_override + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_set_override, "fl_window_set_override"); + pragma Inline (fl_window_set_override); + + function fl_window_modal + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_modal, "fl_window_modal"); + pragma Inline (fl_window_modal); + + function fl_window_non_modal + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_non_modal, "fl_window_non_modal"); + pragma Inline (fl_window_non_modal); + + procedure fl_window_set_modal + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_set_modal, "fl_window_set_modal"); + pragma Inline (fl_window_set_modal); + + procedure fl_window_set_non_modal + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_set_non_modal, "fl_window_set_non_modal"); + pragma Inline (fl_window_set_non_modal); + + procedure fl_window_clear_modal_states + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_clear_modal_states, "fl_window_clear_modal_states"); + pragma Inline (fl_window_clear_modal_states); + + + + + -- Labels, Hotspot, Shape -- + + function fl_window_get_label + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_label, "fl_window_get_label"); + pragma Inline (fl_window_get_label); + + procedure fl_window_copy_label + (W : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_window_copy_label, "fl_window_copy_label"); + pragma Inline (fl_window_copy_label); + + procedure fl_window_hotspot + (W : in Storage.Integer_Address; + X, Y, S : in Interfaces.C.int); + pragma Import (C, fl_window_hotspot, "fl_window_hotspot"); + pragma Inline (fl_window_hotspot); + + procedure fl_window_hotspot2 + (W, I : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_window_hotspot2, "fl_window_hotspot2"); + pragma Inline (fl_window_hotspot2); + + procedure fl_window_shape + (W, P : in Storage.Integer_Address); + pragma Import (C, fl_window_shape, "fl_window_shape"); + pragma Inline (fl_window_shape); + + + + + -- Dimensions -- + + procedure fl_window_size_range + (W : in Storage.Integer_Address; + LW, LH, HW, HH, DW, DH, A : in Interfaces.C.int); + pragma Import (C, fl_window_size_range, "fl_window_size_range"); + pragma Inline (fl_window_size_range); + + procedure fl_window_resize + (N : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_window_resize, "fl_window_resize"); + pragma Inline (fl_window_resize); + + function fl_window_get_force_position + (N : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_force_position, "fl_window_get_force_position"); + pragma Inline (fl_window_get_force_position); + + procedure fl_window_set_force_position + (N : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_window_set_force_position, "fl_window_set_force_position"); + pragma Inline (fl_window_set_force_position); + + function fl_window_get_x_root + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_x_root, "fl_window_get_x_root"); + pragma Inline (fl_window_get_x_root); + + function fl_window_get_y_root + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_y_root, "fl_window_get_y_root"); + pragma Inline (fl_window_get_y_root); + + function fl_window_get_decorated_w + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_decorated_w, "fl_window_get_decorated_w"); + pragma Inline (fl_window_get_decorated_w); + + function fl_window_get_decorated_h + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_window_get_decorated_h, "fl_window_get_decorated_h"); + pragma Inline (fl_window_get_decorated_h); + + + + + -- Class Info -- + + function fl_window_get_xclass + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_xclass, "fl_window_get_xclass"); + pragma Inline (fl_window_get_xclass); + + procedure fl_window_set_xclass + (W : in Storage.Integer_Address; + C : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_xclass, "fl_window_set_xclass"); + pragma Inline (fl_window_set_xclass); + + function fl_window_get_default_xclass + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_window_get_default_xclass, "fl_window_get_default_xclass"); + pragma Inline (fl_window_get_default_xclass); + + procedure fl_window_set_default_xclass + (C : in Interfaces.C.char_array); + pragma Import (C, fl_window_set_default_xclass, "fl_window_set_default_xclass"); + pragma Inline (fl_window_set_default_xclass); + + function fl_window_menu_window + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_menu_window, "fl_window_menu_window"); + pragma Inline (fl_window_menu_window); + + function fl_window_tooltip_window + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_window_tooltip_window, "fl_window_tooltip_window"); + pragma Inline (fl_window_tooltip_window); + + + + + -- Drawing, Events -- + + procedure fl_window_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_draw, "fl_window_draw"); + pragma Inline (fl_window_draw); + + procedure fl_window_flush + (W : in Storage.Integer_Address); + pragma Import (C, fl_window_flush, "fl_window_flush"); + pragma Inline (fl_window_flush); + + function fl_window_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_window_handle, "fl_window_handle"); + pragma Inline (fl_window_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Window) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Window) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_window (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Window; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Window) is + begin + This.Draw_Ptr := fl_window_draw'Address; + This.Handle_Ptr := fl_window_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Window is + begin + return This : Window do + This.Void_Ptr := new_fl_window + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Window is + begin + return This : Window := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (W, H : in Integer; + Text : in String := "") + return Window is + begin + return This : Window do + This.Void_Ptr := new_fl_window2 + (Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, This.Get_X, This.Get_Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return Window is + begin + return This : Window := Create (W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Visibility -- + + procedure Show + (This : in out Window) is + begin + fl_window_show (This.Void_Ptr); + end Show; + + + procedure Show_With_Args + (This : in out Window) is + begin + FLTK.Args_Marshal.Dispatch (fl_window_show2'Access, This.Void_Ptr); + end Show_With_Args; + + + procedure Hide + (This : in out Window) is + begin + fl_window_hide (This.Void_Ptr); + end Hide; + + + function Is_Shown + (This : in Window) + return Boolean is + begin + return fl_window_shown (This.Void_Ptr) /= 0; + end Is_Shown; + + + procedure Wait_For_Expose + (This : in out Window) is + begin + fl_window_wait_for_expose (This.Void_Ptr); + end Wait_For_Expose; + + + procedure Iconify + (This : in out Window) is + begin + fl_window_iconize (This.Void_Ptr); + end Iconify; + + + procedure Make_Current + (This : in out Window) is + begin + fl_window_make_current (This.Void_Ptr); + Last_Current := This'Unchecked_Access; + end Make_Current; + + + function Last_Made_Current + return access Window'Class is + begin + return Last_Current; + end Last_Made_Current; + + + + + -- Fullscreen -- + + function Is_Fullscreen + (This : in Window) + return Boolean is + begin + return fl_window_fullscreen_active (This.Void_Ptr) /= 0; + end Is_Fullscreen; + + + procedure Fullscreen_On + (This : in out Window) is + begin + fl_window_fullscreen (This.Void_Ptr); + end Fullscreen_On; + + + procedure Fullscreen_Off + (This : in out Window) is + begin + fl_window_fullscreen_off (This.Void_Ptr); + end Fullscreen_Off; + + + procedure Fullscreen_Off + (This : in out Window; + X, Y, W, H : in Integer) is + begin + fl_window_fullscreen_off2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Fullscreen_Off; + + + procedure Fullscreen_Screens + (This : in out Window; + Top, Bottom, Left, Right : in Natural) is + begin + fl_window_fullscreen_screens + (This.Void_Ptr, + Interfaces.C.int (Top), + Interfaces.C.int (Bottom), + Interfaces.C.int (Left), + Interfaces.C.int (Right)); + end Fullscreen_Screens; + + + + + -- Icons, Cursors -- + + procedure Set_Icon + (This : in out Window; + Pic : in FLTK.Images.RGB.RGB_Image'Class) is + begin + fl_window_set_icon + (This.Void_Ptr, + Wrapper (Pic).Void_Ptr); + end Set_Icon; + + + procedure Set_Icons + (This : in out Window; + Pics : in FLTK.Images.RGB.RGB_Image_Array) + is + Pointers : array (Pics'First .. Pics'Last) of aliased Storage.Integer_Address; + begin + for Index in Pointers'Range loop + Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; + end loop; + fl_window_icons + (This.Void_Ptr, + (if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), + Pointers'Length); + end Set_Icons; + + + procedure Reset_Icons + (This : in out Window) is + begin + fl_window_icons (This.Void_Ptr, Null_Pointer, 0); + end Reset_Icons; + + + procedure Set_Default_Icon + (Pic : in FLTK.Images.RGB.RGB_Image'Class) is + begin + fl_window_default_icon (Wrapper (Pic).Void_Ptr); + end Set_Default_Icon; + + + procedure Set_Default_Icons + (Pics : in FLTK.Images.RGB.RGB_Image_Array) + is + Pointers : array (Pics'First .. Pics'Last) of aliased Storage.Integer_Address; + begin + for Index in Pointers'Range loop + Pointers (Index) := Wrapper (Pics (Index)).Void_Ptr; + end loop; + fl_window_default_icons + ((if Pointers'Length > 0 + then Storage.To_Integer (Pointers (Pointers'First)'Address) + else Null_Pointer), + Pointers'Length); + end Set_Default_Icons; + + + procedure Reset_Default_Icons is + begin + fl_window_default_icons (Null_Pointer, 0); + end Reset_Default_Icons; + + + function Get_Icon_Label + (This : in Window) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_window_get_iconlabel (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + -- pointer to internal buffer only, so no Free required + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Icon_Label; + + + procedure Set_Icon_Label + (This : in out Window; + To : in String) is + begin + fl_window_set_iconlabel (This.Void_Ptr, Interfaces.C.To_C (To)); + end Set_Icon_Label; + + + procedure Set_Cursor + (This : in out Window; + To : in Mouse_Cursor_Kind) is + begin + fl_window_set_cursor (This.Void_Ptr, Cursor_Values (To)); + end Set_Cursor; + + + procedure Set_Cursor + (This : in out Window; + Pic : in FLTK.Images.RGB.RGB_Image'Class; + Hot_X, Hot_Y : in Integer) is + begin + fl_window_set_cursor2 + (This.Void_Ptr, + Wrapper (Pic).Void_Ptr, + Interfaces.C.int (Hot_X), + Interfaces.C.int (Hot_Y)); + end Set_Cursor; + + + procedure Set_Default_Cursor + (This : in out Window; + To : in Mouse_Cursor_Kind) is + begin + fl_window_set_default_cursor (This.Void_Ptr, Cursor_Values (To)); + end Set_Default_Cursor; + + + + + -- Settings -- + + function Has_Border + (This : in Window) + return Boolean is + begin + return fl_window_get_border (This.Void_Ptr) /= 0; + end Has_Border; + + + procedure Set_Border + (This : in out Window; + Value : in Boolean := True) is + begin + fl_window_set_border (This.Void_Ptr, Boolean'Pos (Value)); + end Set_Border; + + + procedure Clear_Border + (This : in out Window) is + begin + fl_window_clear_border (This.Void_Ptr); + end Clear_Border; + + + function Is_Override + (This : in Window) + return Boolean is + begin + return fl_window_get_override (This.Void_Ptr) /= 0; + end Is_Override; + + + procedure Set_Override + (This : in out Window) is + begin + fl_window_set_override (This.Void_Ptr); + end Set_Override; + + + function Is_Modal + (This : in Window) + return Boolean is + begin + return fl_window_modal (This.Void_Ptr) /= 0; + end Is_Modal; + + + function Is_Non_Modal + (This : in Window) + return Boolean is + begin + return fl_window_non_modal (This.Void_Ptr) /= 0; + end Is_Non_Modal; + + + function Get_Modal_State + (This : in Window) + return Modal_State is + begin + if fl_window_modal (This.Void_Ptr) /= 0 then + return Modal; + elsif fl_window_non_modal (This.Void_Ptr) /= 0 then + return Non_Modal; + else + return Normal; + end if; + end Get_Modal_State; + + + procedure Set_Modal + (This : in out Window) is + begin + fl_window_set_modal (This.Void_Ptr); + end Set_Modal; + + + procedure Set_Non_Modal + (This : in out Window) is + begin + fl_window_set_non_modal (This.Void_Ptr); + end Set_Non_Modal; + + + procedure Set_Modal_State + (This : in out Window; + Value : in Modal_State) is + begin + case Value is + when Normal => fl_window_clear_modal_states (This.Void_Ptr); + when Non_Modal => fl_window_set_non_modal (This.Void_Ptr); + when Modal => fl_window_set_modal (This.Void_Ptr); + end case; + end Set_Modal_State; + + + procedure Clear_Modal_State + (This : in out Window) is + begin + fl_window_clear_modal_states (This.Void_Ptr); + end Clear_Modal_State; + + + + + -- Labels, Hotspot, Shape -- + + function Get_Label + (This : in Window) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_window_get_label (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + -- pointer to internal buffer only, so no Free required + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Label; + + + procedure Set_Label + (This : in out Window; + Text : in String) is + begin + fl_window_copy_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Labels + (This : in out Window; + Text, Icon_Text : in String) is + begin + This.Set_Label (Text); + This.Set_Icon_Label (Icon_Text); + end Set_Labels; + + + procedure Hotspot + (This : in out Window; + X, Y : in Integer; + Offscreen : in Boolean := False) is + begin + fl_window_hotspot + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Boolean'Pos (Offscreen)); + end Hotspot; + + + procedure Hotspot + (This : in out Window; + Item : in Widget'Class; + Offscreen : in Boolean := False) is + begin + fl_window_hotspot2 + (This.Void_Ptr, + Item.Void_Ptr, + Boolean'Pos (Offscreen)); + end Hotspot; + + + procedure Shape + (This : in out Window; + Pic : in FLTK.Images.Image'Class) is + begin + fl_window_shape (This.Void_Ptr, Wrapper (Pic).Void_Ptr); + end Shape; + + + + + -- Dimensions -- + + procedure Set_Size_Range + (This : in out Window; + Min_W, Min_H : in Integer; + Max_W, Max_H, Incre_W, Incre_H : in Integer := 0; + Keep_Aspect : in Boolean := False) is + begin + fl_window_size_range + (This.Void_Ptr, + Interfaces.C.int (Min_W), + Interfaces.C.int (Min_H), + Interfaces.C.int (Max_W), + Interfaces.C.int (Max_H), + Interfaces.C.int (Incre_W), + Interfaces.C.int (Incre_H), + Boolean'Pos (Keep_Aspect)); + end Set_Size_Range; + + + procedure Resize + (This : in out Window; + X, Y, W, H : in Integer) is + begin + fl_window_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + function Is_Position_Forced + (This : in Window) + return Boolean + is + Result : constant Interfaces.C.int := fl_window_get_force_position (This.Void_Ptr); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Window::force_position returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Is_Position_Forced; + + + procedure Force_Position + (This : in out Window; + State : in Boolean := True) is + begin + fl_window_set_force_position (This.Void_Ptr, Boolean'Pos (State)); + end Force_Position; + + + function Get_X_Root + (This : in Window) + return Integer is + begin + return Integer (fl_window_get_x_root (This.Void_Ptr)); + end Get_X_Root; + + + function Get_Y_Root + (This : in Window) + return Integer is + begin + return Integer (fl_window_get_y_root (This.Void_Ptr)); + end Get_Y_Root; + + + function Get_Decorated_W + (This : in Window) + return Integer is + begin + return Integer (fl_window_get_decorated_w (This.Void_Ptr)); + end Get_Decorated_W; + + + function Get_Decorated_H + (This : in Window) + return Integer is + begin + return Integer (fl_window_get_decorated_h (This.Void_Ptr)); + end Get_Decorated_H; + + + + + -- Class Info -- + + function Get_X_Class + (This : in Window) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_xclass (This.Void_Ptr); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_X_Class; + + + procedure Set_X_Class + (This : in out Window; + Value : in String) is + begin + fl_window_set_xclass (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_X_Class; + + + function Get_Default_X_Class + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_window_get_default_xclass; + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Default_X_Class; + + + procedure Set_Default_X_Class + (Value : in String) is + begin + fl_window_set_default_xclass (Interfaces.C.To_C (Value)); + end Set_Default_X_Class; + + + function Is_Menu_Window + (This : in Window) + return Boolean is + begin + return fl_window_menu_window (This.Void_Ptr) /= 0; + end Is_Menu_Window; + + + function Is_Tooltip_Window + (This : in Window) + return Boolean is + begin + return fl_window_tooltip_window (This.Void_Ptr) /= 0; + end Is_Tooltip_Window; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Window) is + begin + Group (This).Draw; + end Draw; + + + procedure Flush + (This : in out Window) is + begin + fl_window_flush (This.Void_Ptr); + end Flush; + + + function Handle + (This : in out Window; + Event : in Event_Kind) + return Event_Outcome is + begin + return Group (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups.Windows; + + diff --git a/body/fltk-widgets-groups-wizards.adb b/body/fltk-widgets-groups-wizards.adb new file mode 100644 index 0000000..513c50f --- /dev/null +++ b/body/fltk-widgets-groups-wizards.adb @@ -0,0 +1,234 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C; + + +package body FLTK.Widgets.Groups.Wizards is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_wizard + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_wizard, "new_fl_wizard"); + pragma Inline (new_fl_wizard); + + procedure free_fl_wizard + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_wizard, "free_fl_wizard"); + pragma Inline (free_fl_wizard); + + + + + -- Navigation -- + + procedure fl_wizard_next + (W : in Storage.Integer_Address); + pragma Import (C, fl_wizard_next, "fl_wizard_next"); + pragma Inline (fl_wizard_next); + + procedure fl_wizard_prev + (W : in Storage.Integer_Address); + pragma Import (C, fl_wizard_prev, "fl_wizard_prev"); + pragma Inline (fl_wizard_prev); + + + + + -- Visibility -- + + function fl_wizard_get_visible + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_wizard_get_visible, "fl_wizard_get_visible"); + pragma Inline (fl_wizard_get_visible); + + procedure fl_wizard_set_visible + (W, I : in Storage.Integer_Address); + pragma Import (C, fl_wizard_set_visible, "fl_wizard_set_visible"); + pragma Inline (fl_wizard_set_visible); + + + + + -- Drawing, Events -- + + procedure fl_wizard_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_wizard_draw, "fl_wizard_draw"); + pragma Inline (fl_wizard_draw); + + function fl_wizard_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_wizard_handle, "fl_wizard_handle"); + pragma Inline (fl_wizard_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Wizard) is + begin + Extra_Final (Group (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Wizard) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_wizard (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Wizard; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Group (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Wizard) is + begin + This.Draw_Ptr := fl_wizard_draw'Address; + This.Handle_Ptr := fl_wizard_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Wizard is + begin + return This : Wizard do + This.Void_Ptr := new_fl_wizard + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Wizard is + begin + return This : Wizard := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Navigation -- + + procedure Next + (This : in out Wizard) is + begin + fl_wizard_next (This.Void_Ptr); + end Next; + + + procedure Prev + (This : in out Wizard) is + begin + fl_wizard_prev (This.Void_Ptr); + end Prev; + + + + + -- Visibility -- + + function Get_Visible + (This : in Wizard) + return access Widget'Class + is + Visible_Ptr : Storage.Integer_Address := fl_wizard_get_visible (This.Void_Ptr); + Actual_Widget : access Widget'Class; + begin + if Visible_Ptr /= Null_Pointer then + Visible_Ptr := fl_widget_get_user_data (Visible_Ptr); + pragma Assert (Visible_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Visible_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Wizard::value returned Widget with no user_data reference back to Ada"; + end Get_Visible; + + + procedure Set_Visible + (This : in out Wizard; + Item : in out Widget'Class) is + begin + fl_wizard_set_visible (This.Void_Ptr, Item.Void_Ptr); + end Set_Visible; + + + + + -- Drawing -- + + procedure Draw + (This : in out Wizard) is + begin + Group (This).Draw; + end Draw; + + +end FLTK.Widgets.Groups.Wizards; + + diff --git a/body/fltk-widgets-groups.adb b/body/fltk-widgets-groups.adb new file mode 100644 index 0000000..d6b51d4 --- /dev/null +++ b/body/fltk-widgets-groups.adb @@ -0,0 +1,674 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_group + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_group, "new_fl_group"); + pragma Inline (new_fl_group); + + procedure free_fl_group + (G : in Storage.Integer_Address); + pragma Import (C, free_fl_group, "free_fl_group"); + pragma Inline (free_fl_group); + + + + + -- Contents Modification -- + + procedure fl_group_add + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_add, "fl_group_add"); + pragma Inline (fl_group_add); + + procedure fl_group_insert + (G, W : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_group_insert, "fl_group_insert"); + pragma Inline (fl_group_insert); + + procedure fl_group_insert2 + (G, W, B : in Storage.Integer_Address); + pragma Import (C, fl_group_insert2, "fl_group_insert2"); + pragma Inline (fl_group_insert2); + + procedure fl_group_remove + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_remove, "fl_group_remove"); + pragma Inline (fl_group_remove); + + procedure fl_group_remove2 + (G : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_group_remove2, "fl_group_remove2"); + pragma Inline (fl_group_remove2); + + + + + -- Contents Query -- + + function fl_group_child + (G : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_group_child, "fl_group_child"); + pragma Inline (fl_group_child); + + function fl_group_find + (G, W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_group_find, "fl_group_find"); + pragma Inline (fl_group_find); + + function fl_group_children + (G : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_group_children, "fl_group_children"); + pragma Inline (fl_group_children); + + + + + -- Clipping -- + + function fl_group_get_clip_children + (G : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_group_get_clip_children, "fl_group_get_clip_children"); + pragma Inline (fl_group_get_clip_children); + + procedure fl_group_set_clip_children + (G : in Storage.Integer_Address; + C : in Interfaces.C.int); + pragma Import (C, fl_group_set_clip_children, "fl_group_set_clip_children"); + pragma Inline (fl_group_set_clip_children); + + + + + -- Dimensions -- + + procedure fl_group_add_resizable + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_add_resizable, "fl_group_add_resizable"); + pragma Inline (fl_group_add_resizable); + + function fl_group_get_resizable + (G : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_group_get_resizable, "fl_group_get_resizable"); + pragma Inline (fl_group_get_resizable); + + procedure fl_group_set_resizable + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_set_resizable, "fl_group_set_resizable"); + pragma Inline (fl_group_set_resizable); + + procedure fl_group_init_sizes + (G : in Storage.Integer_Address); + pragma Import (C, fl_group_init_sizes, "fl_group_init_sizes"); + pragma Inline (fl_group_init_sizes); + + procedure fl_group_resize + (G : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_group_resize, "fl_group_resize"); + pragma Inline (fl_group_resize); + + + + + -- Current -- + + function fl_group_get_current + return Storage.Integer_Address; + pragma Import (C, fl_group_get_current, "fl_group_get_current"); + pragma Inline (fl_group_get_current); + + procedure fl_group_set_current + (G : in Storage.Integer_Address); + pragma Import (C, fl_group_set_current, "fl_group_set_current"); + pragma Inline (fl_group_set_current); + + procedure fl_group_begin + (G : in Storage.Integer_Address); + pragma Import (C, fl_group_begin, "fl_group_begin"); + pragma Inline (fl_group_begin); + + procedure fl_group_end + (G : in Storage.Integer_Address); + pragma Import (C, fl_group_end, "fl_group_end"); + pragma Inline (fl_group_end); + + + + + -- Drawing, Events -- + + procedure fl_group_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_group_draw, "fl_group_draw"); + pragma Inline (fl_group_draw); + + procedure fl_group_draw_child + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_draw_child, "fl_group_draw_child"); + pragma Inline (fl_group_draw_child); + + procedure fl_group_draw_children + (G : in Storage.Integer_Address); + pragma Import (C, fl_group_draw_children, "fl_group_draw_children"); + pragma Inline (fl_group_draw_children); + + procedure fl_group_draw_outside_label + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_draw_outside_label, "fl_group_draw_outside_label"); + pragma Inline (fl_group_draw_outside_label); + + procedure fl_group_update_child + (G, W : in Storage.Integer_Address); + pragma Import (C, fl_group_update_child, "fl_group_update_child"); + pragma Inline (fl_group_update_child); + + function fl_group_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_group_handle, "fl_group_handle"); + pragma Inline (fl_group_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Group) is + begin + if This.Needs_Dealloc then + This.Clear; + end if; + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Group) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_group (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Group; + X, Y, W, H : in Integer; + Text : in String) is + begin + fl_group_end (This.Void_Ptr); + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Group) is + begin + This.Draw_Ptr := fl_group_draw'Address; + This.Handle_Ptr := fl_group_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Group is + begin + return This : Group do + This.Void_Ptr := new_fl_group + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Group is + begin + return This : Group := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Contents Modification -- + + procedure Add + (This : in out Group; + Item : in out Widget'Class) is + begin + fl_group_add (This.Void_Ptr, Item.Void_Ptr); + end Add; + + + procedure Insert + (This : in out Group; + Item : in out Widget'Class; + Place : in Index) is + begin + fl_group_insert + (This.Void_Ptr, + Item.Void_Ptr, + Interfaces.C.int (Place) - 1); + end Insert; + + + procedure Insert + (This : in out Group; + Item : in out Widget'Class; + Before : in Widget'Class) is + begin + fl_group_insert2 + (This.Void_Ptr, + Item.Void_Ptr, + Before.Void_Ptr); + end Insert; + + + procedure Remove + (This : in out Group; + Item : in out Widget'Class) is + begin + fl_group_remove (This.Void_Ptr, Item.Void_Ptr); + end Remove; + + + procedure Remove + (This : in out Group; + Place : in Index) is + begin + fl_group_remove2 (This.Void_Ptr, Interfaces.C.int (Place) - 1); + end Remove; + + + procedure Clear + (This : in out Group) is + begin + -- We don't use the actual clear method here because + -- that would delete the children from memory. + for I in reverse 1 .. This.Number_Of_Children loop + This.Remove (Index (I)); + end loop; + end Clear; + + + + + -- Contents Query -- + + function Has_Child + (This : in Group; + Place : in Index) + return Boolean is + begin + return Place in 1 .. This.Number_Of_Children; + end Has_Child; + + + function Has_Child + (Place : in Cursor) + return Boolean is + begin + return Place.My_Container.Has_Child (Place.My_Index); + end Has_Child; + + + function Child + (This : in Group; + Place : in Index) + return Widget_Reference + is + Widget_Ptr : Storage.Integer_Address := + fl_group_child (This.Void_Ptr, Interfaces.C.int (Place) - 1); + Actual_Widget : access Widget'Class; + begin + Widget_Ptr := fl_widget_get_user_data (Widget_Ptr); + pragma Assert (Widget_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); + return (Data => Actual_Widget); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::child returned Widget with no user_data reference back to Ada"; + end Child; + + + function Child + (This : in Group; + Place : in Cursor) + return Widget_Reference is + begin + return This.Child (Place.My_Index); + end Child; + + + function Find + (This : in Group; + Item : in Widget'Class) + return Extended_Index + is + Result : constant Interfaces.C.int := fl_group_find (This.Void_Ptr, Item.Void_Ptr); + begin + if Result = fl_group_children (This.Void_Ptr) then + return No_Index; + end if; + return Extended_Index (Result + 1); + end Find; + + + function Number_Of_Children + (This : in Group) + return Natural is + begin + return Natural (fl_group_children (This.Void_Ptr)); + end Number_Of_Children; + + + + + -- Iteration -- + + function Iterate + (This : in Group) + return Group_Iterators.Reversible_Iterator'Class is + begin + return It : constant Iterator := (My_Container => This'Unrestricted_Access); + end Iterate; + + + function First + (Object : in Iterator) + return Cursor is + begin + return Cu : constant Cursor := + (My_Container => Object.My_Container, + My_Index => 1); + end First; + + + function Next + (Object : in Iterator; + Place : in Cursor) + return Cursor is + begin + if Object.My_Container /= Place.My_Container then + raise Program_Error; + end if; + return Cu : constant Cursor := + (My_Container => Place.My_Container, + My_Index => Place.My_Index + 1); + end Next; + + + function Last + (Object : in Iterator) + return Cursor is + begin + return Cu : constant Cursor := + (My_Container => Object.My_Container, + My_Index => Object.My_Container.Number_Of_Children); + end Last; + + + function Previous + (Object : in Iterator; + Place : in Cursor) + return Cursor is + begin + if Object.My_Container /= Place.My_Container then + raise Program_Error; + end if; + return Cu : constant Cursor := + (My_Container => Place.My_Container, + My_Index => Place.My_Index - 1); + end Previous; + + + + + -- Clipping -- + + function Get_Clip_Mode + (This : in Group) + return Clip_Mode + is + Result : constant Interfaces.C.unsigned := fl_group_get_clip_children (This.Void_Ptr); + begin + return Clip_Mode'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Group::clip_children returned unexpected unsigned int value of " & + Interfaces.C.unsigned'Image (Result); + end Get_Clip_Mode; + + + procedure Set_Clip_Mode + (This : in out Group; + Mode : in Clip_Mode := Clip) is + begin + fl_group_set_clip_children (This.Void_Ptr, Clip_Mode'Pos (Mode)); + end Set_Clip_Mode; + + + + + -- Dimensions -- + + procedure Add_Resizable + (This : in out Group; + Item : in out Widget'Class) is + begin + fl_group_add_resizable (This.Void_Ptr, Item.Void_Ptr); + end Add_Resizable; + + + function Get_Resizable + (This : in Group) + return access Widget'Class + is + Widget_Ptr : Storage.Integer_Address := fl_group_get_resizable (This.Void_Ptr); + Actual_Widget : access Widget'Class; + begin + if Widget_Ptr /= Null_Pointer then + Widget_Ptr := fl_widget_get_user_data (Widget_Ptr); + pragma Assert (Widget_Ptr /= Null_Pointer); + Actual_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Widget_Ptr)); + end if; + return Actual_Widget; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::resizable returned Widget with no user_data reference back to Ada"; + end Get_Resizable; + + + procedure Set_Resizable + (This : in out Group; + Item : in Widget'Class) is + begin + fl_group_set_resizable (This.Void_Ptr, Item.Void_Ptr); + end Set_Resizable; + + + procedure Reset_Sizes + (This : in out Group) is + begin + fl_group_init_sizes (This.Void_Ptr); + end Reset_Sizes; + + + procedure Resize + (This : in out Group; + X, Y, W, H : in Integer) is + begin + fl_group_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Current -- + + function Get_Current + return access Group'Class + is + Group_Ptr : Storage.Integer_Address := fl_group_get_current; + Actual_Group : access Group'Class; + begin + if Group_Ptr /= Null_Pointer then + Group_Ptr := fl_widget_get_user_data (Group_Ptr); + pragma Assert (Group_Ptr /= Null_Pointer); + Actual_Group := Group_Convert.To_Pointer (Storage.To_Address (Group_Ptr)); + end if; + return Actual_Group; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Group::current returned Widget with no user_data reference back to Ada"; + end Get_Current; + + + procedure Set_Current + (To : in Group'Class) is + begin + fl_group_set_current (To.Void_Ptr); + end Set_Current; + + + procedure Begin_Current + (This : in out Group) is + begin + fl_group_begin (This.Void_Ptr); + end Begin_Current; + + + procedure End_Current + (This : in out Group) is + begin + fl_group_end (This.Void_Ptr); + end End_Current; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Group) is + begin + Widget (This).Draw; + end Draw; + + + procedure Draw_Child + (This : in out Group; + Item : in out Widget'Class) is + begin + fl_group_draw_child (This.Void_Ptr, Item.Void_Ptr); + end Draw_Child; + + + procedure Draw_Children + (This : in out Group) is + begin + fl_group_draw_children (This.Void_Ptr); + end Draw_Children; + + + procedure Draw_Outside_Label + (This : in out Group; + Item : in out Widget'Class) is + begin + fl_group_draw_outside_label (This.Void_Ptr, Item.Void_Ptr); + end Draw_Outside_Label; + + + procedure Update_Child + (This : in out Group; + Item : in out Widget'Class) is + begin + fl_group_update_child (This.Void_Ptr, Item.Void_Ptr); + end Update_Child; + + + function Handle + (This : in out Group; + Event : in Event_Kind) + return Event_Outcome is + begin + return Widget (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Groups; + + diff --git a/body/fltk-widgets-inputs-text-file.adb b/body/fltk-widgets-inputs-text-file.adb new file mode 100644 index 0000000..42c4961 --- /dev/null +++ b/body/fltk-widgets-inputs-text-file.adb @@ -0,0 +1,288 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Widgets.Groups, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Inputs.Text.File is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_file_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_file_input, "new_fl_file_input"); + pragma Inline (new_fl_file_input); + + procedure free_fl_file_input + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_file_input, "free_fl_file_input"); + pragma Inline (free_fl_file_input); + + + + + -- Settings -- + + function fl_file_input_get_down_box + (F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_file_input_get_down_box, "fl_file_input_get_down_box"); + pragma Inline (fl_file_input_get_down_box); + + procedure fl_file_input_set_down_box + (F : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_file_input_set_down_box, "fl_file_input_set_down_box"); + pragma Inline (fl_file_input_set_down_box); + + function fl_file_input_get_errorcolor + (F : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_file_input_get_errorcolor, "fl_file_input_get_errorcolor"); + pragma Inline (fl_file_input_get_errorcolor); + + procedure fl_file_input_set_errorcolor + (F : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_file_input_set_errorcolor, "fl_file_input_set_errorcolor"); + pragma Inline (fl_file_input_set_errorcolor); + + + + + -- Text Field -- + + function fl_file_input_get_value + (F : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_file_input_get_value, "fl_file_input_get_value"); + pragma Inline (fl_file_input_get_value); + + function fl_file_input_set_value + (I : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_file_input_set_value, "fl_file_input_set_value"); + pragma Inline (fl_file_input_set_value); + + + + + -- Drawing, Events -- + + procedure fl_file_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_file_input_draw, "fl_file_input_draw"); + pragma Inline (fl_file_input_draw); + + function fl_file_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_file_input_handle, "fl_file_input_handle"); + pragma Inline (fl_file_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out File_Input) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out File_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_file_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out File_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out File_Input) is + begin + This.Draw_Ptr := fl_file_input_draw'Address; + This.Handle_Ptr := fl_file_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return File_Input is + begin + return This : File_Input do + This.Void_Ptr := new_fl_file_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return File_Input is + begin + return This : File_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Settings -- + + function Get_Down_Box + (This : in File_Input) + return Box_Kind is + begin + return Box_Kind'Val (fl_file_input_get_down_box (This.Void_Ptr)); + end Get_Down_Box; + + + procedure Set_Down_Box + (This : in out File_Input; + To : in Box_Kind) is + begin + fl_file_input_set_down_box (This.Void_Ptr, Box_Kind'Pos (To)); + end Set_Down_Box; + + + function Get_Error_Color + (This : in File_Input) + return Color is + begin + return Color (fl_file_input_get_errorcolor (This.Void_Ptr)); + end Get_Error_Color; + + + procedure Set_Error_Color + (This : in out File_Input; + To : in Color) is + begin + fl_file_input_set_errorcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Error_Color; + + + + + -- Text Field -- + + function Get_Value + (This : in File_Input) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_file_input_get_value (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + -- pointer to internal buffer only, so no Free required + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Value; + + + procedure Set_Value + (This : in out File_Input; + To : in String) + is + Result : constant Interfaces.C.int := fl_file_input_set_value + (This.Void_Ptr, + Interfaces.C.To_C (To), To'Length); + begin + pragma Assert (Result /= 0); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Input::value returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Value; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out File_Input) is + begin + Text_Input (This).Draw; + end Draw; + + + function Handle + (This : in out File_Input; + Event : in Event_Kind) + return Event_Outcome is + begin + return Text_Input (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Inputs.Text.File; + + diff --git a/body/fltk-widgets-inputs-text-floating_point.adb b/body/fltk-widgets-inputs-text-floating_point.adb new file mode 100644 index 0000000..6a7925c --- /dev/null +++ b/body/fltk-widgets-inputs-text-floating_point.adb @@ -0,0 +1,162 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C.Strings; + +use type + + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Inputs.Text.Floating_Point is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_float_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_float_input, "new_fl_float_input"); + pragma Inline (new_fl_float_input); + + procedure free_fl_float_input + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_float_input, "free_fl_float_input"); + pragma Inline (free_fl_float_input); + + + + + -- Drawing, Events -- + + procedure fl_float_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_float_input_draw, "fl_float_input_draw"); + pragma Inline (fl_float_input_draw); + + function fl_float_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_float_input_handle, "fl_float_input_handle"); + pragma Inline (fl_float_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Float_Input) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Float_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_float_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Float_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Float_Input) is + begin + This.Draw_Ptr := fl_float_input_draw'Address; + This.Handle_Ptr := fl_float_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Float_Input is + begin + return This : Float_Input do + This.Void_Ptr := new_fl_float_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Float_Input is + begin + return This : Float_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Text Field -- + + function Get_Value + (This : in Float_Input) + return Long_Float + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr or else + Interfaces.C.Strings.Value (Ptr) = "" + then + return 0.0; + else + return Long_Float'Value (Interfaces.C.Strings.Value (Ptr)); + end if; + end Get_Value; + + +end FLTK.Widgets.Inputs.Text.Floating_Point; + + diff --git a/body/fltk-widgets-inputs-text-multiline.adb b/body/fltk-widgets-inputs-text-multiline.adb new file mode 100644 index 0000000..b348ce5 --- /dev/null +++ b/body/fltk-widgets-inputs-text-multiline.adb @@ -0,0 +1,133 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Inputs.Text.Multiline is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_multiline_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_multiline_input, "new_fl_multiline_input"); + pragma Inline (new_fl_multiline_input); + + procedure free_fl_multiline_input + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_multiline_input, "free_fl_multiline_input"); + pragma Inline (free_fl_multiline_input); + + + + + -- Drawing, Events -- + + procedure fl_multiline_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_multiline_input_draw, "fl_multiline_input_draw"); + pragma Inline (fl_multiline_input_draw); + + function fl_multiline_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_multiline_input_handle, "fl_multiline_input_handle"); + pragma Inline (fl_multiline_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Multiline_Input) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Multiline_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_multiline_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Multiline_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Multiline_Input) is + begin + This.Draw_Ptr := fl_multiline_input_draw'Address; + This.Handle_Ptr := fl_multiline_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Input is + begin + return This : Multiline_Input do + This.Void_Ptr := new_fl_multiline_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Input is + begin + return This : Multiline_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Inputs.Text.Multiline; + + diff --git a/body/fltk-widgets-inputs-text-outputs-multiline.adb b/body/fltk-widgets-inputs-text-outputs-multiline.adb new file mode 100644 index 0000000..e18d9b3 --- /dev/null +++ b/body/fltk-widgets-inputs-text-outputs-multiline.adb @@ -0,0 +1,133 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Inputs.Text.Outputs.Multiline is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_multiline_output + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_multiline_output, "new_fl_multiline_output"); + pragma Inline (new_fl_multiline_output); + + procedure free_fl_multiline_output + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_multiline_output, "free_fl_multiline_output"); + pragma Inline (free_fl_multiline_output); + + + + + -- Drawing, Events -- + + procedure fl_multiline_output_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_multiline_output_draw, "fl_multiline_output_draw"); + pragma Inline (fl_multiline_output_draw); + + function fl_multiline_output_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_multiline_output_handle, "fl_multiline_output_handle"); + pragma Inline (fl_multiline_output_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Multiline_Output) is + begin + Extra_Final (Output (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Multiline_Output) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_multiline_output (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Multiline_Output; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Output (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Multiline_Output) is + begin + This.Draw_Ptr := fl_multiline_output_draw'Address; + This.Handle_Ptr := fl_multiline_output_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Output is + begin + return This : Multiline_Output do + This.Void_Ptr := new_fl_multiline_output + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Output is + begin + return This : Multiline_Output := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Inputs.Text.Outputs.Multiline; + + diff --git a/body/fltk-widgets-inputs-text-outputs.adb b/body/fltk-widgets-inputs-text-outputs.adb new file mode 100644 index 0000000..6be0738 --- /dev/null +++ b/body/fltk-widgets-inputs-text-outputs.adb @@ -0,0 +1,133 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Inputs.Text.Outputs is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_output + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_output, "new_fl_output"); + pragma Inline (new_fl_output); + + procedure free_fl_output + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_output, "free_fl_output"); + pragma Inline (free_fl_output); + + + + + -- Drawing, Events -- + + procedure fl_output_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_output_draw, "fl_output_draw"); + pragma Inline (fl_output_draw); + + function fl_output_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_output_handle, "fl_output_handle"); + pragma Inline (fl_output_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Output) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Output) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_output (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Output; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Output) is + begin + This.Draw_Ptr := fl_output_draw'Address; + This.Handle_Ptr := fl_output_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Output is + begin + return This : Output do + This.Void_Ptr := new_fl_output + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Output is + begin + return This : Output := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Inputs.Text.Outputs; + + diff --git a/body/fltk-widgets-inputs-text-secret.adb b/body/fltk-widgets-inputs-text-secret.adb new file mode 100644 index 0000000..146133f --- /dev/null +++ b/body/fltk-widgets-inputs-text-secret.adb @@ -0,0 +1,150 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Inputs.Text.Secret is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_secret_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_secret_input, "new_fl_secret_input"); + pragma Inline (new_fl_secret_input); + + procedure free_fl_secret_input + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_secret_input, "free_fl_secret_input"); + pragma Inline (free_fl_secret_input); + + + + + -- Drawing, Events -- + + procedure fl_secret_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_secret_input_draw, "fl_secret_input_draw"); + pragma Inline (fl_secret_input_draw); + + function fl_secret_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_secret_input_handle, "fl_secret_input_handle"); + pragma Inline (fl_secret_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Secret_Input) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Secret_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_secret_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Secret_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Secret_Input) is + begin + This.Draw_Ptr := fl_secret_input_draw'Address; + This.Handle_Ptr := fl_secret_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Secret_Input is + begin + return This : Secret_Input do + This.Void_Ptr := new_fl_secret_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Secret_Input is + begin + return This : Secret_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Events -- + + function Handle + (This : in out Secret_Input; + Event : in Event_Kind) + return Event_Outcome is + begin + return Text_Input (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Inputs.Text.Secret; + + diff --git a/body/fltk-widgets-inputs-text-whole_number.adb b/body/fltk-widgets-inputs-text-whole_number.adb new file mode 100644 index 0000000..070dc0f --- /dev/null +++ b/body/fltk-widgets-inputs-text-whole_number.adb @@ -0,0 +1,162 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C.Strings; + +use type + + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Inputs.Text.Whole_Number is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_int_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_int_input, "new_fl_int_input"); + pragma Inline (new_fl_int_input); + + procedure free_fl_int_input + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_int_input, "free_fl_int_input"); + pragma Inline (free_fl_int_input); + + + + + -- Drawing, Events -- + + procedure fl_int_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_int_input_draw, "fl_int_input_draw"); + pragma Inline (fl_int_input_draw); + + function fl_int_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_int_input_handle, "fl_int_input_handle"); + pragma Inline (fl_int_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Integer_Input) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Integer_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_int_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Integer_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Integer_Input) is + begin + This.Draw_Ptr := fl_int_input_draw'Address; + This.Handle_Ptr := fl_int_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Integer_Input is + begin + return This : Integer_Input do + This.Void_Ptr := new_fl_int_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Integer_Input is + begin + return This : Integer_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Text Field -- + + function Get_Value + (This : in Integer_Input) + return Long_Integer + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr or else + Interfaces.C.Strings.Value (Ptr) = "" + then + return 0; + else + return Long_Integer'Value (Interfaces.C.Strings.Value (Ptr)); + end if; + end Get_Value; + + +end FLTK.Widgets.Inputs.Text.Whole_Number; + + diff --git a/body/fltk-widgets-inputs-text.adb b/body/fltk-widgets-inputs-text.adb new file mode 100644 index 0000000..ddac5d9 --- /dev/null +++ b/body/fltk-widgets-inputs-text.adb @@ -0,0 +1,182 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Inputs.Text is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_text_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_text_input, "new_fl_text_input"); + pragma Inline (new_fl_text_input); + + procedure free_fl_text_input + (T : in Storage.Integer_Address); + pragma Import (C, free_fl_text_input, "free_fl_text_input"); + pragma Inline (free_fl_text_input); + + + + + -- Drawing, Events -- + + procedure fl_text_input_draw + (T : in Storage.Integer_Address); + pragma Import (C, fl_text_input_draw, "fl_text_input_draw"); + pragma Inline (fl_text_input_draw); + + function fl_text_input_handle + (T : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_text_input_handle, "fl_text_input_handle"); + pragma Inline (fl_text_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Text_Input) is + begin + Extra_Final (Input (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Text_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_text_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Last stop, everyone out! + procedure text_input_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, text_input_extra_init_hook, "text_input_extra_init_hook"); + + procedure text_input_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Text_Input : Text_Input; + for My_Text_Input'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Text_Input); + begin + Extra_Init + (My_Text_Input, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end text_input_extra_init_hook; + + + procedure Extra_Init + (This : in out Text_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Input (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Text_Input) is + begin + This.Draw_Ptr := fl_text_input_draw'Address; + This.Handle_Ptr := fl_text_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Text_Input is + begin + return This : Text_Input do + This.Void_Ptr := new_fl_text_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Text_Input is + begin + return This : Text_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Drawing, Events -- + + procedure Draw + (This : in out Text_Input) is + begin + Input (This).Draw; + end Draw; + + + function Handle + (This : in out Text_Input; + Event : in Event_Kind) + return Event_Outcome is + begin + return Input (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Inputs.Text; + + diff --git a/body/fltk-widgets-inputs.adb b/body/fltk-widgets-inputs.adb new file mode 100644 index 0000000..2057f96 --- /dev/null +++ b/body/fltk-widgets-inputs.adb @@ -0,0 +1,985 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Widgets.Groups, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Inputs is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_input, "new_fl_input"); + pragma Inline (new_fl_input); + + procedure free_fl_input + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_input, "free_fl_input"); + pragma Inline (free_fl_input); + + + + + -- Clipboard -- + + function fl_input_copy + (I : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_copy, "fl_input_copy"); + pragma Inline (fl_input_copy); + + function fl_input_cut + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_cut, "fl_input_cut"); + pragma Inline (fl_input_cut); + + function fl_input_cut2 + (I : in Storage.Integer_Address; + B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_cut2, "fl_input_cut2"); + pragma Inline (fl_input_cut2); + + function fl_input_cut3 + (I : in Storage.Integer_Address; + A, B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_cut3, "fl_input_cut3"); + pragma Inline (fl_input_cut3); + + function fl_input_copy_cuts + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_copy_cuts, "fl_input_copy_cuts"); + pragma Inline (fl_input_copy_cuts); + + function fl_input_undo + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_undo, "fl_input_undo"); + pragma Inline (fl_input_undo); + + + + + -- Readonly, Tabs, Wrap -- + + function fl_input_get_readonly + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_readonly, "fl_input_get_readonly"); + pragma Inline (fl_input_get_readonly); + + procedure fl_input_set_readonly + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_readonly, "fl_input_set_readonly"); + pragma Inline (fl_input_set_readonly); + + function fl_input_get_tab_nav + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_tab_nav, "fl_input_get_tab_nav"); + pragma Inline (fl_input_get_tab_nav); + + procedure fl_input_set_tab_nav + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_tab_nav, "fl_input_set_tab_nav"); + pragma Inline (fl_input_set_tab_nav); + + function fl_input_get_wrap + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_wrap, "fl_input_get_wrap"); + pragma Inline (fl_input_get_wrap); + + procedure fl_input_set_wrap + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_wrap, "fl_input_set_wrap"); + pragma Inline (fl_input_set_wrap); + + + + + -- Shortcut, Input Position -- + + function fl_input_get_input_type + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_input_type, "fl_input_get_input_type"); + pragma Inline (fl_input_get_input_type); + + procedure fl_input_set_input_type + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_input_type, "fl_input_set_input_type"); + pragma Inline (fl_input_set_input_type); + + function fl_input_get_shortcut + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_shortcut, "fl_input_get_shortcut"); + pragma Inline (fl_input_get_shortcut); + + procedure fl_input_set_shortcut + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_shortcut, "fl_input_set_shortcut"); + pragma Inline (fl_input_set_shortcut); + + function fl_input_get_mark + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_mark, "fl_input_get_mark"); + pragma Inline (fl_input_get_mark); + + function fl_input_set_mark + (I : in Storage.Integer_Address; + T : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_set_mark, "fl_input_set_mark"); + pragma Inline (fl_input_set_mark); + + function fl_input_get_position + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_position, "fl_input_get_position"); + pragma Inline (fl_input_get_position); + + function fl_input_set_position + (I : in Storage.Integer_Address; + T : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_set_position, "fl_input_set_position"); + pragma Inline (fl_input_set_position); + + function fl_input_set_position2 + (I : in Storage.Integer_Address; + P, M : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_set_position2, "fl_input_set_position2"); + pragma Inline (fl_input_set_position2); + + + + + -- Text Field -- + + function fl_input_index + (I : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_input_index, "fl_input_index"); + pragma Inline (fl_input_index); + + function fl_input_insert + (I : in Storage.Integer_Address; + S : in Interfaces.C.char_array; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_insert, "fl_input_insert"); + pragma Inline (fl_input_insert); + + function fl_input_replace + (I : in Storage.Integer_Address; + B, E : in Interfaces.C.int; + S : in Interfaces.C.char_array; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_replace, "fl_input_replace"); + pragma Inline (fl_input_replace); + + function fl_input_set_value + (I : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + L : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_set_value, "fl_input_set_value"); + pragma Inline (fl_input_set_value); + + + + + -- Input Size -- + + function fl_input_get_maximum_size + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_maximum_size, "fl_input_get_maximum_size"); + pragma Inline (fl_input_get_maximum_size); + + procedure fl_input_set_maximum_size + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_maximum_size, "fl_input_set_maximum_size"); + pragma Inline (fl_input_set_maximum_size); + + function fl_input_get_size + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_size, "fl_input_get_size"); + pragma Inline (fl_input_get_size); + + + + + -- Cursors, Text Settings -- + + function fl_input_get_cursor_color + (I : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_input_get_cursor_color, "fl_input_get_cursor_color"); + pragma Inline (fl_input_get_cursor_color); + + procedure fl_input_set_cursor_color + (I : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_input_set_cursor_color, "fl_input_set_cursor_color"); + pragma Inline (fl_input_set_cursor_color); + + function fl_input_get_textcolor + (I : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_input_get_textcolor, "fl_input_get_textcolor"); + pragma Inline (fl_input_get_textcolor); + + procedure fl_input_set_textcolor + (I : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_input_set_textcolor, "fl_input_set_textcolor"); + pragma Inline (fl_input_set_textcolor); + + function fl_input_get_textfont + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_textfont, "fl_input_get_textfont"); + pragma Inline (fl_input_get_textfont); + + procedure fl_input_set_textfont + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_textfont, "fl_input_set_textfont"); + pragma Inline (fl_input_set_textfont); + + function fl_input_get_textsize + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_input_get_textsize, "fl_input_get_textsize"); + pragma Inline (fl_input_get_textsize); + + procedure fl_input_set_textsize + (I : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_input_set_textsize, "fl_input_set_textsize"); + pragma Inline (fl_input_set_textsize); + + + + + -- Dimensions -- + + procedure fl_input_set_size + (I : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_input_set_size, "fl_input_set_size"); + pragma Inline (fl_input_set_size); + + procedure fl_input_resize + (I : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_input_resize, "fl_input_resize"); + pragma Inline (fl_input_resize); + + + + + -- Drawing, Events -- + + procedure fl_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_input_draw, "fl_input_draw"); + pragma Inline (fl_input_draw); + + function fl_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_input_handle, "fl_input_handle"); + pragma Inline (fl_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Input) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Input) is + begin + This.Draw_Ptr := fl_input_draw'Address; + This.Handle_Ptr := fl_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Input is + begin + return This : Input do + This.Void_Ptr := new_fl_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Input is + begin + return This : Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Clipboard -- + + procedure Copy + (This : in out Input; + Destination : in Clipboard_Kind := Cut_Paste_Board) + is + Result : constant Interfaces.C.int := fl_input_copy + (This.Void_Ptr, Clipboard_Kind'Pos (Destination)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Input_::copy returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Copy; + + + function Copy + (This : in out Input; + Destination : in Clipboard_Kind := Cut_Paste_Board) + return Boolean + is + Result : constant Interfaces.C.int := fl_input_copy + (This.Void_Ptr, Clipboard_Kind'Pos (Destination)); + begin + pragma Assert (Result in 0 .. 1); + return Boolean'Val (Result); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Input_::copy returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Copy; + + + procedure Cut + (This : in out Input) + is + Ignore : constant Interfaces.C.int := fl_input_cut (This.Void_Ptr); + begin + null; + end Cut; + + + function Cut + (This : in out Input) + return Boolean is + begin + return fl_input_cut (This.Void_Ptr) /= 0; + end Cut; + + + procedure Cut + (This : in out Input; + Num_Bytes : in Integer) + is + Ignore : constant Interfaces.C.int := fl_input_cut2 + (This.Void_Ptr, + Interfaces.C.int (Num_Bytes)); + begin + null; + end Cut; + + + function Cut + (This : in out Input; + Num_Bytes : in Integer) + return Boolean is + begin + return fl_input_cut2 + (This.Void_Ptr, + Interfaces.C.int (Num_Bytes)) /= 0; + end Cut; + + + procedure Cut + (This : in out Input; + Start, Finish : in Integer) + is + Ignore : constant Interfaces.C.int := fl_input_cut3 + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)); + begin + null; + end Cut; + + + function Cut + (This : in out Input; + Start, Finish : in Integer) + return Boolean is + begin + return fl_input_cut3 + (This.Void_Ptr, + Interfaces.C.int (Start), + Interfaces.C.int (Finish)) /= 0; + end Cut; + + + procedure Copy_Cuts + (This : in out Input) + is + Ignore : constant Interfaces.C.int := fl_input_copy_cuts (This.Void_Ptr); + begin + null; + end Copy_Cuts; + + + function Copy_Cuts + (This : in out Input) + return Boolean + is + Result : constant Interfaces.C.int := fl_input_copy_cuts (This.Void_Ptr); + begin + return Result /= 0; + end Copy_Cuts; + + + procedure Undo + (This : in out Input) + is + Ignore : constant Interfaces.C.int := fl_input_undo (This.Void_Ptr); + begin + null; + end Undo; + + + function Undo + (This : in out Input) + return Boolean is + begin + return fl_input_undo (This.Void_Ptr) /= 0; + end Undo; + + + + + -- Readonly, Tabs, Wrap -- + + function Is_Readonly + (This : in Input) + return Boolean is + begin + return fl_input_get_readonly (This.Void_Ptr) /= 0; + end Is_Readonly; + + + procedure Set_Readonly + (This : in out Input; + To : in Boolean) is + begin + fl_input_set_readonly (This.Void_Ptr, Boolean'Pos (To)); + end Set_Readonly; + + + function Is_Tab_Nav + (This : in Input) + return Boolean is + begin + return fl_input_get_tab_nav (This.Void_Ptr) /= 0; + end Is_Tab_Nav; + + + procedure Set_Tab_Nav + (This : in out Input; + To : in Boolean) is + begin + fl_input_set_tab_nav (This.Void_Ptr, Boolean'Pos (To)); + end Set_Tab_Nav; + + + function Is_Wrap + (This : in Input) + return Boolean is + begin + return fl_input_get_wrap (This.Void_Ptr) /= 0; + end Is_Wrap; + + + procedure Set_Wrap + (This : in out Input; + To : in Boolean) is + begin + fl_input_set_wrap (This.Void_Ptr, Boolean'Pos (To)); + end Set_Wrap; + + + + + -- Shortcut, Input Position -- + + function Get_Kind + (This : in Input) + return Input_Kind + is + C_Val : constant Interfaces.C.int := fl_input_get_input_type (This.Void_Ptr); + begin + for V in Input_Kind loop + if Input_Kind_Values (V) = C_Val then + return V; + end if; + end loop; + return Normal_Field; + end Get_Kind; + + + function Get_Shortcut + (This : in Input) + return Key_Combo is + begin + return To_Ada (Interfaces.C.unsigned (fl_input_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Input; + To : in Key_Combo) is + begin + fl_input_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); + end Set_Shortcut; + + + function Get_Mark + (This : in Input) + return Natural is + begin + return Natural (fl_input_get_mark (This.Void_Ptr)); + end Get_Mark; + + + procedure Set_Mark + (This : in out Input; + To : in Natural) + is + Ignore : constant Interfaces.C.int := fl_input_set_mark + (This.Void_Ptr, + Interfaces.C.int (To)); + begin + null; + end Set_Mark; + + + function Set_Mark + (This : in out Input; + To : in Natural) + return Boolean is + begin + return fl_input_set_mark + (This.Void_Ptr, + Interfaces.C.int (To)) /= 0; + end Set_Mark; + + + function Get_Position + (This : in Input) + return Natural is + begin + return Natural (fl_input_get_position (This.Void_Ptr)); + end Get_Position; + + + procedure Set_Position + (This : in out Input; + To : in Natural) + is + Ignore : constant Interfaces.C.int := fl_input_set_position + (This.Void_Ptr, + Interfaces.C.int (To)); + begin + null; + end Set_Position; + + + function Set_Position + (This : in out Input; + To : in Natural) + return Boolean is + begin + return fl_input_set_position + (This.Void_Ptr, + Interfaces.C.int (To)) /= 0; + end Set_Position; + + + procedure Set_Position_Mark + (This : in out Input; + Place : in Natural; + Mark : in Natural) + is + Ignore : constant Interfaces.C.int := fl_input_set_position2 + (This.Void_Ptr, + Interfaces.C.int (Place), + Interfaces.C.int (Mark)); + begin + null; + end Set_Position_Mark; + + + function Set_Position_Mark + (This : in out Input; + Place : in Natural; + Mark : in Natural) + return Boolean is + begin + return fl_input_set_position2 + (This.Void_Ptr, + Interfaces.C.int (Place), + Interfaces.C.int (Mark)) /= 0; + end Set_Position_Mark; + + + + + -- Text Field -- + + function Index + (This : in Input; + Place : in Integer) + return Character is + begin + return Character'Val (fl_input_index (This.Void_Ptr, Interfaces.C.int (Place))); + end Index; + + + procedure Insert + (This : in out Input; + Str : in String) + is + Ignore : constant Interfaces.C.int := fl_input_insert + (This.Void_Ptr, + Interfaces.C.To_C (Str, False), + Str'Length); + begin + null; + end Insert; + + + function Insert + (This : in out Input; + Str : in String) + return Boolean is + begin + return fl_input_insert + (This.Void_Ptr, + Interfaces.C.To_C (Str, False), + Str'Length) /= 0; + end Insert; + + + procedure Replace + (This : in out Input; + From, To : in Natural; + New_Text : in String) + is + Ignore : constant Interfaces.C.int := fl_input_replace + (This.Void_Ptr, + Interfaces.C.int (From), + Interfaces.C.int (To), + Interfaces.C.To_C (New_Text), + New_Text'Length); + begin + null; + end Replace; + + + function Replace + (This : in out Input; + From, To : in Natural; + New_Text : in String) + return Boolean is + begin + return fl_input_replace + (This.Void_Ptr, + Interfaces.C.int (From), + Interfaces.C.int (To), + Interfaces.C.To_C (New_Text, False), + New_Text'Length) /= 0; + end Replace; + + + function Get_Value + (This : in Input) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_input_get_value (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + -- pointer to internal buffer only, so no Free required + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Value; + + + procedure Set_Value + (This : in out Input; + To : in String) + is + Ignore : constant Interfaces.C.int := fl_input_set_value + (This.Void_Ptr, Interfaces.C.To_C (To), To'Length); + begin + null; + end Set_Value; + + + function Set_Value + (This : in out Input; + To : in String) + return Boolean is + begin + return fl_input_set_value + (This.Void_Ptr, + Interfaces.C.To_C (To, False), + To'Length) /= 0; + end Set_Value; + + + + + -- Input Size -- + + function Get_Maximum_Size + (This : in Input) + return Natural is + begin + return Natural (fl_input_get_maximum_size (This.Void_Ptr)); + end Get_Maximum_Size; + + + procedure Set_Maximum_Size + (This : in out Input; + To : in Natural) is + begin + fl_input_set_maximum_size (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Maximum_Size; + + + function Size + (This : in Input) + return Natural is + begin + return Natural (fl_input_get_size (This.Void_Ptr)); + end Size; + + + + + -- Cursors, Text Settings -- + + function Get_Cursor_Color + (This : in Input) + return Color is + begin + return Color (fl_input_get_cursor_color (This.Void_Ptr)); + end Get_Cursor_Color; + + + procedure Set_Cursor_Color + (This : in out Input; + To : in Color) is + begin + fl_input_set_cursor_color (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Cursor_Color; + + + function Get_Text_Color + (This : in Input) + return Color is + begin + return Color (fl_input_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Input; + To : in Color) is + begin + fl_input_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Input) + return Font_Kind is + begin + return Font_Kind'Val (fl_input_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Input; + To : in Font_Kind) is + begin + fl_input_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Input) + return Font_Size is + begin + return Font_Size (fl_input_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Input; + To : in Font_Size) is + begin + fl_input_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Input; + W, H : in Integer) is + begin + fl_input_set_size (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)); + end Resize; + + + procedure Resize + (This : in out Input; + X, Y, W, H : in Integer) is + begin + fl_input_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Changing Input Type -- + + package body Extra is + + procedure Set_Kind + (This : in out Input; + To : in Input_Kind) is + begin + fl_input_set_input_type (This.Void_Ptr, Input_Kind_Values (To)); + end Set_Kind; + + pragma Inline (Set_Kind); + + end Extra; + + +end FLTK.Widgets.Inputs; + + diff --git a/body/fltk-widgets-menus-choices.adb b/body/fltk-widgets-menus-choices.adb new file mode 100644 index 0000000..ac4564c --- /dev/null +++ b/body/fltk-widgets-menus-choices.adb @@ -0,0 +1,250 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Menus.Choices is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_choice + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_choice, "new_fl_choice"); + pragma Inline (new_fl_choice); + + procedure free_fl_choice + (B : in Storage.Integer_Address); + pragma Import (C, free_fl_choice, "free_fl_choice"); + pragma Inline (free_fl_choice); + + + + + -- Selection -- + + function fl_choice_value + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_choice_value, "fl_choice_value"); + pragma Inline (fl_choice_value); + + function fl_choice_set_value + (M, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_choice_set_value, "fl_choice_set_value"); + pragma Inline (fl_choice_set_value); + + function fl_choice_set_value2 + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_choice_set_value2, "fl_choice_set_value2"); + pragma Inline (fl_choice_set_value2); + + + + + -- Drawing, Events -- + + procedure fl_choice_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_choice_draw, "fl_choice_draw"); + pragma Inline (fl_choice_draw); + + function fl_choice_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_choice_handle, "fl_choice_handle"); + pragma Inline (fl_choice_handle); + + + + + -- Initialize -- + + function fl_menu_get_item + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_get_item, "fl_menu_get_item"); + pragma Inline (fl_menu_get_item); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Choice) is + begin + Extra_Final (Menu (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Choice) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_choice (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Choice; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Menu (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Choice) is + begin + This.Draw_Ptr := fl_choice_draw'Address; + This.Handle_Ptr := fl_choice_handle'Address; + This.Get_Item_Ptr := fl_menu_get_item'Address; + This.Value_Ptr := fl_choice_value'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Choice is + begin + return This : Choice do + This.Void_Ptr := new_fl_choice + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Choice is + begin + return This : Choice := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Selection -- + + function Chosen_Index + (This : in Choice) + return Extended_Index is + begin + return Menu (This).Chosen_Index; + end Chosen_Index; + + + procedure Set_Chosen + (This : in out Choice; + Item : in FLTK.Menu_Items.Menu_Item) + is + Ignore_Ret : Interfaces.C.int; + begin + Ignore_Ret := fl_choice_set_value (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Chosen; + + + function Set_Chosen + (This : in out Choice; + Item : in FLTK.Menu_Items.Menu_Item) + return Boolean is + begin + return fl_choice_set_value (This.Void_Ptr, Wrapper (Item).Void_Ptr) /= 0; + end Set_Chosen; + + + procedure Set_Chosen + (This : in out Choice; + Place : in Index) + is + Ignore_Ret : Interfaces.C.int; + begin + Ignore_Ret := fl_choice_set_value2 (This.Void_Ptr, Interfaces.C.int (Place) - 1); + end Set_Chosen; + + + function Set_Chosen + (This : in out Choice; + Place : in Index) + return Boolean is + begin + return fl_choice_set_value2 (This.Void_Ptr, Interfaces.C.int (Place) - 1) /= 0; + end Set_Chosen; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Choice) is + begin + Menu (This).Draw; + end Draw; + + + function Handle + (This : in out Choice; + Event : in Event_Kind) + return Event_Outcome is + begin + return Menu (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Menus.Choices; + + diff --git a/body/fltk-widgets-menus-menu_bars-systemwide.adb b/body/fltk-widgets-menus-menu_bars-systemwide.adb new file mode 100644 index 0000000..88792bb --- /dev/null +++ b/body/fltk-widgets-menus-menu_bars-systemwide.adb @@ -0,0 +1,644 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Unchecked_Deallocation, + FLTK.Widgets.Groups, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is + + + package Chk renames Ada.Assertions; + + procedure Free_Item is new Ada.Unchecked_Deallocation + (Object => FLTK.Menu_Items.Menu_Item, Name => Item_Access); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_sys_menu_bar + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_sys_menu_bar, "new_fl_sys_menu_bar"); + pragma Inline (new_fl_sys_menu_bar); + + procedure free_fl_sys_menu_bar + (M : in Storage.Integer_Address); + pragma Import (C, free_fl_sys_menu_bar, "free_fl_sys_menu_bar"); + pragma Inline (free_fl_sys_menu_bar); + + + + + -- Menu Items -- + + function fl_sys_menu_bar_add + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_add, "fl_sys_menu_bar_add"); + pragma Inline (fl_sys_menu_bar_add); + + function fl_sys_menu_bar_add2 + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + S : in Interfaces.C.int; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_add2, "fl_sys_menu_bar_add2"); + pragma Inline (fl_sys_menu_bar_add2); + + function fl_sys_menu_bar_add3 + (M : in Storage.Integer_Address; + T, S : in Interfaces.C.char_array; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_add3, "fl_sys_menu_bar_add3"); + pragma Inline (fl_sys_menu_bar_add3); + + function fl_sys_menu_bar_insert + (M : in Storage.Integer_Address; + P : in Interfaces.C.int; + T : in Interfaces.C.char_array; + S : in Interfaces.C.int; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_insert, "fl_sys_menu_bar_insert"); + pragma Inline (fl_sys_menu_bar_insert); + + function fl_sys_menu_bar_insert2 + (M : in Storage.Integer_Address; + P : in Interfaces.C.int; + T, S : in Interfaces.C.char_array; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_insert2, "fl_sys_menu_bar_insert2"); + pragma Inline (fl_sys_menu_bar_insert2); + + procedure fl_sys_menu_bar_set_menu + (M, D : in Storage.Integer_Address); + pragma Import (C, fl_sys_menu_bar_set_menu, "fl_sys_menu_bar_set_menu"); + pragma Inline (fl_sys_menu_bar_set_menu); + + procedure fl_sys_menu_bar_remove + (M : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_sys_menu_bar_remove, "fl_sys_menu_bar_remove"); + pragma Inline (fl_sys_menu_bar_remove); + + procedure fl_sys_menu_bar_clear + (M : in Storage.Integer_Address); + pragma Import (C, fl_sys_menu_bar_clear, "fl_sys_menu_bar_clear"); + pragma Inline (fl_sys_menu_bar_clear); + + function fl_sys_menu_bar_clear_submenu + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_clear_submenu, "fl_sys_menu_bar_clear_submenu"); + pragma Inline (fl_sys_menu_bar_clear_submenu); + + + + + -- Item Query -- + + function fl_sys_menu_bar_get_item + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_sys_menu_bar_get_item, "fl_sys_menu_bar_get_item"); + pragma Inline (fl_sys_menu_bar_get_item); + + + + + -- Label, Shortcut, Flags -- + + procedure fl_sys_menu_bar_setonly + (M, I : in Storage.Integer_Address); + pragma Import (C, fl_sys_menu_bar_setonly, "fl_sys_menu_bar_setonly"); + pragma Inline (fl_sys_menu_bar_setonly); + + procedure fl_sys_menu_bar_replace + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_sys_menu_bar_replace, "fl_sys_menu_bar_replace"); + pragma Inline (fl_sys_menu_bar_replace); + + procedure fl_sys_menu_bar_shortcut + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + S : in Interfaces.C.int); + pragma Import (C, fl_sys_menu_bar_shortcut, "fl_sys_menu_bar_shortcut"); + pragma Inline (fl_sys_menu_bar_shortcut); + + function fl_sys_menu_bar_get_mode + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_get_mode, "fl_sys_menu_bar_get_mode"); + pragma Inline (fl_sys_menu_bar_get_mode); + + procedure fl_sys_menu_bar_set_mode + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + F : in Interfaces.C.int); + pragma Import (C, fl_sys_menu_bar_set_mode, "fl_sys_menu_bar_set_mode"); + pragma Inline (fl_sys_menu_bar_set_mode); + + + + + -- Global -- + + procedure fl_sys_menu_bar_global + (M : in Storage.Integer_Address); + pragma Import (C, fl_sys_menu_bar_global, "fl_sys_menu_bar_global"); + pragma Inline (fl_sys_menu_bar_global); + + procedure fl_sys_menu_bar_update + (M : in Storage.Integer_Address); + pragma Import (C, fl_sys_menu_bar_update, "fl_sys_menu_bar_update"); + pragma Inline (fl_sys_menu_bar_update); + + + + + -- Drawing, Events -- + + procedure fl_sys_menu_bar_draw + (M : in Storage.Integer_Address); + pragma Import (C, fl_sys_menu_bar_draw, "fl_sys_menu_bar_draw"); + pragma Inline (fl_sys_menu_bar_draw); + + function fl_sys_menu_bar_handle + (M : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_sys_menu_bar_handle, "fl_sys_menu_bar_handle"); + pragma Inline (fl_sys_menu_bar_handle); + + + + + -- Initialize -- + + function fl_menu_value + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_value, "fl_menu_value"); + pragma Inline (fl_menu_value); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out System_Menu_Bar) is + begin + Extra_Final (Menu_Bar (This)); + end Extra_Final; + + + procedure Finalize + (This : in out System_Menu_Bar) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_sys_menu_bar (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out System_Menu_Bar; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Menu_Bar (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out System_Menu_Bar) is + begin + This.Draw_Ptr := fl_sys_menu_bar_draw'Address; + This.Handle_Ptr := fl_sys_menu_bar_handle'Address; + This.Get_Item_Ptr := fl_sys_menu_bar_get_item'Address; + This.Value_Ptr := fl_menu_value'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return System_Menu_Bar is + begin + return This : System_Menu_Bar do + This.Void_Ptr := new_fl_sys_menu_bar + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return System_Menu_Bar is + begin + return This : System_Menu_Bar := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Menu Items -- + + procedure Add + (This : in out System_Menu_Bar; + Text : in String) + is + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_add + (This.Void_Ptr, Interfaces.C.To_C (Text)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out System_Menu_Bar; + Text : in String) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_add + (This.Void_Ptr, Interfaces.C.To_C (Text)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_add2 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_add2 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_add3 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_add3 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_insert + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Insert; + + + function Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_insert + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Insert; + + + procedure Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_sys_menu_bar_insert2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Insert; + + + function Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_sys_menu_bar_insert2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Insert; + + + procedure Use_Same_Items + (This : in out System_Menu_Bar; + Donor : in Menu'Class) is + begin + -- Donor menu() pointer will be obtained in C++ + fl_sys_menu_bar_set_menu (This.Void_Ptr, Donor.Void_Ptr); + This.Adjust_Item_Store; + end Use_Same_Items; + + + procedure Remove + (This : in out System_Menu_Bar; + Place : in Index) is + begin + fl_sys_menu_bar_remove (This.Void_Ptr, Interfaces.C.int (Place) - 1); + This.Adjust_Item_Store; + end Remove; + + + procedure Clear + (This : in out System_Menu_Bar) is + begin + for Item of This.My_Items loop + Free_Item (Item); + end loop; + This.My_Items.Clear; + fl_sys_menu_bar_clear (This.Void_Ptr); + end Clear; + + + procedure Clear_Submenu + (This : in out System_Menu_Bar; + Place : in Index) + is + Result : constant Interfaces.C.int := fl_sys_menu_bar_clear_submenu + (This.Void_Ptr, + Interfaces.C.int (Place) - 1); + begin + if Result = -1 then + raise No_Reference_Error; + else + pragma Assert (Result = 0); + This.Adjust_Item_Store; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Sys_Menu_Bar::clear_submenu returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Clear_Submenu; + + + + + -- Item Query -- + + function Item + (This : in System_Menu_Bar; + Place : in Index) + return FLTK.Menu_Items.Menu_Item_Reference is + begin + return Menu_Bar (This).Item (Place); + end Item; + + + + + -- Label, Shortcut, Flags -- + + procedure Set_Only + (This : in out System_Menu_Bar; + Item : in out FLTK.Menu_Items.Menu_Item) is + begin + fl_sys_menu_bar_setonly (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Only; + + + procedure Set_Label + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String) is + begin + fl_sys_menu_bar_replace + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Shortcut + (This : in out System_Menu_Bar; + Place : in Index; + Press : in Key_Combo) is + begin + fl_sys_menu_bar_shortcut + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.int (To_C (Press))); + end Set_Shortcut; + + + function Get_Flags + (This : in System_Menu_Bar; + Place : in Index) + return Menu_Flag is + begin + return Cint_To_MFlag + (fl_sys_menu_bar_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); + end Get_Flags; + + + procedure Set_Flags + (This : in out System_Menu_Bar; + Place : in Index; + Flags : in Menu_Flag) is + begin + fl_sys_menu_bar_set_mode + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + MFlag_To_Cint (Flags)); + end Set_Flags; + + + + + -- Global -- + + procedure Make_Global + (This : in out System_Menu_Bar) is + begin + fl_sys_menu_bar_global (This.Void_Ptr); + end Make_Global; + + + procedure Update + (This : in out System_Menu_Bar) is + begin + fl_sys_menu_bar_update (This.Void_Ptr); + end Update; + + + + + -- Drawing -- + + procedure Draw + (This : in out System_Menu_Bar) is + begin + Menu_Bar (This).Draw; + end Draw; + + +end FLTK.Widgets.Menus.Menu_Bars.Systemwide; + + diff --git a/body/fltk-widgets-menus-menu_bars.adb b/body/fltk-widgets-menus-menu_bars.adb new file mode 100644 index 0000000..ec865c8 --- /dev/null +++ b/body/fltk-widgets-menus-menu_bars.adb @@ -0,0 +1,178 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Menus.Menu_Bars is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_menu_bar + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu_bar, "new_fl_menu_bar"); + pragma Inline (new_fl_menu_bar); + + procedure free_fl_menu_bar + (M : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_bar, "free_fl_menu_bar"); + pragma Inline (free_fl_menu_bar); + + + + + -- Drawing, Events -- + + procedure fl_menu_bar_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_menu_bar_draw, "fl_menu_bar_draw"); + pragma Inline (fl_menu_bar_draw); + + function fl_menu_bar_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_bar_handle, "fl_menu_bar_handle"); + pragma Inline (fl_menu_bar_handle); + + + + + -- Initialize -- + + function fl_menu_get_item + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_get_item, "fl_menu_get_item"); + pragma Inline (fl_menu_get_item); + + function fl_menu_value + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_value, "fl_menu_value"); + pragma Inline (fl_menu_value); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Menu_Bar) is + begin + Extra_Final (Menu (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Menu_Bar) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_menu_bar (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Menu_Bar; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Menu (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Menu_Bar) is + begin + This.Draw_Ptr := fl_menu_bar_draw'Address; + This.Handle_Ptr := fl_menu_bar_handle'Address; + This.Get_Item_Ptr := fl_menu_get_item'Address; + This.Value_Ptr := fl_menu_value'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Bar is + begin + return This : Menu_Bar do + This.Void_Ptr := new_fl_menu_bar + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Bar is + begin + return This : Menu_Bar := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Drawing, Events -- + + procedure Draw + (This : in out Menu_Bar) is + begin + Menu (This).Draw; + end Draw; + + + function Handle + (This : in out Menu_Bar; + Event : in Event_Kind) + return Event_Outcome is + begin + return Menu (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Menus.Menu_Bars; + + diff --git a/body/fltk-widgets-menus-menu_buttons.adb b/body/fltk-widgets-menus-menu_buttons.adb new file mode 100644 index 0000000..c305320 --- /dev/null +++ b/body/fltk-widgets-menus-menu_buttons.adb @@ -0,0 +1,256 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C.Strings; + + +package body FLTK.Widgets.Menus.Menu_Buttons is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_menu_button + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu_button, "new_fl_menu_button"); + pragma Inline (new_fl_menu_button); + + procedure free_fl_menu_button + (M : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_button, "free_fl_menu_button"); + pragma Inline (free_fl_menu_button); + + + + + -- Popup -- + + function fl_menu_button_popup + (M : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_button_popup, "fl_menu_button_popup"); + pragma Inline (fl_menu_button_popup); + + function fl_menu_find_index2 + (M, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_find_index2, "fl_menu_find_index2"); + pragma Inline (fl_menu_find_index2); + + + + + -- Drawing, Events -- + + procedure fl_menu_button_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_menu_button_draw, "fl_menu_button_draw"); + pragma Inline (fl_menu_button_draw); + + function fl_menu_button_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_button_handle, "fl_menu_button_handle"); + pragma Inline (fl_menu_button_handle); + + + + + -- Initialize -- + + function fl_menu_get_item + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_get_item, "fl_menu_get_item"); + pragma Inline (fl_menu_get_item); + + function fl_menu_value + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_value, "fl_menu_value"); + pragma Inline (fl_menu_value); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Menu_Button) is + begin + Extra_Final (Menu (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Menu_Button) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_menu_button (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Long distance telephone call receival + procedure menu_button_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, menu_button_extra_init_hook, "menu_button_extra_init_hook"); + + procedure menu_button_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Menu_Button : Menu_Button; + for My_Menu_Button'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Menu_Button); + begin + Extra_Init + (My_Menu_Button, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end menu_button_extra_init_hook; + + + procedure Extra_Init + (This : in out Menu_Button; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Menu (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Menu_Button) is + begin + This.Draw_Ptr := fl_menu_button_draw'Address; + This.Handle_Ptr := fl_menu_button_handle'Address; + This.Get_Item_Ptr := fl_menu_get_item'Address; + This.Value_Ptr := fl_menu_value'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Button is + begin + return This : Menu_Button do + This.Void_Ptr := new_fl_menu_button + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Button is + begin + return This : Menu_Button := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Popup -- + + function Get_Popup_Kind + (This : in Menu_Button) + return Popup_Buttons + is + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + begin + return Popup_Buttons'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Button::type returned unexpected Popup_Buttons value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Popup_Kind; + + + procedure Set_Popup_Kind + (This : in out Menu_Button; + Kind : in Popup_Buttons) is + begin + fl_widget_set_type (This.Void_Ptr, Popup_Buttons'Pos (Kind)); + end Set_Popup_Kind; + + + function Popup + (This : in out Menu_Button) + return Extended_Index + is + use type Interfaces.C.int; + Ptr : constant Storage.Integer_Address := fl_menu_button_popup (This.Void_Ptr); + begin + return Extended_Index (fl_menu_find_index2 (This.Void_Ptr, Ptr) + 1); + end Popup; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Menu_Button) is + begin + Menu (This).Draw; + end Draw; + + + function Handle + (This : in out Menu_Button; + Event : in Event_Kind) + return Event_Outcome is + begin + return Menu (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Menus.Menu_Buttons; + + diff --git a/body/fltk-widgets-menus.adb b/body/fltk-widgets-menus.adb new file mode 100644 index 0000000..1295d76 --- /dev/null +++ b/body/fltk-widgets-menus.adb @@ -0,0 +1,1468 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Ada.Unchecked_Deallocation, + FLTK.Widgets.Groups, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets.Menus is + + + package Chk renames Ada.Assertions; + + procedure Free_Item is new Ada.Unchecked_Deallocation + (Object => FLTK.Menu_Items.Menu_Item, Name => Item_Access); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function null_fl_menu_item + return Storage.Integer_Address; + pragma Import (C, null_fl_menu_item, "null_fl_menu_item"); + pragma Inline (null_fl_menu_item); + + procedure free_fl_menu_item + (MI : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_item, "free_fl_menu_item"); + pragma Inline (free_fl_menu_item); + + function new_fl_menu + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu, "new_fl_menu"); + pragma Inline (new_fl_menu); + + procedure free_fl_menu + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_menu, "free_fl_menu"); + pragma Inline (free_fl_menu); + + + + + -- Menu Items -- + + function fl_menu_add + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_menu_add, "fl_menu_add"); + pragma Inline (fl_menu_add); + + function fl_menu_add2 + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array; + S : in Interfaces.C.int; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_add2, "fl_menu_add2"); + pragma Inline (fl_menu_add2); + + function fl_menu_add3 + (M : in Storage.Integer_Address; + T, S : in Interfaces.C.char_array; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_add3, "fl_menu_add3"); + pragma Inline (fl_menu_add3); + + function fl_menu_insert + (M : in Storage.Integer_Address; + P : in Interfaces.C.int; + T : in Interfaces.C.char_array; + S : in Interfaces.C.int; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_insert, "fl_menu_insert"); + pragma Inline (fl_menu_insert); + + function fl_menu_insert2 + (M : in Storage.Integer_Address; + P : in Interfaces.C.int; + T, S : in Interfaces.C.char_array; + U : in Storage.Integer_Address; + F : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_insert2, "fl_menu_insert2"); + pragma Inline (fl_menu_insert2); + + procedure fl_menu_copy + (M, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_copy, "fl_menu_copy"); + pragma Inline (fl_menu_copy); + + procedure fl_menu_set_menu + (M, D : in Storage.Integer_Address); + pragma Import (C, fl_menu_set_menu, "fl_menu_set_menu"); + pragma Inline (fl_menu_set_menu); + + procedure fl_menu_remove + (M : in Storage.Integer_Address; + P : in Interfaces.C.int); + pragma Import (C, fl_menu_remove, "fl_menu_remove"); + pragma Inline (fl_menu_remove); + + procedure fl_menu_clear + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_clear, "fl_menu_clear"); + pragma Inline (fl_menu_clear); + + function fl_menu_clear_submenu + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_clear_submenu, "fl_menu_clear_submenu"); + pragma Inline (fl_menu_clear_submenu); + + + + + -- Item Query -- + + function fl_menu_get_item + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_get_item, "fl_menu_get_item"); + pragma Inline (fl_menu_get_item); + + function fl_menu_find_index + (M : in Storage.Integer_Address; + T : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_menu_find_index, "fl_menu_find_index"); + pragma Inline (fl_menu_find_index); + + function fl_menu_find_index2 + (M, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_find_index2, "fl_menu_find_index2"); + pragma Inline (fl_menu_find_index2); + + function fl_menu_find_index3 + (M, C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_find_index3, "fl_menu_find_index3"); + -- No inline + + function fl_menu_item_pathname + (M : in Storage.Integer_Address; + B : out Interfaces.C.char_array; + L : in Interfaces.C.int; + I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_pathname, "fl_menu_item_pathname"); + pragma Inline (fl_menu_item_pathname); + + function fl_menu_size + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_size, "fl_menu_size"); + pragma Inline (fl_menu_size); + + + + + -- Selection -- + + function fl_menu_text + (M : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_menu_text, "fl_menu_text"); + pragma Inline (fl_menu_text); + + function fl_menu_value + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_value, "fl_menu_value"); + pragma Inline (fl_menu_value); + + function fl_menu_set_value + (M, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_set_value, "fl_menu_set_value"); + pragma Inline (fl_menu_set_value); + + function fl_menu_set_value2 + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_set_value2, "fl_menu_set_value2"); + pragma Inline (fl_menu_set_value2); + + + + + -- Label, Shortcut, Flags -- + + procedure fl_menu_setonly + (M, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_setonly, "fl_menu_setonly"); + pragma Inline (fl_menu_setonly); + + function fl_menu_text2 + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_menu_text2, "fl_menu_text2"); + pragma Inline (fl_menu_text2); + + procedure fl_menu_replace + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_replace, "fl_menu_replace"); + pragma Inline (fl_menu_replace); + + procedure fl_menu_shortcut + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_shortcut, "fl_menu_shortcut"); + pragma Inline (fl_menu_shortcut); + + function fl_menu_get_mode + (M : in Storage.Integer_Address; + I : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_get_mode, "fl_menu_get_mode"); + pragma Inline (fl_menu_get_mode); + + procedure fl_menu_set_mode + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + F : in Interfaces.C.int); + pragma Import (C, fl_menu_set_mode, "fl_menu_set_mode"); + pragma Inline (fl_menu_set_mode); + + + + + -- Text Settings -- + + function fl_menu_get_textcolor + (M : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_menu_get_textcolor, "fl_menu_get_textcolor"); + pragma Inline (fl_menu_get_textcolor); + + procedure fl_menu_set_textcolor + (M : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_menu_set_textcolor, "fl_menu_set_textcolor"); + pragma Inline (fl_menu_set_textcolor); + + function fl_menu_get_textfont + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_get_textfont, "fl_menu_get_textfont"); + pragma Inline (fl_menu_get_textfont); + + procedure fl_menu_set_textfont + (M : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_menu_set_textfont, "fl_menu_set_textfont"); + pragma Inline (fl_menu_set_textfont); + + function fl_menu_get_textsize + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_get_textsize, "fl_menu_get_textsize"); + pragma Inline (fl_menu_get_textsize); + + procedure fl_menu_set_textsize + (M : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_set_textsize, "fl_menu_set_textsize"); + pragma Inline (fl_menu_set_textsize); + + + + + -- Miscellaneous -- + + function fl_menu_get_down_box + (M : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_get_down_box, "fl_menu_get_down_box"); + pragma Inline (fl_menu_get_down_box); + + procedure fl_menu_set_down_box + (M : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_menu_set_down_box, "fl_menu_set_down_box"); + pragma Inline (fl_menu_set_down_box); + + procedure fl_menu_global + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_global, "fl_menu_global"); + pragma Inline (fl_menu_global); + + function fl_menu_measure + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_measure, "fl_menu_measure"); + pragma Inline (fl_menu_measure); + + + + + -- Menu Item Methods -- + + function fl_menu_popup + (M : in Storage.Integer_Address; + X, Y : in Interfaces.C.int; + T : in Interfaces.C.Strings.chars_ptr; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_popup, "fl_menu_popup"); + -- No inline + + function fl_menu_pulldown + (M : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + N : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_pulldown, "fl_menu_pulldown"); + -- No inline + + function fl_menu_picked + (M, I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_picked, "fl_menu_picked"); + pragma Inline (fl_menu_picked); + + function fl_menu_find_shortcut + (M, I : in Storage.Integer_Address; + A : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_menu_find_shortcut, "fl_menu_find_shortcut"); + pragma Inline (fl_menu_find_shortcut); + + function fl_menu_test_shortcut + (M : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_test_shortcut, "fl_menu_test_shortcut"); + pragma Inline (fl_menu_test_shortcut); + + + + + -- Dimensions -- + + procedure fl_menu_size2 + (M : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_menu_size2, "fl_menu_size2"); + pragma Inline (fl_menu_size2); + + + + + -- Drawing, Events -- + + procedure fl_menu_draw_item + (M : in Storage.Integer_Address; + I : in Interfaces.C.int; + X, Y, W, H : in Interfaces.C.int; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_draw_item, "fl_menu_draw_item"); + pragma Inline (fl_menu_draw_item); + + procedure fl_menu_draw + (M : in Storage.Integer_Address); + pragma Import (C, fl_menu_draw, "fl_menu_draw"); + pragma Inline (fl_menu_draw); + + function fl_menu_handle + (M : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_menu_handle, "fl_menu_handle"); + pragma Inline (fl_menu_handle); + + + + + ------------------------ + -- Internal Utility -- + ------------------------ + + procedure Adjust_Item_Store + (This : in out Menu) + is + Target : constant Natural := This.Number_Of_Items; + begin + while Natural (This.My_Items.Length) > Target loop + Free_Item (This.My_Items.Reference (This.My_Items.Last_Index)); + This.My_Items.Delete_Last; + end loop; + while Natural (This.My_Items.Length) < Target loop + This.My_Items.Append (new FLTK.Menu_Items.Menu_Item); + Wrapper (This.My_Items.Last_Element.all).Needs_Dealloc := False; + end loop; + end Adjust_Item_Store; + + + -- Needed for setting a whole array of Menu_Items at once + Null_Item : Storage.Integer_Address := null_fl_menu_item; + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + procedure Item_Hook + (C_Obj, User_Data : in Storage.Integer_Address); + pragma Export (C, Item_Hook, "menu_item_callback_hook"); + + -- Used for Add and Insert, the userdata parameter is the actual callback we want + procedure Item_Hook + (C_Obj, User_Data : in Storage.Integer_Address) + is + Ada_Ptr : constant Storage.Integer_Address := fl_widget_get_user_data (C_Obj); + Ada_Widget : access Widget'Class; + Action : constant Widget_Callback := Callback_Convert.To_Access (User_Data); + begin + pragma Assert (Ada_Ptr /= Null_Pointer); + Ada_Widget := Widget_Convert.To_Pointer (Storage.To_Address (Ada_Ptr)); + Action.all (Ada_Widget.all); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Callback in Fl_Menu_ was supplied Widget pointer with no user data"; + end Item_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Menu) is + begin + for Item of This.My_Items loop + Free_Item (Item); + end loop; + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Menu) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_menu (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + procedure Finalize + (This : in out Menu_Final_Controller) is + begin + if Null_Item /= Null_Pointer then + free_fl_menu_item (Null_Item); + Null_Item := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Menu; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Menu) is + begin + This.Draw_Ptr := fl_menu_draw'Address; + This.Handle_Ptr := fl_menu_handle'Address; + This.Get_Item_Ptr := fl_menu_get_item'Address; + This.Value_Ptr := fl_menu_value'Address; + Wrapper (This.My_Find).Needs_Dealloc := False; + Wrapper (This.My_Pick).Needs_Dealloc := False; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu is + begin + return This : Menu do + This.Void_Ptr := new_fl_menu + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu is + begin + return This : Menu := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Menu Items -- + + procedure Add + (This : in out Menu; + Text : in String) + is + Ignore : constant Interfaces.C.int := fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out Menu; + Text : in String) + return Index + is + Added_Spot : constant Interfaces.C.int := + fl_menu_add (This.Void_Ptr, Interfaces.C.To_C (Text)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_menu_add2 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_menu_add2 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_menu_add3 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Add; + + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_menu_add3 + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Add; + + + procedure Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_menu_insert + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Insert; + + + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_menu_insert + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.int (To_C (Shortcut)), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Insert; + + + procedure Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + is + Ignore : constant Interfaces.C.int := fl_menu_insert2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + end Insert; + + + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index + is + Added_Spot : constant Interfaces.C.int := fl_menu_insert2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text), + Interfaces.C.To_C (Shortcut), + Callback_Convert.To_Address (Action), + MFlag_To_Cint (Flags)); + begin + This.Adjust_Item_Store; + return Index (Added_Spot + 1); + end Insert; + + + procedure Set_Items + (This : in out Menu; + Items : in FLTK.Menu_Items.Menu_Item_Array) + is + Pointers : aliased array + (Items'First .. Integer'Max (Items'First, Items'Last + 1)) of Storage.Integer_Address; + pragma Convention (C, Pointers); + begin + for Place in Pointers'First .. Pointers'Last - 1 loop + Pointers (Place) := Wrapper (Items (Place)).Void_Ptr; + end loop; + Pointers (Pointers'Last) := Null_Item; + fl_menu_copy (This.Void_Ptr, Storage.To_Integer (Pointers (Pointers'First)'Address)); + This.Adjust_Item_Store; + end Set_Items; + + + procedure Use_Same_Items + (This : in out Menu; + Donor : in Menu'Class) is + begin + -- Donor menu() pointer will be obtained in C++ + fl_menu_set_menu (This.Void_Ptr, Donor.Void_Ptr); + This.Adjust_Item_Store; + end Use_Same_Items; + + + procedure Remove + (This : in out Menu; + Place : in Index) is + begin + fl_menu_remove (This.Void_Ptr, Interfaces.C.int (Place) - 1); + This.Adjust_Item_Store; + end Remove; + + + procedure Clear + (This : in out Menu) is + begin + for Item of This.My_Items loop + Free_Item (Item); + end loop; + This.My_Items.Clear; + fl_menu_clear (This.Void_Ptr); + end Clear; + + + procedure Clear_Submenu + (This : in out Menu; + Place : in Index) + is + Result : constant Interfaces.C.int := fl_menu_clear_submenu + (This.Void_Ptr, + Interfaces.C.int (Place) - 1); + begin + if Result = -1 then + raise No_Reference_Error; + else + pragma Assert (Result = 0); + This.Adjust_Item_Store; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::clear_submenu returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Clear_Submenu; + + + + + -- Item Query -- + + function Has_Item + (This : in Menu; + Place : in Index) + return Boolean is + begin + return Place in 1 .. This.Number_Of_Items; + end Has_Item; + + + function Has_Item + (Place : in Cursor) + return Boolean is + begin + return Place.My_Container.Has_Item (Place.My_Index); + end Has_Item; + + + function Item + (This : in Menu; + Place : in Index) + return FLTK.Menu_Items.Menu_Item_Reference + is + function my_get_item + (M : in Storage.Integer_Address; + P : in Interfaces.C.int) + return Storage.Integer_Address; + for my_get_item'Address use This.Get_Item_Ptr; + pragma Import (Ada, my_get_item); + begin + Wrapper (This.My_Items (Place).all).Void_Ptr := + my_get_item (This.Void_Ptr, Interfaces.C.int (Place) - 1); + return (Data => This.My_Items (Place).all'Unchecked_Access); + end Item; + + + function Item + (This : in Menu; + Place : in Cursor) + return FLTK.Menu_Items.Menu_Item_Reference is + begin + return This.Item (Place.My_Index); + end Item; + + + function Find_Item + (This : in Menu; + Name : in String) + return FLTK.Menu_Items.Menu_Item_Reference + is + Place : constant Extended_Index := This.Find_Index (Name); + begin + if Place = No_Index then + raise No_Reference_Error; + end if; + return This.Item (Place); + end Find_Item; + + + function Find_Item + (This : in Menu; + Action : in Widget_Callback) + return FLTK.Menu_Items.Menu_Item_Reference + is + Place : constant Extended_Index := This.Find_Index (Action); + begin + if Place = No_Index then + raise No_Reference_Error; + end if; + return This.Item (Place); + end Find_Item; + + + function Find_Index + (This : in Menu; + Name : in String) + return Extended_Index + is + Result : constant Interfaces.C.int := + fl_menu_find_index (This.Void_Ptr, Interfaces.C.To_C (Name)); + begin + return Extended_Index (Result + 1); + end Find_Index; + + + function Find_Index + (This : in Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return Extended_Index + is + Result : constant Interfaces.C.int := + fl_menu_find_index2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + begin + return Extended_Index (Result + 1); + end Find_Index; + + + function Find_Index + (This : in Menu; + Action : in Widget_Callback) + return Extended_Index + is + Result : Interfaces.C.int; + begin + -- Don't worry, callbacks actually being stored in userdata is + -- taken into account on the C++ side. + Result := fl_menu_find_index3 (This.Void_Ptr, Callback_Convert.To_Address (Action)); + return Extended_Index (Result + 1); + end Find_Index; + + + function Item_Pathname + (This : in Menu) + return String + is + Buffer : Interfaces.C.char_array := + (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); + Result : constant Interfaces.C.int := fl_menu_item_pathname + (This.Void_Ptr, + Buffer, + Interfaces.C.int (Item_Path_Max), + Null_Pointer); + begin + case Result is + when -1 => raise No_Reference_Error; + when -2 => raise Internal_FLTK_Error with "Item_Pathname buffer of " & + Integer'Image (Item_Path_Max) & " was not long enough"; + when others => + pragma Assert (Result = 0); + return Interfaces.C.To_Ada (Buffer); + end case; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::item_pathname returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Item_Pathname; + + + function Item_Pathname + (This : in Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return String + is + Buffer : Interfaces.C.char_array := + (0 .. Interfaces.C.size_t (Item_Path_Max) => Interfaces.C.nul); + Result : constant Interfaces.C.int := fl_menu_item_pathname + (This.Void_Ptr, + Buffer, + Interfaces.C.int (Item_Path_Max), + Wrapper (Item).Void_Ptr); + begin + case Result is + when -1 => raise No_Reference_Error; + when -2 => raise Internal_FLTK_Error with "Item_Pathname buffer of " & + Integer'Image (Item_Path_Max) & " was not long enough"; + when others => + pragma Assert (Result = 0); + return Interfaces.C.To_Ada (Buffer); + end case; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::item_pathname returned unexpected int result of " & + Interfaces.C.int'Image (Result); + end Item_Pathname; + + + function Number_Of_Items + (This : in Menu) + return Natural is + begin + return Natural (fl_menu_size (This.Void_Ptr)); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Call to Fl_Menu_::size returned unexpected negative result"; + end Number_Of_Items; + + + + + -- Iteration -- + + function Iterate + (This : in Menu) + return Menu_Iterators.Reversible_Iterator'Class is + begin + return It : constant Iterator := (My_Container => This'Unrestricted_Access); + end Iterate; + + + function First + (Object : in Iterator) + return Cursor is + begin + return Cu : constant Cursor := + (My_Container => Object.My_Container, + My_Index => 1); + end First; + + + function Next + (Object : in Iterator; + Place : in Cursor) + return Cursor is + begin + return Cu : constant Cursor := + (My_Container => Place.My_Container, + My_Index => Place.My_Index + 1); + end Next; + + + function Last + (Object : in Iterator) + return Cursor is + begin + return Cu : constant Cursor := + (My_Container => Object.My_Container, + My_Index => Object.My_Container.Number_Of_Items); + end Last; + + + function Previous + (Object : in Iterator; + Place : in Cursor) + return Cursor is + begin + return Cu : constant Cursor := + (My_Container => Place.My_Container, + My_Index => Place.My_Index - 1); + end Previous; + + + + + -- Selection -- + + function Chosen + (This : in Menu) + return FLTK.Menu_Items.Menu_Item_Reference + is + Place : constant Extended_Index := This.Chosen_Index; + begin + if Place = No_Index then + raise No_Reference_Error; + end if; + return This.Item (Place); + end Chosen; + + + function Chosen_Label + (This : in Menu) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_menu_text (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Chosen_Label; + + + function Chosen_Index + (This : in Menu) + return Extended_Index + is + function my_value + (M : in Storage.Integer_Address) + return Interfaces.C.int; + for my_value'Address use This.Value_Ptr; + pragma Import (Ada, my_value); + begin + return Extended_Index (my_value (This.Void_Ptr) + 1); + end Chosen_Index; + + + procedure Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item) + is + Ignore : Interfaces.C.int; + begin + Ignore := fl_menu_set_value (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Chosen; + + + function Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return Boolean is + begin + return fl_menu_set_value (This.Void_Ptr, Wrapper (Item).Void_Ptr) /= 0; + end Set_Chosen; + + + procedure Set_Chosen + (This : in out Menu; + Place : in Index) + is + Ignore : Interfaces.C.int; + begin + Ignore := fl_menu_set_value2 (This.Void_Ptr, Interfaces.C.int (Place) - 1); + end Set_Chosen; + + + function Set_Chosen + (This : in out Menu; + Place : in Index) + return Boolean is + begin + return fl_menu_set_value2 (This.Void_Ptr, Interfaces.C.int (Place) - 1) /= 0; + end Set_Chosen; + + + + + -- Label, Shortcut, Flags -- + + procedure Set_Only + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item) is + begin + fl_menu_setonly (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Only; + + + function Get_Label + (This : in Menu; + Place : in Index) + return String + is + Result : constant Interfaces.C.Strings.chars_ptr := fl_menu_text2 + (This.Void_Ptr, + Interfaces.C.int (Place) - 1); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Get_Label; + + + procedure Set_Label + (This : in out Menu; + Place : in Index; + Text : in String) is + begin + fl_menu_replace + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Shortcut + (This : in out Menu; + Place : in Index; + Press : in Key_Combo) is + begin + fl_menu_shortcut + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + Interfaces.C.int (To_C (Press))); + end Set_Shortcut; + + + function Get_Flags + (This : in Menu; + Place : in Index) + return Menu_Flag is + begin + return Cint_To_MFlag (fl_menu_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1)); + end Get_Flags; + + + procedure Set_Flags + (This : in out Menu; + Place : in Index; + Flags : in Menu_Flag) is + begin + fl_menu_set_mode + (This.Void_Ptr, + Interfaces.C.int (Place) - 1, + MFlag_To_Cint (Flags)); + end Set_Flags; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Menu) + return Color is + begin + return Color (fl_menu_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Menu; + To : in Color) is + begin + fl_menu_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Menu) + return Font_Kind + is + Result : constant Interfaces.C.int := fl_menu_get_textfont (This.Void_Ptr); + begin + return Font_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_::textfont returned unexpected Font value of " & + Interfaces.C.int'Image (Result); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Menu; + To : in Font_Kind) is + begin + fl_menu_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Menu) + return Font_Size + is + Result : constant Interfaces.C.int := fl_menu_get_textsize (This.Void_Ptr); + begin + return Font_Size (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_::textsize returned unexpected Size value of " & + Interfaces.C.int'Image (Result); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Menu; + To : in Font_Size) is + begin + fl_menu_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + + + -- Miscellaneous -- + + function Get_Down_Box + (This : in Menu) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_menu_get_down_box (This.Void_Ptr); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_::down_box returned unexpected Box value of " & + Interfaces.C.int'Image (Result); + end Get_Down_Box; + + + procedure Set_Down_Box + (This : in out Menu; + To : in Box_Kind) is + begin + fl_menu_set_down_box (This.Void_Ptr, Box_Kind'Pos (To)); + end Set_Down_Box; + + + procedure Make_Global + (This : in out Menu) is + begin + fl_menu_global (This.Void_Ptr); + end Make_Global; + + + procedure Measure_Item + (This : in Menu; + Item : in Index; + W, H : out Integer) is + begin + W := Integer (fl_menu_measure + (This.Void_Ptr, + Interfaces.C.int (Item) - 1, + Interfaces.C.int (H))); + end Measure_Item; + + + + + -- Menu Item Methods -- + + function Popup + (This : in Menu; + X, Y : in Integer; + Title : in String := ""; + Initial : in Extended_Index := No_Index) + return Extended_Index + is + C_Title : aliased Interfaces.C.char_array := Interfaces.C.To_C (Title); + Ptr : constant Storage.Integer_Address := fl_menu_popup + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + (if Title = "" + then Interfaces.C.Strings.Null_Ptr + else Interfaces.C.Strings.To_Chars_Ptr (C_Title'Unchecked_Access)), + Interfaces.C.int (Initial) - 1); + begin + return Extended_Index (fl_menu_find_index2 (This.Void_Ptr, Ptr) + 1); + end Popup; + + + function Pulldown + (This : in Menu; + X, Y, W, H : in Integer; + Initial : in Extended_Index := No_Index) + return Extended_Index + is + Ptr : constant Storage.Integer_Address := fl_menu_pulldown + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Initial) - 1); + begin + return Extended_Index (fl_menu_find_index2 (This.Void_Ptr, Ptr) + 1); + end Pulldown; + + + procedure Picked + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item) + is + Ignore : Storage.Integer_Address := fl_menu_picked + (This.Void_Ptr, + Wrapper (Item).Void_Ptr); + begin + null; + end Picked; + + + function Find_Shortcut + (This : in out Menu; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class + is + Tentative_Result : constant Storage.Integer_Address := fl_menu_find_shortcut + (This.Void_Ptr, + Null_Pointer, + Boolean'Pos (Require_Alt)); + begin + if Tentative_Result = Null_Pointer then + return null; + else + Wrapper (This.My_Find).Void_Ptr := Tentative_Result; + return This.My_Find'Unchecked_Access; + end if; + end Find_Shortcut; + + + function Find_Shortcut + (This : in out Menu; + Place : out Extended_Index; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class + is + C_Place : Interfaces.C.int; + Tentative_Result : constant Storage.Integer_Address := fl_menu_find_shortcut + (This.Void_Ptr, + Storage.To_Integer (C_Place'Address), + Boolean'Pos (Require_Alt)); + begin + if Tentative_Result = Null_Pointer then + Place := No_Index; + return null; + else + Wrapper (This.My_Find).Void_Ptr := Tentative_Result; + Place := Index (C_Place + 1); + return This.My_Find'Unchecked_Access; + end if; + end Find_Shortcut; + + + function Test_Shortcut + (This : in out Menu) + return access FLTK.Menu_Items.Menu_Item'Class + is + Tentative_Pick : constant Storage.Integer_Address := fl_menu_test_shortcut (This.Void_Ptr); + begin + if Tentative_Pick = Null_Pointer then + return null; + else + Wrapper (This.My_Pick).Void_Ptr := Tentative_Pick; + return This.My_Pick'Unchecked_Access; + end if; + end Test_Shortcut; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Menu; + W, H : in Integer) is + begin + fl_menu_size2 + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Drawing -- + + procedure Draw_Item + (This : in out Menu; + Item : in Index; + X, Y, W, H : in Integer; + Selected : in Boolean := False) is + begin + fl_menu_draw_item + (This.Void_Ptr, + Interfaces.C.int (Item) - 1, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Boolean'Pos (Selected)); + end Draw_Item; + + +end FLTK.Widgets.Menus; + + diff --git a/body/fltk-widgets-positioners.adb b/body/fltk-widgets-positioners.adb new file mode 100644 index 0000000..29246cd --- /dev/null +++ b/body/fltk-widgets-positioners.adb @@ -0,0 +1,572 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Positioners is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_positioner + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_positioner, "new_fl_positioner"); + pragma Inline (new_fl_positioner); + + procedure free_fl_positioner + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_positioner, "free_fl_positioner"); + pragma Inline (free_fl_positioner); + + + + + -- Targeting -- + + function fl_positioner_set_value + (P : in Storage.Integer_Address; + X, Y : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_positioner_set_value, "fl_positioner_set_value"); + pragma Inline (fl_positioner_set_value); + + + + + -- X Axis -- + + procedure fl_positioner_xbounds + (P : in Storage.Integer_Address; + L, H : in Interfaces.C.double); + pragma Import (C, fl_positioner_xbounds, "fl_positioner_xbounds"); + pragma Inline (fl_positioner_xbounds); + + procedure fl_positioner_xstep + (P : in Storage.Integer_Address; + A : in Interfaces.C.double); + pragma Import (C, fl_positioner_xstep, "fl_positioner_xstep"); + pragma Inline (fl_positioner_xstep); + + function fl_positioner_get_xminimum + (P : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_positioner_get_xminimum, "fl_positioner_get_xminimum"); + pragma Inline (fl_positioner_get_xminimum); + + procedure fl_positioner_set_xminimum + (P : in Storage.Integer_Address; + A : in Interfaces.C.double); + pragma Import (C, fl_positioner_set_xminimum, "fl_positioner_set_xminimum"); + pragma Inline (fl_positioner_set_xminimum); + + function fl_positioner_get_xmaximum + (P : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_positioner_get_xmaximum, "fl_positioner_get_xmaximum"); + pragma Inline (fl_positioner_get_xmaximum); + + procedure fl_positioner_set_xmaximum + (P : in Storage.Integer_Address; + A : in Interfaces.C.double); + pragma Import (C, fl_positioner_set_xmaximum, "fl_positioner_set_xmaximum"); + pragma Inline (fl_positioner_set_xmaximum); + + function fl_positioner_get_xvalue + (P : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_positioner_get_xvalue, "fl_positioner_get_xvalue"); + pragma Inline (fl_positioner_get_xvalue); + + function fl_positioner_set_xvalue + (P : in Storage.Integer_Address; + V : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_positioner_set_xvalue, "fl_positioner_set_xvalue"); + pragma Inline (fl_positioner_set_xvalue); + + + + + -- Y Axis -- + + procedure fl_positioner_ybounds + (P : in Storage.Integer_Address; + L, H : in Interfaces.C.double); + pragma Import (C, fl_positioner_ybounds, "fl_positioner_ybounds"); + pragma Inline (fl_positioner_ybounds); + + procedure fl_positioner_ystep + (P : in Storage.Integer_Address; + A : in Interfaces.C.double); + pragma Import (C, fl_positioner_ystep, "fl_positioner_ystep"); + pragma Inline (fl_positioner_ystep); + + function fl_positioner_get_yminimum + (P : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_positioner_get_yminimum, "fl_positioner_get_yminimum"); + pragma Inline (fl_positioner_get_yminimum); + + procedure fl_positioner_set_yminimum + (P : in Storage.Integer_Address; + A : in Interfaces.C.double); + pragma Import (C, fl_positioner_set_yminimum, "fl_positioner_set_yminimum"); + pragma Inline (fl_positioner_set_yminimum); + + function fl_positioner_get_ymaximum + (P : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_positioner_get_ymaximum, "fl_positioner_get_ymaximum"); + pragma Inline (fl_positioner_get_ymaximum); + + procedure fl_positioner_set_ymaximum + (P : in Storage.Integer_Address; + A : in Interfaces.C.double); + pragma Import (C, fl_positioner_set_ymaximum, "fl_positioner_set_ymaximum"); + pragma Inline (fl_positioner_set_ymaximum); + + function fl_positioner_get_yvalue + (P : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_positioner_get_yvalue, "fl_positioner_get_yvalue"); + pragma Inline (fl_positioner_get_yvalue); + + function fl_positioner_set_yvalue + (P : in Storage.Integer_Address; + V : in Interfaces.C.double) + return Interfaces.C.int; + pragma Import (C, fl_positioner_set_yvalue, "fl_positioner_set_yvalue"); + pragma Inline (fl_positioner_set_yvalue); + + + + + -- Drawing, Events -- + + procedure fl_positioner_draw + (P : in Storage.Integer_Address); + pragma Import (C, fl_positioner_draw, "fl_positioner_draw"); + pragma Inline (fl_positioner_draw); + + procedure fl_positioner_draw2 + (P : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_positioner_draw2, "fl_positioner_draw2"); + pragma Inline (fl_positioner_draw2); + + function fl_positioner_handle + (P : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_positioner_handle, "fl_positioner_handle"); + pragma Inline (fl_positioner_handle); + + function fl_positioner_handle2 + (P : in Storage.Integer_Address; + E, X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_positioner_handle2, "fl_positioner_handle2"); + pragma Inline (fl_positioner_handle2); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Positioner) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Positioner) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_positioner (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Positioner; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Positioner) is + begin + This.Draw_Ptr := fl_positioner_draw'Address; + This.Handle_Ptr := fl_positioner_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Positioner is + begin + return This : Positioner do + This.Void_Ptr := new_fl_positioner + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Positioner is + begin + return This : Positioner := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Targeting -- + + procedure Get_Coords + (This : in Positioner; + X, Y : out Long_Float) is + begin + X := This.Get_Ecks; + Y := This.Get_Why; + end Get_Coords; + + + procedure Set_Coords + (This : in out Positioner; + X, Y : in Long_Float) + is + Result : constant Interfaces.C.int := fl_positioner_set_value + (This.Void_Ptr, + Interfaces.C.double (X), + Interfaces.C.double (Y)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Positioner::value returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Coords; + + + function Set_Coords + (This : in out Positioner; + X, Y : in Long_Float) + return Boolean + is + Result : constant Interfaces.C.int := fl_positioner_set_value + (This.Void_Ptr, + Interfaces.C.double (X), + Interfaces.C.double (Y)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::value returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Coords; + + + + + -- X Axis -- + + procedure Set_Ecks_Bounds + (This : in out Positioner; + Low, High : in Long_Float) is + begin + fl_positioner_xbounds + (This.Void_Ptr, + Interfaces.C.double (Low), + Interfaces.C.double (High)); + end Set_Ecks_Bounds; + + + procedure Set_Ecks_Step + (This : in out Positioner; + Value : in Long_Float) is + begin + fl_positioner_xstep (This.Void_Ptr, Interfaces.C.double (Value)); + end Set_Ecks_Step; + + + function Get_Ecks_Minimum + (This : in Positioner) + return Long_Float is + begin + return Long_Float (fl_positioner_get_xminimum (This.Void_Ptr)); + end Get_Ecks_Minimum; + + + procedure Set_Ecks_Minimum + (This : in out Positioner; + Value : in Long_Float) is + begin + fl_positioner_set_xminimum (This.Void_Ptr, Interfaces.C.double (Value)); + end Set_Ecks_Minimum; + + + function Get_Ecks_Maximum + (This : in Positioner) + return Long_Float is + begin + return Long_Float (fl_positioner_get_xmaximum (This.Void_Ptr)); + end Get_Ecks_Maximum; + + + procedure Set_Ecks_Maximum + (This : in out Positioner; + Value : in Long_Float) is + begin + fl_positioner_set_xmaximum (This.Void_Ptr, Interfaces.C.double (Value)); + end Set_Ecks_Maximum; + + + function Get_Ecks + (This : in Positioner) + return Long_Float is + begin + return Long_Float (fl_positioner_get_xvalue (This.Void_Ptr)); + end Get_Ecks; + + + procedure Set_Ecks + (This : in out Positioner; + Value : in Long_Float) + is + Result : constant Interfaces.C.int := fl_positioner_set_xvalue + (This.Void_Ptr, + Interfaces.C.double (Value)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Positioner::xvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Ecks; + + + function Set_Ecks + (This : in out Positioner; + Value : in Long_Float) + return Boolean + is + Result : constant Interfaces.C.int := fl_positioner_set_xvalue + (This.Void_Ptr, + Interfaces.C.double (Value)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::xvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Ecks; + + + + + -- Y Axis -- + + procedure Set_Why_Bounds + (This : in out Positioner; + Low, High : in Long_Float) is + begin + fl_positioner_ybounds + (This.Void_Ptr, + Interfaces.C.double (Low), + Interfaces.C.double (High)); + end Set_Why_Bounds; + + + procedure Set_Why_Step + (This : in out Positioner; + Value : in Long_Float) is + begin + fl_positioner_ystep (This.Void_Ptr, Interfaces.C.double (Value)); + end Set_Why_Step; + + + function Get_Why_Minimum + (This : in Positioner) + return Long_Float is + begin + return Long_Float (fl_positioner_get_yminimum (This.Void_Ptr)); + end Get_Why_Minimum; + + + procedure Set_Why_Minimum + (This : in out Positioner; + Value : in Long_Float) is + begin + fl_positioner_set_yminimum (This.Void_Ptr, Interfaces.C.double (Value)); + end Set_Why_Minimum; + + + function Get_Why_Maximum + (This : in Positioner) + return Long_Float is + begin + return Long_Float (fl_positioner_get_ymaximum (This.Void_Ptr)); + end Get_Why_Maximum; + + + procedure Set_Why_Maximum + (This : in out Positioner; + Value : in Long_Float) is + begin + fl_positioner_set_ymaximum (This.Void_Ptr, Interfaces.C.double (Value)); + end Set_Why_Maximum; + + + function Get_Why + (This : in Positioner) + return Long_Float is + begin + return Long_Float (fl_positioner_get_yvalue (This.Void_Ptr)); + end Get_Why; + + + procedure Set_Why + (This : in out Positioner; + Value : in Long_Float) + is + Result : constant Interfaces.C.int := fl_positioner_set_yvalue + (This.Void_Ptr, + Interfaces.C.double (Value)); + begin + pragma Assert (Result in 0 .. 1); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_Positioner::yvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Why; + + + function Set_Why + (This : in out Positioner; + Value : in Long_Float) + return Boolean + is + Result : constant Interfaces.C.int := fl_positioner_set_yvalue + (This.Void_Ptr, + Interfaces.C.double (Value)); + begin + return Boolean'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::yvalue returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Set_Why; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Positioner) is + begin + Widget (This).Draw; + end Draw; + + + procedure Draw + (This : in out Positioner; + X, Y, W, H : in Integer) is + begin + fl_positioner_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw; + + + function Handle + (This : in out Positioner; + Event : in Event_Kind) + return Event_Outcome is + begin + return Widget (This).Handle (Event); + end Handle; + + + function Handle + (This : in out Positioner; + Event : in Event_Kind; + X, Y, W, H : in Integer) + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_positioner_handle2 + (This.Void_Ptr, + Event_Kind'Pos (Event), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Positioner::handle returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Handle; + + +end FLTK.Widgets.Positioners; + + diff --git a/body/fltk-widgets-progress_bars.adb b/body/fltk-widgets-progress_bars.adb new file mode 100644 index 0000000..d04c275 --- /dev/null +++ b/body/fltk-widgets-progress_bars.adb @@ -0,0 +1,242 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Progress_Bars is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_progress + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_progress, "new_fl_progress"); + pragma Inline (new_fl_progress); + + procedure free_fl_progress + (P : in Storage.Integer_Address); + pragma Import (C, free_fl_progress, "free_fl_progress"); + pragma Inline (free_fl_progress); + + + + + -- Values -- + + function fl_progress_get_minimum + (P : in Storage.Integer_Address) + return Interfaces.C.C_float; + pragma Import (C, fl_progress_get_minimum, "fl_progress_get_minimum"); + pragma Inline (fl_progress_get_minimum); + + procedure fl_progress_set_minimum + (P : in Storage.Integer_Address; + T : in Interfaces.C.C_float); + pragma Import (C, fl_progress_set_minimum, "fl_progress_set_minimum"); + pragma Inline (fl_progress_set_minimum); + + function fl_progress_get_maximum + (P : in Storage.Integer_Address) + return Interfaces.C.C_float; + pragma Import (C, fl_progress_get_maximum, "fl_progress_get_maximum"); + pragma Inline (fl_progress_get_maximum); + + procedure fl_progress_set_maximum + (P : in Storage.Integer_Address; + T : in Interfaces.C.C_float); + pragma Import (C, fl_progress_set_maximum, "fl_progress_set_maximum"); + pragma Inline (fl_progress_set_maximum); + + function fl_progress_get_value + (P : in Storage.Integer_Address) + return Interfaces.C.C_float; + pragma Import (C, fl_progress_get_value, "fl_progress_get_value"); + pragma Inline (fl_progress_get_value); + + procedure fl_progress_set_value + (P : in Storage.Integer_Address; + T : in Interfaces.C.C_float); + pragma Import (C, fl_progress_set_value, "fl_progress_set_value"); + pragma Inline (fl_progress_set_value); + + + + + -- Drawing, Events -- + + procedure fl_progress_draw + (P : in Storage.Integer_Address); + pragma Import (C, fl_progress_draw, "fl_progress_draw"); + pragma Inline (fl_progress_draw); + + function fl_progress_handle + (P : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_progress_handle, "fl_progress_handle"); + pragma Inline (fl_progress_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Progress_Bar) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Progress_Bar) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_progress (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Progress_Bar; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Progress_Bar) is + begin + This.Draw_Ptr := fl_progress_draw'Address; + This.Handle_Ptr := fl_progress_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Progress_Bar is + begin + return This : Progress_Bar do + This.Void_Ptr := new_fl_progress + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Progress_Bar is + begin + return This : Progress_Bar := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Values -- + + function Get_Minimum + (This : in Progress_Bar) + return Float is + begin + return Float (fl_progress_get_minimum (This.Void_Ptr)); + end Get_Minimum; + + + procedure Set_Minimum + (This : in out Progress_Bar; + To : in Float) is + begin + fl_progress_set_minimum (This.Void_Ptr, Interfaces.C.C_float (To)); + end Set_Minimum; + + + function Get_Maximum + (This : in Progress_Bar) + return Float is + begin + return Float (fl_progress_get_maximum (This.Void_Ptr)); + end Get_Maximum; + + + procedure Set_Maximum + (This : in out Progress_Bar; + To : in Float) is + begin + fl_progress_set_maximum (This.Void_Ptr, Interfaces.C.C_float (To)); + end Set_Maximum; + + + function Get_Value + (This : in Progress_Bar) + return Float is + begin + return Float (fl_progress_get_value (This.Void_Ptr)); + end Get_Value; + + + procedure Set_Value + (This : in out Progress_Bar; + To : in Float) is + begin + fl_progress_set_value (This.Void_Ptr, Interfaces.C.C_float (To)); + end Set_Value; + + + + + -- Drawing -- + + procedure Draw + (This : in out Progress_Bar) is + begin + Widget (This).Draw; + end Draw; + + +end FLTK.Widgets.Progress_Bars; + + diff --git a/body/fltk-widgets-valuators-adjusters.adb b/body/fltk-widgets-valuators-adjusters.adb new file mode 100644 index 0000000..d740da5 --- /dev/null +++ b/body/fltk-widgets-valuators-adjusters.adb @@ -0,0 +1,211 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Valuators.Adjusters is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_adjuster + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_adjuster, "new_fl_adjuster"); + pragma Inline (new_fl_adjuster); + + procedure free_fl_adjuster + (A : in Storage.Integer_Address); + pragma Import (C, free_fl_adjuster, "free_fl_adjuster"); + pragma Inline (free_fl_adjuster); + + + + + -- Allow Outside Range -- + + function fl_adjuster_is_soft + (A : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_adjuster_is_soft, "fl_adjuster_is_soft"); + pragma Inline (fl_adjuster_is_soft); + + procedure fl_adjuster_set_soft + (A : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_adjuster_set_soft, "fl_adjuster_set_soft"); + pragma Inline (fl_adjuster_set_soft); + + + + + -- Drawing, Events -- + + procedure fl_adjuster_value_damage + (A : in Storage.Integer_Address); + pragma Import (C, fl_adjuster_value_damage, "fl_adjuster_value_damage"); + pragma Inline (fl_adjuster_value_damage); + + procedure fl_adjuster_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_adjuster_draw, "fl_adjuster_draw"); + pragma Inline (fl_adjuster_draw); + + function fl_adjuster_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_adjuster_handle, "fl_adjuster_handle"); + pragma Inline (fl_adjuster_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Adjuster) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Adjuster) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_adjuster (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Adjuster; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Adjuster) is + begin + This.Draw_Ptr := fl_adjuster_draw'Address; + This.Handle_Ptr := fl_adjuster_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Adjuster is + begin + return This : Adjuster do + This.Void_Ptr := new_fl_adjuster + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Adjuster is + begin + return This : Adjuster := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Allow Outside Range -- + + function Is_Soft + (This : in Adjuster) + return Boolean is + begin + return fl_adjuster_is_soft (This.Void_Ptr) /= 0; + end Is_Soft; + + + procedure Set_Soft + (This : in out Adjuster; + To : in Boolean) is + begin + fl_adjuster_set_soft (This.Void_Ptr, Boolean'Pos (To)); + end Set_Soft; + + + + + -- Drawing, Events -- + + procedure Value_Damage + (This : in out Adjuster) is + begin + fl_adjuster_value_damage (This.Void_Ptr); + end Value_Damage; + + + procedure Draw + (This : in out Adjuster) is + begin + Valuator (This).Draw; + end Draw; + + + function Handle + (This : in out Adjuster; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Valuators.Adjusters; + + diff --git a/body/fltk-widgets-valuators-counters-simple.adb b/body/fltk-widgets-valuators-counters-simple.adb new file mode 100644 index 0000000..cd9a8f4 --- /dev/null +++ b/body/fltk-widgets-valuators-counters-simple.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Counters.Simple is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_simple_counter + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_simple_counter, "new_fl_simple_counter"); + pragma Inline (new_fl_simple_counter); + + procedure free_fl_simple_counter + (A : in Storage.Integer_Address); + pragma Import (C, free_fl_simple_counter, "free_fl_simple_counter"); + pragma Inline (free_fl_simple_counter); + + + + + -- Drawing, Events -- + + procedure fl_simple_counter_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_simple_counter_draw, "fl_simple_counter_draw"); + pragma Inline (fl_simple_counter_draw); + + function fl_simple_counter_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_simple_counter_handle, "fl_simple_counter_handle"); + pragma Inline (fl_simple_counter_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Simple_Counter) is + begin + Extra_Final (Counter (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Simple_Counter) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_simple_counter (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Simple_Counter; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Counter (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Simple_Counter) is + begin + This.Draw_Ptr := fl_simple_counter_draw'Address; + This.Handle_Ptr := fl_simple_counter_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Simple_Counter is + begin + return This : Simple_Counter do + This.Void_Ptr := new_fl_simple_counter + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Simple_Counter is + begin + return This : Simple_Counter := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Counters.Simple; + + diff --git a/body/fltk-widgets-valuators-counters.adb b/body/fltk-widgets-valuators-counters.adb new file mode 100644 index 0000000..f05df69 --- /dev/null +++ b/body/fltk-widgets-valuators-counters.adb @@ -0,0 +1,359 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Valuators.Counters is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_counter + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_counter, "new_fl_counter"); + pragma Inline (new_fl_counter); + + procedure free_fl_counter + (A : in Storage.Integer_Address); + pragma Import (C, free_fl_counter, "free_fl_counter"); + pragma Inline (free_fl_counter); + + + + + -- Button Steps -- + + function fl_counter_get_step + (C : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_counter_get_step, "fl_counter_get_step"); + pragma Inline (fl_counter_get_step); + + procedure fl_counter_set_step_top + (C : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_counter_set_step_top, "fl_counter_set_step_top"); + pragma Inline (fl_counter_set_step_top); + + procedure fl_counter_set_lstep + (C : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_counter_set_lstep, "fl_counter_set_lstep"); + pragma Inline (fl_counter_set_lstep); + + procedure fl_counter_set_step_both + (C : in Storage.Integer_Address; + S, L : in Interfaces.C.double); + pragma Import (C, fl_counter_set_step_both, "fl_counter_set_step_both"); + pragma Inline (fl_counter_set_step_both); + + + + + -- Text Settings -- + + function fl_counter_get_textcolor + (C : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_counter_get_textcolor, "fl_counter_get_textcolor"); + pragma Inline (fl_counter_get_textcolor); + + procedure fl_counter_set_textcolor + (C : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_counter_set_textcolor, "fl_counter_set_textcolor"); + pragma Inline (fl_counter_set_textcolor); + + function fl_counter_get_textfont + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_counter_get_textfont, "fl_counter_get_textfont"); + pragma Inline (fl_counter_get_textfont); + + procedure fl_counter_set_textfont + (C : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_counter_set_textfont, "fl_counter_set_textfont"); + pragma Inline (fl_counter_set_textfont); + + function fl_counter_get_textsize + (C : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_counter_get_textsize, "fl_counter_get_textsize"); + pragma Inline (fl_counter_get_textsize); + + procedure fl_counter_set_textsize + (C : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_counter_set_textsize, "fl_counter_set_textsize"); + pragma Inline (fl_counter_set_textsize); + + + + + -- Drawing, Events -- + + procedure fl_counter_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_counter_draw, "fl_counter_draw"); + pragma Inline (fl_counter_draw); + + function fl_counter_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_counter_handle, "fl_counter_handle"); + pragma Inline (fl_counter_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Counter) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Counter) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_counter (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Counter; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Counter) is + begin + This.Draw_Ptr := fl_counter_draw'Address; + This.Handle_Ptr := fl_counter_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Counter is + begin + return This : Counter do + This.Void_Ptr := new_fl_counter + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Counter is + begin + return This : Counter := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Button Steps -- + + function Get_Step + (This : in Counter) + return Long_Float is + begin + return Long_Float (fl_counter_get_step (This.Void_Ptr)); + end Get_Step; + + + procedure Set_Step_Top + (This : in out Counter; + To : in Long_Float) is + begin + fl_counter_set_step_top (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Step_Top; + + + function Get_Long_Step + (This : in Counter) + return Long_Float is + begin + return This.Long_Step; + end Get_Long_Step; + + + procedure Set_Long_Step + (This : in out Counter; + To : in Long_Float) is + begin + This.Long_Step := To; + fl_counter_set_lstep (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Long_Step; + + + procedure Set_Step_Both + (This : in out Counter; + Short, Long : in Long_Float) is + begin + fl_counter_set_step_both + (This.Void_Ptr, + Interfaces.C.double (Short), + Interfaces.C.double (Long)); + end Set_Step_Both; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Counter) + return Color is + begin + return Color (fl_counter_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Counter; + To : in Color) is + begin + fl_counter_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Counter) + return Font_Kind is + begin + return Font_Kind'Val (fl_counter_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Counter; + To : in Font_Kind) is + begin + fl_counter_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Counter) + return Font_Size is + begin + return Font_Size (fl_counter_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Counter; + To : in Font_Size) is + begin + fl_counter_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Counter) is + begin + Valuator (This).Draw; + end Draw; + + + function Handle + (This : in out Counter; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + + + + -- Counter Type -- + + function Get_Kind + (This : in out Counter) + return Counter_Kind + is + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + begin + return Counter_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Counter::type returned unexpected unsigned char value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Kind; + + + package body Extra is + + procedure Set_Kind + (This : in out Counter; + Value : in Counter_Kind) is + begin + fl_widget_set_type (This.Void_Ptr, Counter_Kind'Pos (Value)); + end Set_Kind; + + pragma Inline (Set_Kind); + + end Extra; + + +end FLTK.Widgets.Valuators.Counters; + + diff --git a/body/fltk-widgets-valuators-dials-fill.adb b/body/fltk-widgets-valuators-dials-fill.adb new file mode 100644 index 0000000..a1d1066 --- /dev/null +++ b/body/fltk-widgets-valuators-dials-fill.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Dials.Fill is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_fill_dial + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_fill_dial, "new_fl_fill_dial"); + pragma Inline (new_fl_fill_dial); + + procedure free_fl_fill_dial + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_fill_dial, "free_fl_fill_dial"); + pragma Inline (free_fl_fill_dial); + + + + + -- Drawing, Events -- + + procedure fl_fill_dial_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_fill_dial_draw, "fl_fill_dial_draw"); + pragma Inline (fl_fill_dial_draw); + + function fl_fill_dial_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_fill_dial_handle, "fl_fill_dial_handle"); + pragma Inline (fl_fill_dial_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Fill_Dial) is + begin + Extra_Final (Dial (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Fill_Dial) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_fill_dial (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Fill_Dial; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Dial (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Fill_Dial) is + begin + This.Draw_Ptr := fl_fill_dial_draw'Address; + This.Handle_Ptr := fl_fill_dial_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Dial is + begin + return This : Fill_Dial do + This.Void_Ptr := new_fl_fill_dial + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Dial is + begin + return This : Fill_Dial := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Dials.Fill; + + diff --git a/body/fltk-widgets-valuators-dials-line.adb b/body/fltk-widgets-valuators-dials-line.adb new file mode 100644 index 0000000..8f6914c --- /dev/null +++ b/body/fltk-widgets-valuators-dials-line.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Dials.Line is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_line_dial + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_line_dial, "new_fl_line_dial"); + pragma Inline (new_fl_line_dial); + + procedure free_fl_line_dial + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_line_dial, "free_fl_line_dial"); + pragma Inline (free_fl_line_dial); + + + + + -- Drawing, Events -- + + procedure fl_line_dial_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_line_dial_draw, "fl_line_dial_draw"); + pragma Inline (fl_line_dial_draw); + + function fl_line_dial_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_line_dial_handle, "fl_line_dial_handle"); + pragma Inline (fl_line_dial_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Line_Dial) is + begin + Extra_Final (Dial (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Line_Dial) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_line_dial (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Line_Dial; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Dial (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Line_Dial) is + begin + This.Draw_Ptr := fl_line_dial_draw'Address; + This.Handle_Ptr := fl_line_dial_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Line_Dial is + begin + return This : Line_Dial do + This.Void_Ptr := new_fl_line_dial + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Line_Dial is + begin + return This : Line_Dial := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Dials.Line; + + diff --git a/body/fltk-widgets-valuators-dials.adb b/body/fltk-widgets-valuators-dials.adb new file mode 100644 index 0000000..43d943f --- /dev/null +++ b/body/fltk-widgets-valuators-dials.adb @@ -0,0 +1,336 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Valuators.Dials is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_dial + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_dial, "new_fl_dial"); + pragma Inline (new_fl_dial); + + procedure free_fl_dial + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_dial, "free_fl_dial"); + pragma Inline (free_fl_dial); + + + + + -- Limit Angles -- + + function fl_dial_get_angle1 + (D : in Storage.Integer_Address) + return Interfaces.C.short; + pragma Import (C, fl_dial_get_angle1, "fl_dial_get_angle1"); + pragma Inline (fl_dial_get_angle1); + + procedure fl_dial_set_angle1 + (D : in Storage.Integer_Address; + T : in Interfaces.C.short); + pragma Import (C, fl_dial_set_angle1, "fl_dial_set_angle1"); + pragma Inline (fl_dial_set_angle1); + + function fl_dial_get_angle2 + (D : in Storage.Integer_Address) + return Interfaces.C.short; + pragma Import (C, fl_dial_get_angle2, "fl_dial_get_angle2"); + pragma Inline (fl_dial_get_angle2); + + procedure fl_dial_set_angle2 + (D : in Storage.Integer_Address; + T : in Interfaces.C.short); + pragma Import (C, fl_dial_set_angle2, "fl_dial_set_angle2"); + pragma Inline (fl_dial_set_angle2); + + procedure fl_dial_set_angles + (D : in Storage.Integer_Address; + A, B : in Interfaces.C.short); + pragma Import (C, fl_dial_set_angles, "fl_dial_set_angles"); + pragma Inline (fl_dial_set_angles); + + + + + -- Drawing, Events -- + + procedure fl_dial_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_dial_draw, "fl_dial_draw"); + pragma Inline (fl_dial_draw); + + procedure fl_dial_draw2 + (D : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_dial_draw2, "fl_dial_draw2"); + pragma Inline (fl_dial_draw2); + + function fl_dial_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_dial_handle, "fl_dial_handle"); + pragma Inline (fl_dial_handle); + + function fl_dial_handle2 + (D : in Storage.Integer_Address; + E, X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_dial_handle2, "fl_dial_handle2"); + pragma Inline (fl_dial_handle2); + + + + + -- Dial Type -- + + function fl_widget_get_type + (D : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_widget_get_type, "fl_widget_get_type"); + pragma Inline (fl_widget_get_type); + + procedure fl_widget_set_type + (D : in Storage.Integer_Address; + T : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_set_type, "fl_widget_set_type"); + pragma Inline (fl_widget_set_type); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Dial) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Dial) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_dial (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Dial; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Dial) is + begin + This.Draw_Ptr := fl_dial_draw'Address; + This.Handle_Ptr := fl_dial_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Dial is + begin + return This : Dial do + This.Void_Ptr := new_fl_dial + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Dial is + begin + return This : Dial := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Limit Angles -- + + function Get_First_Angle + (This : in Dial) + return Short_Integer is + begin + return Short_Integer (fl_dial_get_angle1 (This.Void_Ptr)); + end Get_First_Angle; + + + procedure Set_First_Angle + (This : in out Dial; + To : in Short_Integer) is + begin + fl_dial_set_angle1 (This.Void_Ptr, Interfaces.C.short (To)); + end Set_First_Angle; + + + function Get_Second_Angle + (This : in Dial) + return Short_Integer is + begin + return Short_Integer (fl_dial_get_angle2 (This.Void_Ptr)); + end Get_Second_Angle; + + + procedure Set_Second_Angle + (This : in out Dial; + To : in Short_Integer) is + begin + fl_dial_set_angle2 (This.Void_Ptr, Interfaces.C.short (To)); + end Set_Second_Angle; + + + procedure Set_Angles + (This : in out Dial; + One, Two : in Short_Integer) is + begin + fl_dial_set_angles + (This.Void_Ptr, + Interfaces.C.short (One), + Interfaces.C.short (Two)); + end Set_Angles; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Dial) is + begin + Valuator (This).Draw; + end Draw; + + + procedure Draw + (This : in out Dial; + X, Y, W, H : in Integer) is + begin + fl_dial_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw; + + + function Handle + (This : in out Dial; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + + function Handle + (This : in out Dial; + Event : in Event_Kind; + X, Y, W, H : in Integer) + return Event_Outcome + is + Result : constant Interfaces.C.int := fl_dial_handle2 + (This.Void_Ptr, + Event_Kind'Pos (Event), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Dial::handle returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Handle; + + + + + -- Dial Type -- + + function Get_Kind + (This : in Dial) + return Dial_Kind + is + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + begin + return Dial_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Dial::type returned unexpected unsigned char value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Kind; + + + package body Extra is + + procedure Set_Kind + (This : in out Dial; + To : in Dial_Kind) is + begin + fl_widget_set_type (This.Void_Ptr, Dial_Kind'Pos (To)); + end Set_Kind; + + pragma Inline (Set_Kind); + + end Extra; + + +end FLTK.Widgets.Valuators.Dials; + + diff --git a/body/fltk-widgets-valuators-rollers.adb b/body/fltk-widgets-valuators-rollers.adb new file mode 100644 index 0000000..45939fb --- /dev/null +++ b/body/fltk-widgets-valuators-rollers.adb @@ -0,0 +1,157 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Valuators.Rollers is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_roller + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_roller, "new_fl_roller"); + pragma Inline (new_fl_roller); + + procedure free_fl_roller + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_roller, "free_fl_roller"); + pragma Inline (free_fl_roller); + + + + + -- Drawing, Events -- + + procedure fl_roller_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_roller_draw, "fl_roller_draw"); + pragma Inline (fl_roller_draw); + + function fl_roller_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_roller_handle, "fl_roller_handle"); + pragma Inline (fl_roller_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Roller) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Roller) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_roller (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Roller; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Roller) is + begin + This.Draw_Ptr := fl_roller_draw'Address; + This.Handle_Ptr := fl_roller_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Roller is + begin + return This : Roller do + This.Void_Ptr := new_fl_roller + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Roller is + begin + return This : Roller := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Drawing, Events -- + + procedure Draw + (This : in out Roller) is + begin + Valuator (This).Draw; + end Draw; + + + function Handle + (This : in out Roller; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Valuators.Rollers; + + diff --git a/body/fltk-widgets-valuators-sliders-fill.adb b/body/fltk-widgets-valuators-sliders-fill.adb new file mode 100644 index 0000000..c9b0d82 --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-fill.adb @@ -0,0 +1,133 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Valuators.Sliders.Fill is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_fill_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_fill_slider, "new_fl_fill_slider"); + pragma Inline (new_fl_fill_slider); + + procedure free_fl_fill_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_fill_slider, "free_fl_fill_slider"); + pragma Inline (free_fl_fill_slider); + + + + + -- Drawing, Events -- + + procedure fl_fill_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_fill_slider_draw, "fl_fill_slider_draw"); + pragma Inline (fl_fill_slider_draw); + + function fl_fill_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_fill_slider_handle, "fl_fill_slider_handle"); + pragma Inline (fl_fill_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Fill_Slider) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Fill_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_fill_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Fill_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Fill_Slider) is + begin + This.Draw_Ptr := fl_fill_slider_draw'Address; + This.Handle_Ptr := fl_fill_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Slider is + begin + return This : Fill_Slider do + This.Void_Ptr := new_fl_fill_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Slider is + begin + return This : Fill_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Sliders.Fill; + + diff --git a/body/fltk-widgets-valuators-sliders-horizontal.adb b/body/fltk-widgets-valuators-sliders-horizontal.adb new file mode 100644 index 0000000..1fb5114 --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-horizontal.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Sliders.Horizontal is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_horizontal_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_horizontal_slider, "new_fl_horizontal_slider"); + pragma Inline (new_fl_horizontal_slider); + + procedure free_fl_horizontal_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_horizontal_slider, "free_fl_horizontal_slider"); + pragma Inline (free_fl_horizontal_slider); + + + + + -- Drawing, Events -- + + procedure fl_horizontal_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_horizontal_slider_draw, "fl_horizontal_slider_draw"); + pragma Inline (fl_horizontal_slider_draw); + + function fl_horizontal_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_horizontal_slider_handle, "fl_horizontal_slider_handle"); + pragma Inline (fl_horizontal_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Horizontal_Slider) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Horizontal_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_horizontal_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Horizontal_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Horizontal_Slider) is + begin + This.Draw_Ptr := fl_horizontal_slider_draw'Address; + This.Handle_Ptr := fl_horizontal_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Slider is + begin + return This : Horizontal_Slider do + This.Void_Ptr := new_fl_horizontal_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Slider is + begin + return This : Horizontal_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Sliders.Horizontal; + + diff --git a/body/fltk-widgets-valuators-sliders-horizontal_fill.adb b/body/fltk-widgets-valuators-sliders-horizontal_fill.adb new file mode 100644 index 0000000..2ecf088 --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-horizontal_fill.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Sliders.Horizontal_Fill is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_hor_fill_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_hor_fill_slider, "new_fl_hor_fill_slider"); + pragma Inline (new_fl_hor_fill_slider); + + procedure free_fl_hor_fill_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_hor_fill_slider, "free_fl_hor_fill_slider"); + pragma Inline (free_fl_hor_fill_slider); + + + + + -- Drawing, Events -- + + procedure fl_hor_fill_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_hor_fill_slider_draw, "fl_hor_fill_slider_draw"); + pragma Inline (fl_hor_fill_slider_draw); + + function fl_hor_fill_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_hor_fill_slider_handle, "fl_hor_fill_slider_handle"); + pragma Inline (fl_hor_fill_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Horizontal_Fill_Slider) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Horizontal_Fill_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_hor_fill_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Horizontal_Fill_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Horizontal_Fill_Slider) is + begin + This.Draw_Ptr := fl_hor_fill_slider_draw'Address; + This.Handle_Ptr := fl_hor_fill_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Fill_Slider is + begin + return This : Horizontal_Fill_Slider do + This.Void_Ptr := new_fl_hor_fill_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Fill_Slider is + begin + return This : Horizontal_Fill_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Sliders.Horizontal_Fill; + + diff --git a/body/fltk-widgets-valuators-sliders-horizontal_nice.adb b/body/fltk-widgets-valuators-sliders-horizontal_nice.adb new file mode 100644 index 0000000..5efb3ca --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-horizontal_nice.adb @@ -0,0 +1,133 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Valuators.Sliders.Horizontal_Nice is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_hor_nice_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_hor_nice_slider, "new_fl_hor_nice_slider"); + pragma Inline (new_fl_hor_nice_slider); + + procedure free_fl_hor_nice_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_hor_nice_slider, "free_fl_hor_nice_slider"); + pragma Inline (free_fl_hor_nice_slider); + + + + + -- Drawing, Events -- + + procedure fl_hor_nice_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_hor_nice_slider_draw, "fl_hor_nice_slider_draw"); + pragma Inline (fl_hor_nice_slider_draw); + + function fl_hor_nice_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_hor_nice_slider_handle, "fl_hor_nice_slider_handle"); + pragma Inline (fl_hor_nice_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Horizontal_Nice_Slider) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Horizontal_Nice_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_hor_nice_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Horizontal_Nice_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Horizontal_Nice_Slider) is + begin + This.Draw_Ptr := fl_hor_nice_slider_draw'Address; + This.Handle_Ptr := fl_hor_nice_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Nice_Slider is + begin + return This : Horizontal_Nice_Slider do + This.Void_Ptr := new_fl_hor_nice_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Nice_Slider is + begin + return This : Horizontal_Nice_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Sliders.Horizontal_Nice; + + diff --git a/body/fltk-widgets-valuators-sliders-nice.adb b/body/fltk-widgets-valuators-sliders-nice.adb new file mode 100644 index 0000000..4b24754 --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-nice.adb @@ -0,0 +1,132 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups; + + +package body FLTK.Widgets.Valuators.Sliders.Nice is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_nice_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_nice_slider, "new_fl_nice_slider"); + pragma Inline (new_fl_nice_slider); + + procedure free_fl_nice_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_nice_slider, "free_fl_nice_slider"); + pragma Inline (free_fl_nice_slider); + + + + + -- Drawing, Events -- + + procedure fl_nice_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_nice_slider_draw, "fl_nice_slider_draw"); + pragma Inline (fl_nice_slider_draw); + + function fl_nice_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_nice_slider_handle, "fl_nice_slider_handle"); + pragma Inline (fl_nice_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Nice_Slider) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Nice_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_nice_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Nice_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Nice_Slider) is + begin + This.Draw_Ptr := fl_nice_slider_draw'Address; + This.Handle_Ptr := fl_nice_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Nice_Slider is + begin + return This : Nice_Slider do + This.Void_Ptr := new_fl_nice_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Nice_Slider is + begin + return This : Nice_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Sliders.Nice; + + diff --git a/body/fltk-widgets-valuators-sliders-scrollbars.adb b/body/fltk-widgets-valuators-sliders-scrollbars.adb new file mode 100644 index 0000000..660970a --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-scrollbars.adb @@ -0,0 +1,269 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C.Strings; + + +package body FLTK.Widgets.Valuators.Sliders.Scrollbars is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_scrollbar + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_scrollbar, "new_fl_scrollbar"); + pragma Inline (new_fl_scrollbar); + + procedure free_fl_scrollbar + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_scrollbar, "free_fl_scrollbar"); + pragma Inline (free_fl_scrollbar); + + + + + -- Line Position -- + + function fl_scrollbar_get_linesize + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_scrollbar_get_linesize, "fl_scrollbar_get_linesize"); + pragma Inline (fl_scrollbar_get_linesize); + + procedure fl_scrollbar_set_linesize + (S : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_scrollbar_set_linesize, "fl_scrollbar_set_linesize"); + pragma Inline (fl_scrollbar_set_linesize); + + function fl_scrollbar_get_value + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_scrollbar_get_value, "fl_scrollbar_get_value"); + pragma Inline (fl_scrollbar_get_value); + + procedure fl_scrollbar_set_value + (S : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_scrollbar_set_value, "fl_scrollbar_set_value"); + pragma Inline (fl_scrollbar_set_value); + + procedure fl_scrollbar_set_value2 + (S : in Storage.Integer_Address; + P, W, F, T : in Interfaces.C.int); + pragma Import (C, fl_scrollbar_set_value2, "fl_scrollbar_set_value2"); + pragma Inline (fl_scrollbar_set_value2); + + + + + -- Drawing, Events -- + + procedure fl_scrollbar_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_scrollbar_draw, "fl_scrollbar_draw"); + pragma Inline (fl_scrollbar_draw); + + function fl_scrollbar_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_scrollbar_handle, "fl_scrollbar_handle"); + pragma Inline (fl_scrollbar_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Scrollbar) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Scrollbar) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_scrollbar (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Radio signal successfully intercepted + procedure scrollbar_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr); + pragma Export (C, scrollbar_extra_init_hook, "scrollbar_extra_init_hook"); + + procedure scrollbar_extra_init_hook + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.Strings.chars_ptr) + is + My_Scrollbar : Scrollbar; + for My_Scrollbar'Address use Storage.To_Address (Ada_Obj); + pragma Import (Ada, My_Scrollbar); + begin + Extra_Init + (My_Scrollbar, + Integer (X), Integer (Y), + Integer (W), Integer (H), + Interfaces.C.Strings.Value (C_Str)); + end scrollbar_extra_init_hook; + + + procedure Extra_Init + (This : in out Scrollbar; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Scrollbar) is + begin + This.Draw_Ptr := fl_scrollbar_draw'Address; + This.Handle_Ptr := fl_scrollbar_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Scrollbar is + begin + return This : Scrollbar do + This.Void_Ptr := new_fl_scrollbar + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Scrollbar is + begin + return This : Scrollbar := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Line Position -- + + function Get_Line_Size + (This : in Scrollbar) + return Natural is + begin + return Natural (fl_scrollbar_get_linesize (This.Void_Ptr)); + end Get_Line_Size; + + + procedure Set_Line_Size + (This : in out Scrollbar; + To : in Natural) is + begin + fl_scrollbar_set_linesize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Line_Size; + + + function Get_Position + (This : in Scrollbar) + return Natural is + begin + return Natural (fl_scrollbar_get_value (This.Void_Ptr)); + end Get_Position; + + + procedure Set_Position + (This : in out Scrollbar; + To : in Natural) is + begin + fl_scrollbar_set_value (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Position; + + + procedure Set_All + (This : in out Scrollbar; + Position : in Natural; + Win_Size : in Natural; + First_Line : in Natural; + Total_Lines : in Natural) is + begin + fl_scrollbar_set_value2 + (This.Void_Ptr, + Interfaces.C.int (Position), + Interfaces.C.int (Win_Size), + Interfaces.C.int (First_Line), + Interfaces.C.int (Total_Lines)); + end Set_All; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Scrollbar) is + begin + Slider (This).Draw; + end Draw; + + + function Handle + (This : in out Scrollbar; + Event : in Event_Kind) + return Event_Outcome is + begin + return Slider (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Valuators.Sliders.Scrollbars; + + diff --git a/body/fltk-widgets-valuators-sliders-value-horizontal.adb b/body/fltk-widgets-valuators-sliders-value-horizontal.adb new file mode 100644 index 0000000..9e3d946 --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-value-horizontal.adb @@ -0,0 +1,134 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Sliders.Value.Horizontal is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_hor_value_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_hor_value_slider, "new_fl_hor_value_slider"); + pragma Inline (new_fl_hor_value_slider); + + procedure free_fl_hor_value_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_hor_value_slider, "free_fl_hor_value_slider"); + pragma Inline (free_fl_hor_value_slider); + + + + + -- Drawing, Events -- + + procedure fl_hor_value_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_hor_value_slider_draw, "fl_hor_value_slider_draw"); + pragma Inline (fl_hor_value_slider_draw); + + function fl_hor_value_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_hor_value_slider_handle, "fl_hor_value_slider_handle"); + pragma Inline (fl_hor_value_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Horizontal_Value_Slider) is + begin + Extra_Final (Value_Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Horizontal_Value_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_hor_value_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Horizontal_Value_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Value_Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Horizontal_Value_Slider) is + begin + This.Draw_Ptr := fl_hor_value_slider_draw'Address; + This.Handle_Ptr := fl_hor_value_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Value_Slider is + begin + return This : Horizontal_Value_Slider do + This.Void_Ptr := new_fl_hor_value_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Value_Slider is + begin + return This : Horizontal_Value_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + +end FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + diff --git a/body/fltk-widgets-valuators-sliders-value.adb b/body/fltk-widgets-valuators-sliders-value.adb new file mode 100644 index 0000000..28a932e --- /dev/null +++ b/body/fltk-widgets-valuators-sliders-value.adb @@ -0,0 +1,251 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Sliders.Value is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_value_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_value_slider, "new_fl_value_slider"); + pragma Inline (new_fl_value_slider); + + procedure free_fl_value_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_value_slider, "free_fl_value_slider"); + pragma Inline (free_fl_value_slider); + + + + + -- Text Settings -- + + function fl_value_slider_get_textcolor + (S : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_value_slider_get_textcolor, "fl_value_slider_get_textcolor"); + pragma Inline (fl_value_slider_get_textcolor); + + procedure fl_value_slider_set_textcolor + (S : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_value_slider_set_textcolor, "fl_value_slider_set_textcolor"); + pragma Inline (fl_value_slider_set_textcolor); + + function fl_value_slider_get_textfont + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_slider_get_textfont, "fl_value_slider_get_textfont"); + pragma Inline (fl_value_slider_get_textfont); + + procedure fl_value_slider_set_textfont + (S : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_value_slider_set_textfont, "fl_value_slider_set_textfont"); + pragma Inline (fl_value_slider_set_textfont); + + function fl_value_slider_get_textsize + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_slider_get_textsize, "fl_value_slider_get_textsize"); + pragma Inline (fl_value_slider_get_textsize); + + procedure fl_value_slider_set_textsize + (S : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_value_slider_set_textsize, "fl_value_slider_set_textsize"); + pragma Inline (fl_value_slider_set_textsize); + + + + + -- Drawing, Events -- + + procedure fl_value_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_value_slider_draw, "fl_value_slider_draw"); + pragma Inline (fl_value_slider_draw); + + function fl_value_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_value_slider_handle, "fl_value_slider_handle"); + pragma Inline (fl_value_slider_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Value_Slider) is + begin + Extra_Final (Slider (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Value_Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_value_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Value_Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Slider (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Value_Slider) is + begin + This.Draw_Ptr := fl_value_slider_draw'Address; + This.Handle_Ptr := fl_value_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Value_Slider is + begin + return This : Value_Slider do + This.Void_Ptr := new_fl_value_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Value_Slider is + begin + return This : Value_Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Text Settings -- + + function Get_Text_Color + (This : in Value_Slider) + return Color is + begin + return Color (fl_value_slider_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Value_Slider; + To : in Color) is + begin + fl_value_slider_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Value_Slider) + return Font_Kind is + begin + return Font_Kind'Val (fl_value_slider_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Value_Slider; + To : in Font_Kind) is + begin + fl_value_slider_set_textfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Value_Slider) + return Font_Size is + begin + return Font_Size (fl_value_slider_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Value_Slider; + To : in Font_Size) is + begin + fl_value_slider_set_textsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Text_Size; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Value_Slider) is + begin + Slider (This).Draw; + end Draw; + + + function Handle + (This : in out Value_Slider; + Event : in Event_Kind) + return Event_Outcome is + begin + return Slider (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Valuators.Sliders.Value; + + diff --git a/body/fltk-widgets-valuators-sliders.adb b/body/fltk-widgets-valuators-sliders.adb new file mode 100644 index 0000000..b670ba2 --- /dev/null +++ b/body/fltk-widgets-valuators-sliders.adb @@ -0,0 +1,396 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + + +package body FLTK.Widgets.Valuators.Sliders is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_slider + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_slider, "new_fl_slider"); + pragma Inline (new_fl_slider); + + function new_fl_slider2 + (K : in Interfaces.C.unsigned_char; + X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_slider2, "new_fl_slider2"); + pragma Inline (new_fl_slider2); + + procedure free_fl_slider + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_slider, "free_fl_slider"); + pragma Inline (free_fl_slider); + + + + + -- Settings -- + + procedure fl_slider_set_bounds + (S : in Storage.Integer_Address; + A, B : in Interfaces.C.double); + pragma Import (C, fl_slider_set_bounds, "fl_slider_set_bounds"); + pragma Inline (fl_slider_set_bounds); + + function fl_slider_get_slider + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_slider_get_slider, "fl_slider_get_slider"); + pragma Inline (fl_slider_get_slider); + + procedure fl_slider_set_slider + (S : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_slider_set_slider, "fl_slider_set_slider"); + pragma Inline (fl_slider_set_slider); + + function fl_slider_get_slider_size + (S : in Storage.Integer_Address) + return Interfaces.C.C_float; + pragma Import (C, fl_slider_get_slider_size, "fl_slider_get_slider_size"); + pragma Inline (fl_slider_get_slider_size); + + procedure fl_slider_set_slider_size + (S : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_slider_set_slider_size, "fl_slider_set_slider_size"); + pragma Inline (fl_slider_set_slider_size); + + function fl_slider_scrollvalue + (S : in Storage.Integer_Address; + P, Z, F, T : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_slider_scrollvalue, "fl_slider_scrollvalue"); + pragma Inline (fl_slider_scrollvalue); + + + + + -- Drawing, Events -- + + procedure fl_slider_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_slider_draw, "fl_slider_draw"); + pragma Inline (fl_slider_draw); + + procedure fl_slider_draw2 + (S : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_slider_draw2, "fl_slider_draw2"); + pragma Inline (fl_slider_draw2); + + function fl_slider_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_slider_handle, "fl_slider_handle"); + pragma Inline (fl_slider_handle); + + function fl_slider_handle2 + (S : in Storage.Integer_Address; + E, X, Y, W, H : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_slider_handle2, "fl_slider_handle2"); + pragma Inline (fl_slider_handle2); + + + + + -- Slider Type -- + + function fl_widget_get_type + (S : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_widget_get_type, "fl_widget_get_type"); + pragma Inline (fl_widget_get_type); + + procedure fl_widget_set_type + (S : in Storage.Integer_Address; + T : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_set_type, "fl_widget_set_type"); + pragma Inline (fl_widget_set_type); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Slider) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Slider) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_slider (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Slider; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Slider) is + begin + This.Draw_Ptr := fl_slider_draw'Address; + This.Handle_Ptr := fl_slider_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Slider is + begin + return This : Slider do + This.Void_Ptr := new_fl_slider + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Slider is + begin + return This : Slider := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + + function Create + (Kind : in Slider_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Slider is + begin + return This : Slider do + This.Void_Ptr := new_fl_slider2 + (Slider_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + Kind : in Slider_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Slider is + begin + return This : Slider := Create (Kind, X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Settings -- + + procedure Set_Bounds + (This : in out Slider; + Min, Max : in Long_Float) is + begin + fl_slider_set_bounds + (This.Void_Ptr, + Interfaces.C.double (Min), + Interfaces.C.double (Max)); + end Set_Bounds; + + + function Get_Box + (This : in Slider) + return Box_Kind is + begin + return Box_Kind'Val (fl_slider_get_slider (This.Void_Ptr)); + end Get_Box; + + + procedure Set_Box + (This : in out Slider; + To : in Box_Kind) is + begin + fl_slider_set_slider (This.Void_Ptr, Box_Kind'Pos (To)); + end Set_Box; + + + function Get_Slide_Size + (This : in Slider) + return Float is + begin + return Float (fl_slider_get_slider_size (This.Void_Ptr)); + end Get_Slide_Size; + + + procedure Set_Slide_Size + (This : in out Slider; + To : in Long_Float) is + begin + fl_slider_set_slider_size (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Slide_Size; + + + procedure Set_Scrollvalue + (This : in out Slider; + Pos_First_Line : in Natural; + Lines_In_Window : in Natural; + First_Line_Num : in Natural; + Total_Lines : in Natural) + is + Ignore_Me : Interfaces.C.int; + begin + Ignore_Me := fl_slider_scrollvalue + (This.Void_Ptr, + Interfaces.C.int (Pos_First_Line), + Interfaces.C.int (Lines_In_Window), + Interfaces.C.int (First_Line_Num), + Interfaces.C.int (Total_Lines)); + end Set_Scrollvalue; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Slider) is + begin + Valuator (This).Draw; + end Draw; + + + procedure Draw + (This : in out Slider; + X, Y, W, H : in Integer) is + begin + fl_slider_draw2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw; + + + function Handle + (This : in out Slider; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + + function Handle + (This : in out Slider; + Event : in Event_Kind; + X, Y, W, H : in Integer) + return Event_Outcome is + begin + return Event_Outcome'Val (fl_slider_handle2 + (This.Void_Ptr, + Event_Kind'Pos (Event), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H))); + end Handle; + + + + + -- Slider Type -- + + function Get_Kind + (This : in Slider) + return Slider_Kind + is + Result : constant Interfaces.C.unsigned_char := fl_widget_get_type (This.Void_Ptr); + begin + return Slider_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Slider::type returned unexpected unsigned char value of " & + Interfaces.C.unsigned_char'Image (Result); + end Get_Kind; + + + package body Extra is + + procedure Set_Kind + (This : in out Slider; + To : in Slider_Kind) is + begin + fl_widget_set_type (This.Void_Ptr, Slider_Kind'Pos (To)); + end Set_Kind; + + pragma Inline (Set_Kind); + + end Extra; + + +end FLTK.Widgets.Valuators.Sliders; + + diff --git a/body/fltk-widgets-valuators-value_inputs.adb b/body/fltk-widgets-valuators-value_inputs.adb new file mode 100644 index 0000000..1909c1c --- /dev/null +++ b/body/fltk-widgets-valuators-value_inputs.adb @@ -0,0 +1,435 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Valuators.Value_Inputs is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_value_input + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_value_input, "new_fl_value_input"); + pragma Inline (new_fl_value_input); + + procedure free_fl_value_input + (A : in Storage.Integer_Address); + pragma Import (C, free_fl_value_input, "free_fl_value_input"); + pragma Inline (free_fl_value_input); + + + + + -- Attributes -- + + function fl_value_input_get_input + (V : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_value_input_get_input, "fl_value_input_get_input"); + pragma Inline (fl_value_input_get_input); + + + + + -- Cursors -- + + function fl_value_input_get_cursor_color + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_value_input_get_cursor_color, "fl_value_input_get_cursor_color"); + pragma Inline (fl_value_input_get_cursor_color); + + procedure fl_value_input_set_cursor_color + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_value_input_set_cursor_color, "fl_value_input_set_cursor_color"); + pragma Inline (fl_value_input_set_cursor_color); + + + + + -- Shortcut -- + + function fl_value_input_get_shortcut + (B : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_input_get_shortcut, "fl_value_input_get_shortcut"); + pragma Inline (fl_value_input_get_shortcut); + + procedure fl_value_input_set_shortcut + (B : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_value_input_set_shortcut, "fl_value_input_set_shortcut"); + pragma Inline (fl_value_input_set_shortcut); + + + + + -- Allow Outside Range -- + + function fl_value_input_is_soft + (A : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_input_is_soft, "fl_value_input_is_soft"); + pragma Inline (fl_value_input_is_soft); + + procedure fl_value_input_set_soft + (A : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_value_input_set_soft, "fl_value_input_set_soft"); + pragma Inline (fl_value_input_set_soft); + + + + + -- Text Settings -- + + function fl_value_input_get_text_color + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_value_input_get_text_color, "fl_value_input_get_text_color"); + pragma Inline (fl_value_input_get_text_color); + + procedure fl_value_input_set_text_color + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_value_input_set_text_color, "fl_value_input_set_text_color"); + pragma Inline (fl_value_input_set_text_color); + + function fl_value_input_get_text_font + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_input_get_text_font, "fl_value_input_get_text_font"); + pragma Inline (fl_value_input_get_text_font); + + procedure fl_value_input_set_text_font + (TD : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_value_input_set_text_font, "fl_value_input_set_text_font"); + pragma Inline (fl_value_input_set_text_font); + + function fl_value_input_get_text_size + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_input_get_text_size, "fl_value_input_get_text_size"); + pragma Inline (fl_value_input_get_text_size); + + procedure fl_value_input_set_text_size + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_value_input_set_text_size, "fl_value_input_set_text_size"); + pragma Inline (fl_value_input_set_text_size); + + + + + -- Dimensions -- + + procedure fl_value_input_resize + (TD : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_value_input_resize, "fl_value_input_resize"); + pragma Inline (fl_value_input_resize); + + + + + -- Drawing, Events -- + + procedure fl_value_input_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_value_input_draw, "fl_value_input_draw"); + pragma Inline (fl_value_input_draw); + + function fl_value_input_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_value_input_handle, "fl_value_input_handle"); + pragma Inline (fl_value_input_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Value_Input) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Value_Input) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_value_input (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + -- Black magic, don't try this at home kids + procedure fl_text_input_extra_init + (Ada_Obj : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int; + C_Str : in Interfaces.C.char_array); + pragma Import (C, fl_text_input_extra_init, "fl_text_input_extra_init"); + pragma Inline (fl_text_input_extra_init); + + + procedure Extra_Init + (This : in out Value_Input; + X, Y, W, H : in Integer; + Text : in String) is + begin + Wrapper (This.My_Input).Void_Ptr := fl_value_input_get_input (This.Void_Ptr); + Wrapper (This.My_Input).Needs_Dealloc := False; + fl_text_input_extra_init + (Storage.To_Integer (This.My_Input'Address), + Interfaces.C.int (This.My_Input.Get_X), + Interfaces.C.int (This.My_Input.Get_Y), + Interfaces.C.int (This.My_Input.Get_W), + Interfaces.C.int (This.My_Input.Get_H), + Interfaces.C.To_C (This.My_Input.Get_Label)); + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Value_Input) is + begin + This.Draw_Ptr := fl_value_input_draw'Address; + This.Handle_Ptr := fl_value_input_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Value_Input is + begin + return This : Value_Input do + This.Void_Ptr := new_fl_value_input + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Value_Input is + begin + return This : Value_Input := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Attributes -- + + function Text_Field + (This : in out Value_Input) + return FLTK.Widgets.Inputs.Text.Text_Input_Reference is + begin + return (Data => This.My_Input'Unchecked_Access); + end Text_Field; + + + + + -- Cursors -- + + function Get_Cursor_Color + (This : in Value_Input) + return Color is + begin + return Color (fl_value_input_get_cursor_color (This.Void_Ptr)); + end Get_Cursor_Color; + + + procedure Set_Cursor_Color + (This : in out Value_Input; + Col : in Color) is + begin + fl_value_input_set_cursor_color (This.Void_Ptr, Interfaces.C.unsigned (Col)); + end Set_Cursor_Color; + + + + + -- Shortcut -- + + function Get_Shortcut + (This : in Value_Input) + return Key_Combo is + begin + return To_Ada (Interfaces.C.unsigned (fl_value_input_get_shortcut (This.Void_Ptr))); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Value_Input; + Key : in Key_Combo) is + begin + fl_value_input_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (Key))); + end Set_Shortcut; + + + + + -- Allow Outside Range -- + + function Is_Soft + (This : in Value_Input) + return Boolean is + begin + return fl_value_input_is_soft (This.Void_Ptr) /= 0; + end Is_Soft; + + + procedure Set_Soft + (This : in out Value_Input; + To : in Boolean) is + begin + fl_value_input_set_soft (This.Void_Ptr, Boolean'Pos (To)); + end Set_Soft; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Value_Input) + return Color is + begin + return Color (fl_value_input_get_text_color (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Value_Input; + Col : in Color) is + begin + fl_value_input_set_text_color (This.Void_Ptr, Interfaces.C.unsigned (Col)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Value_Input) + return Font_Kind is + begin + return Font_Kind'Val (fl_value_input_get_text_font (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Value_Input; + Font : in Font_Kind) is + begin + fl_value_input_set_text_font (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Value_Input) + return Font_Size is + begin + return Font_Size (fl_value_input_get_text_size (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Value_Input; + Size : in Font_Size) is + begin + fl_value_input_set_text_size (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Value_Input; + X, Y, W, H : in Integer) is + begin + fl_value_input_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Value_Input) is + begin + Valuator (This).Draw; + end Draw; + + + function Handle + (This : in out Value_Input; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Valuators.Value_Inputs; + + diff --git a/body/fltk-widgets-valuators-value_outputs.adb b/body/fltk-widgets-valuators-value_outputs.adb new file mode 100644 index 0000000..82259a6 --- /dev/null +++ b/body/fltk-widgets-valuators-value_outputs.adb @@ -0,0 +1,292 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups, + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Valuators.Value_Outputs is + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_value_output + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_value_output, "new_fl_value_output"); + pragma Inline (new_fl_value_output); + + procedure free_fl_value_output + (A : in Storage.Integer_Address); + pragma Import (C, free_fl_value_output, "free_fl_value_output"); + pragma Inline (free_fl_value_output); + + + + + -- Allow Outside Range -- + + function fl_value_output_is_soft + (A : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_output_is_soft, "fl_value_output_is_soft"); + pragma Inline (fl_value_output_is_soft); + + procedure fl_value_output_set_soft + (A : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_value_output_set_soft, "fl_value_output_set_soft"); + pragma Inline (fl_value_output_set_soft); + + + + + -- Text Settings -- + + function fl_value_output_get_text_color + (TD : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_value_output_get_text_color, "fl_value_output_get_text_color"); + pragma Inline (fl_value_output_get_text_color); + + procedure fl_value_output_set_text_color + (TD : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_value_output_set_text_color, "fl_value_output_set_text_color"); + pragma Inline (fl_value_output_set_text_color); + + function fl_value_output_get_text_font + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_output_get_text_font, "fl_value_output_get_text_font"); + pragma Inline (fl_value_output_get_text_font); + + procedure fl_value_output_set_text_font + (TD : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_value_output_set_text_font, "fl_value_output_set_text_font"); + pragma Inline (fl_value_output_set_text_font); + + function fl_value_output_get_text_size + (TD : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_value_output_get_text_size, "fl_value_output_get_text_size"); + pragma Inline (fl_value_output_get_text_size); + + procedure fl_value_output_set_text_size + (TD : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_value_output_set_text_size, "fl_value_output_set_text_size"); + pragma Inline (fl_value_output_set_text_size); + + + + + -- Drawing, Events -- + + procedure fl_value_output_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_value_output_draw, "fl_value_output_draw"); + pragma Inline (fl_value_output_draw); + + function fl_value_output_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_value_output_handle, "fl_value_output_handle"); + pragma Inline (fl_value_output_handle); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Value_Output) is + begin + Extra_Final (Valuator (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Value_Output) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_value_output (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Value_Output; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Valuator (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Value_Output) is + begin + This.Draw_Ptr := fl_value_output_draw'Address; + This.Handle_Ptr := fl_value_output_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Value_Output is + begin + return This : Value_Output do + This.Void_Ptr := new_fl_value_output + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Value_Output is + begin + return This : Value_Output := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Allow Outside Range -- + + function Is_Soft + (This : in Value_Output) + return Boolean is + begin + return fl_value_output_is_soft (This.Void_Ptr) /= 0; + end Is_Soft; + + + procedure Set_Soft + (This : in out Value_Output; + To : in Boolean) is + begin + fl_value_output_set_soft (This.Void_Ptr, Boolean'Pos (To)); + end Set_Soft; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Value_Output) + return Color is + begin + return Color (fl_value_output_get_text_color (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Value_Output; + Col : in Color) is + begin + fl_value_output_set_text_color (This.Void_Ptr, Interfaces.C.unsigned (Col)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Value_Output) + return Font_Kind is + begin + return Font_Kind'Val (fl_value_output_get_text_font (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Value_Output; + Font : in Font_Kind) is + begin + fl_value_output_set_text_font (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Value_Output) + return Font_Size is + begin + return Font_Size (fl_value_output_get_text_size (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Value_Output; + Size : in Font_Size) is + begin + fl_value_output_set_text_size (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Value_Output) is + begin + Valuator (This).Draw; + end Draw; + + + function Handle + (This : in out Value_Output; + Event : in Event_Kind) + return Event_Outcome is + begin + return Valuator (This).Handle (Event); + end Handle; + + +end FLTK.Widgets.Valuators.Value_Outputs; + + diff --git a/body/fltk-widgets-valuators.adb b/body/fltk-widgets-valuators.adb new file mode 100644 index 0000000..c762fe4 --- /dev/null +++ b/body/fltk-widgets-valuators.adb @@ -0,0 +1,500 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + FLTK.Widgets.Groups, + Interfaces.C.Strings, + System.Address_To_Access_Conversions; + + +package body FLTK.Widgets.Valuators is + + + package Chk renames Ada.Assertions; + + package Valuator_Convert is new System.Address_To_Access_Conversions (Valuator'Class); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_valuator + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_valuator, "new_fl_valuator"); + pragma Inline (new_fl_valuator); + + procedure free_fl_valuator + (V : in Storage.Integer_Address); + pragma Import (C, free_fl_valuator, "free_fl_valuator"); + pragma Inline (free_fl_valuator); + + + + + -- Formatting -- + + function fl_valuator_format + (V : in Storage.Integer_Address; + B : out Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_valuator_format, "fl_valuator_format"); + pragma Inline (fl_valuator_format); + + + + + -- Calculation -- + + function fl_valuator_clamp + (V : in Storage.Integer_Address; + D : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_valuator_clamp, "fl_valuator_clamp"); + pragma Inline (fl_valuator_clamp); + + function fl_valuator_round + (V : in Storage.Integer_Address; + D : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_valuator_round, "fl_valuator_round"); + pragma Inline (fl_valuator_round); + + function fl_valuator_increment + (V : in Storage.Integer_Address; + D : in Interfaces.C.double; + S : in Interfaces.C.int) + return Interfaces.C.double; + pragma Import (C, fl_valuator_increment, "fl_valuator_increment"); + pragma Inline (fl_valuator_increment); + + + + + -- Settings, Value -- + + function fl_valuator_get_minimum + (V : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_valuator_get_minimum, "fl_valuator_get_minimum"); + pragma Inline (fl_valuator_get_minimum); + + procedure fl_valuator_set_minimum + (V : in Storage.Integer_Address; + D : in Interfaces.C.double); + pragma Import (C, fl_valuator_set_minimum, "fl_valuator_set_minimum"); + pragma Inline (fl_valuator_set_minimum); + + function fl_valuator_get_maximum + (V : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_valuator_get_maximum, "fl_valuator_get_maximum"); + pragma Inline (fl_valuator_get_maximum); + + procedure fl_valuator_set_maximum + (V : in Storage.Integer_Address; + D : in Interfaces.C.double); + pragma Import (C, fl_valuator_set_maximum, "fl_valuator_set_maximum"); + pragma Inline (fl_valuator_set_maximum); + + function fl_valuator_get_step + (V : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_valuator_get_step, "fl_valuator_get_step"); + pragma Inline (fl_valuator_get_step); + + procedure fl_valuator_set_step_top + (V : in Storage.Integer_Address; + T : in Interfaces.C.double); + pragma Import (C, fl_valuator_set_step_top, "fl_valuator_set_step_top"); + pragma Inline (fl_valuator_set_step_top); + + procedure fl_valuator_set_step_bottom + (V : in Storage.Integer_Address; + B : in Interfaces.C.int); + pragma Import (C, fl_valuator_set_step_bottom, "fl_valuator_set_step_bottom"); + pragma Inline (fl_valuator_set_step_bottom); + + procedure fl_valuator_set_step + (V : in Storage.Integer_Address; + T : in Interfaces.C.double; + B : in Interfaces.C.int); + pragma Import (C, fl_valuator_set_step, "fl_valuator_set_step"); + pragma Inline (fl_valuator_set_step); + + function fl_valuator_get_value + (V : in Storage.Integer_Address) + return Interfaces.C.double; + pragma Import (C, fl_valuator_get_value, "fl_valuator_get_value"); + pragma Inline (fl_valuator_get_value); + + procedure fl_valuator_set_value + (V : in Storage.Integer_Address; + D : in Interfaces.C.double); + pragma Import (C, fl_valuator_set_value, "fl_valuator_set_value"); + pragma Inline (fl_valuator_set_value); + + procedure fl_valuator_bounds + (V : in Storage.Integer_Address; + A, B : in Interfaces.C.double); + pragma Import (C, fl_valuator_bounds, "fl_valuator_bounds"); + pragma Inline (fl_valuator_bounds); + + procedure fl_valuator_precision + (V : in Storage.Integer_Address; + D : in Interfaces.C.int); + pragma Import (C, fl_valuator_precision, "fl_valuator_precision"); + pragma Inline (fl_valuator_precision); + + procedure fl_valuator_range + (V : in Storage.Integer_Address; + A, B : in Interfaces.C.double); + pragma Import (C, fl_valuator_range, "fl_valuator_range"); + pragma Inline (fl_valuator_range); + + + + + -- Drawing, Events -- + + procedure fl_valuator_value_damage + (V : in Storage.Integer_Address); + pragma Import (C, fl_valuator_value_damage, "fl_valuator_value_damage"); + pragma Inline (fl_valuator_value_damage); + + procedure fl_valuator_draw + (V : in Storage.Integer_Address); + pragma Import (C, fl_valuator_draw, "fl_valuator_draw"); + pragma Inline (fl_valuator_draw); + + function fl_valuator_handle + (V : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_valuator_handle, "fl_valuator_handle"); + pragma Inline (fl_valuator_handle); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + function Valuator_Format_Hook + (Userdata : in Storage.Integer_Address; + Buffer : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + pragma Export (C, Valuator_Format_Hook, "valuator_format_hook"); + + function Valuator_Format_Hook + (Userdata : in Storage.Integer_Address; + Buffer : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int + is + Ada_Obj : access Valuator'Class; + begin + pragma Assert (Userdata /= Null_Pointer); + Ada_Obj := Valuator_Convert.To_Pointer (Storage.To_Address (Userdata)); + declare + -- God this whole Format method is sketchy as hell. + -- ...what? This is the area to declare things and that needed declaring. + String_Result : constant String := Ada_Obj.Format; + begin + if String_Result'Length <= FLTK.Buffer_Size then + Interfaces.C.Strings.Update (Buffer, 0, Interfaces.C.To_C (String_Result), False); + return String_Result'Length; + else + Interfaces.C.Strings.Update + (Buffer, 0, Interfaces.C.To_C (String_Result (1 .. Buffer_Size)), False); + return Interfaces.C.int (FLTK.Buffer_Size); + end if; + end; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Valuator::format callback hook was passed null userdata wrapper reference pointer"; + end Valuator_Format_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Valuator) is + begin + Extra_Final (Widget (This)); + end Extra_Final; + + + procedure Finalize + (This : in out Valuator) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_valuator (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Valuator; + X, Y, W, H : in Integer; + Text : in String) is + begin + Extra_Init (Widget (This), X, Y, W, H, Text); + end Extra_Init; + + + procedure Initialize + (This : in out Valuator) is + begin + This.Draw_Ptr := fl_valuator_draw'Address; + This.Handle_Ptr := fl_valuator_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Valuator is + begin + return This : Valuator do + This.Void_Ptr := new_fl_valuator + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Valuator is + begin + return This : Valuator := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Formatting -- + + function Format + (This : in Valuator) + return String + is + Buffer : Interfaces.C.char_array := + (1 .. Interfaces.C.size_t (FLTK.Buffer_Size) => Interfaces.C.To_C (Character'Val (0))); + Result : constant Interfaces.C.int := fl_valuator_format (This.Void_Ptr, Buffer); + begin + return Interfaces.C.To_Ada (Buffer (1 .. Interfaces.C.size_t (Result)), False); + end Format; + + + + + -- Calculation -- + + function Clamp + (This : in Valuator; + Input : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_valuator_clamp (This.Void_Ptr, Interfaces.C.double (Input))); + end Clamp; + + + function Round + (This : in Valuator; + Input : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_valuator_round (This.Void_Ptr, Interfaces.C.double (Input))); + end Round; + + + function Increment + (This : in Valuator; + Input : in Long_Float; + Step : in Integer) + return Long_Float is + begin + return Long_Float (fl_valuator_increment + (This.Void_Ptr, + Interfaces.C.double (Input), + Interfaces.C.int (Step))); + end Increment; + + + + + -- Settings, Value -- + + function Get_Minimum + (This : in Valuator) + return Long_Float is + begin + return Long_Float (fl_valuator_get_minimum (This.Void_Ptr)); + end Get_Minimum; + + + procedure Set_Minimum + (This : in out Valuator; + To : in Long_Float) is + begin + fl_valuator_set_minimum (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Minimum; + + + function Get_Maximum + (This : in Valuator) + return Long_Float is + begin + return Long_Float (fl_valuator_get_maximum (This.Void_Ptr)); + end Get_Maximum; + + + procedure Set_Maximum + (This : in out Valuator; + To : in Long_Float) is + begin + fl_valuator_set_maximum (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Maximum; + + + function Get_Step + (This : in Valuator) + return Long_Float is + begin + return Long_Float (fl_valuator_get_step (This.Void_Ptr)); + end Get_Step; + + + procedure Set_Step_Top + (This : in out Valuator; + To : in Long_Float) is + begin + fl_valuator_set_step_top + (This.Void_Ptr, + Interfaces.C.double (To)); + end Set_Step_Top; + + + procedure Set_Step_Bottom + (This : in out Valuator; + To : in Integer) is + begin + fl_valuator_set_step_bottom + (This.Void_Ptr, + Interfaces.C.int (To)); + end Set_Step_Bottom; + + + procedure Set_Step + (This : in out Valuator; + Top : in Long_Float; + Bottom : in Integer) is + begin + fl_valuator_set_step + (This.Void_Ptr, + Interfaces.C.double (Top), + Interfaces.C.int (Bottom)); + end Set_Step; + + + function Get_Value + (This : in Valuator) + return Long_Float is + begin + return Long_Float (fl_valuator_get_value (This.Void_Ptr)); + end Get_Value; + + + procedure Set_Value + (This : in out Valuator; + To : in Long_Float) is + begin + fl_valuator_set_value (This.Void_Ptr, Interfaces.C.double (To)); + end Set_Value; + + + procedure Set_Bounds + (This : in out Valuator; + Min, Max : in Long_Float) is + begin + fl_valuator_bounds + (This.Void_Ptr, + Interfaces.C.double (Min), + Interfaces.C.double (Max)); + end Set_Bounds; + + + procedure Set_Precision + (This : in out Valuator; + To : in Integer) is + begin + fl_valuator_precision (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Precision; + + + procedure Set_Range + (This : in out Valuator; + Min, Max : in Long_Float) is + begin + fl_valuator_range + (This.Void_Ptr, + Interfaces.C.double (Min), + Interfaces.C.double (Max)); + end Set_Range; + + + + + -- Drawing -- + + procedure Value_Damage + (This : in out Valuator) is + begin + fl_valuator_value_damage (This.Void_Ptr); + end Value_Damage; + + +end FLTK.Widgets.Valuators; + + diff --git a/body/fltk-widgets.adb b/body/fltk-widgets.adb new file mode 100644 index 0000000..f4409e4 --- /dev/null +++ b/body/fltk-widgets.adb @@ -0,0 +1,1691 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings, + FLTK.Widgets.Groups.Windows; + +use type + + Interfaces.C.int, + Interfaces.C.unsigned, + Interfaces.C.unsigned_char, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Widgets is + + + package Chk renames Ada.Assertions; + + + package Group_Convert is new + System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Group'Class); + + package Window_Convert is new + System.Address_To_Access_Conversions (FLTK.Widgets.Groups.Windows.Window'Class); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Allocation -- + + function new_fl_widget + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_widget, "new_fl_widget"); + pragma Inline (new_fl_widget); + + procedure free_fl_widget + (F : in Storage.Integer_Address); + pragma Import (C, free_fl_widget, "free_fl_widget"); + pragma Inline (free_fl_widget); + + + + + -- Activity -- + + procedure fl_widget_activate + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_activate, "fl_widget_activate"); + pragma Inline (fl_widget_activate); + + procedure fl_widget_deactivate + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_deactivate, "fl_widget_deactivate"); + pragma Inline (fl_widget_deactivate); + + function fl_widget_active + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_active, "fl_widget_active"); + pragma Inline (fl_widget_active); + + function fl_widget_active_r + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_active_r, "fl_widget_active_r"); + pragma Inline (fl_widget_active_r); + + procedure fl_widget_set_active + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_active, "fl_widget_set_active"); + pragma Inline (fl_widget_set_active); + + procedure fl_widget_clear_active + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_active, "fl_widget_clear_active"); + pragma Inline (fl_widget_clear_active); + + + + + -- Changed and Output -- + + function fl_widget_changed + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_widget_changed, "fl_widget_changed"); + pragma Inline (fl_widget_changed); + + procedure fl_widget_set_changed + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_changed, "fl_widget_set_changed"); + pragma Inline (fl_widget_set_changed); + + procedure fl_widget_clear_changed + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_changed, "fl_widget_clear_changed"); + pragma Inline (fl_widget_clear_changed); + + function fl_widget_output + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_output, "fl_widget_output"); + pragma Inline (fl_widget_output); + + procedure fl_widget_set_output + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_output, "fl_widget_set_output"); + pragma Inline (fl_widget_set_output); + + procedure fl_widget_clear_output + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_output, "fl_widget_clear_output"); + pragma Inline (fl_widget_clear_output); + + + + + -- Visibility -- + + function fl_widget_visible + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_visible, "fl_widget_visible"); + pragma Inline (fl_widget_visible); + + function fl_widget_visible_r + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_visible_r, "fl_widget_visible_r"); + pragma Inline (fl_widget_visible_r); + + procedure fl_widget_set_visible + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_visible, "fl_widget_set_visible"); + pragma Inline (fl_widget_set_visible); + + procedure fl_widget_clear_visible + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_visible, "fl_widget_clear_visible"); + pragma Inline (fl_widget_clear_visible); + + procedure fl_widget_show + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_show, "fl_widget_show"); + pragma Inline (fl_widget_show); + + procedure fl_widget_hide + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_hide, "fl_widget_hide"); + pragma Inline (fl_widget_hide); + + + + + -- Focus -- + + function fl_widget_get_visible_focus + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_visible_focus, "fl_widget_get_visible_focus"); + pragma Inline (fl_widget_get_visible_focus); + + procedure fl_widget_set_visible_focus2 + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_visible_focus2, "fl_widget_set_visible_focus2"); + pragma Inline (fl_widget_set_visible_focus2); + + procedure fl_widget_set_visible_focus + (W : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_widget_set_visible_focus, "fl_widget_set_visible_focus"); + pragma Inline (fl_widget_set_visible_focus); + + procedure fl_widget_clear_visible_focus + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_clear_visible_focus, "fl_widget_clear_visible_focus"); + pragma Inline (fl_widget_clear_visible_focus); + + function fl_widget_take_focus + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_take_focus, "fl_widget_take_focus"); + pragma Inline (fl_widget_take_focus); + + function fl_widget_takesevents + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_takesevents, "fl_widget_takesevents"); + pragma Inline (fl_widget_takesevents); + + + + + -- Colors -- + + function fl_widget_get_color + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_widget_get_color, "fl_widget_get_color"); + pragma Inline (fl_widget_get_color); + + procedure fl_widget_set_color + (W : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_color, "fl_widget_set_color"); + pragma Inline (fl_widget_set_color); + + function fl_widget_get_selection_color + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_widget_get_selection_color, "fl_widget_get_selection_color"); + pragma Inline (fl_widget_get_selection_color); + + procedure fl_widget_set_selection_color + (W : in Storage.Integer_Address; + T : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_selection_color, "fl_widget_set_selection_color"); + pragma Inline (fl_widget_set_selection_color); + + procedure fl_widget_set_colors + (W : in Storage.Integer_Address; + B, S : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_colors, "fl_widget_set_colors"); + pragma Inline (fl_widget_set_colors); + + + + + -- Relatives -- + + function fl_widget_get_parent + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_parent, "fl_widget_get_parent"); + pragma Inline (fl_widget_get_parent); + + function fl_widget_contains + (W, I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_contains, "fl_widget_contains"); + pragma Inline (fl_widget_contains); + + function fl_widget_inside + (W, P : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_inside, "fl_widget_inside"); + pragma Inline (fl_widget_inside); + + function fl_widget_window + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_window, "fl_widget_window"); + pragma Inline (fl_widget_window); + + function fl_widget_top_window + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_top_window, "fl_widget_top_window"); + pragma Inline (fl_widget_top_window); + + function fl_widget_top_window_offset + (W : in Storage.Integer_Address; + X, Y : out Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, fl_widget_top_window_offset, "fl_widget_top_window_offset"); + pragma Inline (fl_widget_top_window_offset); + + + + + -- Alignment, Box, Tooltip -- + + function fl_widget_get_align + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_widget_get_align, "fl_widget_get_align"); + pragma Inline (fl_widget_get_align); + + procedure fl_widget_set_align + (W : in Storage.Integer_Address; + A : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_align, "fl_widget_set_align"); + pragma Inline (fl_widget_set_align); + + function fl_widget_get_box + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_box, "fl_widget_get_box"); + pragma Inline (fl_widget_get_box); + + procedure fl_widget_set_box + (W : in Storage.Integer_Address; + B : in Interfaces.C.int); + pragma Import (C, fl_widget_set_box, "fl_widget_set_box"); + pragma Inline (fl_widget_set_box); + + function fl_widget_tooltip + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_widget_tooltip, "fl_widget_tooltip"); + pragma Inline (fl_widget_tooltip); + + procedure fl_widget_copy_tooltip + (W : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_widget_copy_tooltip, "fl_widget_copy_tooltip"); + pragma Inline (fl_widget_copy_tooltip); + + + + + -- Labels -- + + function fl_widget_get_label + (W : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_widget_get_label, "fl_widget_get_label"); + pragma Inline (fl_widget_get_label); + + function fl_widget_get_labelcolor + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_widget_get_labelcolor, "fl_widget_get_labelcolor"); + pragma Inline (fl_widget_get_labelcolor); + + procedure fl_widget_set_labelcolor + (W : in Storage.Integer_Address; + V : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_set_labelcolor, "fl_widget_set_labelcolor"); + pragma Inline (fl_widget_set_labelcolor); + + function fl_widget_get_labelfont + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_labelfont, "fl_widget_get_labelfont"); + pragma Inline (fl_widget_get_labelfont); + + procedure fl_widget_set_labelfont + (W : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_widget_set_labelfont, "fl_widget_set_labelfont"); + pragma Inline (fl_widget_set_labelfont); + + function fl_widget_get_labelsize + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_labelsize, "fl_widget_get_labelsize"); + pragma Inline (fl_widget_get_labelsize); + + procedure fl_widget_set_labelsize + (W : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_widget_set_labelsize, "fl_widget_set_labelsize"); + pragma Inline (fl_widget_set_labelsize); + + function fl_widget_get_labeltype + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_labeltype, "fl_widget_get_labeltype"); + pragma Inline (fl_widget_get_labeltype); + + procedure fl_widget_set_labeltype + (W : in Storage.Integer_Address; + L : in Interfaces.C.int); + pragma Import (C, fl_widget_set_labeltype, "fl_widget_set_labeltype"); + pragma Inline (fl_widget_set_labeltype); + + procedure fl_widget_measure_label + (W : in Storage.Integer_Address; + D, H : out Interfaces.C.int); + pragma Import (C, fl_widget_measure_label, "fl_widget_measure_label"); + pragma Inline (fl_widget_measure_label); + + + + + -- Callbacks -- + + procedure fl_widget_set_callback + (W, C : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_callback, "fl_widget_set_callback"); + pragma Inline (fl_widget_set_callback); + + procedure fl_widget_default_callback + (W, U : in Storage.Integer_Address); + pragma Import (C, fl_widget_default_callback, "fl_widget_default_callback"); + pragma Inline (fl_widget_default_callback); + + function fl_widget_get_when + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_widget_get_when, "fl_widget_get_when"); + pragma Inline (fl_widget_get_when); + + procedure fl_widget_set_when + (W : in Storage.Integer_Address; + T : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_set_when, "fl_widget_set_when"); + pragma Inline (fl_widget_set_when); + + + + + -- Dimensions -- + + function fl_widget_get_x + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_x, "fl_widget_get_x"); + pragma Inline (fl_widget_get_x); + + function fl_widget_get_y + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_y, "fl_widget_get_y"); + pragma Inline (fl_widget_get_y); + + function fl_widget_get_w + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_w, "fl_widget_get_w"); + pragma Inline (fl_widget_get_w); + + function fl_widget_get_h + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_get_h, "fl_widget_get_h"); + pragma Inline (fl_widget_get_h); + + procedure fl_widget_size + (W : in Storage.Integer_Address; + D, H : in Interfaces.C.int); + pragma Import (C, fl_widget_size, "fl_widget_size"); + pragma Inline (fl_widget_size); + + procedure fl_widget_resize + (O : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_resize, "fl_widget_resize"); + pragma Inline (fl_widget_resize); + + procedure fl_widget_position + (W : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_widget_position, "fl_widget_position"); + pragma Inline (fl_widget_position); + + + + + -- Images -- + + procedure fl_widget_set_image + (W, I : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_image, "fl_widget_set_image"); + pragma Inline (fl_widget_set_image); + + procedure fl_widget_set_deimage + (W, I : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_deimage, "fl_widget_set_deimage"); + pragma Inline (fl_widget_set_deimage); + + + + + -- Damage, Drawing, Events -- + + function fl_widget_damage + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_widget_damage, "fl_widget_damage"); + pragma Inline (fl_widget_damage); + + procedure fl_widget_set_damage + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_set_damage, "fl_widget_set_damage"); + pragma Inline (fl_widget_set_damage); + + procedure fl_widget_set_damage2 + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char; + X, Y, D, H : in Interfaces.C.int); + pragma Import (C, fl_widget_set_damage2, "fl_widget_set_damage2"); + pragma Inline (fl_widget_set_damage2); + + procedure fl_widget_clear_damage + (W : in Storage.Integer_Address; + M : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_clear_damage, "fl_widget_clear_damage"); + pragma Inline (fl_widget_clear_damage); + + procedure fl_widget_draw + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw, "fl_widget_draw"); + pragma Inline (fl_widget_draw); + + procedure fl_widget_draw_label + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_label, "fl_widget_draw_label"); + pragma Inline (fl_widget_draw_label); + + procedure fl_widget_draw_label2 + (O : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_draw_label2, "fl_widget_draw_label2"); + pragma Inline (fl_widget_draw_label2); + + procedure fl_widget_draw_label3 + (W : in Storage.Integer_Address; + X, Y, D, H : in Interfaces.C.int; + A : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_label3, "fl_widget_draw_label3"); + pragma Inline (fl_widget_draw_label3); + + procedure fl_widget_draw_backdrop + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_backdrop, "fl_widget_draw_backdrop"); + pragma Inline (fl_widget_draw_backdrop); + + procedure fl_widget_draw_box + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_box, "fl_widget_draw_box"); + pragma Inline (fl_widget_draw_box); + + procedure fl_widget_draw_box2 + (W : in Storage.Integer_Address; + K : in Interfaces.C.int; + H : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_box2, "fl_widget_draw_box2"); + pragma Inline (fl_widget_draw_box2); + + procedure fl_widget_draw_box3 + (O : in Storage.Integer_Address; + K, X, Y, W, H : in Interfaces.C.int; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_widget_draw_box3, "fl_widget_draw_box3"); + pragma Inline (fl_widget_draw_box3); + + procedure fl_widget_draw_focus + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_draw_focus, "fl_widget_draw_focus"); + pragma Inline (fl_widget_draw_focus); + + procedure fl_widget_draw_focus2 + (O : in Storage.Integer_Address; + K, X, Y, W, H : in Interfaces.C.int); + pragma Import (C, fl_widget_draw_focus2, "fl_widget_draw_focus2"); + pragma Inline (fl_widget_draw_focus2); + + procedure fl_widget_redraw + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_redraw, "fl_widget_redraw"); + pragma Inline (fl_widget_redraw); + + procedure fl_widget_redraw_label + (W : in Storage.Integer_Address); + pragma Import (C, fl_widget_redraw_label, "fl_widget_redraw_label"); + pragma Inline (fl_widget_redraw_label); + + function fl_widget_handle + (W : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_widget_handle, "fl_widget_handle"); + pragma Inline (fl_widget_handle); + + + + + -- Miscellaneous -- + + function fl_widget_use_accents_menu + (W : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_widget_use_accents_menu, "fl_widget_use_accents_menu"); + pragma Inline (fl_widget_use_accents_menu); + + + + + ---------------------- + -- Exported Hooks -- + ---------------------- + + procedure Callback_Hook + (W, U : in Storage.Integer_Address) + is + Ada_Widget : constant access Widget'Class := + Widget_Convert.To_Pointer (Storage.To_Address (U)); + begin + Ada_Widget.Callback.all (Ada_Widget.all); + end Callback_Hook; + + + procedure Draw_Hook + (U : in Storage.Integer_Address) + is + Ada_Widget : constant access Widget'Class := + Widget_Convert.To_Pointer (Storage.To_Address (U)); + begin + Ada_Widget.Draw; + end Draw_Hook; + + + function Handle_Hook + (U : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int + is + Ada_Widget : constant access Widget'Class := + Widget_Convert.To_Pointer (Storage.To_Address (U)); + begin + return Event_Outcome'Pos (Ada_Widget.Handle (Event_Kind'Val (E))); + end Handle_Hook; + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Extra_Final + (This : in out Widget) + is + Maybe_Parent : access FLTK.Widgets.Groups.Group'Class; + begin + if This.Needs_Dealloc then + Maybe_Parent := This.Parent; + if Maybe_Parent /= null then + Maybe_Parent.Remove (This); + end if; + end if; + end Extra_Final; + + + procedure Finalize + (This : in out Widget) is + begin + Extra_Final (This); + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_widget (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + procedure Extra_Init + (This : in out Widget; + X, Y, W, H : in Integer; + Text : in String) is + begin + fl_widget_set_user_data + (This.Void_Ptr, + Storage.To_Integer (Widget_Convert.To_Address (This'Unchecked_Access))); + fl_widget_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Extra_Init; + + + procedure Initialize + (This : in out Widget) is + begin + This.Draw_Ptr := fl_widget_draw'Address; + This.Handle_Ptr := fl_widget_handle'Address; + end Initialize; + + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Widget is + begin + return This : Widget do + This.Void_Ptr := new_fl_widget + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + Extra_Init (This, X, Y, W, H, Text); + end return; + end Create; + + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Widget is + begin + return This : Widget := Create (X, Y, W, H, Text) do + Parent.Add (This); + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Activity -- + + procedure Activate + (This : in out Widget) is + begin + fl_widget_activate (This.Void_Ptr); + end Activate; + + + procedure Deactivate + (This : in out Widget) is + begin + fl_widget_deactivate (This.Void_Ptr); + end Deactivate; + + + function Is_Active + (This : in Widget) + return Boolean is + begin + return fl_widget_active (This.Void_Ptr) /= 0; + end Is_Active; + + + function Is_Tree_Active + (This : in Widget) + return Boolean is + begin + return fl_widget_active_r (This.Void_Ptr) /= 0; + end Is_Tree_Active; + + + procedure Set_Active + (This : in out Widget) is + begin + fl_widget_set_active (This.Void_Ptr); + end Set_Active; + + + procedure Set_Active + (This : in out Widget; + To : in Boolean) is + begin + if To then + fl_widget_set_active (This.Void_Ptr); + else + fl_widget_clear_active (This.Void_Ptr); + end if; + end Set_Active; + + + procedure Clear_Active + (This : in out Widget) is + begin + fl_widget_clear_active (This.Void_Ptr); + end Clear_Active; + + + + + -- Changed and Output -- + + function Has_Changed + (This : in Widget) + return Boolean is + begin + return fl_widget_changed (This.Void_Ptr) /= 0; + end Has_Changed; + + + procedure Set_Changed + (This : in out Widget) is + begin + fl_widget_set_changed (This.Void_Ptr); + end Set_Changed; + + + procedure Set_Changed + (This : in out Widget; + To : in Boolean) is + begin + if To then + fl_widget_set_changed (This.Void_Ptr); + else + fl_widget_clear_changed (This.Void_Ptr); + end if; + end Set_Changed; + + + procedure Clear_Changed + (This : in out Widget) is + begin + fl_widget_clear_changed (This.Void_Ptr); + end Clear_Changed; + + + function Is_Output_Only + (This : in Widget) + return Boolean is + begin + return fl_widget_output (This.Void_Ptr) /= 0; + end Is_Output_Only; + + + procedure Set_Output_Only + (This : in out Widget) is + begin + fl_widget_set_output (This.Void_Ptr); + end Set_Output_Only; + + + procedure Set_Output_Only + (This : in out Widget; + To : in Boolean) is + begin + if To then + fl_widget_set_output (This.Void_Ptr); + else + fl_widget_clear_output (This.Void_Ptr); + end if; + end Set_Output_Only; + + + procedure Clear_Output_Only + (This : in out Widget) is + begin + fl_widget_clear_output (This.Void_Ptr); + end Clear_Output_Only; + + + + + -- Visibility -- + + function Is_Visible + (This : in Widget) + return Boolean is + begin + return fl_widget_visible (This.Void_Ptr) /= 0; + end Is_Visible; + + + function Is_Tree_Visible + (This : in Widget) + return Boolean is + begin + return fl_widget_visible_r (This.Void_Ptr) /= 0; + end Is_Tree_Visible; + + + procedure Set_Visible + (This : in out Widget) is + begin + fl_widget_set_visible (This.Void_Ptr); + end Set_Visible; + + + procedure Set_Visible + (This : in out Widget; + To : in Boolean) is + begin + if To then + fl_widget_set_visible (This.Void_Ptr); + else + fl_widget_clear_visible (This.Void_Ptr); + end if; + end Set_Visible; + + + procedure Clear_Visible + (This : in out Widget) is + begin + fl_widget_clear_visible (This.Void_Ptr); + end Clear_Visible; + + + procedure Show + (This : in out Widget) is + begin + fl_widget_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Widget) is + begin + fl_widget_hide (This.Void_Ptr); + end Hide; + + + + + -- Focus -- + + function Has_Visible_Focus + (This : in Widget) + return Boolean is + begin + return fl_widget_get_visible_focus (This.Void_Ptr) /= 0; + end Has_Visible_Focus; + + + procedure Set_Visible_Focus + (This : in out Widget) is + begin + fl_widget_set_visible_focus2 (This.Void_Ptr); + end Set_Visible_Focus; + + + procedure Set_Visible_Focus + (This : in out Widget; + To : in Boolean) is + begin + fl_widget_set_visible_focus (This.Void_Ptr, Boolean'Pos (To)); + end Set_Visible_Focus; + + + procedure Clear_Visible_Focus + (This : in out Widget) is + begin + fl_widget_clear_visible_focus (This.Void_Ptr); + end Clear_Visible_Focus; + + + function Take_Focus + (This : in out Widget) + return Boolean is + begin + return fl_widget_take_focus (This.Void_Ptr) /= 0; + end Take_Focus; + + + function Takes_Events + (This : in Widget) + return Boolean is + begin + return fl_widget_takesevents (This.Void_Ptr) /= 0; + end Takes_Events; + + + + + -- Colors -- + + function Get_Background_Color + (This : in Widget) + return Color is + begin + return Color (fl_widget_get_color (This.Void_Ptr)); + end Get_Background_Color; + + + procedure Set_Background_Color + (This : in out Widget; + To : in Color) is + begin + fl_widget_set_color (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Background_Color; + + + function Get_Selection_Color + (This : in Widget) + return Color is + begin + return Color (fl_widget_get_selection_color (This.Void_Ptr)); + end Get_Selection_Color; + + + procedure Set_Selection_Color + (This : in out Widget; + To : in Color) is + begin + fl_widget_set_selection_color (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Selection_Color; + + + procedure Set_Colors + (This : in out Widget; + Back, Sel : in Color) is + begin + fl_widget_set_colors + (This.Void_Ptr, + Interfaces.C.unsigned (Back), + Interfaces.C.unsigned (Sel)); + end Set_Colors; + + + + + -- Relatives -- + + function Parent + (This : in Widget) + return access FLTK.Widgets.Groups.Group'Class + is + Parent_Ptr : Storage.Integer_Address := fl_widget_get_parent (This.Void_Ptr); + Actual_Parent : access FLTK.Widgets.Groups.Group'Class; + begin + if Parent_Ptr /= Null_Pointer then + Parent_Ptr := fl_widget_get_user_data (Parent_Ptr); + -- Can't assert user data being not null here because fl_ask is a bitch, + -- so have to fall back on saying that if it's null then you get nothing. + -- Any widget created by users of this binding will have appropriate back + -- reference to the corresponding Ada object in the user data anyway. + Actual_Parent := Group_Convert.To_Pointer (Storage.To_Address (Parent_Ptr)); + end if; + return Actual_Parent; + end Parent; + + + function Contains + (This : in Widget; + Item : in Widget'Class) + return Boolean is + begin + return fl_widget_contains (This.Void_Ptr, Item.Void_Ptr) /= 0; + end Contains; + + + function Inside + (This : in Widget; + Parent : in Widget'Class) + return Boolean is + begin + return fl_widget_inside (This.Void_Ptr, Parent.Void_Ptr) /= 0; + end Inside; + + + function Nearest_Window + (This : in Widget) + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Window_Ptr : Storage.Integer_Address := fl_widget_window (This.Void_Ptr); + Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Window_Ptr /= Null_Pointer then + Window_Ptr := fl_widget_get_user_data (Window_Ptr); + pragma Assert (Window_Ptr /= Null_Pointer); + Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Window_Ptr)); + end if; + return Actual_Window; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::window has no user_data reference back to Ada"; + end Nearest_Window; + + + function Top_Window + (This : in Widget) + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Window_Ptr : Storage.Integer_Address := fl_widget_top_window (This.Void_Ptr); + Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Window_Ptr /= Null_Pointer then + Window_Ptr := fl_widget_get_user_data (Window_Ptr); + pragma Assert (Window_Ptr /= Null_Pointer); + Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Window_Ptr)); + end if; + return Actual_Window; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::top_window has no user_data reference back to Ada"; + end Top_Window; + + + function Top_Window_Offset + (This : in Widget; + Offset_X, Offset_Y : out Integer) + return access FLTK.Widgets.Groups.Windows.Window'Class + is + Window_Ptr : Storage.Integer_Address := fl_widget_top_window_offset + (This.Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; + begin + if Window_Ptr /= Null_Pointer then + Window_Ptr := fl_widget_get_user_data (Window_Ptr); + pragma Assert (Window_Ptr /= Null_Pointer); + Actual_Window := Window_Convert.To_Pointer (Storage.To_Address (Window_Ptr)); + end if; + return Actual_Window; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Widget returned by Fl_Widget::top_window_offset has no user_data reference back to Ada"; + end Top_Window_Offset; + + + + + -- Alignment, Box, Tooltip -- + + function Get_Alignment + (This : in Widget) + return Alignment is + begin + return Alignment (fl_widget_get_align (This.Void_Ptr)); + end Get_Alignment; + + + procedure Set_Alignment + (This : in out Widget; + New_Align : in Alignment) is + begin + fl_widget_set_align (This.Void_Ptr, Interfaces.C.unsigned (New_Align)); + end Set_Alignment; + + + function Get_Box + (This : in Widget) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_widget_get_box (This.Void_Ptr); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Widget::box returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Box; + + + procedure Set_Box + (This : in out Widget; + Box : in Box_Kind) is + begin + fl_widget_set_box (This.Void_Ptr, Box_Kind'Pos (Box)); + end Set_Box; + + + function Get_Tooltip + (This : in Widget) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_widget_tooltip (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + -- no need for dealloc + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Tooltip; + + + procedure Set_Tooltip + (This : in out Widget; + Text : in String) is + begin + fl_widget_copy_tooltip (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Set_Tooltip; + + + + + -- Labels -- + + function Get_Label + (This : in Widget) + return String + is + Ptr : constant Interfaces.C.Strings.chars_ptr := fl_widget_get_label (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Label; + + + procedure Set_Label + (This : in out Widget; + Text : in String) is + begin + fl_widget_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Label + (This : in out Widget; + Kind : in Label_Kind; + Text : in String) is + begin + This.Set_Label_Kind (Kind); + This.Set_Label (Text); + end Set_Label; + + + function Get_Label_Color + (This : in Widget) + return Color is + begin + return Color (fl_widget_get_labelcolor (This.Void_Ptr)); + end Get_Label_Color; + + + procedure Set_Label_Color + (This : in out Widget; + Value : in Color) is + begin + fl_widget_set_labelcolor (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Label_Color; + + + function Get_Label_Font + (This : in Widget) + return Font_Kind is + begin + return Font_Kind'Val (fl_widget_get_labelfont (This.Void_Ptr)); + end Get_Label_Font; + + + procedure Set_Label_Font + (This : in out Widget; + Font : in Font_Kind) is + begin + fl_widget_set_labelfont (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Label_Font; + + + function Get_Label_Size + (This : in Widget) + return Font_Size is + begin + return Font_Size (fl_widget_get_labelsize (This.Void_Ptr)); + end Get_Label_Size; + + + procedure Set_Label_Size + (This : in out Widget; + Size : in Font_Size) is + begin + fl_widget_set_labelsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Label_Size; + + + function Get_Label_Kind + (This : in Widget) + return Label_Kind + is + Result : constant Interfaces.C.int := fl_widget_get_labeltype (This.Void_Ptr); + begin + return Label_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Widget::labeltype returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Kind; + + + procedure Set_Label_Kind + (This : in out Widget; + Label : in Label_Kind) is + begin + fl_widget_set_labeltype (This.Void_Ptr, Label_Kind'Pos (Label)); + end Set_Label_Kind; + + + procedure Measure_Label + (This : in Widget; + W, H : out Integer) is + begin + fl_widget_measure_label + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Measure_Label; + + + + + -- Callbacks -- + + function Get_Callback + (This : in Widget) + return Widget_Callback is + begin + return This.Callback; + end Get_Callback; + + + procedure Set_Callback + (This : in out Widget; + Func : in Widget_Callback) is + begin + if Func /= null then + This.Callback := Func; + fl_widget_set_callback (This.Void_Ptr, Storage.To_Integer (Callback_Hook'Address)); + end if; + end Set_Callback; + + + procedure Do_Callback + (This : in out Widget) is + begin + if This.Callback /= null then + This.Callback.all (This); + end if; + end Do_Callback; + + + procedure Do_Callback + (This : in Widget; + Using : in out Widget) is + begin + if This.Callback /= null then + This.Callback.all (Using); + end if; + end Do_Callback; + + + procedure Default_Callback + (This : in out Widget'Class) is + begin + fl_widget_default_callback + (This.Void_Ptr, + fl_widget_get_user_data (This.Void_Ptr)); + end Default_Callback; + + + function Get_When + (This : in Widget) + return Callback_Flag is + begin + return UChar_To_Flag (fl_widget_get_when (This.Void_Ptr)); + end Get_When; + + + procedure Set_When + (This : in out Widget; + To : in Callback_Flag) is + begin + fl_widget_set_when (This.Void_Ptr, Flag_To_UChar (To)); + end Set_When; + + + + + -- Dimensions -- + + function Get_X + (This : in Widget) + return Integer is + begin + return Integer (fl_widget_get_x (This.Void_Ptr)); + end Get_X; + + + function Get_Y + (This : in Widget) + return Integer is + begin + return Integer (fl_widget_get_y (This.Void_Ptr)); + end Get_Y; + + + function Get_W + (This : in Widget) + return Integer is + begin + return Integer (fl_widget_get_w (This.Void_Ptr)); + end Get_W; + + + function Get_H + (This : in Widget) + return Integer is + begin + return Integer (fl_widget_get_h (This.Void_Ptr)); + end Get_H; + + + procedure Resize + (This : in out Widget; + W, H : in Integer) is + begin + fl_widget_size + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Resize + (This : in out Widget; + X, Y, W, H : in Integer) is + begin + fl_widget_resize + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + procedure Reposition + (This : in out Widget; + X, Y : in Integer) is + begin + fl_widget_position + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Reposition; + + + + + -- Images -- + + function Get_Image + (This : in Widget) + return access FLTK.Images.Image'Class is + begin + return This.Current_Image; + end Get_Image; + + + procedure Set_Image + (This : in out Widget; + Pic : in out FLTK.Images.Image'Class) is + begin + This.Current_Image := Pic'Unchecked_Access; + fl_widget_set_image + (This.Void_Ptr, + Wrapper (Pic).Void_Ptr); + end Set_Image; + + + function Get_Inactive_Image + (This : in Widget) + return access FLTK.Images.Image'Class is + begin + return This.Inactive_Image; + end Get_Inactive_Image; + + + procedure Set_Inactive_Image + (This : in out Widget; + Pic : in out FLTK.Images.Image'Class) is + begin + This.Inactive_Image := Pic'Unchecked_Access; + fl_widget_set_deimage + (This.Void_Ptr, + Wrapper (Pic).Void_Ptr); + end Set_Inactive_Image; + + + + + -- Damage, Drawing, Events -- + + function Is_Damaged + (This : in Widget) + return Boolean is + begin + return fl_widget_damage (This.Void_Ptr) /= 0; + end Is_Damaged; + + + function Get_Damage + (This : in Widget) + return Damage_Mask is + begin + return UChar_To_Mask (fl_widget_damage (This.Void_Ptr)); + end Get_Damage; + + + procedure Set_Damage + (This : in out Widget; + Mask : in Damage_Mask) is + begin + fl_widget_set_damage (This.Void_Ptr, Mask_To_UChar (Mask)); + end Set_Damage; + + + procedure Set_Damage + (This : in out Widget; + Mask : in Damage_Mask; + X, Y, W, H : in Integer) is + begin + fl_widget_set_damage2 + (This.Void_Ptr, + Mask_To_UChar (Mask), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Set_Damage; + + + procedure Clear_Damage + (This : in out Widget; + Mask : in Damage_Mask := Damage_None) is + begin + fl_widget_clear_damage (This.Void_Ptr, Mask_To_UChar (Mask)); + end Clear_Damage; + + + procedure Draw + (This : in out Widget) + is + procedure my_draw + (V : in Storage.Integer_Address); + for my_draw'Address use This.Draw_Ptr; + pragma Import (Ada, my_draw); + begin + my_draw (This.Void_Ptr); + end Draw; + + + procedure Draw_Label + (This : in out Widget) is + begin + fl_widget_draw_label (This.Void_Ptr); + end Draw_Label; + + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer) is + begin + fl_widget_draw_label2 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Label; + + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer; + Align : in Alignment) is + begin + fl_widget_draw_label3 + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Align)); + end Draw_Label; + + + procedure Draw_Backdrop + (This : in out Widget) is + begin + fl_widget_draw_backdrop (This.Void_Ptr); + end Draw_Backdrop; + + + procedure Draw_Box + (This : in out Widget) is + begin + fl_widget_draw_box (This.Void_Ptr); + end Draw_Box; + + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + Hue : in Color) is + begin + fl_widget_draw_box2 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Hue : in Color) is + begin + fl_widget_draw_box3 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.unsigned (Hue)); + end Draw_Box; + + + procedure Draw_Focus + (This : in out Widget) is + begin + fl_widget_draw_focus (This.Void_Ptr); + end Draw_Focus; + + + procedure Draw_Focus + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer) is + begin + fl_widget_draw_focus2 + (This.Void_Ptr, + Box_Kind'Pos (Kind), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Draw_Focus; + + + procedure Redraw + (This : in out Widget) is + begin + fl_widget_redraw (This.Void_Ptr); + end Redraw; + + + procedure Redraw_Label + (This : in out Widget) is + begin + fl_widget_redraw_label (This.Void_Ptr); + end Redraw_Label; + + + function Handle + (This : in out Widget; + Event : in Event_Kind) + return Event_Outcome + is + function my_handle + (V : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + for my_handle'Address use This.Handle_Ptr; + pragma Import (Ada, my_handle); + + Result : constant Interfaces.C.int := my_handle (This.Void_Ptr, Event_Kind'Pos (Event)); + begin + return Event_Outcome'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Dispatched handle function returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Handle; + + + + + -- Miscellaneous -- + + function Uses_Accents_Menu + (This : in Widget) + return Boolean is + begin + return fl_widget_use_accents_menu (This.Void_Ptr) /= 0; + end Uses_Accents_Menu; + + +end FLTK.Widgets; + + diff --git a/body/fltk.adb b/body/fltk.adb new file mode 100644 index 0000000..49d9048 --- /dev/null +++ b/body/fltk.adb @@ -0,0 +1,776 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.int, + Interfaces.C.unsigned, + Interfaces.C.unsigned_char; + + +package body FLTK is + + + ------------------------ + -- Constants From C -- + ------------------------ + + -- Color -- + + fl_enum_num_red : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_red, "fl_enum_num_red"); + + fl_enum_num_green : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_green, "fl_enum_num_green"); + + fl_enum_num_blue : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_blue, "fl_enum_num_blue"); + + fl_enum_num_gray : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_gray, "fl_enum_num_gray"); + + + + + -- Keyboard and Mouse Input -- + + fl_enum_button1 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_buttons : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_buttons, "fl_enum_buttons"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + -- Enumerations.H -- + + -- Color -- + + function fl_enum_rgb_color2 + (L : in Interfaces.C.unsigned_char) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_rgb_color2, "fl_enum_rgb_color2"); + pragma Inline (fl_enum_rgb_color2); + + function fl_enum_rgb_color + (R, G, B : in Interfaces.C.unsigned_char) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_rgb_color, "fl_enum_rgb_color"); + pragma Inline (fl_enum_rgb_color); + + function fl_enum_color_cube + (R, G, B : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_color_cube, "fl_enum_color_cube"); + pragma Inline (fl_enum_color_cube); + + function fl_enum_gray_ramp + (L : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_gray_ramp, "fl_enum_gray_ramp"); + pragma Inline (fl_enum_gray_ramp); + + function fl_enum_darker + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_darker, "fl_enum_darker"); + pragma Inline (fl_enum_darker); + + function fl_enum_lighter + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_lighter, "fl_enum_lighter"); + pragma Inline (fl_enum_lighter); + + function fl_enum_contrast + (F, B : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_contrast, "fl_enum_contrast"); + pragma Inline (fl_enum_contrast); + + function fl_enum_inactive + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_inactive, "fl_enum_inactive"); + pragma Inline (fl_enum_inactive); + + function fl_enum_color_average + (T1, T2 : in Interfaces.C.unsigned; + W : in Interfaces.C.C_float) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_color_average, "fl_enum_color_average"); + pragma Inline (fl_enum_color_average); + + + + + -- Box Types -- + + function fl_enum_box + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_box, "fl_enum_box"); + pragma Inline (fl_enum_box); + + function fl_enum_frame + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_frame, "fl_enum_frame"); + pragma Inline (fl_enum_frame); + + function fl_enum_down + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_down, "fl_enum_down"); + pragma Inline (fl_enum_down); + + + + + -- Fl.H -- + + -- Versioning -- + + function fl_abi_check + (V : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_abi_check, "fl_abi_check"); + pragma Inline (fl_abi_check); + + function fl_abi_version + return Interfaces.C.int; + pragma Import (C, fl_abi_version, "fl_abi_version"); + pragma Inline (fl_abi_version); + + function fl_api_version + return Interfaces.C.int; + pragma Import (C, fl_api_version, "fl_api_version"); + pragma Inline (fl_api_version); + + function fl_version + return Interfaces.C.double; + pragma Import (C, fl_version, "fl_version"); + pragma Inline (fl_version); + + + + + -- Event Loop -- + + function fl_check + return Interfaces.C.int; + pragma Import (C, fl_check, "fl_check"); + pragma Inline (fl_check); + + function fl_ready + return Interfaces.C.int; + pragma Import (C, fl_ready, "fl_ready"); + pragma Inline (fl_ready); + + function fl_wait + return Interfaces.C.int; + pragma Import (C, fl_wait, "fl_wait"); + pragma Inline (fl_wait); + + function fl_wait2 + (S : in Interfaces.C.double) + return Interfaces.C.double; + pragma Import (C, fl_wait2, "fl_wait2"); + pragma Inline (fl_wait2); + + function fl_run + return Interfaces.C.int; + pragma Import (C, fl_run, "fl_run"); + pragma Inline (fl_run); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Implementation Details -- + + function Is_Valid + (Object : in Wrapper) + return Boolean is + begin + return Object.Void_Ptr /= Null_Pointer; + end Is_Valid; + + + + + -- Color -- + + function RGB_Color + (Light : in Greyscale) + return Color is + begin + case Light is + when 'A' .. 'W' => return Color (fl_enum_rgb_color2 + ((Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First)) * 11)); + when 'X' => return Color (fl_enum_rgb_color2 (255)); + end case; + end RGB_Color; + + + function RGB_Color + (Light : in Color_Component) + return Color is + begin + return Color (fl_enum_rgb_color2 (Interfaces.C.unsigned_char (Light))); + end RGB_Color; + + + function RGB_Color + (R, G, B : in Color_Component) + return Color is + begin + return Color (fl_enum_rgb_color + (Interfaces.C.unsigned_char (R), + Interfaces.C.unsigned_char (G), + Interfaces.C.unsigned_char (B))); + end RGB_Color; + + + function Color_Cube + (R, G, B : in Color_Component) + return Color is + begin + return Color (fl_enum_color_cube + (Interfaces.C.int (Float'Rounding (Float (R) * Float (fl_enum_num_red - 1) / 255.0)), + Interfaces.C.int (Float'Rounding (Float (G) * Float (fl_enum_num_green - 1) / 255.0)), + Interfaces.C.int (Float'Rounding (Float (B) * Float (fl_enum_num_blue - 1) / 255.0)))); + end Color_Cube; + + + function Grey_Ramp + (Light : in Greyscale) + return Color is + begin + return Color (fl_enum_gray_ramp (Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First))); + end Grey_Ramp; + + + function Grey_Ramp + (Light : in Color_Component) + return Color is + begin + return Color (fl_enum_gray_ramp (Interfaces.C.int + (Float'Rounding (Float (Light) * Float (fl_enum_num_gray - 1) / 255.0)))); + end Grey_Ramp; + + + function Darker + (Tone : in Color) + return Color is + begin + return Color (fl_enum_darker (Interfaces.C.unsigned (Tone))); + end Darker; + + + function Lighter + (Tone : in Color) + return Color is + begin + return Color (fl_enum_lighter (Interfaces.C.unsigned (Tone))); + end Lighter; + + + function Contrast + (Fore, Back : in Color) + return Color is + begin + return Color (fl_enum_contrast + (Interfaces.C.unsigned (Fore), + Interfaces.C.unsigned (Back))); + end Contrast; + + + function Inactive + (Tone : in Color) + return Color is + begin + return Color (fl_enum_inactive (Interfaces.C.unsigned (Tone))); + end Inactive; + + + function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color is + begin + return Color (fl_enum_color_average + (Interfaces.C.unsigned (Tone1), + Interfaces.C.unsigned (Tone2), + Interfaces.C.C_float (Weight))); + end Color_Average; + + + + + -- Alignment -- + + function "+" + (Left, Right : in Alignment) + return Alignment is + begin + return Left or Right; + end "+"; + + + function "-" + (Left, Right : in Alignment) + return Alignment is + begin + return Left and not Right; + end "-"; + + + + + -- Keyboard and Mouse Input -- + + function Press + (Key : in Pressable_Key) + return Keypress is + begin + return Character'Pos (Key); + end Press; + + + function Press + (Key : Pressable_Key) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Mod_None; + This.Keycode := Character'Pos (Key); + This.Mousecode := No_Button; + end return; + end Press; + + + function Press + (Key : in Keypress) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Mod_None; + This.Keycode := Key; + This.Mousecode := No_Button; + end return; + end Press; + + + function Press + (Key : in Mouse_Button) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Mod_None; + This.Keycode := 0; + This.Mousecode := Key; + end return; + end Press; + + + + + function "+" + (Left, Right : in Modifier) + return Modifier is + begin + return Left or Right; + end "+"; + + + function "+" + (Left : in Modifier; + Right : in Pressable_Key) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Left; + This.Keycode := Character'Pos (Right); + This.Mousecode := No_Button; + end return; + end "+"; + + + function "+" + (Left : in Modifier; + Right : in Keypress) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Left; + This.Keycode := Right; + This.Mousecode := No_Button; + end return; + end "+"; + + + function "+" + (Left : in Modifier; + Right : in Mouse_Button) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Left; + This.Keycode := 0; + This.Mousecode := Right; + end return; + end "+"; + + + function "+" + (Left : in Modifier; + Right : in Key_Combo) + return Key_Combo is + begin + return This : Key_Combo do + This.Modcode := Left or Right.Modcode; + This.Keycode := Right.Keycode; + This.Mousecode := Right.Mousecode; + end return; + end "+"; + + + + + function To_C + (Key : in Key_Combo) + return Interfaces.C.unsigned is + begin + return To_C (Key.Modcode) + To_C (Key.Keycode) + To_C (Key.Mousecode); + end To_C; + + + function To_Ada + (Key : in Interfaces.C.unsigned) + return Key_Combo is + begin + return Result : Key_Combo do + Result.Modcode := To_Ada (Key); + Result.Keycode := To_Ada (Key); + Result.Mousecode := To_Ada (Key); + end return; + end To_Ada; + + + function To_C + (Key : in Keypress) + return Interfaces.C.unsigned is + begin + return Interfaces.C.unsigned (Key); + end To_C; + + + function To_Ada + (Key : in Interfaces.C.unsigned) + return Keypress is + begin + return Keypress (Key mod 65536); + end To_Ada; + + + function To_C + (Modi : in Modifier) + return Interfaces.C.unsigned is + begin + return Interfaces.C.unsigned (Modi) * 65536; + end To_C; + + + function To_Ada + (Modi : in Interfaces.C.unsigned) + return Modifier is + begin + return Modifier ((Modi / 65536) mod 256); + end To_Ada; + + + function To_C + (Button : in Mouse_Button) + return Interfaces.C.unsigned is + begin + case Button is + when No_Button => return 0; + when Left_Button => return fl_enum_button1; + when Middle_Button => return fl_enum_button2; + when Right_Button => return fl_enum_button3; + when Back_Button => return fl_enum_button4; + when Forward_Button => return fl_enum_button5; + when Any_Button => return fl_enum_buttons; + end case; + end To_C; + + + function To_Ada + (Button : in Interfaces.C.unsigned) + return Mouse_Button is + begin + if Button = 0 then + return No_Button; + elsif Button = fl_enum_button1 then + return Left_Button; + elsif Button = fl_enum_button2 then + return Middle_Button; + elsif Button = fl_enum_button3 then + return Right_Button; + elsif Button = fl_enum_button4 then + return Back_Button; + elsif Button = fl_enum_button5 then + return Forward_Button; + elsif Button = fl_enum_buttons then + return Any_Button; + else + raise Constraint_Error; + end if; + end To_Ada; + + + + + -- Box Types -- + + function Filled + (Box : in Box_Kind) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_enum_box (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_box in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Filled; + + + function Frame + (Box : in Box_Kind) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_enum_frame (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_frame in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Frame; + + + function Down + (Box : in Box_Kind) + return Box_Kind + is + Result : constant Interfaces.C.int := fl_enum_down (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_down in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Down; + + + + + -- Callback Flags -- + + type Callback_Bitmask is mod 2 ** Interfaces.C.unsigned_char'Size; + + function CFlag_To_Bits is new + Ada.Unchecked_Conversion (Callback_Flag, Callback_Bitmask); + + function Bits_To_CFlag is new + Ada.Unchecked_Conversion (Callback_Bitmask, Callback_Flag); + + + function "+" + (Left, Right : in Callback_Flag) + return Callback_Flag is + begin + return Bits_To_CFlag (CFlag_To_Bits (Left) or CFlag_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Callback_Flag) + return Callback_Flag is + begin + return Bits_To_CFlag (CFlag_To_Bits (Left) and not CFlag_To_Bits (Right)); + end "-"; + + + + + -- Menu Flags -- + + type Menu_Bitmask is mod 2 ** Interfaces.C.int'Size; + + function MFlag_To_Bits is new + Ada.Unchecked_Conversion (Menu_Flag, Menu_Bitmask); + + function Bits_To_MFlag is new + Ada.Unchecked_Conversion (Menu_Bitmask, Menu_Flag); + + + function "+" + (Left, Right : in Menu_Flag) + return Menu_Flag is + begin + return Bits_To_MFlag (MFlag_To_Bits (Left) or MFlag_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Menu_Flag) + return Menu_Flag is + begin + return Bits_To_MFlag (MFlag_To_Bits (Left) and not MFlag_To_Bits (Right)); + end "-"; + + + + + -- Damage Bits -- + + type Damage_Bitmask is mod 2 ** Interfaces.C.unsigned_char'Size; + + function Damage_To_Bits is new + Ada.Unchecked_Conversion (Damage_Mask, Damage_Bitmask); + + function Bits_To_Damage is new + Ada.Unchecked_Conversion (Damage_Bitmask, Damage_Mask); + + + function "+" + (Left, Right : in Damage_Mask) + return Damage_Mask is + begin + return Bits_To_Damage (Damage_To_Bits (Left) or Damage_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Damage_Mask) + return Damage_Mask is + begin + return Bits_To_Damage (Damage_To_Bits (Left) and not Damage_To_Bits (Right)); + end "-"; + + + + + -- Versioning -- + + function ABI_Check + (ABI_Ver : in Version_Number) + return Boolean is + begin + return fl_abi_check (Interfaces.C.int (ABI_Ver)) /= 0; + end ABI_Check; + + + function ABI_Version + return Version_Number is + begin + return Version_Number (fl_abi_version); + end ABI_Version; + + + function API_Version + return Version_Number is + begin + return Version_Number (fl_api_version); + end API_Version; + + + function Version + return Version_Number is + begin + return Version_Number (fl_version); + end Version; + + + + + -- Event Loop -- + + procedure Check + is + Ignore : Interfaces.C.int := fl_check; + begin + null; + end Check; + + + function Check + return Boolean is + begin + return fl_check /= 0; + end Check; + + + function Ready + return Boolean is + begin + return fl_ready /= 0; + end Ready; + + + function Wait + return Integer is + begin + return Integer (fl_wait); + end Wait; + + + function Wait + (Seconds : in Long_Float) + return Long_Float is + begin + return Long_Float (fl_wait2 (Interfaces.C.double (Seconds))); + end Wait; + + + function Run + return Integer is + begin + return Integer (fl_run); + end Run; + + +end FLTK; + + |