From d6458841c9134a3b6d8ca260766fca64a72740aa Mon Sep 17 00:00:00 2001 From: Jedidiah Barber <contact@jedbarber.id.au> Date: Wed, 22 Jan 2025 15:40:12 +1300 Subject: Arc testing program and Valuator Format subprogram bugfix --- test/arc.adb | 149 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 149 insertions(+) create mode 100644 test/arc.adb (limited to 'test') diff --git a/test/arc.adb b/test/arc.adb new file mode 100644 index 0000000..88d2214 --- /dev/null +++ b/test/arc.adb @@ -0,0 +1,149 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Arc drawing test program functionality duplicated in Ada + + +with + + FLTK.Draw, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + +function Arc + return Integer +is + + + package FDR renames FLTK.Draw; + 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 := + (140.0, 140.0, 50.0, 0.0, 360.0, 0.0); + + + 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 (6) > 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 (6)); + 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.Set_Color (FLTK.White_Color); + FDR.Translate (Long_Float (This.Get_X), Long_Float (This.Get_Y)); + FDR.Begin_Complex_Polygon; + FDR.Arc (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), Arg_Values (5)); + FDR.Gap; + FDR.Arc (140.0, 140.0, 20.0, 0.0, -360.0); + FDR.End_Complex_Polygon; + FDR.Set_Color (FLTK.Red_Color); + FDR.Begin_Line; + FDR.Arc (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), Arg_Values (5)); + FDR.End_Line; + FDR.Pop_Matrix; + FDR.Pop_Clip; + end Draw; + + + The_Window : WD.Double_Window := WD.Forge.Create (300, 460, "Arc Testing"); + + The_Drawing : Drawing_Widget := + (FLTK.Widgets.Forge.Create (The_Window, 10, 10, 280, 280) + with null record); + + + type My_Slider is new HV.Horizontal_Value_Slider with record + Index : Integer range Arg_Values'Range; + end record; + + + -- Trying out some stack allocation for this one + + Slider_One : aliased My_Slider := + (HV.Forge.Create (The_Window, 50, 300, 240, 25, "X") + with Index => 1); + + Slider_Two : aliased My_Slider := + (HV.Forge.Create (The_Window, 50, 325, 240, 25, "Y") + with Index => 2); + + Slider_Three : aliased My_Slider := + (HV.Forge.Create (The_Window, 50, 350, 240, 25, "R") + with Index => 3); + + Slider_Four : aliased My_Slider := + (HV.Forge.Create (The_Window, 50, 375, 240, 25, "start") + with Index => 4); + + Slider_Five : aliased My_Slider := + (HV.Forge.Create (The_Window, 50, 400, 240, 25, "end") + with Index => 5); + + Slider_Six : aliased My_Slider := + (HV.Forge.Create (The_Window, 50, 425, 240, 25, "rotate") + with Index => 6); + + + type Slider_Access is access all My_Slider; + + Sliders : array (Positive range <>) of Slider_Access := + (Slider_One'Access, Slider_Two'Access, Slider_Three'Access, + Slider_Four'Access, Slider_Five'Access, Slider_Six'Access); + + + 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; + + +begin + + + for Place in Integer range 1 .. 6 loop + if Place <= 3 then + Sliders (Place).Set_Minimum (0.0); + Sliders (Place).Set_Maximum (300.0); + elsif Place = 6 then + Sliders (Place).Set_Minimum (0.0); + Sliders (Place).Set_Maximum (360.0); + else + Sliders (Place).Set_Minimum (-360.0); + Sliders (Place).Set_Maximum (360.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_Window.Show_With_Args; + + return FLTK.Run; + + +end Arc; + + -- cgit