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