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-2006,2009 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.21 $
  39 --  $Date: 2009/12/26 17:38:58 $
  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 : 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    procedure Explain (Key : String)
  90    is
  91    begin
  92       Explain (Key, Null_Window);
  93    end Explain;
  94
  95    procedure Explain (Key : String;
  96                       Win : 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 : 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;