ncurses 6.1 - patch 20190831
[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-2011,2014 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.27 $
39 --  $Date: 2014/09/13 19:10:18 $
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.txt";
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 : String;
77                       Win : 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    function Check_File (Name : String) return Boolean;
90
91    procedure Explain (Key : String)
92    is
93    begin
94       Explain (Key, Null_Window);
95    end Explain;
96
97    procedure Explain (Key : String;
98                       Win : Window)
99    is
100       --  Retrieve the text associated with this key and display it in this
101       --  window. If no window argument is passed, the routine will create
102       --  a temporary window and use it.
103
104       function Filter_Key return Real_Key_Code;
105       procedure Unknown_Key;
106       procedure Redo;
107       procedure To_Window (C   : in out Help_Line_Access;
108                           More : in out Boolean);
109
110       Frame : Window := Null_Window;
111
112       W : Window := Win;
113       K : Real_Key_Code;
114       P : Panel;
115
116       Height   : Line_Count;
117       Width    : Column_Count;
118       Help     : Help_Line_Access := Search (Key);
119       Current  : Help_Line_Access;
120       Top_Line : Help_Line_Access;
121
122       Has_More : Boolean := True;
123
124       procedure Unknown_Key
125       is
126       begin
127          Add (W, "Help message with ID ");
128          Add (W, Key);
129          Add (W, " not found.");
130          Add (W, Character'Val (10));
131          Add (W, "Press the Function key labeled 'Quit' key to continue.");
132       end Unknown_Key;
133
134       procedure Redo
135       is
136          H : Help_Line_Access := Top_Line;
137       begin
138          if Top_Line /= null then
139             for L in 0 .. (Height - 1) loop
140                Add (W, L, 0, H.all.Line.all);
141                exit when H.all.Next = null;
142                H := H.all.Next;
143             end loop;
144          else
145             Unknown_Key;
146          end if;
147       end Redo;
148
149       function Filter_Key return Real_Key_Code
150       is
151          K : Real_Key_Code;
152       begin
153          loop
154             K := Get_Key (W);
155             if K in Special_Key_Code'Range then
156                case K is
157                   when HELP_CODE =>
158                      if not Find_Context (In_Help) then
159                         Push_Environment (In_Help, False);
160                         Explain (In_Help, W);
161                         Pop_Environment;
162                         Redo;
163                      end if;
164                   when EXPLAIN_CODE =>
165                      if not Find_Context (Help_Keys) then
166                         Push_Environment (Help_Keys, False);
167                         Explain (Help_Keys, W);
168                         Pop_Environment;
169                         Redo;
170                      end if;
171                   when others => exit;
172                end case;
173             else
174                exit;
175             end if;
176          end loop;
177          return K;
178       end Filter_Key;
179
180       procedure To_Window (C   : in out Help_Line_Access;
181                           More : in out Boolean)
182       is
183          L : Line_Position := 0;
184       begin
185          loop
186             Add (W, L, 0, C.all.Line.all);
187             L := L + 1;
188             exit when C.all.Next = null or else L = Height;
189             C := C.all.Next;
190          end loop;
191          if C.all.Next /= null then
192             pragma Assert (L = Height);
193             More := True;
194          else
195             More := False;
196          end if;
197       end To_Window;
198
199    begin
200       if W = Null_Window then
201          Push_Environment ("HELP");
202          Default_Labels;
203          Frame := New_Window (Lines - 2, Columns, 0, 0);
204          if Has_Colors then
205             Set_Background (Win => Frame,
206                             Ch  => (Ch    => ' ',
207                                     Color => Help_Color,
208                                     Attr  => Normal_Video));
209             Set_Character_Attributes (Win   => Frame,
210                                       Attr  => Normal_Video,
211                                       Color => Help_Color);
212             Erase (Frame);
213          end if;
214          Box (Frame);
215          Set_Character_Attributes (Frame, (Reverse_Video => True,
216                                            others        => False));
217          Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls");
218          Set_Character_Attributes (Frame); -- Back to default.
219          Window_Title (Frame, "Explanation");
220          W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1);
221          Refresh_Without_Update (Frame);
222          Get_Size (W, Height, Width);
223          Set_Meta_Mode (W);
224          Set_KeyPad_Mode (W);
225          Allow_Scrolling (W, True);
226          Set_Echo_Mode (False);
227          P := Create (Frame);
228          Top (P);
229          Update_Panels;
230       else
231          Clear (W);
232          Refresh_Without_Update (W);
233       end if;
234
235       Current := Help; Top_Line := Help;
236
237       if null = Help then
238          Unknown_Key;
239          loop
240             K := Filter_Key;
241             exit when K = QUIT_CODE;
242          end loop;
243       else
244          To_Window (Current, Has_More);
245          if Has_More then
246             --  This means there are more lines available, so we have to go
247             --  into a scroll manager.
248             loop
249                K := Filter_Key;
250                if K in Special_Key_Code'Range then
251                   case K is
252                      when Key_Cursor_Down =>
253                         if Current.all.Next /= null then
254                            Move_Cursor (W, Height - 1, 0);
255                            Scroll (W, 1);
256                            Current := Current.all.Next;
257                            Top_Line := Top_Line.all.Next;
258                            Add (W, Current.all.Line.all);
259                         end if;
260                      when Key_Cursor_Up =>
261                         if Top_Line.all.Prev /= null then
262                            Move_Cursor (W, 0, 0);
263                            Scroll (W, -1);
264                            Top_Line := Top_Line.all.Prev;
265                            Current := Current.all.Prev;
266                            Add (W, Top_Line.all.Line.all);
267                         end if;
268                      when QUIT_CODE => exit;
269                         when others => null;
270                   end case;
271                end if;
272             end loop;
273          else
274             loop
275                K := Filter_Key;
276                exit when K = QUIT_CODE;
277             end loop;
278          end if;
279       end if;
280
281       Clear (W);
282
283       if Frame /= Null_Window then
284          Clear (Frame);
285          Delete (P);
286          Delete (W);
287          Delete (Frame);
288          Pop_Environment;
289       end if;
290
291       Update_Panels;
292       Update_Screen;
293
294       Release_Help (Help);
295
296    end Explain;
297
298    function Search (Key : String) return Help_Line_Access
299    is
300       Last    : Natural;
301       Buffer  : String (1 .. 256);
302       Root    : Help_Line_Access := null;
303       Current : Help_Line_Access;
304       Tail    : Help_Line_Access := null;
305
306       function Next_Line return Boolean;
307
308       function Next_Line return Boolean
309       is
310          H_End : constant String := "#END";
311       begin
312          Get_Line (F, Buffer, Last);
313          if Last = H_End'Length and then H_End = Buffer (1 .. Last) then
314             return False;
315          else
316             return True;
317          end if;
318       end Next_Line;
319    begin
320       Reset (F);
321       Outer :
322       loop
323          exit Outer when not Next_Line;
324          if Last = (1 + Key'Length)
325            and then Key = Buffer (2 .. Last)
326            and then Buffer (1) = '#'
327          then
328             loop
329                exit when not Next_Line;
330                exit when Buffer (1) = '#';
331                Current := new Help_Line'(null, null,
332                                          new String'(Buffer (1 .. Last)));
333                if Tail = null then
334                   Release_Help (Root);
335                   Root := Current;
336                else
337                   Tail.all.Next := Current;
338                   Current.all.Prev := Tail;
339                end if;
340                Tail := Current;
341             end loop;
342             exit Outer;
343          end if;
344       end loop Outer;
345       return Root;
346    end Search;
347
348    procedure Release_Help (Root : in out Help_Line_Access)
349    is
350       Next : Help_Line_Access;
351    begin
352       loop
353          exit when Root = null;
354          Next := Root.all.Next;
355          Release_String (Root.all.Line);
356          Release_Help_Line (Root);
357          Root := Next;
358       end loop;
359    end Release_Help;
360
361    procedure Explain_Context
362    is
363    begin
364       Explain (Context);
365    end Explain_Context;
366
367    procedure Notepad (Key : String)
368    is
369       H : constant Help_Line_Access := Search (Key);
370       T : Help_Line_Access := H;
371       N : Line_Count := 1;
372       L : Line_Position := 0;
373       W : Window;
374       P : Panel;
375    begin
376       if H /= null then
377          loop
378             T := T.all.Next;
379             exit when T = null;
380             N := N + 1;
381          end loop;
382          W := New_Window (N + 2, Columns, Lines - N - 2, 0);
383          if Has_Colors then
384             Set_Background (Win => W,
385                             Ch  => (Ch    => ' ',
386                                     Color => Notepad_Color,
387                                     Attr  => Normal_Video));
388             Set_Character_Attributes (Win   => W,
389                                       Attr  => Normal_Video,
390                                       Color => Notepad_Color);
391             Erase (W);
392          end if;
393          Box (W);
394          Window_Title (W, "Notepad");
395          P := New_Panel (W);
396          T := H;
397          loop
398             Add (W, L + 1, 1, T.all.Line.all, Integer (Columns - 2));
399             L := L + 1;
400             T := T.all.Next;
401             exit when T = null;
402          end loop;
403          T := H;
404          Release_Help (T);
405          Refresh_Without_Update (W);
406          Notepad_To_Context (P);
407       end if;
408    end Notepad;
409
410    function Check_File (Name : String) return Boolean is
411       The_File : File_Type;
412    begin
413       Open (The_File, In_File, Name);
414       Close (The_File);
415       return True;
416    exception
417       when Name_Error =>
418          return False;
419    end Check_File;
420
421 begin
422    if Check_File ("/usr/share/AdaCurses/" & File_Name) then
423       Open (F, In_File, "/usr/share/AdaCurses/" & File_Name);
424    elsif Check_File (File_Name) then
425       Open (F, In_File, File_Name);
426    else
427       Put_Line (Standard_Error,
428                 "The file explain.txt was not found in the current directory."
429                 );
430       raise Name_Error;
431    end if;
432 end Sample.Explanation;