4cae72752f3e6fb2db35ea50b63d194c68e496dd
[ncurses.git] / Ada95 / samples / sample-function_key_setting.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                       GNAT ncurses Binding Samples                       --
4 --                                                                          --
5 --                         Sample.Function_Key_Setting                      --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 --  Version 00.92                                                           --
10 --                                                                          --
11 --  The ncurses Ada95 binding is copyrighted 1996 by                        --
12 --  Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de                     --
13 --                                                                          --
14 --  Permission is hereby granted to reproduce and distribute this           --
15 --  binding by any means and for any fee, whether alone or as part          --
16 --  of a larger distribution, in source or in binary form, PROVIDED         --
17 --  this notice is included with any such distribution, and is not          --
18 --  removed from any of its header files. Mention of ncurses and the        --
19 --  author of this binding in any applications linked with it is            --
20 --  highly appreciated.                                                     --
21 --                                                                          --
22 --  This binding comes AS IS with no warranty, implied or expressed.        --
23 ------------------------------------------------------------------------------
24 --  Version Control
25 --  $Revision: 1.3 $
26 ------------------------------------------------------------------------------
27 with Ada.Unchecked_Deallocation;
28 with Sample.Manifest; use  Sample.Manifest;
29
30 --  This package implements a simple stack of function key label environments.
31 --
32 package body Sample.Function_Key_Setting is
33
34    Max_Label_Length : constant Positive := 8;
35    Number_Of_Keys   : Label_Number := Label_Number'Last;
36    Justification    : Label_Justification := Left;
37
38    subtype Label is String (1 .. Max_Label_Length);
39    type Label_Array is array (Label_Number range <>) of Label;
40
41    type Key_Environment (N : Label_Number := Label_Number'Last);
42    type Env_Ptr is access Key_Environment;
43    pragma Controlled (Env_Ptr);
44
45    type String_Access is access String;
46    pragma Controlled (String_Access);
47
48    Active_Context : String_Access := new String'("MAIN");
49    Active_Notepad : Panel := Null_Panel;
50
51    type Key_Environment  (N : Label_Number := Label_Number'Last) is
52       record
53          Prev    : Env_Ptr;
54          Help    : String_Access;
55          Notepad : Panel;
56          Labels  : Label_Array (1 .. N);
57       end record;
58
59    procedure Release_String is
60      new Ada.Unchecked_Deallocation (String,
61                                      String_Access);
62
63    procedure Release_Environment is
64       new Ada.Unchecked_Deallocation (Key_Environment,
65                                       Env_Ptr);
66
67    Top_Of_Stack : Env_Ptr := null;
68
69    procedure Push_Environment (Key   : in String;
70                                Reset : in Boolean := True)
71    is
72       P : constant Env_Ptr := new Key_Environment (Number_Of_Keys);
73    begin
74       --  Store the current labels in the environment
75       for I in 1 .. Number_Of_Keys loop
76          Get_Soft_Label_Key (I, P.Labels (I));
77          if Reset then
78             Set_Soft_Label_Key (I, " ");
79          end if;
80       end loop;
81       P.Prev := Top_Of_Stack;
82       --  now store active help context and notepad
83       P.Help := Active_Context;
84       P.Notepad := Active_Notepad;
85       --  The notepad must now vanish and the new notepad is empty.
86       if (P.Notepad /= Null_Panel) then
87          Hide (P.Notepad);
88          Update_Panels;
89       end if;
90       Active_Notepad := Null_Panel;
91       Active_Context := new String'(Key);
92
93       Top_Of_Stack := P;
94       if Reset then
95          Refresh_Soft_Label_Keys_Without_Update;
96       end if;
97    end Push_Environment;
98
99    procedure Pop_Environment
100    is
101       P : Env_Ptr := Top_Of_Stack;
102    begin
103       if Top_Of_Stack = null then
104          raise Function_Key_Stack_Error;
105       else
106          for I in 1 .. Number_Of_Keys loop
107             Set_Soft_Label_Key (I, P.Labels (I), Justification);
108          end loop;
109          pragma Assert (Active_Context /= null);
110          Release_String (Active_Context);
111          Active_Context := P.Help;
112          Refresh_Soft_Label_Keys_Without_Update;
113          Notepad_To_Context (P.Notepad);
114          Top_Of_Stack := P.Prev;
115          Release_Environment (P);
116       end if;
117    end Pop_Environment;
118
119    function Context return String
120    is
121    begin
122       if Active_Context /= null then
123          return Active_Context.all;
124       else
125          return "";
126       end if;
127    end Context;
128
129    function Find_Context (Key : String) return Boolean
130    is
131       P : Env_Ptr := Top_Of_Stack;
132    begin
133       if Active_Context.all = Key then
134          return True;
135       else
136          loop
137             exit when P = null;
138             if P.Help.all = Key then
139                return True;
140             else
141                P := P.Prev;
142             end if;
143          end loop;
144          return False;
145       end if;
146    end Find_Context;
147
148    procedure Notepad_To_Context (Pan : in Panel)
149    is
150       W : Window;
151    begin
152       if Active_Notepad /= Null_Panel then
153          W := Get_Window (Active_Notepad);
154          Clear (W);
155          Delete (Active_Notepad);
156          Delete (W);
157       end if;
158       Active_Notepad := Pan;
159       if Pan /= Null_Panel then
160          Top  (Pan);
161       end if;
162       Update_Panels;
163       Update_Screen;
164    end Notepad_To_Context;
165
166    procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style;
167                          Just : Label_Justification := Left)
168    is
169    begin
170       case Mode is
171          when PC_Style .. PC_Style_With_Index
172            => Number_Of_Keys := 12;
173          when others
174            => Number_Of_Keys := 8;
175       end case;
176       Init_Soft_Label_Keys (Mode);
177       Justification := Just;
178    end Initialize;
179
180    procedure Default_Labels
181    is
182    begin
183       Set_Soft_Label_Key (FKEY_QUIT, "Quit");
184       Set_Soft_Label_Key (FKEY_HELP, "Help");
185       Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys");
186       Refresh_Soft_Label_Keys_Without_Update;
187    end Default_Labels;
188
189    function Notepad_Window return Window
190    is
191    begin
192       if Active_Notepad /= Null_Panel then
193          return Get_Window (Active_Notepad);
194       else
195          return Null_Window;
196       end if;
197    end Notepad_Window;
198
199 end Sample.Function_Key_Setting;