diff options
Diffstat (limited to 'body')
| -rw-r--r-- | body/c_fl_bitmap.cpp | 7 | ||||
| -rw-r--r-- | body/c_fl_bitmap.h | 3 | ||||
| -rw-r--r-- | body/c_fl_image.cpp | 50 | ||||
| -rw-r--r-- | body/c_fl_image.h | 9 | ||||
| -rw-r--r-- | body/c_fl_pixmap.cpp | 8 | ||||
| -rw-r--r-- | body/c_fl_pixmap.h | 3 | ||||
| -rw-r--r-- | body/c_fl_png_image.cpp | 1 | ||||
| -rw-r--r-- | body/c_fl_pnm_image.cpp | 1 | ||||
| -rw-r--r-- | body/c_fl_rgb_image.cpp | 7 | ||||
| -rw-r--r-- | body/c_fl_rgb_image.h | 3 | ||||
| -rw-r--r-- | body/fltk-images-bitmaps-xbm.adb | 23 | ||||
| -rw-r--r-- | body/fltk-images-bitmaps.adb | 142 | ||||
| -rw-r--r-- | body/fltk-images-pixmaps-gif.adb | 18 | ||||
| -rw-r--r-- | body/fltk-images-pixmaps-xpm.adb | 18 | ||||
| -rw-r--r-- | body/fltk-images-pixmaps.adb | 116 | ||||
| -rw-r--r-- | body/fltk-images-rgb-bmp.adb | 18 | ||||
| -rw-r--r-- | body/fltk-images-rgb-jpeg.adb | 26 | ||||
| -rw-r--r-- | body/fltk-images-rgb-png.adb | 26 | ||||
| -rw-r--r-- | body/fltk-images-rgb-pnm.adb | 18 | ||||
| -rw-r--r-- | body/fltk-images-rgb.adb | 140 | ||||
| -rw-r--r-- | body/fltk-images-tiled.adb | 31 | ||||
| -rw-r--r-- | body/fltk-images.adb | 235 |
22 files changed, 573 insertions, 330 deletions
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<const void*>(static_cast<Fl_Bitmap*>(b)->array); +} + + + + void fl_bitmap_draw2(BITMAP b, int x, int y) { static_cast<Fl_Bitmap*>(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<My_Image*>(i); + delete static_cast<Fl_Image*>(i); } @@ -69,16 +81,7 @@ void fl_image_inactive(IMAGE i) { } int fl_image_fail(IMAGE i) { - switch (static_cast<Fl_Image*>(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<Fl_Image*>(i)->fail(); } void fl_image_uncache(IMAGE i) { @@ -105,10 +108,6 @@ int fl_image_ld(IMAGE i) { return static_cast<Fl_Image*>(i)->ld(); } -int fl_image_count(IMAGE i) { - return static_cast<Fl_Image*>(i)->count(); -} - @@ -116,12 +115,8 @@ const void * fl_image_data(IMAGE i) { return static_cast<Fl_Image*>(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<Fl_Image*>(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<My_Image*>(i)->draw_empty(x, y); + (static_cast<Fl_Image*>(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<char**>(d)); + return p; +} + void free_fl_pixmap(PIXMAP b) { delete static_cast<Fl_Pixmap*>(b); } + + + PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h) { // virtual so disable dispatch return static_cast<Fl_Pixmap*>(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<Fl_PNG_Image*>(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<Fl_PNM_Image*>(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<const void*>(static_cast<Fl_RGB_Image*>(i)->array); +} + + + + void fl_rgb_image_draw2(RGBIMAGE i, int x, int y) { static_cast<Fl_RGB_Image*>(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; + |