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