Filled holes in FLTK.Draw API, refactored Pixmap data marshalling

6 files changed, 270 insertions, 65 deletions

diff --git a/body/c_fl_draw.cpp b/body/c_fl_draw.cpp
index ddf17b0..25d7796 100644
--- a/body/c_fl_draw.cpp
+++ b/body/c_fl_draw.cpp
@@ -216,6 +216,10 @@ void fl_draw_draw_image_mono2(void * func, void * data, int x, int y, int w, int
     fl_draw_image_mono(reinterpret_cast<Fl_Draw_Image_Cb>(func), data, x, y, w, h, d);
 }
 
+int fl_draw_draw_pixmap(void * data, int x, int y, unsigned int h) {
+    return fl_draw_pixmap(static_cast<char * const *>(data), x, y, static_cast<Fl_Color>(h));
+}
+
 void * fl_draw_read_image(void * data, int x, int y, int w, int h, int alpha) {
     return fl_read_image(static_cast<uchar*>(data), x, y, w, h, alpha);
 }
@@ -280,6 +284,12 @@ void fl_draw_text_extents(const char * t, int n, int &dx, int &dy, int &w, int &
     fl_text_extents(t, n, dx, dy, w, h);
 }
 
+const char * fl_draw_expand_text(const char * str, char * &buf, int maxbuf,
+    double maxw, int &n, double &width, int wrap, int symbol)
+{
+    return fl_expand_text(str, buf, maxbuf, maxw, n, width, wrap, symbol);
+}
+
 double fl_draw_width(const char *txt, int n) {
     return fl_width(txt, n);
 }
