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