1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000-2011,2014 Free Software Foundation, Inc. --
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: --
20 -- The above copyright notice and this permission notice shall be included --
21 -- in all copies or substantial portions of the Software. --
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. --
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 --
35 ------------------------------------------------------------------------------
36 -- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
39 -- $Date: 2014/09/13 19:10:18 $
40 -- Binding Version 01.00
41 ------------------------------------------------------------------------------
42 with ncurses2.util; use ncurses2.util;
44 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
47 with System.Storage_Elements;
48 with System.Address_To_Access_Conversions;
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
56 procedure ncurses2.demo_pad is
58 type timestruct is record
60 microseconds : Integer;
63 type myfunc is access function (w : Window) return Key_Code;
65 function gettime return timestruct;
66 procedure do_h_line (y : Line_Position;
68 c : Attributed_Character;
69 to : Column_Position);
70 procedure do_v_line (y : Line_Position;
72 c : Attributed_Character;
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;
90 function gettime return timestruct is
95 type timeval is record
99 pragma Convention (C, timeval);
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?
105 package myP is new System.Address_To_Access_Conversions (timeval);
108 t : constant Object_Pointer := new timeval;
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");
116 tmp := gettimeofday (System.Storage_Elements.To_Integer
117 (myP.To_Address (t)),
118 System.Storage_Elements.To_Integer
119 (myP.To_Address (null)));
122 retval.microseconds := 0;
124 retval.seconds := Integer (t.all.tv_sec);
125 retval.microseconds := Integer (t.all.tv_usec);
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;
135 c : Attributed_Character;
136 to : Column_Position) is
139 Move_Cursor (Line => y, Column => x);
140 Horizontal_Line (Line_Size => Natural (to - x), Line_Symbol => c);
144 procedure do_v_line (y : Line_Position;
146 c : Attributed_Character;
147 to : Line_Position) is
150 Move_Cursor (Line => y, Column => x);
151 Vertical_Line (Line_Size => Natural (to - y), Line_Symbol => c);
155 function padgetch (win : Window) return Key_Code is
160 c2 := Code_To_Char (c);
166 when Character'Val (Character'Pos ('r') mod 16#20#) => -- CTRL('r')
170 when Character'Val (Character'Pos ('l') mod 16#20#) => -- CTRL('l')
173 return Key_Cursor_Up;
175 return Key_Cursor_Down;
177 return Key_Cursor_Right;
179 return Key_Cursor_Left;
181 return Key_Insert_Line;
183 return Key_Delete_Line;
185 return Key_Insert_Char;
187 return Key_Delete_Char;
188 -- when ERR=> /* FALLTHRU */
196 show_panner_legend : Boolean := True;
198 function panner_legend (line : Line_Position) return Boolean is
199 legend : constant array (0 .. 3) of String (1 .. 61) :=
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;
207 n : constant Integer := legendsize - Integer (Lines - line);
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));
214 Clear_To_End_Of_Line;
215 return show_panner_legend;
220 procedure panner_legend (line : Line_Position) is
222 if not panner_legend (line) then
227 procedure panner_h_cleanup (from_y : Line_Position;
228 from_x : Column_Position;
229 to_x : Column_Position) is
231 if not panner_legend (from_y) then
232 do_h_line (from_y, from_x, Blank2, to_x);
234 end panner_h_cleanup;
236 procedure panner_v_cleanup (from_y : Line_Position;
237 from_x : Column_Position;
238 to_y : Line_Position) is
240 if not panner_legend (from_y) then
241 do_v_line (from_y, from_x, Blank2, to_y);
243 end panner_v_cleanup;
245 procedure panner (pad : Window;
246 top_xp : Column_Position;
247 top_yp : Line_Position;
248 portyp : Line_Position;
249 portxp : Column_Position;
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;
257 top_x : Column_Position := top_xp;
258 top_y : Line_Position := top_yp;
259 porty : Line_Position := portyp;
260 portx : Column_Position := portxp;
262 -- f[x] returns max[x - 1, 0]
263 function f (y : Line_Position) return Line_Position is
272 function f (x : Column_Position) return Column_Position is
281 function greater (y1, y2 : Line_Position) return Integer is
290 function greater (x1, x2 : Column_Position) return Integer is
299 pymax : Line_Position;
300 basey : Line_Position := 0;
301 pxmax : Column_Position;
302 basex : Column_Position := 0;
304 scrollers : Boolean := True;
305 before, after : timestruct;
306 timing : Boolean := True;
308 package floatio is new Ada.Text_IO.Float_IO (Long_Float);
310 Get_Size (pad, pymax, pxmax);
311 Allow_Scrolling (Mode => False); -- we don't want stdscr to scroll!
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
319 if top_x > Columns then
322 if portx > Columns then
325 if top_y > Lines then
328 if porty > Lines then
333 when Key_Refresh | Character'Pos ('?') =>
334 if c = Key_Refresh then
337 show_panner_legend := not show_panner_legend;
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;
346 panner_legend (Lines - 1);
348 when Character'Pos ('s') =>
349 scrollers := not scrollers;
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
358 panner_v_cleanup (top_y, top_x, porty);
362 when Character'Pos ('j') =>
363 -- decrease-lines: move top-edge down
364 if top_y >= porty then
368 panner_h_cleanup (top_y - 1, f (top_x), portx);
372 when Character'Pos ('k') =>
373 -- increase-lines: move top-edge up
378 panner_h_cleanup (top_y, top_x, portx);
381 when Character'Pos ('l') =>
382 -- decrease-columns: move left-edge to right
383 if top_x >= portx then
387 panner_v_cleanup (f (top_y), top_x - 1, porty);
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
399 panner_v_cleanup (f (top_y), portx - 1, porty);
401 -- C had ++portx instead of portx++, weird.
403 when Key_Insert_Line =>
404 -- increase-lines: move bottom-edge down
405 if porty >= pymax or porty >= Lines then
408 panner_h_cleanup (porty - 1, f (top_x), portx);
412 when Key_Delete_Char =>
413 -- decrease-columns: move bottom edge up
414 if portx <= top_x then
418 panner_v_cleanup (f (top_y), portx, porty);
421 when Key_Delete_Line =>
423 if porty <= top_y then
427 panner_h_cleanup (porty, f (top_x), portx);
429 when Key_Cursor_Left =>
436 when Key_Cursor_Right =>
438 -- if (basex + portx - (pymax > porty) < pxmax)
440 Column_Position (greater (pymax, porty)) < pxmax
442 -- if basex + portx < pxmax or
443 -- (pymax > porty and basex + portx - 1 < pxmax) then
449 when Key_Cursor_Up =>
457 when Key_Cursor_Down =>
459 -- same as if (basey + porty - (pxmax > portx) < pymax)
461 Line_Position (greater (pxmax, portx)) < pymax
463 -- if (basey + porty < pymax) or
464 -- (pxmax > portx and basey + porty - 1 < pymax) then
470 when Character'Pos ('H') |
475 when Character'Pos ('E') |
478 if pymax < porty then
481 basey := pymax - porty;
488 -- more writing off the screen.
489 -- Interestingly, the exception is not handled if
490 -- we put a block around this.
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));
497 do_v_line (top_y, top_x - 1, ACS_Map (ACS_Vertical_Line), porty);
500 do_h_line (top_y - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
502 -- exception when Curses_Exception => null; end;
504 -- in C was ... pxmax > portx - 1
505 if scrollers and pxmax >= portx then
507 length : constant Column_Position := portx - top_x - 1;
508 lowend, highend : Column_Position;
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;
514 do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line),
516 if highend < portx then
517 Switch_Character_Attribute
518 (Attr => (Reverse_Video => True, others => False),
520 do_h_line (porty - 1, lowend, Blank2, highend + 1);
521 Switch_Character_Attribute
522 (Attr => (Reverse_Video => True, others => False),
524 do_h_line (porty - 1, highend + 1,
525 ACS_Map (ACS_Horizontal_Line), portx);
529 do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
532 if scrollers and pymax >= porty then
534 length : constant Line_Position := porty - top_y - 1;
535 lowend, highend : Line_Position;
537 lowend := top_y + (basey * length) / pymax;
538 highend := top_y + ((basey + length) * length) / pymax;
540 do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line),
542 if highend < porty then
543 Switch_Character_Attribute
544 (Attr => (Reverse_Video => True, others => False),
546 do_v_line (lowend, portx - 1, Blank2, highend + 1);
547 Switch_Character_Attribute
548 (Attr => (Reverse_Video => True, others => False),
550 do_v_line (highend + 1, portx - 1,
551 ACS_Map (ACS_Vertical_Line), porty);
555 do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), porty);
559 Add (Line => top_y - 1, Column => portx - 1,
560 Ch => ACS_Map (ACS_Upper_Right_Corner));
563 Add (Line => porty - 1, Column => top_x - 1,
564 Ch => ACS_Map (ACS_Lower_Left_Corner));
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));
573 when Curses_Exception => null;
578 Refresh_Without_Update;
581 -- the C version allows the panel to have a zero height
582 -- wich raise the exception
584 Refresh_Without_Update
589 porty - Line_Position (greater (pxmax, portx)) - 1,
590 portx - Column_Position (greater (pymax, porty)) - 1);
592 when Curses_Exception => null;
600 elapsed : Long_Float;
603 elapsed := (Long_Float (after.seconds - before.seconds) +
604 Long_Float (after.microseconds
605 - before.microseconds)
607 Move_Cursor (Line => Lines - 1, Column => Columns - 20);
608 floatio.Put (s, elapsed, Aft => 3, Exp => 0);
615 exit when c = Key_Exit;
619 Allow_Scrolling (Mode => True);
623 Gridsize : constant := 3;
624 Gridcount : Integer := 0;
626 Pad_High : constant Line_Count := 200;
627 Pad_Wide : constant Column_Count := 200;
628 panpad : Window := New_Pad (Pad_High, Pad_Wide);
630 if panpad = Null_Window then
631 Cannot ("cannot create requested pad");
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
643 Ch => Character'Val (Character'Pos ('A') +
645 Gridcount := Gridcount + 1;
647 elsif i mod Gridsize = 0 then
649 elsif j mod Gridsize = 0 then
653 -- handle the write to the lower right corner error
657 when Curses_Exception => null;
662 panner_legend (Lines - 4);
663 panner_legend (Lines - 3);
664 panner_legend (Lines - 2);
665 panner_legend (Lines - 1);
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.
672 panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access);
675 End_Windows; -- Hmm, Erase after End_Windows
677 end ncurses2.demo_pad;