1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
5 -- Sample.Explanation --
11 -- The ncurses Ada95 binding is copyrighted 1996 by --
12 -- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
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. --
22 -- This binding comes AS IS with no warranty, implied or expressed. --
23 ------------------------------------------------------------------------------
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.
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;
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;
41 package body Sample.Explanation is
43 Help_Keys : constant String := "HELPKEYS";
44 In_Help : constant String := "INHELP";
46 File_Name : String := "explain.msg";
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);
57 Prev, Next : Help_Line_Access;
61 procedure Explain (Key : in String;
64 procedure Release_String is
65 new Ada.Unchecked_Deallocation (String,
67 procedure Release_Help_Line is
68 new Ada.Unchecked_Deallocation (Help_Line,
71 function Search (Key : String) return Help_Line_Access;
72 procedure Release_Help (Root : in out Help_Line_Access);
74 procedure Explain (Key : in String)
77 Explain (Key, Null_Window);
80 procedure Explain (Key : in String;
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.
87 function Filter_Key return Real_Key_Code;
88 procedure Unknown_Key;
90 procedure To_Window (C : in out Help_Line_Access;
91 More : in out Boolean);
93 Frame : Window := Null_Window;
100 Width : Column_Count;
101 Help : Help_Line_Access := Search (Key);
102 Current : Help_Line_Access;
103 Top_Line : Help_Line_Access;
107 procedure Unknown_Key
110 Add (W, "Help message with ID ");
112 Add (W, " not found.");
113 Add (W, Character'Val (10));
114 Add (W, "Press the Function key labelled 'Quit' key to continue.");
119 H : Help_Line_Access := Top_Line;
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;
132 function Filter_Key return Real_Key_Code
138 if K in Special_Key_Code'Range then
141 if not Find_Context (In_Help) then
142 Push_Environment (In_Help, False);
143 Explain (In_Help, W);
148 if not Find_Context (Help_Keys) then
149 Push_Environment (Help_Keys, False);
150 Explain (Help_Keys, W);
163 procedure To_Window (C : in out Help_Line_Access;
164 More : in out Boolean)
166 L : Line_Position := 0;
169 Add (W, L, 0, C.Line.all);
171 exit when C.Next = null or else L = Height;
174 if C.Next /= null then
175 pragma Assert (L = Height);
183 if W = Null_Window then
184 Push_Environment ("HELP");
186 Frame := New_Window (Lines - 2, Columns, 0, 0);
188 Set_Background (Win => Frame,
191 Attr => Normal_Video));
192 Set_Character_Attributes (Win => Frame,
193 Attr => Normal_Video,
194 Color => Help_Color);
198 Set_Character_Attributes (Frame, (Reverse_Video => True,
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);
208 Allow_Scrolling (W, True);
209 Set_Echo_Mode (False);
215 Refresh_Without_Update (W);
218 Current := Help; Top_Line := Help;
224 exit when K = QUIT_CODE;
227 To_Window (Current, Has_More);
229 -- This means there are more lines available, so we have to go
230 -- into a scroll manager.
233 if K in Special_Key_Code'Range then
235 when Key_Cursor_Down =>
236 if Current.Next /= null then
237 Move_Cursor (W, Height - 1, 0);
239 Current := Current.Next;
240 Top_Line := Top_Line.Next;
241 Add (W, Current.Line.all);
243 when Key_Cursor_Up =>
244 if Top_Line.Prev /= null then
245 Move_Cursor (W, 0, 0);
247 Top_Line := Top_Line.Prev;
248 Current := Current.Prev;
249 Add (W, Top_Line.Line.all);
251 when QUIT_CODE => exit;
259 exit when K = QUIT_CODE;
266 if Frame /= Null_Window then
281 function Search (Key : String) return Help_Line_Access
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;
290 function Next_Line return Boolean;
292 function Next_Line return Boolean
294 H_End : constant String := "#END";
296 Get_Line (F, Buffer, Last);
297 if Last = H_End'Length and then H_End = Buffer (1 .. Last) then
307 exit when not Next_Line;
308 if Last = (1 + Key'Length) and then Key = Buffer (2 .. Last)
309 and then Buffer (1) = '#' then
311 exit when not Next_Line;
312 exit when Buffer (1) = '#';
313 Current := new Help_Line'(null, null,
314 new String'(Buffer (1 .. Last)));
319 Tail.Next := Current;
320 Current.Prev := Tail;
330 procedure Release_Help (Root : in out Help_Line_Access)
332 Next : Help_Line_Access;
335 exit when Root = null;
337 Release_String (Root.Line);
338 Release_Help_Line (Root);
343 procedure Explain_Context
349 procedure Notepad (Key : in String)
351 H : constant Help_Line_Access := Search (Key);
352 T : Help_Line_Access := H;
354 L : Line_Position := 0;
364 W := New_Window (N + 2, Columns, Lines - N - 2, 0);
366 Set_Background (Win => W,
368 Color => Notepad_Color,
369 Attr => Normal_Video));
370 Set_Character_Attributes (Win => W,
371 Attr => Normal_Video,
372 Color => Notepad_Color);
376 Window_Title (W, "Notepad");
380 Add (W, L + 1, 1, T.Line.all, Integer (Columns - 2));
387 Refresh_Without_Update (W);
388 Notepad_To_Context (P);
393 Open (F, In_File, File_Name);
394 end Sample.Explanation;