Fl_Tiled_Image binding added

5 files changed, 442 insertions, 1 deletions

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 <FL/Fl_Tiled_Image.H>
+#include <FL/Fl_Image.H>
+#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<Fl_Image*>(i), w, h);
+    return t;
+}
+
+void free_fl_tiled_image(TILED_IMAGE t) {
+    delete reinterpret_cast<Fl_Tiled_Image*>(t);
+}
+
+TILED_IMAGE fl_tiled_image_copy(TILED_IMAGE t, int w, int h) {
+    //  virtual so disable dispatch
+    return reinterpret_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::copy(w, h);
+}
+
+TILED_IMAGE fl_tiled_image_copy2(TILED_IMAGE t) {
+    return reinterpret_cast<Fl_Tiled_Image*>(t)->copy();
+}
+
+
+
+
+void * fl_tiled_image_get_image(TILED_IMAGE t) {
+    return reinterpret_cast<Fl_Tiled_Image*>(t)->image();
+}
+
+
+
+
+void fl_tiled_image_color_average(TILED_IMAGE t, int c, float b) {
+    //  virtual so disable dispatch
+    reinterpret_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::color_average(c, b);
+}
+
+void fl_tiled_image_desaturate(TILED_IMAGE t) {
+    //  virtual so disable dispatch
+    reinterpret_cast<Fl_Tiled_Image*>(t)->Fl_Tiled_Image::desaturate();
+}
+
+
+
+
+void fl_tiled_image_draw(TILED_IMAGE t, int x, int y) {
+    reinterpret_cast<Fl_Tiled_Image*>(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<Fl_Tiled_Image*>(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;