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