summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c_fl_bitmap.cpp15
-rw-r--r--src/c_fl_bitmap.h4
-rw-r--r--src/c_fl_image.cpp28
-rw-r--r--src/c_fl_image.h8
-rw-r--r--src/c_fl_jpeg_image.cpp5
-rw-r--r--src/c_fl_jpeg_image.h1
-rw-r--r--src/c_fl_pixmap.cpp10
-rw-r--r--src/c_fl_pixmap.h3
-rw-r--r--src/c_fl_png_image.cpp5
-rw-r--r--src/c_fl_png_image.h1
-rw-r--r--src/c_fl_rgb_image.cpp27
-rw-r--r--src/c_fl_rgb_image.h7
-rw-r--r--src/c_fl_shared_image.cpp20
-rw-r--r--src/c_fl_shared_image.h6
-rw-r--r--src/fltk-images-bitmaps-xbm.adb13
-rw-r--r--src/fltk-images-bitmaps-xbm.ads8
-rw-r--r--src/fltk-images-bitmaps.adb90
-rw-r--r--src/fltk-images-bitmaps.ads37
-rw-r--r--src/fltk-images-pixmaps-gif.adb18
-rw-r--r--src/fltk-images-pixmaps-gif.ads8
-rw-r--r--src/fltk-images-pixmaps-xpm.adb18
-rw-r--r--src/fltk-images-pixmaps-xpm.ads8
-rw-r--r--src/fltk-images-pixmaps.adb65
-rw-r--r--src/fltk-images-pixmaps.ads31
-rw-r--r--src/fltk-images-rgb-bmp.adb18
-rw-r--r--src/fltk-images-rgb-bmp.ads8
-rw-r--r--src/fltk-images-rgb-jpeg.adb43
-rw-r--r--src/fltk-images-rgb-jpeg.ads13
-rw-r--r--src/fltk-images-rgb-png.adb45
-rw-r--r--src/fltk-images-rgb-png.ads13
-rw-r--r--src/fltk-images-rgb-pnm.adb18
-rw-r--r--src/fltk-images-rgb-pnm.ads8
-rw-r--r--src/fltk-images-rgb.adb143
-rw-r--r--src/fltk-images-rgb.ads60
-rw-r--r--src/fltk-images-shared.adb76
-rw-r--r--src/fltk-images-shared.ads48
-rw-r--r--src/fltk-images.adb247
-rw-r--r--src/fltk-images.ads100
-rw-r--r--src/fltk.ads8
39 files changed, 1118 insertions, 166 deletions
diff --git a/src/c_fl_bitmap.cpp b/src/c_fl_bitmap.cpp
index 38665b5..6a38b1e 100644
--- a/src/c_fl_bitmap.cpp
+++ b/src/c_fl_bitmap.cpp
@@ -6,11 +6,17 @@
+BITMAP new_fl_bitmap(void *data, int w, int h) {
+ Fl_Bitmap *b = new Fl_Bitmap(reinterpret_cast<uchar*>(data), w, h);
+ return b;
+}
+
void free_fl_bitmap(BITMAP b) {
delete reinterpret_cast<Fl_Bitmap*>(b);
}
BITMAP fl_bitmap_copy(BITMAP b, int w, int h) {
+ // virtual so disable dispatch
return reinterpret_cast<Fl_Bitmap*>(b)->Fl_Bitmap::copy(w, h);
}
@@ -21,11 +27,20 @@ BITMAP fl_bitmap_copy2(BITMAP b) {
+void fl_bitmap_uncache(BITMAP b) {
+ // virtual so disable dispatch
+ reinterpret_cast<Fl_Bitmap*>(b)->Fl_Bitmap::uncache();
+}
+
+
+
+
void fl_bitmap_draw2(BITMAP b, int x, int y) {
reinterpret_cast<Fl_Bitmap*>(b)->draw(x, y);
}
void fl_bitmap_draw(BITMAP b, int x, int y, int w, int h, int cx, int cy) {
+ // virtual so disable dispatch
reinterpret_cast<Fl_Bitmap*>(b)->Fl_Bitmap::draw(x, y, w, h, cx, cy);
}
diff --git a/src/c_fl_bitmap.h b/src/c_fl_bitmap.h
index 219af14..f2290dd 100644
--- a/src/c_fl_bitmap.h
+++ b/src/c_fl_bitmap.h
@@ -11,11 +11,15 @@ typedef void* BITMAP;
+extern "C" BITMAP new_fl_bitmap(void *data, int w, int h);
extern "C" void free_fl_bitmap(BITMAP b);
extern "C" BITMAP fl_bitmap_copy(BITMAP b, int w, int h);
extern "C" BITMAP fl_bitmap_copy2(BITMAP b);
+extern "C" void fl_bitmap_uncache(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/src/c_fl_image.cpp b/src/c_fl_image.cpp
index 07b6d4d..6e42280 100644
--- a/src/c_fl_image.cpp
+++ b/src/c_fl_image.cpp
@@ -77,6 +77,11 @@ int fl_image_fail(IMAGE i) {
}
}
+void fl_image_uncache(IMAGE i) {
+ // virtual so disable dispatch
+ reinterpret_cast<Fl_Image*>(i)->Fl_Image::uncache();
+}
+
@@ -92,6 +97,29 @@ int fl_image_d(IMAGE i) {
return reinterpret_cast<Fl_Image*>(i)->d();
}
+int fl_image_ld(IMAGE i) {
+ return reinterpret_cast<Fl_Image*>(i)->ld();
+}
+
+int fl_image_count(IMAGE i) {
+ return reinterpret_cast<Fl_Image*>(i)->count();
+}
+
+
+
+
+const void * fl_image_data(IMAGE i) {
+ return reinterpret_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;
+}
+
diff --git a/src/c_fl_image.h b/src/c_fl_image.h
index 29e1b93..2915ab7 100644
--- a/src/c_fl_image.h
+++ b/src/c_fl_image.h
@@ -29,11 +29,19 @@ extern "C" void fl_image_desaturate(IMAGE i);
extern "C" void fl_image_inactive(IMAGE i);
extern "C" int fl_image_fail(IMAGE i);
+extern "C" void fl_image_uncache(IMAGE i);
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" void fl_image_draw(IMAGE i, int x, int y);
diff --git a/src/c_fl_jpeg_image.cpp b/src/c_fl_jpeg_image.cpp
index 93ab22d..be99257 100644
--- a/src/c_fl_jpeg_image.cpp
+++ b/src/c_fl_jpeg_image.cpp
@@ -11,6 +11,11 @@ JPEG_IMAGE new_fl_jpeg_image(const char * f) {
return j;
}
+JPEG_IMAGE new_fl_jpeg_image2(const char *n, void *data) {
+ Fl_JPEG_Image *j = new Fl_JPEG_Image(n, reinterpret_cast<uchar*>(data));
+ return j;
+}
+
void free_fl_jpeg_image(JPEG_IMAGE j) {
delete reinterpret_cast<Fl_JPEG_Image*>(j);
}
diff --git a/src/c_fl_jpeg_image.h b/src/c_fl_jpeg_image.h
index c81bd6f..1592465 100644
--- a/src/c_fl_jpeg_image.h
+++ b/src/c_fl_jpeg_image.h
@@ -12,6 +12,7 @@ typedef void* JPEG_IMAGE;
extern "C" JPEG_IMAGE new_fl_jpeg_image(const char * f);
+extern "C" JPEG_IMAGE new_fl_jpeg_image2(const char * n, void *data);
extern "C" void free_fl_jpeg_image(JPEG_IMAGE j);
diff --git a/src/c_fl_pixmap.cpp b/src/c_fl_pixmap.cpp
index 18e6b5d..322f98c 100644
--- a/src/c_fl_pixmap.cpp
+++ b/src/c_fl_pixmap.cpp
@@ -11,6 +11,7 @@ void free_fl_pixmap(PIXMAP b) {
}
PIXMAP fl_pixmap_copy(PIXMAP b, int w, int h) {
+ // virtual so disable dispatch
return reinterpret_cast<Fl_Pixmap*>(b)->Fl_Pixmap::copy(w, h);
}
@@ -34,11 +35,20 @@ void fl_pixmap_desaturate(PIXMAP p) {
+void fl_pixmap_uncache(PIXMAP p) {
+ // virtual so disable dispatch
+ reinterpret_cast<Fl_Pixmap*>(p)->Fl_Pixmap::uncache();
+}
+
+
+
+
void fl_pixmap_draw2(PIXMAP b, int x, int y) {
reinterpret_cast<Fl_Pixmap*>(b)->draw(x, y);
}
void fl_pixmap_draw(PIXMAP b, int x, int y, int w, int h, int cx, int cy) {
+ // virtual so disable dispatch
reinterpret_cast<Fl_Pixmap*>(b)->Fl_Pixmap::draw(x, y, w, h, cx, cy);
}
diff --git a/src/c_fl_pixmap.h b/src/c_fl_pixmap.h
index de987a8..1d5a57a 100644
--- a/src/c_fl_pixmap.h
+++ b/src/c_fl_pixmap.h
@@ -20,6 +20,9 @@ extern "C" void fl_pixmap_color_average(PIXMAP p, int c, float b);
extern "C" void fl_pixmap_desaturate(PIXMAP p);
+extern "C" void fl_pixmap_uncache(PIXMAP p);
+
+
extern "C" void fl_pixmap_draw2(PIXMAP b, int x, int y);
extern "C" void fl_pixmap_draw(PIXMAP b, int x, int y, int w, int h, int cx, int cy);
diff --git a/src/c_fl_png_image.cpp b/src/c_fl_png_image.cpp
index 132c567..b4fb29a 100644
--- a/src/c_fl_png_image.cpp
+++ b/src/c_fl_png_image.cpp
@@ -11,6 +11,11 @@ PNG_IMAGE new_fl_png_image(const char * f) {
return p;
}
+PNG_IMAGE new_fl_png_image2(const char *name, void *data, int size) {
+ Fl_PNG_Image *p = new Fl_PNG_Image(name, reinterpret_cast<uchar*>(data), size);
+ return p;
+}
+
void free_fl_png_image(PNG_IMAGE p) {
delete reinterpret_cast<Fl_PNG_Image*>(p);
}
diff --git a/src/c_fl_png_image.h b/src/c_fl_png_image.h
index b9901ea..7e9a25c 100644
--- a/src/c_fl_png_image.h
+++ b/src/c_fl_png_image.h
@@ -12,6 +12,7 @@ typedef void* PNG_IMAGE;
extern "C" PNG_IMAGE new_fl_png_image(const char * f);
+extern "C" PNG_IMAGE new_fl_png_image2(const char *name, void *data, int size);
extern "C" void free_fl_png_image(PNG_IMAGE p);
diff --git a/src/c_fl_rgb_image.cpp b/src/c_fl_rgb_image.cpp
index 3c0fec6..adde3e4 100644
--- a/src/c_fl_rgb_image.cpp
+++ b/src/c_fl_rgb_image.cpp
@@ -1,15 +1,34 @@
#include <FL/Fl_RGB_Image.H>
+#include <FL/Fl_Pixmap.H>
#include "c_fl_rgb_image.h"
+RGB_IMAGE new_fl_rgb_image(void *data, int w, int h, int d, int ld) {
+ Fl_RGB_Image *rgb = new Fl_RGB_Image(reinterpret_cast<uchar*>(data), w, h, d, ld);
+ return rgb;
+}
+
+RGB_IMAGE new_fl_rgb_image2(void *pix, unsigned int c) {
+ Fl_RGB_Image *rgb = new Fl_RGB_Image(reinterpret_cast<Fl_Pixmap*>(pix), c);
+ return rgb;
+}
+
void free_fl_rgb_image(RGB_IMAGE i) {
delete reinterpret_cast<Fl_RGB_Image*>(i);
}
+size_t fl_rgb_image_get_max_size() {
+ return Fl_RGB_Image::max_size();
+}
+
+void fl_rgb_image_set_max_size(size_t v) {
+ Fl_RGB_Image::max_size(v);
+}
+
RGB_IMAGE fl_rgb_image_copy(RGB_IMAGE i, int w, int h) {
// virtual so disable dispatch
return reinterpret_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::copy(w, h);
@@ -35,6 +54,14 @@ void fl_rgb_image_desaturate(RGB_IMAGE i) {
+void fl_rgb_image_uncache(RGB_IMAGE i) {
+ // virtual so disable dispatch
+ reinterpret_cast<Fl_RGB_Image*>(i)->Fl_RGB_Image::uncache();
+}
+
+
+
+
void fl_rgb_image_draw2(RGB_IMAGE i, int x, int y) {
reinterpret_cast<Fl_RGB_Image*>(i)->draw(x, y);
}
diff --git a/src/c_fl_rgb_image.h b/src/c_fl_rgb_image.h
index 3ec4c58..0e32539 100644
--- a/src/c_fl_rgb_image.h
+++ b/src/c_fl_rgb_image.h
@@ -11,7 +11,11 @@ typedef void* RGB_IMAGE;
+extern "C" RGB_IMAGE new_fl_rgb_image(void *data, int w, int h, int d, int ld);
+extern "C" RGB_IMAGE new_fl_rgb_image2(void *pix, unsigned int c);
extern "C" void free_fl_rgb_image(RGB_IMAGE i);
+extern "C" size_t fl_rgb_image_get_max_size();
+extern "C" void fl_rgb_image_set_max_size(size_t v);
extern "C" RGB_IMAGE fl_rgb_image_copy(RGB_IMAGE i, int w, int h);
extern "C" RGB_IMAGE fl_rgb_image_copy2(RGB_IMAGE i);
@@ -22,6 +26,9 @@ extern "C" void fl_rgb_image_color_average(RGB_IMAGE i, int c, float b);
extern "C" void fl_rgb_image_desaturate(RGB_IMAGE i);
+extern "C" void fl_rgb_image_uncache(RGB_IMAGE i);
+
+
extern "C" void fl_rgb_image_draw2(RGB_IMAGE i, int x, int y);
extern "C" void fl_rgb_image_draw(RGB_IMAGE i, int x, int y, int w, int h, int cx, int cy);
diff --git a/src/c_fl_shared_image.cpp b/src/c_fl_shared_image.cpp
index b7fcdb2..fd09519 100644
--- a/src/c_fl_shared_image.cpp
+++ b/src/c_fl_shared_image.cpp
@@ -48,14 +48,31 @@ void fl_shared_image_desaturate(SHARED_IMAGE i) {
+int fl_shared_image_num_images() {
+ return Fl_Shared_Image::num_images();
+}
+
const char * fl_shared_image_name(SHARED_IMAGE i) {
return reinterpret_cast<Fl_Shared_Image*>(i)->name();
}
+int fl_shared_image_original(SHARED_IMAGE i) {
+ return reinterpret_cast<Fl_Shared_Image*>(i)->original();
+}
+
+int fl_shared_image_refcount(SHARED_IMAGE i) {
+ return reinterpret_cast<Fl_Shared_Image*>(i)->refcount();
+}
+
void fl_shared_image_reload(SHARED_IMAGE i) {
reinterpret_cast<Fl_Shared_Image*>(i)->reload();
}
+void fl_shared_image_uncache(SHARED_IMAGE i) {
+ // virtual so disable dispatch
+ reinterpret_cast<Fl_Shared_Image*>(i)->uncache();
+}
+
@@ -67,9 +84,6 @@ void fl_shared_image_scale(SHARED_IMAGE i, int w, int h, int p, int e) {
reinterpret_cast<Fl_Shared_Image*>(i)->scale(w, h, p, e);
}
-
-
-
void fl_shared_image_draw(SHARED_IMAGE i, int x, int y, int w, int h, int cx, int cy) {
// virtual so disable dispatch
reinterpret_cast<Fl_Shared_Image*>(i)->Fl_Shared_Image::draw(x, y, w, h, cx, cy);
diff --git a/src/c_fl_shared_image.h b/src/c_fl_shared_image.h
index 5555530..d7d57f2 100644
--- a/src/c_fl_shared_image.h
+++ b/src/c_fl_shared_image.h
@@ -25,14 +25,16 @@ extern "C" void fl_shared_image_color_average(SHARED_IMAGE i, int c, float b);
extern "C" void fl_shared_image_desaturate(SHARED_IMAGE i);
+extern "C" int fl_shared_image_num_images();
extern "C" const char * fl_shared_image_name(SHARED_IMAGE i);
+extern "C" int fl_shared_image_original(SHARED_IMAGE i);
+extern "C" int fl_shared_image_refcount(SHARED_IMAGE i);
extern "C" void fl_shared_image_reload(SHARED_IMAGE i);
+extern "C" void fl_shared_image_uncache(SHARED_IMAGE i);
extern "C" void fl_shared_image_scaling_algorithm(int v);
extern "C" void fl_shared_image_scale(SHARED_IMAGE i, int w, int h, int p, int e);
-
-
extern "C" void fl_shared_image_draw(SHARED_IMAGE i, int x, int y, int w, int h, int cx, int cy);
extern "C" void fl_shared_image_draw2(SHARED_IMAGE i, int x, int y);
diff --git a/src/fltk-images-bitmaps-xbm.adb b/src/fltk-images-bitmaps-xbm.adb
index 3732801..d8059ff 100644
--- a/src/fltk-images-bitmaps-xbm.adb
+++ b/src/fltk-images-bitmaps-xbm.adb
@@ -42,6 +42,10 @@ package body FLTK.Images.Bitmaps.XBM is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -58,12 +62,9 @@ package body FLTK.Images.Bitmaps.XBM is
-- 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;
+ when 2 => raise File_Access_Error;
+ when 3 => raise Format_Error;
+ when others => null;
end case;
end return;
end Create;
diff --git a/src/fltk-images-bitmaps-xbm.ads b/src/fltk-images-bitmaps-xbm.ads
index a242538..f39589f 100644
--- a/src/fltk-images-bitmaps-xbm.ads
+++ b/src/fltk-images-bitmaps-xbm.ads
@@ -3,6 +3,10 @@
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
@@ -11,6 +15,10 @@ package FLTK.Images.Bitmaps.XBM is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
diff --git a/src/fltk-images-bitmaps.adb b/src/fltk-images-bitmaps.adb
index ac4bf1e..3ddfa93 100644
--- a/src/fltk-images-bitmaps.adb
+++ b/src/fltk-images-bitmaps.adb
@@ -13,6 +13,13 @@ use type
package body FLTK.Images.Bitmaps is
+ function new_fl_bitmap
+ (D : in System.Address;
+ W, H : in Interfaces.C.int)
+ return System.Address;
+ pragma Import (C, new_fl_bitmap, "new_fl_bitmap");
+ pragma Inline (new_fl_bitmap);
+
procedure free_fl_bitmap
(I : in System.Address);
pragma Import (C, free_fl_bitmap, "free_fl_bitmap");
@@ -34,6 +41,14 @@ package body FLTK.Images.Bitmaps is
+ procedure fl_bitmap_uncache
+ (I : in System.Address);
+ pragma Import (C, fl_bitmap_uncache, "fl_bitmap_uncache");
+ pragma Inline (fl_bitmap_uncache);
+
+
+
+
procedure fl_bitmap_draw2
(I : in System.Address;
X, Y : in Interfaces.C.int);
@@ -64,6 +79,39 @@ package body FLTK.Images.Bitmaps is
+ --------------------
+ -- Construction --
+ --------------------
+
+ package body Forge is
+
+ function Create
+ (Data : in Color_Component_Array;
+ Width, Height : in Natural)
+ return Bitmap is
+ begin
+ return This : Bitmap do
+ This.Void_Ptr := new_fl_bitmap
+ (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;
+
+
function Copy
(This : in Bitmap;
Width, Height : in Natural)
@@ -71,9 +119,9 @@ package body FLTK.Images.Bitmaps is
begin
return Copied : Bitmap do
Copied.Void_Ptr := fl_bitmap_copy
- (This.Void_Ptr,
- Interfaces.C.int (Width),
- Interfaces.C.int (Height));
+ (This.Void_Ptr,
+ Interfaces.C.int (Width),
+ Interfaces.C.int (Height));
end return;
end Copy;
@@ -90,14 +138,30 @@ package body FLTK.Images.Bitmaps is
+ ----------------
+ -- Activity --
+ ----------------
+
+ procedure Uncache
+ (This : in out Bitmap) is
+ begin
+ fl_bitmap_uncache (This.Void_Ptr);
+ end Uncache;
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Draw
(This : in Bitmap;
X, Y : in Integer) is
begin
fl_bitmap_draw2
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y));
end Draw;
@@ -107,13 +171,13 @@ package body FLTK.Images.Bitmaps is
CX, CY : in Integer := 0) is
begin
fl_bitmap_draw
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y),
- Interfaces.C.int (W),
- Interfaces.C.int (H),
- Interfaces.C.int (CX),
- Interfaces.C.int (CY));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y),
+ Interfaces.C.int (W),
+ Interfaces.C.int (H),
+ Interfaces.C.int (CX),
+ Interfaces.C.int (CY));
end Draw;
diff --git a/src/fltk-images-bitmaps.ads b/src/fltk-images-bitmaps.ads
index 14df718..cf35396 100644
--- a/src/fltk-images-bitmaps.ads
+++ b/src/fltk-images-bitmaps.ads
@@ -3,6 +3,10 @@
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
@@ -11,6 +15,22 @@ package FLTK.Images.Bitmaps is
+ --------------------
+ -- Construction --
+ --------------------
+
+ 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
+
+ function Create
+ (Data : in Color_Component_Array;
+ Width, Height : in Natural)
+ return Bitmap;
+
+ end Forge;
+
function Copy
(This : in Bitmap;
Width, Height : in Natural)
@@ -23,6 +43,20 @@ package FLTK.Images.Bitmaps is
+ ----------------
+ -- Activity --
+ ----------------
+
+ procedure Uncache
+ (This : in out Bitmap);
+
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Draw
(This : in Bitmap;
X, Y : in Integer);
@@ -42,9 +76,8 @@ private
(This : in out Bitmap);
-
-
pragma Inline (Copy);
+ pragma Inline (Uncache);
pragma Inline (Draw);
diff --git a/src/fltk-images-pixmaps-gif.adb b/src/fltk-images-pixmaps-gif.adb
index 579d8b7..546ed3e 100644
--- a/src/fltk-images-pixmaps-gif.adb
+++ b/src/fltk-images-pixmaps-gif.adb
@@ -42,6 +42,10 @@ package body FLTK.Images.Pixmaps.GIF is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -50,16 +54,12 @@ package body FLTK.Images.Pixmaps.GIF is
begin
return This : GIF_Image do
This.Void_Ptr := new_fl_gif_image
- (Interfaces.C.To_C (Filename));
+ (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;
+ 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;
diff --git a/src/fltk-images-pixmaps-gif.ads b/src/fltk-images-pixmaps-gif.ads
index 18e31b9..4936617 100644
--- a/src/fltk-images-pixmaps-gif.ads
+++ b/src/fltk-images-pixmaps-gif.ads
@@ -3,6 +3,10 @@
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
@@ -11,6 +15,10 @@ package FLTK.Images.Pixmaps.GIF is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
diff --git a/src/fltk-images-pixmaps-xpm.adb b/src/fltk-images-pixmaps-xpm.adb
index 36c4180..136aee9 100644
--- a/src/fltk-images-pixmaps-xpm.adb
+++ b/src/fltk-images-pixmaps-xpm.adb
@@ -42,6 +42,10 @@ package body FLTK.Images.Pixmaps.XPM is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -50,16 +54,12 @@ package body FLTK.Images.Pixmaps.XPM is
begin
return This : XPM_Image do
This.Void_Ptr := new_fl_xpm_image
- (Interfaces.C.To_C (Filename));
+ (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;
+ 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;
diff --git a/src/fltk-images-pixmaps-xpm.ads b/src/fltk-images-pixmaps-xpm.ads
index e888632..004e2a4 100644
--- a/src/fltk-images-pixmaps-xpm.ads
+++ b/src/fltk-images-pixmaps-xpm.ads
@@ -3,6 +3,10 @@
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
@@ -11,6 +15,10 @@ package FLTK.Images.Pixmaps.XPM is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
diff --git a/src/fltk-images-pixmaps.adb b/src/fltk-images-pixmaps.adb
index dc77d24..c8db506 100644
--- a/src/fltk-images-pixmaps.adb
+++ b/src/fltk-images-pixmaps.adb
@@ -49,6 +49,14 @@ package body FLTK.Images.Pixmaps is
+ procedure fl_pixmap_uncache
+ (I : in System.Address);
+ pragma Import (C, fl_pixmap_uncache, "fl_pixmap_uncache");
+ pragma Inline (fl_pixmap_uncache);
+
+
+
+
procedure fl_pixmap_draw2
(I : in System.Address;
X, Y : in Interfaces.C.int);
@@ -79,6 +87,10 @@ package body FLTK.Images.Pixmaps is
+ --------------------
+ -- Construction --
+ --------------------
+
function Copy
(This : in Pixmap;
Width, Height : in Natural)
@@ -86,9 +98,9 @@ package body FLTK.Images.Pixmaps is
begin
return Copied : Pixmap do
Copied.Void_Ptr := fl_pixmap_copy
- (This.Void_Ptr,
- Interfaces.C.int (Width),
- Interfaces.C.int (Height));
+ (This.Void_Ptr,
+ Interfaces.C.int (Width),
+ Interfaces.C.int (Height));
end return;
end Copy;
@@ -105,15 +117,19 @@ package body FLTK.Images.Pixmaps is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out Pixmap;
Col : in Color;
Amount : in Blend) is
begin
fl_pixmap_color_average
- (This.Void_Ptr,
- Interfaces.C.int (Col),
- Interfaces.C.C_float (Amount));
+ (This.Void_Ptr,
+ Interfaces.C.int (Col),
+ Interfaces.C.C_float (Amount));
end Color_Average;
@@ -126,14 +142,31 @@ package body FLTK.Images.Pixmaps is
+ ----------------
+ -- Activity --
+ ----------------
+
+ procedure Uncache
+ (This : in out Pixmap) is
+ begin
+ fl_pixmap_uncache (This.Void_Ptr);
+ end Uncache;
+
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Draw
(This : in Pixmap;
X, Y : in Integer) is
begin
fl_pixmap_draw2
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y));
end Draw;
@@ -143,13 +176,13 @@ package body FLTK.Images.Pixmaps is
CX, CY : in Integer := 0) is
begin
fl_pixmap_draw
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y),
- Interfaces.C.int (W),
- Interfaces.C.int (H),
- Interfaces.C.int (CX),
- Interfaces.C.int (CY));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y),
+ Interfaces.C.int (W),
+ Interfaces.C.int (H),
+ Interfaces.C.int (CX),
+ Interfaces.C.int (CY));
end Draw;
diff --git a/src/fltk-images-pixmaps.ads b/src/fltk-images-pixmaps.ads
index b72c382..a935e72 100644
--- a/src/fltk-images-pixmaps.ads
+++ b/src/fltk-images-pixmaps.ads
@@ -3,6 +3,10 @@
package FLTK.Images.Pixmaps is
+ -------------
+ -- Types --
+ -------------
+
type Pixmap is new Image with private;
type Pixmap_Reference (Data : not null access Pixmap'Class) is limited null record
@@ -11,6 +15,10 @@ package FLTK.Images.Pixmaps is
+ --------------------
+ -- Construction --
+ --------------------
+
function Copy
(This : in Pixmap;
Width, Height : in Natural)
@@ -23,6 +31,10 @@ package FLTK.Images.Pixmaps is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out Pixmap;
Col : in Color;
@@ -34,6 +46,20 @@ package FLTK.Images.Pixmaps is
+ ----------------
+ -- Activity --
+ ----------------
+
+ procedure Uncache
+ (This : in out Pixmap);
+
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Draw
(This : in Pixmap;
X, Y : in Integer);
@@ -53,12 +79,13 @@ private
(This : in out Pixmap);
-
-
pragma Inline (Color_Average);
pragma Inline (Desaturate);
+ pragma Inline (Uncache);
+
+
pragma Inline (Copy);
pragma Inline (Draw);
diff --git a/src/fltk-images-rgb-bmp.adb b/src/fltk-images-rgb-bmp.adb
index 31162f9..6a982d0 100644
--- a/src/fltk-images-rgb-bmp.adb
+++ b/src/fltk-images-rgb-bmp.adb
@@ -42,6 +42,10 @@ package body FLTK.Images.RGB.BMP is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -50,16 +54,12 @@ package body FLTK.Images.RGB.BMP is
begin
return This : BMP_Image do
This.Void_Ptr := new_fl_bmp_image
- (Interfaces.C.To_C (Filename));
+ (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;
+ 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;
diff --git a/src/fltk-images-rgb-bmp.ads b/src/fltk-images-rgb-bmp.ads
index bb4fa48..dbbeea1 100644
--- a/src/fltk-images-rgb-bmp.ads
+++ b/src/fltk-images-rgb-bmp.ads
@@ -3,6 +3,10 @@
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
@@ -11,6 +15,10 @@ package FLTK.Images.RGB.BMP is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
diff --git a/src/fltk-images-rgb-jpeg.adb b/src/fltk-images-rgb-jpeg.adb
index 9448570..9d7afe1 100644
--- a/src/fltk-images-rgb-jpeg.adb
+++ b/src/fltk-images-rgb-jpeg.adb
@@ -19,6 +19,13 @@ package body FLTK.Images.RGB.JPEG is
pragma Import (C, new_fl_jpeg_image, "new_fl_jpeg_image");
pragma Inline (new_fl_jpeg_image);
+ function new_fl_jpeg_image2
+ (N : in Interfaces.C.char_array;
+ D : in System.Address)
+ return System.Address;
+ pragma Import (C, new_fl_jpeg_image2, "new_fl_jpeg_image2");
+ pragma Inline (new_fl_jpeg_image2);
+
procedure free_fl_jpeg_image
(P : in System.Address);
pragma Import (C, free_fl_jpeg_image, "free_fl_jpeg_image");
@@ -42,6 +49,10 @@ package body FLTK.Images.RGB.JPEG is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -50,16 +61,30 @@ package body FLTK.Images.RGB.JPEG is
begin
return This : JPEG_Image do
This.Void_Ptr := new_fl_jpeg_image
- (Interfaces.C.To_C (Filename));
+ (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;
+ end return;
+ end Create;
+
+ function Create
+ (Name : in String := "";
+ Data : in Color_Component_Array)
+ return JPEG_Image is
+ begin
+ return This : JPEG_Image do
+ This.Void_Ptr := new_fl_jpeg_image2
+ (Interfaces.C.To_C (Name),
+ 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;
+ 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;
diff --git a/src/fltk-images-rgb-jpeg.ads b/src/fltk-images-rgb-jpeg.ads
index c7fafd8..742ae4e 100644
--- a/src/fltk-images-rgb-jpeg.ads
+++ b/src/fltk-images-rgb-jpeg.ads
@@ -3,6 +3,10 @@
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
@@ -11,12 +15,21 @@ package FLTK.Images.RGB.JPEG is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
(Filename : in String)
return JPEG_Image;
+ function Create
+ (Name : in String := "";
+ Data : in Color_Component_Array)
+ return JPEG_Image;
+
end Forge;
diff --git a/src/fltk-images-rgb-png.adb b/src/fltk-images-rgb-png.adb
index 8cb97ce..6023f82 100644
--- a/src/fltk-images-rgb-png.adb
+++ b/src/fltk-images-rgb-png.adb
@@ -19,6 +19,14 @@ package body FLTK.Images.RGB.PNG is
pragma Import (C, new_fl_png_image, "new_fl_png_image");
pragma Inline (new_fl_png_image);
+ function new_fl_png_image2
+ (N : in Interfaces.C.char_array;
+ D : in System.Address;
+ S : in Interfaces.C.int)
+ return System.Address;
+ pragma Import (C, new_fl_png_image2, "new_fl_png_image2");
+ pragma Inline (new_fl_png_image2);
+
procedure free_fl_png_image
(P : in System.Address);
pragma Import (C, free_fl_png_image, "free_fl_png_image");
@@ -42,6 +50,10 @@ package body FLTK.Images.RGB.PNG is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -50,16 +62,31 @@ package body FLTK.Images.RGB.PNG is
begin
return This : PNG_Image do
This.Void_Ptr := new_fl_png_image
- (Interfaces.C.To_C (Filename));
+ (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;
+ end return;
+ end Create;
+
+ function Create
+ (Name : in String := "";
+ Data : in Color_Component_Array)
+ return PNG_Image is
+ begin
+ return This : PNG_Image do
+ This.Void_Ptr := new_fl_png_image2
+ (Interfaces.C.To_C (Name),
+ 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;
+ 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;
diff --git a/src/fltk-images-rgb-png.ads b/src/fltk-images-rgb-png.ads
index 760f84d..a4c270a 100644
--- a/src/fltk-images-rgb-png.ads
+++ b/src/fltk-images-rgb-png.ads
@@ -3,6 +3,10 @@
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
@@ -11,12 +15,21 @@ package FLTK.Images.RGB.PNG is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
(Filename : in String)
return PNG_Image;
+ function Create
+ (Name : in String := "";
+ Data : in Color_Component_Array)
+ return PNG_Image;
+
end Forge;
diff --git a/src/fltk-images-rgb-pnm.adb b/src/fltk-images-rgb-pnm.adb
index 95247a1..6b0e515 100644
--- a/src/fltk-images-rgb-pnm.adb
+++ b/src/fltk-images-rgb-pnm.adb
@@ -42,6 +42,10 @@ package body FLTK.Images.RGB.PNM is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -50,16 +54,12 @@ package body FLTK.Images.RGB.PNM is
begin
return This : PNM_Image do
This.Void_Ptr := new_fl_pnm_image
- (Interfaces.C.To_C (Filename));
+ (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;
+ 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;
diff --git a/src/fltk-images-rgb-pnm.ads b/src/fltk-images-rgb-pnm.ads
index 92743ea..f895d73 100644
--- a/src/fltk-images-rgb-pnm.ads
+++ b/src/fltk-images-rgb-pnm.ads
@@ -3,6 +3,10 @@
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
@@ -11,6 +15,10 @@ package FLTK.Images.RGB.PNM is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
diff --git a/src/fltk-images-rgb.adb b/src/fltk-images-rgb.adb
index 8e3e36f..4382e93 100644
--- a/src/fltk-images-rgb.adb
+++ b/src/fltk-images-rgb.adb
@@ -13,11 +13,35 @@ use type
package body FLTK.Images.RGB is
+ function new_fl_rgb_image
+ (Data : in System.Address;
+ W, H, D, L : in Interfaces.C.int)
+ return System.Address;
+ pragma Import (C, new_fl_rgb_image, "new_fl_rgb_image");
+ pragma Inline (new_fl_rgb_image);
+
+ function new_fl_rgb_image2
+ (P : in System.Address;
+ C : in Interfaces.C.unsigned)
+ return System.Address;
+ pragma Import (C, new_fl_rgb_image2, "new_fl_rgb_image2");
+ pragma Inline (new_fl_rgb_image2);
+
procedure free_fl_rgb_image
(I : in System.Address);
pragma Import (C, free_fl_rgb_image, "free_fl_rgb_image");
pragma Inline (free_fl_rgb_image);
+ function fl_rgb_image_get_max_size
+ return Interfaces.C.size_t;
+ pragma Import (C, fl_rgb_image_get_max_size, "fl_rgb_image_get_max_size");
+ pragma Inline (fl_rgb_image_get_max_size);
+
+ procedure fl_rgb_image_set_max_size
+ (V : in Interfaces.C.size_t);
+ pragma Import (C, fl_rgb_image_set_max_size, "fl_rgb_image_set_max_size");
+ pragma Inline (fl_rgb_image_set_max_size);
+
function fl_rgb_image_copy
(I : in System.Address;
W, H : in Interfaces.C.int)
@@ -49,6 +73,14 @@ package body FLTK.Images.RGB is
+ procedure fl_rgb_image_uncache
+ (I : in System.Address);
+ pragma Import (C, fl_rgb_image_uncache, "fl_rgb_image_uncache");
+ pragma Inline (fl_rgb_image_uncache);
+
+
+
+
procedure fl_rgb_image_draw2
(I : in System.Address;
X, Y : in Interfaces.C.int);
@@ -79,6 +111,70 @@ package body FLTK.Images.RGB is
+ --------------------
+ -- Construction --
+ --------------------
+
+ package body Forge is
+
+ function Create
+ (Data : in Color_Component_Array;
+ Width, Height : in Natural;
+ Depth : in Natural := 3;
+ Line_Data : in Natural := 0)
+ return RGB_Image is
+ begin
+ return This : RGB_Image do
+ This.Void_Ptr := new_fl_rgb_image
+ (Data (Data'First)'Address,
+ Interfaces.C.int (Width),
+ Interfaces.C.int (Height),
+ Interfaces.C.int (Depth),
+ Interfaces.C.int (Line_Data));
+ case fl_image_fail (This.Void_Ptr) is
+ when 1 => raise No_Image_Error;
+ when 2 => raise File_Access_Error;
+ when 3 => raise Format_Error;
+ when others => null;
+ end case;
+ end return;
+ end Create;
+
+ function Create
+ (Data : in FLTK.Images.Pixmaps.Pixmap'Class;
+ Background : in Color := Background_Color)
+ return RGB_Image is
+ begin
+ return This : RGB_Image do
+ This.Void_Ptr := new_fl_rgb_image2
+ (Wrapper (Data).Void_Ptr,
+ Interfaces.C.unsigned (Background));
+ case fl_image_fail (This.Void_Ptr) is
+ when 1 => raise No_Image_Error;
+ when 2 => raise File_Access_Error;
+ when 3 => raise Format_Error;
+ when others => null;
+ end case;
+ end return;
+ end Create;
+
+ end Forge;
+
+
+ function Get_Max_Size
+ return Natural is
+ begin
+ return Natural (fl_rgb_image_get_max_size);
+ end Get_Max_Size;
+
+
+ procedure Set_Max_Size
+ (Value : in Natural) is
+ begin
+ fl_rgb_image_set_max_size (Interfaces.C.size_t (Value));
+ end Set_Max_Size;
+
+
function Copy
(This : in RGB_Image;
Width, Height : in Natural)
@@ -105,15 +201,19 @@ package body FLTK.Images.RGB is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out RGB_Image;
Col : in Color;
Amount : in Blend) is
begin
fl_rgb_image_color_average
- (This.Void_Ptr,
- Interfaces.C.int (Col),
- Interfaces.C.C_float (Amount));
+ (This.Void_Ptr,
+ Interfaces.C.int (Col),
+ Interfaces.C.C_float (Amount));
end Color_Average;
@@ -126,14 +226,31 @@ package body FLTK.Images.RGB is
+ ----------------
+ -- Activity --
+ ----------------
+
+ procedure Uncache
+ (This : in out RGB_Image) is
+ begin
+ fl_rgb_image_uncache (This.Void_Ptr);
+ end Uncache;
+
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Draw
(This : in RGB_Image;
X, Y : in Integer) is
begin
fl_rgb_image_draw2
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y));
end Draw;
@@ -143,13 +260,13 @@ package body FLTK.Images.RGB is
CX, CY : in Integer := 0) is
begin
fl_rgb_image_draw
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y),
- Interfaces.C.int (W),
- Interfaces.C.int (H),
- Interfaces.C.int (CX),
- Interfaces.C.int (CY));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y),
+ Interfaces.C.int (W),
+ Interfaces.C.int (H),
+ Interfaces.C.int (CX),
+ Interfaces.C.int (CY));
end Draw;
diff --git a/src/fltk-images-rgb.ads b/src/fltk-images-rgb.ads
index 3aa3de0..67518c3 100644
--- a/src/fltk-images-rgb.ads
+++ b/src/fltk-images-rgb.ads
@@ -1,8 +1,17 @@
+with
+
+ FLTK.Images.Pixmaps;
+
+
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
@@ -11,6 +20,32 @@ package FLTK.Images.RGB is
+ --------------------
+ -- Construction --
+ --------------------
+
+ package Forge is
+
+ function Create
+ (Data : in Color_Component_Array;
+ Width, Height : in Natural;
+ Depth : in Natural := 3;
+ Line_Data : in Natural := 0)
+ return RGB_Image;
+
+ function Create
+ (Data : in FLTK.Images.Pixmaps.Pixmap'Class;
+ Background : in Color := Background_Color)
+ return RGB_Image;
+
+ end Forge;
+
+ function Get_Max_Size
+ return Natural;
+
+ procedure Set_Max_Size
+ (Value : in Natural);
+
function Copy
(This : in RGB_Image;
Width, Height : in Natural)
@@ -23,6 +58,10 @@ package FLTK.Images.RGB is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out RGB_Image;
Col : in Color;
@@ -34,6 +73,20 @@ package FLTK.Images.RGB is
+ ----------------
+ -- Activity --
+ ----------------
+
+ procedure Uncache
+ (This : in out RGB_Image);
+
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Draw
(This : in RGB_Image;
X, Y : in Integer);
@@ -53,8 +106,8 @@ private
(This : in out RGB_Image);
-
-
+ pragma Inline (Get_Max_Size);
+ pragma Inline (Set_Max_Size);
pragma Inline (Copy);
@@ -62,6 +115,9 @@ private
pragma Inline (Desaturate);
+ pragma Inline (Uncache);
+
+
pragma Inline (Draw);
diff --git a/src/fltk-images-shared.adb b/src/fltk-images-shared.adb
index 2d20e3c..24bc014 100644
--- a/src/fltk-images-shared.adb
+++ b/src/fltk-images-shared.adb
@@ -7,6 +7,7 @@ with
use type
+ Interfaces.C.int,
Interfaces.C.Strings.chars_ptr,
System.Address;
@@ -70,17 +71,39 @@ package body FLTK.Images.Shared is
+ function fl_shared_image_num_images
+ return Interfaces.C.int;
+ pragma Import (C, fl_shared_image_num_images, "fl_shared_image_num_images");
+ pragma Inline (fl_shared_image_num_images);
+
function fl_shared_image_name
(I : in System.Address)
return Interfaces.C.Strings.chars_ptr;
pragma Import (C, fl_shared_image_name, "fl_shared_image_name");
pragma Inline (fl_shared_image_name);
+ function fl_shared_image_original
+ (I : in System.Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_shared_image_original, "fl_shared_image_original");
+ pragma Inline (fl_shared_image_original);
+
+ function fl_shared_image_refcount
+ (I : in System.Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_shared_image_refcount, "fl_shared_image_refcount");
+ pragma Inline (fl_shared_image_refcount);
+
procedure fl_shared_image_reload
(I : in System.Address);
pragma Import (C, fl_shared_image_reload, "fl_shared_image_reload");
pragma Inline (fl_shared_image_reload);
+ procedure fl_shared_image_uncache
+ (I : in System.Address);
+ pragma Import (C, fl_shared_image_uncache, "fl_shared_image_uncache");
+ pragma Inline (fl_shared_image_uncache);
+
@@ -95,9 +118,6 @@ package body FLTK.Images.Shared is
pragma Import (C, fl_shared_image_scale, "fl_shared_image_scale");
pragma Inline (fl_shared_image_scale);
-
-
-
procedure fl_shared_image_draw
(I : in System.Address;
X, Y, W, H, CX, CY : in Interfaces.C.int);
@@ -128,6 +148,10 @@ package body FLTK.Images.Shared is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -173,8 +197,6 @@ package body FLTK.Images.Shared is
end Forge;
-
-
function Copy
(This : in Shared_Image;
Width, Height : in Natural)
@@ -201,6 +223,10 @@ package body FLTK.Images.Shared is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out Shared_Image;
Col : in Color;
@@ -222,6 +248,17 @@ package body FLTK.Images.Shared is
+ ----------------
+ -- Activity --
+ ----------------
+
+ function Number_Of_Images
+ return Natural is
+ begin
+ return Natural (fl_shared_image_num_images);
+ end Number_Of_Images;
+
+
function Name
(This : in Shared_Image)
return String
@@ -236,6 +273,22 @@ package body FLTK.Images.Shared is
end Name;
+ function Original
+ (This : in Shared_Image)
+ return Boolean is
+ begin
+ return fl_shared_image_original (This.Void_Ptr) /= 0;
+ end Original;
+
+
+ function Reference_Count
+ (This : in Shared_Image)
+ return Natural is
+ begin
+ return Natural (fl_shared_image_refcount (This.Void_Ptr));
+ end Reference_Count;
+
+
procedure Reload
(This : in out Shared_Image) is
begin
@@ -243,7 +296,18 @@ package body FLTK.Images.Shared is
end Reload;
+ procedure Uncache
+ (This : in out Shared_Image) is
+ begin
+ fl_shared_image_uncache (This.Void_Ptr);
+ end Uncache;
+
+
+
+ ---------------
+ -- Drawing --
+ ---------------
procedure Set_Scaling_Algorithm
(To : in Scaling_Kind) is
@@ -267,8 +331,6 @@ package body FLTK.Images.Shared is
end Scale;
-
-
procedure Draw
(This : in Shared_Image;
X, Y, W, H : in Integer;
diff --git a/src/fltk-images-shared.ads b/src/fltk-images-shared.ads
index a6810f8..ff12457 100644
--- a/src/fltk-images-shared.ads
+++ b/src/fltk-images-shared.ads
@@ -8,6 +8,10 @@ with
package FLTK.Images.Shared is
+ -------------
+ -- Types --
+ -------------
+
type Shared_Image is new Image with private;
type Shared_Image_Reference (Data : not null access Shared_Image'Class) is
@@ -16,6 +20,10 @@ package FLTK.Images.Shared is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
@@ -34,9 +42,6 @@ package FLTK.Images.Shared is
end Forge;
-
-
-
function Copy
(This : in Shared_Image;
Width, Height : in Natural)
@@ -49,6 +54,10 @@ package FLTK.Images.Shared is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out Shared_Image;
Col : in Color;
@@ -60,16 +69,38 @@ package FLTK.Images.Shared is
+ ----------------
+ -- Activity --
+ ----------------
+
+ function Number_Of_Images
+ return Natural;
+
function Name
(This : in Shared_Image)
return String;
+ function Original
+ (This : in Shared_Image)
+ return Boolean;
+
+ function Reference_Count
+ (This : in Shared_Image)
+ return Natural;
+
procedure Reload
(This : in out Shared_Image);
+ procedure Uncache
+ (This : in out Shared_Image);
+
+ ---------------
+ -- Drawing --
+ ---------------
+
procedure Set_Scaling_Algorithm
(To : in Scaling_Kind);
@@ -79,9 +110,6 @@ package FLTK.Images.Shared is
Proportional : in Boolean := True;
Can_Expand : in Boolean := False);
-
-
-
procedure Draw
(This : in Shared_Image;
X, Y, W, H : in Integer;
@@ -101,8 +129,6 @@ private
(This : in out Shared_Image);
-
-
pragma Inline (Copy);
@@ -110,14 +136,16 @@ private
pragma Inline (Desaturate);
+ pragma Inline (Number_Of_Images);
pragma Inline (Name);
+ pragma Inline (Original);
+ pragma Inline (Reference_Count);
pragma Inline (Reload);
+ pragma Inline (Uncache);
pragma Inline (Set_Scaling_Algorithm);
pragma Inline (Scale);
-
-
pragma Inline (Draw);
diff --git a/src/fltk-images.adb b/src/fltk-images.adb
index 008e0b2..b8dff24 100644
--- a/src/fltk-images.adb
+++ b/src/fltk-images.adb
@@ -2,7 +2,7 @@
with
- Interfaces.C,
+ Interfaces.C.Strings,
System;
use type
@@ -74,6 +74,11 @@ package body FLTK.Images is
pragma Import (C, fl_image_inactive, "fl_image_inactive");
pragma Inline (fl_image_inactive);
+ procedure fl_image_uncache
+ (I : in System.Address);
+ pragma Import (C, fl_image_uncache, "fl_image_uncache");
+ pragma Inline (fl_image_uncache);
+
@@ -95,6 +100,41 @@ package body FLTK.Images is
pragma Import (C, fl_image_d, "fl_image_d");
pragma Inline (fl_image_d);
+ function fl_image_ld
+ (I : in System.Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_image_ld, "fl_image_ld");
+ pragma Inline (fl_image_ld);
+
+ function fl_image_count
+ (I : in System.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 System.Address)
+ return System.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);
+
@@ -133,6 +173,10 @@ package body FLTK.Images is
+ --------------------
+ -- Construction --
+ --------------------
+
package body Forge is
function Create
@@ -141,18 +185,14 @@ package body FLTK.Images is
begin
return This : Image do
This.Void_Ptr := new_fl_image
- (Interfaces.C.int (Width),
- Interfaces.C.int (Height),
- Interfaces.C.int (Depth));
+ (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;
+ 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;
@@ -160,8 +200,6 @@ package body FLTK.Images is
end Forge;
-
-
function Get_Copy_Algorithm
return Scaling_Kind is
begin
@@ -183,9 +221,9 @@ package body FLTK.Images is
begin
return Copied : Image do
Copied.Void_Ptr := fl_image_copy
- (This.Void_Ptr,
- Interfaces.C.int (Width),
- Interfaces.C.int (Height));
+ (This.Void_Ptr,
+ Interfaces.C.int (Width),
+ Interfaces.C.int (Height));
end return;
end Copy;
@@ -202,15 +240,19 @@ package body FLTK.Images is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out Image;
Col : in Color;
Amount : in Blend) is
begin
fl_image_color_average
- (This.Void_Ptr,
- Interfaces.C.int (Col),
- Interfaces.C.C_float (Amount));
+ (This.Void_Ptr,
+ Interfaces.C.int (Col),
+ Interfaces.C.C_float (Amount));
end Color_Average;
@@ -223,6 +265,10 @@ package body FLTK.Images is
+ ----------------
+ -- Activity --
+ ----------------
+
procedure Inactive
(This : in out Image) is
begin
@@ -238,8 +284,19 @@ package body FLTK.Images is
end Is_Empty;
+ procedure Uncache
+ (This : in out Image) is
+ begin
+ fl_image_uncache (This.Void_Ptr);
+ end Uncache;
+
+
+ ------------------
+ -- Dimensions --
+ ------------------
+
function Get_W
(This : in Image)
return Natural is
@@ -264,16 +321,140 @@ package body FLTK.Images is
end Get_D;
+ function Get_Line_Data
+ (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;
+
+
+
+
+ ------------------
+ -- 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 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 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 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 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;
X, Y : in Integer) is
begin
fl_image_draw
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y));
end Draw;
@@ -283,13 +464,13 @@ package body FLTK.Images is
CX, CY : in Integer := 0) is
begin
fl_image_draw2
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y),
- Interfaces.C.int (W),
- Interfaces.C.int (H),
- Interfaces.C.int (CX),
- Interfaces.C.int (CY));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y),
+ Interfaces.C.int (W),
+ Interfaces.C.int (H),
+ Interfaces.C.int (CX),
+ Interfaces.C.int (CY));
end Draw;
@@ -298,9 +479,9 @@ package body FLTK.Images is
X, Y : in Integer) is
begin
fl_image_draw_empty
- (This.Void_Ptr,
- Interfaces.C.int (X),
- Interfaces.C.int (Y));
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y));
end Draw_Empty;
diff --git a/src/fltk-images.ads b/src/fltk-images.ads
index 053ed19..0ee31d5 100644
--- a/src/fltk-images.ads
+++ b/src/fltk-images.ads
@@ -3,6 +3,10 @@
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
@@ -17,6 +21,10 @@ package FLTK.Images is
+ --------------------
+ -- Construction --
+ --------------------
+
package Forge is
function Create
@@ -25,9 +33,6 @@ package FLTK.Images is
end Forge;
-
-
-
function Get_Copy_Algorithm
return Scaling_Kind;
@@ -46,6 +51,10 @@ package FLTK.Images is
+ --------------
+ -- Colors --
+ --------------
+
procedure Color_Average
(This : in out Image;
Col : in Color;
@@ -57,6 +66,10 @@ package FLTK.Images is
+ ----------------
+ -- Activity --
+ ----------------
+
procedure Inactive
(This : in out Image);
@@ -64,8 +77,15 @@ package FLTK.Images is
(This : in Image)
return Boolean;
+ procedure Uncache
+ (This : in out Image);
+
+
+ ------------------
+ -- Dimensions --
+ ------------------
function Get_W
(This : in Image)
@@ -79,8 +99,77 @@ package FLTK.Images is
(This : in Image)
return Natural;
+ function Get_Line_Data
+ (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;
@@ -107,6 +196,8 @@ private
+ pragma Inline (Get_Copy_Algorithm);
+ pragma Inline (Set_Copy_Algorithm);
pragma Inline (Copy);
@@ -116,11 +207,14 @@ private
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 (Draw);
diff --git a/src/fltk.ads b/src/fltk.ads
index c4cf336..7ad5c96 100644
--- a/src/fltk.ads
+++ b/src/fltk.ads
@@ -30,7 +30,9 @@ package FLTK is
type Greyscale is new Character range 'A' .. 'X';
type Color is mod 2**32;
+
type Color_Component is mod 256;
+ type Color_Component_Array is array (Positive range <>) of aliased Color_Component;
-- Examples of RGB colors
-- The lowest byte has to be 00 for the color to be RGB
@@ -381,6 +383,12 @@ private
+ for Color_Component_Array'Component_Size use Interfaces.C.CHAR_BIT;
+ pragma Convention (C, Color_Component_Array);
+
+
+
+
type Alignment is new Interfaces.Unsigned_16;
Align_Center : constant Alignment := 0;
Align_Top : constant Alignment := 1;