summaryrefslogtreecommitdiff
path: root/ncurses-5.3/Ada95/samples/ncurses2-demo_pad.adb
diff options
context:
space:
mode:
Diffstat (limited to 'ncurses-5.3/Ada95/samples/ncurses2-demo_pad.adb')
-rw-r--r--ncurses-5.3/Ada95/samples/ncurses2-demo_pad.adb671
1 files changed, 0 insertions, 671 deletions
diff --git a/ncurses-5.3/Ada95/samples/ncurses2-demo_pad.adb b/ncurses-5.3/Ada95/samples/ncurses2-demo_pad.adb
deleted file mode 100644
index 3e37a2a..0000000
--- a/ncurses-5.3/Ada95/samples/ncurses2-demo_pad.adb
+++ /dev/null
@@ -1,671 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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 <aldomel@ix.netcom.com> 2000
--- Version Control
--- $Revision$
--- Binding Version 01.00
-------------------------------------------------------------------------------
-with ncurses2.util; use ncurses2.util;
-
-with Terminal_Interface.Curses; use Terminal_Interface.Curses;
-
-with Interfaces.C;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-
-with Ada.Text_IO;
--- with Ada.Real_Time; use Ada.Real_Time;
--- TODO is there a way to use Real_Time or Ada.Calendar in place of
--- gettimeofday?
-
--- Demonstrate pads.
-procedure ncurses2.demo_pad is
-
- type timestruct is record
- seconds : Integer;
- microseconds : Integer;
- end record;
-
- type myfunc is access function (w : Window) return Key_Code;
-
- function gettime return timestruct;
- procedure do_h_line (y : Line_Position;
- x : Column_Position;
- c : Attributed_Character;
- to : Column_Position);
- procedure do_v_line (y : Line_Position;
- x : Column_Position;
- c : Attributed_Character;
- to : Line_Position);
- function padgetch (win : Window) return Key_Code;
- function panner_legend (line : Line_Position) return Boolean;
- procedure panner_legend (line : Line_Position);
- procedure panner_h_cleanup (from_y : Line_Position;
- from_x : Column_Position;
- to_x : Column_Position);
- procedure panner_v_cleanup (from_y : Line_Position;
- from_x : Column_Position;
- to_y : Line_Position);
- procedure panner (pad : Window;
- top_xp : Column_Position;
- top_yp : Line_Position;
- portyp : Line_Position;
- portxp : Column_Position;
- pgetc : myfunc);
-
- function gettime return timestruct is
-
- retval : timestruct;
-
- use Interfaces.C;
- type timeval is record
- tv_sec : long;
- tv_usec : long;
- end record;
- pragma Convention (C, timeval);
-
- -- TODO function from_timeval is new Ada.Unchecked_Conversion(
- -- timeval_a, System.Storage_Elements.Integer_Address);
- -- should Interfaces.C.Pointers be used here?
-
- package myP is new System.Address_To_Access_Conversions (timeval);
- use myP;
-
- t : Object_Pointer := new timeval;
-
- function gettimeofday
- (TP : System.Storage_Elements.Integer_Address;
- TZP : System.Storage_Elements.Integer_Address) return int;
- pragma Import (C, gettimeofday, "gettimeofday");
- tmp : int;
- begin
- tmp := gettimeofday (System.Storage_Elements.To_Integer
- (myP.To_Address (t)),
- System.Storage_Elements.To_Integer
- (myP.To_Address (null)));
- retval.seconds := Integer (t.tv_sec);
- retval.microseconds := Integer (t.tv_usec);
- return retval;
- end gettime;
-
-
- -- in C, The behavior of mvhline, mvvline for negative/zero length is
- -- unspecified, though we can rely on negative x/y values to stop the
- -- macro. Except Ada makes Line_Position(-1) = Natural - 1 so forget it.
- procedure do_h_line (y : Line_Position;
- x : Column_Position;
- c : Attributed_Character;
- to : Column_Position) is
- begin
- if to > x then
- Move_Cursor (Line => y, Column => x);
- Horizontal_Line (Line_Size => Natural (to - x), Line_Symbol => c);
- end if;
- end do_h_line;
-
- procedure do_v_line (y : Line_Position;
- x : Column_Position;
- c : Attributed_Character;
- to : Line_Position) is
- begin
- if to > y then
- Move_Cursor (Line => y, Column => x);
- Vertical_Line (Line_Size => Natural (to - y), Line_Symbol => c);
- end if;
- end do_v_line;
-
-
-
-
- function padgetch (win : Window) return Key_Code is
- c : Key_Code;
- c2 : Character;
- begin
- c := Getchar (win);
- c2 := Code_To_Char (c);
-
- case c2 is
- when '!' =>
- ShellOut (False);
- return Key_Refresh;
- when Character'Val (Character'Pos ('r') mod 16#20#) => -- CTRL('r')
- End_Windows;
- Refresh;
- return Key_Refresh;
- when Character'Val (Character'Pos ('l') mod 16#20#) => -- CTRL('l')
- return Key_Refresh;
- when 'U' =>
- return Key_Cursor_Up;
- when 'D' =>
- return Key_Cursor_Down;
- when 'R' =>
- return Key_Cursor_Right;
- when 'L' =>
- return Key_Cursor_Left;
- when '+' =>
- return Key_Insert_Line;
- when '-' =>
- return Key_Delete_Line;
- when '>' =>
- return Key_Insert_Char;
- when '<' =>
- return Key_Delete_Char;
- -- when ERR=> /* FALLTHRU */
- when 'q' =>
- return (Key_Exit);
- when others =>
- return (c);
- end case;
- end padgetch;
-
- show_panner_legend : Boolean := True;
-
- function panner_legend (line : Line_Position) return Boolean is
- legend : constant array (0 .. 3) of String (1 .. 61) :=
- (
- "Use arrow keys (or U,D,L,R) to pan, q to quit (?,t,s flags) ",
- "Use ! to shell-out. Toggle legend:?, timer:t, scroll mark:s.",
- "Use +,- (or j,k) to grow/shrink the panner vertically. ",
- "Use <,> (or h,l) to grow/shrink the panner horizontally. ");
- legendsize : constant := 4;
-
- n : Integer := legendsize - Integer (Lines - line);
- begin
- if line < Lines and n >= 0 then
- Move_Cursor (Line => line, Column => 0);
- if show_panner_legend then
- Add (Str => legend (n));
- end if;
- Clear_To_End_Of_Line;
- return show_panner_legend;
- end if;
- return False;
- end panner_legend;
-
- procedure panner_legend (line : Line_Position) is
- tmp : Boolean;
- begin
- tmp := panner_legend (line);
- end panner_legend;
-
- procedure panner_h_cleanup (from_y : Line_Position;
- from_x : Column_Position;
- to_x : Column_Position) is
- begin
- if not panner_legend (from_y) then
- do_h_line (from_y, from_x, Blank2, to_x);
- end if;
- end panner_h_cleanup;
-
- procedure panner_v_cleanup (from_y : Line_Position;
- from_x : Column_Position;
- to_y : Line_Position) is
- begin
- if not panner_legend (from_y) then
- do_v_line (from_y, from_x, Blank2, to_y);
- end if;
- end panner_v_cleanup;
-
-
- procedure panner (pad : Window;
- top_xp : Column_Position;
- top_yp : Line_Position;
- portyp : Line_Position;
- portxp : Column_Position;
- pgetc : myfunc) is
-
- function f (y : Line_Position) return Line_Position;
- function f (x : Column_Position) return Column_Position;
- function greater (y1, y2 : Line_Position) return Integer;
- function greater (x1, x2 : Column_Position) return Integer;
-
- top_x : Column_Position := top_xp;
- top_y : Line_Position := top_yp;
- porty : Line_Position := portyp;
- portx : Column_Position := portxp;
-
- -- f[x] returns max[x - 1, 0]
- function f (y : Line_Position) return Line_Position is
- begin
- if y > 0 then
- return y - 1;
- else
- return y; -- 0
- end if;
- end f;
-
- function f (x : Column_Position) return Column_Position is
- begin
- if x > 0 then
- return x - 1;
- else
- return x; -- 0
- end if;
- end f;
-
- function greater (y1, y2 : Line_Position) return Integer is
- begin
- if y1 > y2 then
- return 1;
- else
- return 0;
- end if;
- end greater;
-
- function greater (x1, x2 : Column_Position) return Integer is
- begin
- if x1 > x2 then
- return 1;
- else
- return 0;
- end if;
- end greater;
-
-
- pymax : Line_Position;
- basey : Line_Position := 0;
- pxmax : Column_Position;
- basex : Column_Position := 0;
- c : Key_Code;
- scrollers : Boolean := True;
- before, after : timestruct;
- timing : Boolean := True;
-
- package floatio is new Ada.Text_IO.Float_IO (Long_Float);
- begin
- Get_Size (pad, pymax, pxmax);
- Allow_Scrolling (Mode => False); -- we don't want stdscr to scroll!
-
- c := Key_Refresh;
- loop
- -- During shell-out, the user may have resized the window. Adjust
- -- the port size of the pad to accommodate this. Ncurses
- -- automatically resizes all of the normal windows to fit on the
- -- new screen.
- if top_x > Columns then
- top_x := Columns;
- end if;
- if portx > Columns then
- portx := Columns;
- end if;
- if top_y > Lines then
- top_y := Lines;
- end if;
- if porty > Lines then
- porty := Lines;
- end if;
-
- case c is
- when Key_Refresh | Character'Pos ('?') =>
- if c = Key_Refresh then
- Erase;
- else -- '?'
- show_panner_legend := not show_panner_legend;
- end if;
- panner_legend (Lines - 4);
- panner_legend (Lines - 3);
- panner_legend (Lines - 2);
- panner_legend (Lines - 1);
- when Character'Pos ('t') =>
- timing := not timing;
- if not timing then
- panner_legend (Lines - 1);
- end if;
- when Character'Pos ('s') =>
- scrollers := not scrollers;
-
- -- Move the top-left corner of the pad, keeping the
- -- bottom-right corner fixed.
- when Character'Pos ('h') =>
- -- increase-columns: move left edge to left
- if top_x <= 0 then
- Beep;
- else
- panner_v_cleanup (top_y, top_x, porty);
- top_x := top_x - 1;
- end if;
-
- when Character'Pos ('j') =>
- -- decrease-lines: move top-edge down
- if top_y >= porty then
- Beep;
- else
- if top_y /= 0 then
- panner_h_cleanup (top_y - 1, f (top_x), portx);
- end if;
- top_y := top_y + 1;
- end if;
- when Character'Pos ('k') =>
- -- increase-lines: move top-edge up
- if top_y <= 0 then
- Beep;
- else
- top_y := top_y - 1;
- panner_h_cleanup (top_y, top_x, portx);
- end if;
-
- when Character'Pos ('l') =>
- -- decrease-columns: move left-edge to right
- if top_x >= portx then
- Beep;
- else
- if top_x /= 0 then
- panner_v_cleanup (f (top_y), top_x - 1, porty);
- end if;
- top_x := top_x + 1;
- end if;
-
- -- Move the bottom-right corner of the pad, keeping the
- -- top-left corner fixed.
- when Key_Insert_Char =>
- -- increase-columns: move right-edge to right
- if portx >= pxmax or portx >= Columns then
- Beep;
- else
- panner_v_cleanup (f (top_y), portx - 1, porty);
- portx := portx + 1;
- -- C had ++portx instead of portx++, weird.
- end if;
- when Key_Insert_Line =>
- -- increase-lines: move bottom-edge down
- if porty >= pymax or porty >= Lines then
- Beep;
- else
- panner_h_cleanup (porty - 1, f (top_x), portx);
- porty := porty + 1;
- end if;
-
- when Key_Delete_Char =>
- -- decrease-columns: move bottom edge up
- if portx <= top_x then
- Beep;
- else
- portx := portx - 1;
- panner_v_cleanup (f (top_y), portx, porty);
- end if;
-
- when Key_Delete_Line =>
- -- decrease-lines
- if porty <= top_y then
- Beep;
- else
- porty := porty - 1;
- panner_h_cleanup (porty, f (top_x), portx);
- end if;
- when Key_Cursor_Left =>
- -- pan leftwards
- if basex > 0 then
- basex := basex - 1;
- else
- Beep;
- end if;
- when Key_Cursor_Right =>
- -- pan rightwards
- -- if (basex + portx - (pymax > porty) < pxmax)
- if (basex + portx -
- Column_Position (greater (pymax, porty)) < pxmax) then
- -- if basex + portx < pxmax or
- -- (pymax > porty and basex + portx - 1 < pxmax) then
- basex := basex + 1;
- else
- Beep;
- end if;
-
- when Key_Cursor_Up =>
- -- pan upwards
- if basey > 0 then
- basey := basey - 1;
- else
- Beep;
- end if;
-
- when Key_Cursor_Down =>
- -- pan downwards
- -- same as if (basey + porty - (pxmax > portx) < pymax)
- if (basey + porty -
- Line_Position (greater (pxmax, portx)) < pymax) then
- -- if (basey + porty < pymax) or
- -- (pxmax > portx and basey + porty - 1 < pymax) then
- basey := basey + 1;
- else
- Beep;
- end if;
-
- when Character'Pos ('H') |
- Key_Home |
- Key_Find =>
- basey := 0;
-
- when Character'Pos ('E') |
- Key_End |
- Key_Select =>
- basey := pymax - porty;
- if basey < 0 then -- basey := max(basey, 0);
- basey := 0;
- end if;
-
- when others =>
- Beep;
- end case;
-
- -- more writing off the screen.
- -- Interestingly, the exception is not handled if
- -- we put a block around this.
- -- delcare --begin
- if top_y /= 0 and top_x /= 0 then
- Add (Line => top_y - 1, Column => top_x - 1,
- Ch => ACS_Map (ACS_Upper_Left_Corner));
- end if;
- if top_x /= 0 then
- do_v_line (top_y, top_x - 1, ACS_Map (ACS_Vertical_Line), porty);
- end if;
- if top_y /= 0 then
- do_h_line (top_y - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
- end if;
- -- exception when Curses_Exception => null; end;
-
- -- in C was ... pxmax > portx - 1
- if scrollers and pxmax >= portx then
- declare
- length : Column_Position := portx - top_x - 1;
- lowend, highend : Column_Position;
- begin
- -- Instead of using floats, I'll use integers only.
- lowend := top_x + (basex * length) / pxmax;
- highend := top_x + ((basex + length) * length) / pxmax;
-
- do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line),
- lowend);
- if highend < portx then
- Switch_Character_Attribute
- (Attr => (Reverse_Video => True, others => False),
- On => True);
- do_h_line (porty - 1, lowend, Blank2, highend + 1);
- Switch_Character_Attribute
- (Attr => (Reverse_Video => True, others => False),
- On => False);
- do_h_line (porty - 1, highend + 1,
- ACS_Map (ACS_Horizontal_Line), portx);
- end if;
- end;
- else
- do_h_line (porty - 1, top_x, ACS_Map (ACS_Horizontal_Line), portx);
- end if;
-
- if scrollers and pymax >= porty then
- declare
- length : Line_Position := porty - top_y - 1;
- lowend, highend : Line_Position;
- begin
- lowend := top_y + (basey * length) / pymax;
- highend := top_y + ((basey + length) * length) / pymax;
-
- do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line),
- lowend);
- if highend < porty then
- Switch_Character_Attribute
- (Attr => (Reverse_Video => True, others => False),
- On => True);
- do_v_line (lowend, portx - 1, Blank2, highend + 1);
- Switch_Character_Attribute
- (Attr => (Reverse_Video => True, others => False),
- On => False);
- do_v_line (highend + 1, portx - 1,
- ACS_Map (ACS_Vertical_Line), porty);
- end if;
- end;
- else
- do_v_line (top_y, portx - 1, ACS_Map (ACS_Vertical_Line), porty);
- end if;
-
- if top_y /= 0 then
- Add (Line => top_y - 1, Column => portx - 1,
- Ch => ACS_Map (ACS_Upper_Right_Corner));
- end if;
- if top_x /= 0 then
- Add (Line => porty - 1, Column => top_x - 1,
- Ch => ACS_Map (ACS_Lower_Left_Corner));
- end if;
- declare
- begin
- -- Here is another place where it is possible
- -- to write to the corner of the screen.
- Add (Line => porty - 1, Column => portx - 1,
- Ch => ACS_Map (ACS_Lower_Right_Corner));
- exception
- when Curses_Exception => null;
- end;
-
- before := gettime;
-
- Refresh_Without_Update;
-
- declare
- -- the C version allows the panel to have a zero height
- -- wich raise the exception
- begin
- Refresh_Without_Update
- (
- pad,
- basey, basex,
- top_y, top_x,
- porty - Line_Position (greater (pxmax, portx)) - 1,
- portx - Column_Position (greater (pymax, porty)) - 1);
- exception
- when Curses_Exception => null;
- end;
-
- Update_Screen;
-
- if timing then declare
- s : String (1 .. 7);
- elapsed : Long_Float;
- begin
- after := gettime;
- elapsed := (Long_Float (after.seconds - before.seconds) +
- Long_Float (after.microseconds - before.microseconds)
- / 1.0e6);
- Move_Cursor (Line => Lines - 1, Column => Columns - 20);
- floatio.Put (s, elapsed, Aft => 3, Exp => 0);
- Add (Str => s);
- Refresh;
- end;
- end if;
-
- c := pgetc (pad);
- exit when c = Key_Exit;
-
- end loop;
-
- Allow_Scrolling (Mode => True);
-
- end panner;
-
- Gridsize : constant := 3;
- Gridcount : Integer := 0;
-
- Pad_High : constant Line_Count := 200;
- Pad_Wide : constant Column_Count := 200;
- panpad : Window := New_Pad (Pad_High, Pad_Wide);
-begin
- if panpad = Null_Window then
- Cannot ("cannot create requested pad");
- return;
- end if;
-
- for i in 0 .. Pad_High - 1 loop
- for j in 0 .. Pad_Wide - 1 loop
- if i mod Gridsize = 0 and j mod Gridsize = 0 then
- if i = 0 or j = 0 then
- Add (panpad, '+');
- else
- -- depends on ASCII?
- Add (panpad,
- Ch => Character'Val (Character'Pos ('A') +
- Gridcount mod 26));
- Gridcount := Gridcount + 1;
- end if;
- elsif i mod Gridsize = 0 then
- Add (panpad, '-');
- elsif j mod Gridsize = 0 then
- Add (panpad, '|');
- else
- declare
- -- handle the write to the lower right corner error
- begin
- Add (panpad, ' ');
- exception
- when Curses_Exception => null;
- end;
- end if;
- end loop;
- end loop;
- panner_legend (Lines - 4);
- panner_legend (Lines - 3);
- panner_legend (Lines - 2);
- panner_legend (Lines - 1);
-
- Set_KeyPad_Mode (panpad, True);
- -- Make the pad (initially) narrow enough that a trace file won't wrap.
- -- We'll still be able to widen it during a test, since that's required
- -- for testing boundaries.
-
- panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access);
-
- Delete (panpad);
- End_Windows; -- Hmm, Erase after End_Windows
- Erase;
-end ncurses2.demo_pad;
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-07 17:31:43 +0000