From dee76d5884c6f079ea3a2387d07289534a51a0c1 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 28 Jan 2025 21:43:17 +1300 Subject: Revised Image subhierarchy, fixed data subprograms, added constructor for Pixmap --- spec/fltk-images-bitmaps-xbm.ads | 9 +-- spec/fltk-images-bitmaps.ads | 87 +++++++++++++++++++++------ spec/fltk-images-pixmaps-gif.ads | 9 +-- spec/fltk-images-pixmaps-xpm.ads | 9 +-- spec/fltk-images-pixmaps.ads | 75 +++++++++++++++++------ spec/fltk-images-rgb-bmp.ads | 9 +-- spec/fltk-images-rgb-jpeg.ads | 9 +-- spec/fltk-images-rgb-png.ads | 9 +-- spec/fltk-images-rgb-pnm.ads | 9 +-- spec/fltk-images-rgb.ads | 95 ++++++++++++++++++++++-------- spec/fltk-images-tiled.ads | 29 +++------ spec/fltk-images.ads | 124 +++++++++------------------------------ 12 files changed, 242 insertions(+), 231 deletions(-) (limited to 'spec') diff --git a/spec/fltk-images-bitmaps-xbm.ads b/spec/fltk-images-bitmaps-xbm.ads index 0887666..5805332 100644 --- a/spec/fltk-images-bitmaps-xbm.ads +++ b/spec/fltk-images-bitmaps-xbm.ads @@ -7,10 +7,6 @@ package FLTK.Images.Bitmaps.XBM is - ------------- - -- Types -- - ------------- - type XBM_Image is new Bitmap with private; type XBM_Image_Reference (Data : not null access XBM_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.Bitmaps.XBM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Bitmaps.XBM; + diff --git a/spec/fltk-images-bitmaps.ads b/spec/fltk-images-bitmaps.ads index d8730a2..d60334f 100644 --- a/spec/fltk-images-bitmaps.ads +++ b/spec/fltk-images-bitmaps.ads @@ -7,10 +7,6 @@ package FLTK.Images.Bitmaps is - ------------- - -- Types -- - ------------- - type Bitmap is new Image with private; type Bitmap_Reference (Data : not null access Bitmap'Class) is limited null record @@ -19,22 +15,31 @@ package FLTK.Images.Bitmaps is - -------------------- - -- Construction -- - -------------------- + function To_Next_Byte + (Bits : in Natural) + return Natural; + + + package Forge is - -- Please note that I'm pretty sure (?) input data here should be some - -- declared item that lives at least as long as the resulting Bitmap + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting Bitmap. function Create (Data : in Color_Component_Array; Width, Height : in Natural) - return Bitmap; + return Bitmap + with Pre => Data'Length = To_Next_Byte (Width) * Height; end Forge; + + + + -- Copying -- + function Copy (This : in Bitmap; Width, Height : in Natural) @@ -47,9 +52,7 @@ package FLTK.Images.Bitmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Bitmap); @@ -57,18 +60,56 @@ package FLTK.Images.Bitmaps is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Natural; + + function Get_Datum + (This : in Bitmap; + Place : in Positive) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in Bitmap; + Low : in Positive; + High : in Natural) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Integer'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in Bitmap) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + -- Drawing -- - --------------- procedure Draw (This : in Bitmap; X, Y : in Integer); procedure Draw - (This : in Bitmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private @@ -80,10 +121,22 @@ private (This : in out Bitmap); + pragma Inline (To_Next_Byte); + pragma Inline (Copy); + pragma Inline (Uncache); + + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); + pragma Inline (Draw); end FLTK.Images.Bitmaps; + diff --git a/spec/fltk-images-pixmaps-gif.ads b/spec/fltk-images-pixmaps-gif.ads index 7084a13..5720138 100644 --- a/spec/fltk-images-pixmaps-gif.ads +++ b/spec/fltk-images-pixmaps-gif.ads @@ -7,10 +7,6 @@ package FLTK.Images.Pixmaps.GIF is - ------------- - -- Types -- - ------------- - type GIF_Image is new Pixmap with private; type GIF_Image_Reference (Data : not null access GIF_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Pixmaps.GIF is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Pixmaps.GIF; + diff --git a/spec/fltk-images-pixmaps-xpm.ads b/spec/fltk-images-pixmaps-xpm.ads index d5bae5a..c703264 100644 --- a/spec/fltk-images-pixmaps-xpm.ads +++ b/spec/fltk-images-pixmaps-xpm.ads @@ -7,10 +7,6 @@ package FLTK.Images.Pixmaps.XPM is - ------------- - -- Types -- - ------------- - type XPM_Image is new Pixmap with private; type XPM_Image_Reference (Data : not null access XPM_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Pixmaps.XPM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.Pixmaps.XPM; + diff --git a/spec/fltk-images-pixmaps.ads b/spec/fltk-images-pixmaps.ads index 14e3f94..64d8330 100644 --- a/spec/fltk-images-pixmaps.ads +++ b/spec/fltk-images-pixmaps.ads @@ -4,12 +4,17 @@ -- Released into the public domain -package FLTK.Images.Pixmaps is +with + + Ada.Strings.Unbounded; + +private with + Interfaces.C.Strings; + + +package FLTK.Images.Pixmaps is - ------------- - -- Types -- - ------------- type Pixmap is new Image with private; @@ -17,11 +22,48 @@ package FLTK.Images.Pixmaps is with Implicit_Dereference => Data; + type Header is record + Width, Height, Colors, Per_Pixel : Positive; + end record; + + type Color_Kind is (Colorful, Monochrome, Greyscale, Symbolic); + + type Color_Definition is record + Name : Ada.Strings.Unbounded.Unbounded_String; + Kind : Color_Kind; + Value : Ada.Strings.Unbounded.Unbounded_String; + end record; + + type Color_Definition_Array is array (Positive range <>) of Color_Definition; + + type Pixmap_Data is array (Positive range <>, Positive range <>) of Character; + - -------------------- - -- Construction -- - -------------------- + + package Forge is + + -- Unlike Bitmaps or RGB_Images, you do NOT have to keep this data around. + -- A copy will be allocated and deallocated internally. + + function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap + with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; + + end Forge; + + + + + -- Copying -- function Copy (This : in Pixmap; @@ -35,9 +77,7 @@ package FLTK.Images.Pixmaps is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Pixmap; @@ -50,9 +90,7 @@ package FLTK.Images.Pixmaps is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out Pixmap); @@ -60,24 +98,24 @@ package FLTK.Images.Pixmaps is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Pixmap; X, Y : in Integer); procedure Draw - (This : in Pixmap; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private - type Pixmap is new Image with null record; + type Pixmap is new Image with record + Loose_Ptr : access Interfaces.C.Strings.chars_ptr_array; + end record; overriding procedure Finalize (This : in out Pixmap); @@ -86,13 +124,12 @@ private pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Uncache); - pragma Inline (Copy); pragma Inline (Draw); end FLTK.Images.Pixmaps; + diff --git a/spec/fltk-images-rgb-bmp.ads b/spec/fltk-images-rgb-bmp.ads index 4eb9e1b..f2bf103 100644 --- a/spec/fltk-images-rgb-bmp.ads +++ b/spec/fltk-images-rgb-bmp.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.BMP is - ------------- - -- Types -- - ------------- - type BMP_Image is new RGB_Image with private; type BMP_Image_Reference (Data : not null access BMP_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.BMP is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.RGB.BMP; + diff --git a/spec/fltk-images-rgb-jpeg.ads b/spec/fltk-images-rgb-jpeg.ads index 0349b01..8bb21ba 100644 --- a/spec/fltk-images-rgb-jpeg.ads +++ b/spec/fltk-images-rgb-jpeg.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.JPEG is - ------------- - -- Types -- - ------------- - type JPEG_Image is new RGB_Image with private; type JPEG_Image_Reference (Data : not null access JPEG_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.RGB.JPEG is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -48,3 +40,4 @@ private end FLTK.Images.RGB.JPEG; + diff --git a/spec/fltk-images-rgb-png.ads b/spec/fltk-images-rgb-png.ads index 23890b3..dcfbd4f 100644 --- a/spec/fltk-images-rgb-png.ads +++ b/spec/fltk-images-rgb-png.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.PNG is - ------------- - -- Types -- - ------------- - type PNG_Image is new RGB_Image with private; type PNG_Image_Reference (Data : not null access PNG_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.PNG is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -48,3 +40,4 @@ private end FLTK.Images.RGB.PNG; + diff --git a/spec/fltk-images-rgb-pnm.ads b/spec/fltk-images-rgb-pnm.ads index d72706b..847b149 100644 --- a/spec/fltk-images-rgb-pnm.ads +++ b/spec/fltk-images-rgb-pnm.ads @@ -7,10 +7,6 @@ package FLTK.Images.RGB.PNM is - ------------- - -- Types -- - ------------- - type PNM_Image is new RGB_Image with private; type PNM_Image_Reference (Data : not null access PNM_Image'Class) is limited null record @@ -19,10 +15,6 @@ package FLTK.Images.RGB.PNM is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -43,3 +35,4 @@ private end FLTK.Images.RGB.PNM; + diff --git a/spec/fltk-images-rgb.ads b/spec/fltk-images-rgb.ads index 5768b3c..a935872 100644 --- a/spec/fltk-images-rgb.ads +++ b/spec/fltk-images-rgb.ads @@ -12,10 +12,6 @@ with package FLTK.Images.RGB is - ------------- - -- Types -- - ------------- - type RGB_Image is new Image with private; type RGB_Image_Reference (Data : not null access RGB_Image'Class) is limited null record @@ -24,18 +20,30 @@ package FLTK.Images.RGB is - -------------------- - -- Construction -- - -------------------- + function Get_Max_Size + return Natural; + + procedure Set_Max_Size + (Value : in Natural); + + + package Forge is + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting RGB_Image. + function Create (Data : in Color_Component_Array; Width, Height : in Natural; Depth : in Natural := 3; - Line_Data : in Natural := 0) - return RGB_Image; + Line_Size : in Natural := 0) + return RGB_Image + with Pre => (if Line_Size = 0 + then Data'Length = Width * Height * Depth + else Data'Length = Line_Size * Height) + and Data'Length <= Get_Max_Size; function Create (Data : in FLTK.Images.Pixmaps.Pixmap'Class; @@ -44,11 +52,10 @@ package FLTK.Images.RGB is end Forge; - function Get_Max_Size - return Natural; - procedure Set_Max_Size - (Value : in Natural); + + + -- Copying -- function Copy (This : in RGB_Image; @@ -62,9 +69,7 @@ package FLTK.Images.RGB is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out RGB_Image; @@ -77,9 +82,7 @@ package FLTK.Images.RGB is - ---------------- -- Activity -- - ---------------- procedure Uncache (This : in out RGB_Image); @@ -87,18 +90,56 @@ package FLTK.Images.RGB is - --------------- + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Natural; + + function Get_Datum + (This : in RGB_Image; + Place : in Positive) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in RGB_Image; + Low : in Positive; + High : in Natural) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Integer'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + -- Drawing -- - --------------- procedure Draw (This : in RGB_Image; X, Y : in Integer); procedure Draw - (This : in RGB_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); private @@ -112,18 +153,24 @@ private pragma Inline (Get_Max_Size); pragma Inline (Set_Max_Size); - pragma Inline (Copy); + pragma Inline (Copy); pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Uncache); + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); pragma Inline (Draw); end FLTK.Images.RGB; + diff --git a/spec/fltk-images-tiled.ads b/spec/fltk-images-tiled.ads index a7e775e..a7470fc 100644 --- a/spec/fltk-images-tiled.ads +++ b/spec/fltk-images-tiled.ads @@ -7,10 +7,6 @@ package FLTK.Images.Tiled is - ------------- - -- Types -- - ------------- - type Tiled_Image is new Image with private; type Tiled_Image_Reference (Data : not null access Tiled_Image'Class) is @@ -19,10 +15,6 @@ package FLTK.Images.Tiled is - -------------------- - -- Construction -- - -------------------- - package Forge is function Create @@ -32,6 +24,11 @@ package FLTK.Images.Tiled is end Forge; + + + + -- Copying -- + function Copy (This : in Tiled_Image; Width, Height : in Natural) @@ -44,9 +41,7 @@ package FLTK.Images.Tiled is - --------------------- -- Miscellaneous -- - --------------------- procedure Inactive (This : in out Tiled_Image); @@ -58,9 +53,7 @@ package FLTK.Images.Tiled is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Tiled_Image; @@ -73,18 +66,16 @@ package FLTK.Images.Tiled is - --------------- -- Drawing -- - --------------- procedure Draw (This : in Tiled_Image; X, Y : in Integer); procedure Draw - (This : in Tiled_Image; - X, Y, W, H : in Integer; - CX, CY : in Integer); + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer); private @@ -100,17 +91,15 @@ private pragma Inline (Copy); - pragma Inline (Inactive); pragma Inline (Tile); - pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Draw); end FLTK.Images.Tiled; + diff --git a/spec/fltk-images.ads b/spec/fltk-images.ads index 9a02f23..165c203 100644 --- a/spec/fltk-images.ads +++ b/spec/fltk-images.ads @@ -7,10 +7,6 @@ package FLTK.Images is - ------------- - -- Types -- - ------------- - type Image is new Wrapper with private; type Image_Reference (Data : not null access Image'Class) is limited null record @@ -20,23 +16,27 @@ package FLTK.Images is type Blend is new Float range 0.0 .. 1.0; - No_Image_Error, File_Access_Error, Format_Error : exception; + No_Image_Error, File_Access_Error, Format_Error : exception; - -------------------- - -- Construction -- - -------------------- package Forge is + -- This creates an empty image with no data, so not that useful. + function Create (Width, Height, Depth : in Natural) return Image; end Forge; + + + + -- Copying -- + function Get_Copy_Algorithm return Scaling_Kind; @@ -55,9 +55,7 @@ package FLTK.Images is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Image; @@ -70,9 +68,7 @@ package FLTK.Images is - ---------------- -- Activity -- - ---------------- procedure Inactive (This : in out Image); @@ -87,9 +83,7 @@ package FLTK.Images is - ------------------ -- Dimensions -- - ------------------ function Get_W (This : in Image) @@ -103,86 +97,23 @@ package FLTK.Images is (This : in Image) return Natural; - function Get_Line_Data + function Get_Line_Size (This : in Image) return Natural; - function Get_Data_Count - (This : in Image) - return Natural; - - function Get_Data_Size - (This : in Image) - return Natural; - - - - - ------------------ - -- Pixel Data -- - ------------------ - - function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - - procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This); - - function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Count <= Get_Data_Size (This) - Position + 1; - - function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array - with Pre => - Data <= Get_Data_Count (This); - - procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) - with Pre => - Data <= Get_Data_Count (This) and - Position <= Get_Data_Size (This) and - Values'Length <= Get_Data_Size (This) - Position + 1; - - --------------- -- Drawing -- - --------------- procedure Draw (This : in Image; X, Y : in Integer); procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0); + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); procedure Draw_Empty (This : in Image; @@ -198,40 +129,43 @@ private (This : in out Image); + procedure Raise_Fail_Errors + (This : in Image'Class); + + + function fl_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_data, "fl_image_data"); + pragma Inline (fl_image_data); + + function fl_image_count + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_count, "fl_image_count"); + pragma Inline (fl_image_count); pragma Inline (Get_Copy_Algorithm); pragma Inline (Set_Copy_Algorithm); pragma Inline (Copy); - pragma Inline (Color_Average); pragma Inline (Desaturate); - pragma Inline (Inactive); pragma Inline (Is_Empty); pragma Inline (Uncache); - pragma Inline (Get_W); pragma Inline (Get_H); pragma Inline (Get_D); - pragma Inline (Get_Line_Data); - pragma Inline (Get_Data_Count); - + pragma Inline (Get_Line_Size); pragma Inline (Draw); pragma Inline (Draw_Empty); - - - function fl_image_fail - (I : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_image_fail, "fl_image_fail"); - - end FLTK.Images; + -- cgit