------------------------------------------------------------------------------ -- -- -- GNAT ncurses Binding Samples -- -- -- -- ncurses -- -- -- -- B O D Y -- -- -- ------------------------------------------------------------------------------ -- Copyright (c) 2000-2009,2011 Free Software Foundation, Inc. -- -- -- -- Permission is hereby granted, free of charge, to any person obtaining a -- -- copy of this software and associated documentation files (the -- -- "Software"), to deal in the Software without restriction, including -- -- without limitation the rights to use, copy, modify, merge, publish, -- -- distribute, distribute with modifications, sublicense, and/or sell -- -- copies of the Software, and to permit persons to whom the Software is -- -- furnished to do so, subject to the following conditions: -- -- -- -- The above copyright notice and this permission notice shall be included -- -- in all copies or substantial portions of the Software. -- -- -- -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- -- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- -- -- -- Except as contained in this notice, the name(s) of the above copyright -- -- holders shall not be used in advertising or otherwise to promote the -- -- sale, use or other dealings in this Software without prior written -- -- authorization. -- ------------------------------------------------------------------------------ -- Author: Eugene V. Melaragno 2000 -- Version Control -- $Revision: 1.10 $ -- $Date: 2011/03/19 12:16:44 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ -- Windows and scrolling tester. -- Demonstrate windows with Ada.Strings.Fixed; with Ada.Strings; with ncurses2.util; use ncurses2.util; with ncurses2.genericPuts; with Terminal_Interface.Curses; use Terminal_Interface.Curses; with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse; with Terminal_Interface.Curses.PutWin; use Terminal_Interface.Curses.PutWin; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Streams; use Ada.Streams; procedure ncurses2.acs_and_scroll is Macro_Quit : constant Key_Code := Character'Pos ('Q') mod 16#20#; Macro_Escape : constant Key_Code := Character'Pos ('[') mod 16#20#; Quit : constant Key_Code := CTRL ('Q'); Escape : constant Key_Code := CTRL ('['); Botlines : constant Line_Position := 4; type pair is record y : Line_Position; x : Column_Position; end record; type Frame; type FrameA is access Frame; f : File_Type; dumpfile : constant String := "screendump"; procedure Outerbox (ul, lr : pair; onoff : Boolean); function HaveKeyPad (w : Window) return Boolean; function HaveScroll (w : Window) return Boolean; procedure newwin_legend (curpw : Window); procedure transient (curpw : Window; msg : String); procedure newwin_report (win : Window := Standard_Window); procedure selectcell (uli : Line_Position; ulj : Column_Position; lri : Line_Position; lrj : Column_Position; p : out pair; b : out Boolean); function getwindow return Window; procedure newwin_move (win : Window; dy : Line_Position; dx : Column_Position); function delete_framed (fp : FrameA; showit : Boolean) return FrameA; -- A linked list -- I wish there was a standard library linked list. Oh well. type Frame is record next, last : FrameA; do_scroll : Boolean; do_keypad : Boolean; wind : Window; end record; current : FrameA; c : Key_Code; procedure Outerbox (ul, lr : pair; onoff : Boolean) is begin if onoff then -- Note the fix of an obscure bug -- try making a 1x1 box then enlarging it, the is a blank -- upper left corner! Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ACS_Map (ACS_Upper_Left_Corner)); Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ACS_Map (ACS_Upper_Right_Corner)); Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ACS_Map (ACS_Lower_Right_Corner)); Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ACS_Map (ACS_Lower_Left_Corner)); Move_Cursor (Line => ul.y - 1, Column => ul.x); Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line), Line_Size => Integer (lr.x - ul.x) + 1); Move_Cursor (Line => ul.y, Column => ul.x - 1); Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line), Line_Size => Integer (lr.y - ul.y) + 1); Move_Cursor (Line => lr.y + 1, Column => ul.x); Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line), Line_Size => Integer (lr.x - ul.x) + 1); Move_Cursor (Line => ul.y, Column => lr.x + 1); Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line), Line_Size => Integer (lr.y - ul.y) + 1); else Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ' '); Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ' '); Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ' '); Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ' '); Move_Cursor (Line => ul.y - 1, Column => ul.x); Horizontal_Line (Line_Symbol => Blank2, Line_Size => Integer (lr.x - ul.x) + 1); Move_Cursor (Line => ul.y, Column => ul.x - 1); Vertical_Line (Line_Symbol => Blank2, Line_Size => Integer (lr.y - ul.y) + 1); Move_Cursor (Line => lr.y + 1, Column => ul.x); Horizontal_Line (Line_Symbol => Blank2, Line_Size => Integer (lr.x - ul.x) + 1); Move_Cursor (Line => ul.y, Column => lr.x + 1); Vertical_Line (Line_Symbol => Blank2, Line_Size => Integer (lr.y - ul.y) + 1); end if; end Outerbox; function HaveKeyPad (w : Window) return Boolean is begin return Get_KeyPad_Mode (w); exception when Curses_Exception => return False; end HaveKeyPad; function HaveScroll (w : Window) return Boolean is begin return Scrolling_Allowed (w); exception when Curses_Exception => return False; end HaveScroll; procedure newwin_legend (curpw : Window) is package p is new genericPuts (200); use p; use p.BS; type string_a is access String; type rrr is record msg : string_a; code : Integer range 0 .. 3; end record; legend : constant array (Positive range <>) of rrr := ( ( new String'("^C = create window"), 0 ), ( new String'("^N = next window"), 0 ), ( new String'("^P = previous window"), 0 ), ( new String'("^F = scroll forward"), 0 ), ( new String'("^B = scroll backward"), 0 ), ( new String'("^K = keypad(%s)"), 1 ), ( new String'("^S = scrollok(%s)"), 2 ), ( new String'("^W = save window to file"), 0 ), ( new String'("^R = restore window"), 0 ), ( new String'("^X = resize"), 0 ), ( new String'("^Q%s = exit"), 3 ) ); buf : Bounded_String; do_keypad : constant Boolean := HaveKeyPad (curpw); do_scroll : constant Boolean := HaveScroll (curpw); pos : Natural; mypair : pair; use Ada.Strings.Fixed; begin Move_Cursor (Line => Lines - 4, Column => 0); for n in legend'Range loop pos := Ada.Strings.Fixed.Index (Source => legend (n).msg.all, Pattern => "%s"); -- buf := (others => ' '); buf := To_Bounded_String (legend (n).msg.all); case legend (n).code is when 0 => null; when 1 => if do_keypad then Replace_Slice (buf, pos, pos + 1, "yes"); else Replace_Slice (buf, pos, pos + 1, "no"); end if; when 2 => if do_scroll then Replace_Slice (buf, pos, pos + 1, "yes"); else Replace_Slice (buf, pos, pos + 1, "no"); end if; when 3 => if do_keypad then Replace_Slice (buf, pos, pos + 1, "/ESC"); else Replace_Slice (buf, pos, pos + 1, ""); end if; end case; Get_Cursor_Position (Line => mypair.y, Column => mypair.x); if Columns < mypair.x + 3 + Column_Position (Length (buf)) then Add (Ch => newl); elsif n /= 1 then -- n /= legen'First Add (Str => ", "); end if; myAdd (Str => buf); end loop; Clear_To_End_Of_Line; end newwin_legend; procedure transient (curpw : Window; msg : String) is begin newwin_legend (curpw); if msg /= "" then Add (Line => Lines - 1, Column => 0, Str => msg); Refresh; Nap_Milli_Seconds (1000); end if; Move_Cursor (Line => Lines - 1, Column => 0); if HaveKeyPad (curpw) then Add (Str => "Non-arrow"); else Add (Str => "All other"); end if; Add (Str => " characters are echoed, window should "); if not HaveScroll (curpw) then Add (Str => "not "); end if; Add (Str => "scroll"); Clear_To_End_Of_Line; end transient; procedure newwin_report (win : Window := Standard_Window) is y : Line_Position; x : Column_Position; use Int_IO; tmp2a : String (1 .. 2); tmp2b : String (1 .. 2); begin if win /= Standard_Window then transient (win, ""); end if; Get_Cursor_Position (win, y, x); Move_Cursor (Line => Lines - 1, Column => Columns - 17); Put (tmp2a, Integer (y)); Put (tmp2b, Integer (x)); Add (Str => "Y = " & tmp2a & " X = " & tmp2b); if win /= Standard_Window then Refresh; else Move_Cursor (win, y, x); end if; end newwin_report; procedure selectcell (uli : Line_Position; ulj : Column_Position; lri : Line_Position; lrj : Column_Position; p : out pair; b : out Boolean) is c : Key_Code; res : pair; i : Line_Position := 0; j : Column_Position := 0; si : constant Line_Position := lri - uli + 1; sj : constant Column_Position := lrj - ulj + 1; begin res.y := uli; res.x := ulj; loop Move_Cursor (Line => uli + i, Column => ulj + j); newwin_report; c := Getchar; case c is when Macro_Quit | Macro_Escape => -- on the same line macro calls interfere due to the # comment -- this is needed because keypad off affects all windows. -- try removing the ESCAPE and see what happens. b := False; return; when KEY_UP => i := i + si - 1; -- same as i := i - 1 because of Modulus arithmetic, -- on Line_Position, which is a Natural -- the C version uses this form too, interestingly. when KEY_DOWN => i := i + 1; when KEY_LEFT => j := j + sj - 1; when KEY_RIGHT => j := j + 1; when Key_Mouse => declare event : Mouse_Event; y : Line_Position; x : Column_Position; Button : Mouse_Button; State : Button_State; begin event := Get_Mouse; Get_Event (Event => event, Y => y, X => x, Button => Button, State => State); if y > uli and x > ulj then i := y - uli; j := x - ulj; -- same as when others => res.y := uli + i; res.x := ulj + j; p := res; b := True; return; else Beep; end if; end; when others => res.y := uli + i; res.x := ulj + j; p := res; b := True; return; end case; i := i mod si; j := j mod sj; end loop; end selectcell; function getwindow return Window is rwindow : Window; ul, lr : pair; result : Boolean; begin Move_Cursor (Line => 0, Column => 0); Clear_To_End_Of_Line; Add (Str => "Use arrows to move cursor, anything else to mark corner 1"); Refresh; selectcell (2, 1, Lines - Botlines - 2, Columns - 2, ul, result); if not result then return Null_Window; end if; Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ACS_Map (ACS_Upper_Left_Corner)); Move_Cursor (Line => 0, Column => 0); Clear_To_End_Of_Line; Add (Str => "Use arrows to move cursor, anything else to mark corner 2"); Refresh; selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, lr, result); if not result then return Null_Window; end if; rwindow := Sub_Window (Number_Of_Lines => lr.y - ul.y + 1, Number_Of_Columns => lr.x - ul.x + 1, First_Line_Position => ul.y, First_Column_Position => ul.x); Outerbox (ul, lr, True); Refresh; Refresh (rwindow); Move_Cursor (Line => 0, Column => 0); Clear_To_End_Of_Line; return rwindow; end getwindow; procedure newwin_move (win : Window; dy : Line_Position; dx : Column_Position) is cur_y, max_y : Line_Position; cur_x, max_x : Column_Position; begin Get_Cursor_Position (win, cur_y, cur_x); Get_Size (win, max_y, max_x); cur_x := Column_Position'Min (Column_Position'Max (cur_x + dx, 0), max_x - 1); cur_y := Line_Position'Min (Line_Position'Max (cur_y + dy, 0), max_y - 1); Move_Cursor (win, Line => cur_y, Column => cur_x); end newwin_move; function delete_framed (fp : FrameA; showit : Boolean) return FrameA is np : FrameA; begin fp.last.next := fp.next; fp.next.last := fp.last; if showit then Erase (fp.wind); Refresh (fp.wind); end if; Delete (fp.wind); if fp = fp.next then np := null; else np := fp.next; end if; -- TODO free(fp); return np; end delete_framed; Mask : Event_Mask := No_Events; Mask2 : Event_Mask; usescr : Window; begin if Has_Mouse then Register_Reportable_Event ( Button => Left, State => Clicked, Mask => Mask); Mask2 := Start_Mouse (Mask); end if; c := CTRL ('C'); Set_Raw_Mode (SwitchOn => True); loop transient (Standard_Window, ""); case c is when Character'Pos ('c') mod 16#20# => -- Ctrl('c') declare neww : constant FrameA := new Frame'(null, null, False, False, Null_Window); begin neww.wind := getwindow; if neww.wind = Null_Window then exit; -- was goto breakout; ha ha ha else if current = null then neww.next := neww; neww.last := neww; else neww.next := current.next; neww.last := current; neww.last.next := neww; neww.next.last := neww; end if; current := neww; Set_KeyPad_Mode (current.wind, True); current.do_keypad := HaveKeyPad (current.wind); current.do_scroll := HaveScroll (current.wind); end if; end; when Character'Pos ('N') mod 16#20# => -- Ctrl('N') if current /= null then current := current.next; end if; when Character'Pos ('P') mod 16#20# => -- Ctrl('P') if current /= null then current := current.last; end if; when Character'Pos ('F') mod 16#20# => -- Ctrl('F') if current /= null and then HaveScroll (current.wind) then Scroll (current.wind, 1); end if; when Character'Pos ('B') mod 16#20# => -- Ctrl('B') if current /= null and then HaveScroll (current.wind) then -- The C version of Scroll may return ERR which is ignored -- we need to avoid the exception -- with the 'and HaveScroll(current.wind)' Scroll (current.wind, -1); end if; when Character'Pos ('K') mod 16#20# => -- Ctrl('K') if current /= null then current.do_keypad := not current.do_keypad; Set_KeyPad_Mode (current.wind, current.do_keypad); end if; when Character'Pos ('S') mod 16#20# => -- Ctrl('S') if current /= null then current.do_scroll := not current.do_scroll; Allow_Scrolling (current.wind, current.do_scroll); end if; when Character'Pos ('W') mod 16#20# => -- Ctrl('W') if current /= current.next then Create (f, Name => dumpfile); -- TODO error checking if not Is_Open (f) then raise Curses_Exception; end if; Put_Window (current.wind, f); Close (f); current := delete_framed (current, True); end if; when Character'Pos ('R') mod 16#20# => -- Ctrl('R') declare neww : FrameA := new Frame'(null, null, False, False, Null_Window); begin Open (f, Mode => In_File, Name => dumpfile); neww := new Frame'(null, null, False, False, Null_Window); neww.next := current.next; neww.last := current; neww.last.next := neww; neww.next.last := neww; neww.wind := Get_Window (f); Close (f); Refresh (neww.wind); end; when Character'Pos ('X') mod 16#20# => -- Ctrl('X') if current /= null then declare tmp, ul, lr : pair; mx : Column_Position; my : Line_Position; tmpbool : Boolean; begin Move_Cursor (Line => 0, Column => 0); Clear_To_End_Of_Line; Add (Str => "Use arrows to move cursor, anything else " & "to mark new corner"); Refresh; Get_Window_Position (current.wind, ul.y, ul.x); selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, tmp, tmpbool); if not tmpbool then -- the C version had a goto. I refuse gotos. Beep; else Get_Size (current.wind, lr.y, lr.x); lr.y := lr.y + ul.y - 1; lr.x := lr.x + ul.x - 1; Outerbox (ul, lr, False); Refresh_Without_Update; Get_Size (current.wind, my, mx); if my > tmp.y - ul.y then Get_Cursor_Position (current.wind, lr.y, lr.x); Move_Cursor (current.wind, tmp.y - ul.y + 1, 0); Clear_To_End_Of_Screen (current.wind); Move_Cursor (current.wind, lr.y, lr.x); end if; if mx > tmp.x - ul.x then for i in 0 .. my - 1 loop Move_Cursor (current.wind, i, tmp.x - ul.x + 1); Clear_To_End_Of_Line (current.wind); end loop; end if; Refresh_Without_Update (current.wind); lr := tmp; -- The C version passes invalid args to resize -- which returns an ERR. For Ada we avoid the exception. if lr.y /= ul.y and lr.x /= ul.x then Resize (current.wind, lr.y - ul.y + 0, lr.x - ul.x + 0); end if; Get_Window_Position (current.wind, ul.y, ul.x); Get_Size (current.wind, lr.y, lr.x); lr.y := lr.y + ul.y - 1; lr.x := lr.x + ul.x - 1; Outerbox (ul, lr, True); Refresh_Without_Update; Refresh_Without_Update (current.wind); Move_Cursor (Line => 0, Column => 0); Clear_To_End_Of_Line; Update_Screen; end if; end; end if; when Key_F10 => declare tmp : pair; tmpbool : Boolean; begin -- undocumented --- use this to test area clears selectcell (0, 0, Lines - 1, Columns - 1, tmp, tmpbool); Clear_To_End_Of_Screen; Refresh; end; when Key_Cursor_Up => newwin_move (current.wind, -1, 0); when Key_Cursor_Down => newwin_move (current.wind, 1, 0); when Key_Cursor_Left => newwin_move (current.wind, 0, -1); when Key_Cursor_Right => newwin_move (current.wind, 0, 1); when Key_Backspace | Key_Delete_Char => declare y : Line_Position; x : Column_Position; tmp : Line_Position; begin Get_Cursor_Position (current.wind, y, x); -- x := x - 1; -- I got tricked by the -1 = Max_Natural - 1 result -- y := y - 1; if not (x = 0 and y = 0) then if x = 0 then y := y - 1; Get_Size (current.wind, tmp, x); end if; x := x - 1; Delete_Character (current.wind, y, x); end if; end; when others => -- TODO c = '\r' ? if current /= null then declare begin Add (current.wind, Ch => Code_To_Char (c)); exception when Curses_Exception => null; -- this happens if we are at the -- lower right of a window and add a character. end; else Beep; end if; end case; newwin_report (current.wind); if current /= null then usescr := current.wind; else usescr := Standard_Window; end if; Refresh (usescr); c := Getchar (usescr); exit when c = Quit or (c = Escape and HaveKeyPad (usescr)); -- TODO when does c = ERR happen? end loop; -- TODO while current /= null loop -- current := delete_framed(current, False); -- end loop; Allow_Scrolling (Mode => True); End_Mouse (Mask2); Set_Raw_Mode (SwitchOn => True); Erase; End_Windows; end ncurses2.acs_and_scroll;