diff options
Diffstat (limited to 'src/fltk-images.adb')
| -rw-r--r-- | src/fltk-images.adb | 251 |
1 files changed, 217 insertions, 34 deletions
diff --git a/src/fltk-images.adb b/src/fltk-images.adb index 008e0b2..f86071e 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); + @@ -125,7 +165,9 @@ package body FLTK.Images is if This.Void_Ptr /= System.Null_Address and then This in Image'Class then - free_fl_image (This.Void_Ptr); + if This.Needs_Dealloc then + free_fl_image (This.Void_Ptr); + end if; This.Void_Ptr := System.Null_Address; end if; end Finalize; @@ -133,6 +175,10 @@ package body FLTK.Images is + -------------------- + -- Construction -- + -------------------- + package body Forge is function Create @@ -141,18 +187,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 +202,6 @@ package body FLTK.Images is end Forge; - - function Get_Copy_Algorithm return Scaling_Kind is begin @@ -183,9 +223,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 +242,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 +267,10 @@ package body FLTK.Images is + ---------------- + -- Activity -- + ---------------- + procedure Inactive (This : in out Image) is begin @@ -238,8 +286,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 +323,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 +466,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 +481,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; |