ncurses 5.6 - patch 20080112
[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 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998-2004,2006 Free Software Foundation, Inc.              --
11 --                                                                          --
12 -- Permission is hereby granted, free of charge, to any person obtaining a  --
13 -- copy of this software and associated documentation files (the            --
14 -- "Software"), to deal in the Software without restriction, including      --
15 -- without limitation the rights to use, copy, modify, merge, publish,      --
16 -- distribute, distribute with modifications, sublicense, and/or sell       --
17 -- copies of the Software, and to permit persons to whom the Software is    --
18 -- furnished to do so, subject to the following conditions:                 --
19 --                                                                          --
20 -- The above copyright notice and this permission notice shall be included  --
21 -- in all copies or substantial portions of the Software.                   --
22 --                                                                          --
23 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
24 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
25 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
26 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
27 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
28 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
29 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
30 --                                                                          --
31 -- Except as contained in this notice, the name(s) of the above copyright   --
32 -- holders shall not be used in advertising or otherwise to promote the     --
33 -- sale, use or other dealings in this Software without prior written       --
34 -- authorization.                                                           --
35 ------------------------------------------------------------------------------
36 --  Author:  Juergen Pfeifer, 1996
37 --  Version Control
38 --  $Revision: 1.20 $
39 --  $Date: 2006/06/25 14:30:22 $
40 --  Binding Version 01.00
41 ------------------------------------------------------------------------------
42 --  Poor mans help system. This scans a sequential file for key lines and
43 --  then reads the lines up to the next key. Those lines are presented in
44 --  a window as help or explanation.
45 --
46 with Ada.Text_IO; use Ada.Text_IO;
47 with Ada.Unchecked_Deallocation;
48 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
49 with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels;
50
51 with Sample.Keyboard_Handler; use Sample.Keyboard_Handler;
52 with Sample.Manifest; use Sample.Manifest;
53 with Sample.Function_Key_Setting; use Sample.Function_Key_Setting;
54 with Sample.Helpers; use Sample.Helpers;
55
56 package body Sample.Explanation is
57
58    Help_Keys : constant String := "HELPKEYS";
59    In_Help   : constant String := "INHELP";
60
61    File_Name : constant String := "explain.msg";
62    F : File_Type;
63
64    type Help_Line;
65    type Help_Line_Access is access Help_Line;
66    pragma Controlled (Help_Line_Access);
67    type String_Access is access String;
68    pragma Controlled (String_Access);
69
70    type Help_Line is
71       record
72          Prev, Next : Help_Line_Access;
73          Line : String_Access;
74       end record;
75
76    procedure Explain (Key : in String;
77                       Win : in Window);
78
79    procedure Release_String is
80      new Ada.Unchecked_Deallocation (String,
81                                      String_Access);
82    procedure Release_Help_Line is
83      new Ada.Unchecked_Deallocation (Help_Line,
84                                      Help_Line_Access);
85
86    function Search (Key : String) return Help_Line_Access;
87    procedure Release_Help (Root : in out Help_Line_Access);
88
89    procedure Explain (Key : in String)
90    is
91    begin
92       Explain (Key, Null_Window);
93    end Explain;
94
95    procedure Explain (Key : in String;
96                       Win : in Window)
97    is
98       --  Retrieve the text associated with this key and display it in this
99       --  window. If no window argument is passed, the routine will create
100       --  a temporary window and use it.
101
102       function Filter_Key return Real_Key_Code;
103       procedure Unknown_Key;
104       procedure Redo;
105       procedure To_Window (C   : in out Help_Line_Access;
106                           More : in out Boolean);
107
108       Frame : Window := Null_Window;
109
110       W : Window := Win;
111       K : Real_Key_Code;
112       P : Panel;
113
114       Height   : Line_Count;
115       Width    : Column_Count;
116       Help     : Help_Line_Access := Search (Key);
117       Current  : Help_Line_Access;
118       Top_Line : Help_Line_Access;
119
120       Has_More : Boolean := True;
121
122       procedure Unknown_Key
123       is
124       begin
125          Add (W, "Help message with ID ");
126          Add (W, Key);
127          Add (W, " not found.");
128          Add (W, Character'Val (10));
129          Add (W, "Press the Function key labelled 'Quit' key to continue.");
130       end Unknown_Key;
131
132       procedure Redo
133       is
134          H : Help_Line_Access := Top_Line;
135       begin
136          if Top_Line /= null then
137             for L in 0 .. (Height - 1) loop
138                Add (W, L, 0, H.Line.all);
139                exit when H.Next = null;
140                H := H.Next;
141             end loop;
142          else
143             Unknown_Key;
144          end if;
145       end Redo;
146
147       function Filter_Key return Real_Key_Code
148       is
149          K : Real_Key_Code;
150       begin
151          loop
152             K := Get_Key (W);
153             if K in Special_Key_Code'Range then
154                case K is
155                   when HELP_CODE =>
156                      if not Find_Context (In_Help) then
157                         Push_Environment (In_Help, False);
158                         Explain (In_Help, W);
159                         Pop_Environment;
160                         Redo;
161                      end if;
162                   when EXPLAIN_CODE =>
163                      if not Find_Context (Help_Keys) then
164                         Push_Environment (Help_Keys, False);
165                         Explain (Help_Keys, W);
166                         Pop_Environment;
167                         Redo;
168                      end if;
169                   when others => exit;
170                end case;
171             else
172                exit;
173             end if;
174          end loop;
175          return K;
176       end Filter_Key;
177
178       procedure To_Window (C   : in out Help_Line_Access;
179                           More : in out Boolean)
180       is
181          L : Line_Position := 0;
182       begin
183          loop
184             Add (W, L, 0, C.Line.all);
185             L := L + 1;
186             exit when C.Next = null or else L = Height;
187             C := C.Next;
188          end loop;
189          if C.Next /= null then
190             pragma Assert (L = Height);
191             More := True;
192          else
193             More := False;
194          end if;
195       end To_Window;
196
197    begin
198       if W = Null_Window then
199          Push_Environment ("HELP");
200          Default_Labels;
201          Frame := New_Window (Lines - 2, Columns, 0, 0);
202          if Has_Colors then
203             Set_Background (Win => Frame,
204                             Ch  => (Ch    => ' ',
205                                     Color => Help_Color,
206                                     Attr  => Normal_Video));
207             Set_Character_Attributes (Win   => Frame,
208                                       Attr  => Normal_Video,
209                                       Color => Help_Color);
210             Erase (Frame);
211          end if;
212          Box (Frame);
213          Set_Character_Attributes (Frame, (Reverse_Video => True,
214                                            others        => False));
215          Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls");
216          Set_Character_Attributes (Frame); -- Back to default.
217          Window_Title (Frame, "Explanation");
218          W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1);
219          Refresh_Without_Update (Frame);
220          Get_Size (W, Height, Width);
221          Set_Meta_Mode (W);
222          Set_KeyPad_Mode (W);
223          Allow_Scrolling (W, True);
224          Set_Echo_Mode (False);
225          P := Create (Frame);
226          Top (P);
227          Update_Panels;
228       else
229          Clear (W);
230          Refresh_Without_Update (W);
231       end if;
232
233       Current := Help; Top_Line := Help;
234
235       if null = Help then
236          Unknown_Key;
237          loop
238             K := Filter_Key;
239             exit when K = QUIT_CODE;
240          end loop;
241       else
242          To_Window (Current, Has_More);
243          if Has_More then
244             --  This means there are more lines available, so we have to go
245             --  into a scroll manager.
246             loop
247                K := Filter_Key;
248                if K in Special_Key_Code'Range then
249                   case K is
250                      when Key_Cursor_Down =>
251                         if Current.Next /= null then
252                            Move_Cursor (W, Height - 1, 0);
253                            Scroll (W, 1);
254                            Current := Current.Next;
255                            Top_Line := Top_Line.Next;
256                            Add (W, Current.Line.all);
257                         end if;
258                      when Key_Cursor_Up =>
259                         if Top_Line.Prev /= null then
260                            Move_Cursor (W, 0, 0);
261                            Scroll (W, -1);
262                            Top_Line := Top_Line.Prev;
263                            Current := Current.Prev;
264                            Add (W, Top_Line.Line.all);
265                         end if;
266                      when QUIT_CODE => exit;
267                         when others => null;
268                   end case;
269                end if;
270             end loop;
271          else
272             loop
273                K := Filter_Key;
274                exit when K = QUIT_CODE;
275             end loop;
276          end if;
277       end if;
278
279       Clear (W);
280
281       if Frame /= Null_Window then
282          Clear (Frame);
283          Delete (P);
284          Delete (W);
285          Delete (Frame);
286          Pop_Environment;
287       end if;
288
289       Update_Panels;
290       Update_Screen;
291
292       Release_Help (Help);
293
294    end Explain;
295
296    function Search (Key : String) return Help_Line_Access
297    is
298       Last    : Natural;
299       Buffer  : String (1 .. 256);
300       Root    : Help_Line_Access := null;
301       Current : Help_Line_Access;
302       Tail    : Help_Line_Access := null;
303
304       function Next_Line return Boolean;
305
306       function Next_Line return Boolean
307       is
308          H_End : constant String := "#END";
309       begin
310          Get_Line (F, Buffer, Last);
311          if Last = H_End'Length and then H_End = Buffer (1 .. Last) then
312             return False;
313          else
314             return True;
315          end if;
316       end Next_Line;
317    begin
318       Reset (F);
319       Outer :
320       loop
321          exit Outer when not Next_Line;
322          if Last = (1 + Key'Length) and then Key = Buffer (2 .. Last)
323            and then Buffer (1) = '#' then
324             loop
325                exit when not Next_Line;
326                exit when Buffer (1) = '#';
327                Current := new Help_Line'(null, null,
328                                          new String'(Buffer (1 .. Last)));
329                if Tail = null then
330                   Release_Help (Root);
331                   Root := Current;
332                else
333                   Tail.Next := Current;
334                   Current.Prev := Tail;
335                end if;
336                Tail := Current;
337             end loop;
338             exit Outer;
339          end if;
340       end loop Outer;
341       return Root;
342    end Search;
343
344    procedure Release_Help (Root : in out Help_Line_Access)
345    is
346       Next : Help_Line_Access;
347    begin
348       loop
349          exit when Root = null;
350          Next := Root.Next;
351          Release_String (Root.Line);
352          Release_Help_Line (Root);
353          Root := Next;
354       end loop;
355    end Release_Help;
356
357    procedure Explain_Context
358    is
359    begin
360       Explain (Context);
361    end Explain_Context;
362
363    procedure Notepad (Key : in String)
364    is
365       H : constant Help_Line_Access := Search (Key);
366       T : Help_Line_Access := H;
367       N : Line_Count := 1;
368       L : Line_Position := 0;
369       W : Window;
370       P : Panel;
371    begin
372       if H /= null then
373          loop
374             T := T.Next;
375             exit when T = null;
376             N := N + 1;
377          end loop;
378          W := New_Window (N + 2, Columns, Lines - N - 2, 0);
379          if Has_Colors then
380             Set_Background (Win => W,
381                             Ch  => (Ch    => ' ',
382                                     Color => Notepad_Color,
383                                     Attr  => Normal_Video));
384             Set_Character_Attributes (Win   => W,
385                                       Attr  => Normal_Video,
386                                       Color => Notepad_Color);
387             Erase (W);
388          end if;
389          Box (W);
390          Window_Title (W, "Notepad");
391          P := New_Panel (W);
392          T := H;
393          loop
394             Add (W, L + 1, 1, T.Line.all, Integer (Columns - 2));
395             L := L + 1;
396             T := T.Next;
397             exit when T = null;
398          end loop;
399          T := H;
400          Release_Help (T);
401          Refresh_Without_Update (W);
402          Notepad_To_Context (P);
403       end if;
404    end Notepad;
405
406 begin
407    Open (F, In_File, File_Name);
408 end Sample.Explanation;