diff options
Diffstat (limited to 'test/ask.adb')
| -rw-r--r-- | test/ask.adb | 144 |
1 files changed, 144 insertions, 0 deletions
diff --git a/test/ask.adb b/test/ask.adb new file mode 100644 index 0000000..201d245 --- /dev/null +++ b/test/ask.adb @@ -0,0 +1,144 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Standard dialog test program functionality reproduced in Ada + + +with + + Ada.Characters.Latin_1, + Ada.Command_Line, + FLTK.Asks, + FLTK.Static, + FLTK.Widgets.Boxes, + FLTK.Widgets.Buttons, + FLTK.Widgets.Buttons.Enter, + FLTK.Widgets.Inputs.Text, + FLTK.Widgets.Groups.Windows.Double; + +use type + + FLTK.Asks.Choice_Result, + FLTK.Color; + + +function Ask + return Integer +is + + + package Latin renames Ada.Characters.Latin_1; + package ACom renames Ada.Command_Line; + + package AK renames FLTK.Asks; + package Stc renames FLTK.Static; + 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; + + + procedure Update_Input_Text + (Item : in out FLTK.Widgets.Widget'Class; + Text : in String) is + begin + Item.Set_Label (Text); + Item.Redraw; + end Update_Input_Text; + + + procedure Rename_Me + (Item : in out FLTK.Widgets.Widget'Class) + is + Input : String := AK.Text_Input ("Input:", Item.Get_Label); + begin + Update_Input_Text (Item, Input); + end Rename_Me; + + + procedure Rename_Me_Pwd + (Item : in out FLTK.Widgets.Widget'Class) + is + Input : String := AK.Password ("Input PWD:", Item.Get_Label); + begin + Update_Input_Text (Item, Input); + end Rename_Me_Pwd; + + + procedure Window_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Hotspot : Boolean := AK.Get_Message_Hotspot; + Reply : AK.Choice_Result; + begin + AK.Set_Message_Hotspot (False); + AK.Set_Message_Title ("Note: No hotspot set for this dialog"); + Reply := AK.Choice ("Are you sure you want to quit?", "Cancel", "Quit", "Dunno"); + AK.Set_Message_Hotspot (Hotspot); + if Reply = AK.Second then + ACom.Set_Exit_Status (ACom.Success); + WD.Double_Window (Item).Hide; + elsif Reply = AK.Third then + AK.Message_Box ("Well, maybe you should know before we quit."); + end if; + end Window_Callback; + + + Stop : Boolean := False; + + procedure Timer_Callback is + Change : Long_Float := 5.0; + Message_Icon : BX.Box_Reference := AK.Get_Message_Icon; + My_Color : FLTK.Color; + begin + Stc.Repeat_Timeout (Change, Timer_Callback'Unrestricted_Access); + + if Stop then + Message_Icon.Set_Background_Color (FLTK.White_Color); + return; + end if; + + My_Color := Message_Icon.Get_Background_Color; + My_Color := (My_Color + 1) mod 32; + if My_Color = Message_Icon.Get_Label_Color then + My_Color := My_Color + 1; + end if; + Message_Icon.Set_Background_Color (My_Color); + + Stop := AK.Choice + ("Timeout. Click the 'Close' button." & Latin.LF & + "Note: This message is blocked in FLTK 1.3" & Latin.LF & + "if another message window is open." & Latin.LF & + "This message should pop up every 5 seconds.", + "Close", "Stop these funny popups") = AK.Second; + end Timer_Callback; + + + The_Window : WD.Double_Window := WD.Forge.Create (200, 105, "Ask Test"); + + Button_One : ENT.Enter_Button := ENT.Forge.Create (The_Window, 20, 10, 160, 35, "Test text"); + Button_Two : BTN.Button := BTN.Forge.Create (The_Window, 20, 50, 160, 35, "MyPassword"); + + +begin + + + Button_One.Set_Callback (Rename_Me'Unrestricted_Access); + Button_Two.Set_Callback (Rename_Me_Pwd'Unrestricted_Access); + + The_Window.Set_Resizable (Button_One); + The_Window.Set_Callback (Window_Callback'Unrestricted_Access); + The_Window.Show_With_Args; + + Stc.Add_Timeout (5.0, Timer_Callback'Unrestricted_Access); + + return FLTK.Run; + + +end Ask; + + |