From 24c57b72a3a8edb92d2861cd8c88bb81bd936ae9 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Mon, 19 Mar 2018 22:01:34 +1100 Subject: Added FLTK.Widgets.Groups.Tiled --- progress.txt | 2 +- src/c_fl_tile.cpp | 77 +++++++++++++++++++++ src/c_fl_tile.h | 32 +++++++++ src/fltk-widgets-groups-tiled.adb | 137 ++++++++++++++++++++++++++++++++++++++ src/fltk-widgets-groups-tiled.ads | 50 ++++++++++++++ 5 files changed, 297 insertions(+), 1 deletion(-) create mode 100644 src/c_fl_tile.cpp create mode 100644 src/c_fl_tile.h create mode 100644 src/fltk-widgets-groups-tiled.adb create mode 100644 src/fltk-widgets-groups-tiled.ads diff --git a/progress.txt b/progress.txt index 99247b3..d757afa 100644 --- a/progress.txt +++ b/progress.txt @@ -40,6 +40,7 @@ FLTK.Widgets.Groups.Scrolls FLTK.Widgets.Groups.Spinners FLTK.Widgets.Groups.Tabbed FLTK.Widgets.Groups.Text_Displays.Text_Editors +FLTK.Widgets.Groups.Tiled FLTK.Widgets.Groups.Windows.Double FLTK.Widgets.Groups.Windows.Single FLTK.Widgets.Groups.Windows.Single.Menu @@ -109,7 +110,6 @@ FL_Help_View (several methods have ABI_VERSION bugs) FL_Pack FL_Table FL_Table_Row -FL_Tile FL_Tree diff --git a/src/c_fl_tile.cpp b/src/c_fl_tile.cpp new file mode 100644 index 0000000..32dc7a0 --- /dev/null +++ b/src/c_fl_tile.cpp @@ -0,0 +1,77 @@ + + +#include +#include "c_fl_tile.h" +#include "c_fl_type.h" + + + + +class My_Tile : public Fl_Tile { + public: + using Fl_Tile::Fl_Tile; + friend void tile_set_draw_hook(TILE n, void * d); + friend void fl_tile_draw(TILE n); + friend void tile_set_handle_hook(TILE n, void * h); + friend int fl_tile_handle(TILE 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_Tile::draw() { + (*draw_hook)(this->user_data()); +} + +void My_Tile::real_draw() { + Fl_Tile::draw(); +} + +int My_Tile::handle(int e) { + return (*handle_hook)(this->user_data(), e); +} + +int My_Tile::real_handle(int e) { + return Fl_Tile::handle(e); +} + +void tile_set_draw_hook(TILE n, void * d) { + reinterpret_cast(n)->draw_hook = reinterpret_cast(d); +} + +void fl_tile_draw(TILE n) { + reinterpret_cast(n)->real_draw(); +} + +void tile_set_handle_hook(TILE n, void * h) { + reinterpret_cast(n)->handle_hook = reinterpret_cast(h); +} + +int fl_tile_handle(TILE n, int e) { + return reinterpret_cast(n)->real_handle(e); +} + + + + +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) { + delete reinterpret_cast(t); +} + + + + +void fl_tile_position(TILE t, int ox, int oy, int nx, int ny) { + reinterpret_cast(t)->position(ox,oy,nx,ny); +} + + diff --git a/src/c_fl_tile.h b/src/c_fl_tile.h new file mode 100644 index 0000000..b87e806 --- /dev/null +++ b/src/c_fl_tile.h @@ -0,0 +1,32 @@ + + +#ifndef FL_TILE_GUARD +#define FL_TILE_GUARD + + + + +typedef void* TILE; + + + + +extern "C" void tile_set_draw_hook(TILE n, void * d); +extern "C" void fl_tile_draw(TILE n); +extern "C" void tile_set_handle_hook(TILE n, void * h); +extern "C" int fl_tile_handle(TILE n, int e); + + + + +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); + + +#endif + diff --git a/src/fltk-widgets-groups-tiled.adb b/src/fltk-widgets-groups-tiled.adb new file mode 100644 index 0000000..ee19ea0 --- /dev/null +++ b/src/fltk-widgets-groups-tiled.adb @@ -0,0 +1,137 @@ + + +with + + Interfaces.C, + System; + +use type + + System.Address; + + +package body FLTK.Widgets.Groups.Tiled is + + + procedure tile_set_draw_hook + (W, D : in System.Address); + pragma Import (C, tile_set_draw_hook, "tile_set_draw_hook"); + + procedure tile_set_handle_hook + (W, H : in System.Address); + pragma Import (C, tile_set_handle_hook, "tile_set_handle_hook"); + + + + + function new_fl_tile + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return System.Address; + pragma Import (C, new_fl_tile, "new_fl_tile"); + + procedure free_fl_tile + (B : in System.Address); + pragma Import (C, free_fl_tile, "free_fl_tile"); + + + + + procedure fl_tile_position + (T : in System.Address; + OX, OY, NX, NY : in Interfaces.C.int); + pragma Import (C, fl_tile_position, "fl_tile_position"); + + + + + procedure fl_tile_draw + (W : in System.Address); + pragma Import (C, fl_tile_draw, "fl_tile_draw"); + + function fl_tile_handle + (W : in System.Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_tile_handle, "fl_tile_handle"); + + + + + procedure Finalize + (This : in out Tiled_Group) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in Tiled_Group'Class + then + This.Clear; + free_fl_tile (This.Void_Ptr); + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Group (This)); + end Finalize; + + + + + 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)); + fl_group_end (This.Void_Ptr); + fl_widget_set_user_data + (This.Void_Ptr, + Widget_Convert.To_Address (This'Unchecked_Access)); + tile_set_draw_hook (This.Void_Ptr, Draw_Hook'Address); + tile_set_handle_hook (This.Void_Ptr, Handle_Hook'Address); + end return; + end Create; + + end Forge; + + + + + 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 Draw + (This : in out Tiled_Group) is + begin + fl_tile_draw (This.Void_Ptr); + end Draw; + + + function Handle + (This : in out Tiled_Group; + Event : in Event_Kind) + return Event_Outcome is + begin + return Event_Outcome'Val + (fl_tile_handle (This.Void_Ptr, Event_Kind'Pos (Event))); + end Handle; + + +end FLTK.Widgets.Groups.Tiled; + diff --git a/src/fltk-widgets-groups-tiled.ads b/src/fltk-widgets-groups-tiled.ads new file mode 100644 index 0000000..89e2c82 --- /dev/null +++ b/src/fltk-widgets-groups-tiled.ads @@ -0,0 +1,50 @@ + + +package FLTK.Widgets.Groups.Tiled is + + + type Tiled_Group is new Group with private; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String) + return Tiled_Group; + + end Forge; + + + + + procedure Position + (This : in out Tiled_Group; + Old_X, Old_Y : in Integer; + New_X, New_Y : in Integer); + + + + + procedure Draw + (This : in out Tiled_Group); + + function Handle + (This : in out Tiled_Group; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Tiled_Group is new Group with null record; + + overriding procedure Finalize + (This : in out Tiled_Group); + + +end FLTK.Widgets.Groups.Tiled; + -- cgit