ncurses2-demo_pad.adb [plain text]
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;
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);
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;
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#) => End_Windows;
Refresh;
return Key_Refresh;
when Character'Val (Character'Pos ('l') mod 16#20#) => 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 '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;
function f (y : Line_Position) return Line_Position is
begin
if y > 0 then
return y - 1;
else
return y; end if;
end f;
function f (x : Column_Position) return Column_Position is
begin
if x > 0 then
return x - 1;
else
return x; 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);
c := Key_Refresh;
loop
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;
when Character'Pos ('h') =>
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') =>
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') =>
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') =>
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;
when Key_Insert_Char =>
if portx >= pxmax or portx >= Columns then
Beep;
else
panner_v_cleanup (f (top_y), portx - 1, porty);
portx := portx + 1;
end if;
when Key_Insert_Line =>
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 =>
if portx <= top_x then
Beep;
else
portx := portx - 1;
panner_v_cleanup (f (top_y), portx, porty);
end if;
when Key_Delete_Line =>
if porty <= top_y then
Beep;
else
porty := porty - 1;
panner_h_cleanup (porty, f (top_x), portx);
end if;
when Key_Cursor_Left =>
if basex > 0 then
basex := basex - 1;
else
Beep;
end if;
when Key_Cursor_Right =>
if (basex + portx -
Column_Position (greater (pymax, porty)) < pxmax) then
basex := basex + 1;
else
Beep;
end if;
when Key_Cursor_Up =>
if basey > 0 then
basey := basey - 1;
else
Beep;
end if;
when Key_Cursor_Down =>
if (basey + porty -
Line_Position (greater (pxmax, portx)) < 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 := 0;
end if;
when others =>
Beep;
end case;
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;
if scrollers and pxmax >= portx then
declare
length : Column_Position := portx - top_x - 1;
lowend, highend : Column_Position;
begin
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
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
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
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
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);
panner (panpad, 2, 2, Lines - 5, Columns - 15, padgetch'Access);
Delete (panpad);
End_Windows; Erase;
end ncurses2.demo_pad;