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