Ada95/samples/ncurses2-demo_pad.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                                 ncurses                                  --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright (c) 2000-2011,2014 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: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37 --  Version Control
  38 --  $Revision: 1.9 $
  39 --  $Date: 2014/09/13 19:10:18 $
  40 --  Binding Version 01.00
  41 ------------------------------------------------------------------------------
  42 with ncurses2.util; use ncurses2.util;
  43
  44 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  45
  46 with Interfaces.C;
  47 with System.Storage_Elements;
  48 with System.Address_To_Access_Conversions;
  49
  50 with Ada.Text_IO;
  51 --  with Ada.Real_Time; use Ada.Real_Time;
  52 --  TODO is there a way to use Real_Time or Ada.Calendar in place of
  53 --  gettimeofday?
  54
  55 --  Demonstrate pads.
  56 procedure ncurses2.demo_pad is
  57
  58    type timestruct is record
  59       seconds : Integer;
  60       microseconds : Integer;
  61    end record;
  62
  63    type myfunc is access function (w : Window) return Key_Code;
  64
  65    function  gettime return timestruct;
  66    procedure do_h_line (y  : Line_Position;
  67                         x  : Column_Position;
  68                         c  : Attributed_Character;
  69                         to : Column_Position);
  70    procedure do_v_line (y  : Line_Position;
  71                         x  : Column_Position;
  72                         c  : Attributed_Character;
  73                         to : Line_Position);
  74    function  padgetch (win : Window) return Key_Code;
  75    function  panner_legend (line : Line_Position) return Boolean;
  76    procedure panner_legend (line : Line_Position);
  77    procedure panner_h_cleanup (from_y : Line_Position;
  78                                from_x : Column_Position;
  79                                to_x   : Column_Position);
  80    procedure panner_v_cleanup (from_y : Line_Position;
  81                                from_x : Column_Position;
  82                                to_y   : Line_Position);
  83    procedure panner (pad    : Window;
  84                      top_xp : Column_Position;
  85                      top_yp : Line_Position;
  86                      portyp : Line_Position;
  87                      portxp : Column_Position;
  88                      pgetc  : myfunc);
  89
  90    function gettime return timestruct is
  91
  92       retval : timestruct;
  93
  94       use Interfaces.C;
  95       type timeval is record
  96          tv_sec : long;
  97          tv_usec : long;
  98       end record;
  99       pragma Convention (C, timeval);
 100
 101       --      TODO    function from_timeval is new Ada.Unchecked_Conversion(
 102       --                  timeval_a, System.Storage_Elements.Integer_Address);
 103       --  should Interfaces.C.Pointers be used here?
 104
 105       package myP is new System.Address_To_Access_Conversions (timeval);
 106       use myP;
 107
 108       t : constant Object_Pointer := new timeval;
 109
 110       function gettimeofday
 111         (TP : System.Storage_Elements.Integer_Address;
 112          TZP : System.Storage_Elements.Integer_Address) return int;
 113       pragma Import (C, gettimeofday, "gettimeofday");
 114       tmp : int;
 115    begin
 116       tmp := gettimeofday (System.Storage_Elements.To_Integer
 117                            (myP.To_Address (t)),
 118                            System.Storage_Elements.To_Integer
 119                            (myP.To_Address (null)));
 120       if tmp < 0 then
 121          retval.seconds := 0;
 122          retval.microseconds := 0;
 123       else
 124          retval.seconds := Integer (t.all.tv_sec);
 125          retval.microseconds := Integer (t.all.tv_usec);
 126       end if;
 127       return retval;
 128    end gettime;
 129
 130    --  in C, The behavior of mvhline, mvvline for negative/zero length is
 131    --  unspecified, though we can rely on negative x/y values to stop the
 132    --  macro. Except Ada makes Line_Position(-1) = Natural - 1 so forget it.
 133    procedure do_h_line (y  : Line_Position;
 134                         x  : Column_Position;
 135                         c  : Attributed_Character;
 136                         to : Column_Position) is
 137    begin
 138       if to > x then
 139          Move_Cursor (Line => y, Column => x);
 140          Horizontal_Line (Line_Size => Natural (to - x), Line_Symbol => c);
 141       end if;
 142    end do_h_line;
 143
 144    procedure do_v_line (y  : Line_Position;
 145                         x  : Column_Position;
 146                         c  : Attributed_Character;
 147                         to : Line_Position) is
 148    begin
 149       if to > y then
 150          Move_Cursor (Line => y, Column => x);
 151          Vertical_Line (Line_Size => Natural (to - y), Line_Symbol => c);
 152       end if;
 153    end do_v_line;
 154
 155    function padgetch (win : Window) return Key_Code is
 156       c : Key_Code;
 157       c2 : Character;
 158    begin
 159       c := Getchar (win);
 160       c2 := Code_To_Char (c);
 161
 162       case c2 is
 163          when '!' =>
 164             ShellOut (False);
 165             return Key_Refresh;
 166          when Character'Val (Character'Pos ('r') mod 16#20#) => --  CTRL('r')
 167             End_Windows;
 168             Refresh;
 169             return Key_Refresh;
 170          when Character'Val (Character'Pos ('l') mod 16#20#) => --  CTRL('l')
 171             return Key_Refresh;
 172          when 'U' =>
 173             return Key_Cursor_Up;
 174          when 'D' =>
 175             return Key_Cursor_Down;
 176          when 'R' =>
 177             return Key_Cursor_Right;
 178          when 'L' =>
 179             return Key_Cursor_Left;
 180          when '+' =>
 181             return Key_Insert_Line;
 182          when '-' =>
 183             return Key_Delete_Line;
 184          when '>' =>
 185             return Key_Insert_Char;
 186          when '<' =>
 187             return Key_Delete_Char;
 188             --  when ERR=>                   /* FALLTHRU */
 189          when 'q' =>
 190             return (Key_Exit);
 191          when others =>
 192             return (c);
 193       end case;
 194    end padgetch;
 195
 196    show_panner_legend : Boolean := True;
 197
 198    function panner_legend (line : Line_Position) return Boolean is
 199       legend : constant array (0 .. 3) of String (1 .. 61) :=
 200         (
 201          "Use arrow keys (or U,D,L,R) to pan, q to quit (?,t,s flags)  ",
 202          "Use ! to shell-out.  Toggle legend:?, timer:t, scroll mark:s.",
 203          "Use +,- (or j,k) to grow/shrink the panner vertically.       ",
 204          "Use <,> (or h,l) to grow/shrink the panner horizontally.     ");
 205       legendsize : constant := 4;
 206
 207       n : constant Integer := legendsize - Integer (Lines - line);
 208    begin
 209       if line < Lines and n >= 0 then
 210          Move_Cursor (Line => line, Column => 0);
 211          if show_panner_legend then
 212             Add (Str => legend (n));
 213          end if;
 214          Clear_To_End_Of_Line;
 215          return show_panner_legend;
 216       end if;
 217       return False;
 218    end panner_legend;
 219
 220    procedure panner_legend (line : Line_Position) is
 221    begin
 222       if not panner_legend (line) then
 223          Beep;
 224       end if;
 225    end panner_legend;
 226
 227    procedure panner_h_cleanup (from_y : Line_Position;
 228                                from_x : Column_Position;
 229                                to_x   : Column_Position) is
 230    begin
 231       if not panner_legend (from_y) then
 232          do_h_line (from_y, from_x, Blank2, to_x);
 233       end if;
 234    end panner_h_cleanup;
 235
 236    procedure panner_v_cleanup (from_y : Line_Position;
 237                                from_x : Column_Position;
 238                                to_y   : Line_Position) is
 239    begin
 240       if not panner_legend (from_y) then
 241          do_v_line (from_y, from_x, Blank2, to_y);
 242       end if;
 243    end panner_v_cleanup;
 244
 245    procedure panner (pad    : Window;
 246                      top_xp : Column_Position;
 247                      top_yp : Line_Position;
 248                      portyp : Line_Position;
 249                      portxp : Column_Position;
 250                      pgetc  : myfunc) is
 251
 252       function f (y : Line_Position) return Line_Position;
 253       function f (x : Column_Position) return Column_Position;
 254       function greater (y1, y2 : Line_Position) return Integer;
 255       function greater (x1, x2 : Column_Position) return Integer;
 256
 257       top_x : Column_Position := top_xp;
 258       top_y : Line_Position := top_yp;
 259       porty : Line_Position := portyp;
 260       portx : Column_Position := portxp;
 261
 262       --  f[x] returns max[x - 1, 0]
 263       function f (y : Line_Position) return Line_Position is
 264       begin
 265          if y > 0 then
 266             return y - 1;
 267          else
 268             return y; -- 0
 269          end if;
 270       end f;
 271
 272       function f (x : Column_Position) return Column_Position is
 273       begin
 274          if x > 0 then
 275             return x - 1;
 276          else
 277             return x; -- 0
 278          end if;
 279       end f;
 280
 281       function greater (y1, y2 : Line_Position) return Integer is
 282       begin
 283          if y1 > y2 then
 284             return 1;
 285          else
 286             return 0;
 287          end if;
 288       end greater;
 289
 290       function greater (x1, x2 : Column_Position) return Integer is
 291       begin
 292          if x1 > x2 then
 293             return 1;
 294          else
 295             return 0;
 296          end if;
 297       end greater;
 298
 299       pymax : Line_Position;
 300       basey : Line_Position := 0;
 301       pxmax : Column_Position;
 302       basex : Column_Position := 0;
 303       c : Key_Code;
 304       scrollers : Boolean := True;
 305       before, after : timestruct;
 306       timing : Boolean := True;
 307
 308       package floatio is new Ada.Text_IO.Float_IO (Long_Float);
 309    begin
 310       Get_Size (pad, pymax, pxmax);
 311       Allow_Scrolling (Mode => False); -- we don't want stdscr to scroll!
 312
 313       c := Key_Refresh;
 314       loop
 315          --  During shell-out, the user may have resized the window.  Adjust
 316          --  the port size of the pad to accommodate this.  Ncurses
 317          --  automatically resizes all of the normal windows to fit on the
 318          --  new screen.
 319          if top_x > Columns then
 320             top_x := Columns;
 321          end if;
 322          if portx > Columns then
 323             portx := Columns;
 324          end if;
 325          if top_y > Lines then
 326             top_y := Lines;
 327          end if;
 328          if porty > Lines then
 329             porty := Lines;
 330          end if;
 331
 332          case c is
 333             when Key_Refresh | Character'Pos ('?') =>
 334                if c = Key_Refresh then
 335                   Erase;
 336                else -- '?'
 337                   show_panner_legend := not show_panner_legend;
 338                end if;
 339                panner_legend (Lines - 4);
 340                panner_legend (Lines - 3);
 341                panner_legend (Lines - 2);
 342                panner_legend (Lines - 1);
 343             when Character'Pos ('t') =>
 344                timing := not timing;
 345                if not timing then
 346                   panner_legend (Lines - 1);
 347                end if;
 348             when Character'Pos ('s') =>
 349                scrollers := not scrollers;
 350
 351                --  Move the top-left corner of the pad, keeping the
 352                --  bottom-right corner fixed.
 353             when Character'Pos ('h') =>
 354                --  increase-columns: move left edge to left
 355                if top_x = 0 then
 356                   Beep;
 357                else
 358                   panner_v_cleanup (top_y, top_x, porty);
 359                   top_x := top_x - 1;
 360                end if;
 361
 362             when Character'Pos ('j') =>
 363                --  decrease-lines: move top-edge down
 364                if top_y >= porty then
 365                   Beep;
 366                else
 367                   if top_y /= 0 then
 368                      panner_h_cleanup (top_y - 1, f (top_x), portx);
 369                   end if;
 370                   top_y := top_y + 1;
 371                end if;
 372             when Character'Pos ('k') =>
 373                --  increase-lines: move top-edge up
 374                if top_y = 0 then
 375                   Beep;
 376                else
 377                   top_y := top_y - 1;
 378                   panner_h_cleanup (top_y, top_x, portx);
 379                end if;
 380
 381             when Character'Pos ('l') =>
 382                --  decrease-columns: move left-edge to right
 383                if top_x >= portx then
 384                   Beep;
 385                else
 386                   if top_x /= 0 then
 387                      panner_v_cleanup (f (top_y), top_x - 1, porty);
 388                   end if;
 389                   top_x := top_x + 1;
 390                end if;
 391
 392                --  Move the bottom-right corner of the pad, keeping the
 393                --  top-left corner fixed.
 394             when Key_Insert_Char =>
 395                --  increase-columns: move right-edge to right
 396                if portx >= pxmax or portx >= Columns then
 397                   Beep;
 398                else
 399                   panner_v_cleanup (f (top_y), portx - 1, porty);
 400                   portx := portx + 1;
 401                   --  C had ++portx instead of portx++, weird.
 402                end if;
 403             when Key_Insert_Line =>
 404                --  increase-lines: move bottom-edge down
 405                if porty >= pymax or porty >= Lines then
 406                   Beep;
 407                else
 408                   panner_h_cleanup (porty - 1, f (top_x), portx);
 409                   porty := porty + 1;
 410                end if;
 411
 412             when Key_Delete_Char =>
 413                --  decrease-columns: move bottom edge up
 414                if portx <= top_x then
 415                   Beep;
 416                else
 417                   portx := portx - 1;
 418                   panner_v_cleanup (f (top_y), portx, porty);
 419                end if;
 420
 421             when Key_Delete_Line =>
 422                --  decrease-lines
 423                if porty <= top_y then
 424                   Beep;
 425                else
 426                   porty := porty - 1;
 427                   panner_h_cleanup (porty, f (top_x), portx);
 428                end if;
 429             when Key_Cursor_Left =>
 430                --  pan leftwards
 431                if basex > 0 then
 432                   basex := basex - 1;
 433                else
 434                   Beep;
 435                end if;
 436             when Key_Cursor_Right =>
 437                --  pan rightwards
 438                --  if (basex + portx - (pymax > porty) < pxmax)
 439                if basex + portx -
 440                    Column_Position (greater (pymax, porty)) < pxmax
 441                then
 442                   --  if basex + portx  < pxmax or
 443                   --      (pymax > porty and basex + portx - 1 < pxmax) then
 444                   basex := basex + 1;
 445                else
 446                   Beep;
 447                end if;
 448
 449             when Key_Cursor_Up =>
 450                --  pan upwards
 451                if basey > 0 then
 452                   basey := basey - 1;
 453                else
 454                   Beep;
 455                end if;
 456
 457             when Key_Cursor_Down =>
 458                --  pan downwards
 459                --  same as if (basey + porty - (pxmax > portx) < pymax)
 460                if basey + porty -
 461                    Line_Position (greater (pxmax, portx)) < pymax
 462                then
 463                   --  if (basey + porty  < pymax) or
 464                   --      (pxmax > portx and basey + porty - 1 < pymax) then
 465                   basey := basey + 1;
 466                else
 467                   Beep;
 468                end if;
 469
 470             when  Character'Pos ('H') |
 471               Key_Home |
 472               Key_Find =>
 473                basey := 0;
 474
 475             when   Character'Pos ('E') |
 476               Key_End |
 477               Key_Select =>
 478                if pymax < porty then
 479                   basey := 0;
 480                else
 481                   basey := pymax - porty;
 482                end if;
 483
 484             when others =>
 485                Beep;
 486          end case;
 487
 488          --  more writing off the screen.
 489          --  Interestingly, the exception is not handled if
 490          --  we put a block around this.
 491          --  delcare --begin
 492          if top_y /= 0 and top_x /= 0 then
 493             Add (Line => top_y - 1, Column => top_x - 1,
 494                  Ch => ACS_Map (ACS_Upper_Left_Corner));
 495          end if;
 496          if top_x /= 0 then
 497             do_v_line (top_y, top_x - 1, ACS_Map (ACS_Vertical_Line), porty);
 498          end if;
 499          if top_y /= 0 then
 500             do_h_line (top_y - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
 501          end if;
 502          --  exception when Curses_Exception => null; end;
 503
 504          --  in C was ... pxmax > portx - 1
 505          if scrollers and pxmax >= portx then
 506             declare
 507                length : constant Column_Position := portx - top_x - 1;
 508                lowend, highend : Column_Position;
 509             begin
 510                --  Instead of using floats, I'll use integers only.
 511                lowend := top_x + (basex * length) / pxmax;
 512                highend := top_x + ((basex + length) * length) / pxmax;
 513
 514                do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line),
 515                           lowend);
 516                if highend < portx then
 517                   Switch_Character_Attribute
 518                     (Attr => (Reverse_Video => True, others => False),
 519                      On => True);
 520                   do_h_line (porty - 1, lowend, Blank2, highend + 1);
 521                   Switch_Character_Attribute
 522                     (Attr => (Reverse_Video => True, others => False),
 523                      On => False);
 524                   do_h_line (porty - 1, highend + 1,
 525                              ACS_Map (ACS_Horizontal_Line), portx);
 526                end if;
 527             end;
 528          else
 529             do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
 530          end if;
 531
 532          if scrollers and pymax >= porty then
 533             declare
 534                length : constant Line_Position := porty - top_y - 1;
 535                lowend, highend : Line_Position;
 536             begin
 537                lowend := top_y + (basey * length) / pymax;
 538                highend := top_y + ((basey + length) * length) / pymax;
 539
 540                do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line),
 541                           lowend);
 542                if highend < porty then
 543                   Switch_Character_Attribute
 544                     (Attr => (Reverse_Video => True, others => False),
 545                      On => True);
 546                   do_v_line (lowend, portx - 1, Blank2, highend + 1);
 547                   Switch_Character_Attribute
 548                     (Attr => (Reverse_Video => True, others => False),
 549                      On => False);
 550                   do_v_line (highend + 1, portx - 1,
 551                              ACS_Map (ACS_Vertical_Line), porty);
 552                end if;
 553             end;
 554          else
 555             do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), porty);
 556          end if;
 557
 558          if top_y /= 0 then
 559             Add (Line => top_y - 1, Column => portx - 1,
 560                  Ch => ACS_Map (ACS_Upper_Right_Corner));
 561          end if;
 562          if top_x /= 0 then
 563             Add (Line => porty - 1, Column => top_x - 1,
 564                  Ch => ACS_Map (ACS_Lower_Left_Corner));
 565          end if;
 566          declare
 567          begin
 568             --  Here is another place where it is possible
 569             --  to write to the corner of the screen.
 570             Add (Line => porty - 1, Column => portx - 1,
 571                  Ch => ACS_Map (ACS_Lower_Right_Corner));
 572             exception
 573             when Curses_Exception => null;
 574          end;
 575
 576          before := gettime;
 577
 578          Refresh_Without_Update;
 579
 580          declare
 581             --  the C version allows the panel to have a zero height
 582             --  wich raise the exception
 583          begin
 584             Refresh_Without_Update
 585               (
 586                pad,
 587                basey, basex,
 588                top_y, top_x,
 589                porty - Line_Position (greater (pxmax, portx)) - 1,
 590                portx - Column_Position (greater (pymax, porty)) - 1);
 591             exception
 592             when Curses_Exception => null;
 593          end;
 594
 595          Update_Screen;
 596
 597          if timing then
 598             declare
 599                s : String (1 .. 7);
 600                elapsed : Long_Float;
 601             begin
 602                after := gettime;
 603                elapsed := (Long_Float (after.seconds - before.seconds) +
 604                            Long_Float (after.microseconds
 605                                      - before.microseconds)
 606                            / 1.0e6);
 607                Move_Cursor (Line => Lines - 1, Column => Columns - 20);
 608                floatio.Put (s, elapsed, Aft => 3, Exp => 0);
 609                Add (Str => s);
 610                Refresh;
 611             end;
 612          end if;
 613
 614          c := pgetc (pad);
 615          exit when c = Key_Exit;
 616
 617       end loop;
 618
 619       Allow_Scrolling (Mode => True);
 620
 621    end panner;
 622
 623    Gridsize : constant := 3;
 624    Gridcount : Integer := 0;
 625
 626    Pad_High : constant Line_Count :=  200;
 627    Pad_Wide : constant Column_Count := 200;
 628    panpad : Window := New_Pad (Pad_High, Pad_Wide);
 629 begin
 630    if panpad = Null_Window then
 631       Cannot ("cannot create requested pad");
 632       return;
 633    end if;
 634
 635    for i in 0 .. Pad_High - 1 loop
 636       for j in 0 .. Pad_Wide - 1  loop
 637          if i mod Gridsize = 0 and j mod Gridsize = 0 then
 638             if i = 0 or j = 0 then
 639                Add (panpad, '+');
 640             else
 641                --  depends on ASCII?
 642                Add (panpad,
 643                     Ch => Character'Val (Character'Pos ('A') +
 644                                          Gridcount mod 26));
 645                Gridcount := Gridcount + 1;
 646             end if;
 647          elsif i mod Gridsize = 0 then
 648             Add (panpad, '-');
 649          elsif j mod Gridsize = 0 then
 650             Add (panpad, '|');
 651          else
 652             declare
 653                --  handle the write to the lower right corner error
 654             begin
 655                Add (panpad, ' ');
 656                exception
 657                when Curses_Exception => null;
 658             end;
 659          end if;
 660       end loop;
 661    end loop;
 662    panner_legend (Lines - 4);
 663    panner_legend (Lines - 3);
 664    panner_legend (Lines - 2);
 665    panner_legend (Lines - 1);
 666
 667    Set_KeyPad_Mode (panpad, True);
 668    --  Make the pad (initially) narrow enough that a trace file won't wrap.
 669    --  We'll still be able to widen it during a test, since that's required
 670    --  for testing boundaries.
 671
 672    panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access);
 673
 674    Delete (panpad);
 675    End_Windows; --  Hmm, Erase after End_Windows
 676    Erase;
 677 end ncurses2.demo_pad;