1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright 2020 Thomas E. Dickey --
11 -- Copyright 2000-2011,2014 Free Software Foundation, Inc. --
13 -- Permission is hereby granted, free of charge, to any person obtaining a --
14 -- copy of this software and associated documentation files (the --
15 -- "Software"), to deal in the Software without restriction, including --
16 -- without limitation the rights to use, copy, modify, merge, publish, --
17 -- distribute, distribute with modifications, sublicense, and/or sell --
18 -- copies of the Software, and to permit persons to whom the Software is --
19 -- furnished to do so, subject to the following conditions: --
21 -- The above copyright notice and this permission notice shall be included --
22 -- in all copies or substantial portions of the Software. --
24 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
25 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
26 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
27 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
28 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
29 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
30 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
32 -- Except as contained in this notice, the name(s) of the above copyright --
33 -- holders shall not be used in advertising or otherwise to promote the --
34 -- sale, use or other dealings in this Software without prior written --
36 ------------------------------------------------------------------------------
37 -- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
40 -- $Date: 2020/02/02 23:34:34 $
41 -- Binding Version 01.00
42 ------------------------------------------------------------------------------
43 with ncurses2.util; use ncurses2.util;
45 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48 with System.Storage_Elements;
49 with System.Address_To_Access_Conversions;
52 -- with Ada.Real_Time; use Ada.Real_Time;
53 -- TODO is there a way to use Real_Time or Ada.Calendar in place of
57 procedure ncurses2.demo_pad is
59 type timestruct is record
61 microseconds : Integer;
64 type myfunc is access function (w : Window) return Key_Code;
66 function gettime return timestruct;
67 procedure do_h_line (y : Line_Position;
69 c : Attributed_Character;
70 to : Column_Position);
71 procedure do_v_line (y : Line_Position;
73 c : Attributed_Character;
75 function padgetch (win : Window) return Key_Code;
76 function panner_legend (line : Line_Position) return Boolean;
77 procedure panner_legend (line : Line_Position);
78 procedure panner_h_cleanup (from_y : Line_Position;
79 from_x : Column_Position;
80 to_x : Column_Position);
81 procedure panner_v_cleanup (from_y : Line_Position;
82 from_x : Column_Position;
83 to_y : Line_Position);
84 procedure panner (pad : Window;
85 top_xp : Column_Position;
86 top_yp : Line_Position;
87 portyp : Line_Position;
88 portxp : Column_Position;
91 function gettime return timestruct is
96 type timeval is record
100 pragma Convention (C, timeval);
102 -- TODO function from_timeval is new Ada.Unchecked_Conversion(
103 -- timeval_a, System.Storage_Elements.Integer_Address);
104 -- should Interfaces.C.Pointers be used here?
106 package myP is new System.Address_To_Access_Conversions (timeval);
109 t : constant Object_Pointer := new timeval;
111 function gettimeofday
112 (TP : System.Storage_Elements.Integer_Address;
113 TZP : System.Storage_Elements.Integer_Address) return int;
114 pragma Import (C, gettimeofday, "gettimeofday");
117 tmp := gettimeofday (System.Storage_Elements.To_Integer
118 (myP.To_Address (t)),
119 System.Storage_Elements.To_Integer
120 (myP.To_Address (null)));
123 retval.microseconds := 0;
125 retval.seconds := Integer (t.all.tv_sec);
126 retval.microseconds := Integer (t.all.tv_usec);
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;
136 c : Attributed_Character;
137 to : Column_Position) is
140 Move_Cursor (Line => y, Column => x);
141 Horizontal_Line (Line_Size => Natural (to - x), Line_Symbol => c);
145 procedure do_v_line (y : Line_Position;
147 c : Attributed_Character;
148 to : Line_Position) is
151 Move_Cursor (Line => y, Column => x);
152 Vertical_Line (Line_Size => Natural (to - y), Line_Symbol => c);
156 function padgetch (win : Window) return Key_Code is
161 c2 := Code_To_Char (c);
167 when Character'Val (Character'Pos ('r') mod 16#20#) => -- CTRL('r')
171 when Character'Val (Character'Pos ('l') mod 16#20#) => -- CTRL('l')
174 return Key_Cursor_Up;
176 return Key_Cursor_Down;
178 return Key_Cursor_Right;
180 return Key_Cursor_Left;
182 return Key_Insert_Line;
184 return Key_Delete_Line;
186 return Key_Insert_Char;
188 return Key_Delete_Char;
189 -- when ERR=> /* FALLTHRU */
197 show_panner_legend : Boolean := True;
199 function panner_legend (line : Line_Position) return Boolean is
200 legend : constant array (0 .. 3) of String (1 .. 61) :=
202 "Use arrow keys (or U,D,L,R) to pan, q to quit (?,t,s flags) ",
203 "Use ! to shell-out. Toggle legend:?, timer:t, scroll mark:s.",
204 "Use +,- (or j,k) to grow/shrink the panner vertically. ",
205 "Use <,> (or h,l) to grow/shrink the panner horizontally. ");
206 legendsize : constant := 4;
208 n : constant Integer := legendsize - Integer (Lines - line);
210 if line < Lines and n >= 0 then
211 Move_Cursor (Line => line, Column => 0);
212 if show_panner_legend then
213 Add (Str => legend (n));
215 Clear_To_End_Of_Line;
216 return show_panner_legend;
221 procedure panner_legend (line : Line_Position) is
223 if not panner_legend (line) then
228 procedure panner_h_cleanup (from_y : Line_Position;
229 from_x : Column_Position;
230 to_x : Column_Position) is
232 if not panner_legend (from_y) then
233 do_h_line (from_y, from_x, Blank2, to_x);
235 end panner_h_cleanup;
237 procedure panner_v_cleanup (from_y : Line_Position;
238 from_x : Column_Position;
239 to_y : Line_Position) is
241 if not panner_legend (from_y) then
242 do_v_line (from_y, from_x, Blank2, to_y);
244 end panner_v_cleanup;
246 procedure panner (pad : Window;
247 top_xp : Column_Position;
248 top_yp : Line_Position;
249 portyp : Line_Position;
250 portxp : Column_Position;
253 function f (y : Line_Position) return Line_Position;
254 function f (x : Column_Position) return Column_Position;
255 function greater (y1, y2 : Line_Position) return Integer;
256 function greater (x1, x2 : Column_Position) return Integer;
258 top_x : Column_Position := top_xp;
259 top_y : Line_Position := top_yp;
260 porty : Line_Position := portyp;
261 portx : Column_Position := portxp;
263 -- f[x] returns max[x - 1, 0]
264 function f (y : Line_Position) return Line_Position is
273 function f (x : Column_Position) return Column_Position is
282 function greater (y1, y2 : Line_Position) return Integer is
291 function greater (x1, x2 : Column_Position) return Integer is
300 pymax : Line_Position;
301 basey : Line_Position := 0;
302 pxmax : Column_Position;
303 basex : Column_Position := 0;
305 scrollers : Boolean := True;
306 before, after : timestruct;
307 timing : Boolean := True;
309 package floatio is new Ada.Text_IO.Float_IO (Long_Float);
311 Get_Size (pad, pymax, pxmax);
312 Allow_Scrolling (Mode => False); -- we don't want stdscr to scroll!
316 -- During shell-out, the user may have resized the window. Adjust
317 -- the port size of the pad to accommodate this. Ncurses
318 -- automatically resizes all of the normal windows to fit on the
320 if top_x > Columns then
323 if portx > Columns then
326 if top_y > Lines then
329 if porty > Lines then
334 when Key_Refresh | Character'Pos ('?') =>
335 if c = Key_Refresh then
338 show_panner_legend := not show_panner_legend;
340 panner_legend (Lines - 4);
341 panner_legend (Lines - 3);
342 panner_legend (Lines - 2);
343 panner_legend (Lines - 1);
344 when Character'Pos ('t') =>
345 timing := not timing;
347 panner_legend (Lines - 1);
349 when Character'Pos ('s') =>
350 scrollers := not scrollers;
352 -- Move the top-left corner of the pad, keeping the
353 -- bottom-right corner fixed.
354 when Character'Pos ('h') =>
355 -- increase-columns: move left edge to left
359 panner_v_cleanup (top_y, top_x, porty);
363 when Character'Pos ('j') =>
364 -- decrease-lines: move top-edge down
365 if top_y >= porty then
369 panner_h_cleanup (top_y - 1, f (top_x), portx);
373 when Character'Pos ('k') =>
374 -- increase-lines: move top-edge up
379 panner_h_cleanup (top_y, top_x, portx);
382 when Character'Pos ('l') =>
383 -- decrease-columns: move left-edge to right
384 if top_x >= portx then
388 panner_v_cleanup (f (top_y), top_x - 1, porty);
393 -- Move the bottom-right corner of the pad, keeping the
394 -- top-left corner fixed.
395 when Key_Insert_Char =>
396 -- increase-columns: move right-edge to right
397 if portx >= pxmax or portx >= Columns then
400 panner_v_cleanup (f (top_y), portx - 1, porty);
402 -- C had ++portx instead of portx++, weird.
404 when Key_Insert_Line =>
405 -- increase-lines: move bottom-edge down
406 if porty >= pymax or porty >= Lines then
409 panner_h_cleanup (porty - 1, f (top_x), portx);
413 when Key_Delete_Char =>
414 -- decrease-columns: move bottom edge up
415 if portx <= top_x then
419 panner_v_cleanup (f (top_y), portx, porty);
422 when Key_Delete_Line =>
424 if porty <= top_y then
428 panner_h_cleanup (porty, f (top_x), portx);
430 when Key_Cursor_Left =>
437 when Key_Cursor_Right =>
439 -- if (basex + portx - (pymax > porty) < pxmax)
441 Column_Position (greater (pymax, porty)) < pxmax
443 -- if basex + portx < pxmax or
444 -- (pymax > porty and basex + portx - 1 < pxmax) then
450 when Key_Cursor_Up =>
458 when Key_Cursor_Down =>
460 -- same as if (basey + porty - (pxmax > portx) < pymax)
462 Line_Position (greater (pxmax, portx)) < pymax
464 -- if (basey + porty < pymax) or
465 -- (pxmax > portx and basey + porty - 1 < pymax) then
471 when Character'Pos ('H') |
476 when Character'Pos ('E') |
479 if pymax < porty then
482 basey := pymax - porty;
489 -- more writing off the screen.
490 -- Interestingly, the exception is not handled if
491 -- we put a block around this.
493 if top_y /= 0 and top_x /= 0 then
494 Add (Line => top_y - 1, Column => top_x - 1,
495 Ch => ACS_Map (ACS_Upper_Left_Corner));
498 do_v_line (top_y, top_x - 1, ACS_Map (ACS_Vertical_Line), porty);
501 do_h_line (top_y - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
503 -- exception when Curses_Exception => null; end;
505 -- in C was ... pxmax > portx - 1
506 if scrollers and pxmax >= portx then
508 length : constant Column_Position := portx - top_x - 1;
509 lowend, highend : Column_Position;
511 -- Instead of using floats, I'll use integers only.
512 lowend := top_x + (basex * length) / pxmax;
513 highend := top_x + ((basex + length) * length) / pxmax;
515 do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line),
517 if highend < portx then
518 Switch_Character_Attribute
519 (Attr => (Reverse_Video => True, others => False),
521 do_h_line (porty - 1, lowend, Blank2, highend + 1);
522 Switch_Character_Attribute
523 (Attr => (Reverse_Video => True, others => False),
525 do_h_line (porty - 1, highend + 1,
526 ACS_Map (ACS_Horizontal_Line), portx);
530 do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
533 if scrollers and pymax >= porty then
535 length : constant Line_Position := porty - top_y - 1;
536 lowend, highend : Line_Position;
538 lowend := top_y + (basey * length) / pymax;
539 highend := top_y + ((basey + length) * length) / pymax;
541 do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line),
543 if highend < porty then
544 Switch_Character_Attribute
545 (Attr => (Reverse_Video => True, others => False),
547 do_v_line (lowend, portx - 1, Blank2, highend + 1);
548 Switch_Character_Attribute
549 (Attr => (Reverse_Video => True, others => False),
551 do_v_line (highend + 1, portx - 1,
552 ACS_Map (ACS_Vertical_Line), porty);
556 do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), porty);
560 Add (Line => top_y - 1, Column => portx - 1,
561 Ch => ACS_Map (ACS_Upper_Right_Corner));
564 Add (Line => porty - 1, Column => top_x - 1,
565 Ch => ACS_Map (ACS_Lower_Left_Corner));
569 -- Here is another place where it is possible
570 -- to write to the corner of the screen.
571 Add (Line => porty - 1, Column => portx - 1,
572 Ch => ACS_Map (ACS_Lower_Right_Corner));
574 when Curses_Exception => null;
579 Refresh_Without_Update;
582 -- the C version allows the panel to have a zero height
583 -- which raise the exception
585 Refresh_Without_Update
590 porty - Line_Position (greater (pxmax, portx)) - 1,
591 portx - Column_Position (greater (pymax, porty)) - 1);
593 when Curses_Exception => null;
601 elapsed : Long_Float;
604 elapsed := (Long_Float (after.seconds - before.seconds) +
605 Long_Float (after.microseconds
606 - before.microseconds)
608 Move_Cursor (Line => Lines - 1, Column => Columns - 20);
609 floatio.Put (s, elapsed, Aft => 3, Exp => 0);
616 exit when c = Key_Exit;
620 Allow_Scrolling (Mode => True);
624 Gridsize : constant := 3;
625 Gridcount : Integer := 0;
627 Pad_High : constant Line_Count := 200;
628 Pad_Wide : constant Column_Count := 200;
629 panpad : Window := New_Pad (Pad_High, Pad_Wide);
631 if panpad = Null_Window then
632 Cannot ("cannot create requested pad");
636 for i in 0 .. Pad_High - 1 loop
637 for j in 0 .. Pad_Wide - 1 loop
638 if i mod Gridsize = 0 and j mod Gridsize = 0 then
639 if i = 0 or j = 0 then
644 Ch => Character'Val (Character'Pos ('A') +
646 Gridcount := Gridcount + 1;
648 elsif i mod Gridsize = 0 then
650 elsif j mod Gridsize = 0 then
654 -- handle the write to the lower right corner error
658 when Curses_Exception => null;
663 panner_legend (Lines - 4);
664 panner_legend (Lines - 3);
665 panner_legend (Lines - 2);
666 panner_legend (Lines - 1);
668 Set_KeyPad_Mode (panpad, True);
669 -- Make the pad (initially) narrow enough that a trace file won't wrap.
670 -- We'll still be able to widen it during a test, since that's required
671 -- for testing boundaries.
673 panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access);
676 End_Windows; -- Hmm, Erase after End_Windows
678 end ncurses2.demo_pad;