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