diff options
Diffstat (limited to 'body/fltk-draw.adb')
| -rw-r--r-- | body/fltk-draw.adb | 398 |
1 files changed, 175 insertions, 223 deletions
diff --git a/body/fltk-draw.adb b/body/fltk-draw.adb index 8e98a7f..38ccb80 100644 --- a/body/fltk-draw.adb +++ b/body/fltk-draw.adb @@ -8,12 +8,13 @@ with Ada.Assertions, Ada.Unchecked_Deallocation, + FLTK.Pixmap_Marshal, + Interfaces.C.Pointers, Interfaces.C.Strings; use type - Interfaces.C.int, - Interfaces.C.size_t; + Interfaces.C.int; package body FLTK.Draw is @@ -21,6 +22,13 @@ package body FLTK.Draw is package Chk renames Ada.Assertions; + -- Oh no... Anyway, this is just used for Expand_Text. + package Char_Pointers is new Interfaces.C.Pointers + (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + @@ -28,9 +36,7 @@ package body FLTK.Draw is -- Functions From C -- ------------------------ - procedure fl_draw_reset_spot; - pragma Import (C, fl_draw_reset_spot, "fl_draw_reset_spot"); - pragma Inline (fl_draw_reset_spot); + -- No Documentation -- procedure fl_draw_set_spot (F, S : in Interfaces.C.int; @@ -47,6 +53,8 @@ package body FLTK.Draw is + -- Utility -- + function fl_draw_can_do_alpha_blending return Interfaces.C.int; pragma Import (C, fl_draw_can_do_alpha_blending, "fl_draw_can_do_alpha_blending"); @@ -61,6 +69,8 @@ package body FLTK.Draw is + -- Charset Conversion -- + function fl_draw_latin1_to_local (T : in Interfaces.C.char_array; N : in Interfaces.C.int) @@ -92,6 +102,8 @@ package body FLTK.Draw is + -- Clipping -- + function fl_draw_clip_box (X, Y, W, H : in Interfaces.C.int; BX, BY, BW, BH : out Interfaces.C.int) @@ -105,29 +117,15 @@ package body FLTK.Draw is pragma Import (C, fl_draw_not_clipped, "fl_draw_not_clipped"); pragma Inline (fl_draw_not_clipped); - procedure fl_draw_pop_clip; - pragma Import (C, fl_draw_pop_clip, "fl_draw_pop_clip"); - pragma Inline (fl_draw_pop_clip); - procedure fl_draw_push_clip (X, Y, W, H : in Interfaces.C.int); pragma Import (C, fl_draw_push_clip, "fl_draw_push_clip"); pragma Inline (fl_draw_push_clip); - procedure fl_draw_push_no_clip; - pragma Import (C, fl_draw_push_no_clip, "fl_draw_push_no_clip"); - pragma Inline (fl_draw_push_no_clip); - - procedure fl_draw_restore_clip; - pragma Import (C, fl_draw_restore_clip, "fl_draw_restore_clip"); - pragma Inline (fl_draw_restore_clip); - - procedure fl_draw_overlay_clear; - pragma Import (C, fl_draw_overlay_clear, "fl_draw_overlay_clear"); - pragma Inline (fl_draw_overlay_clear); + -- Overlay -- procedure fl_draw_overlay_rect (X, Y, W, H : in Interfaces.C.int); @@ -137,6 +135,8 @@ package body FLTK.Draw is + -- Settings -- + function fl_draw_get_color return Interfaces.C.unsigned; pragma Import (C, fl_draw_get_color, "fl_draw_get_color"); @@ -206,19 +206,13 @@ package body FLTK.Draw is + -- Matrix Operations -- + procedure fl_draw_mult_matrix (A, B, C, D, X, Y : in Interfaces.C.double); pragma Import (C, fl_draw_mult_matrix, "fl_draw_mult_matrix"); pragma Inline (fl_draw_mult_matrix); - procedure fl_draw_pop_matrix; - pragma Import (C, fl_draw_pop_matrix, "fl_draw_pop_matrix"); - pragma Inline (fl_draw_pop_matrix); - - procedure fl_draw_push_matrix; - pragma Import (C, fl_draw_push_matrix, "fl_draw_push_matrix"); - pragma Inline (fl_draw_push_matrix); - procedure fl_draw_rotate (D : in Interfaces.C.double); pragma Import (C, fl_draw_rotate, "fl_draw_rotate"); @@ -276,6 +270,8 @@ package body FLTK.Draw is + -- Image Drawing -- + procedure fl_draw_draw_image (Buf : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int; @@ -302,6 +298,14 @@ package body FLTK.Draw is pragma Import (C, fl_draw_draw_image_mono2, "fl_draw_draw_image_mono2"); pragma Inline (fl_draw_draw_image_mono2); + function fl_draw_draw_pixmap + (Data : in Storage.Integer_Address; + X, Y : in Interfaces.C.int; + H : in Interfaces.C.unsigned) + return Interfaces.C.int; + pragma Import (C, fl_draw_draw_pixmap, "fl_draw_draw_pixmap"); + pragma Inline (fl_draw_draw_pixmap); + function fl_draw_read_image (Buf : in Storage.Integer_Address; X, Y, W, H : in Interfaces.C.int; @@ -313,6 +317,8 @@ package body FLTK.Draw is + -- Special Drawing -- + function fl_draw_add_symbol (Name : in Interfaces.C.char_array; Drawit : in Storage.Integer_Address; @@ -395,6 +401,19 @@ package body FLTK.Draw is pragma Import (C, fl_draw_text_extents, "fl_draw_text_extents"); pragma Inline (fl_draw_text_extents); + -- This function in particular is such bullshit. + function fl_draw_expand_text + (Str : in Interfaces.C.char_array; + Buf : out Interfaces.C.Strings.chars_ptr; + Max_Buf : in Interfaces.C.int; + Max_W : in Interfaces.C.double; + N : out Interfaces.C.int; + Width : out Interfaces.C.double; + Wrap, Sym : in Interfaces.C.int) + return Char_Pointers.Pointer; + pragma Import (C, fl_draw_expand_text, "fl_draw_expand_text"); + pragma Inline (fl_draw_expand_text); + function fl_draw_width (Str : in Interfaces.C.char_array; N : in Interfaces.C.int) @@ -411,28 +430,7 @@ package body FLTK.Draw is - procedure fl_draw_begin_complex_polygon; - pragma Import (C, fl_draw_begin_complex_polygon, "fl_draw_begin_complex_polygon"); - pragma Inline (fl_draw_begin_complex_polygon); - - procedure fl_draw_begin_line; - pragma Import (C, fl_draw_begin_line, "fl_draw_begin_line"); - pragma Inline (fl_draw_begin_line); - - procedure fl_draw_begin_loop; - pragma Import (C, fl_draw_begin_loop, "fl_draw_begin_loop"); - pragma Inline (fl_draw_begin_loop); - - procedure fl_draw_begin_points; - pragma Import (C, fl_draw_begin_points, "fl_draw_begin_points"); - pragma Inline (fl_draw_begin_points); - - procedure fl_draw_begin_polygon; - pragma Import (C, fl_draw_begin_polygon, "fl_draw_begin_polygon"); - pragma Inline (fl_draw_begin_polygon); - - - + -- Manual Drawing -- procedure fl_draw_arc (X, Y, R, Start, Finish : in Interfaces.C.double); @@ -471,10 +469,6 @@ package body FLTK.Draw is pragma Import (C, fl_draw_frame, "fl_draw_frame"); pragma Inline (fl_draw_frame); - procedure fl_draw_gap; - pragma Import (C, fl_draw_gap, "fl_draw_gap"); - pragma Inline (fl_draw_gap); - procedure fl_draw_line (X0, Y0 : in Interfaces.C.int; X1, Y1 : in Interfaces.C.int); @@ -590,38 +584,11 @@ package body FLTK.Draw is - procedure fl_draw_end_complex_polygon; - pragma Import (C, fl_draw_end_complex_polygon, "fl_draw_end_complex_polygon"); - pragma Inline (fl_draw_end_complex_polygon); - - procedure fl_draw_end_line; - pragma Import (C, fl_draw_end_line, "fl_draw_end_line"); - pragma Inline (fl_draw_end_line); - - procedure fl_draw_end_loop; - pragma Import (C, fl_draw_end_loop, "fl_draw_end_loop"); - pragma Inline (fl_draw_end_loop); - - procedure fl_draw_end_points; - pragma Import (C, fl_draw_end_points, "fl_draw_end_points"); - pragma Inline (fl_draw_end_points); - - procedure fl_draw_end_polygon; - pragma Import (C, fl_draw_end_polygon, "fl_draw_end_polygon"); - pragma Inline (fl_draw_end_polygon); - - - + ----------------------- + -- API Subprograms -- + ----------------------- - ------------------------ -- No Documentation -- - ------------------------ - - procedure Reset_Spot is - begin - fl_draw_reset_spot; - end Reset_Spot; - procedure Set_Spot (X, Y, W, H : in Integer; @@ -669,14 +636,12 @@ package body FLTK.Draw is - --------------- -- Utility -- - --------------- function Can_Do_Alpha_Blending return Boolean is - Result : Interfaces.C.int := fl_draw_can_do_alpha_blending; + Result : constant Interfaces.C.int := fl_draw_can_do_alpha_blending; begin if Result = 1 then return True; @@ -685,7 +650,9 @@ package body FLTK.Draw is return False; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_can_do_alpha_blending returned unexpected value of " & + Interfaces.C.int'Image (Result); end Can_Do_Alpha_Blending; @@ -694,15 +661,13 @@ package body FLTK.Draw is return String is begin return Interfaces.C.Strings.Value - (fl_draw_shortcut_label (Interfaces.C.unsigned (To_C (Keys)))); + (fl_draw_shortcut_label (To_C (Keys))); end Shortcut_Label; - -------------------------- -- Charset Conversion -- - -------------------------- function Latin1_To_Local (From : in String) @@ -742,9 +707,7 @@ package body FLTK.Draw is - ---------------- -- Clipping -- - ---------------- function Clip_Box (X, Y, W, H : in Integer; @@ -752,7 +715,7 @@ package body FLTK.Draw is return Boolean is CX, CY, CW, CH : Interfaces.C.int; - Result : Interfaces.C.int := fl_draw_clip_box + Result : constant Interfaces.C.int := fl_draw_clip_box (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), @@ -779,12 +742,6 @@ package body FLTK.Draw is end Clip_Intersects; - procedure Pop_Clip is - begin - fl_draw_pop_clip; - end Pop_Clip; - - procedure Push_Clip (X, Y, W, H : in Integer) is begin @@ -796,29 +753,9 @@ package body FLTK.Draw is end Push_Clip; - procedure Push_No_Clip is - begin - fl_draw_push_no_clip; - end Push_No_Clip; - - procedure Restore_Clip is - begin - fl_draw_restore_clip; - end Restore_Clip; - - - - --------------- -- Overlay -- - --------------- - - procedure Overlay_Clear is - begin - fl_draw_overlay_clear; - end Overlay_Clear; - procedure Overlay_Rect (X, Y, W, H : in Integer) is @@ -833,9 +770,7 @@ package body FLTK.Draw is - ---------------- -- Settings -- - ---------------- function Get_Color return Color is @@ -958,9 +893,7 @@ package body FLTK.Draw is - ------------------------- -- Matrix Operations -- - ------------------------- procedure Mult_Matrix (A, B, C, D, X, Y : in Long_Float) is @@ -975,18 +908,6 @@ package body FLTK.Draw is end Mult_Matrix; - procedure Pop_Matrix is - begin - fl_draw_pop_matrix; - end Pop_Matrix; - - - procedure Push_Matrix is - begin - fl_draw_push_matrix; - end Push_Matrix; - - procedure Rotate (Angle : in Long_Float) is begin @@ -1079,20 +1000,18 @@ package body FLTK.Draw is - --------------------- -- Image Drawing -- - --------------------- procedure Draw_Image (X, Y, W, H : in Integer; Data : in Color_Component_Array; Depth : in Positive := 3; - Line_Data : in Natural := 0; + Line_Size : in Natural := 0; Flip_Horizontal : in Boolean := False; Flip_Vertical : in Boolean := False) is Real_Depth : Integer := Depth; - Real_Line_Data : Integer := Line_Data; + Real_Line_Data : Integer := Line_Size; begin if Flip_Horizontal then Real_Depth := Real_Depth * (-1); @@ -1105,7 +1024,9 @@ package body FLTK.Draw is end if; end if; fl_draw_draw_image - (Storage.To_Integer (Data (Data'First)'Address), + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), @@ -1118,11 +1039,17 @@ package body FLTK.Draw is Image_Func_Ptr : Image_Draw_Function; procedure Draw_Image_Hook - (User : in Storage.Integer_Address; + (Ignore : in Storage.Integer_Address; + X, Y, W : in Interfaces.C.int; + Buf_Ptr : in Storage.Integer_Address); + pragma Convention (C, Draw_Image_Hook); + + procedure Draw_Image_Hook + (Ignore : in Storage.Integer_Address; X, Y, W : in Interfaces.C.int; Buf_Ptr : in Storage.Integer_Address) is - Data_Buffer : Color_Component_Array (1 .. Integer (W)); + Data_Buffer : Color_Component_Array (1 .. Size_Type (W)); for Data_Buffer'Address use Storage.To_Address (Buf_Ptr); pragma Import (Ada, Data_Buffer); begin @@ -1150,12 +1077,12 @@ package body FLTK.Draw is (X, Y, W, H : in Integer; Data : in Color_Component_Array; Depth : in Positive := 1; - Line_Data : in Natural := 0; + Line_Size : in Natural := 0; Flip_Horizontal : Boolean := False; Flip_Vertical : Boolean := False) is Real_Depth : Integer := Depth; - Real_Line_Data : Integer := Line_Data; + Real_Line_Data : Integer := Line_Size; begin if Flip_Horizontal then Real_Depth := Real_Depth * (-1); @@ -1168,7 +1095,9 @@ package body FLTK.Draw is end if; end if; fl_draw_draw_image_mono - (Storage.To_Integer (Data (Data'First)'Address), + ((if Data'Length > 0 + then Storage.To_Integer (Data (Data'First)'Address) + else Null_Pointer), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), @@ -1181,11 +1110,17 @@ package body FLTK.Draw is Mono_Image_Func_Ptr : Image_Draw_Function; procedure Draw_Image_Mono_Hook - (User : in Storage.Integer_Address; + (Ignore : in Storage.Integer_Address; + X, Y, W : in Interfaces.C.int; + Buf_Ptr : in Storage.Integer_Address); + pragma Convention (C, Draw_Image_Mono_Hook); + + procedure Draw_Image_Mono_Hook + (Ignore : in Storage.Integer_Address; X, Y, W : in Interfaces.C.int; Buf_Ptr : in Storage.Integer_Address) is - Data_Buffer : Color_Component_Array (1 .. Integer (W)); + Data_Buffer : Color_Component_Array (1 .. Size_Type (W)); for Data_Buffer'Address use Storage.To_Address (Buf_Ptr); pragma Import (Ada, Data_Buffer); begin @@ -1209,41 +1144,73 @@ package body FLTK.Draw is end Draw_Image_Mono; + procedure Draw_Pixmap + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; + X, Y : in Integer; + Tone : in Color := Grey0_Color) + is + C_Data : Pixmap_Marshal.chars_ptr_array_access := + Pixmap_Marshal.Marshal_Data (Values, Colors, Pixels); + Result : constant Interfaces.C.int := fl_draw_draw_pixmap + (Storage.To_Integer (C_Data (C_Data'First)'Address), + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.unsigned (Tone)); + begin + pragma Assert (Result /= 0); + Pixmap_Marshal.Free_Recursive (C_Data); + exception + when Chk.Assertion_Error => + Pixmap_Marshal.Free_Recursive (C_Data); + raise Draw_Error with "fl_draw_pixmap could not decode supplied XPM pixmap data"; + end Draw_Pixmap; + + function Read_Image (X, Y, W, H : in Integer; Alpha : in Integer := 0) return Color_Component_Array is - My_Len : Integer := (if Alpha = 0 then W * H * 3 else W * H * 4); + My_Len : constant Size_Type := + (if Alpha = 0 + then Size_Type (W) * Size_Type (H) * 3 + else Size_Type (W) * Size_Type (H) * 4); Result : Color_Component_Array (1 .. My_Len); Buffer : Storage.Integer_Address; begin Buffer := fl_draw_read_image - (Storage.To_Integer (Result (Result'First)'Address), + ((if Result'Length > 0 + then Storage.To_Integer (Result (Result'First)'Address) + else Null_Pointer), Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H), Interfaces.C.int (Alpha)); - pragma Assert (Buffer = Storage.To_Integer (Result (Result'First)'Address)); + pragma Assert + ((if Result'Length > 0 + then Buffer = Storage.To_Integer (Result (Result'First)'Address) + else Buffer = Null_Pointer)); return Result; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_read_image returned unexpected address value that did not " & + "correspond to supplied address value"; end Read_Image; - ----------------------- -- Special Drawing -- - ----------------------- procedure Add_Symbol (Text : in String; Callback : in Symbol_Draw_Function; Scalable : in Boolean) is - Ret_Val : Interfaces.C.int := fl_draw_add_symbol + Ret_Val : constant Interfaces.C.int := fl_draw_add_symbol (Interfaces.C.To_C (Text), Storage.To_Integer (Callback.all'Address), Boolean'Pos (Scalable)); @@ -1254,7 +1221,9 @@ package body FLTK.Draw is pragma Assert (Ret_Val = 1); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_add_symbol returned unexpected int value of " & + Interfaces.C.int'Image (Ret_Val); end Add_Symbol; procedure Draw_Text @@ -1310,6 +1279,12 @@ package body FLTK.Draw is procedure Draw_Text_Hook (Ptr : in Storage.Integer_Address; + N, X0, Y0 : in Interfaces.C.int); + + pragma Convention (C, Draw_Text_Hook); + + procedure Draw_Text_Hook + (Ptr : in Storage.Integer_Address; N, X0, Y0 : in Interfaces.C.int) is Data : String (1 .. Integer (N)); @@ -1319,7 +1294,6 @@ package body FLTK.Draw is Text_Func_Ptr (Integer (X0), Integer (Y0), Data); end Draw_Text_Hook; - procedure Draw_Text (X, Y, W, H : in Integer; Text : in String; @@ -1409,7 +1383,7 @@ package body FLTK.Draw is Name : in String; Hue : in Color) is - Ret_Val : Interfaces.C.int := fl_draw_draw_symbol + Ret_Val : constant Interfaces.C.int := fl_draw_draw_symbol (Interfaces.C.To_C (Name), Interfaces.C.int (X), Interfaces.C.int (Y), @@ -1423,7 +1397,9 @@ package body FLTK.Draw is pragma Assert (Ret_Val = 1); end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_draw_symbol returned unexpected int value of " & + Interfaces.C.int'Image (Ret_Val); end Draw_Symbol; @@ -1446,13 +1422,23 @@ package body FLTK.Draw is procedure Scroll_Hook - (Ptr : in Area_Draw_Function; - X, Y, W, H : in Interfaces.C.int) is + (Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int); + + pragma Convention (C, Scroll_Hook); + + procedure Scroll_Hook + (Ptr : in Storage.Integer_Address; + X, Y, W, H : in Interfaces.C.int) + is + procedure my_area_draw + (X, Y, W, H : in Integer); + for my_area_draw'Address use Storage.To_Address (Ptr); + pragma Import (Ada, my_area_draw); begin - Ptr.all (Integer (X), Integer (Y), Integer (W), Integer (H)); + my_area_draw (Integer (X), Integer (Y), Integer (W), Integer (H)); end Scroll_Hook; - procedure Scroll (X, Y, W, H : in Integer; DX, DY : in Integer; @@ -1490,6 +1476,32 @@ package body FLTK.Draw is end Text_Extents; + function Expand_Text + (Text : in String; + Max_Width : in Long_Float; + Width : out Long_Float; + Last : out Natural; + Wrap : in Boolean; + Symbols : in Boolean := False) + return String + is + Buffer : Interfaces.C.Strings.chars_ptr; + Length : Interfaces.C.int; + Temp : Interfaces.C.char_array := Interfaces.C.To_C (Text); + Result : constant Char_Pointers.Pointer := fl_draw_expand_text + (Temp, Buffer, 0, + Interfaces.C.double (Max_Width), + Length, + Interfaces.C.double (Width), + Boolean'Pos (Wrap), + Boolean'Pos (Symbols)); + use type Char_Pointers.Pointer; + begin + Last := Natural (Result - Temp (Temp'First)'Unchecked_Access); + return Interfaces.C.Strings.Value (Buffer, Interfaces.C.size_t (Length)); + end Expand_Text; + + function Width (Text : in String) return Long_Float is @@ -1524,35 +1536,7 @@ package body FLTK.Draw is - ---------------------- -- Manual Drawing -- - ---------------------- - - procedure Begin_Complex_Polygon is - begin - fl_draw_begin_complex_polygon; - end Begin_Complex_Polygon; - - procedure Begin_Line is - begin - fl_draw_begin_line; - end Begin_Line; - - procedure Begin_Loop is - begin - fl_draw_begin_loop; - end Begin_Loop; - - procedure Begin_Points is - begin - fl_draw_begin_points; - end Begin_Points; - - procedure Begin_Polygon is - begin - fl_draw_begin_polygon; - end Begin_Polygon; - procedure Arc (X, Y, R, Start, Finish : in Long_Float) is @@ -1634,12 +1618,6 @@ package body FLTK.Draw is end Frame; - procedure Gap is - begin - fl_draw_gap; - end Gap; - - procedure Line (X0, Y0 : in Integer; X1, Y1 : in Integer) is @@ -1866,32 +1844,6 @@ package body FLTK.Draw is end Why_Ecks_Line; - procedure End_Complex_Polygon is - begin - fl_draw_end_complex_polygon; - end End_Complex_Polygon; - - procedure End_Line is - begin - fl_draw_end_line; - end End_Line; - - procedure End_Loop is - begin - fl_draw_end_loop; - end End_Loop; - - procedure End_Points is - begin - fl_draw_end_points; - end End_Points; - - procedure End_Polygon is - begin - fl_draw_end_polygon; - end End_Polygon; - - end FLTK.Draw; |