From 2cbec01126c34e70fc8e11d77553ef5bfd94cec7 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Fri, 18 May 2018 16:21:25 +1000 Subject: Added Choices, Pixmaps, GIFs, XPMs --- src/c_fl_choice.cpp | 85 +++++++++++++++++ src/c_fl_choice.h | 34 +++++++ src/c_fl_gif_image.cpp | 17 ++++ src/c_fl_gif_image.h | 19 ++++ src/c_fl_menu.cpp | 8 ++ src/c_fl_menu.h | 2 + src/c_fl_pixmap.cpp | 44 +++++++++ src/c_fl_pixmap.h | 28 ++++++ src/c_fl_xpm_image.cpp | 17 ++++ src/c_fl_xpm_image.h | 19 ++++ src/fltk-images-pixmaps-gif.adb | 71 +++++++++++++++ src/fltk-images-pixmaps-gif.ads | 33 +++++++ src/fltk-images-pixmaps-xpm.adb | 71 +++++++++++++++ src/fltk-images-pixmaps-xpm.ads | 33 +++++++ src/fltk-images-pixmaps.adb | 157 ++++++++++++++++++++++++++++++++ src/fltk-images-pixmaps.ads | 67 ++++++++++++++ src/fltk-widgets-menus-choices.adb | 182 +++++++++++++++++++++++++++++++++++++ src/fltk-widgets-menus-choices.ads | 75 +++++++++++++++ src/fltk-widgets-menus.adb | 33 +++++++ src/fltk-widgets-menus.ads | 9 ++ 20 files changed, 1004 insertions(+) create mode 100644 src/c_fl_choice.cpp create mode 100644 src/c_fl_choice.h create mode 100644 src/c_fl_gif_image.cpp create mode 100644 src/c_fl_gif_image.h create mode 100644 src/c_fl_pixmap.cpp create mode 100644 src/c_fl_pixmap.h create mode 100644 src/c_fl_xpm_image.cpp create mode 100644 src/c_fl_xpm_image.h create mode 100644 src/fltk-images-pixmaps-gif.adb create mode 100644 src/fltk-images-pixmaps-gif.ads create mode 100644 src/fltk-images-pixmaps-xpm.adb create mode 100644 src/fltk-images-pixmaps-xpm.ads create mode 100644 src/fltk-images-pixmaps.adb create mode 100644 src/fltk-images-pixmaps.ads create mode 100644 src/fltk-widgets-menus-choices.adb create mode 100644 src/fltk-widgets-menus-choices.ads (limited to 'src') diff --git a/src/c_fl_choice.cpp b/src/c_fl_choice.cpp new file mode 100644 index 0000000..f45ceed --- /dev/null +++ b/src/c_fl_choice.cpp @@ -0,0 +1,85 @@ + + +#include +#include "c_fl_choice.h" +#include "c_fl_type.h" + + + + +class My_Choice : public Fl_Choice { + public: + using Fl_Choice::Fl_Choice; + friend void choice_set_draw_hook(CHOICE n, void * d); + friend void fl_choice_draw(CHOICE n); + friend void choice_set_handle_hook(CHOICE n, void * h); + friend int fl_choice_handle(CHOICE n, int e); + protected: + void draw(); + void real_draw(); + int handle(int e); + int real_handle(int e); + d_hook_p draw_hook; + h_hook_p handle_hook; +}; + +void My_Choice::draw() { + (*draw_hook)(this->user_data()); +} + +void My_Choice::real_draw() { + Fl_Choice::draw(); +} + +int My_Choice::handle(int e) { + return (*handle_hook)(this->user_data(), e); +} + +int My_Choice::real_handle(int e) { + return Fl_Choice::handle(e); +} + +void choice_set_draw_hook(CHOICE n, void * d) { + reinterpret_cast(n)->draw_hook = reinterpret_cast(d); +} + +void fl_choice_draw(CHOICE n) { + reinterpret_cast(n)->real_draw(); +} + +void choice_set_handle_hook(CHOICE n, void * h) { + reinterpret_cast(n)->handle_hook = reinterpret_cast(h); +} + +int fl_choice_handle(CHOICE n, int e) { + return reinterpret_cast(n)->real_handle(e); +} + + + + +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) { + delete reinterpret_cast(b); +} + + + + +int fl_choice_value(CHOICE c) { + return reinterpret_cast(c)->value(); +} + +int fl_choice_set_value(CHOICE c, int p) { + return reinterpret_cast(c)->value(p); +} + +int fl_choice_set_value2(CHOICE c, void * i) { + return reinterpret_cast(c)->value(reinterpret_cast(i)); +} + + diff --git a/src/c_fl_choice.h b/src/c_fl_choice.h new file mode 100644 index 0000000..05515bb --- /dev/null +++ b/src/c_fl_choice.h @@ -0,0 +1,34 @@ + + +#ifndef FL_CHOICE_GUARD +#define FL_CHOICE_GUARD + + + + +typedef void* CHOICE; + + + + +extern "C" void choice_set_draw_hook(CHOICE n, void * d); +extern "C" void fl_choice_draw(CHOICE n); +extern "C" void choice_set_handle_hook(CHOICE n, void * h); +extern "C" int fl_choice_handle(CHOICE n, int e); + + + + +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, int p); +extern "C" int fl_choice_set_value2(CHOICE c, void * i); + + +#endif + diff --git a/src/c_fl_gif_image.cpp b/src/c_fl_gif_image.cpp new file mode 100644 index 0000000..ad923bd --- /dev/null +++ b/src/c_fl_gif_image.cpp @@ -0,0 +1,17 @@ + + +#include +#include "c_fl_gif_image.h" + + + + +GIF_IMAGE new_fl_gif_image(const char * f) { + Fl_GIF_Image *j = new Fl_GIF_Image(f); + return j; +} + +void free_fl_gif_image(GIF_IMAGE j) { + delete reinterpret_cast(j); +} + diff --git a/src/c_fl_gif_image.h b/src/c_fl_gif_image.h new file mode 100644 index 0000000..c193ca0 --- /dev/null +++ b/src/c_fl_gif_image.h @@ -0,0 +1,19 @@ + + +#ifndef FL_GIF_IMAGE_GUARD +#define FL_GIF_IMAGE_GUARD + + + + +typedef void* GIF_IMAGE; + + + + +extern "C" GIF_IMAGE new_fl_gif_image(const char * f); +extern "C" void free_fl_gif_image(GIF_IMAGE j); + + +#endif + diff --git a/src/c_fl_menu.cpp b/src/c_fl_menu.cpp index 411efde..3a4fa8f 100644 --- a/src/c_fl_menu.cpp +++ b/src/c_fl_menu.cpp @@ -125,6 +125,14 @@ int fl_menu_value(MENU m) { return reinterpret_cast(m)->value(); } +int fl_menu_set_value(MENU m, int p) { + return reinterpret_cast(m)->value(p); +} + +int fl_menu_set_value2(MENU m, void * i) { + return reinterpret_cast(m)->value(reinterpret_cast(i)); +} + diff --git a/src/c_fl_menu.h b/src/c_fl_menu.h index 79f64a8..7babca2 100644 --- a/src/c_fl_menu.h +++ b/src/c_fl_menu.h @@ -41,6 +41,8 @@ extern "C" int fl_menu_size(MENU m); extern "C" const void * fl_menu_mvalue(MENU m); 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, int p); +extern "C" int fl_menu_set_value2(MENU m, void * i); extern "C" unsigned int fl_menu_get_textcolor(MENU m); diff --git a/src/c_fl_pixmap.cpp b/src/c_fl_pixmap.cpp new file mode 100644 index 0000000..18e6b5d --- /dev/null +++ b/src/c_fl_pixmap.cpp @@ -0,0 +1,44 @@ + + +#include +#include "c_fl_pixmap.h" + + + + +void free_fl_pixmap(PIXMAP b) { + delete reinterpret_cast(b); +} + +PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h) { + return reinterpret_cast(b)->Fl_Pixmap::copy(w, h); +} + +PIXMAP fl_pixmap_copy2(PIXMAP b) { + return reinterpret_cast(b)->copy(); +} + + + + +void fl_pixmap_color_average(PIXMAP p, int c, float b) { + // virtual so disable dispatch + reinterpret_cast(p)->Fl_Pixmap::color_average(c, b); +} + +void fl_pixmap_desaturate(PIXMAP p) { + // virtual so disable dispatch + reinterpret_cast(p)->Fl_Pixmap::desaturate(); +} + + + + +void fl_pixmap_draw2(PIXMAP b, int x, int y) { + reinterpret_cast(b)->draw(x, y); +} + +void fl_pixmap_draw(PIXMAP b, int x, int y, int w, int h, int cx, int cy) { + reinterpret_cast(b)->Fl_Pixmap::draw(x, y, w, h, cx, cy); +} + diff --git a/src/c_fl_pixmap.h b/src/c_fl_pixmap.h new file mode 100644 index 0000000..de987a8 --- /dev/null +++ b/src/c_fl_pixmap.h @@ -0,0 +1,28 @@ + + +#ifndef FL_PIXMAP_GUARD +#define FL_PIXMAP_GUARD + + + + +typedef void* PIXMAP; + + + + +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_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/src/c_fl_xpm_image.cpp b/src/c_fl_xpm_image.cpp new file mode 100644 index 0000000..dae1c12 --- /dev/null +++ b/src/c_fl_xpm_image.cpp @@ -0,0 +1,17 @@ + + +#include +#include "c_fl_xpm_image.h" + + + + +XPM_IMAGE new_fl_xpm_image(const char * f) { + Fl_XPM_Image *j = new Fl_XPM_Image(f); + return j; +} + +void free_fl_xpm_image(XPM_IMAGE j) { + delete reinterpret_cast(j); +} + diff --git a/src/c_fl_xpm_image.h b/src/c_fl_xpm_image.h new file mode 100644 index 0000000..3d01e61 --- /dev/null +++ b/src/c_fl_xpm_image.h @@ -0,0 +1,19 @@ + + +#ifndef FL_XPM_IMAGE_GUARD +#define FL_XPM_IMAGE_GUARD + + + + +typedef void* XPM_IMAGE; + + + + +extern "C" XPM_IMAGE new_fl_xpm_image(const char * f); +extern "C" void free_fl_xpm_image(XPM_IMAGE j); + + +#endif + diff --git a/src/fltk-images-pixmaps-gif.adb b/src/fltk-images-pixmaps-gif.adb new file mode 100644 index 0000000..579d8b7 --- /dev/null +++ b/src/fltk-images-pixmaps-gif.adb @@ -0,0 +1,71 @@ + + +with + + Interfaces.C, + System; + +use type + + System.Address; + + +package body FLTK.Images.Pixmaps.GIF is + + + function new_fl_gif_image + (F : in Interfaces.C.char_array) + return System.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 System.Address); + pragma Import (C, free_fl_gif_image, "free_fl_gif_image"); + pragma Inline (free_fl_gif_image); + + + + + overriding procedure Finalize + (This : in out GIF_Image) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in GIF_Image'Class + then + free_fl_gif_image (This.Void_Ptr); + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Pixmap (This)); + end Finalize; + + + + + 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)); + case fl_image_fail (This.Void_Ptr) is + when 1 => + raise No_Image_Error; + when 2 => + raise File_Access_Error; + when 3 => + raise Format_Error; + when others => + null; + end case; + end return; + end Create; + + end Forge; + + +end FLTK.Images.Pixmaps.GIF; + diff --git a/src/fltk-images-pixmaps-gif.ads b/src/fltk-images-pixmaps-gif.ads new file mode 100644 index 0000000..18e31b9 --- /dev/null +++ b/src/fltk-images-pixmaps-gif.ads @@ -0,0 +1,33 @@ + + +package FLTK.Images.Pixmaps.GIF is + + + type GIF_Image is new Pixmap with private; + + type GIF_Image_Reference (Data : not null access GIF_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return GIF_Image; + + end Forge; + + +private + + + type GIF_Image is new Pixmap with null record; + + overriding procedure Finalize + (This : in out GIF_Image); + + +end FLTK.Images.Pixmaps.GIF; + diff --git a/src/fltk-images-pixmaps-xpm.adb b/src/fltk-images-pixmaps-xpm.adb new file mode 100644 index 0000000..36c4180 --- /dev/null +++ b/src/fltk-images-pixmaps-xpm.adb @@ -0,0 +1,71 @@ + + +with + + Interfaces.C, + System; + +use type + + System.Address; + + +package body FLTK.Images.Pixmaps.XPM is + + + function new_fl_xpm_image + (F : in Interfaces.C.char_array) + return System.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 System.Address); + pragma Import (C, free_fl_xpm_image, "free_fl_xpm_image"); + pragma Inline (free_fl_xpm_image); + + + + + overriding procedure Finalize + (This : in out XPM_Image) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in XPM_Image'Class + then + free_fl_xpm_image (This.Void_Ptr); + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Pixmap (This)); + end Finalize; + + + + + 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)); + case fl_image_fail (This.Void_Ptr) is + when 1 => + raise No_Image_Error; + when 2 => + raise File_Access_Error; + when 3 => + raise Format_Error; + when others => + null; + end case; + end return; + end Create; + + end Forge; + + +end FLTK.Images.Pixmaps.XPM; + diff --git a/src/fltk-images-pixmaps-xpm.ads b/src/fltk-images-pixmaps-xpm.ads new file mode 100644 index 0000000..e888632 --- /dev/null +++ b/src/fltk-images-pixmaps-xpm.ads @@ -0,0 +1,33 @@ + + +package FLTK.Images.Pixmaps.XPM is + + + type XPM_Image is new Pixmap with private; + + type XPM_Image_Reference (Data : not null access XPM_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return XPM_Image; + + end Forge; + + +private + + + type XPM_Image is new Pixmap with null record; + + overriding procedure Finalize + (This : in out XPM_Image); + + +end FLTK.Images.Pixmaps.XPM; + diff --git a/src/fltk-images-pixmaps.adb b/src/fltk-images-pixmaps.adb new file mode 100644 index 0000000..dc77d24 --- /dev/null +++ b/src/fltk-images-pixmaps.adb @@ -0,0 +1,157 @@ + + +with + + Interfaces.C, + System; + +use type + + System.Address; + + +package body FLTK.Images.Pixmaps is + + + procedure free_fl_pixmap + (I : in System.Address); + pragma Import (C, free_fl_pixmap, "free_fl_pixmap"); + pragma Inline (free_fl_pixmap); + + function fl_pixmap_copy + (I : in System.Address; + W, H : in Interfaces.C.int) + return System.Address; + pragma Import (C, fl_pixmap_copy, "fl_pixmap_copy"); + pragma Inline (fl_pixmap_copy); + + function fl_pixmap_copy2 + (I : in System.Address) + return System.Address; + pragma Import (C, fl_pixmap_copy2, "fl_pixmap_copy2"); + pragma Inline (fl_pixmap_copy2); + + + + + procedure fl_pixmap_color_average + (I : in System.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 System.Address); + pragma Import (C, fl_pixmap_desaturate, "fl_pixmap_desaturate"); + pragma Inline (fl_pixmap_desaturate); + + + + + procedure fl_pixmap_draw2 + (I : in System.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 System.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); + + + + + overriding procedure Finalize + (This : in out Pixmap) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in Pixmap'Class + then + free_fl_pixmap (This.Void_Ptr); + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Image (This)); + end Finalize; + + + + + 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; + + + + + 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; + + + + + 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; + CX, CY : 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 (CX), + Interfaces.C.int (CY)); + end Draw; + + +end FLTK.Images.Pixmaps; + diff --git a/src/fltk-images-pixmaps.ads b/src/fltk-images-pixmaps.ads new file mode 100644 index 0000000..b72c382 --- /dev/null +++ b/src/fltk-images-pixmaps.ads @@ -0,0 +1,67 @@ + + +package FLTK.Images.Pixmaps is + + + type Pixmap is new Image with private; + + type Pixmap_Reference (Data : not null access Pixmap'Class) is limited null record + with Implicit_Dereference => Data; + + + + + function Copy + (This : in Pixmap; + Width, Height : in Natural) + return Pixmap'Class; + + function Copy + (This : in Pixmap) + return Pixmap'Class; + + + + + procedure Color_Average + (This : in out Pixmap; + Col : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out Pixmap); + + + + + procedure Draw + (This : in Pixmap; + X, Y : in Integer); + + procedure Draw + (This : in Pixmap; + X, Y, W, H : in Integer; + CX, CY : in Integer := 0); + + +private + + + type Pixmap is new Image with null record; + + overriding procedure Finalize + (This : in out Pixmap); + + + + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + + pragma Inline (Copy); + pragma Inline (Draw); + + +end FLTK.Images.Pixmaps; + diff --git a/src/fltk-widgets-menus-choices.adb b/src/fltk-widgets-menus-choices.adb new file mode 100644 index 0000000..5696bd2 --- /dev/null +++ b/src/fltk-widgets-menus-choices.adb @@ -0,0 +1,182 @@ + + +with + + Interfaces.C, + System; + +use type + + Interfaces.C.int, + System.Address; + + +package body FLTK.Widgets.Menus.Choices is + + + procedure choice_set_draw_hook + (W, D : in System.Address); + pragma Import (C, choice_set_draw_hook, "choice_set_draw_hook"); + pragma Inline (choice_set_draw_hook); + + procedure choice_set_handle_hook + (W, H : in System.Address); + pragma Import (C, choice_set_handle_hook, "choice_set_handle_hook"); + pragma Inline (choice_set_handle_hook); + + + + + function new_fl_choice + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return System.Address; + pragma Import (C, new_fl_choice, "new_fl_choice"); + pragma Inline (new_fl_choice); + + procedure free_fl_choice + (B : in System.Address); + pragma Import (C, free_fl_choice, "free_fl_choice"); + pragma Inline (free_fl_choice); + + + + + function fl_choice_value + (M : in System.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 : in System.Address; + I : in Interfaces.C.int) + 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, I : in System.Address) + return Interfaces.C.int; + pragma Import (C, fl_choice_set_value2, "fl_choice_set_value2"); + pragma Inline (fl_choice_set_value2); + + + + + procedure fl_choice_draw + (W : in System.Address); + pragma Import (C, fl_choice_draw, "fl_choice_draw"); + pragma Inline (fl_choice_draw); + + function fl_choice_handle + (W : in System.Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_choice_handle, "fl_choice_handle"); + pragma Inline (fl_choice_handle); + + + + + procedure Finalize + (This : in out Choice) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in Choice'Class + then + if This.Needs_Dealloc then + free_fl_choice (This.Void_Ptr); + end if; + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Widget (This)); + end Finalize; + + + + + 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)); + fl_widget_set_user_data + (This.Void_Ptr, + Widget_Convert.To_Address (This'Unchecked_Access)); + choice_set_draw_hook (This.Void_Ptr, Draw_Hook'Address); + choice_set_handle_hook (This.Void_Ptr, Handle_Hook'Address); + end return; + end Create; + + end Forge; + + + + + function Chosen + (This : in Choice) + return FLTK.Menu_Items.Menu_Item_Reference is + begin + return (Data => This.My_Items.Element (This.Chosen_Index)); + end Chosen; + + + function Chosen_Index + (This : in Choice) + return Extended_Index is + begin + return Extended_Index (fl_choice_value (This.Void_Ptr) + 1); + end Chosen_Index; + + + procedure Set_Chosen + (This : in out Choice; + Place : in Index) + is + Ignore_Ret : Interfaces.C.int; + begin + Ignore_Ret := fl_choice_set_value (This.Void_Ptr, Interfaces.C.int (Place) - 1); + end Set_Chosen; + + + 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_value2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Chosen; + + + + + procedure Draw + (This : in out Choice) is + begin + fl_choice_draw (This.Void_Ptr); + end Draw; + + + function Handle + (This : in out Choice; + Event : in Event_Kind) + return Event_Outcome is + begin + return Event_Outcome'Val + (fl_choice_handle (This.Void_Ptr, Event_Kind'Pos (Event))); + end Handle; + + +end FLTK.Widgets.Menus.Choices; + diff --git a/src/fltk-widgets-menus-choices.ads b/src/fltk-widgets-menus-choices.ads new file mode 100644 index 0000000..7f99852 --- /dev/null +++ b/src/fltk-widgets-menus-choices.ads @@ -0,0 +1,75 @@ + + +package FLTK.Widgets.Menus.Choices is + + + type Choice is new Menu with private; + + type Choice_Reference (Data : not null access Choice'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String) + return Choice; + + end Forge; + + + + + function Chosen + (This : in Choice) + return FLTK.Menu_Items.Menu_Item_Reference; + + function Chosen_Index + (This : in Choice) + return Extended_Index; + + procedure Set_Chosen + (This : in out Choice; + Place : in Index); + + procedure Set_Chosen + (This : in out Choice; + Item : in FLTK.Menu_Items.Menu_Item); + + + + + procedure Draw + (This : in out Choice); + + function Handle + (This : in out Choice; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Choice is new Menu with null record; + + overriding procedure Finalize + (This : in out Choice); + + + + + pragma Inline (Chosen); + pragma Inline (Chosen_Index); + pragma Inline (Set_Chosen); + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Menus.Choices; + diff --git a/src/fltk-widgets-menus.adb b/src/fltk-widgets-menus.adb index 03333d2..0b652cf 100644 --- a/src/fltk-widgets-menus.adb +++ b/src/fltk-widgets-menus.adb @@ -146,6 +146,19 @@ package body FLTK.Widgets.Menus is pragma Import (C, fl_menu_value, "fl_menu_value"); pragma Inline (fl_menu_value); + function fl_menu_set_value + (M : in System.Address; + I : in Interfaces.C.int) + 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, I : in System.Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_set_value2, "fl_menu_set_value2"); + pragma Inline (fl_menu_set_value2); + @@ -583,6 +596,26 @@ package body FLTK.Widgets.Menus is end Chosen_Index; + procedure Set_Chosen + (This : in out Menu; + Place : in Index) + is + Ignore_Ret : Interfaces.C.int; + begin + Ignore_Ret := fl_menu_set_value (This.Void_Ptr, Interfaces.C.int (Place) - 1); + end Set_Chosen; + + + procedure Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item) + is + Ignore_Ret : Interfaces.C.int; + begin + Ignore_Ret := fl_menu_set_value2 (This.Void_Ptr, Wrapper (Item).Void_Ptr); + end Set_Chosen; + + function Get_Text_Color diff --git a/src/fltk-widgets-menus.ads b/src/fltk-widgets-menus.ads index 95e4528..f756109 100644 --- a/src/fltk-widgets-menus.ads +++ b/src/fltk-widgets-menus.ads @@ -142,6 +142,14 @@ package FLTK.Widgets.Menus is (This : in Menu) return Extended_Index; + procedure Set_Chosen + (This : in out Menu; + Place : in Index); + + procedure Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item); + @@ -294,6 +302,7 @@ private pragma Inline (Chosen); pragma Inline (Chosen_Label); pragma Inline (Chosen_Index); + pragma Inline (Set_Chosen); pragma Inline (Get_Text_Color); -- cgit