path: root/ncurses-5.3/Ada95/samples/ncurses2-acs_and_scroll.adb

------------------------------------------------------------------------------
--                                                                          --
--                       GNAT ncurses Binding Samples                       --
--                                                                          --
--                                 ncurses                                  --
--                                                                          --
--                                 B O D Y                                  --
--                                                                          --
------------------------------------------------------------------------------
-- Copyright (c) 2000 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 <aldomel@ix.netcom.com> 2000
--  Version Control
--  $Revision$
--  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 : Boolean := HaveKeyPad (curpw);
      do_scroll : 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 : Line_Position := lri - uli + 1;
      sj : 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;
            when KEY_RIGHT =>
               j := j + 1;
            when Key_Mouse =>
               declare
                  event : Mouse_Event;
                  y : Line_Position;
                  x : Column_Position;
                  Button : Mouse_Button;
                  State : Button_State;

               begin
                  event := Get_Mouse;
                  Get_Event (Event => event,
                             Y => y,
                             X => x,
                             Button => Button,
                             State  => State);
                  if y > uli and x > ulj then
                     i := y - uli;
                     j := x - ulj;
                     --  same as when others =>
                     res.y := uli + i;
                     res.x := ulj + j;
                     p := res;
                     b := True;
                     return;
                  else
                     Beep;
                  end if;
               end;
            when others =>
               res.y := uli + i;
               res.x := ulj + j;
               p := res;
               b := True;
               return;
         end case;
         i := i mod si;
         j := j mod sj;
      end loop;
   end selectcell;


   function getwindow return Window is
      rwindow : Window;
      ul, lr : pair;
      result : Boolean;
   begin
      Move_Cursor (Line => 0, Column => 0);
      Clear_To_End_Of_Line;
      Add (Str => "Use arrows to move cursor, anything else to mark corner 1");
      Refresh;
      selectcell (2, 1, Lines - Botlines - 2, Columns - 2, ul, result);
      if not result then
         return Null_Window;
      end if;
      Add (Line => ul.y - 1, Column => ul.x - 1,
           Ch => ACS_Map (ACS_Upper_Left_Corner));
      Move_Cursor (Line => 0, Column => 0);
      Clear_To_End_Of_Line;
      Add (Str => "Use arrows to move cursor, anything else to mark corner 2");
      Refresh;
      selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, lr, result);
      if not result then
         return Null_Window;
      end if;

      rwindow := Sub_Window (Number_Of_Lines => lr.y - ul.y + 1,
                             Number_Of_Columns => lr.x - ul.x + 1,
                             First_Line_Position => ul.y,
                             First_Column_Position => ul.x);

      Outerbox (ul, lr, True);
      Refresh;

      Refresh (rwindow);

      Move_Cursor (Line => 0, Column => 0);
      Clear_To_End_Of_Line;
      return rwindow;
   end getwindow;


   procedure newwin_move (win : Window;
                          dy  : Line_Position;
                          dx  : Column_Position) is
      cur_y, max_y : Line_Position;
      cur_x, max_x : Column_Position;
   begin
      Get_Cursor_Position (win, cur_y, cur_x);
      Get_Size (win, max_y, max_x);
      cur_x := Column_Position'Min (Column_Position'Max (cur_x + dx, 0),
                                    max_x - 1);
      cur_y := Line_Position'Min (Line_Position'Max (cur_y + dy, 0),
                                  max_y - 1);

      Move_Cursor (win, Line => cur_y, Column => cur_x);
   end newwin_move;

   function delete_framed (fp : FrameA; showit : Boolean) return FrameA is
      np : FrameA;
   begin
      fp.last.next := fp.next;
      fp.next.last := fp.last;

      if showit then
         Erase (fp.wind);
         Refresh (fp.wind);
      end if;
      Delete (fp.wind);

      if fp = fp.next then
         np := null;
      else
         np := fp.next;
      end if;
      --  TODO free(fp);
      return np;
   end delete_framed;

   Mask : Event_Mask := No_Events;
   Mask2 : Event_Mask;

   usescr : Window;

