diff options
Diffstat (limited to 'body/fltk-images.adb')
| -rw-r--r-- | body/fltk-images.adb | 235 |
1 files changed, 71 insertions, 164 deletions
diff --git a/body/fltk-images.adb b/body/fltk-images.adb index 19a1f86..fdc4abd 100644 --- a/body/fltk-images.adb +++ b/body/fltk-images.adb @@ -16,6 +16,26 @@ use type package body FLTK.Images is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_image_err_no_image : constant Interfaces.C.int; + pragma Import (C, fl_image_err_no_image, "fl_image_err_no_image"); + + fl_image_err_file_access : constant Interfaces.C.int; + pragma Import (C, fl_image_err_file_access, "fl_image_err_file_access"); + + fl_image_err_format : constant Interfaces.C.int; + pragma Import (C, fl_image_err_format, "fl_image_err_format"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_image (W, H, D : in Interfaces.C.int) return Storage.Integer_Address; @@ -30,6 +50,14 @@ package body FLTK.Images is + function fl_image_fail + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_fail, "fl_image_fail"); + + + + function fl_image_get_rgb_scaling return Interfaces.C.int; pragma Import (C, fl_image_get_rgb_scaling, "fl_image_get_rgb_scaling"); @@ -108,35 +136,6 @@ package body FLTK.Images is pragma Import (C, fl_image_ld, "fl_image_ld"); pragma Inline (fl_image_ld); - function fl_image_count - (I : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_image_count, "fl_image_count"); - pragma Inline (fl_image_count); - - - - - function fl_image_data - (I : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_image_data, "fl_image_data"); - pragma Inline (fl_image_data); - - function fl_image_get_pixel - (C : in Interfaces.C.Strings.chars_ptr; - O : in Interfaces.C.int) - return Interfaces.C.unsigned_char; - pragma Import (C, fl_image_get_pixel, "fl_image_get_pixel"); - pragma Inline (fl_image_get_pixel); - - procedure fl_image_set_pixel - (C : in Interfaces.C.Strings.chars_ptr; - O : in Interfaces.C.int; - V : in Interfaces.C.unsigned_char); - pragma Import (C, fl_image_set_pixel, "fl_image_set_pixel"); - pragma Inline (fl_image_set_pixel); - @@ -161,6 +160,31 @@ package body FLTK.Images is + ------------------------ + -- Internal Utility -- + ------------------------ + + procedure Raise_Fail_Errors + (This : in Image'Class) + is + Result : Interfaces.C.int := fl_image_fail (This.Void_Ptr); + begin + if Result = fl_image_err_no_image and This.Is_Empty then + raise No_Image_Error; + elsif Result = fl_image_err_file_access then + raise File_Access_Error; + elsif Result = fl_image_err_format then + raise Format_Error; + end if; + end Raise_Fail_Errors; + + + + + ------------------- + -- Destructors -- + ------------------- + overriding procedure Finalize (This : in out Image) is begin @@ -174,7 +198,7 @@ package body FLTK.Images is -------------------- - -- Construction -- + -- Constructors -- -------------------- package body Forge is @@ -188,18 +212,20 @@ package body FLTK.Images is (Interfaces.C.int (Width), Interfaces.C.int (Height), Interfaces.C.int (Depth)); - case fl_image_fail (This.Void_Ptr) is - when 1 => raise No_Image_Error; - when 2 => raise File_Access_Error; - when 3 => raise Format_Error; - when others => null; - end case; end return; end Create; end Forge; + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Copying -- + function Get_Copy_Algorithm return Scaling_Kind is begin @@ -240,9 +266,7 @@ package body FLTK.Images is - -------------- -- Colors -- - -------------- procedure Color_Average (This : in out Image; @@ -265,9 +289,7 @@ package body FLTK.Images is - ---------------- -- Activity -- - ---------------- procedure Inactive (This : in out Image) is @@ -280,7 +302,7 @@ package body FLTK.Images is (This : in Image) return Boolean is begin - return fl_image_fail (This.Void_Ptr) /= 0; + return fl_image_count (This.Void_Ptr) = 0 or This.Get_W = 0 or This.Get_H = 0; end Is_Empty; @@ -293,9 +315,7 @@ package body FLTK.Images is - ------------------ -- Dimensions -- - ------------------ function Get_W (This : in Image) @@ -321,131 +341,17 @@ package body FLTK.Images is end Get_D; - function Get_Line_Data + function Get_Line_Size (This : in Image) return Natural is begin return Natural (fl_image_ld (This.Void_Ptr)); - end Get_Line_Data; - - - function Get_Data_Count - (This : in Image) - return Natural is - begin - return Natural (fl_image_count (This.Void_Ptr)); - end Get_Data_Count; - - - function Get_Data_Size - (This : in Image) - return Natural - is - My_Depth : Natural := This.Get_D; - My_Line_Data : Natural := This.Get_Line_Data; - begin - if My_Line_Data > 0 then - return My_Line_Data * This.Get_H; - elsif My_Depth = 0 then - return Integer (Float'Ceiling (Float (This.Get_W) / 8.0)) * This.Get_H; - else - return This.Get_W * My_Depth * This.Get_H; - end if; - end Get_Data_Size; - + end Get_Line_Size; - ------------------ - -- Pixel Data -- - ------------------ - - function Get_Datum - (This : in Image; - Data : in Positive; - Position : in Positive) - return Color_Component - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - return Color_Component - (fl_image_get_pixel (Pointers (Data), Interfaces.C.int (Position) - 1)); - end Get_Datum; - - procedure Set_Datum - (This : in out Image; - Data : in Positive; - Position : in Positive; - Value : in Color_Component) - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - fl_image_set_pixel - (Pointers (Data), - Interfaces.C.int (Position) - 1, - Interfaces.C.unsigned_char (Value)); - end Set_Datum; - - - function Get_Data - (This : in Image; - Data : in Positive; - Position : in Positive; - Count : in Natural) - return Color_Component_Array - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - Result : Color_Component_Array := (1 .. Count => 0); - begin - for Index in Result'Range loop - Result (Index) := Color_Component (fl_image_get_pixel - (Pointers (Data), - Interfaces.C.int (Index - 1 + Position - 1))); - end loop; - return Result; - end Get_Data; - - - function All_Data - (This : in Image; - Data : in Positive) - return Color_Component_Array is - begin - return This.Get_Data (Data, 1, This.Get_Data_Size); - end All_Data; - - - procedure Update_Data - (This : in out Image; - Data : in Positive; - Position : in Positive; - Values : in Color_Component_Array) - is - Pointers : array (1 .. This.Get_Data_Count) of Interfaces.C.Strings.chars_ptr; - for Pointers'Address use Storage.To_Address (fl_image_data (This.Void_Ptr)); - pragma Import (Ada, Pointers); - begin - for Counter in Integer range 0 .. Values'Length - 1 loop - fl_image_set_pixel - (Pointers (Data), - Interfaces.C.int (Position - 1 + Counter), - Interfaces.C.unsigned_char (Values (Values'First + Counter))); - end loop; - end Update_Data; - - - - - --------------- -- Drawing -- - --------------- procedure Draw (This : in Image; @@ -459,9 +365,9 @@ package body FLTK.Images is procedure Draw - (This : in Image; - X, Y, W, H : in Integer; - CX, CY : in Integer := 0) is + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0) is begin fl_image_draw2 (This.Void_Ptr, @@ -469,8 +375,8 @@ package body FLTK.Images is Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), - Interfaces.C.int (CX), - Interfaces.C.int (CY)); + Interfaces.C.int (Clip_X), + Interfaces.C.int (Clip_Y)); end Draw; @@ -487,3 +393,4 @@ package body FLTK.Images is end FLTK.Images; + |