Ask and Bitmap test programsHEADmaster

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;
+
+