ncurses2-acs_and_scroll.adb

ncurses 库 可能有用酒用 没用就算了 我觉得还可以用

------------------------------------------------------------------------------
--                                                                          --
--                       GNAT ncurses Binding Samples                       --
--                                                                          --
--                                 ncurses                                  --
--                                                                          --
--                                 B O D Y                                  --
--                                                                          --
------------------------------------------------------------------------------
-- Copyright (c) 2000,2004 Free Software Foundation, Inc.                   --
--                                                                          --
-- Permission is hereby granted, free of charge, to any person obtaining a  --
-- copy of this software and associated documentation files (the            --
-- "Software"), to deal in the Software without restriction, including      --
-- without limitation the rights to use, copy, modify, merge, publish,      --
-- distribute, distribute with modifications, sublicense, and/or sell       --
-- copies of the Software, and to permit persons to whom the Software is    --
-- furnished to do so, subject to the following conditions:                 --
--                                                                          --
-- The above copyright notice and this permission notice shall be included  --
-- in all copies or substantial portions of the Software.                   --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
-- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
--                                                                          --
-- Except as contained in this notice, the name(s) of the above copyright   --
-- holders shall not be used in advertising or otherwise to promote the     --
-- sale, use or other dealings in this Software without prior written       --
-- authorization.                                                           --
------------------------------------------------------------------------------
--  Author: Eugene V. Melaragno <[e-mail]> 2000
--  Version Control
--  $Revision: 1.6 $
--  $Date: 2004/08/21 21:37:00 $
--  Binding Version 01.00
------------------------------------------------------------------------------
--  Windows and scrolling tester.
--  Demonstrate windows

with Ada.Strings.Fixed;
with Ada.Strings;

with ncurses2.util; use ncurses2.util;
with ncurses2.genericPuts;
with Terminal_Interface.Curses; use Terminal_Interface.Curses;
with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
with Terminal_Interface.Curses.PutWin; use Terminal_Interface.Curses.PutWin;

with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with Ada.Streams; use Ada.Streams;

