ncurses2-demo_pad.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.5 $
--  $Date: 2004/08/21 21:37:00 $
--  Binding Version 01.00
------------------------------------------------------------------------------
with ncurses2.util; use ncurses2.util;

with Terminal_Interface.Curses; use Terminal_Interface.Curses;

with Interfaces.C;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;

with Ada.Text_IO;
--  with Ada.Real_Time; use Ada.Real_Time;
--  TODO is there a way to use Real_Time or Ada.Calendar in place of
--  gettimeofday?

--  Demonstrate pads.
procedure ncurses2.demo_pad is

   type timestruct is record
      seconds : Integer;
      microseconds : Integer;
   end record;

   type myfunc is access function (w : Window) return Key_Code;

   function  gettime return timestruct;
   procedure do_h_line (y  : Line_Position;
                        x  : Column_Position;
                        c  : Attributed_Character;
                        to : Column_Position);
   procedure do_v_line (y  : Line_Position;
                        x  : Column_Position;
                        c  : Attributed_Character;
                        to : Line_Position);
   function  padgetch (win : Window) return Key_Code;
   function  panner_legend (line : Line_Position) return Boolean;
   procedure panner_legend (line : Line_Position);
   procedure panner_h_cleanup (from_y : Line_Position;
                               from_x : Column_Position;
                               to_x   : Column_Position);
   procedure panner_v_cleanup (from_y : Line_Position;
                               from_x : Column_Position;
                               to_y   : Line_Position);
   procedure panner (pad    : Window;
                     top_xp : Column_Position;
                     top_yp : Line_Position;
                     portyp : Line_Position;
                     portxp : Column_Position;
                     pgetc  : myfunc);

   function gettime return timestruct is

      retval : timestruct;

      use Interfaces.C;
      type timeval is record
         tv_sec : long;
         tv_usec : long;
      end record;
      pragma Convention (C, timeval);

      --      TODO    function from_timeval is new Ada.Unchecked_Conversion(
      --                  timeval_a, System.Storage_Elements.Integer_Address);
      --  should Interfaces.C.Pointers be used here?

      package myP is new System.Address_To_Access_Conversions (timeval);
      use myP;

      t : constant Object_Pointer := new timeval;

      function gettimeofday
        (TP : System.Storage_Elements.Integer_Address;
         TZP : System.Storage_Elements.Integer_Address) return int;
      pragma Import (C, gettimeofday, "gettimeofday");
      tmp : int;
   begin
      tmp := gettimeofday (System.Storage_Elements.To_Integer
                           (myP.To_Address (t)),
                           System.Storage_Elements.To_Integer
                           (myP.To_Address (null)));
      if tmp < 0 then
         retval.seconds := 0;
         retval.microseconds := 0;
      else
         retval.seconds := Integer (t.tv_sec);
         retval.microseconds := Integer (t.tv_usec);
      end if;
      return retval;
   end gettime;


   --  in C, The behavior of mvhline, mvvline for negative/zero length is
   --  unspecified, though we can rely on negative x/y values to stop the
   --  macro. Except Ada makes Line_Position(-1) = Natural - 1 so forget it.
   procedure do_h_line (y  : Line_Position;
                        x  : Column_Position;
                        c  : Attributed_Character;
                        to : Column_Position) is
   begin
      if to > x then
         Move_Cursor (Line => y, Column => x);
         Horizontal_Line (Line_Size => Natural (to - x), Line_Symbol => c);
      end if;
   end do_h_line;

   procedure do_v_line (y  : Line_Position;
                        x  : Column_Position;
                        c  : Attributed_Character;
                        to : Line_Position) is
   begin
      if to > y then
         Move_Cursor (Line => y, Column => x);
         Vertical_Line (Line_Size => Natural (to - y), Line_Symbol => c);
      end if;
   end do_v_line;




   function padgetch (win : Window) return Key_Code is
      c : Key_Code;
      c2 : Character;
   begin
      c := Getchar (win);
      c2 := Code_To_Char (c);

      case c2 is
         when '!' =>
            ShellOut (False);
            return Key_Refresh;
         when Character'Val (Character'Pos ('r') mod 16#20#) => --  CTRL('r')
            End_Windows;
            Refresh;
            return Key_Refresh;
         when Character'Val (Character'Pos ('l') mod 16#20#) => --  CTRL('l')
            return Key_Refresh;
         when 'U' =>
            return Key_Cursor_Up;
         when 'D' =>
            return Key_Cursor_Down;
         when 'R' =>
            return Key_Cursor_Right;
         when 'L' =>
            return Key_Cursor_Left;
         when '+' =>
            return Key_Insert_Line;
         when '-' =>
            return Key_Delete_Line;
         when '>' =>
            return Key_Insert_Char;
         when '<' =>
            return Key_Delete_Char;
            --  when ERR=>                   /* FALLTHRU */
         when 'q' =>
            return (Key_Exit);
         when others =>
            return (c);
      end case;
   end padgetch;

   show_panner_legend : Boolean := True;

   function panner_legend (line : Line_Position) return Boolean is
      legend : constant array (0 .. 3) of String (1 .. 61) :=
        (
         "Use arrow keys (or U,D,L,R) to pan, q to quit (?,t,s flags)  ",
         "Use ! to shell-out.  Toggle legend:?, timer:t, scroll mark:s.",
         "Use +,- (or j,k) to grow/shrink the panner vertically.       ",
         "Use <,> (or h,l) to grow/shrink the panner horizontally.     ");
      legendsize : constant := 4;

      n : constant Integer := legendsize - Integer (Lines - line);
   begin
      if line < Lines and n >= 0 then
         Move_Cursor (Line => line, Column => 0);
         if show_panner_legend then
            Add (Str => legend (n));
         end if;
         Clear_To_End_Of_Line;
         return show_panner_legend;
      end if;
      return False;
   end panner_legend;

   procedure panner_legend (line : Line_Position) is
   begin
      if not panner_legend (line) then
         Beep;
      end if;
   end panner_legend;

   procedure panner_h_cleanup (from_y : Line_Position;
                               from_x : Column_Position;
                               to_x   : Column_Position) is
   begin
      if not panner_legend (from_y) then
         do_h_line (from_y, from_x, Blank2, to_x);
      end if;
   end panner_h_cleanup;

   procedure panner_v_cleanup (from_y : Line_Position;
                               from_x : Column_Position;
                               to_y   : Line_Position) is
   begin
      if not panner_legend (from_y) then
         do_v_line (from_y, from_x, Blank2, to_y);
      end if;
   end panner_v_cleanup;


   procedure panner (pad    : Window;
                     top_xp : Column_Position;
                     top_yp : Line_Position;
                     portyp : Line_Position;
                     portxp : Column_Position;
                     pgetc  : myfunc) is

      function f (y : Line_Position) return Line_Position;
      function f (x : Column_Position) return Column_Position;
      function greater (y1, y2 : Line_Position) return Integer;
      function greater (x1, x2 : Column_Position) return Integer;

      top_x : Column_Position := top_xp;
      top_y : Line_Position := top_yp;
      porty : Line_Position := portyp;
      portx : Column_Position := portxp;

      --  f[x] returns max[x - 1, 0]
      function f (y : Line_Position) return Line_Position is
      begin
         if y > 0 then
            return y - 1;
         else
            return y; -- 0
         end if;
      end f;

      function f (x : Column_Position) return Column_Position is
      begin
         if x > 0 then
            return x - 1;
         else
            return x; -- 0
         end if;
      end f;

      function greater (y1, y2 : Line_Position) return Integer is
      begin
         if y1 > y2 then
            return 1;
         else
            return 0;
         end if;
      end greater;

      function greater (x1, x2 : Column_Position) return Integer is
      begin
         if x1 > x2 then
            return 1;
         else
            return 0;
         end if;
      end greater;


      pymax : Line_Position;
      basey : Line_Position := 0;
      pxmax : Column_Position;
      basex : Column_Position := 0;
      c : Key_Code;
      scrollers : Boolean := True;
      before, after : timestruct;
      timing : Boolean := True;

      package floatio is new Ada.Text_IO.Float_IO (Long_Float);
   begin
      Get_Size (pad, pymax, pxmax);
      Allow_Scrolling (Mode => False); -- we don't want stdscr to scroll!

      c := Key_Refresh;
      loop
         --  During shell-out, the user may have resized the window.  Adjust
         --  the port size of the pad to accommodate this.  Ncurses
         --  automatically resizes all of the normal windows to fit on the
         --  new screen.
         if top_x > Columns then
            top_x := Columns;
         end if;
         if portx > Columns then
            portx := Columns;
         end if;
         if top_y > Lines then
            top_y := Lines;
         end if;
         if porty > Lines then
            porty := Lines;
         end if;

         case c is
            when Key_Refresh | Character'Pos ('?') =>
               if c = Key_Refresh then