From dee76d5884c6f079ea3a2387d07289534a51a0c1 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 28 Jan 2025 21:43:17 +1300 Subject: Revised Image subhierarchy, fixed data subprograms, added constructor for Pixmap --- body/c_fl_bitmap.cpp | 7 ++ body/c_fl_bitmap.h | 3 + body/c_fl_image.cpp | 50 ++++----- body/c_fl_image.h | 9 +- body/c_fl_pixmap.cpp | 8 ++ body/c_fl_pixmap.h | 3 + body/c_fl_png_image.cpp | 1 + body/c_fl_pnm_image.cpp | 1 + body/c_fl_rgb_image.cpp | 7 ++ body/c_fl_rgb_image.h | 3 + body/fltk-images-bitmaps-xbm.adb | 23 ++-- body/fltk-images-bitmaps.adb | 142 +++++++++++++++++++---- body/fltk-images-pixmaps-gif.adb | 18 +-- body/fltk-images-pixmaps-xpm.adb | 18 +-- body/fltk-images-pixmaps.adb | 116 ++++++++++++++++--- body/fltk-images-rgb-bmp.adb | 18 +-- body/fltk-images-rgb-jpeg.adb | 26 ++--- body/fltk-images-rgb-png.adb | 26 ++--- body/fltk-images-rgb-pnm.adb | 18 +-- body/fltk-images-rgb.adb | 140 ++++++++++++++++++----- body/fltk-images-tiled.adb | 31 ++++-- body/fltk-images.adb | 235 ++++++++++++--------------------------- doc/fl_bitmap.html | 48 +++++++- doc/fl_image.html | 78 ++----------- doc/fl_pixmap.html | 45 +++++++- doc/fl_rgb_image.html | 51 ++++++++- doc/fl_tiled_image.html | 6 +- progress.txt | 4 +- spec/fltk-images-bitmaps-xbm.ads | 9 +- spec/fltk-images-bitmaps.ads | 87 ++++++++++++--- spec/fltk-images-pixmaps-gif.ads | 9 +- spec/fltk-images-pixmaps-xpm.ads | 9 +- spec/fltk-images-pixmaps.ads | 75 +++++++++---- spec/fltk-images-rgb-bmp.ads | 9 +- spec/fltk-images-rgb-jpeg.ads | 9 +- spec/fltk-images-rgb-png.ads | 9 +- spec/fltk-images-rgb-pnm.ads | 9 +- spec/fltk-images-rgb.ads | 95 ++++++++++++---- spec/fltk-images-tiled.ads | 29 ++--- spec/fltk-images.ads | 124 +++++---------------- test/bitmap.adb | 1 - test/pixmap.adb | 175 +++++++++++++++++++++++++++++ tests.gpr | 4 +- 43 files changed, 1135 insertions(+), 653 deletions(-) create mode 100644 test/pixmap.adb diff --git a/body/c_fl_bitmap.cpp b/body/c_fl_bitmap.cpp index 01077b2..a54b579 100644 --- a/body/c_fl_bitmap.cpp +++ b/body/c_fl_bitmap.cpp @@ -39,6 +39,13 @@ void fl_bitmap_uncache(BITMAP b) { +const void * fl_bitmap_data(BITMAP b) { + return static_cast(static_cast(b)->array); +} + + + + void fl_bitmap_draw2(BITMAP b, int x, int y) { static_cast(b)->draw(x, y); } diff --git a/body/c_fl_bitmap.h b/body/c_fl_bitmap.h index f5f6e15..088486c 100644 --- a/body/c_fl_bitmap.h +++ b/body/c_fl_bitmap.h @@ -20,6 +20,9 @@ extern "C" BITMAP fl_bitmap_copy2(BITMAP b); extern "C" void fl_bitmap_uncache(BITMAP b); +extern "C" const void * fl_bitmap_data(BITMAP b); + + extern "C" void fl_bitmap_draw2(BITMAP b, int x, int y); extern "C" void fl_bitmap_draw(BITMAP b, int x, int y, int w, int h, int cx, int cy); diff --git a/body/c_fl_image.cpp b/body/c_fl_image.cpp index 328c187..cf24c59 100644 --- a/body/c_fl_image.cpp +++ b/body/c_fl_image.cpp @@ -10,22 +10,34 @@ -class My_Image : public Fl_Image { - public: - using Fl_Image::Fl_Image; - friend void fl_image_draw_empty(IMAGE i, int x, int y); +// Enums, macros, and constants + +const int fl_image_err_no_image = Fl_Image::ERR_NO_IMAGE; +const int fl_image_err_file_access = Fl_Image::ERR_FILE_ACCESS; +const int fl_image_err_format = Fl_Image::ERR_FORMAT; + + + + +// Non-friend protected access + +class Friend_Image : Fl_Image { +public: + using Fl_Image::draw_empty; }; +// Flattened C API + IMAGE new_fl_image(int w, int h, int d) { - My_Image *i = new My_Image(w, h, d); + Fl_Image *i = new Fl_Image(w, h, d); return i; } void free_fl_image(IMAGE i) { - delete static_cast(i); + delete static_cast(i); } @@ -69,16 +81,7 @@ void fl_image_inactive(IMAGE i) { } int fl_image_fail(IMAGE i) { - switch (static_cast(i)->fail()) { - case Fl_Image::ERR_NO_IMAGE: - return 1; - case Fl_Image::ERR_FILE_ACCESS: - return 2; - case Fl_Image::ERR_FORMAT: - return 3; - default: - return 0; - } + return static_cast(i)->fail(); } void fl_image_uncache(IMAGE i) { @@ -105,10 +108,6 @@ int fl_image_ld(IMAGE i) { return static_cast(i)->ld(); } -int fl_image_count(IMAGE i) { - return static_cast(i)->count(); -} - @@ -116,12 +115,8 @@ const void * fl_image_data(IMAGE i) { return static_cast(i)->data(); } -char fl_image_get_pixel(char *c, int off) { - return c[off]; -} - -void fl_image_set_pixel(char *c, int off, char val) { - c[off] = val; +int fl_image_count(IMAGE i) { + return static_cast(i)->count(); } @@ -137,6 +132,7 @@ void fl_image_draw2(IMAGE i, int x, int y, int w, int h, int cx, int cy) { } void fl_image_draw_empty(IMAGE i, int x, int y) { - static_cast(i)->draw_empty(x, y); + (static_cast(i)->*(&Friend_Image::draw_empty))(x, y); } + diff --git a/body/c_fl_image.h b/body/c_fl_image.h index ee96b7a..24ef65c 100644 --- a/body/c_fl_image.h +++ b/body/c_fl_image.h @@ -8,6 +8,11 @@ #define FL_IMAGE_GUARD +extern "C" const int fl_image_err_no_image; +extern "C" const int fl_image_err_file_access; +extern "C" const int fl_image_err_format; + + typedef void* IMAGE; @@ -34,12 +39,10 @@ extern "C" int fl_image_w(IMAGE i); extern "C" int fl_image_h(IMAGE i); extern "C" int fl_image_d(IMAGE i); extern "C" int fl_image_ld(IMAGE i); -extern "C" int fl_image_count(IMAGE i); extern "C" const void * fl_image_data(IMAGE i); -extern "C" char fl_image_get_pixel(char *c, int off); -extern "C" void fl_image_set_pixel(char *c, int off, char val); +extern "C" int fl_image_count(IMAGE i); extern "C" void fl_image_draw(IMAGE i, int x, int y); diff --git a/body/c_fl_pixmap.cpp b/body/c_fl_pixmap.cpp index 6ebcb56..14b5a74 100644 --- a/body/c_fl_pixmap.cpp +++ b/body/c_fl_pixmap.cpp @@ -10,10 +10,18 @@ +PIXMAP new_fl_pixmap(void * d) { + Fl_Pixmap *p = new Fl_Pixmap(static_cast(d)); + return p; +} + void free_fl_pixmap(PIXMAP b) { delete static_cast(b); } + + + PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h) { // virtual so disable dispatch return static_cast(b)->Fl_Pixmap::copy(w, h); diff --git a/body/c_fl_pixmap.h b/body/c_fl_pixmap.h index ceba284..868a3a2 100644 --- a/body/c_fl_pixmap.h +++ b/body/c_fl_pixmap.h @@ -11,7 +11,10 @@ typedef void* PIXMAP; +extern "C" PIXMAP new_fl_pixmap(void * d); extern "C" void free_fl_pixmap(PIXMAP b); + + extern "C" PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h); extern "C" PIXMAP fl_pixmap_copy2(PIXMAP b); diff --git a/body/c_fl_png_image.cpp b/body/c_fl_png_image.cpp index a4a6d71..ae77476 100644 --- a/body/c_fl_png_image.cpp +++ b/body/c_fl_png_image.cpp @@ -24,3 +24,4 @@ void free_fl_png_image(PNGIMAGE p) { delete static_cast(p); } + diff --git a/body/c_fl_pnm_image.cpp b/body/c_fl_pnm_image.cpp index 1550998..e5f7f17 100644 --- a/body/c_fl_pnm_image.cpp +++ b/body/c_fl_pnm_image.cpp @@ -19,3 +19,4 @@ void free_fl_pnm_image(PNMIMAGE p) { delete static_cast(p); } + diff --git a/body/c_fl_rgb_image.cpp b/body/c_fl_rgb_image.cpp index 65afbf9..fc39594 100644 --- a/body/c_fl_rgb_image.cpp +++ b/body/c_fl_rgb_image.cpp @@ -66,6 +66,13 @@ void fl_rgb_image_uncache(RGBIMAGE i) { +const void * fl_rgb_image_data(RGBIMAGE i) { + return static_cast(static_cast(i)->array); +} + + + + void fl_rgb_image_draw2(RGBIMAGE i, int x, int y) { static_cast(i)->draw(x, y); } diff --git a/body/c_fl_rgb_image.h b/body/c_fl_rgb_image.h index a09b58e..2d42993 100644 --- a/body/c_fl_rgb_image.h +++ b/body/c_fl_rgb_image.h @@ -27,6 +27,9 @@ extern "C" void fl_rgb_image_desaturate(RGBIMAGE i); extern "C" void fl_rgb_image_uncache(RGBIMAGE i); +extern "C" const void * fl_rgb_image_data(RGBIMAGE i); + + extern "C" void fl_rgb_image_draw2(RGBIMAGE i, int x, int y); extern "C" void fl_rgb_image_draw(RGBIMAGE i, int x, int y, int w, int h, int cx, int cy); diff --git a/body/fltk-images-bitmaps-xbm.adb b/body/fltk-images-bitmaps-xbm.adb index eb8c093..12fce18 100644 --- a/body/fltk-images-bitmaps-xbm.adb +++ b/body/fltk-images-bitmaps-xbm.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.Bitmaps.XBM is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_xbm_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +30,10 @@ package body FLTK.Images.Bitmaps.XBM is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out XBM_Image) is begin @@ -39,7 +47,7 @@ package body FLTK.Images.Bitmaps.XBM is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,17 +59,7 @@ package body FLTK.Images.Bitmaps.XBM is return This : XBM_Image do This.Void_Ptr := new_fl_xbm_image (Interfaces.C.To_C (Filename)); - case fl_image_fail (This.Void_Ptr) is - when 1 => - -- raise No_Image_Error; - null; - -- Since the image depth and line data are both zero here, - -- the fail method will think there's no image even though - -- nothing is wrong. This is a bug in FLTK. - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; + Raise_Fail_Errors (This); end return; end Create; @@ -70,3 +68,4 @@ package body FLTK.Images.Bitmaps.XBM is end FLTK.Images.Bitmaps.XBM; + diff --git a/body/fltk-images-bitmaps.adb b/body/fltk-images-bitmaps.adb index 90150c9..e2c7dd3 100644 --- a/body/fltk-images-bitmaps.adb +++ b/body/fltk-images-bitmaps.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.Bitmaps is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_bitmap (D : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -48,6 +52,15 @@ package body FLTK.Images.Bitmaps is + function fl_bitmap_data + (B : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_bitmap_data, "fl_bitmap_data"); + pragma Inline (fl_bitmap_data); + + + + procedure fl_bitmap_draw2 (I : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -63,6 +76,10 @@ package body FLTK.Images.Bitmaps is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Bitmap) is begin @@ -76,7 +93,7 @@ package body FLTK.Images.Bitmaps is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -91,23 +108,31 @@ package body FLTK.Images.Bitmaps is (Storage.To_Integer (Data (Data'First)'Address), Interfaces.C.int (Width), Interfaces.C.int (Height)); - case fl_image_fail (This.Void_Ptr) is - when 1 => - -- raise No_Image_Error; - null; - -- Since the image depth and line data are both zero here, - -- the fail method will think there's no image even though - -- nothing is wrong. This is a bug in FLTK. - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; end return; end Create; end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + function To_Next_Byte + (Bits : in Natural) + return Natural is + begin + return Integer (Float'Ceiling (Float (Bits) / Float (Color_Component_Array'Component_Size))) + * Color_Component_Array'Component_Size; + end To_Next_Byte; + + + + + -- Copying -- + function Copy (This : in Bitmap; Width, Height : in Natural) @@ -134,9 +159,7 @@ package body FLTK.Images.Bitmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Bitmap) is @@ -146,9 +169,85 @@ package body FLTK.Images.Bitmaps is - --------------- + + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Natural is + begin + return To_Next_Byte (This.Get_W) * This.Get_H; + end Data_Size; + + + function Get_Datum + (This : in Bitmap; + Place : in Positive) + return Color_Component + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Place); + end Get_Datum; + + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive; + Value : in Color_Component) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place) := Value; + end Set_Datum; + + + function Slice + (This : in Bitmap; + Low : in Positive; + High : in Natural) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Low .. High); + end Slice; + + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive; + Values : in Color_Component_Array) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place .. Place + Values'Length - 1) := Values; + end Overwrite; + + + function All_Data + (This : in Bitmap) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_bitmap_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data; + end All_Data; + + + + -- Drawing -- - --------------- procedure Draw (This : in Bitmap; @@ -162,9 +261,9 @@ package body FLTK.Images.Bitmaps is procedure Draw - (This : in Bitmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_bitmap_draw (This.Void_Ptr, @@ -172,10 +271,11 @@ package body FLTK.Images.Bitmaps 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; end FLTK.Images.Bitmaps; + diff --git a/body/fltk-images-pixmaps-gif.adb b/body/fltk-images-pixmaps-gif.adb index 535debf..95ce3d9 100644 --- a/body/fltk-images-pixmaps-gif.adb +++ b/body/fltk-images-pixmaps-gif.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.Pixmaps.GIF is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_gif_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +30,10 @@ package body FLTK.Images.Pixmaps.GIF is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out GIF_Image) is begin @@ -39,7 +47,7 @@ package body FLTK.Images.Pixmaps.GIF is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +59,7 @@ package body FLTK.Images.Pixmaps.GIF is return This : GIF_Image do This.Void_Ptr := new_fl_gif_image (Interfaces.C.To_C (Filename)); - 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; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +68,4 @@ package body FLTK.Images.Pixmaps.GIF is end FLTK.Images.Pixmaps.GIF; + diff --git a/body/fltk-images-pixmaps-xpm.adb b/body/fltk-images-pixmaps-xpm.adb index 006c8b4..beeb1d2 100644 --- a/body/fltk-images-pixmaps-xpm.adb +++ b/body/fltk-images-pixmaps-xpm.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.Pixmaps.XPM is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_xpm_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +30,10 @@ package body FLTK.Images.Pixmaps.XPM is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out XPM_Image) is begin @@ -39,7 +47,7 @@ package body FLTK.Images.Pixmaps.XPM is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +59,7 @@ package body FLTK.Images.Pixmaps.XPM is return This : XPM_Image do This.Void_Ptr := new_fl_xpm_image (Interfaces.C.To_C (Filename)); - 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; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +68,4 @@ package body FLTK.Images.Pixmaps.XPM is end FLTK.Images.Pixmaps.XPM; + 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; diff --git a/body/fltk-images-rgb-bmp.adb b/body/fltk-images-rgb-bmp.adb index 01669eb..f14f782 100644 --- a/body/fltk-images-rgb-bmp.adb +++ b/body/fltk-images-rgb-bmp.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.RGB.BMP is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_bmp_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +30,10 @@ package body FLTK.Images.RGB.BMP is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out BMP_Image) is begin @@ -39,7 +47,7 @@ package body FLTK.Images.RGB.BMP is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +59,7 @@ package body FLTK.Images.RGB.BMP is return This : BMP_Image do This.Void_Ptr := new_fl_bmp_image (Interfaces.C.To_C (Filename)); - 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; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +68,4 @@ package body FLTK.Images.RGB.BMP is end FLTK.Images.RGB.BMP; + diff --git a/body/fltk-images-rgb-jpeg.adb b/body/fltk-images-rgb-jpeg.adb index 17debb5..da30529 100644 --- a/body/fltk-images-rgb-jpeg.adb +++ b/body/fltk-images-rgb-jpeg.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.RGB.JPEG is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_jpeg_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -33,6 +37,10 @@ package body FLTK.Images.RGB.JPEG is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out JPEG_Image) is begin @@ -46,7 +54,7 @@ package body FLTK.Images.RGB.JPEG is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -58,15 +66,11 @@ package body FLTK.Images.RGB.JPEG is return This : JPEG_Image do This.Void_Ptr := new_fl_jpeg_image (Interfaces.C.To_C (Filename)); - 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; + Raise_Fail_Errors (This); end return; end Create; + function Create (Name : in String := ""; Data : in Color_Component_Array) @@ -76,12 +80,7 @@ package body FLTK.Images.RGB.JPEG is This.Void_Ptr := new_fl_jpeg_image2 (Interfaces.C.To_C (Name), Storage.To_Integer (Data (Data'First)'Address)); - 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; + Raise_Fail_Errors (This); end return; end Create; @@ -90,3 +89,4 @@ package body FLTK.Images.RGB.JPEG is end FLTK.Images.RGB.JPEG; + diff --git a/body/fltk-images-rgb-png.adb b/body/fltk-images-rgb-png.adb index 67befe3..84dc9af 100644 --- a/body/fltk-images-rgb-png.adb +++ b/body/fltk-images-rgb-png.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.RGB.PNG is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_png_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -34,6 +38,10 @@ package body FLTK.Images.RGB.PNG is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out PNG_Image) is begin @@ -47,7 +55,7 @@ package body FLTK.Images.RGB.PNG is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -59,15 +67,11 @@ package body FLTK.Images.RGB.PNG is return This : PNG_Image do This.Void_Ptr := new_fl_png_image (Interfaces.C.To_C (Filename)); - 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; + Raise_Fail_Errors (This); end return; end Create; + function Create (Name : in String := ""; Data : in Color_Component_Array) @@ -78,12 +82,7 @@ package body FLTK.Images.RGB.PNG is (Interfaces.C.To_C (Name), Storage.To_Integer (Data (Data'First)'Address), Data'Length); - 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; + Raise_Fail_Errors (This); end return; end Create; @@ -92,3 +91,4 @@ package body FLTK.Images.RGB.PNG is end FLTK.Images.RGB.PNG; + diff --git a/body/fltk-images-rgb-pnm.adb b/body/fltk-images-rgb-pnm.adb index 362b8d6..be4ed29 100644 --- a/body/fltk-images-rgb-pnm.adb +++ b/body/fltk-images-rgb-pnm.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.RGB.PNM is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_pnm_image (F : in Interfaces.C.char_array) return Storage.Integer_Address; @@ -26,6 +30,10 @@ package body FLTK.Images.RGB.PNM is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out PNM_Image) is begin @@ -39,7 +47,7 @@ package body FLTK.Images.RGB.PNM is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -51,12 +59,7 @@ package body FLTK.Images.RGB.PNM is return This : PNM_Image do This.Void_Ptr := new_fl_pnm_image (Interfaces.C.To_C (Filename)); - 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; + Raise_Fail_Errors (This); end return; end Create; @@ -65,3 +68,4 @@ package body FLTK.Images.RGB.PNM is end FLTK.Images.RGB.PNM; + diff --git a/body/fltk-images-rgb.adb b/body/fltk-images-rgb.adb index 19a7952..4e193bf 100644 --- a/body/fltk-images-rgb.adb +++ b/body/fltk-images-rgb.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.RGB is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_rgb_image (Data : in Storage.Integer_Address; W, H, D, L : in Interfaces.C.int) @@ -80,6 +84,15 @@ package body FLTK.Images.RGB is + function fl_rgb_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_rgb_image_data, "fl_rgb_image_data"); + pragma Inline (fl_rgb_image_data); + + + + procedure fl_rgb_image_draw2 (I : in Storage.Integer_Address; X, Y : in Interfaces.C.int); @@ -95,6 +108,10 @@ package body FLTK.Images.RGB is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out RGB_Image) is begin @@ -108,7 +125,7 @@ package body FLTK.Images.RGB is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -117,7 +134,7 @@ package body FLTK.Images.RGB is (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) + Line_Size : in Natural := 0) return RGB_Image is begin return This : RGB_Image do @@ -126,16 +143,11 @@ package body FLTK.Images.RGB is 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; + Interfaces.C.int (Line_Size)); end return; end Create; + function Create (Data : in FLTK.Images.Pixmaps.Pixmap'Class; Background : in Color := Background_Color) @@ -145,18 +157,16 @@ package body FLTK.Images.RGB is 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; + + + -- Copying -- + function Get_Max_Size return Natural is begin @@ -197,9 +207,7 @@ package body FLTK.Images.RGB is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out RGB_Image; @@ -222,9 +230,7 @@ package body FLTK.Images.RGB is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out RGB_Image) is @@ -235,9 +241,90 @@ package body FLTK.Images.RGB is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Natural + is + Per_Line : Natural := This.Get_Line_Size; + begin + if Per_Line = 0 then + return This.Get_W * This.Get_D * This.Get_H; + else + return Per_Line * This.Get_H; + end if; + end Data_Size; + + + function Get_Datum + (This : in RGB_Image; + Place : in Positive) + return Color_Component + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Place); + end Get_Datum; + + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive; + Value : in Color_Component) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place) := Value; + end Set_Datum; + + + function Slice + (This : in RGB_Image; + Low : in Positive; + High : in Natural) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data (Low .. High); + end Slice; + + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive; + Values : in Color_Component_Array) + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + The_Data (Place .. Place + Values'Length - 1) := Values; + end Overwrite; + + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + is + The_Data : Color_Component_Array (1 .. This.Data_Size); + for The_Data'Address use Storage.To_Address (fl_rgb_image_data (This.Void_Ptr)); + pragma Import (Ada, The_Data); + begin + return The_Data; + end All_Data; + + + + -- Drawing -- - --------------- procedure Draw (This : in RGB_Image; @@ -251,9 +338,9 @@ package body FLTK.Images.RGB is procedure Draw - (This : in RGB_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_rgb_image_draw (This.Void_Ptr, @@ -261,10 +348,11 @@ package body FLTK.Images.RGB 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; end FLTK.Images.RGB; + diff --git a/body/fltk-images-tiled.adb b/body/fltk-images-tiled.adb index 6bed730..bf9dfb3 100644 --- a/body/fltk-images-tiled.adb +++ b/body/fltk-images-tiled.adb @@ -12,6 +12,10 @@ with package body FLTK.Images.Tiled is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_tiled_image (T : in Storage.Integer_Address; W, H : in Interfaces.C.int) @@ -80,6 +84,10 @@ package body FLTK.Images.Tiled is + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Tiled_Image) is begin @@ -93,7 +101,7 @@ package body FLTK.Images.Tiled is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -116,6 +124,10 @@ package body FLTK.Images.Tiled is end Forge; + + + -- Copying -- + function Copy (This : in Tiled_Image; Width, Height : in Natural) @@ -146,9 +158,7 @@ package body FLTK.Images.Tiled is - --------------------- -- Miscellaneous -- - --------------------- procedure Inactive (This : in out Tiled_Image) is @@ -169,9 +179,7 @@ package body FLTK.Images.Tiled is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Tiled_Image; @@ -198,6 +206,8 @@ package body FLTK.Images.Tiled is + -- Drawing -- + procedure Draw (This : in Tiled_Image; X, Y : in Integer) is @@ -210,9 +220,9 @@ package body FLTK.Images.Tiled is procedure Draw - (This : in Tiled_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer) is + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer) is begin fl_tiled_image_draw2 (This.Void_Ptr, @@ -220,10 +230,11 @@ package body FLTK.Images.Tiled 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; end FLTK.Images.Tiled; + diff --git a/body/fltk-images.adb b/body/fltk-images.adb index 19a1f86..fdc4abd 100644 --- a/body/fltk-images.adb +++ b/body/fltk-images.adb @@ -16,6 +16,26 @@ use type package body FLTK.Images is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_image_err_no_image : constant Interfaces.C.int; + pragma Import (C, fl_image_err_no_image, "fl_image_err_no_image"); + + fl_image_err_file_access : constant Interfaces.C.int; + pragma Import (C, fl_image_err_file_access, "fl_image_err_file_access"); + + fl_image_err_format : constant Interfaces.C.int; + pragma Import (C, fl_image_err_format, "fl_image_err_format"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_image (W, H, D : in Interfaces.C.int) return Storage.Integer_Address; @@ -30,6 +50,14 @@ package body FLTK.Images is + function fl_image_fail + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_fail, "fl_image_fail"); + + + + function fl_image_get_rgb_scaling return Interfaces.C.int; pragma Import (C, fl_image_get_rgb_scaling, "fl_image_get_rgb_scaling"); @@ -108,35 +136,6 @@ package body FLTK.Images is pragma Import (C, fl_image_ld, "fl_image_ld"); pragma Inline (fl_image_ld); - function fl_image_count - (I : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_image_count, "fl_image_count"); - pragma Inline (fl_image_count); - - - - - function fl_image_data - (I : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_image_data, "fl_image_data"); - pragma Inline (fl_image_data); - - function fl_image_get_pixel - (C : in Interfaces.C.Strings.chars_ptr; - O : in Interfaces.C.int) - return Interfaces.C.unsigned_char; - pragma Import (C, fl_image_get_pixel, "fl_image_get_pixel"); - pragma Inline (fl_image_get_pixel); - - procedure fl_image_set_pixel - (C : in Interfaces.C.Strings.chars_ptr; - O : in Interfaces.C.int; - V : in Interfaces.C.unsigned_char); - pragma Import (C, fl_image_set_pixel, "fl_image_set_pixel"); - pragma Inline (fl_image_set_pixel); - @@ -161,6 +160,31 @@ package body FLTK.Images is + ------------------------ + -- Internal Utility -- + ------------------------ + + procedure Raise_Fail_Errors + (This : in Image'Class) + is + Result : Interfaces.C.int := fl_image_fail (This.Void_Ptr); + begin + if Result = fl_image_err_no_image and This.Is_Empty then + raise No_Image_Error; + elsif Result = fl_image_err_file_access then + raise File_Access_Error; + elsif Result = fl_image_err_format then + raise Format_Error; + end if; + end Raise_Fail_Errors; + + + + + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Image) is begin @@ -174,7 +198,7 @@ package body FLTK.Images is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -188,18 +212,20 @@ package body FLTK.Images is (Interfaces.C.int (Width), Interfaces.C.int (Height), Interfaces.C.int (Depth)); - 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; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Get_Copy_Algorithm return Scaling_Kind is begin @@ -240,9 +266,7 @@ package body FLTK.Images is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Image; @@ -265,9 +289,7 @@ package body FLTK.Images is - ---------------- -- Activity -- - ---------------- procedure Inactive (This : in out Image) is @@ -280,7 +302,7 @@ package body FLTK.Images is (This : in Image) return Boolean is begin - return fl_image_fail (This.Void_Ptr) /= 0; + return fl_image_count (This.Void_Ptr) = 0 or This.Get_W = 0 or This.Get_H = 0; end Is_Empty; @@ -293,9 +315,7 @@ package body FLTK.Images is - ------------------ -- Dimensions -- - ------------------ function Get_W (This : in Image) @@ -321,131 +341,17 @@ package body FLTK.Images is end Get_D; - function Get_Line_Data + function Get_Line_Size (This : in Image) return Natural is begin return Natural (fl_image_ld (This.Void_Ptr)); - end Get_Line_Data; - - - function Get_Data_Count - (This : in Image) - return Natural is - begin - return Natural (fl_image_count (This.Void_Ptr)); - end Get_Data_Count; - - - function Get_Data_Size - (This : in Image) - return Natural - is - My_Depth : Natural := This.Get_D; - My_Line_Data : Natural := This.Get_Line_Data; - begin - if My_Line_Data > 0 then - return My_Line_Data * This.Get_H; - elsif My_Depth = 0 then - return Integer (Float'Ceiling (Float (This.Get_W) / 8.0)) * This.Get_H; - else - return This.Get_W * My_Depth * This.Get_H; - end if; - end Get_Data_Size; - + end Get_Line_Size; - ------------------ - -- Pixel Data -- - ------------------ - - function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - return Color_Component - (fl_image_get_pixel (Pointers (Data), Interfaces.C.int (Position) - 1)); - end Get_Datum; - - procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - fl_image_set_pixel - (Pointers (Data), - Interfaces.C.int (Position) - 1, - Interfaces.C.unsigned_char (Value)); - end Set_Datum; - - - function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - Result : Color_Component_Array := (1 .. Count => 0); - begin - for Index in Result'Range loop - Result (Index) := Color_Component (fl_image_get_pixel - (Pointers (Data), - Interfaces.C.int (Index - 1 + Position - 1))); - end loop; - return Result; - end Get_Data; - - - function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array is - begin - return This.Get_Data (Data, 1, This.Get_Data_Size); - end All_Data; - - - procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - for Counter in Integer range 0 .. Values'Length - 1 loop - fl_image_set_pixel - (Pointers (Data), - Interfaces.C.int (Position - 1 + Counter), - Interfaces.C.unsigned_char (Values (Values'First + Counter))); - end loop; - end Update_Data; - - - - - --------------- -- Drawing -- - --------------- procedure Draw (This : in Image; @@ -459,9 +365,9 @@ package body FLTK.Images is procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_image_draw2 (This.Void_Ptr, @@ -469,8 +375,8 @@ package body FLTK.Images 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; @@ -487,3 +393,4 @@ package body FLTK.Images is end FLTK.Images; + diff --git a/doc/fl_bitmap.html b/doc/fl_bitmap.html index 2a8cc72..922b1b5 100644 --- a/doc/fl_bitmap.html +++ b/doc/fl_bitmap.html @@ -52,14 +52,49 @@ 
 int alloc_array;
-  +Intentionally left unbound. 
 const uchar * array;
-  +
+function Data_Size
+       (This : in Bitmap)
+    return Natural;
+
+function Get_Datum
+       (This  : in Bitmap;
+        Place : in Positive)
+    return Color_Component
+with Pre => Place <= This.Data_Size;
+
+procedure Set_Datum
+       (This  : in out Bitmap;
+        Place : in     Positive;
+        Value : in     Color_Component)
+with Pre => Place <= This.Data_Size;
+
+function Slice
+       (This : in Bitmap;
+        Low  : in Positive;
+        High : in Natural)
+    return Color_Component_Array
+with Pre => High <= This.Data_Size,
+    Post => Slice'Result'Length = Integer'Max (0, High - Low + 1);
+
+procedure Overwrite
+       (This   : in out Bitmap;
+        Place  : in     Positive;
+        Values : in     Color_Component_Array)
+with Pre => Place + Values'Length - 1 <= This.Data_Size;
+
+function All_Data
+       (This : in Bitmap)
+    return Color_Component_Array
+with Post => All_Data'Result'Length = This.Data_Size;
+
@@ -79,7 +114,8 @@ Fl_Bitmap(const char *bits, int W, int H); function Create (Data : in Color_Component_Array; Width, Height : in Natural) - return Bitmap; + return Bitmap +with Pre => Data'Length = To_Next_Byte (Width) * Height; @@ -120,9 +156,9 @@ virtual void draw(int X, int Y, int W, int H, 
 procedure Draw
-       (This       : in Bitmap;
-        X, Y, W, H : in Integer;
-        CX, CY     : in Integer := 0);
+       (This           : in Bitmap;
+        X, Y, W, H     : in Integer;
+        Clip_X, Clip_Y : in Integer := 0);
diff --git a/doc/fl_image.html b/doc/fl_image.html index 7550b5c..10c9ed8 100644 --- a/doc/fl_image.html +++ b/doc/fl_image.html @@ -84,21 +84,21 @@ 
 static const int ERR_FILE_ACCESS = -2;
-  +See the errors table. 
 static const int ERR_FORMAT = -3;
-  +See the errors table. 
 static const int ERR_NO_IMAGE = -1;
-  +See the errors table. @@ -192,20 +192,7 @@ function Copy 
 int count() const;
-
-function Get_Data_Count
-       (This : in Image)
-    return Natural;
-
- - - -  -
-function Get_Data_Size
-       (This : in Image)
-    return Natural;
-
+Intentionally left unbound. @@ -223,53 +210,8 @@ function Get_D 
 const char * const * data() const;
-
-function Get_Datum
-       (This     : in Image;
-        Data     : in Positive;
-        Position : in Positive)
-    return Color_Component
-with Pre =>
-        Data <= Get_Data_Count (This) and
-        Position <= Get_Data_Size (This);
-
-procedure Set_Datum
-       (This     : in out Image;
-        Data     : in     Positive;
-        Position : in     Positive;
-        Value    : in     Color_Component)
-with Pre =>
-        Data <= Get_Data_Count (This) and
-        Position <= Get_Data_Size (This);
-
-function Get_Data
-       (This     : in Image;
-        Data     : in Positive;
-        Position : in Positive;
-        Count    : in Natural)
-    return Color_Component_Array
-with Pre =>
-        Data <= Get_Data_Count (This) and
-        Position <= Get_Data_Size (This) and
-        Count <= Get_Data_Size (This) - Position + 1;
-
-function All_Data
-       (This : in Image;
-        Data : in Positive)
-    return Color_Component_Array
-with Pre =>
-        Data <= Get_Data_Count (This);
-
-procedure Update_Data
-       (This     : in out Image;
-        Data     : in     Positive;
-        Position : in     Positive;
-        Values   : in     Color_Component_Array)
-with Pre =>
-        Data <= Get_Data_Count (This) and
-        Position <= Get_Data_Size (This) and
-        Values'Length <= Get_Data_Size (This) - Position + 1;
-
+See Data_Size, Get_Datum, Set_Datum, Slice, Overwrite, All_Data subprograms +in Fl_Bitmap and Fl_RGB_Image. @@ -289,9 +231,9 @@ virtual void draw(int X, int Y, int W, int H, 
 procedure Draw
-       (This       : in Image;
-        X, Y, W, H : in Integer;
-        CX, CY     : in Integer := 0);
+       (This           : in Image;
+        X, Y, W, H     : in Integer;
+        Clip_X, Clip_Y : in Integer := 0);
@@ -357,7 +299,7 @@ virtual void label(Fl_Menu_Item *m); int ld() const; 
-function Get_Line_Data
+function Get_Line_Size
        (This : in Image)
     return Natural;
diff --git a/doc/fl_pixmap.html b/doc/fl_pixmap.html index 60fec01..ab8c8d8 100644 --- a/doc/fl_pixmap.html +++ b/doc/fl_pixmap.html @@ -41,6 +41,31 @@ Pixmap_Reference + + char * + Header + + + + char + Color_Kind + + + + char * + Color_Definition + + + + char ** + Color_Definition_Array + + + + char ** + Pixmap_Data + + @@ -72,7 +97,19 @@ Fl_Pixmap(const char *const *D); Fl_Pixmap(const uchar *const *D); -  +
+function Create
+       (Values : in Header;
+        Colors : in Color_Definition_Array;
+        Pixels : in Pixmap_Data)
+    return Pixmap
+with Pre =>
+    Colors'Length = Values.Colors and
+    Pixels'Length (1) = Values.Height and
+    (for all Definition of Colors =>
+        Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and
+    Pixels'Length (2) = Values.Width * Values.Per_Pixel;
+
@@ -134,9 +171,9 @@ virtual void draw(int X, int Y, int W, int H, 
 procedure Draw
-       (This       : in Pixmap;
-        X, Y, W, H : in Integer;
-        CX, CY     : in Integer := 0);
+       (This           : in Pixmap;
+        X, Y, W, H     : in Integer;
+        Clip_X, Clip_Y : in Integer := 0);
diff --git a/doc/fl_rgb_image.html b/doc/fl_rgb_image.html index 1e115d5..061b07a 100644 --- a/doc/fl_rgb_image.html +++ b/doc/fl_rgb_image.html @@ -59,7 +59,42 @@ int alloc_array; 
 const uchar * array;
-Intentionally left unbound. +
+function Data_Size
+       (This : in RGB_Image)
+    return Natural;
+
+function Get_Datum
+       (This  : in RGB_Image;
+        Place : in Positive)
+    return Color_Component
+with Pre => Place <= This.Data_Size;
+
+procedure Set_Datum
+       (This  : in out RGB_Image;
+        Place : in     Positive;
+        Value : in     Color_Component)
+with Pre => Place <= This.Data_Size;
+
+function Slice
+       (This : in RGB_Image;
+        Low  : in Positive;
+        High : in Natural)
+    return Color_Component_Array
+with Pre => High <= This.Data_Size,
+    Post => Slice'Result'Length = Integer'Max (0, High - Low + 1);
+
+procedure Overwrite
+       (This   : in out RGB_Image;
+        Place  : in     Positive;
+        Values : in     Color_Component_Array)
+with Pre => Place + Values'Length - 1 <= This.Data_Size;
+
+function All_Data
+       (This : in RGB_Image)
+    return Color_Component_Array
+with Post => All_Data'Result'Length = This.Data_Size;
+
@@ -78,8 +113,12 @@ function Create (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) - return RGB_Image; + Line_Size : in Natural := 0) + return RGB_Image +with Pre => (if Line_Size = 0 + then Data'Length = Width * Height * Depth + else Data'Length = Line_Size * Height) + and Data'Length <= Get_Max_Size; @@ -181,9 +220,9 @@ virtual void draw(int X, int Y, int W, int H, 
 procedure Draw
-       (This       : in RGB_Image;
-        X, Y, W, H : in Integer;
-        CX, CY     : in Integer := 0);
+       (This           : in RGB_Image;
+        X, Y, W, H     : in Integer;
+        Clip_X, Clip_Y : in Integer := 0);
diff --git a/doc/fl_tiled_image.html b/doc/fl_tiled_image.html index 39292b1..49aeca0 100644 --- a/doc/fl_tiled_image.html +++ b/doc/fl_tiled_image.html @@ -150,9 +150,9 @@ virtual void draw(int X, int Y, int W, int H, int cx, int cy); 
 procedure Draw
-       (This       : in Tiled_Image;
-        X, Y, W, H : in Integer;
-        CX, CY     : in Integer);
+       (This           : in Tiled_Image;
+        X, Y, W, H     : in Integer;
+        Clip_X, Clip_Y : in Integer);
diff --git a/progress.txt b/progress.txt index 6e2c8b8..928ed3b 100644 --- a/progress.txt +++ b/progress.txt @@ -215,9 +215,7 @@ Non-widgets with incomplete APIs: FLTK FLTK.Devices.Graphics FLTK.Draw -FLTK.Images (static attributes, draw_empty, Get_Data_Size?) -FLTK.Images.Bitmaps (attributes) -FLTK.Images.Pixmaps (constructor) +FLTK.Images.Pixmaps (unmarshall data access?) FLTK.Images.Shared (images(), compare) FLTK.Text_Buffers diff --git a/spec/fltk-images-bitmaps-xbm.ads b/spec/fltk-images-bitmaps-xbm.ads index 0887666..5805332 100644 --- a/spec/fltk-images-bitmaps-xbm.ads +++ b/spec/fltk-images-bitmaps-xbm.ads @@ -7,10 +7,6 @@ package FLTK.Images.Bitmaps.XBM is - ------------- - -- Types -- - ------------- - type XBM_Image is new Bitmap with private; type XBM_Image_Reference (Data : not null access XBM_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.Bitmaps.XBM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Bitmaps.XBM; + diff --git a/spec/fltk-images-bitmaps.ads b/spec/fltk-images-bitmaps.ads index d8730a2..d60334f 100644 --- a/spec/fltk-images-bitmaps.ads +++ b/spec/fltk-images-bitmaps.ads @@ -7,10 +7,6 @@ package FLTK.Images.Bitmaps is - ------------- - -- Types -- - ------------- - type Bitmap is new Image with private; type Bitmap_Reference (Data : not null access Bitmap'Class) is limited null record @@ -19,22 +15,31 @@ package FLTK.Images.Bitmaps is - -------------------- - -- Construction -- - -------------------- + function To_Next_Byte + (Bits : in Natural) + return Natural; + + + package Forge is - -- Please note that I'm pretty sure (?) input data here should be some - -- declared item that lives at least as long as the resulting Bitmap + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting Bitmap. function Create (Data : in Color_Component_Array; Width, Height : in Natural) - return Bitmap; + return Bitmap + with Pre => Data'Length = To_Next_Byte (Width) * Height; end Forge; + + + + -- Copying -- + function Copy (This : in Bitmap; Width, Height : in Natural) @@ -47,9 +52,7 @@ package FLTK.Images.Bitmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Bitmap); @@ -57,18 +60,56 @@ package FLTK.Images.Bitmaps is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Natural; + + function Get_Datum + (This : in Bitmap; + Place : in Positive) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in Bitmap; + Low : in Positive; + High : in Natural) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Integer'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in Bitmap) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + -- Drawing -- - --------------- procedure Draw (This : in Bitmap; X, Y : in Integer); procedure Draw - (This : in Bitmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private @@ -80,10 +121,22 @@ private (This : in out Bitmap); + pragma Inline (To_Next_Byte); + pragma Inline (Copy); + pragma Inline (Uncache); + + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); + pragma Inline (Draw); end FLTK.Images.Bitmaps; + diff --git a/spec/fltk-images-pixmaps-gif.ads b/spec/fltk-images-pixmaps-gif.ads index 7084a13..5720138 100644 --- a/spec/fltk-images-pixmaps-gif.ads +++ b/spec/fltk-images-pixmaps-gif.ads @@ -7,10 +7,6 @@ package FLTK.Images.Pixmaps.GIF is - ------------- - -- Types -- - ------------- - type GIF_Image is new Pixmap with private; type GIF_Image_Reference (Data : not null access GIF_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Pixmaps.GIF is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Pixmaps.GIF; + diff --git a/spec/fltk-images-pixmaps-xpm.ads b/spec/fltk-images-pixmaps-xpm.ads index d5bae5a..c703264 100644 --- a/spec/fltk-images-pixmaps-xpm.ads +++ b/spec/fltk-images-pixmaps-xpm.ads @@ -7,10 +7,6 @@ package FLTK.Images.Pixmaps.XPM is - ------------- - -- Types -- - ------------- - type XPM_Image is new Pixmap with private; type XPM_Image_Reference (Data : not null access XPM_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Pixmaps.XPM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Pixmaps.XPM; + diff --git a/spec/fltk-images-pixmaps.ads b/spec/fltk-images-pixmaps.ads index 14e3f94..64d8330 100644 --- a/spec/fltk-images-pixmaps.ads +++ b/spec/fltk-images-pixmaps.ads @@ -4,12 +4,17 @@ -- Released into the public domain -package FLTK.Images.Pixmaps is +with + + Ada.Strings.Unbounded; + +private with + Interfaces.C.Strings; + + +package FLTK.Images.Pixmaps is - ------------- - -- Types -- - ------------- type Pixmap is new Image with private; @@ -17,11 +22,48 @@ package FLTK.Images.Pixmaps is with Implicit_Dereference => Data; + type Header is record + Width, Height, Colors, Per_Pixel : Positive; + end record; + + type Color_Kind is (Colorful, Monochrome, Greyscale, Symbolic); + + type Color_Definition is record + Name : Ada.Strings.Unbounded.Unbounded_String; + Kind : Color_Kind; + Value : Ada.Strings.Unbounded.Unbounded_String; + end record; + + type Color_Definition_Array is array (Positive range <>) of Color_Definition; + + type Pixmap_Data is array (Positive range <>, Positive range <>) of Character; + - -------------------- - -- Construction -- - -------------------- + + package Forge is + + -- Unlike Bitmaps or RGB_Images, you do NOT have to keep this data around. + -- A copy will be allocated and deallocated internally. + + function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap + with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; + + end Forge; + + + + + -- Copying -- function Copy (This : in Pixmap; @@ -35,9 +77,7 @@ package FLTK.Images.Pixmaps is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Pixmap; @@ -50,9 +90,7 @@ package FLTK.Images.Pixmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Pixmap); @@ -60,24 +98,24 @@ package FLTK.Images.Pixmaps is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Pixmap; X, Y : in Integer); procedure Draw - (This : in Pixmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private - type Pixmap is new Image with null record; + type Pixmap is new Image with record + Loose_Ptr : access Interfaces.C.Strings.chars_ptr_array; + end record; overriding procedure Finalize (This : in out Pixmap); @@ -86,13 +124,12 @@ private pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Uncache); - pragma Inline (Copy); pragma Inline (Draw); end FLTK.Images.Pixmaps; + diff --git a/spec/fltk-images-rgb-bmp.ads b/spec/fltk-images-rgb-bmp.ads index 4eb9e1b..f2bf103 100644 --- a/spec/fltk-images-rgb-bmp.ads +++ b/spec/fltk-images-rgb-bmp.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.BMP is - ------------- - -- Types -- - ------------- - type BMP_Image is new RGB_Image with private; type BMP_Image_Reference (Data : not null access BMP_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.BMP is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.RGB.BMP; + diff --git a/spec/fltk-images-rgb-jpeg.ads b/spec/fltk-images-rgb-jpeg.ads index 0349b01..8bb21ba 100644 --- a/spec/fltk-images-rgb-jpeg.ads +++ b/spec/fltk-images-rgb-jpeg.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.JPEG is - ------------- - -- Types -- - ------------- - type JPEG_Image is new RGB_Image with private; type JPEG_Image_Reference (Data : not null access JPEG_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.RGB.JPEG is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -48,3 +40,4 @@ private end FLTK.Images.RGB.JPEG; + diff --git a/spec/fltk-images-rgb-png.ads b/spec/fltk-images-rgb-png.ads index 23890b3..dcfbd4f 100644 --- a/spec/fltk-images-rgb-png.ads +++ b/spec/fltk-images-rgb-png.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.PNG is - ------------- - -- Types -- - ------------- - type PNG_Image is new RGB_Image with private; type PNG_Image_Reference (Data : not null access PNG_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.PNG is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -48,3 +40,4 @@ private end FLTK.Images.RGB.PNG; + diff --git a/spec/fltk-images-rgb-pnm.ads b/spec/fltk-images-rgb-pnm.ads index d72706b..847b149 100644 --- a/spec/fltk-images-rgb-pnm.ads +++ b/spec/fltk-images-rgb-pnm.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.PNM is - ------------- - -- Types -- - ------------- - type PNM_Image is new RGB_Image with private; type PNM_Image_Reference (Data : not null access PNM_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.PNM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.RGB.PNM; + diff --git a/spec/fltk-images-rgb.ads b/spec/fltk-images-rgb.ads index 5768b3c..a935872 100644 --- a/spec/fltk-images-rgb.ads +++ b/spec/fltk-images-rgb.ads @@ -12,10 +12,6 @@ with package FLTK.Images.RGB is - ------------- - -- Types -- - ------------- - type RGB_Image is new Image with private; type RGB_Image_Reference (Data : not null access RGB_Image'Class) is limited null record @@ -24,18 +20,30 @@ package FLTK.Images.RGB is - -------------------- - -- Construction -- - -------------------- + function Get_Max_Size + return Natural; + + procedure Set_Max_Size + (Value : in Natural); + + + package Forge is + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting RGB_Image. + function Create (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) - return RGB_Image; + Line_Size : in Natural := 0) + return RGB_Image + with Pre => (if Line_Size = 0 + then Data'Length = Width * Height * Depth + else Data'Length = Line_Size * Height) + and Data'Length <= Get_Max_Size; function Create (Data : in FLTK.Images.Pixmaps.Pixmap'Class; @@ -44,11 +52,10 @@ package FLTK.Images.RGB is end Forge; - function Get_Max_Size - return Natural; - procedure Set_Max_Size - (Value : in Natural); + + + -- Copying -- function Copy (This : in RGB_Image; @@ -62,9 +69,7 @@ package FLTK.Images.RGB is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out RGB_Image; @@ -77,9 +82,7 @@ package FLTK.Images.RGB is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out RGB_Image); @@ -87,18 +90,56 @@ package FLTK.Images.RGB is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Natural; + + function Get_Datum + (This : in RGB_Image; + Place : in Positive) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in RGB_Image; + Low : in Positive; + High : in Natural) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Integer'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + -- Drawing -- - --------------- procedure Draw (This : in RGB_Image; X, Y : in Integer); procedure Draw - (This : in RGB_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private @@ -112,18 +153,24 @@ private pragma Inline (Get_Max_Size); pragma Inline (Set_Max_Size); - pragma Inline (Copy); + pragma Inline (Copy); pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Uncache); + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); pragma Inline (Draw); end FLTK.Images.RGB; + diff --git a/spec/fltk-images-tiled.ads b/spec/fltk-images-tiled.ads index a7e775e..a7470fc 100644 --- a/spec/fltk-images-tiled.ads +++ b/spec/fltk-images-tiled.ads @@ -7,10 +7,6 @@ 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 @@ -19,10 +15,6 @@ package FLTK.Images.Tiled is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -32,6 +24,11 @@ package FLTK.Images.Tiled is end Forge; + + + + -- Copying -- + function Copy (This : in Tiled_Image; Width, Height : in Natural) @@ -44,9 +41,7 @@ package FLTK.Images.Tiled is - --------------------- -- Miscellaneous -- - --------------------- procedure Inactive (This : in out Tiled_Image); @@ -58,9 +53,7 @@ package FLTK.Images.Tiled is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Tiled_Image; @@ -73,18 +66,16 @@ package FLTK.Images.Tiled is - --------------- -- 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); + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer); private @@ -100,17 +91,15 @@ private 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/spec/fltk-images.ads b/spec/fltk-images.ads index 9a02f23..165c203 100644 --- a/spec/fltk-images.ads +++ b/spec/fltk-images.ads @@ -7,10 +7,6 @@ package FLTK.Images is - ------------- - -- Types -- - ------------- - type Image is new Wrapper with private; type Image_Reference (Data : not null access Image'Class) is limited null record @@ -20,23 +16,27 @@ package FLTK.Images is type Blend is new Float range 0.0 .. 1.0; - No_Image_Error, File_Access_Error, Format_Error : exception; + No_Image_Error, File_Access_Error, Format_Error : exception; - -------------------- - -- Construction -- - -------------------- package Forge is + -- This creates an empty image with no data, so not that useful. + function Create (Width, Height, Depth : in Natural) return Image; end Forge; + + + + -- Copying -- + function Get_Copy_Algorithm return Scaling_Kind; @@ -55,9 +55,7 @@ package FLTK.Images is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Image; @@ -70,9 +68,7 @@ package FLTK.Images is - ---------------- -- Activity -- - ---------------- procedure Inactive (This : in out Image); @@ -87,9 +83,7 @@ package FLTK.Images is - ------------------ -- Dimensions -- - ------------------ function Get_W (This : in Image) @@ -103,86 +97,23 @@ package FLTK.Images is (This : in Image) return Natural; - function Get_Line_Data + function Get_Line_Size (This : in Image) return Natural; - function Get_Data_Count - (This : in Image) - return Natural; - - function Get_Data_Size - (This : in Image) - return Natural; - - - - - ------------------ - -- Pixel Data -- - ------------------ - - function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - - procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - - function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Count <= Get_Data_Size (This) - Position + 1; - - function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array - with Pre => - Data <= Get_Data_Count (This); - - procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Values'Length <= Get_Data_Size (This) - Position + 1; - - --------------- -- Drawing -- - --------------- procedure Draw (This : in Image; X, Y : in Integer); procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); procedure Draw_Empty (This : in Image; @@ -198,40 +129,43 @@ private (This : in out Image); + procedure Raise_Fail_Errors + (This : in Image'Class); + + + function fl_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_data, "fl_image_data"); + pragma Inline (fl_image_data); + + function fl_image_count + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_count, "fl_image_count"); + pragma Inline (fl_image_count); pragma Inline (Get_Copy_Algorithm); pragma Inline (Set_Copy_Algorithm); pragma Inline (Copy); - pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Inactive); pragma Inline (Is_Empty); pragma Inline (Uncache); - pragma Inline (Get_W); pragma Inline (Get_H); pragma Inline (Get_D); - pragma Inline (Get_Line_Data); - pragma Inline (Get_Data_Count); - + pragma Inline (Get_Line_Size); pragma Inline (Draw); pragma Inline (Draw_Empty); - - - function fl_image_fail - (I : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_image_fail, "fl_image_fail"); - - end FLTK.Images; + diff --git a/test/bitmap.adb b/test/bitmap.adb index e6d5094..86c1406 100644 --- a/test/bitmap.adb +++ b/test/bitmap.adb @@ -10,7 +10,6 @@ with FLTK.Images.Bitmaps, - FLTK.Widgets.Buttons, FLTK.Widgets.Buttons.Toggle, FLTK.Widgets.Groups.Windows.Double; diff --git a/test/pixmap.adb b/test/pixmap.adb new file mode 100644 index 0000000..0ca3982 --- /dev/null +++ b/test/pixmap.adb @@ -0,0 +1,175 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Pixmap label test program functionality reproduced in Ada + + +with + + Ada.Strings.Unbounded, + FLTK.Images.Pixmaps, + FLTK.Widgets.Buttons.Toggle, + FLTK.Widgets.Groups.Windows.Double; + +use type + + FLTK.Alignment; + + +function Pixmap + return Integer +is + + + package SU renames Ada.Strings.Unbounded; + + function "+" (Str : in String) return SU.Unbounded_String renames SU.To_Unbounded_String; + + package Pix renames FLTK.Images.Pixmaps; + package Btn renames FLTK.Widgets.Buttons; + package Tog renames FLTK.Widgets.Buttons.Toggle; + package WD renames FLTK.Widgets.Groups.Windows.Double; + + + Porsche_Header : Pix.Header := (64, 64, 4, 1); + + Porsche_Colors : Pix.Color_Definition_Array := + ((Name => +" ", Kind => Pix.Colorful, Value => +"#background"), + (Name => +".", Kind => Pix.Colorful, Value => +"#000000000000"), + (Name => +"X", Kind => Pix.Colorful, Value => +"#ffd100"), + (Name => +"o", Kind => Pix.Colorful, Value => +"#FFFF00000000")); + + Porsche_Data : Pix.Pixmap_Data := + (" ", + " .......................... ", + " ..................................... ", + " ............XXXXXXXXXXXXXXXXXXXXXXXX............ ", + " ......XXXXXXX...XX...XXXXXXXX...XXXXXXXXXX...... ", + " ..XXXXXXXXXX..X..XX..XXXX.XXXX..XXXXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..X..XX..XXX..XXXX..X...XXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XX.....XX..XX.XXXXXXXXXXX.. ", + " ..XXXXXXXXX.....XXX..XXX..XXXX..X.XXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..XXXX....XXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..XXXX..X..XXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..X.XX..XX..XXXXXXXXXX.. ", + " ..XXXXXXXXX....XXX....XXX..XX....XX..XXXXXXXXX.. ", + " ..XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.. ", + " ..XXXXXXXXX..........................XXXXXXXXX.. ", + " ..XXX.......XXXXXXXXXXX...................XXXX.. ", + " ......XX.XXX.XXX..XXXXX......................... ", + " ..XXXXX.XXX.XXX.XXXX.XX......................... ", + " ..XXXX.XXX.XX.......XXX......................... ", + " ..XXXX.......XXXXXX..XX..ooooooooooooooooooooo.. ", + " ..X.....XXXXXXXXXXXXXXX..ooooooooooooooooooooo.. ", + " ..X...XXXXXXXXXXXXXXXXX..ooooooooooooooooooooo.. ", + " ..X..XXXXXXX.XX.XXXXXXX..ooooooooooooooooooooo.. ", + " ..XXXXX.XXX.XX.XXXXXXXX..ooooooooooooooooooooo.. ", + " ..XXXX.XXX.XX.XX................................ ", + " ..XXXX.X.........X....X.X.X..................... ", + " ..XXXX...XXXXXXX.X..X...X.X.X.X................. ", + " ..X....XXXXXXXXXX.X...X.X.X..................... ", + " ..X...XXXXXXXXXX.XXXXXXXXXXXXXX................. ", + " ..X..XXXXXX.XX.X.XXX...XXXXXXXX................. ", + " ..XXXXX.XX.XX.XX.XX.....XXXXXXX.oooooooooooooo.. ", + " ..XXXX.XX.XX.XX..XX.X...XXXXX.X.oooooooooooooo.. ", + " ..XXXX.X.......X.XXXX...XXXX..X.oooooooooooooo.. ", + " ..X......XXXXXX..XXXX...XXXX..X.oooooooooooooo.. ", + " ..X...XXXXXXXXXX.XXX.....XXX.XX.oooooooooooooo.. ", + " ..X..XXXXXXXXXXX.X...........XX.oooooooooooooo.. ", + " .................X.X.........XX................. ", + " .................X.X.XXXX....XX.XXXXXXXXXXXXXX.. ", + " .................XXX.XXXXX.X.XX.XXX.XX.XXXXXXX.. ", + " ................XXXX.XXX..X..X.XX.XX.XXX.XXX.. ", + " ................XXXXXXXX.XX.XX.X.XX.XXX.XXXX.. ", + " .................XXXXXX.XX.XX.X..........XXX.. ", + " ..oooooooooooooo.XXXXXXXXXX....XXXXXXXX..X.. ", + " ..ooooooooooooooo.XXXXXXXX....XXXXXXXXXXXX.. ", + " ..ooooooooooooooo........XXXXXXX.XX.XXXX.. ", + " ..oooooooooooooooooo..XXXXX.XXX.XX.XX.XX.. ", + " ..ooooooooooooooooo..XXXX.XXX.XX.XX.XX.. ", + " ..ooooooooooooooooo..XXX.XX........XXX.. ", + " ....................XXX....XXXXXX..X.. ", + " ...................XX...XXXXXXXXXXX. ", + " ...................X...XXXXXXXXXXX.. ", + " ..................X..XXXX.XXXXXX.. ", + " .................XXX.XX.XX.XXX.. ", + " ................XX.XX.XX.XXX.. ", + " ..ooooooooooo..XX.......XX.. ", + " ..oooooooooo..X...XXXX.X.. ", + " ..ooooooooo..X..XXXXXX.. ", + " ...ooooooo..X..XXXX... ", + " ....ooooo..XXXXX.... ", + " ....ooo..XXX.... ", + " ....o..X.... ", + " ........ ", + " .... ", + " "); + + + The_Window : WD.Double_Window := WD.Forge.Create (400, 400, "Badgery of Pixmap Labels"); + + The_Button : Btn.Button := Btn.Forge.Create (The_Window, 140, 160, 120, 120, "Pixmap"); + + The_Pixmap : Pix.Pixmap := Pix.Forge.Create (Porsche_Header, Porsche_Colors, Porsche_Data); + De_Pixmap : Pix.Pixmap'Class := The_Pixmap.Copy; + + Left_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 25, 50, 50, 25, "left"); + Right_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 75, 50, 50, 25, "right"); + Top_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 125, 50, 50, 25, "top"); + Bottom_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 175, 50, 50, 25, "bottom"); + Inside_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 225, 50, 50, 25, "inside"); + Over_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 25, 75, 100, 25, "text over"); + Inact_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 125, 75, 100, 25, "inactive"); + + + procedure Button_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + New_Align : FLTK.Alignment; + begin + if Left_Btn.Is_On then New_Align := New_Align + FLTK.Align_Left; end if; + if Right_Btn.Is_On then New_Align := New_Align + FLTK.Align_Right; end if; + if Top_Btn.Is_On then New_Align := New_Align + FLTK.Align_Top; end if; + if Bottom_Btn.Is_On then New_Align := New_Align + FLTK.Align_Bottom; end if; + if Inside_Btn.Is_On then New_Align := New_Align + FLTK.Align_Inside; end if; + if Over_Btn.Is_On then New_Align := New_Align + FLTK.Align_Text_Over_Image; end if; + The_Button.Set_Alignment (New_Align); + + if Inact_Btn.Is_On then + The_Button.Deactivate; + else + The_Button.Activate; + end if; + + The_Window.Redraw; + end Button_Callback; + + +begin + + + De_Pixmap.Inactive; + + The_Button.Set_Image (The_Pixmap); + The_Button.Set_Inactive_Image (De_Pixmap); + + Left_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Right_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Top_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Bottom_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Inside_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Over_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Inact_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + + The_Window.Set_Resizable (The_Window); + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Pixmap; + + diff --git a/tests.gpr b/tests.gpr index 6137d80..04c0c76 100644 --- a/tests.gpr +++ b/tests.gpr @@ -21,7 +21,8 @@ project Tests is "bitmap.adb", "compare.adb", "dirlist.adb", - "page_formats.adb"); + "page_formats.adb", + "pixmap.adb"); package Builder is for Executable ("adjuster.adb") use "adjuster"; @@ -30,6 +31,7 @@ project Tests is for Executable ("compare.adb") use "compare"; for Executable ("dirlist.adb") use "dirlist"; for Executable ("page_formats.adb") use "page_formats"; + for Executable ("pixmap.adb") use "pixmap"; end Builder; package Compiler renames Common.Compiler; -- cgit