diff options
Diffstat (limited to 'test/curve.adb')
| -rw-r--r-- | test/curve.adb | 164 |
1 files changed, 164 insertions, 0 deletions
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; + + |