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------------------------------------------------------------------------------ 43with ncurses2.util; use ncurses2.util; 44 45with Terminal_Interface.Curses; use Terminal_Interface.Curses; 46 47with Interfaces.C; 48with System.Storage_Elements; 49with System.Address_To_Access_Conversions; 50 51with 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. 57procedure 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); 630begin 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; 678end ncurses2.demo_pad; 679