diff --git a/body/c_fl_draw.h b/body/c_fl_draw.h
index ae3419f..cd1a16d 100644
--- a/body/c_fl_draw.h
+++ b/body/c_fl_draw.h
@@ -68,6 +68,7 @@ extern "C" void fl_draw_draw_image(void * data, int x, int y, int w, int h, int
 extern "C" void fl_draw_draw_image2(void * func, void * data, int x, int y, int w, int h, int d);
 extern "C" void fl_draw_draw_image_mono(void * data, int x, int y, int w, int h, int d, int l);
 extern "C" void fl_draw_draw_image_mono2(void * func, void * data, int x, int y, int w, int h, int d);
+extern "C" int fl_draw_draw_pixmap(void * data, int x, int y, unsigned int h);
 extern "C" void * fl_draw_read_image(void * data, int x, int y, int w, int h, int alpha);
 
 
@@ -85,6 +86,8 @@ extern "C" void fl_draw_measure(const char * str, int &w, int &h, int draw_symbo
 extern "C" void fl_draw_scroll(int x, int y, int w, int h, int dx, int dy,
                                void * func, void * data);
 extern "C" void fl_draw_text_extents(const char * t, int n, int &dx, int &dy, int &w, int &h);
+extern "C" const char * fl_draw_expand_text(const char * str, char * &buf, int maxbuf,
+    double maxw, int &n, double &width, int wrap, int symbol);
 extern "C" double fl_draw_width(const char *txt, int n);
 extern "C" double fl_draw_width2(unsigned long c);
 
diff --git a/body/fltk-draw.adb b/body/fltk-draw.adb
index a98edae..c71599d 100644
--- a/body/fltk-draw.adb
+++ b/body/fltk-draw.adb
@@ -8,6 +8,8 @@ with
 
     Ada.Assertions,
     Ada.Unchecked_Deallocation,
+    FLTK.Pixmap_Marshal,
+    Interfaces.C.Pointers,
     Interfaces.C.Strings;
 
 use type
@@ -21,6 +23,13 @@ package body FLTK.Draw is
 
     package Chk renames Ada.Assertions;
 
+    --  Oh no... Anyway, this is just used for Expand_Text.
+    package Char_Pointers is new Interfaces.C.Pointers
+       (Index              => Interfaces.C.size_t,
+        Element            => Interfaces.C.char,
+        Element_Array      => Interfaces.C.char_array,
+        Default_Terminator => Interfaces.C.nul);
+
 
 
 
@@ -302,6 +311,14 @@ package body FLTK.Draw is
     pragma Import (C, fl_draw_draw_image_mono2, "fl_draw_draw_image_mono2");
     pragma Inline (fl_draw_draw_image_mono2);
 
+    function fl_draw_draw_pixmap
+           (Data : in Storage.Integer_Address;
+            X, Y : in Interfaces.C.int;
+            H    : in Interfaces.C.unsigned)
+        return Interfaces.C.int;
+    pragma Import (C, fl_draw_draw_pixmap, "fl_draw_draw_pixmap");
+    pragma Inline (fl_draw_draw_pixmap);
+
     function fl_draw_read_image
            (Buf        : in Storage.Integer_Address;
             X, Y, W, H : in Interfaces.C.int;
@@ -395,6 +412,19 @@ package body FLTK.Draw is
     pragma Import (C, fl_draw_text_extents, "fl_draw_text_extents");
     pragma Inline (fl_draw_text_extents);
 
+    --  This function in particular is such bullshit.
+    function fl_draw_expand_text
+           (Str       : in     Interfaces.C.char_array;
+            Buf       :    out Interfaces.C.Strings.chars_ptr;
+            Max_Buf   : in     Interfaces.C.int;
+            Max_W     : in     Interfaces.C.double;
+            N         :    out Interfaces.C.int;
+            Width     :    out Interfaces.C.double;
+            Wrap, Sym : in     Interfaces.C.int)
+        return Char_Pointers.Pointer;
+    pragma Import (C, fl_draw_expand_text, "fl_draw_expand_text");
+    pragma Inline (fl_draw_expand_text);
+
     function fl_draw_width
            (Str : in Interfaces.C.char_array;
             N   : in Interfaces.C.int)
@@ -1122,6 +1152,13 @@ package body FLTK.Draw is
     procedure Draw_Image_Hook
            (User    : in Storage.Integer_Address;
             X, Y, W : in Interfaces.C.int;
+            Buf_Ptr : in Storage.Integer_Address);
+
+    pragma Convention (C, Draw_Image_Hook);
+
+    procedure Draw_Image_Hook
+           (User    : in Storage.Integer_Address;
+            X, Y, W : in Interfaces.C.int;
             Buf_Ptr : in Storage.Integer_Address)
     is
         Data_Buffer : Color_Component_Array (1 .. Integer (W));
@@ -1185,6 +1222,13 @@ package body FLTK.Draw is
     procedure Draw_Image_Mono_Hook
            (User    : in Storage.Integer_Address;
             X, Y, W : in Interfaces.C.int;
+            Buf_Ptr : in Storage.Integer_Address);
+
+    pragma Convention (C, Draw_Image_Mono_Hook);
+
+    procedure Draw_Image_Mono_Hook
+           (User    : in Storage.Integer_Address;
+            X, Y, W : in Interfaces.C.int;
             Buf_Ptr : in Storage.Integer_Address)
     is
         Data_Buffer : Color_Component_Array (1 .. Integer (W));
@@ -1211,6 +1255,30 @@ package body FLTK.Draw is
     end Draw_Image_Mono;
 
 
+    procedure Draw_Pixmap
+           (Values : in FLTK.Images.Pixmaps.Header;
+            Colors : in FLTK.Images.Pixmaps.Color_Definition_Array;
+            Pixels : in FLTK.Images.Pixmaps.Pixmap_Data;
+            X, Y   : in Integer;
+            Hue    : in Color := Grey0_Color)
+    is
+        C_Data : Pixmap_Marshal.chars_ptr_array_access :=
+            Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels);
+        Result : Interfaces.C.int := fl_draw_draw_pixmap
+           (Storage.To_Integer (C_Data (C_Data'First)'Address),
+            Interfaces.C.int (X),
+            Interfaces.C.int (Y),
+            Interfaces.C.unsigned (Hue));
+    begin
+        pragma Assert (Result /= 0);
+        Pixmap_Marshal.Free_Recursive (C_Data);
+    exception
+    when Chk.Assertion_Error =>
+        Pixmap_Marshal.Free_Recursive (C_Data);
+        raise Draw_Error with "fl_draw_pixmap could not decode supplied XPM pixmap data";
+    end Draw_Pixmap;
+
+
     function Read_Image
            (X, Y, W, H : in Integer;
             Alpha      : in Integer := 0)
@@ -1316,6 +1384,12 @@ package body FLTK.Draw is
 
     procedure Draw_Text_Hook
            (Ptr       : in Storage.Integer_Address;
+            N, X0, Y0 : in Interfaces.C.int);
+
+    pragma Convention (C, Draw_Text_Hook);
+
+    procedure Draw_Text_Hook
+           (Ptr       : in Storage.Integer_Address;
             N, X0, Y0 : in Interfaces.C.int)
     is
         Data : String (1 .. Integer (N));
@@ -1325,7 +1399,6 @@ package body FLTK.Draw is
         Text_Func_Ptr (Integer (X0), Integer (Y0), Data);
     end Draw_Text_Hook;
 
-
     procedure Draw_Text
            (X, Y, W, H : in Integer;
             Text       : in String;
@@ -1454,13 +1527,23 @@ package body FLTK.Draw is
 
 
     procedure Scroll_Hook
-           (Ptr        : in Area_Draw_Function;
-            X, Y, W, H : in Interfaces.C.int) is
+           (Ptr        : in Storage.Integer_Address;
+            X, Y, W, H : in Interfaces.C.int);
+
+    pragma Convention (C, Scroll_Hook);
+
+    procedure Scroll_Hook
+           (Ptr        : in Storage.Integer_Address;
+            X, Y, W, H : in Interfaces.C.int)
+    is
+        procedure my_area_draw
+               (X, Y, W, H : in Integer);
+        for my_area_draw'Address use Storage.To_Address (Ptr);
+        pragma Import (Ada, my_area_draw);
     begin
-        Ptr.all (Integer (X), Integer (Y), Integer (W), Integer (H));
+        my_area_draw (Integer (X), Integer (Y), Integer (W), Integer (H));
     end Scroll_Hook;
 
-
     procedure Scroll
            (X, Y, W, H : in Integer;
             DX, DY     : in Integer;
@@ -1498,6 +1581,32 @@ package body FLTK.Draw is
     end Text_Extents;
 
 
+    function Expand_Text
+           (Text      : in     String;
+            Max_Width : in     Long_Float;
+            Width     :    out Long_Float;
+            Last      :    out Natural;
+            Wrap      : in     Boolean;
+            Symbols   : in     Boolean := False)
+        return String
+    is
+        Buffer : Interfaces.C.Strings.chars_ptr;
+        Length : Interfaces.C.int;
+        Temp   : Interfaces.C.char_array := Interfaces.C.To_C (Text);
+        Result : Char_Pointers.Pointer := fl_draw_expand_text
+           (Temp, Buffer, 0,
+            Interfaces.C.double (Max_Width),
+            Length,
+            Interfaces.C.double (Width),
+            Boolean'Pos (Wrap),
+            Boolean'Pos (Symbols));
+        use type Char_Pointers.Pointer;
+    begin
+        Last := Natural (Result - Temp (Temp'First)'Unchecked_Access);
+        return Interfaces.C.Strings.Value (Buffer, Interfaces.C.size_t (Length));
+    end Expand_Text;
+
+
     function Width
            (Text : in String)
         return Long_Float is
diff --git a/body/fltk-images-pixmaps.adb b/body/fltk-images-pixmaps.adb
index b6164c8..b5d47a7 100644
--- a/body/fltk-images-pixmaps.adb
+++ b/body/fltk-images-pixmaps.adb
@@ -6,9 +6,7 @@
 
 with
 
-    Ada.Strings.Fixed,
-    Ada.Strings.Unbounded,
-    Ada.Unchecked_Deallocation,
+    FLTK.Pixmap_Marshal,
     Interfaces.C.Strings;
 
 
@@ -88,21 +86,11 @@ package body FLTK.Images.Pixmaps is
     --  Destructors  --
     -------------------
 
-    type chars_ptr_array_access is access all Interfaces.C.Strings.chars_ptr_array;
-
-    procedure Free is new Ada.Unchecked_Deallocation
-        (Interfaces.C.Strings.chars_ptr_array, chars_ptr_array_access);
-
     overriding procedure Finalize
            (This : in out Pixmap) is
     begin
         if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then
-            if This.Loose_Ptr /= null then
-                for Item of This.Loose_Ptr.all loop
-                    Interfaces.C.Strings.Free (Item);
-                end loop;
-                Free (This.Loose_Ptr);
-            end if;
+            Pixmap_Marshal.Free_Recursive (This.Loose_Ptr);
             free_fl_pixmap (This.Void_Ptr);
             This.Void_Ptr := Null_Pointer;
         end if;
@@ -117,58 +105,16 @@ package body FLTK.Images.Pixmaps is
 
     package body Forge is
 
-        function To_Coltype
-               (Value : in Color_Kind)
-            return Character is
-        begin
-            case Value is
-            when Colorful   => return 'c';
-            when Monochrome => return 'm';
-            when Greyscale  => return 'g';
-            when Symbolic   => return 's';
-            end case;
-        end To_Coltype;
-
-
         function Create
                (Values : in Header;
                 Colors : in Color_Definition_Array;
                 Pixels : in Pixmap_Data)
-            return Pixmap
-        is
-            use Interfaces.C.Strings;
-            C_Data : access chars_ptr_array := new chars_ptr_array
-                (1 .. Interfaces.C.size_t (1 + Colors'Length + Pixels'Length (1)));
+            return Pixmap is
         begin
-            --  Header values line
-            C_Data (1) := New_String (Ada.Strings.Fixed.Trim
-               ((Positive'Image (Values.Width)  & Positive'Image (Values.Height) &
-                 Positive'Image (Values.Colors) & Positive'Image (Values.Per_Pixel)),
-                Ada.Strings.Left));
-
-            --  Color definition lines
-            for Place in 1 .. Colors'Length loop
-                C_Data (Interfaces.C.size_t (Place + 1)) := New_String
-                   (Ada.Strings.Unbounded.To_String (Colors (Colors'First + Place - 1).Name) & " " &
-                    To_Coltype (Colors (Colors'First + Place - 1).Kind) & " " &
-                    Ada.Strings.Unbounded.To_String (Colors (Colors'First + Place - 1).Value));
-            end loop;
-
-            --  Pixel data lines
-            for Place in 1 .. Pixels'Length (1) loop
-                declare
-                    Line : String (1 .. Pixels'Length (2));
-                    for Line'Address use Pixels (Pixels'First (1) + Place - 1, 1)'Address;
-                    pragma Import (Ada, Line);
-                begin
-                    C_Data (Interfaces.C.size_t (Place + 1 + Colors'Length)) := New_String (Line);
-                end;
-            end loop;
-
-            --  Pass it all off to C++ to actually create the cursed thing
             return This : Pixmap do
-                This.Void_Ptr := new_fl_pixmap (Storage.To_Integer (C_Data (C_Data'First)'Address));
-                This.Loose_Ptr := C_Data;  --  Much easier to save this for later
+                This.Loose_Ptr := Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels);
+                This.Void_Ptr := new_fl_pixmap
+                    (Storage.To_Integer (This.Loose_Ptr (This.Loose_Ptr'First)'Address));
             end return;
         end Create;
 
diff --git a/body/fltk-pixmap_marshal.adb b/body/fltk-pixmap_marshal.adb
new file mode 100644
index 0000000..768cd08
--- /dev/null
+++ b/body/fltk-pixmap_marshal.adb
@@ -0,0 +1,99 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Ada.Strings.Fixed,
+    Ada.Strings.Unbounded,
+    Ada.Unchecked_Deallocation,
+    FLTK.Images.Pixmaps,
+    Interfaces.C.Strings;
+
+
+package body FLTK.Pixmap_Marshal is
+
+
+    package SU  renames Ada.Strings.Unbounded;
+    package Pix renames FLTK.Images.Pixmaps;
+    package C   renames Interfaces.C;
+    package CS  renames Interfaces.C.Strings;
+
+
+
+
+    function To_Coltype
+           (Value : in Pix.Color_Kind)
+        return Character is
+    begin
+        case Value is
+        when Pix.Colorful   => return 'c';
+        when Pix.Monochrome => return 'm';
+        when Pix.Greyscale  => return 'g';
+        when Pix.Symbolic   => return 's';
+        end case;
+    end To_Coltype;
+
+
+
+
+    function Marshal_Data
+           (Values : in Pix.Header;
+            Colors : in Pix.Color_Definition_Array;
+            Pixels : in Pix.Pixmap_Data)
+        return chars_ptr_array_access
+    is
+        C_Data : chars_ptr_array_access := new CS.chars_ptr_array
+            (1 .. C.size_t (1 + Colors'Length + Pixels'Length (1)));
+    begin
+        --  Header values line
+        C_Data (1) := CS.New_String (Ada.Strings.Fixed.Trim
+           ((Positive'Image (Values.Width)  & Positive'Image (Values.Height) &
+             Positive'Image (Values.Colors) & Positive'Image (Values.Per_Pixel)),
+            Ada.Strings.Left));
+
+        --  Color definition lines
+        for Place in 1 .. Colors'Length loop
+            C_Data (C.size_t (Place + 1)) := CS.New_String
+               (SU.To_String (Colors (Colors'First + Place - 1).Name) & " " &
+                To_Coltype   (Colors (Colors'First + Place - 1).Kind) & " " &
+                SU.To_String (Colors (Colors'First + Place - 1).Value));
+        end loop;
+
+        --  Pixel data lines
+        for Place in 1 .. Pixels'Length (1) loop
+            declare
+                Line : String (1 .. Pixels'Length (2));
+                for Line'Address use Pixels (Pixels'First (1) + Place - 1, 1)'Address;
+                pragma Import (Ada, Line);
+            begin
+                C_Data (C.size_t (Place + 1 + Colors'Length)) := CS.New_String (Line);
+            end;
+        end loop;
+
+        return C_Data;
+    end Marshal_Data;
+
+
+
+
+    procedure Free is new Ada.Unchecked_Deallocation
+        (Interfaces.C.Strings.chars_ptr_array, chars_ptr_array_access);
+
+    procedure Free_Recursive
+           (This : in out chars_ptr_array_access) is
+    begin
+        if This /= null then
+            for Item of This.all loop
+                CS.Free (Item);
+            end loop;
+            Free (This);
+        end if;
+    end Free_Recursive;
+
+
+end FLTK.Pixmap_Marshal;
+
+
diff --git a/body/fltk-pixmap_marshal.ads b/body/fltk-pixmap_marshal.ads
new file mode 100644
index 0000000..c74e0eb
--- /dev/null
+++ b/body/fltk-pixmap_marshal.ads
@@ -0,0 +1,38 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+limited with
+
+    FLTK.Images.Pixmaps;
+
+with
+
+    Interfaces.C.Strings;
+
+
+private package FLTK.Pixmap_Marshal is
+
+
+    type chars_ptr_array_access is access all Interfaces.C.Strings.chars_ptr_array;
+
+
+    function To_Coltype
+           (Value : in FLTK.Images.Pixmaps.Color_Kind)
+        return Character;
+
+    function Marshal_Data
+           (Values : in FLTK.Images.Pixmaps.Header;
+            Colors : in FLTK.Images.Pixmaps.Color_Definition_Array;
+            Pixels : in FLTK.Images.Pixmaps.Pixmap_Data)
+        return chars_ptr_array_access;
+
+    procedure Free_Recursive
+           (This : in out chars_ptr_array_access);
+
+
+end FLTK.Pixmap_Marshal;
+
+