ncurses 4.1
[ncurses.git] / Ada95 / samples / sample-explanation.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                       GNAT ncurses Binding Samples                       --
4 --                                                                          --
5 --                           Sample.Explanation                             --
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.6 $
26 ------------------------------------------------------------------------------
27 --  Poor mans help system. This scans a sequential file for key lines and
28 --  then reads the lines up to the next key. Those lines are presented in
29 --  a window as help or explanation.
30 --
31 with Ada.Text_IO; use Ada.Text_IO;
32 with Ada.Unchecked_Deallocation;
33 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
34 with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels;
35
36 with Sample.Keyboard_Handler; use Sample.Keyboard_Handler;
37 with Sample.Manifest; use Sample.Manifest;
38 with Sample.Function_Key_Setting; use Sample.Function_Key_Setting;
39 with Sample.Helpers; use Sample.Helpers;
40
41 package body Sample.Explanation is
42
43    Help_Keys : constant String := "HELPKEYS";
44    In_Help   : constant String := "INHELP";
45
46    File_Name : String := "explain.msg";
47    F : File_Type;
48
49    type Help_Line;
50    type Help_Line_Access is access Help_Line;
51    pragma Controlled (Help_Line_Access);
52    type String_Access is access String;
53    pragma Controlled (String_Access);
54
55    type Help_Line is
56       record
57          Prev, Next : Help_Line_Access;
58          Line : String_Access;
59       end record;
60
61    procedure Explain (Key : in String;
62                       Win : in Window);
63
64    procedure Release_String is
65      new Ada.Unchecked_Deallocation (String,
66                                      String_Access);
67    procedure Release_Help_Line is
68      new Ada.Unchecked_Deallocation (Help_Line,
69                                      Help_Line_Access);
70
71    function Search (Key : String) return Help_Line_Access;
72    procedure Release_Help (Root : in out Help_Line_Access);
73
74    procedure Explain (Key : in String)
75    is
76    begin
77       Explain (Key, Null_Window);
78    end Explain;
79
80    procedure Explain (Key : in String;
81                       Win : in Window)
82    is
83       --  Retrieve the text associated with this key and display it in this
84       --  window. If no window argument is passed, the routine will create
85       --  a temporary window and use it.
86
87       function Filter_Key return Real_Key_Code;
88       procedure Unknown_Key;
89       procedure Redo;
90       procedure To_Window (C   : in out Help_Line_Access;
91                           More : in out Boolean);
92
93       Frame : Window := Null_Window;
94
95       W : Window := Win;
96       K : Real_Key_Code;
97       P : Panel;
98
99       Height   : Line_Count;
100       Width    : Column_Count;
101       Help     : Help_Line_Access := Search (Key);
102       Current  : Help_Line_Access;
103       Top_Line : Help_Line_Access;
104
105       Has_More : Boolean;
106
107       procedure Unknown_Key
108       is
109       begin
110          Add (W, "Help message with ID ");
111          Add (W, Key);
112          Add (W, " not found.");
113          Add (W, Character'Val (10));
114          Add (W, "Press the Function key labelled 'Quit' key to continue.");
115       end Unknown_Key;
116
117       procedure Redo
118       is
119          H : Help_Line_Access := Top_Line;
120       begin
121          if Top_Line /= null then
122             for L in 0 .. (Height - 1) loop
123                Add (W, L, 0, H.Line.all);
124                exit when H.Next = null;
125                H := H.Next;
126             end loop;
127          else
128             Unknown_Key;
129          end if;
130       end Redo;
131
132       function Filter_Key return Real_Key_Code
133       is
134          K : Real_Key_Code;
135       begin
136          loop
137             K := Get_Key (W);
138             if K in Special_Key_Code'Range then
139                case K is
140                   when HELP_CODE =>
141                      if not Find_Context (In_Help) then
142                         Push_Environment (In_Help, False);
143                         Explain (In_Help, W);
144                         Pop_Environment;
145                         Redo;
146                      end if;
147                   when EXPLAIN_CODE =>
148                      if not Find_Context (Help_Keys) then
149                         Push_Environment (Help_Keys, False);
150                         Explain (Help_Keys, W);
151                         Pop_Environment;
152                         Redo;
153                      end if;
154                   when others => exit;
155                end case;
156             else
157                exit;
158             end if;
159          end loop;
160          return K;
161       end Filter_Key;
162
163       procedure To_Window (C   : in out Help_Line_Access;
164                           More : in out Boolean)
165       is
166          L : Line_Position := 0;
167       begin
168          loop
169             Add (W, L, 0, C.Line.all);
170             L := L + 1;
171             exit when C.Next = null or else L = Height;
172             C := C.Next;
173          end loop;
174          if C.Next /= null then
175             pragma Assert (L = Height);
176             More := True;
177          else
178             More := False;
179          end if;
180       end To_Window;
181
182    begin
183       if W = Null_Window then
184          Push_Environment ("HELP");
185          Default_Labels;
186          Frame := New_Window (Lines - 2, Columns, 0, 0);
187          if Has_Colors then
188             Set_Background (Win => Frame,
189                             Ch  => (Ch    => ' ',
190                                     Color => Help_Color,
191                                     Attr  => Normal_Video));
192             Set_Character_Attributes (Win   => Frame,
193                                       Attr  => Normal_Video,
194                                       Color => Help_Color);
195             Erase (Frame);
196          end if;
197          Box (Frame);
198          Set_Character_Attributes (Frame, (Reverse_Video => True,
199                                            others        => False));
200          Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls");
201          Set_Character_Attributes (Frame); -- Back to default.
202          Window_Title (Frame, "Explanation");
203          W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1);
204          Refresh_Without_Update (Frame);
205          Get_Size (W, Height, Width);
206          Set_Meta_Mode (W);
207          Set_KeyPad_Mode (W);
208          Allow_Scrolling (W, True);
209          Set_Echo_Mode (False);
210          P := Create (Frame);
211          Top (P);
212          Update_Panels;
213       else
214          Clear (W);
215          Refresh_Without_Update (W);
216       end if;
217
218       Current := Help; Top_Line := Help;
219
220       if null = Help then
221          Unknown_Key;
222          loop
223             K := Filter_Key;
224             exit when K = QUIT_CODE;
225          end loop;
226       else
227          To_Window (Current, Has_More);
228          if Has_More then
229             --  This means there are more lines available, so we have to go
230             --  into a scroll manager.
231             loop
232                K := Filter_Key;
233                if K in Special_Key_Code'Range then
234                   case K is
235                      when Key_Cursor_Down =>
236                         if Current.Next /= null then
237                            Move_Cursor (W, Height - 1, 0);
238                            Scroll (W, 1);
239                            Current := Current.Next;
240                            Top_Line := Top_Line.Next;
241                            Add (W, Current.Line.all);
242                         end if;
243                      when Key_Cursor_Up =>
244                         if Top_Line.Prev /= null then
245                            Move_Cursor (W, 0, 0);
246                            Scroll (W, -1);
247                            Top_Line := Top_Line.Prev;
248                            Current := Current.Prev;
249                            Add (W, Top_Line.Line.all);
250                         end if;
251                      when QUIT_CODE => exit;
252                         when others => null;
253                   end case;
254                end if;
255             end loop;
256          else
257             loop
258                K := Filter_Key;
259                exit when K = QUIT_CODE;
260             end loop;
261          end if;
262       end if;
263
264       Clear (W);
265
266       if Frame /= Null_Window then
267          Clear (Frame);
268          Delete (P);
269          Delete (W);
270          Delete (Frame);
271          Pop_Environment;
272       end if;
273
274       Update_Panels;
275       Update_Screen;
276
277       Release_Help (Help);
278
279    end Explain;
280
281    function Search (Key : String) return Help_Line_Access
282    is
283       Last    : Natural;
284       Buffer  : String (1 .. 256);
285       Root    : Help_Line_Access := null;
286       Current : Help_Line_Access;
287       Tail    : Help_Line_Access := null;
288       Save    : String_Access;
289
290       function Next_Line return Boolean;
291
292       function Next_Line return Boolean
293       is
294          H_End : constant String := "#END";
295       begin
296          Get_Line (F, Buffer, Last);
297          if Last = H_End'Length and then H_End = Buffer (1 .. Last) then
298             return False;
299          else
300             return True;
301          end if;
302       end Next_Line;
303    begin
304       Reset (F);
305       Outer :
306       loop
307          exit when not Next_Line;
308          if Last = (1 + Key'Length) and then Key = Buffer (2 .. Last)
309            and then Buffer (1) = '#' then
310             loop
311                exit when not Next_Line;
312                exit when Buffer (1) = '#';
313                Current := new Help_Line'(null, null,
314                                          new String'(Buffer (1 .. Last)));
315                if Tail = null then
316                   Release_Help (Root);
317                   Root := Current;
318                else
319                   Tail.Next := Current;
320                   Current.Prev := Tail;
321                end if;
322                Tail := Current;
323             end loop;
324             exit Outer;
325          end if;
326       end loop Outer;
327       return Root;
328    end Search;
329
330    procedure Release_Help (Root : in out Help_Line_Access)
331    is
332       Next : Help_Line_Access;
333    begin
334       loop
335          exit when Root = null;
336          Next := Root.Next;
337          Release_String (Root.Line);
338          Release_Help_Line (Root);
339          Root := Next;
340       end loop;
341    end Release_Help;
342
343    procedure Explain_Context
344    is
345    begin
346       Explain (Context);
347    end Explain_Context;
348
349    procedure Notepad (Key : in String)
350    is
351       H : constant Help_Line_Access := Search (Key);
352       T : Help_Line_Access := H;
353       N : Line_Count := 1;
354       L : Line_Position := 0;
355       W : Window;
356       P : Panel;
357    begin
358       if H /= null then
359          loop
360             T := T.Next;
361             exit when T = null;
362             N := N + 1;
363          end loop;
364          W := New_Window (N + 2, Columns, Lines - N - 2, 0);
365          if Has_Colors then
366             Set_Background (Win => W,
367                             Ch  => (Ch    => ' ',
368                                     Color => Notepad_Color,
369                                     Attr  => Normal_Video));
370             Set_Character_Attributes (Win   => W,
371                                       Attr  => Normal_Video,
372                                       Color => Notepad_Color);
373             Erase (W);
374          end if;
375          Box (W);
376          Window_Title (W, "Notepad");
377          P := New_Panel (W);
378          T := H;
379          loop
380             Add (W, L + 1, 1, T.Line.all, Integer (Columns - 2));
381             L := L + 1;
382             T := T.Next;
383             exit when T = null;
384          end loop;
385          T := H;
386          Release_Help (T);
387          Refresh_Without_Update (W);
388          Notepad_To_Context (P);
389       end if;
390    end Notepad;
391
392 begin
393    Open (F, In_File, File_Name);
394 end Sample.Explanation;
395