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