diff options
Diffstat (limited to 'src')
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; |