begin
   if Has_Mouse then
      Register_Reportable_Event (
                                 Button => Left,
                                 State => Clicked,
                                 Mask => Mask);
      Mask2 := Start_Mouse (Mask);
   end if;
   c := CTRL ('C');
   Set_Raw_Mode (SwitchOn => True);
   loop
      transient (Standard_Window, "");
      case c is
         when Character'Pos ('c') mod 16#20# => --  Ctrl('c')
            declare
               neww : FrameA := new Frame'(null, null, False, False,
                                           Null_Window);
            begin
               neww.wind := getwindow;
               if neww.wind = Null_Window  then
                  exit;
                  --  was goto breakout; ha ha ha
               else

                  if current = null  then
                     neww.next := neww;
                     neww.last := neww;
                  else
                     neww.next := current.next;
                     neww.last := current;
                     neww.last.next := neww;
                     neww.next.last := neww;
                  end if;
                  current := neww;

                  Set_KeyPad_Mode (current.wind, True);
                  current.do_keypad := HaveKeyPad (current.wind);
                  current.do_scroll := HaveScroll (current.wind);
               end if;
            end;
         when Character'Pos ('N') mod 16#20#  => --  Ctrl('N')
            if current /= null then
               current := current.next;
            end if;
         when Character'Pos ('P') mod 16#20#  => --  Ctrl('P')
            if current /= null then
               current := current.last;
            end if;
         when Character'Pos ('F') mod 16#20#  => --  Ctrl('F')
            if current /= null and HaveScroll (current.wind) then
               Scroll (current.wind, 1);
            end if;
         when Character'Pos ('B') mod 16#20#  => --  Ctrl('B')
            if current /= null and HaveScroll (current.wind) then
            --  The C version of Scroll may return ERR which is ignored
            --  we need to avoid the exception
            --  with the 'and HaveScroll(current.wind)'
               Scroll (current.wind, -1);
            end if;
         when Character'Pos ('K') mod 16#20#  => --  Ctrl('K')
            if current /= null then
               current.do_keypad := not current.do_keypad;
               Set_KeyPad_Mode (current.wind, current.do_keypad);
            end if;
         when Character'Pos ('S') mod 16#20#  => --  Ctrl('S')
            if current /= null then
               current.do_scroll := not current.do_scroll;
               Allow_Scrolling (current.wind, current.do_scroll);
            end if;
         when Character'Pos ('W') mod 16#20#  => --  Ctrl('W')
            if current /= current.next then
               Create (f, Name => dumpfile); -- TODO error checking
               if not Is_Open (f) then
                  raise Curses_Exception;
               end if;
               Put_Window (current.wind, f);
               Close (f);
               current := delete_framed (current, True);
            end if;
         when Character'Pos ('R') mod 16#20#  => --  Ctrl('R')
            declare
               neww : FrameA := new Frame'(null, null, False, False,
                                           Null_Window);
            begin
               Open (f, Mode => In_File, Name => dumpfile);
               neww := new Frame'(null, null, False, False, Null_Window);

               neww.next := current.next;
               neww.last := current;
               neww.last.next := neww;
               neww.next.last := neww;

               neww.wind := Get_Window (f);
               Close (f);

               Refresh (neww.wind);
            end;
         when Character'Pos ('X') mod 16#20# => --  Ctrl('X')
            if current /= null then
               declare
                  tmp, ul, lr : pair;
                  mx : Column_Position;
                  my : Line_Position;
                  tmpbool : Boolean;
               begin
                  Move_Cursor (Line => 0, Column => 0);
                  Clear_To_End_Of_Line;
                  Add (Str => "Use arrows to move cursor, anything else " &
                       "to mark new corner");
                  Refresh;

                  Get_Window_Position (current.wind, ul.y, ul.x);

                  selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2,
                              tmp, tmpbool);
                  if not tmpbool then
                     --  the C version had a goto. I refuse gotos.
                     Beep;
                  else
                     Get_Size (current.wind, lr.y, lr.x);
                     lr.y := lr.y + ul.y - 1;
                     lr.x := lr.x + ul.x - 1;
                     Outerbox (ul, lr, False);
                     Refresh_Without_Update;

                     Get_Size (current.wind, my, mx);
                     if my > tmp.y - ul.y then
                        Get_Cursor_Position (current.wind, lr.y, lr.x);
                        Move_Cursor (current.wind, tmp.y - ul.y + 1, 0);
                        Clear_To_End_Of_Screen (current.wind);
                        Move_Cursor (current.wind, lr.y, lr.x);
                     end if;
                     if mx > tmp.x - ul.x then
                        for i in 0 .. my - 1 loop
                           Move_Cursor (current.wind, i, tmp.x - ul.x + 1);
                           Clear_To_End_Of_Line (current.wind);
                        end loop;
                     end if;
                     Refresh_Without_Update (current.wind);

                     lr := tmp;
                     --  The C version passes invalid args to resize
                     --  which returns an ERR. For Ada we avoid the exception.
                     if lr.y /= ul.y and lr.x /= ul.x then
                        Resize (current.wind, lr.y - ul.y + 0,
                                lr.x - ul.x + 0);
                     end if;

                     Get_Window_Position (current.wind, ul.y, ul.x);
                     Get_Size (current.wind, lr.y, lr.x);
                     lr.y := lr.y + ul.y - 1;
                     lr.x := lr.x + ul.x - 1;
                     Outerbox (ul, lr, True);
                     Refresh_Without_Update;

                     Refresh_Without_Update (current.wind);
                     Move_Cursor (Line => 0, Column => 0);
                     Clear_To_End_Of_Line;
                     Update_Screen;
                  end if;
               end;
            end if;
         when Key_F10  =>
            declare tmp : pair; tmpbool : Boolean;
            begin
               --  undocumented --- use this to test area clears
               selectcell (0, 0, Lines - 1, Columns - 1, tmp, tmpbool);
               Clear_To_End_Of_Screen;
               Refresh;
            end;
         when Key_Cursor_Up =>
            newwin_move (current.wind, -1, 0);
         when Key_Cursor_Down  =>
            newwin_move (current.wind, 1, 0);
         when Key_Cursor_Left  =>
            newwin_move (current.wind, 0, -1);
         when Key_Cursor_Right  =>
            newwin_move (current.wind, 0, 1);
         when Key_Backspace | Key_Delete_Char  =>
            declare
               y : Line_Position;
               x : Column_Position;
               tmp : Line_Position;
            begin
               Get_Cursor_Position (current.wind, y, x);
               --  x := x - 1;
               --  I got tricked by the -1 = Max_Natural - 1 result
               --  y := y - 1;
               if not (x = 0 and y = 0) then
                  if x = 0 then
                     y := y - 1;
                     Get_Size (current.wind, tmp, x);
                  end if;
                  x := x - 1;
                  Delete_Character (current.wind, y, x);
               end if;
            end;
         when others =>
            --  TODO c = '\r' ?
            if current /= null then
               declare
               begin
                  Add (current.wind, Ch => Code_To_Char (c));
               exception
                  when Curses_Exception => null;
                     --  this happens if we are at the
                     --  lower right of a window and add a character.
               end;
            else
               Beep;
            end if;
      end case;
      newwin_report (current.wind);
      if current /= null then
         usescr := current.wind;
      else
         usescr := Standard_Window;
      end if;
      Refresh (usescr);
      c := Getchar (usescr);
      exit when c = Quit or (c = Escape and HaveKeyPad (usescr));
      --  TODO when does c = ERR happen?
   end loop;

   --  TODO while current /= null loop
   --  current := delete_framed(current, False);
   --  end loop;

   Allow_Scrolling (Mode => True);

   End_Mouse;
   Set_Raw_Mode (SwitchOn => True);
   Erase;
   End_Windows;

end ncurses2.acs_and_scroll;