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