1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright 2018,2020 Thomas E. Dickey --
11 -- Copyright 2000-2009,2011 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 -- Windows and scrolling tester.
44 -- Demonstrate windows
46 with Ada.Strings.Fixed;
49 with ncurses2.util; use ncurses2.util;
50 with ncurses2.genericPuts;
51 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
52 with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
53 with Terminal_Interface.Curses.PutWin; use Terminal_Interface.Curses.PutWin;
55 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
56 with Ada.Streams; use Ada.Streams;
58 procedure ncurses2.acs_and_scroll is
60 Macro_Quit : constant Key_Code := Character'Pos ('Q') mod 16#20#;
61 Macro_Escape : constant Key_Code := Character'Pos ('[') mod 16#20#;
63 Quit : constant Key_Code := CTRL ('Q');
64 Escape : constant Key_Code := CTRL ('[');
66 Botlines : constant Line_Position := 4;
74 type FrameA is access Frame;
77 dumpfile : constant String := "screendump";
79 procedure Outerbox (ul, lr : pair; onoff : Boolean);
80 function HaveKeyPad (w : Window) return Boolean;
81 function HaveScroll (w : Window) return Boolean;
82 procedure newwin_legend (curpw : Window);
83 procedure transient (curpw : Window; msg : String);
84 procedure newwin_report (win : Window := Standard_Window);
85 procedure selectcell (uli : Line_Position;
86 ulj : Column_Position;
88 lrj : Column_Position;
91 function getwindow return Window;
92 procedure newwin_move (win : Window;
94 dx : Column_Position);
95 function delete_framed (fp : FrameA; showit : Boolean) return FrameA;
98 -- I wish there was a standard library linked list. Oh well.
110 procedure Outerbox (ul, lr : pair; onoff : Boolean) is
113 -- Note the fix of an obscure bug
114 -- try making a 1x1 box then enlarging it, the is a blank
115 -- upper left corner!
116 Add (Line => ul.y - 1, Column => ul.x - 1,
117 Ch => ACS_Map (ACS_Upper_Left_Corner));
118 Add (Line => ul.y - 1, Column => lr.x + 1,
119 Ch => ACS_Map (ACS_Upper_Right_Corner));
120 Add (Line => lr.y + 1, Column => lr.x + 1,
121 Ch => ACS_Map (ACS_Lower_Right_Corner));
122 Add (Line => lr.y + 1, Column => ul.x - 1,
123 Ch => ACS_Map (ACS_Lower_Left_Corner));
125 Move_Cursor (Line => ul.y - 1, Column => ul.x);
126 Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
127 Line_Size => Integer (lr.x - ul.x) + 1);
128 Move_Cursor (Line => ul.y, Column => ul.x - 1);
129 Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
130 Line_Size => Integer (lr.y - ul.y) + 1);
131 Move_Cursor (Line => lr.y + 1, Column => ul.x);
132 Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
133 Line_Size => Integer (lr.x - ul.x) + 1);
134 Move_Cursor (Line => ul.y, Column => lr.x + 1);
135 Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
136 Line_Size => Integer (lr.y - ul.y) + 1);
138 Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ' ');
139 Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ' ');
140 Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ' ');
141 Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ' ');
143 Move_Cursor (Line => ul.y - 1, Column => ul.x);
144 Horizontal_Line (Line_Symbol => Blank2,
145 Line_Size => Integer (lr.x - ul.x) + 1);
146 Move_Cursor (Line => ul.y, Column => ul.x - 1);
147 Vertical_Line (Line_Symbol => Blank2,
148 Line_Size => Integer (lr.y - ul.y) + 1);
149 Move_Cursor (Line => lr.y + 1, Column => ul.x);
150 Horizontal_Line (Line_Symbol => Blank2,
151 Line_Size => Integer (lr.x - ul.x) + 1);
152 Move_Cursor (Line => ul.y, Column => lr.x + 1);
153 Vertical_Line (Line_Symbol => Blank2,
154 Line_Size => Integer (lr.y - ul.y) + 1);
158 function HaveKeyPad (w : Window) return Boolean is
160 return Get_KeyPad_Mode (w);
162 when Curses_Exception => return False;
165 function HaveScroll (w : Window) return Boolean is
167 return Scrolling_Allowed (w);
169 when Curses_Exception => return False;
172 procedure newwin_legend (curpw : Window) is
174 package p is new genericPuts (200);
178 type string_a is access String;
182 code : Integer range 0 .. 3;
185 legend : constant array (Positive range <>) of rrr :=
188 new String'("^C = create window"), 0
191 new String'("^N = next window"), 0
194 new String'("^P = previous window"), 0
197 new String'("^F = scroll forward"), 0
200 new String'("^B = scroll backward"), 0
203 new String'("^K = keypad(%s)"), 1
206 new String'("^S = scrollok(%s)"), 2
209 new String'("^W = save window to file"), 0
212 new String'("^R = restore window"), 0
215 new String'("^X = resize"), 0
218 new String'("^Q%s = exit"), 3
222 buf : Bounded_String;
223 do_keypad : constant Boolean := HaveKeyPad (curpw);
224 do_scroll : constant Boolean := HaveScroll (curpw);
231 Move_Cursor (Line => Lines - 4, Column => 0);
232 for n in legend'Range loop
233 pos := Ada.Strings.Fixed.Index (Source => legend (n).msg.all,
235 buf := To_Bounded_String (legend (n).msg.all);
236 case legend (n).code is
240 Replace_Slice (buf, pos, pos + 1, "yes");
242 Replace_Slice (buf, pos, pos + 1, "no");
246 Replace_Slice (buf, pos, pos + 1, "yes");
248 Replace_Slice (buf, pos, pos + 1, "no");
252 Replace_Slice (buf, pos, pos + 1, "/ESC");
254 Replace_Slice (buf, pos, pos + 1, "");
257 Get_Cursor_Position (Line => mypair.y, Column => mypair.x);
258 if Columns < mypair.x + 3 + Column_Position (Length (buf)) then
260 elsif n /= 1 then -- n /= legen'First
265 Clear_To_End_Of_Line;
268 procedure transient (curpw : Window; msg : String) is
270 newwin_legend (curpw);
272 Add (Line => Lines - 1, Column => 0, Str => msg);
274 Nap_Milli_Seconds (1000);
277 Move_Cursor (Line => Lines - 1, Column => 0);
279 if HaveKeyPad (curpw) then
280 Add (Str => "Non-arrow");
282 Add (Str => "All other");
284 Add (Str => " characters are echoed, window should ");
285 if not HaveScroll (curpw) then
288 Add (Str => "scroll");
290 Clear_To_End_Of_Line;
293 procedure newwin_report (win : Window := Standard_Window) is
297 tmp2a : String (1 .. 2);
298 tmp2b : String (1 .. 2);
300 if win /= Standard_Window then
303 Get_Cursor_Position (win, y, x);
304 Move_Cursor (Line => Lines - 1, Column => Columns - 17);
305 Put (tmp2a, Integer (y));
306 Put (tmp2b, Integer (x));
307 Add (Str => "Y = " & tmp2a & " X = " & tmp2b);
308 if win /= Standard_Window then
311 Move_Cursor (win, y, x);
315 procedure selectcell (uli : Line_Position;
316 ulj : Column_Position;
318 lrj : Column_Position;
323 i : Line_Position := 0;
324 j : Column_Position := 0;
325 si : constant Line_Position := lri - uli + 1;
326 sj : constant Column_Position := lrj - ulj + 1;
331 Move_Cursor (Line => uli + i, Column => ulj + j);
339 -- on the same line macro calls interfere due to the # comment
340 -- this is needed because keypad off affects all windows.
341 -- try removing the ESCAPE and see what happens.
346 -- same as i := i - 1 because of Modulus arithmetic,
347 -- on Line_Position, which is a Natural
348 -- the C version uses this form too, interestingly.
360 Button : Mouse_Button;
361 State : Button_State;
365 Get_Event (Event => event,
370 if y > uli and x > ulj then
373 -- same as when others =>
395 function getwindow return Window is
400 Move_Cursor (Line => 0, Column => 0);
401 Clear_To_End_Of_Line;
402 Add (Str => "Use arrows to move cursor, anything else to mark corner 1");
404 selectcell (2, 1, Lines - Botlines - 2, Columns - 2, ul, result);
408 Add (Line => ul.y - 1, Column => ul.x - 1,
409 Ch => ACS_Map (ACS_Upper_Left_Corner));
410 Move_Cursor (Line => 0, Column => 0);
411 Clear_To_End_Of_Line;
412 Add (Str => "Use arrows to move cursor, anything else to mark corner 2");
414 selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, lr, result);
419 rwindow := Sub_Window (Number_Of_Lines => lr.y - ul.y + 1,
420 Number_Of_Columns => lr.x - ul.x + 1,
421 First_Line_Position => ul.y,
422 First_Column_Position => ul.x);
424 Outerbox (ul, lr, True);
429 Move_Cursor (Line => 0, Column => 0);
430 Clear_To_End_Of_Line;
434 procedure newwin_move (win : Window;
436 dx : Column_Position) is
437 cur_y, max_y : Line_Position;
438 cur_x, max_x : Column_Position;
440 Get_Cursor_Position (win, cur_y, cur_x);
441 Get_Size (win, max_y, max_x);
442 cur_x := Column_Position'Min (Column_Position'Max (cur_x + dx, 0),
444 cur_y := Line_Position'Min (Line_Position'Max (cur_y + dy, 0),
447 Move_Cursor (win, Line => cur_y, Column => cur_x);
450 function delete_framed (fp : FrameA; showit : Boolean) return FrameA is
453 fp.all.last.all.next := fp.all.next;
454 fp.all.next.all.last := fp.all.last;
458 Refresh (fp.all.wind);
460 Delete (fp.all.wind);
462 if fp = fp.all.next then
471 Mask : Event_Mask := No_Events;
478 Register_Reportable_Event (
482 Mask2 := Start_Mouse (Mask);
485 Set_Raw_Mode (SwitchOn => True);
487 transient (Standard_Window, "");
489 when Character'Pos ('c') mod 16#20# => -- Ctrl('c')
491 neww : constant FrameA := new Frame'(null, null,
495 neww.all.wind := getwindow;
496 if neww.all.wind = Null_Window then
498 -- was goto breakout; ha ha ha
501 if current = null then
502 neww.all.next := neww;
503 neww.all.last := neww;
505 neww.all.next := current.all.next;
506 neww.all.last := current;
507 neww.all.last.all.next := neww;
508 neww.all.next.all.last := neww;
512 Set_KeyPad_Mode (current.all.wind, True);
513 current.all.do_keypad := HaveKeyPad (current.all.wind);
514 current.all.do_scroll := HaveScroll (current.all.wind);
517 when Character'Pos ('N') mod 16#20# => -- Ctrl('N')
518 if current /= null then
519 current := current.all.next;
521 when Character'Pos ('P') mod 16#20# => -- Ctrl('P')
522 if current /= null then
523 current := current.all.last;
525 when Character'Pos ('F') mod 16#20# => -- Ctrl('F')
526 if current /= null and then HaveScroll (current.all.wind) then
527 Scroll (current.all.wind, 1);
529 when Character'Pos ('B') mod 16#20# => -- Ctrl('B')
530 if current /= null and then HaveScroll (current.all.wind) then
531 -- The C version of Scroll may return ERR which is ignored
532 -- we need to avoid the exception
533 -- with the 'and HaveScroll(current.wind)'
534 Scroll (current.all.wind, -1);
536 when Character'Pos ('K') mod 16#20# => -- Ctrl('K')
537 if current /= null then
538 current.all.do_keypad := not current.all.do_keypad;
539 Set_KeyPad_Mode (current.all.wind, current.all.do_keypad);
541 when Character'Pos ('S') mod 16#20# => -- Ctrl('S')
542 if current /= null then
543 current.all.do_scroll := not current.all.do_scroll;
544 Allow_Scrolling (current.all.wind, current.all.do_scroll);
546 when Character'Pos ('W') mod 16#20# => -- Ctrl('W')
547 if current /= current.all.next then
548 Create (f, Name => dumpfile); -- TODO error checking
549 if not Is_Open (f) then
550 raise Curses_Exception;
552 Put_Window (current.all.wind, f);
554 current := delete_framed (current, True);
556 when Character'Pos ('R') mod 16#20# => -- Ctrl('R')
558 neww : FrameA := new Frame'(null, null, False, False,
561 Open (f, Mode => In_File, Name => dumpfile);
562 neww := new Frame'(null, null, False, False, Null_Window);
564 neww.all.next := current.all.next;
565 neww.all.last := current;
566 neww.all.last.all.next := neww;
567 neww.all.next.all.last := neww;
569 neww.all.wind := Get_Window (f);
572 Refresh (neww.all.wind);
574 when Character'Pos ('X') mod 16#20# => -- Ctrl('X')
575 if current /= null then
578 mx : Column_Position;
582 Move_Cursor (Line => 0, Column => 0);
583 Clear_To_End_Of_Line;
584 Add (Str => "Use arrows to move cursor, anything else " &
585 "to mark new corner");
588 Get_Window_Position (current.all.wind, ul.y, ul.x);
590 selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2,
593 -- the C version had a goto. I refuse gotos.
596 Get_Size (current.all.wind, lr.y, lr.x);
597 lr.y := lr.y + ul.y - 1;
598 lr.x := lr.x + ul.x - 1;
599 Outerbox (ul, lr, False);
600 Refresh_Without_Update;
602 Get_Size (current.all.wind, my, mx);
603 if my > tmp.y - ul.y then
604 Get_Cursor_Position (current.all.wind, lr.y, lr.x);
605 Move_Cursor (current.all.wind, tmp.y - ul.y + 1, 0);
606 Clear_To_End_Of_Screen (current.all.wind);
607 Move_Cursor (current.all.wind, lr.y, lr.x);
609 if mx > tmp.x - ul.x then
610 for i in 0 .. my - 1 loop
611 Move_Cursor (current.all.wind, i, tmp.x - ul.x + 1);
612 Clear_To_End_Of_Line (current.all.wind);
615 Refresh_Without_Update (current.all.wind);
618 -- The C version passes invalid args to resize
619 -- which returns an ERR. For Ada we avoid the exception.
620 if lr.y /= ul.y and lr.x /= ul.x then
621 Resize (current.all.wind, lr.y - ul.y + 0,
625 Get_Window_Position (current.all.wind, ul.y, ul.x);
626 Get_Size (current.all.wind, lr.y, lr.x);
627 lr.y := lr.y + ul.y - 1;
628 lr.x := lr.x + ul.x - 1;
629 Outerbox (ul, lr, True);
630 Refresh_Without_Update;
632 Refresh_Without_Update (current.all.wind);
633 Move_Cursor (Line => 0, Column => 0);
634 Clear_To_End_Of_Line;
640 declare tmp : pair; tmpbool : Boolean;
642 -- undocumented --- use this to test area clears
643 selectcell (0, 0, Lines - 1, Columns - 1, tmp, tmpbool);
644 Clear_To_End_Of_Screen;
647 when Key_Cursor_Up =>
648 newwin_move (current.all.wind, -1, 0);
649 when Key_Cursor_Down =>
650 newwin_move (current.all.wind, 1, 0);
651 when Key_Cursor_Left =>
652 newwin_move (current.all.wind, 0, -1);
653 when Key_Cursor_Right =>
654 newwin_move (current.all.wind, 0, 1);
655 when Key_Backspace | Key_Delete_Char =>
661 Get_Cursor_Position (current.all.wind, y, x);
663 -- I got tricked by the -1 = Max_Natural - 1 result
665 if not (x = 0 and y = 0) then
668 Get_Size (current.all.wind, tmp, x);
671 Delete_Character (current.all.wind, y, x);
676 if current /= null then
679 Add (current.all.wind, Ch => Code_To_Char (c));
681 when Curses_Exception => null;
682 -- this happens if we are at the
683 -- lower right of a window and add a character.
689 newwin_report (current.all.wind);
690 if current /= null then
691 usescr := current.all.wind;
693 usescr := Standard_Window;
696 c := Getchar (usescr);
697 exit when c = Quit or (c = Escape and HaveKeyPad (usescr));
698 -- TODO when does c = ERR happen?
701 -- TODO while current /= null loop
702 -- current := delete_framed(current, False);
705 Allow_Scrolling (Mode => True);
708 Set_Raw_Mode (SwitchOn => True);
712 end ncurses2.acs_and_scroll;