?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
libncurses: updated to 6.0
[tomato.git] / release / src / router / libncurses / Ada95 / samples / ncurses2-demo_pad.adb
blob062ec53869fb6c3639f5683c4d7da113cf32e15a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT ncurses Binding Samples --
4 -- --
5 -- ncurses --
6 -- --
7 -- B O D Y --
8 -- --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000-2011,2014 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.9 $
39 -- $Date: 2014/09/13 19:10:18 $
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
441 then
442 -- if basex + portx < pxmax or
443 -- (pymax > porty and basex + portx - 1 < pxmax) then
444 basex := basex + 1;
445 else
446 Beep;
447 end if;
448
449 when Key_Cursor_Up =>
450 -- pan upwards
451 if basey > 0 then
452 basey := basey - 1;
453 else
454 Beep;
455 end if;
456
457 when Key_Cursor_Down =>
458 -- pan downwards
459 -- same as if (basey + porty - (pxmax > portx) < pymax)
460 if basey + porty -
461 Line_Position (greater (pxmax, portx)) < pymax
462 then
463 -- if (basey + porty < pymax) or
464 -- (pxmax > portx and basey + porty - 1 < pymax) then
465 basey := basey + 1;
466 else
467 Beep;
468 end if;
469
470 when Character'Pos ('H') |
471 Key_Home |
472 Key_Find =>
473 basey := 0;
474
475 when Character'Pos ('E') |
476 Key_End |
477 Key_Select =>
478 if pymax < porty then
479 basey := 0;
480 else
481 basey := pymax - porty;
482 end if;
483
484 when others =>
485 Beep;
486 end case;
487
488 -- more writing off the screen.
489 -- Interestingly, the exception is not handled if
490 -- we put a block around this.
491 -- delcare --begin
492 if top_y /= 0 and top_x /= 0 then
493 Add (Line => top_y - 1, Column => top_x - 1,
494 Ch => ACS_Map (ACS_Upper_Left_Corner));
495 end if;
496 if top_x /= 0 then
497 do_v_line (top_y, top_x - 1, ACS_Map (ACS_Vertical_Line), porty);
498 end if;
499 if top_y /= 0 then
500 do_h_line (top_y - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
501 end if;
502 -- exception when Curses_Exception => null; end;
503
504 -- in C was ... pxmax > portx - 1
505 if scrollers and pxmax >= portx then
506 declare
507 length : constant Column_Position := portx - top_x - 1;
508 lowend, highend : Column_Position;
509 begin
510 -- Instead of using floats, I'll use integers only.
511 lowend := top_x + (basex * length) / pxmax;
512 highend := top_x + ((basex + length) * length) / pxmax;
513
514 do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line),
515 lowend);
516 if highend < portx then
517 Switch_Character_Attribute
518 (Attr => (Reverse_Video => True, others => False),
519 On => True);
520 do_h_line (porty - 1, lowend, Blank2, highend + 1);
521 Switch_Character_Attribute
522 (Attr => (Reverse_Video => True, others => False),
523 On => False);
524 do_h_line (porty - 1, highend + 1,
525 ACS_Map (ACS_Horizontal_Line), portx);
526 end if;
527 end;
528 else
529 do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
530 end if;
531
532 if scrollers and pymax >= porty then
533 declare
534 length : constant Line_Position := porty - top_y - 1;
535 lowend, highend : Line_Position;
536 begin
537 lowend := top_y + (basey * length) / pymax;
538 highend := top_y + ((basey + length) * length) / pymax;
539
540 do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line),
541 lowend);
542 if highend < porty then
543 Switch_Character_Attribute
544 (Attr => (Reverse_Video => True, others => False),
545 On => True);
546 do_v_line (lowend, portx - 1, Blank2, highend + 1);
547 Switch_Character_Attribute
548 (Attr => (Reverse_Video => True, others => False),
549 On => False);
550 do_v_line (highend + 1, portx - 1,
551 ACS_Map (ACS_Vertical_Line), porty);
552 end if;
553 end;
554 else
555 do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), porty);
556 end if;
557
558 if top_y /= 0 then
559 Add (Line => top_y - 1, Column => portx - 1,
560 Ch => ACS_Map (ACS_Upper_Right_Corner));
561 end if;
562 if top_x /= 0 then
563 Add (Line => porty - 1, Column => top_x - 1,
564 Ch => ACS_Map (ACS_Lower_Left_Corner));
565 end if;
566 declare
567 begin
568 -- Here is another place where it is possible
569 -- to write to the corner of the screen.
570 Add (Line => porty - 1, Column => portx - 1,
571 Ch => ACS_Map (ACS_Lower_Right_Corner));
572 exception
573 when Curses_Exception => null;
574 end;
575
576 before := gettime;
577
578 Refresh_Without_Update;
579
580 declare
581 -- the C version allows the panel to have a zero height
582 -- wich raise the exception
583 begin
584 Refresh_Without_Update
585 (
586 pad,
587 basey, basex,
588 top_y, top_x,
589 porty - Line_Position (greater (pxmax, portx)) - 1,
590 portx - Column_Position (greater (pymax, porty)) - 1);
591 exception
592 when Curses_Exception => null;
593 end;
594
595 Update_Screen;
596
597 if timing then
598 declare
599 s : String (1 .. 7);
600 elapsed : Long_Float;
601 begin
602 after := gettime;
603 elapsed := (Long_Float (after.seconds - before.seconds) +
604 Long_Float (after.microseconds
605 - before.microseconds)
606 / 1.0e6);
607 Move_Cursor (Line => Lines - 1, Column => Columns - 20);
608 floatio.Put (s, elapsed, Aft => 3, Exp => 0);
609 Add (Str => s);
610 Refresh;
611 end;
612 end if;
613
614 c := pgetc (pad);
615 exit when c = Key_Exit;
616
617 end loop;
618
619 Allow_Scrolling (Mode => True);
620
621 end panner;
622
623 Gridsize : constant := 3;
624 Gridcount : Integer := 0;
625
626 Pad_High : constant Line_Count := 200;
627 Pad_Wide : constant Column_Count := 200;
628 panpad : Window := New_Pad (Pad_High, Pad_Wide);
629 begin
630 if panpad = Null_Window then
631 Cannot ("cannot create requested pad");
632 return;
633 end if;
634
635 for i in 0 .. Pad_High - 1 loop
636 for j in 0 .. Pad_Wide - 1 loop
637 if i mod Gridsize = 0 and j mod Gridsize = 0 then
638 if i = 0 or j = 0 then
639 Add (panpad, '+');
640 else
641 -- depends on ASCII?
642 Add (panpad,
643 Ch => Character'Val (Character'Pos ('A') +
644 Gridcount mod 26));
645 Gridcount := Gridcount + 1;
646 end if;
647 elsif i mod Gridsize = 0 then
648 Add (panpad, '-');
649 elsif j mod Gridsize = 0 then
650 Add (panpad, '|');
651 else
652 declare
653 -- handle the write to the lower right corner error
654 begin
655 Add (panpad, ' ');
656 exception
657 when Curses_Exception => null;
658 end;
659 end if;
660 end loop;
661 end loop;
662 panner_legend (Lines - 4);
663 panner_legend (Lines - 3);
664 panner_legend (Lines - 2);
665 panner_legend (Lines - 1);
666
667 Set_KeyPad_Mode (panpad, True);
668 -- Make the pad (initially) narrow enough that a trace file won't wrap.
669 -- We'll still be able to widen it during a test, since that's required
670 -- for testing boundaries.
671
672 panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access);
673
674 Delete (panpad);
675 End_Windows; -- Hmm, Erase after End_Windows
676 Erase;
677 end ncurses2.demo_pad;
Tomato firmware and modifications.