diff options
Diffstat (limited to 'test')
| -rw-r--r-- | test/button.adb | 67 | ||||
| -rw-r--r-- | test/buttons.adb | 59 | ||||
| -rw-r--r-- | test/clock.adb | 50 | ||||
| -rw-r--r-- | test/color_chooser.adb | 162 | ||||
| -rw-r--r-- | test/cursor.adb | 116 | ||||
| -rw-r--r-- | test/curve.adb | 164 | ||||
| -rw-r--r-- | test/hello.adb | 45 |
7 files changed, 663 insertions, 0 deletions
diff --git a/test/button.adb b/test/button.adb new file mode 100644 index 0000000..9ca6102 --- /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 + (This : in out Wdg.Widget'Class) is + begin + Ask.Beep; + end Beep_Callback; + + + The_Window : Win.Window := Win.Forge.Create (320, 65); + + + procedure Exit_Callback + (This : 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..e93da8e --- /dev/null +++ b/test/buttons.adb @@ -0,0 +1,59 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Another button test program functionality reproduced in Ada + + +with + + FLTK.Tooltips, + 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..b4d8f40 --- /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 : 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 : 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..09003b9 --- /dev/null +++ b/test/color_chooser.adb @@ -0,0 +1,162 @@ + + +-- 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.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 : Integer; + begin + return Data : FLTK.Color_Component_Array (1 .. 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 * (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 : 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 + (This : 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 + (This : 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/cursor.adb b/test/cursor.adb new file mode 100644 index 0000000..e968b6f --- /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.Widgets.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.Widgets.When_Release + FLTK.Widgets.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/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; + + |