diff options
Diffstat (limited to 'test')
| -rw-r--r-- | test/animated.adb | 21 | ||||
| -rw-r--r-- | test/ask.adb | 10 | ||||
| -rw-r--r-- | test/bitmap.adb | 3 | ||||
| -rw-r--r-- | test/button.adb | 67 | ||||
| -rw-r--r-- | test/buttons.adb | 58 | ||||
| -rw-r--r-- | test/clock.adb | 50 | ||||
| -rw-r--r-- | test/color_chooser.adb | 164 | ||||
| -rw-r--r-- | test/compare.adb | 10 | ||||
| -rw-r--r-- | test/cursor.adb | 116 | ||||
| -rw-r--r-- | test/curve.adb | 164 | ||||
| -rw-r--r-- | test/dirlist.adb | 11 | ||||
| -rw-r--r-- | test/filename.adb | 40 | ||||
| -rw-r--r-- | test/hello.adb | 45 | ||||
| -rw-r--r-- | test/pixmap.adb | 175 |
14 files changed, 907 insertions, 27 deletions
diff --git a/test/animated.adb b/test/animated.adb index 42d2a49..4f6f590 100644 --- a/test/animated.adb +++ b/test/animated.adb @@ -34,7 +34,8 @@ is Dimension : constant Integer := 256; - subtype Image_Data is FLTK.Color_Component_Array (1 .. Dimension ** 2 * Channels); + subtype Image_Data is FLTK.Color_Component_Array + (1 .. FLTK.Size_Type (Dimension ** 2 * Channels)); type Image_Data_Array is array (Positive range <>) of Image_Data; @@ -43,7 +44,7 @@ is begin for X in Integer range 0 .. 9 loop for Y in Integer range 0 .. 9 loop - Store (Y * Dimension * Channels + X * Channels + 4) := 255; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 4)) := 255; end loop; end loop; end Black_Box_Corner; @@ -82,10 +83,10 @@ is My_Alpha := FLTK.Color_Component (Float (My_Alpha) * (1.0 - Fill) * 10.0); end if; - Store (Y * Dimension * Channels + X * Channels + 1) := Grey; - Store (Y * Dimension * Channels + X * Channels + 2) := Grey; - Store (Y * Dimension * Channels + X * Channels + 3) := Grey; - Store (Y * Dimension * Channels + X * Channels + 4) := My_Alpha; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 1)) := Grey; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 2)) := Grey; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 3)) := Grey; + Store (FLTK.Size_Type (Channels * (Y * Dimension + X) + 4)) := My_Alpha; end if; end loop; end loop; @@ -106,8 +107,10 @@ is if (X + X_Offset >= 0) and (X + X_Offset < Dimension) then for Y in Integer range Y_Offset - W .. Y_Offset + W - 1 loop Grey := FLTK.Color_Component (abs (Y - Y_Offset)); - Store (Y * Dimension * Channels + (X + X_Offset) * Channels + 3) := Grey; - Store (Y * Dimension * Channels + (X + X_Offset) * Channels + 4) := 127; + Store (FLTK.Size_Type + (Channels * (Y * Dimension + (X + X_Offset)) + 3)) := Grey; + Store (FLTK.Size_Type + (Channels * (Y * Dimension + (X + X_Offset)) + 4)) := 127; end loop; end if; end loop; @@ -130,7 +133,7 @@ is Frame_Image_Data : constant Image_Data_Array := Make_Image_Data; -- This syntax requires Ada 2022, but it allows all overt heap usage to be avoided - Frame_Images : array (Positive range <>) of RGB.RGB_Image := + Frame_Images : constant array (Positive range <>) of RGB.RGB_Image := (for Index in Frame_Image_Data'Range => RGB.Forge.Create (Frame_Image_Data (Index), Dimension, Dimension, Channels)); diff --git a/test/ask.adb b/test/ask.adb index cb12fff..81ab104 100644 --- a/test/ask.adb +++ b/test/ask.adb @@ -16,7 +16,6 @@ with FLTK.Widgets.Boxes, FLTK.Widgets.Buttons, FLTK.Widgets.Buttons.Enter, - FLTK.Widgets.Inputs.Text, FLTK.Widgets.Groups.Windows.Double; use type @@ -38,7 +37,6 @@ is package BX renames FLTK.Widgets.Boxes; package BTN renames FLTK.Widgets.Buttons; package ENT renames FLTK.Widgets.Buttons.Enter; - package INP renames FLTK.Widgets.Inputs.Text; package WD renames FLTK.Widgets.Groups.Windows.Double; @@ -54,7 +52,7 @@ is procedure Rename_Me (Item : in out FLTK.Widgets.Widget'Class) is - Input : String := AK.Text_Input ("Input:", Item.Get_Label); + Input : constant String := AK.Text_Input ("Input:", Item.Get_Label); begin Update_Input_Text (Item, Input); end Rename_Me; @@ -63,7 +61,7 @@ is procedure Rename_Me_Pwd (Item : in out FLTK.Widgets.Widget'Class) is - Input : String := AK.Password ("Input PWD:", Item.Get_Label); + Input : constant String := AK.Password ("Input PWD:", Item.Get_Label); begin Update_Input_Text (Item, Input); end Rename_Me_Pwd; @@ -72,7 +70,7 @@ is procedure Window_Callback (Item : in out FLTK.Widgets.Widget'Class) is - Hotspot : Boolean := AK.Get_Message_Hotspot; + Hotspot : constant Boolean := AK.Get_Message_Hotspot; Reply : AK.Choice_Result; begin AK.Set_Message_Hotspot (False); @@ -91,7 +89,7 @@ is Stop : Boolean := False; procedure Timer_Callback is - Message_Icon : BX.Box_Reference := AK.Get_Message_Icon; + Message_Icon : constant BX.Box_Reference := AK.Get_Message_Icon; My_Color : FLTK.Color; begin if Stop then diff --git a/test/bitmap.adb b/test/bitmap.adb index e6d5094..04f4793 100644 --- a/test/bitmap.adb +++ b/test/bitmap.adb @@ -10,7 +10,6 @@ with FLTK.Images.Bitmaps, - FLTK.Widgets.Buttons, FLTK.Widgets.Buttons.Toggle, FLTK.Widgets.Groups.Windows.Double; @@ -118,7 +117,7 @@ is procedure Button_Callback - (Item : in out FLTK.Widgets.Widget'Class) + (Ignore : in out FLTK.Widgets.Widget'Class) is New_Align : FLTK.Alignment; begin diff --git a/test/button.adb b/test/button.adb new file mode 100644 index 0000000..1cd6557 --- /dev/null +++ b/test/button.adb @@ -0,0 +1,67 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Button/callback test program functionality reproduced in Ada + + +with + + Ada.Command_Line, + FLTK.Asks, + FLTK.Widgets.Buttons, + FLTK.Widgets.Groups.Windows; + + +function Button + return Integer +is + + + package ACom renames Ada.Command_Line; + + package Ask renames FLTK.Asks; + package Wdg renames FLTK.Widgets; + package Btn renames FLTK.Widgets.Buttons; + package Win renames FLTK.Widgets.Groups.Windows; + + + procedure Beep_Callback + (Ignore : in out Wdg.Widget'Class) is + begin + Ask.Beep; + end Beep_Callback; + + + The_Window : Win.Window := Win.Forge.Create (320, 65); + + + procedure Exit_Callback + (Ignore : in out Wdg.Widget'Class) is + begin + ACom.Set_Exit_Status (ACom.Success); + The_Window.Hide; + end Exit_Callback; + + + Button_One : Btn.Button := Btn.Forge.Create (The_Window, 20, 20, 80, 25, "&Beep"); + Button_Two : Btn.Button := Btn.Forge.Create (The_Window, 120, 20, 80, 25, "&No Op"); + Button_Three : Btn.Button := Btn.Forge.Create (The_Window, 220, 20, 80, 25, "E&xit"); + + +begin + + + Button_One.Set_Callback (Beep_Callback'Unrestricted_Access); + Button_Three.Set_Callback (Exit_Callback'Unrestricted_Access); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Button; + + diff --git a/test/buttons.adb b/test/buttons.adb new file mode 100644 index 0000000..a502f44 --- /dev/null +++ b/test/buttons.adb @@ -0,0 +1,58 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Another button test program functionality reproduced in Ada + + +with + + FLTK.Widgets.Buttons.Enter, + FLTK.Widgets.Buttons.Light.Check, + FLTK.Widgets.Buttons.Light.Round, + FLTK.Widgets.Buttons.Repeat, + FLTK.Widgets.Groups.Windows; + + +function Buttons + return Integer +is + + + package Btn renames FLTK.Widgets.Buttons; + package Ent renames FLTK.Widgets.Buttons.Enter; + package Lit renames FLTK.Widgets.Buttons.Light; + package Chk renames FLTK.Widgets.Buttons.Light.Check; + package Ond renames FLTK.Widgets.Buttons.Light.Round; + package Rpt renames FLTK.Widgets.Buttons.Repeat; + package Win renames FLTK.Widgets.Groups.Windows; + + + The_Win : Win.Window := Win.Forge.Create (320, 130); + + + Base : Btn.Button := Btn.Forge.Create (The_Win, 10, 10, 130, 30, "Fl_Button"); + + + Enter : Ent.Enter_Button := Ent.Forge.Create (The_Win, 150, 10, 160, 30, "Fl_Return_Button"); + Repeat : Rpt.Repeat_Button := Rpt.Forge.Create (The_Win, 10, 50, 130, 30, "Fl_Repeat_Button"); + Light : Lit.Light_Button := Lit.Forge.Create (The_Win, 10, 90, 130, 30, "Fl_Light_Button"); + Round : Ond.Round_Button := Ond.Forge.Create (The_Win, 150, 50, 160, 30, "Fl_Round_Button"); + Check : Chk.Check_Button := Chk.Forge.Create (The_Win, 150, 90, 160, 30, "Fl_Check_Button"); + + +begin + + + Base.Set_Tooltip ("This is a Tooltip."); + + The_Win.Show_With_Args; + + return FLTK.Run; + + +end Buttons; + + diff --git a/test/clock.adb b/test/clock.adb new file mode 100644 index 0000000..e550941 --- /dev/null +++ b/test/clock.adb @@ -0,0 +1,50 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Clock test program functionality reproduced in Ada + + +with + + FLTK.Widgets.Clocks.Updated.Round, + FLTK.Widgets.Groups.Windows.Double; + + +function Clock + return Integer +is + + + package CL renames FLTK.Widgets.Clocks.Updated; + package CR renames FLTK.Widgets.Clocks.Updated.Round; + package WD renames FLTK.Widgets.Groups.Windows.Double; + + + Window_One : WD.Double_Window := WD.Forge.Create (220, 220, "Fl_Clock"); + Clock_One : constant CL.Updated_Clock := CL.Forge.Create (Window_One, 0, 0, 220, 220); + + Window_Two : WD.Double_Window := WD.Forge.Create (220, 220, "Fl_Round_Clock"); + Clock_Two : constant CR.Round_Clock := CR.Forge.Create (Window_Two, 0, 0, 220, 220); + + +begin + + + Window_One.Set_Resizable (Clock_One); + Window_Two.Set_Resizable (Clock_Two); + + Window_One.Set_X_Class ("Fl_Clock"); + Window_Two.Set_X_Class ("Fl_Clock"); + + Window_One.Show_With_Args; + Window_Two.Show; + + return FLTK.Run; + + +end Clock; + + diff --git a/test/color_chooser.adb b/test/color_chooser.adb new file mode 100644 index 0000000..1c7537c --- /dev/null +++ b/test/color_chooser.adb @@ -0,0 +1,164 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Color chooser test program functionality reproduced in Ada + + +with + + FLTK.Asks, + FLTK.Draw, + FLTK.Images.RGB, + FLTK.Static, + FLTK.Widgets.Boxes, + FLTK.Widgets.Buttons, + FLTK.Widgets.Groups.Color_Choosers, + FLTK.Widgets.Groups.Windows; + +use type + + FLTK.Color, + FLTK.Size_Type, + FLTK.Asks.Confirm_Result; + + +function Color_Chooser + return Integer +is + + + package Ask renames FLTK.Asks; + package FD renames FLTK.Draw; + package Img renames FLTK.Images.RGB; + package Stc renames FLTK.Static; + package Bx renames FLTK.Widgets.Boxes; + package Btn renames FLTK.Widgets.Buttons; + package CC renames FLTK.Widgets.Groups.Color_Choosers; + package Win renames FLTK.Widgets.Groups.Windows; + + + function Make_Image_Data + (W, H : in Positive) + return FLTK.Color_Component_Array + is + X_Frac, Y_Frac : Long_Float; + Offset : FLTK.Size_Type; + begin + return Data : FLTK.Color_Component_Array (1 .. FLTK.Size_Type (W * H * 3)) do + for Y in 0 .. H - 1 loop + Y_Frac := Long_Float (Y) / Long_Float (H - 1); + for X in 0 .. W - 1 loop + X_Frac := Long_Float (X) / Long_Float (W - 1); + Offset := 3 * FLTK.Size_Type (Y * W + X); + Data (Offset + 1) := + FLTK.Color_Component (255.0 * (1.0 - X_Frac) * (1.0 - Y_Frac)); + Data (Offset + 2) := + FLTK.Color_Component (255.0 * (1.0 - X_Frac) * Y_Frac); + Data (Offset + 3) := + FLTK.Color_Component (255.0 * X_Frac * Y_Frac); + end loop; + end loop; + end return; + end Make_Image_Data; + + + Image_Width, Image_Height : constant Natural := 100; + + The_Image_Data : constant FLTK.Color_Component_Array := + Make_Image_Data (Image_Width, Image_Height); + + + type Pens is new Bx.Box with null record; + + procedure Draw + (This : in out Pens) is + begin + for Offset in 0 .. 3 * 8 - 1 loop + FD.Set_Color (FLTK.Grey0_Color + FLTK.Color (Offset)); + FD.Line + (This.Get_X + Offset, This.Get_Y, + This.Get_X + Offset, This.Get_Y + This.Get_H); + end loop; + end Draw; + + + The_Window : Win.Window := Win.Forge.Create (400, 400); + + The_Box : Bx.Box := Bx.Forge.Create + (The_Window, 30, 30, 340, 340); + Hint_Box : Bx.Box := Bx.Forge.Create + (The_Window, 40, 40, 320, 30, "Pick background color with buttons:"); + + Button_One : Btn.Button := Btn.Forge.Create + (The_Window, 120, 80, 180, 30, "fl_show_colormap()"); + Button_Two : Btn.Button := Btn.Forge.Create + (The_Window, 120, 120, 180, 30, "fl_color_chooser()"); + + Image_Box : Bx.Box := Bx.Forge.Create (The_Window, 160, 190, Image_Width, Image_Height); + The_Image : Img.RGB_Image := Img.Forge.Create (The_Image_Data, Image_Width, Image_Height); + + Box_B : Bx.Box := Bx.Forge.Create (The_Window, 160, 310, 120, 30, "Example of fl_draw_image()"); + + My_Pens : Pens := + (Bx.Forge.Create (The_Window, 60, 180, 3 * 8, 120, "lines") + with null record); + + My_Color : FLTK.Color := FLTK.Background_Color; + + + procedure Callback_One + (Ignore : in out FLTK.Widgets.Widget'Class) is + begin + My_Color := Ask.Show_Colormap (My_Color); + The_Box.Set_Background_Color (My_Color); + Hint_Box.Set_Label_Color (FLTK.Contrast (FLTK.Black_Color, My_Color)); + The_Box.Parent.Redraw; + end Callback_One; + + + procedure Callback_Two + (Ignore : in out FLTK.Widgets.Widget'Class) + is + R, G, B : FLTK.Color_Component; + begin + Stc.Get_Color (My_Color, R, G, B); + if Ask.Color_Chooser ("New color:", R, G, B, CC.HSV) = Ask.Cancel then + return; + end if; + My_Color := FLTK.Free_Color; + Stc.Set_Color (FLTK.Free_Color, R, G, B); + The_Box.Set_Background_Color (FLTK.Free_Color); + Hint_Box.Set_Label_Color (FLTK.Contrast (FLTK.Black_Color, FLTK.Free_Color)); + The_Box.Parent.Redraw; + end Callback_Two; + + +begin + + + Stc.Set_Color (FLTK.Free_Color, 145, 159, 170); + My_Color := FLTK.Free_Color; + + The_Box.Set_Box (FLTK.Thin_Down_Box); + The_Box.Set_Background_Color (My_Color); + + Hint_Box.Set_Alignment (FLTK.Align_Inside); + + Button_One.Set_Callback (Callback_One'Unrestricted_Access); + Button_Two.Set_Callback (Callback_Two'Unrestricted_Access); + + Image_Box.Set_Image (The_Image); + + My_Pens.Set_Alignment (FLTK.Align_Top); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Color_Chooser; + + diff --git a/test/compare.adb b/test/compare.adb index 2273414..a631416 100644 --- a/test/compare.adb +++ b/test/compare.adb @@ -15,11 +15,11 @@ procedure Compare is package TIO renames Ada.Text_IO; package FFN renames FLTK.Filenames; - Aardvark : String := "aardvark"; - Zebra : String := "Zebra"; - Two : String := "item_2"; - Ten : String := "item_10"; - Cap_Ten : String := "Item_10"; + Aardvark : constant String := "aardvark"; + Zebra : constant String := "Zebra"; + Two : constant String := "item_2"; + Ten : constant String := "item_10"; + Cap_Ten : constant String := "Item_10"; begin diff --git a/test/cursor.adb b/test/cursor.adb new file mode 100644 index 0000000..93d3f2b --- /dev/null +++ b/test/cursor.adb @@ -0,0 +1,116 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Cursor test program functionality reproduced in Ada + + +with + + FLTK.Draw, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Menus.Choices, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + +use type + + FLTK.Callback_Flag; + + +function Cursor + return Integer +is + + + package FD renames FLTK.Draw; + package WD renames FLTK.Widgets.Groups.Windows.Double; + package MC renames FLTK.Widgets.Menus.Choices; + package HV renames FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + + The_Cursor : FLTK.Mouse_Cursor_Kind := FLTK.Default_Mouse; + + Cursor_Index_Low : constant Long_Float := + Long_Float (FLTK.Mouse_Cursor_Kind'Pos (FLTK.Mouse_Cursor_Kind'First)); + Cursor_Index_High : constant Long_Float := + Long_Float (FLTK.Mouse_Cursor_Kind'Pos (FLTK.Mouse_Cursor_Kind'Last)); + + + The_Window : WD.Double_Window := WD.Forge.Create (400, 300); + + The_Choices : MC.Choice := MC.Forge.Create + (The_Window, 80, 100, 200, 25, "Cursor:"); + + The_Slider : HV.Horizontal_Value_Slider := HV.Forge.Create + (The_Window, 80, 180, 310, 30, "Cursor:"); + + + procedure Choice_Callback + (This : in out FLTK.Widgets.Widget'Class) + is + My_Choice : MC.Choice renames MC.Choice (This); + begin + The_Cursor := FLTK.Mouse_Cursor_Kind'Val (My_Choice.Chosen_Index - 1); + The_Slider.Set_Value (Long_Float (FLTK.Mouse_Cursor_Kind'Pos (The_Cursor))); + FD.Set_Cursor (The_Cursor); + end Choice_Callback; + + + procedure Slider_Callback + (This : in out FLTK.Widgets.Widget'Class) + is + My_Slider : HV.Horizontal_Value_Slider renames HV.Horizontal_Value_Slider (This); + begin + The_Cursor := FLTK.Mouse_Cursor_Kind'Val (Integer (My_Slider.Get_Value)); + The_Choices.Set_Chosen (FLTK.Mouse_Cursor_Kind'Pos (The_Cursor) + 1); + FD.Set_Cursor (The_Cursor); + end Slider_Callback; + + +begin + + + The_Choices.Add ("FL_CURSOR_DEFAULT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_ARROW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_CROSS", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_WAIT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_INSERT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_HAND", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_HELP", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_MOVE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NS", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_WE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NWSE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NESW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_N", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_E", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_SE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_S", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_SW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_W", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NONE", Choice_Callback'Unrestricted_Access); + + The_Choices.Set_Callback (Choice_Callback'Unrestricted_Access); + The_Choices.Set_When (FLTK.When_Release + FLTK.When_Interact); + The_Choices.Set_Chosen (1); + + The_Slider.Set_Alignment (FLTK.Align_Left); + The_Slider.Set_Step_Bottom (1); + The_Slider.Set_Precision (0); + The_Slider.Set_Bounds (Cursor_Index_Low, Cursor_Index_High); + The_Slider.Set_Value (Cursor_Index_Low); + The_Slider.Set_Callback (Slider_Callback'Unrestricted_Access); + + The_Window.Set_Resizable (The_Window); + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Cursor; + + diff --git a/test/curve.adb b/test/curve.adb new file mode 100644 index 0000000..45269e8 --- /dev/null +++ b/test/curve.adb @@ -0,0 +1,164 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Curve drawing test program functionality duplicated in Ada + + +pragma Ada_2022; + + +with + + FLTK.Draw, + FLTK.Widgets.Buttons.Toggle, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + +function Curve + return Integer +is + + + package FDR renames FLTK.Draw; + package Tog renames FLTK.Widgets.Buttons.Toggle; + package WD renames FLTK.Widgets.Groups.Windows.Double; + package HV renames FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + + -- More convenient to have these all as floats instead of integers + Arg_Values : array (Positive range <>) of aliased Long_Float := + (20.0, 20.0, 50.0, 200.0, 100.0, 20.0, 200.0, 200.0, 0.0); + + Points : Boolean := False; + + + type Drawing_Widget is new FLTK.Widgets.Widget with null record; + + procedure Draw + (This : in out Drawing_Widget) is + begin + FDR.Push_Clip (This.Get_X, This.Get_Y, This.Get_W, This.Get_H); + FDR.Set_Color (FLTK.Dark3_Color); + FDR.Rect_Fill (This.Get_X, This.Get_Y, This.Get_W, This.Get_H); + FDR.Push_Matrix; + if Arg_Values (9) > 0.001 then + FDR.Translate + (Long_Float (This.Get_X) + Long_Float (This.Get_W) / 2.0, + Long_Float (This.Get_Y) + Long_Float (This.Get_H) / 2.0); + FDR.Rotate (Arg_Values (9)); + FDR.Translate + (-1.0 * (Long_Float (This.Get_X) + Long_Float (This.Get_W) / 2.0), + -1.0 * (Long_Float (This.Get_Y) + Long_Float (This.Get_H) / 2.0)); + end if; + FDR.Translate (Long_Float (This.Get_X), Long_Float (This.Get_Y)); + if not Points then + FDR.Set_Color (FLTK.White_Color); + FDR.Begin_Complex_Polygon; + FDR.Curve + (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), + Arg_Values (5), Arg_Values (6), Arg_Values (7), Arg_Values (8)); + FDR.End_Complex_Polygon; + end if; + FDR.Set_Color (FLTK.Black_Color); + FDR.Begin_Line; + FDR.Vertex (Arg_Values (1), Arg_Values (2)); + FDR.Vertex (Arg_Values (3), Arg_Values (4)); + FDR.Vertex (Arg_Values (5), Arg_Values (6)); + FDR.Vertex (Arg_Values (7), Arg_Values (8)); + FDR.End_Line; + FDR.Set_Color ((if Points then FLTK.White_Color else FLTK.Red_Color)); + if Points then FDR.Begin_Points; else FDR.Begin_Line; end if; + FDR.Curve + (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), + Arg_Values (5), Arg_Values (6), Arg_Values (7), Arg_Values (8)); + if Points then FDR.End_Points; else FDR.End_Line; end if; + FDR.Pop_Matrix; + FDR.Pop_Clip; + end Draw; + + + The_Window : WD.Double_Window := WD.Forge.Create (300, 555, "Curve Testing"); + + The_Drawing : Drawing_Widget := + (FLTK.Widgets.Forge.Create (The_Window, 10, 10, 280, 280) + with null record); + + The_Toggle : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 50, 525, 50, 25, "points"); + + + type My_Slider is new HV.Horizontal_Value_Slider with record + Index : Integer range Arg_Values'Range; + end record; + + X0_Str : aliased constant String := "X0"; + Y0_Str : aliased constant String := "Y0"; + X1_Str : aliased constant String := "X1"; + Y1_Str : aliased constant String := "Y1"; + X2_Str : aliased constant String := "X2"; + Y2_Str : aliased constant String := "Y2"; + X3_Str : aliased constant String := "X3"; + Y3_Str : aliased constant String := "Y3"; + Rotate_Str : aliased constant String := "rotate"; + + -- A straight up array of strings is not possible because of the different lengths + Slider_Labels : constant array (Positive range <>) of access constant String := + (X0_Str'Access, Y0_Str'Access, X1_Str'Access, Y1_Str'Access, + X2_Str'Access, Y2_Str'Access, X3_Str'Access, Y3_Str'Access, Rotate_Str'Access); + + -- This syntax requires Ada 2022, but it allows all overt heap usage to be avoided + Sliders : array (Positive range <>) of My_Slider := + (for Place in Slider_Labels'Range => + (HV.Forge.Create (The_Window, 50, 275 + Place * 25, 240, 25, Slider_Labels (Place).all) + with Index => Place)); + + + procedure Slider_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Slide : My_Slider renames My_Slider (Item); + begin + Arg_Values (Slide.Index) := Slide.Get_Value; + The_Drawing.Redraw; + end Slider_Callback; + + + procedure Points_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Toggle : Tog.Toggle_Button renames Tog.Toggle_Button (Item); + begin + Points := Toggle.Is_On; + The_Drawing.Redraw; + end Points_Callback; + + +begin + + + for Place in Sliders'Range loop + Sliders (Place).Set_Minimum (0.0); + if Place = 9 then + Sliders (Place).Set_Maximum (360.0); + else + Sliders (Place).Set_Maximum (280.0); + end if; + Sliders (Place).Set_Step_Bottom (1); + Sliders (Place).Set_Value (Arg_Values (Place)); + Sliders (Place).Set_Alignment (FLTK.Align_Left); + Sliders (Place).Set_Callback (Slider_Callback'Unrestricted_Access); + end loop; + + The_Toggle.Set_Callback (Points_Callback'Unrestricted_Access); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Curve; + + diff --git a/test/dirlist.adb b/test/dirlist.adb index 1a07515..a7c159a 100644 --- a/test/dirlist.adb +++ b/test/dirlist.adb @@ -39,7 +39,7 @@ begin end if; declare - Name : Fil.Path_String := Fil.Expand (ACom.Argument (1)); + Name : constant Fil.Path_String := Fil.Expand (ACom.Argument (1)); begin if not Fil.Is_Directory (Name) then TIO.Put_Line ("Error: " & Name & " is not a valid directory."); @@ -48,7 +48,7 @@ begin end if; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Alpha_Sort'Access); + The_List : constant Fil.File_List := Fil.Get_Listing (Name, Fil.Alpha_Sort'Access); begin TIO.Put_Line ("Alphabetical Sort:"); for Index in 1 .. The_List.Length loop @@ -58,7 +58,7 @@ begin end; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Alpha_Sort'Access); + The_List : constant Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Alpha_Sort'Access); begin TIO.Put_Line ("Case Insensitive Alphabetical Sort:"); for Index in 1 .. The_List.Length loop @@ -68,7 +68,7 @@ begin end; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Numeric_Sort'Access); + The_List : constant Fil.File_List := Fil.Get_Listing (Name, Fil.Numeric_Sort'Access); begin TIO.Put_Line ("Numeric Sort:"); for Index in 1 .. The_List.Length loop @@ -78,7 +78,8 @@ begin end; declare - The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Numeric_Sort'Access); + The_List : constant Fil.File_List := + Fil.Get_Listing (Name, Fil.Case_Numeric_Sort'Access); begin TIO.Put_Line ("Case Insensitive Numeric Sort:"); for Index in 1 .. The_List.Length loop diff --git a/test/filename.adb b/test/filename.adb new file mode 100644 index 0000000..937fba4 --- /dev/null +++ b/test/filename.adb @@ -0,0 +1,40 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Command_Line, + Ada.Text_IO, + FLTK.Filenames; + + +procedure Filename is + + package ACom renames Ada.Command_Line; + package TIO renames Ada.Text_IO; + package Fil renames FLTK.Filenames; + +begin + + TIO.Put_Line ("Test program for FLTK filename absolute and expand functions."); + TIO.New_Line; + TIO.Put ("Input: "); + + if ACom.Argument_Count /= 1 then + TIO.Put_Line ("Error: Need exactly one filename argument."); + ACom.Set_Exit_Status (ACom.Failure); + return; + end if; + + TIO.Put_Line (ACom.Argument (1)); + TIO.New_Line; + + TIO.Put_Line ("Absolute: " & Fil.Absolute (ACom.Argument (1))); + TIO.Put_Line ("Expanded: " & Fil.Expand (ACom.Argument (1))); + +end Filename; + + diff --git a/test/hello.adb b/test/hello.adb new file mode 100644 index 0000000..1fcdf9d --- /dev/null +++ b/test/hello.adb @@ -0,0 +1,45 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Hello, World! program functionality reproduced in Ada + + +with + + FLTK.Widgets.Boxes, + FLTK.Widgets.Groups.Windows; + + +function Hello + return Integer +is + + + package Bx renames FLTK.Widgets.Boxes; + package Win renames FLTK.Widgets.Groups.Windows; + + + The_Window : Win.Window := Win.Forge.Create (340, 180); + + The_Box : Bx.Box := Bx.Forge.Create (The_Window, 20, 40, 300, 100, "Hello, World!"); + + +begin + + + The_Box.Set_Box (FLTK.Up_Box); + The_Box.Set_Label_Font (FLTK.Helvetica_Bold_Italic); + The_Box.Set_Label_Size (36); + The_Box.Set_Label_Kind (FLTK.Shadow_Label); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Hello; + + diff --git a/test/pixmap.adb b/test/pixmap.adb new file mode 100644 index 0000000..a9cf6b7 --- /dev/null +++ b/test/pixmap.adb @@ -0,0 +1,175 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Pixmap label test program functionality reproduced in Ada + + +with + + Ada.Strings.Unbounded, + FLTK.Images.Pixmaps, + FLTK.Widgets.Buttons.Toggle, + FLTK.Widgets.Groups.Windows.Double; + +use type + + FLTK.Alignment; + + +function Pixmap + return Integer +is + + + package SU renames Ada.Strings.Unbounded; + + function "+" (Str : in String) return SU.Unbounded_String renames SU.To_Unbounded_String; + + package Pix renames FLTK.Images.Pixmaps; + package Btn renames FLTK.Widgets.Buttons; + package Tog renames FLTK.Widgets.Buttons.Toggle; + package WD renames FLTK.Widgets.Groups.Windows.Double; + + + Porsche_Header : constant Pix.Header := (64, 64, 4, 1); + + Porsche_Colors : constant Pix.Color_Definition_Array := + ((Name => +" ", Kind => Pix.Colorful, Value => +"#background"), + (Name => +".", Kind => Pix.Colorful, Value => +"#000000000000"), + (Name => +"X", Kind => Pix.Colorful, Value => +"#ffd100"), + (Name => +"o", Kind => Pix.Colorful, Value => +"#FFFF00000000")); + + Porsche_Data : constant Pix.Pixmap_Data := + (" ", + " .......................... ", + " ..................................... ", + " ............XXXXXXXXXXXXXXXXXXXXXXXX............ ", + " ......XXXXXXX...XX...XXXXXXXX...XXXXXXXXXX...... ", + " ..XXXXXXXXXX..X..XX..XXXX.XXXX..XXXXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..X..XX..XXX..XXXX..X...XXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XX.....XX..XX.XXXXXXXXXXX.. ", + " ..XXXXXXXXX.....XXX..XXX..XXXX..X.XXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..XXXX....XXXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..XXXX..X..XXXXXXXXXXX.. ", + " ..XXXXXXXXXX..XXXXX..XXX..X.XX..XX..XXXXXXXXXX.. ", + " ..XXXXXXXXX....XXX....XXX..XX....XX..XXXXXXXXX.. ", + " ..XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.. ", + " ..XXXXXXXXX..........................XXXXXXXXX.. ", + " ..XXX.......XXXXXXXXXXX...................XXXX.. ", + " ......XX.XXX.XXX..XXXXX......................... ", + " ..XXXXX.XXX.XXX.XXXX.XX......................... ", + " ..XXXX.XXX.XX.......XXX......................... ", + " ..XXXX.......XXXXXX..XX..ooooooooooooooooooooo.. ", + " ..X.....XXXXXXXXXXXXXXX..ooooooooooooooooooooo.. ", + " ..X...XXXXXXXXXXXXXXXXX..ooooooooooooooooooooo.. ", + " ..X..XXXXXXX.XX.XXXXXXX..ooooooooooooooooooooo.. ", + " ..XXXXX.XXX.XX.XXXXXXXX..ooooooooooooooooooooo.. ", + " ..XXXX.XXX.XX.XX................................ ", + " ..XXXX.X.........X....X.X.X..................... ", + " ..XXXX...XXXXXXX.X..X...X.X.X.X................. ", + " ..X....XXXXXXXXXX.X...X.X.X..................... ", + " ..X...XXXXXXXXXX.XXXXXXXXXXXXXX................. ", + " ..X..XXXXXX.XX.X.XXX...XXXXXXXX................. ", + " ..XXXXX.XX.XX.XX.XX.....XXXXXXX.oooooooooooooo.. ", + " ..XXXX.XX.XX.XX..XX.X...XXXXX.X.oooooooooooooo.. ", + " ..XXXX.X.......X.XXXX...XXXX..X.oooooooooooooo.. ", + " ..X......XXXXXX..XXXX...XXXX..X.oooooooooooooo.. ", + " ..X...XXXXXXXXXX.XXX.....XXX.XX.oooooooooooooo.. ", + " ..X..XXXXXXXXXXX.X...........XX.oooooooooooooo.. ", + " .................X.X.........XX................. ", + " .................X.X.XXXX....XX.XXXXXXXXXXXXXX.. ", + " .................XXX.XXXXX.X.XX.XXX.XX.XXXXXXX.. ", + " ................XXXX.XXX..X..X.XX.XX.XXX.XXX.. ", + " ................XXXXXXXX.XX.XX.X.XX.XXX.XXXX.. ", + " .................XXXXXX.XX.XX.X..........XXX.. ", + " ..oooooooooooooo.XXXXXXXXXX....XXXXXXXX..X.. ", + " ..ooooooooooooooo.XXXXXXXX....XXXXXXXXXXXX.. ", + " ..ooooooooooooooo........XXXXXXX.XX.XXXX.. ", + " ..oooooooooooooooooo..XXXXX.XXX.XX.XX.XX.. ", + " ..ooooooooooooooooo..XXXX.XXX.XX.XX.XX.. ", + " ..ooooooooooooooooo..XXX.XX........XXX.. ", + " ....................XXX....XXXXXX..X.. ", + " ...................XX...XXXXXXXXXXX. ", + " ...................X...XXXXXXXXXXX.. ", + " ..................X..XXXX.XXXXXX.. ", + " .................XXX.XX.XX.XXX.. ", + " ................XX.XX.XX.XXX.. ", + " ..ooooooooooo..XX.......XX.. ", + " ..oooooooooo..X...XXXX.X.. ", + " ..ooooooooo..X..XXXXXX.. ", + " ...ooooooo..X..XXXX... ", + " ....ooooo..XXXXX.... ", + " ....ooo..XXX.... ", + " ....o..X.... ", + " ........ ", + " .... ", + " "); + + + The_Window : WD.Double_Window := WD.Forge.Create (400, 400, "Badgery of Pixmap Labels"); + + The_Button : Btn.Button := Btn.Forge.Create (The_Window, 140, 160, 120, 120, "Pixmap"); + + The_Pixmap : Pix.Pixmap := Pix.Forge.Create (Porsche_Header, Porsche_Colors, Porsche_Data); + De_Pixmap : Pix.Pixmap'Class := The_Pixmap.Copy; + + Left_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 25, 50, 50, 25, "left"); + Right_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 75, 50, 50, 25, "right"); + Top_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 125, 50, 50, 25, "top"); + Bottom_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 175, 50, 50, 25, "bottom"); + Inside_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 225, 50, 50, 25, "inside"); + Over_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 25, 75, 100, 25, "text over"); + Inact_Btn : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 125, 75, 100, 25, "inactive"); + + + procedure Button_Callback + (Ignore : in out FLTK.Widgets.Widget'Class) + is + New_Align : FLTK.Alignment; + begin + if Left_Btn.Is_On then New_Align := New_Align + FLTK.Align_Left; end if; + if Right_Btn.Is_On then New_Align := New_Align + FLTK.Align_Right; end if; + if Top_Btn.Is_On then New_Align := New_Align + FLTK.Align_Top; end if; + if Bottom_Btn.Is_On then New_Align := New_Align + FLTK.Align_Bottom; end if; + if Inside_Btn.Is_On then New_Align := New_Align + FLTK.Align_Inside; end if; + if Over_Btn.Is_On then New_Align := New_Align + FLTK.Align_Text_Over_Image; end if; + The_Button.Set_Alignment (New_Align); + + if Inact_Btn.Is_On then + The_Button.Deactivate; + else + The_Button.Activate; + end if; + + The_Window.Redraw; + end Button_Callback; + + +begin + + + De_Pixmap.Inactive; + + The_Button.Set_Image (The_Pixmap); + The_Button.Set_Inactive_Image (De_Pixmap); + + Left_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Right_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Top_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Bottom_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Inside_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Over_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + Inact_Btn.Set_Callback (Button_Callback'Unrestricted_Access); + + The_Window.Set_Resizable (The_Window); + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Pixmap; + + |