Ada95/samples/sample-explanation.adb

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