procedure ncurses2.acs_and_scroll is


   Macro_Quit   : constant Key_Code := Character'Pos ('Q') mod 16#20#;
   Macro_Escape : constant Key_Code := Character'Pos ('[') mod 16#20#;

   Quit : constant Key_Code := CTRL ('Q');
   Escape : constant Key_Code := CTRL ('[');


   Botlines : constant Line_Position := 4;

   type pair is record
      y : Line_Position;
      x : Column_Position;
   end record;

   type Frame;
   type FrameA is access Frame;

   f : File_Type;
   dumpfile : constant String := "screendump";

   procedure Outerbox (ul, lr : pair; onoff : Boolean);
   function  HaveKeyPad (w : Window) return Boolean;
   function  HaveScroll (w : Window) return Boolean;
   procedure newwin_legend (curpw : Window);
   procedure transient (curpw : Window; msg : String);
   procedure newwin_report (win : Window := Standard_Window);
   procedure selectcell (uli : Line_Position;
                         ulj : Column_Position;
                         lri : Line_Position;
                         lrj : Column_Position;
                         p   : out pair;
                         b   : out Boolean);
   function  getwindow return Window;
   procedure newwin_move (win : Window;
                          dy  : Line_Position;
                          dx  : Column_Position);
   function delete_framed (fp : FrameA; showit : Boolean) return FrameA;

   use Ada.Streams.Stream_IO;


   --  A linked list
   --  I  wish there was a standard library linked list. Oh well.
   type Frame is record
      next, last : FrameA;
      do_scroll : Boolean;
      do_keypad : Boolean;
      wind : Window;
   end record;

   current : FrameA;

   c : Key_Code;

   procedure Outerbox (ul, lr : pair; onoff : Boolean) is
   begin
      if onoff then
         --  Note the fix of an obscure bug
         --  try making a 1x1 box then enlarging it, the is a blank
         --  upper left corner!
         Add (Line => ul.y - 1, Column => ul.x - 1,
             Ch => ACS_Map (ACS_Upper_Left_Corner));
         Add (Line => ul.y - 1, Column => lr.x + 1,
             Ch => ACS_Map (ACS_Upper_Right_Corner));
         Add (Line => lr.y + 1, Column => lr.x + 1,
             Ch => ACS_Map (ACS_Lower_Right_Corner));
         Add (Line => lr.y + 1, Column => ul.x - 1,
             Ch => ACS_Map (ACS_Lower_Left_Corner));

         Move_Cursor (Line => ul.y - 1, Column => ul.x);
         Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
                          Line_Size => Integer (lr.x - ul.x) + 1);
         Move_Cursor (Line => ul.y, Column => ul.x - 1);
         Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
                        Line_Size => Integer (lr.y - ul.y) + 1);
         Move_Cursor (Line => lr.y + 1, Column => ul.x);
         Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
                          Line_Size => Integer (lr.x - ul.x) + 1);
         Move_Cursor (Line => ul.y, Column => lr.x + 1);
         Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
                        Line_Size => Integer (lr.y - ul.y) + 1);
      else
         Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ' ');
         Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ' ');
         Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ' ');
         Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ' ');

         Move_Cursor (Line => ul.y - 1, Column => ul.x);
         Horizontal_Line (Line_Symbol => Blank2,
                          Line_Size => Integer (lr.x - ul.x) + 1);
         Move_Cursor (Line => ul.y, Column => ul.x - 1);
         Vertical_Line (Line_Symbol => Blank2,
                        Line_Size => Integer (lr.y - ul.y) + 1);
         Move_Cursor (Line => lr.y + 1, Column => ul.x);
         Horizontal_Line (Line_Symbol => Blank2,
                          Line_Size => Integer (lr.x - ul.x) + 1);
         Move_Cursor (Line => ul.y, Column => lr.x + 1);
         Vertical_Line (Line_Symbol => Blank2,
                        Line_Size => Integer (lr.y - ul.y) + 1);
      end if;
   end Outerbox;

   function HaveKeyPad (w : Window) return Boolean is
   begin
      return Get_KeyPad_Mode (w);
   exception
      when Curses_Exception => return False;
   end HaveKeyPad;

   function HaveScroll (w : Window) return Boolean is
   begin
      return Scrolling_Allowed (w);
   exception
      when Curses_Exception => return False;
   end HaveScroll;


   procedure newwin_legend (curpw : Window) is

      package p is new genericPuts (200);
      use p;
      use p.BS;

      type string_a is access String;

      type rrr is record
         msg : string_a;
         code : Integer range 0 .. 3;
      end record;

      legend : constant array (Positive range <>) of rrr :=
        (
         (
          new String'("^C = create window"), 0
          ),
         (
          new String'("^N = next window"), 0
          ),
         (
          new String'("^P = previous window"), 0
          ),
         (
          new String'("^F = scroll forward"), 0
          ),
         (
          new String'("^B = scroll backward"), 0
          ),
         (
          new String'("^K = keypad(%s)"), 1
          ),
         (
          new String'("^S = scrollok(%s)"), 2
          ),
         (
          new String'("^W = save window to file"), 0
          ),
         (
          new String'("^R = restore window"), 0
          ),
         (
          new String'("^X = resize"), 0
          ),
         (
          new String'("^Q%s = exit"), 3
          )
         );

      buf : Bounded_String;
      do_keypad : constant Boolean := HaveKeyPad (curpw);
      do_scroll : constant Boolean := HaveScroll (curpw);

      pos : Natural;

      mypair : pair;

      use Ada.Strings.Fixed;

   begin
      Move_Cursor (Line => Lines - 4, Column => 0);
      for n in legend'Range loop
         pos := Ada.Strings.Fixed.Index (Source => legend (n).msg.all,
                                         Pattern => "%s");
         --  buf := (others => ' ');
         buf := To_Bounded_String (legend (n).msg.all);
         case legend (n).code is
            when 0 => null;
            when 1 =>
               if do_keypad then
                  Replace_Slice (buf, pos, pos + 1, "yes");
               else
                  Replace_Slice (buf, pos, pos + 1, "no");
               end if;
            when 2 =>
               if do_scroll then
                  Replace_Slice (buf, pos, pos + 1, "yes");
               else
                  Replace_Slice (buf, pos, pos + 1, "no");
               end if;
            when 3 =>
               if do_keypad then
                  Replace_Slice (buf, pos, pos + 1, "/ESC");
               else
                  Replace_Slice (buf, pos, pos + 1, "");
               end if;
         end case;
         Get_Cursor_Position (Line => mypair.y, Column => mypair.x);
         if Columns < mypair.x + 3 + Column_Position (Length (buf)) then
            Add (Ch => newl);
         elsif n /= 1 then -- n /= legen'First
            Add (Str => ", ");
         end if;
         myAdd (Str => buf);
      end loop;
      Clear_To_End_Of_Line;
   end newwin_legend;


   procedure transient (curpw : Window; msg : String) is
   begin
      newwin_legend (curpw);
      if msg /= "" then
         Add (Line => Lines - 1, Column => 0, Str => msg);
         Refresh;
         Nap_Milli_Seconds (1000);
      end if;

      Move_Cursor (Line => Lines - 1, Column => 0);

      if HaveKeyPad (curpw) then
         Add (Str => "Non-arrow");
      else
         Add (Str => "All other");
      end if;
      Add (str => " characters are echoed, window should ");
      if not HaveScroll (curpw) then
         Add (Str => "not ");
      end if;
      Add (str => "scroll");

      Clear_To_End_Of_Line;
   end transient;


   procedure newwin_report (win : Window := Standard_Window) is
      y : Line_Position;
      x : Column_Position;
      use Int_IO;
      tmp2a : String (1 .. 2);
      tmp2b : String (1 .. 2);
   begin
      if win /= Standard_Window then
         transient (win, "");
      end if;
      Get_Cursor_Position (win, y, x);
      Move_Cursor (Line => Lines - 1, Column => Columns - 17);
      Put (tmp2a, Integer (y));
      Put (tmp2b, Integer (x));
      Add (Str => "Y = " & tmp2a & " X = " & tmp2b);
      if win /= Standard_Window then
         Refresh;
      else
         Move_Cursor (win, y, x);
      end if;
   end newwin_report;

   procedure selectcell (uli : Line_Position;
                         ulj : Column_Position;
                         lri : Line_Position;
                         lrj : Column_Position;
                         p   : out pair;
                         b   : out Boolean) is
      c : Key_Code;
      res : pair;
      i : Line_Position := 0;
      j : Column_Position := 0;
      si : constant Line_Position := lri - uli + 1;
      sj : constant Column_Position := lrj - ulj + 1;
   begin
      res.y := uli;
      res.x := ulj;
      loop
         Move_Cursor (Line => uli + i, Column => ulj + j);
         newwin_report;

         c := Getchar;
         case c is
            when
              Macro_Quit   |
              Macro_Escape =>
               --  on the same line macro calls interfere due to the # comment
               --  this is needed because keypad off affects all windows.
               --  try removing the ESCAPE and see what happens.
               b := False;
               return;
            when KEY_UP =>
               i := i + si - 1;
               --  same as  i := i - 1 because of Modulus arithetic,
               --  on Line_Position, which is a Natural
               --  the C version uses this form too, interestingly.
            when KEY_DOWN =>
               i := i + 1;
            when KEY_LEFT =>
               j := j + sj - 1;