1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding Samples -- 4-- -- 5-- Sample.Explanation -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 2019,2020 Thomas E. Dickey -- 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.5 $ 39-- $Date: 2020/02/02 23:34:34 $ 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-- 46with Ada.Text_IO; use Ada.Text_IO; 47with Ada.Unchecked_Deallocation; 48with Terminal_Interface.Curses; use Terminal_Interface.Curses; 49with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; 50 51with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; 52with Sample.Manifest; use Sample.Manifest; 53with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; 54with Sample.Helpers; use Sample.Helpers; 55 56package 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 421begin 422 if Check_File 423 ($THIS_DATADIR 424 & File_Name) 425 then 426 Open (F, In_File, 427 $THIS_DATADIR 428 & File_Name); 429 elsif Check_File (File_Name) then 430 Open (F, In_File, File_Name); 431 else 432 Put_Line (Standard_Error, 433 "The file " 434 & File_Name 435 & " was not found in " 436 & $THIS_DATADIR 437 ); 438 raise Name_Error; 439 end if; 440end Sample.Explanation; 441-- vile:adamode 442