From dee76d5884c6f079ea3a2387d07289534a51a0c1 Mon Sep 17 00:00:00 2001
From: Jedidiah Barber <contact@jedbarber.id.au>
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<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;
+
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 @@
<td><pre>
int alloc_array;
</pre></td>
-<td> </td>
+<td>Intentionally left unbound.</td>
</tr>
<tr>
<td><pre>
const uchar * array;
</pre></td>
-<td> </td>
+<td><pre>
+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;
+</pre></td>
</tr>
</table>
@@ -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;
</pre></td>
</tr>
@@ -120,9 +156,9 @@ virtual void draw(int X, int Y, int W, int H,
</pre></td>
<td><pre>
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);
</pre></td>
</tr>
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 @@
<td><pre>
static const int ERR_FILE_ACCESS = -2;
</pre></td>
-<td> </td>
+<td>See the errors table.</td>
</tr>
<tr>
<td><pre>
static const int ERR_FORMAT = -3;
</pre></td>
-<td> </td>
+<td>See the errors table.</td>
</tr>
<tr>
<td><pre>
static const int ERR_NO_IMAGE = -1;
</pre></td>
-<td> </td>
+<td>See the errors table.</td>
</tr>
</table>
@@ -192,20 +192,7 @@ function Copy
<td><pre>
int count() const;
</pre></td>
-<td><pre>
-function Get_Data_Count
- (This : in Image)
- return Natural;
-</pre></td>
- </tr>
-
- <tr>
-<td> </td>
-<td><pre>
-function Get_Data_Size
- (This : in Image)
- return Natural;
-</pre></td>
+<td>Intentionally left unbound.</td>
</tr>
<tr>
@@ -223,53 +210,8 @@ function Get_D
<td><pre>
const char * const * data() const;
</pre></td>
-<td><pre>
-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;
-</pre></td>
+<td>See Data_Size, Get_Datum, Set_Datum, Slice, Overwrite, All_Data subprograms
+in Fl_Bitmap and Fl_RGB_Image.</td>
</tr>
<tr>
@@ -289,9 +231,9 @@ virtual void draw(int X, int Y, int W, int H,
</pre></td>
<td><pre>
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);
</pre></td>
</tr>
@@ -357,7 +299,7 @@ virtual void label(Fl_Menu_Item *m);
int ld() const;
</pre></td>
<td><pre>
-function Get_Line_Data
+function Get_Line_Size
(This : in Image)
return Natural;
</pre></td>
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 @@
<td>Pixmap_Reference</td>
</tr>
+ <tr>
+ <td>char *</td>
+ <td>Header</td>
+ </tr>
+
+ <tr>
+ <td>char</td>
+ <td>Color_Kind</td>
+ </tr>
+
+ <tr>
+ <td>char *</td>
+ <td>Color_Definition</td>
+ </tr>
+
+ <tr>
+ <td>char **</td>
+ <td>Color_Definition_Array</td>
+ </tr>
+
+ <tr>
+ <td>char **</td>
+ <td>Pixmap_Data</td>
+ </tr>
+
</table>
@@ -72,7 +97,19 @@ Fl_Pixmap(const char *const *D);
Fl_Pixmap(const uchar *const *D);
</pre></td>
-<td> </td>
+<td><pre>
+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;
+</pre></td>
</tr>
</table>
@@ -134,9 +171,9 @@ virtual void draw(int X, int Y, int W, int H,
</pre></td>
<td><pre>
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);
</pre></td>
</tr>
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;
<td><pre>
const uchar * array;
</pre></td>
-<td>Intentionally left unbound.</td>
+<td><pre>
+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;
+</pre></td>
</tr>
</table>
@@ -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;
</pre></td>
</tr>
@@ -181,9 +220,9 @@ virtual void draw(int X, int Y, int W, int H,
</pre></td>
<td><pre>
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);
</pre></td>
</tr>
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);
</pre></td>
<td><pre>
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);
</pre></td>
</tr>
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