Fl_Tiled_Image binding added

author: Jedidiah Barber <contact@jedbarber.id.au> 2024-02-21 18:48:49 +1300
committer: Jedidiah Barber <contact@jedbarber.id.au> 2024-02-21 18:48:49 +1300
commit: fbec75e5847cace1edd5b10e16176f1fba18f969 (patch)
tree: ba196482bd0e7572e1ed9c442070554fa01c5691
parent: c5b296567825c48d3658d62f01ec770449379e85 (diff)
8 files changed, 594 insertions, 4 deletions
diff --git a/doc/fl_tiled_image.html b/doc/fl_tiled_image.html
new file mode 100644
index 0000000..7cbc7ad
--- /dev/null
+++ b/doc/fl_tiled_image.html
@@ -0,0 +1,148 @@
+
+<!DOCTYPE html>
+
+<html lang="en">
+  <head>
+    <meta charset="utf-8">
+    <title>Fl_Tiled_Image Binding Map</title>
+    <link href="map.css" rel="stylesheet">
+  </head>
+
+  <body>
+
+
+<h2>Fl_Tiled_Image Binding Map</h2>
+
+
+<a href="index.html">Back to Index</a>
+
+
+<table class="package">
+  <tr><th colspan="2">Package name</th></tr>
+
+  <tr>
+    <td>Fl_Tiled_Image</td>
+    <td>FLTK.Images.Tiled</td>
+  </tr>
+
+</table>
+
+
+
+<table class="type">
+  <tr><th colspan="2">Types</th></tr>
+
+  <tr>
+    <td>Fl_Tiled_Image</td>
+    <td>Tiled_Image</td>
+  </tr>
+
+  <tr>
+    <td>&nbsp;</td>
+    <td>Tiled_Image_Reference</td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Functions and Procedures</th></tr>
+
+  <tr>
+<td><pre>
+Fl_Tiled_Image(Fl_Image *i, int W=0, int H=0);
+</pre></td>
+<td><pre>
+function Create
+       (From : in out Image'Class;
+        W, H : in     Integer := 0)
+    return Tiled_Image;
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+virtual void color_average(Fl_Color c, float i);
+</pre></td>
+<td><pre>
+procedure Color_Average
+       (This   : in out Tiled_Image;
+        Hue    : in     Color;
+        Amount : in     Blend);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+Fl_Image * copy();
+</pre></td>
+<td><pre>
+function Copy
+       (This : in Tiled_Image)
+    return Tiled_Image'Class;
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+virtual Fl_Image * copy(int W, int H);
+</pre></td>
+<td><pre>
+function Copy
+       (This          : in Tiled_Image;
+        Width, Height : in Natural)
+    return Tiled_Image'Class;
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+virtual void desaturate();
+</pre></td>
+<td><pre>
+procedure Desaturate
+       (This : in out Tiled_Image);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+void draw(int X, int Y);
+</pre></td>
+<td><pre>
+procedure Draw
+       (This : in Tiled_Image;
+        X, Y : in Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+virtual void draw(int X, int Y, int W, int H, int cx, int cy);
+</pre></td>
+<td><pre>
+procedure Draw
+       (This       : in Tiled_Image;
+        X, Y, W, H : in Integer;
+        CX, CY     : in Integer);
+</pre></td>
+  </tr>
+
+  <tr>
+<td><pre>
+Fl_Image * image();
+</pre></td>
+<td><pre>
+function Tile
+       (This : in out Tiled_Image)
+    return Image_Reference;
+</pre></td>
+  </tr>
+
+</table>
+
+
+  </body>
+</html>
+
diff --git a/doc/index.html b/doc/index.html
index 75d659f..f729db2 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -116,7 +116,7 @@
   <li><a href="fl_text_display.html">Fl_Text_Display</a></li>
   <li><a href="fl_text_editor.html">Fl_Text_Editor</a></li>
   <li><a href="fl_tile.html">Fl_Tile</a></li>
-  <li>Fl_Tiled_Image</li>
+  <li><a href="fl_tiled_image.html">Fl_Tiled_Image</a></li>
   <li><a href="fl_toggle_button.html">Fl_Toggle_Button</a></li>
   <li><a href="fl_tooltip.html">Fl_Tooltip</a></li>
   <li>Fl_Tree</li>
@@ -159,6 +159,7 @@
   <li><a href="fl_png_image.html">FLTK.Images.RGB.PNG</a></li>
   <li><a href="fl_pnm_image.html">FLTK.Images.RGB.PNM</a></li>
   <li><a href="fl_shared_image.html">FLTK.Images.Shared</a></li>
+  <li><a href="fl_tiled_image.html">FLTK.Images.Tiled</a></li>
   <li><a href="fl_menu_item.html">FLTK.Menu_Items</a></li>
   <li><a href="fl.html">FLTK.Screen</a></li>
   <li><a href="fl.html">FLTK.Static</a></li>
diff --git a/progress.txt b/progress.txt
index 6ca018c..1cfb0be 100644
--- a/progress.txt
+++ b/progress.txt
@@ -5,7 +5,7 @@ Approximate Progress List
 
 
 
-Overall estimate: 81%
+Overall estimate: 82%
 
 
 
@@ -41,6 +41,7 @@ FLTK.Images.RGB.JPEG
 FLTK.Images.RGB.PNG
 FLTK.Images.RGB.PNM
 FLTK.Images.Shared
+FLTK.Images.Tiled
 FLTK.Menu_Items
 FLTK.Screen
 FLTK.Static
@@ -148,7 +149,6 @@ Fl_Postscript_File_Device
 Fl_Select_Browser
 Fl_Table
 Fl_Table_Row
-Fl_Tiled_Image
 Fl_Tree
 
 
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;
author	Jedidiah Barber <contact@jedbarber.id.au>	2024-02-21 18:48:49 +1300
committer	Jedidiah Barber <contact@jedbarber.id.au>	2024-02-21 18:48:49 +1300
commit	fbec75e5847cace1edd5b10e16176f1fba18f969 (patch)
tree	ba196482bd0e7572e1ed9c442070554fa01c5691
parent	c5b296567825c48d3658d62f01ec770449379e85 (diff)