diff options
Diffstat (limited to 'body/fltk-images-pixmaps.adb')
| -rw-r--r-- | body/fltk-images-pixmaps.adb | 116 |
1 files changed, 103 insertions, 13 deletions
diff --git a/body/fltk-images-pixmaps.adb b/body/fltk-images-pixmaps.adb index 2e66d2f..b6164c8 100644 --- a/body/fltk-images-pixmaps.adb +++ b/body/fltk-images-pixmaps.adb @@ -6,12 +6,25 @@ with - Interfaces.C; + Ada.Strings.Fixed, + Ada.Strings.Unbounded, + Ada.Unchecked_Deallocation, + Interfaces.C.Strings; package body FLTK.Images.Pixmaps is + ------------------------ + -- Functions From C -- + ------------------------ + + function new_fl_pixmap + (D : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_pixmap, "new_fl_pixmap"); + pragma Inline (new_fl_pixmap); + procedure free_fl_pixmap (I : in Storage.Integer_Address); pragma Import (C, free_fl_pixmap, "free_fl_pixmap"); @@ -71,10 +84,25 @@ 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; free_fl_pixmap (This.Void_Ptr); This.Void_Ptr := Null_Pointer; end if; @@ -84,9 +112,77 @@ package body FLTK.Images.Pixmaps is -------------------- - -- Construction -- + -- Constructors -- -------------------- + 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))); + 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 + end return; + end Create; + + end Forge; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Copy (This : in Pixmap; Width, Height : in Natural) @@ -113,9 +209,7 @@ package body FLTK.Images.Pixmaps is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Pixmap; @@ -138,9 +232,7 @@ package body FLTK.Images.Pixmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Pixmap) is @@ -151,9 +243,7 @@ package body FLTK.Images.Pixmaps is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Pixmap; @@ -167,9 +257,9 @@ package body FLTK.Images.Pixmaps is procedure Draw - (This : in Pixmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_pixmap_draw (This.Void_Ptr, @@ -177,8 +267,8 @@ package body FLTK.Images.Pixmaps is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; |