1 files changed, 99 insertions, 0 deletions
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;
+
+