1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000 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 -- Binding Version 01.00
40 ------------------------------------------------------------------------------
41 -- Windows and scrolling tester.
42 -- Demonstrate windows
44 with Ada.Strings.Fixed;
47 with ncurses2.util; use ncurses2.util;
48 with ncurses2.genericPuts;
49 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
50 with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
51 with Terminal_Interface.Curses.PutWin; use Terminal_Interface.Curses.PutWin;
53 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
54 with Ada.Streams; use Ada.Streams;
56 procedure ncurses2.acs_and_scroll is
59 Macro_Quit : constant Key_Code := Character'Pos ('Q') mod 16#20#;
60 Macro_Escape : constant Key_Code := Character'Pos ('[') mod 16#20#;
62 Quit : constant Key_Code := CTRL ('Q');
63 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;
97 use Ada.Streams.Stream_IO;
101 -- I wish there was a standard library linked list. Oh well.
113 procedure Outerbox (ul, lr : pair; onoff : Boolean) is
116 -- Note the fix of an obscure bug
117 -- try making a 1x1 box then enlarging it, the is a blank
118 -- upper left corner!
119 Add (Line => ul.y - 1, Column => ul.x - 1,
120 Ch => ACS_Map (ACS_Upper_Left_Corner));
121 Add (Line => ul.y - 1, Column => lr.x + 1,
122 Ch => ACS_Map (ACS_Upper_Right_Corner));
123 Add (Line => lr.y + 1, Column => lr.x + 1,
124 Ch => ACS_Map (ACS_Lower_Right_Corner));
125 Add (Line => lr.y + 1, Column => ul.x - 1,
126 Ch => ACS_Map (ACS_Lower_Left_Corner));
128 Move_Cursor (Line => ul.y - 1, Column => ul.x);
129 Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
130 Line_Size => Integer (lr.x - ul.x) + 1);
131 Move_Cursor (Line => ul.y, Column => ul.x - 1);
132 Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
133 Line_Size => Integer (lr.y - ul.y) + 1);
134 Move_Cursor (Line => lr.y + 1, Column => ul.x);
135 Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
136 Line_Size => Integer (lr.x - ul.x) + 1);
137 Move_Cursor (Line => ul.y, Column => lr.x + 1);
138 Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
139 Line_Size => Integer (lr.y - ul.y) + 1);
141 Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ' ');
142 Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ' ');
143 Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ' ');
144 Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ' ');
146 Move_Cursor (Line => ul.y - 1, Column => ul.x);
147 Horizontal_Line (Line_Symbol => Blank2,
148 Line_Size => Integer (lr.x - ul.x) + 1);
149 Move_Cursor (Line => ul.y, Column => ul.x - 1);
150 Vertical_Line (Line_Symbol => Blank2,
151 Line_Size => Integer (lr.y - ul.y) + 1);
152 Move_Cursor (Line => lr.y + 1, Column => ul.x);
153 Horizontal_Line (Line_Symbol => Blank2,
154 Line_Size => Integer (lr.x - ul.x) + 1);
155 Move_Cursor (Line => ul.y, Column => lr.x + 1);
156 Vertical_Line (Line_Symbol => Blank2,
157 Line_Size => Integer (lr.y - ul.y) + 1);
161 function HaveKeyPad (w : Window) return Boolean is
163 return Get_KeyPad_Mode (w);
165 when Curses_Exception => return False;
168 function HaveScroll (w : Window) return Boolean is
170 return Scrolling_Allowed (w);
172 when Curses_Exception => return False;
176 procedure newwin_legend (curpw : Window) is
178 package p is new genericPuts (200);
182 type string_a is access String;
186 code : Integer range 0 .. 3;
189 legend : constant array (Positive range <>) of rrr :=
192 new String'("^C = create window"), 0
195 new String'("^N = next window"), 0
198 new String'("^P = previous window"), 0
201 new String'("^F = scroll forward"), 0
204 new String'("^B = scroll backward"), 0
207 new String'("^K = keypad(%s)"), 1
210 new String'("^S = scrollok(%s)"), 2
213 new String'("^W = save window to file"), 0
216 new String'("^R = restore window"), 0
219 new String'("^X = resize"), 0
222 new String'("^Q%s = exit"), 3
226 buf : Bounded_String;
227 do_keypad : Boolean := HaveKeyPad (curpw);
228 do_scroll : Boolean := HaveScroll (curpw);
234 use Ada.Strings.Fixed;
237 Move_Cursor (Line => Lines - 4, Column => 0);
238 for n in legend'Range loop
239 pos := Ada.Strings.Fixed.Index (Source => legend (n).msg.all,
241 -- buf := (others => ' ');
242 buf := To_Bounded_String (legend (n).msg.all);
243 case legend (n).code is
247 Replace_Slice (buf, pos, pos + 1, "yes");
249 Replace_Slice (buf, pos, pos + 1, "no");
253 Replace_Slice (buf, pos, pos + 1, "yes");
255 Replace_Slice (buf, pos, pos + 1, "no");
259 Replace_Slice (buf, pos, pos + 1, "/ESC");
261 Replace_Slice (buf, pos, pos + 1, "");
264 Get_Cursor_Position (Line => mypair.y, Column => mypair.x);
265 if Columns < mypair.x + 3 + Column_Position (Length (buf)) then
267 elsif n /= 1 then -- n /= legen'First
272 Clear_To_End_Of_Line;
276 procedure transient (curpw : Window; msg : String) is
278 newwin_legend (curpw);
280 Add (Line => Lines - 1, Column => 0, Str => msg);
282 Nap_Milli_Seconds (1000);
285 Move_Cursor (Line => Lines - 1, Column => 0);
287 if HaveKeyPad (curpw) then
288 Add (Str => "Non-arrow");
290 Add (Str => "All other");
292 Add (str => " characters are echoed, window should ");
293 if not HaveScroll (curpw) then
296 Add (str => "scroll");
298 Clear_To_End_Of_Line;
302 procedure newwin_report (win : Window := Standard_Window) is
306 tmp2a : String (1 .. 2);
307 tmp2b : String (1 .. 2);
309 if win /= Standard_Window then
312 Get_Cursor_Position (win, y, x);
313 Move_Cursor (Line => Lines - 1, Column => Columns - 17);
314 Put (tmp2a, Integer (y));
315 Put (tmp2b, Integer (x));
316 Add (Str => "Y = " & tmp2a & " X = " & tmp2b);
317 if win /= Standard_Window then
320 Move_Cursor (win, y, x);
324 procedure selectcell (uli : Line_Position;
325 ulj : Column_Position;
327 lrj : Column_Position;
332 i : Line_Position := 0;
333 j : Column_Position := 0;
334 si : Line_Position := lri - uli + 1;
335 sj : Column_Position := lrj - ulj + 1;
340 Move_Cursor (Line => uli + i, Column => ulj + j);
348 -- on the same line macro calls interfere due to the # comment
349 -- this is needed because keypad off affects all windows.
350 -- try removing the ESCAPE and see what happens.
355 -- same as i := i - 1 because of Modulus arithetic,
356 -- on Line_Position, which is a Natural
357 -- the C version uses this form too, interestingly.
369 Button : Mouse_Button;
370 State : Button_State;
374 Get_Event (Event => event,
379 if y > uli and x > ulj then
382 -- same as when others =>
405 function getwindow return Window is
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 1");
414 selectcell (2, 1, Lines - Botlines - 2, Columns - 2, ul, result);
418 Add (Line => ul.y - 1, Column => ul.x - 1,
419 Ch => ACS_Map (ACS_Upper_Left_Corner));
420 Move_Cursor (Line => 0, Column => 0);
421 Clear_To_End_Of_Line;
422 Add (Str => "Use arrows to move cursor, anything else to mark corner 2");
424 selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, lr, result);
429 rwindow := Sub_Window (Number_Of_Lines => lr.y - ul.y + 1,
430 Number_Of_Columns => lr.x - ul.x + 1,
431 First_Line_Position => ul.y,
432 First_Column_Position => ul.x);
434 Outerbox (ul, lr, True);
439 Move_Cursor (Line => 0, Column => 0);
440 Clear_To_End_Of_Line;
445 procedure newwin_move (win : Window;
447 dx : Column_Position) is
448 cur_y, max_y : Line_Position;
449 cur_x, max_x : Column_Position;
451 Get_Cursor_Position (win, cur_y, cur_x);
452 Get_Size (win, max_y, max_x);
453 cur_x := Column_Position'Min (Column_Position'Max (cur_x + dx, 0),
455 cur_y := Line_Position'Min (Line_Position'Max (cur_y + dy, 0),
458 Move_Cursor (win, Line => cur_y, Column => cur_x);
461 function delete_framed (fp : FrameA; showit : Boolean) return FrameA is
464 fp.last.next := fp.next;
465 fp.next.last := fp.last;
482 Mask : Event_Mask := No_Events;
489 Register_Reportable_Event (
493 Mask2 := Start_Mouse (Mask);
496 Set_Raw_Mode (SwitchOn => True);
498 transient (Standard_Window, "");
500 when Character'Pos ('c') mod 16#20# => -- Ctrl('c')
502 neww : FrameA := new Frame'(null, null, False, False,
505 neww.wind := getwindow;
506 if neww.wind = Null_Window then
508 -- was goto breakout; ha ha ha
511 if current = null then
515 neww.next := current.next;
516 neww.last := current;
517 neww.last.next := neww;
518 neww.next.last := neww;
522 Set_KeyPad_Mode (current.wind, True);
523 current.do_keypad := HaveKeyPad (current.wind);
524 current.do_scroll := HaveScroll (current.wind);
527 when Character'Pos ('N') mod 16#20# => -- Ctrl('N')
528 if current /= null then
529 current := current.next;
531 when Character'Pos ('P') mod 16#20# => -- Ctrl('P')
532 if current /= null then
533 current := current.last;
535 when Character'Pos ('F') mod 16#20# => -- Ctrl('F')
536 if current /= null and HaveScroll (current.wind) then
537 Scroll (current.wind, 1);
539 when Character'Pos ('B') mod 16#20# => -- Ctrl('B')
540 if current /= null and HaveScroll (current.wind) then
541 -- The C version of Scroll may return ERR which is ignored
542 -- we need to avoid the exception
543 -- with the 'and HaveScroll(current.wind)'
544 Scroll (current.wind, -1);
546 when Character'Pos ('K') mod 16#20# => -- Ctrl('K')
547 if current /= null then
548 current.do_keypad := not current.do_keypad;
549 Set_KeyPad_Mode (current.wind, current.do_keypad);
551 when Character'Pos ('S') mod 16#20# => -- Ctrl('S')
552 if current /= null then
553 current.do_scroll := not current.do_scroll;
554 Allow_Scrolling (current.wind, current.do_scroll);
556 when Character'Pos ('W') mod 16#20# => -- Ctrl('W')
557 if current /= current.next then
558 Create (f, Name => dumpfile); -- TODO error checking
559 if not Is_Open (f) then
560 raise Curses_Exception;
562 Put_Window (current.wind, f);
564 current := delete_framed (current, True);
566 when Character'Pos ('R') mod 16#20# => -- Ctrl('R')
568 neww : FrameA := new Frame'(null, null, False, False,
571 Open (f, Mode => In_File, Name => dumpfile);
572 neww := new Frame'(null, null, False, False, Null_Window);
574 neww.next := current.next;
575 neww.last := current;
576 neww.last.next := neww;
577 neww.next.last := neww;
579 neww.wind := Get_Window (f);
584 when Character'Pos ('X') mod 16#20# => -- Ctrl('X')
585 if current /= null then
588 mx : Column_Position;
592 Move_Cursor (Line => 0, Column => 0);
593 Clear_To_End_Of_Line;
594 Add (Str => "Use arrows to move cursor, anything else " &
595 "to mark new corner");
598 Get_Window_Position (current.wind, ul.y, ul.x);
600 selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2,
603 -- the C version had a goto. I refuse gotos.
606 Get_Size (current.wind, lr.y, lr.x);
607 lr.y := lr.y + ul.y - 1;
608 lr.x := lr.x + ul.x - 1;
609 Outerbox (ul, lr, False);
610 Refresh_Without_Update;
612 Get_Size (current.wind, my, mx);
613 if my > tmp.y - ul.y then
614 Get_Cursor_Position (current.wind, lr.y, lr.x);
615 Move_Cursor (current.wind, tmp.y - ul.y + 1, 0);
616 Clear_To_End_Of_Screen (current.wind);
617 Move_Cursor (current.wind, lr.y, lr.x);
619 if mx > tmp.x - ul.x then
620 for i in 0 .. my - 1 loop
621 Move_Cursor (current.wind, i, tmp.x - ul.x + 1);
622 Clear_To_End_Of_Line (current.wind);
625 Refresh_Without_Update (current.wind);
628 -- The C version passes invalid args to resize
629 -- which returns an ERR. For Ada we avoid the exception.
630 if lr.y /= ul.y and lr.x /= ul.x then
631 Resize (current.wind, lr.y - ul.y + 0,
635 Get_Window_Position (current.wind, ul.y, ul.x);
636 Get_Size (current.wind, lr.y, lr.x);
637 lr.y := lr.y + ul.y - 1;
638 lr.x := lr.x + ul.x - 1;
639 Outerbox (ul, lr, True);
640 Refresh_Without_Update;
642 Refresh_Without_Update (current.wind);
643 Move_Cursor (Line => 0, Column => 0);
644 Clear_To_End_Of_Line;
650 declare tmp : pair; tmpbool : Boolean;
652 -- undocumented --- use this to test area clears
653 selectcell (0, 0, Lines - 1, Columns - 1, tmp, tmpbool);
654 Clear_To_End_Of_Screen;
657 when Key_Cursor_Up =>
658 newwin_move (current.wind, -1, 0);
659 when Key_Cursor_Down =>
660 newwin_move (current.wind, 1, 0);
661 when Key_Cursor_Left =>
662 newwin_move (current.wind, 0, -1);
663 when Key_Cursor_Right =>
664 newwin_move (current.wind, 0, 1);
665 when Key_Backspace | Key_Delete_Char =>
671 Get_Cursor_Position (current.wind, y, x);
673 -- I got tricked by the -1 = Max_Natural - 1 result
675 if not (x = 0 and y = 0) then
678 Get_Size (current.wind, tmp, x);
681 Delete_Character (current.wind, y, x);
686 if current /= null then
689 Add (current.wind, Ch => Code_To_Char (c));
691 when Curses_Exception => null;
692 -- this happens if we are at the
693 -- lower right of a window and add a character.
699 newwin_report (current.wind);
700 if current /= null then
701 usescr := current.wind;
703 usescr := Standard_Window;
706 c := Getchar (usescr);
707 exit when c = Quit or (c = Escape and HaveKeyPad (usescr));
708 -- TODO when does c = ERR happen?
711 -- TODO while current /= null loop
712 -- current := delete_framed(current, False);
715 Allow_Scrolling (Mode => True);
718 Set_Raw_Mode (SwitchOn => True);
722 end ncurses2.acs_and_scroll;