ncurses 6.3 - patch 20211127
[ncurses.git] / 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;