1 files changed, 270 insertions, 0 deletions
diff --git a/body/fltk-images-rgb.adb b/body/fltk-images-rgb.adb
new file mode 100644
index 0000000..19a7952
--- /dev/null
+++ b/body/fltk-images-rgb.adb
@@ -0,0 +1,270 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Interfaces.C;
+
+
+package body FLTK.Images.RGB is
+
+
+    function new_fl_rgb_image
+           (Data       : in Storage.Integer_Address;
+            W, H, D, L : in Interfaces.C.int)
+        return Storage.Integer_Address;
+    pragma Import (C, new_fl_rgb_image, "new_fl_rgb_image");
+    pragma Inline (new_fl_rgb_image);
+
+    function new_fl_rgb_image2
+           (P : in Storage.Integer_Address;
+            C : in Interfaces.C.unsigned)
+        return Storage.Integer_Address;
+    pragma Import (C, new_fl_rgb_image2, "new_fl_rgb_image2");
+    pragma Inline (new_fl_rgb_image2);
+
+    procedure free_fl_rgb_image
+           (I : in Storage.Integer_Address);
+    pragma Import (C, free_fl_rgb_image, "free_fl_rgb_image");
+    pragma Inline (free_fl_rgb_image);
+
+    function fl_rgb_image_get_max_size
+        return Interfaces.C.size_t;
+    pragma Import (C, fl_rgb_image_get_max_size, "fl_rgb_image_get_max_size");
+    pragma Inline (fl_rgb_image_get_max_size);
+
+    procedure fl_rgb_image_set_max_size
+           (V : in Interfaces.C.size_t);
+    pragma Import (C, fl_rgb_image_set_max_size, "fl_rgb_image_set_max_size");
+    pragma Inline (fl_rgb_image_set_max_size);
+
+    function fl_rgb_image_copy
+           (I    : in Storage.Integer_Address;
+            W, H : in Interfaces.C.int)
+        return Storage.Integer_Address;
+    pragma Import (C, fl_rgb_image_copy, "fl_rgb_image_copy");
+    pragma Inline (fl_rgb_image_copy);
+
+    function fl_rgb_image_copy2
+           (I : in Storage.Integer_Address)
+        return Storage.Integer_Address;
+    pragma Import (C, fl_rgb_image_copy2, "fl_rgb_image_copy2");
+    pragma Inline (fl_rgb_image_copy2);
+
+
+
+
+    procedure fl_rgb_image_color_average
+           (I : in Storage.Integer_Address;
+            C : in Interfaces.C.int;
+            B : in Interfaces.C.C_float);
+    pragma Import (C, fl_rgb_image_color_average, "fl_rgb_image_color_average");
+    pragma Inline (fl_rgb_image_color_average);
+
+    procedure fl_rgb_image_desaturate
+           (I : in Storage.Integer_Address);
+    pragma Import (C, fl_rgb_image_desaturate, "fl_rgb_image_desaturate");
+    pragma Inline (fl_rgb_image_desaturate);
+
+
+
+
+    procedure fl_rgb_image_uncache
+           (I : in Storage.Integer_Address);
+    pragma Import (C, fl_rgb_image_uncache, "fl_rgb_image_uncache");
+    pragma Inline (fl_rgb_image_uncache);
+
+
+
+
+    procedure fl_rgb_image_draw2
+           (I    : in Storage.Integer_Address;
+            X, Y : in Interfaces.C.int);
+    pragma Import (C, fl_rgb_image_draw2, "fl_rgb_image_draw2");
+    pragma Inline (fl_rgb_image_draw2);
+
+    procedure fl_rgb_image_draw
+           (I                  : in Storage.Integer_Address;
+            X, Y, W, H, CX, CY : in Interfaces.C.int);
+    pragma Import (C, fl_rgb_image_draw, "fl_rgb_image_draw");
+    pragma Inline (fl_rgb_image_draw);
+
+
+
+
+    overriding procedure Finalize
+           (This : in out RGB_Image) is
+    begin
+        if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then
+            free_fl_rgb_image (This.Void_Ptr);
+            This.Void_Ptr := Null_Pointer;
+        end if;
+    end Finalize;
+
+
+
+
+    --------------------
+    --  Construction  --
+    --------------------
+
+    package body Forge is
+
+        function Create
+               (Data          : in Color_Component_Array;
+                Width, Height : in Natural;
+                Depth         : in Natural := 3;
+                Line_Data     : in Natural := 0)
+            return RGB_Image is
+        begin
+            return This : RGB_Image do
+                This.Void_Ptr := new_fl_rgb_image
+                   (Storage.To_Integer (Data (Data'First)'Address),
+                    Interfaces.C.int (Width),
+                    Interfaces.C.int (Height),
+                    Interfaces.C.int (Depth),
+                    Interfaces.C.int (Line_Data));
+                case fl_image_fail (This.Void_Ptr) is
+                    when 1 => raise No_Image_Error;
+                    when 2 => raise File_Access_Error;
+                    when 3 => raise Format_Error;
+                    when others => null;
+                end case;
+            end return;
+        end Create;
+
+        function Create
+               (Data       : in FLTK.Images.Pixmaps.Pixmap'Class;
+                Background : in Color := Background_Color)
+            return RGB_Image is
+        begin
+            return This : RGB_Image do
+                This.Void_Ptr := new_fl_rgb_image2
+                   (Wrapper (Data).Void_Ptr,
+                    Interfaces.C.unsigned (Background));
+                case fl_image_fail (This.Void_Ptr) is
+                    when 1 => raise No_Image_Error;
+                    when 2 => raise File_Access_Error;
+                    when 3 => raise Format_Error;
+                    when others => null;
+                end case;
+            end return;
+        end Create;
+
+    end Forge;
+
+
+    function Get_Max_Size
+        return Natural is
+    begin
+        return Natural (fl_rgb_image_get_max_size);
+    end Get_Max_Size;
+
+
+    procedure Set_Max_Size
+           (Value : in Natural) is
+    begin
+        fl_rgb_image_set_max_size (Interfaces.C.size_t (Value));
+    end Set_Max_Size;
+
+
+    function Copy
+           (This          : in RGB_Image;
+            Width, Height : in Natural)
+        return RGB_Image'Class is
+    begin
+        return Copied : RGB_Image do
+            Copied.Void_Ptr := fl_rgb_image_copy
+                   (This.Void_Ptr,
+                    Interfaces.C.int (Width),
+                    Interfaces.C.int (Height));
+        end return;
+    end Copy;
+
+
+    function Copy
+           (This : in RGB_Image)
+        return RGB_Image'Class is
+    begin
+        return Copied : RGB_Image do
+            Copied.Void_Ptr := fl_rgb_image_copy2 (This.Void_Ptr);
+        end return;
+    end Copy;
+
+
+
+
+    --------------
+    --  Colors  --
+    --------------
+
+    procedure Color_Average
+           (This   : in out RGB_Image;
+            Col    : in     Color;
+            Amount : in     Blend) is
+    begin
+        fl_rgb_image_color_average
+           (This.Void_Ptr,
+            Interfaces.C.int (Col),
+            Interfaces.C.C_float (Amount));
+    end Color_Average;
+
+
+    procedure Desaturate
+           (This : in out RGB_Image) is
+    begin
+        fl_rgb_image_desaturate (This.Void_Ptr);
+    end Desaturate;
+
+
+
+
+    ----------------
+    --  Activity  --
+    ----------------
+
+    procedure Uncache
+           (This : in out RGB_Image) is
+    begin
+        fl_rgb_image_uncache (This.Void_Ptr);
+    end Uncache;
+
+
+
+
+    ---------------
+    --  Drawing  --
+    ---------------
+
+    procedure Draw
+           (This : in RGB_Image;
+            X, Y : in Integer) is
+    begin
+        fl_rgb_image_draw2
+           (This.Void_Ptr,
+            Interfaces.C.int (X),
+            Interfaces.C.int (Y));
+    end Draw;
+
+
+    procedure Draw
+           (This       : in RGB_Image;
+            X, Y, W, H : in Integer;
+            CX, CY     : in Integer := 0) is
+    begin
+        fl_rgb_image_draw
+           (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.RGB;
+