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