1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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;
|
