diff options
Diffstat (limited to 'body')
| -rw-r--r-- | body/c_fl_table_row.cpp | 129 | ||||
| -rw-r--r-- | body/c_fl_table_row.h | 38 | ||||
| -rw-r--r-- | body/fltk-widgets-groups-tables-row.adb | 372 | ||||
| -rw-r--r-- | body/fltk-widgets-groups-tables.adb | 15 |
4 files changed, 550 insertions, 4 deletions
diff --git a/body/c_fl_table_row.cpp b/body/c_fl_table_row.cpp new file mode 100644 index 0000000..8094df4 --- /dev/null +++ b/body/c_fl_table_row.cpp @@ -0,0 +1,129 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Table_Row.H> +#include "c_fl_table_row.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) { + 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/fltk-widgets-groups-tables-row.adb b/body/fltk-widgets-groups-tables-row.adb new file mode 100644 index 0000000..2063470 --- /dev/null +++ b/body/fltk-widgets-groups-tables-row.adb @@ -0,0 +1,372 @@ + + +-- 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 -- + ------------------------ + + 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); + + + + + 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); + + + + + 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); + + + + + 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; + + + + + 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; + + + + + function Get_Rows + (This : in Row_Table) + return Natural + is + Result : 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; + + + + + function Is_Row_Selected + (This : in Row_Table; + Row : in Positive) + return Boolean + is + Result : 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 : 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 : 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 : 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; + + + + + procedure Cell_Dimensions + (This : in Row_Table; + Context : in Table_Context; + Row, Column : in Positive; + X, Y, W, H : out Integer) + is + Result : 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 index 9e7fd38..30cc642 100644 --- a/body/fltk-widgets-groups-tables.adb +++ b/body/fltk-widgets-groups-tables.adb @@ -824,8 +824,9 @@ package body FLTK.Widgets.Groups.Tables is procedure Initialize (This : in out Table) is begin - This.Draw_Ptr := fl_table_draw'Address; - This.Handle_Ptr := fl_table_handle'Address; + 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; @@ -1804,6 +1805,12 @@ package body FLTK.Widgets.Groups.Tables is 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 @@ -1820,7 +1827,7 @@ package body FLTK.Widgets.Groups.Tables is C_Row := Interfaces.C.int (Row); C_Column := Interfaces.C.int (Column); end case; - fl_table_draw_cell + my_draw_cell (This.Void_Ptr, To_Cint (Context), C_Row, C_Column, @@ -1884,7 +1891,7 @@ package body FLTK.Widgets.Groups.Tables is Interfaces.C.int (H)); begin if Result = -1 then - raise Out_Of_Range_Error with + raise Range_Error with "Row = " & Integer'Image (Row) & ", Column = " & Integer'Image (Column); else pragma Assert (Result = 0); |