From fbec75e5847cace1edd5b10e16176f1fba18f969 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Wed, 21 Feb 2024 18:48:49 +1300 Subject: Fl_Tiled_Image binding added --- src/c_fl_tiled_image.cpp | 60 ++++++++++++ src/c_fl_tiled_image.h | 34 +++++++ src/fltk-images-tiled.adb | 233 ++++++++++++++++++++++++++++++++++++++++++++++ src/fltk-images-tiled.ads | 112 ++++++++++++++++++++++ src/fltk-images.adb | 4 +- 5 files changed, 442 insertions(+), 1 deletion(-) create mode 100644 src/c_fl_tiled_image.cpp create mode 100644 src/c_fl_tiled_image.h create mode 100644 src/fltk-images-tiled.adb create mode 100644 src/fltk-images-tiled.ads (limited to 'src') diff --git a/src/c_fl_tiled_image.cpp b/src/c_fl_tiled_image.cpp new file mode 100644 index 0000000..8d7ecde --- /dev/null +++ b/src/c_fl_tiled_image.cpp @@ -0,0 +1,60 @@ + + +#include +#include +#include "c_fl_tiled_image.h" + + + + +TILED_IMAGE new_fl_tiled_image(void * i, int w, int h) { + Fl_Tiled_Image *t = new Fl_Tiled_Image(reinterpret_cast(i), w, h); + return t; +} + +void free_fl_tiled_image(TILED_IMAGE t) { + delete reinterpret_cast(t); +} + +TILED_IMAGE fl_tiled_image_copy(TILED_IMAGE t, int w, int h) { + // virtual so disable dispatch + return reinterpret_cast(t)->Fl_Tiled_Image::copy(w, h); +} + +TILED_IMAGE fl_tiled_image_copy2(TILED_IMAGE t) { + return reinterpret_cast(t)->copy(); +} + + + + +void * fl_tiled_image_get_image(TILED_IMAGE t) { + return reinterpret_cast(t)->image(); +} + + + + +void fl_tiled_image_color_average(TILED_IMAGE t, int c, float b) { + // virtual so disable dispatch + reinterpret_cast(t)->Fl_Tiled_Image::color_average(c, b); +} + +void fl_tiled_image_desaturate(TILED_IMAGE t) { + // virtual so disable dispatch + reinterpret_cast(t)->Fl_Tiled_Image::desaturate(); +} + + + + +void fl_tiled_image_draw(TILED_IMAGE t, int x, int y) { + reinterpret_cast(t)->draw(x, y); +} + +void fl_tiled_image_draw2(TILED_IMAGE t, int x, int y, int w, int h, int cx, int cy) { + // virtual so disable dispatch + reinterpret_cast(t)->Fl_Tiled_Image::draw(x, y, w, h, cx, cy); +} + + diff --git a/src/c_fl_tiled_image.h b/src/c_fl_tiled_image.h new file mode 100644 index 0000000..12b1c1e --- /dev/null +++ b/src/c_fl_tiled_image.h @@ -0,0 +1,34 @@ + + +#ifndef FL_TILED_IMAGE_GUARD +#define FL_TILED_IMAGE_GUARD + + + + +typedef void* TILED_IMAGE; + + + + +extern "C" TILED_IMAGE new_fl_tiled_image(void * i, int w, int h); +extern "C" void free_fl_tiled_image(TILED_IMAGE t); +extern "C" TILED_IMAGE fl_tiled_image_copy(TILED_IMAGE t, int w, int h); +extern "C" TILED_IMAGE fl_tiled_image_copy2(TILED_IMAGE t); + + + + +extern "C" void * fl_tiled_image_get_image(TILED_IMAGE t); + + +extern "C" void fl_tiled_image_color_average(TILED_IMAGE t, int c, float b); +extern "C" void fl_tiled_image_desaturate(TILED_IMAGE t); + + +extern "C" void fl_tiled_image_draw(TILED_IMAGE t, int x, int y); +extern "C" void fl_tiled_image_draw2(TILED_IMAGE t, int x, int y, int w, int h, int cx, int cy); + + +#endif + diff --git a/src/fltk-images-tiled.adb b/src/fltk-images-tiled.adb new file mode 100644 index 0000000..fd4b9ed --- /dev/null +++ b/src/fltk-images-tiled.adb @@ -0,0 +1,233 @@ + + +with + + Interfaces.C, + System; + +use type + + System.Address; + + +package body FLTK.Images.Tiled is + + + function new_fl_tiled_image + (T : in System.Address; + W, H : in Interfaces.C.int) + return System.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 System.Address); + pragma Import (C, free_fl_tiled_image, "free_fl_tiled_image"); + pragma Inline (free_fl_tiled_image); + + function fl_tiled_image_copy + (T : in System.Address; + W, H : in Interfaces.C.int) + return System.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 System.Address) + return System.Address; + pragma Import (C, fl_tiled_image_copy2, "fl_tiled_image_copy2"); + pragma Inline (fl_tiled_image_copy2); + + + + + function fl_tiled_image_get_image + (T : in System.Address) + return System.Address; + pragma Import (C, fl_tiled_image_get_image, "fl_tiled_image_get_image"); + pragma Inline (fl_tiled_image_get_image); + + + + + procedure fl_tiled_image_color_average + (T : in System.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 System.Address); + pragma Import (C, fl_tiled_image_desaturate, "fl_tiled_image_desaturate"); + pragma Inline (fl_tiled_image_desaturate); + + + + + procedure fl_tiled_image_draw + (T : in System.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 System.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); + + + + + overriding procedure Finalize + (This : in out Tiled_Image) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in Tiled_Image'Class + then + free_fl_tiled_image (This.Void_Ptr); + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Image (This)); + end Finalize; + + + + + -------------------- + -- Construction -- + -------------------- + + 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; + + + 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; + + + + + 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; + CX, CY : 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 (CX), + Interfaces.C.int (CY)); + end Draw; + + +end FLTK.Images.Tiled; + diff --git a/src/fltk-images-tiled.ads b/src/fltk-images-tiled.ads new file mode 100644 index 0000000..cf3ee13 --- /dev/null +++ b/src/fltk-images-tiled.ads @@ -0,0 +1,112 @@ + + +package FLTK.Images.Tiled is + + + ------------- + -- Types -- + ------------- + + type Tiled_Image is new Image with private; + + type Tiled_Image_Reference (Data : not null access Tiled_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + -------------------- + -- Construction -- + -------------------- + + package Forge is + + function Create + (From : in out Image'Class; + W, H : in Integer := 0) + return Tiled_Image; + + end Forge; + + function Copy + (This : in Tiled_Image; + Width, Height : in Natural) + return Tiled_Image'Class; + + function Copy + (This : in Tiled_Image) + return Tiled_Image'Class; + + + + + --------------------- + -- Miscellaneous -- + --------------------- + + procedure Inactive + (This : in out Tiled_Image); + + function Tile + (This : in out Tiled_Image) + return Image_Reference; + + + + + -------------- + -- Colors -- + -------------- + + procedure Color_Average + (This : in out Tiled_Image; + Hue : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out Tiled_Image); + + + + + --------------- + -- Drawing -- + --------------- + + procedure Draw + (This : in Tiled_Image; + X, Y : in Integer); + + procedure Draw + (This : in Tiled_Image; + X, Y, W, H : in Integer; + CX, CY : in Integer); + + +private + + + type Tiled_Image is new Image with record + Dummy : aliased Image; + end record; + + overriding procedure Finalize + (This : in out Tiled_Image); + + + pragma Inline (Copy); + + + pragma Inline (Inactive); + pragma Inline (Tile); + + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + + pragma Inline (Draw); + + +end FLTK.Images.Tiled; + diff --git a/src/fltk-images.adb b/src/fltk-images.adb index b8dff24..f86071e 100644 --- a/src/fltk-images.adb +++ b/src/fltk-images.adb @@ -165,7 +165,9 @@ package body FLTK.Images is if This.Void_Ptr /= System.Null_Address and then This in Image'Class then - free_fl_image (This.Void_Ptr); + if This.Needs_Dealloc then + free_fl_image (This.Void_Ptr); + end if; This.Void_Ptr := System.Null_Address; end if; end Finalize; -- cgit