X-Git-Url: https://ncurses.scripts.mit.edu/?a=blobdiff_plain;f=Ada95%2Fsamples%2Fncurses2-acs_and_scroll.adb;fp=Ada95%2Fsamples%2Fncurses2-acs_and_scroll.adb;h=65c2939a8597426b277f5675fcfc16892389a088;hb=46722468f47c2b77b3987729b4bcf2321cccfd01;hp=0000000000000000000000000000000000000000;hpb=c633e5103a29a38532cf1925257b91cea33fd090;p=ncurses.git diff --git a/Ada95/samples/ncurses2-acs_and_scroll.adb b/Ada95/samples/ncurses2-acs_and_scroll.adb new file mode 100644 index 00000000..65c2939a --- /dev/null +++ b/Ada95/samples/ncurses2-acs_and_scroll.adb @@ -0,0 +1,722 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding Samples -- +-- -- +-- ncurses -- +-- -- +-- B O D Y -- +-- -- +------------------------------------------------------------------------------ +-- Copyright (c) 2000 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.1 $ +-- 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; + + use Ada.Streams.Stream_IO; + + + -- 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 : Boolean := HaveKeyPad (curpw); + do_scroll : 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 : Line_Position := lri - uli + 1; + sj : 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 arithetic, + -- 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 : 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 HaveScroll (current.wind) then + Scroll (current.wind, 1); + end if; + when Character'Pos ('B') mod 16#20# => -- Ctrl('B') + if current /= null and 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; + Set_Raw_Mode (SwitchOn => True); + Erase; + End_Windows; + +end ncurses2.acs_and_scroll;