mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-02 16:39:36 +01:00
673 lines
16 KiB
ObjectPascal
673 lines
16 KiB
ObjectPascal
Unit nCrt;
|
|
{---------------------------------------------------------------------------
|
|
CncWare
|
|
(c) Copyright 1999
|
|
---------------------------------------------------------------------------
|
|
Filename..: ncrt.pp
|
|
Programmer: Ken J. Wright
|
|
Date......: 03/01/99
|
|
|
|
Purpose - Misc crt replacements & extras using ncurses.
|
|
|
|
NOTE: Although most of the crt procedures & functions have been replaced,
|
|
this is NOT intended as a total replacement for the crt unit. It simply
|
|
makes the ncurses library a little easier to use in a Pascal program,
|
|
including the most commonly used crt functions, with some familiar naming.
|
|
This mostly eliminates the need for using crt, or ncurses directly. By
|
|
utilizing ncurses, we get terminal independence, among other things.
|
|
|
|
If you also need some of the functionality of crt, then just add crt to the
|
|
uses clause of your program *before* ncrt.
|
|
|
|
-------------------------------<< REVISIONS >>--------------------------------
|
|
Ver | Date | Prog| Description
|
|
-------+----------+-----+-----------------------------------------------------
|
|
1.00 | 03/01/99 | kjw | Initial Release.
|
|
| 03/22/99 | kjw | Added nDelWindow(), delwin() does not nil pointer.
|
|
1.01 | 11/22/99 | kjw | Added the following: nEcho, ClrEol, ClrBot, InsLine,
|
|
| DelLine, Delay, nClrEol, nClrBot, nInsLine, nDelLine,
|
|
| nRefresh, nScroll, nDrawBox, nNewWindow, nWinColor,
|
|
| nWriteScr, nFrame & some functions for returning
|
|
| line drawing character values.
|
|
------------------------------------------------------------------------------
|
|
}
|
|
Interface
|
|
|
|
Uses linux,ncurses,strings;
|
|
|
|
Const
|
|
|
|
{ border styles for text boxes }
|
|
btNone : integer = 0;
|
|
btSingle : integer = 1;
|
|
btDouble : integer = 2;
|
|
|
|
Black = 0;
|
|
Blue = 1;
|
|
Green = 2;
|
|
Cyan = 3;
|
|
Red = 4;
|
|
Magenta = 5;
|
|
Brown = 6;
|
|
LightGray = 7;
|
|
DarkGray = 8;
|
|
LightBlue = 9;
|
|
LightGreen = 10;
|
|
LightCyan = 11;
|
|
LightRed = 12;
|
|
LightMagenta = 13;
|
|
Yellow = 14;
|
|
White = 15;
|
|
|
|
Type
|
|
pwin = ^Window;
|
|
|
|
Function StartCurses(var win : pWindow) : Boolean;
|
|
Procedure EndCurses;
|
|
Procedure ClrScr;
|
|
Procedure ClrEol;
|
|
Procedure ClrBot;
|
|
Procedure InsLine;
|
|
Procedure DelLine;
|
|
Procedure GotoXY(x,y : integer);
|
|
Function WhereX : integer;
|
|
Function WhereY : integer;
|
|
Function Readkey : char;
|
|
Function Keypressed : boolean;
|
|
Procedure Delay(DTime: Word);
|
|
Procedure nEcho(b : boolean);
|
|
Procedure nWindow(var win : pWindow; x,y,x1,y1 : integer);
|
|
Procedure nNewWindow(var win : pWindow; x,y,x1,y1 : integer);
|
|
Procedure nDelWindow(var win : pWindow);
|
|
Procedure nWinColor(win : pWindow; att : integer);
|
|
Procedure nClrScr(win : pWindow; att : integer);
|
|
Procedure nClrEol(win : pWindow);
|
|
Procedure nClrBot(win : pWindow);
|
|
Procedure nInsLine(win : pWindow);
|
|
Procedure nDelLine(win : pWindow);
|
|
Procedure nGotoXY(win : pWindow; x,y : integer);
|
|
Function nWhereX(win : pWindow) : integer;
|
|
Function nWhereY(win : pWindow) : integer;
|
|
Function nReadkey(win : pWindow) : char;
|
|
Function nReadln(win : pWindow) : string;
|
|
Procedure nWrite(win : pWindow; s : string);
|
|
Procedure nWriteln(win : pWindow; s : string);
|
|
Procedure nWriteScr(win : pWindow; x,y,att : integer; s : string);
|
|
Procedure nRefresh(win : pWindow);
|
|
Procedure nScroll(win : pWindow; lines,dir : integer);
|
|
Procedure nDrawBox(LineStyle,x1,y1,x2,y2,att : Integer);
|
|
Procedure nFrame(win : pWindow);
|
|
Function nHL : char; { horizontal line }
|
|
Function nVL : char; { vertical line }
|
|
Function nUL : char; { upper left corner }
|
|
Function nLL : char; { lower loft corner }
|
|
Function nUR : char; { upper right corner }
|
|
Function nLR : char; { lower right corner }
|
|
Function nLT : char; { left tee }
|
|
Function nRT : char; { right tee }
|
|
Function nTT : char; { top tee }
|
|
Function nBT : char; { bottom tee }
|
|
Function nPL : char; { plus, + }
|
|
Function nLA : char; { left arrow }
|
|
Function nRA : char; { right arrow }
|
|
Function nUA : char; { up arror }
|
|
Function nDA : char; { down arrow }
|
|
Function IsBold(att : integer) : boolean;
|
|
Function SetColorPair(att : integer) : integer;
|
|
Procedure FWrite(Col,Row,Attrib:byte;Clear:Integer;s:String);
|
|
|
|
Implementation
|
|
|
|
Var
|
|
fg,bg : integer;
|
|
cp : array [0..7,0..7] of integer; { color pair array }
|
|
ps : array [0..255] of char; { for use with pchars }
|
|
|
|
{--------------------------------------
|
|
initialize ncurses screen & keyboard,
|
|
return a pointer to stdscr
|
|
--------------------------------------}
|
|
Function StartCurses(var win : pWindow) : Boolean;
|
|
Begin
|
|
if initscr=Nil then Begin
|
|
StartCurses := FALSE;
|
|
halt;
|
|
End Else Begin
|
|
StartCurses := TRUE;
|
|
start_color;
|
|
cbreak; { don't buffer keyboard input }
|
|
noecho; { don't echo kepresses }
|
|
nonl; { don't process cr in newline }
|
|
intrflush(stdscr,bool(false));
|
|
keypad(stdscr,bool(true));
|
|
win := stdscr;
|
|
End;
|
|
|
|
End;
|
|
|
|
{-------------------
|
|
Shutdown ncurses
|
|
-------------------}
|
|
Procedure EndCurses;
|
|
Begin
|
|
echo;
|
|
nocbreak;
|
|
refresh;
|
|
endwin;
|
|
End;
|
|
|
|
{ clear stdscr }
|
|
Procedure ClrScr;
|
|
Begin
|
|
TouchWin(stdscr);
|
|
erase;
|
|
refresh;
|
|
End;
|
|
|
|
{ clear from the cursor to the end of line in stdscr }
|
|
Procedure ClrEol;
|
|
Begin
|
|
clrtoeol;
|
|
refresh;
|
|
End;
|
|
|
|
{ clear from the cursor to the bottom of stdscr }
|
|
Procedure ClrBot;
|
|
Begin
|
|
clrtobot;
|
|
refresh;
|
|
End;
|
|
|
|
{ insert a line at the cursor line in stdscr }
|
|
Procedure InsLine;
|
|
Begin
|
|
insertln;
|
|
refresh;
|
|
End;
|
|
|
|
{ delete line at the cursor in stdscr }
|
|
Procedure DelLine;
|
|
Begin
|
|
deleteln;
|
|
refresh;
|
|
End;
|
|
|
|
{ position cursor in stdscr }
|
|
Procedure GotoXY(x,y : integer);
|
|
Begin
|
|
move(y-1,x-1);
|
|
refresh;
|
|
End;
|
|
|
|
{ find cursor x position in stdscr }
|
|
Function WhereX : integer;
|
|
var x,y : longint;
|
|
Begin
|
|
getyx(stdscr,y,x);
|
|
WhereX := x+1;
|
|
End;
|
|
|
|
{ find cursor y position in stdscr }
|
|
Function WhereY : integer;
|
|
var x,y : longint;
|
|
Begin
|
|
getyx(stdscr,y,x);
|
|
WhereY := y+1;
|
|
End;
|
|
|
|
{ Wait for DTime milliseconds }
|
|
Procedure Delay(DTime: Word);
|
|
Begin
|
|
Select(0,nil,nil,nil,DTime);
|
|
End;
|
|
|
|
{ set the echo flag }
|
|
Procedure nEcho(b : boolean);
|
|
Begin
|
|
Case b of
|
|
true : echo;
|
|
false: noecho;
|
|
End;
|
|
End;
|
|
|
|
{ create a new subwindow }
|
|
Procedure nWindow(var win : pWindow; x,y,x1,y1 : integer);
|
|
Begin
|
|
nDelWindow(win);
|
|
win := subwin(stdscr,y1-y+1,x1-x+1,y-1,x-1);
|
|
If win = nil then Exit;
|
|
intrflush(win,bool(false));
|
|
keypad(win,bool(true));
|
|
End;
|
|
|
|
{ create a new window }
|
|
Procedure nNewWindow(var win : pWindow; x,y,x1,y1 : integer);
|
|
Begin
|
|
nDelWindow(win);
|
|
win := newwin(y1-y+1,x1-x+1,y-1,x-1);
|
|
If win = nil then Exit;
|
|
intrflush(win,bool(false));
|
|
keypad(win,bool(true));
|
|
End;
|
|
|
|
{ delete a window, note this does not clear it }
|
|
Procedure nDelWindow(var win : pWindow);
|
|
Begin
|
|
If win <> Nil Then delwin(win);
|
|
win := Nil;
|
|
End;
|
|
|
|
{ set the color of the entire window, }
|
|
{ delayed until next refresh }
|
|
Procedure nWinColor(win : pWindow; att : integer);
|
|
Begin
|
|
wbkgd(win,COLOR_PAIR(SetColorPair(att)));
|
|
If IsBold(att) Then
|
|
wattr_set(win,A_BOLD);
|
|
End;
|
|
|
|
{ clear the specified screen }
|
|
procedure nClrScr(win : pWindow; att : integer);
|
|
Begin
|
|
wbkgd(win,COLOR_PAIR(SetColorPair(att)));
|
|
If IsBold(att) Then
|
|
wattr_set(win,A_BOLD);
|
|
TouchWin(win);
|
|
werase(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ clear from the cursor to the end of line in a window }
|
|
Procedure nClrEol(win : pWindow);
|
|
Begin
|
|
wclrtoeol(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ clear from the cursor to the bottom in a window }
|
|
Procedure nClrBot(win : pWindow);
|
|
Begin
|
|
wclrtobot(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ insert a line at the cursor line in a window }
|
|
Procedure nInsLine(win : pWindow);
|
|
Begin
|
|
winsertln(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ delete line at the cursor in stdscr }
|
|
Procedure nDelLine(win : pWindow);
|
|
Begin
|
|
wdeleteln(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ position cursor in a window }
|
|
Procedure nGotoXY(win : pWindow; x,y : integer);
|
|
Begin
|
|
wmove(win,y-1,x-1);
|
|
touchwin(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ find cursor x position in a window }
|
|
Function nWhereX(win : pWindow) : integer;
|
|
var x,y : longint;
|
|
Begin
|
|
getyx(win,y,x);
|
|
nWhereX := x+1;
|
|
End;
|
|
|
|
{ find cursor y position in a window }
|
|
Function nWhereY(win : pWindow) : integer;
|
|
var x,y : longint;
|
|
Begin
|
|
getyx(win,y,x);
|
|
nWhereY := y+1;
|
|
End;
|
|
|
|
{ repaint a window }
|
|
Procedure nRefresh(win : pWindow);
|
|
Begin
|
|
touchwin(win);
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{
|
|
Check if a key has been pressed.
|
|
Note: this is best used along with select() on STDIN, as it can suck
|
|
up lots of cpu time.
|
|
}
|
|
function Keypressed : boolean;
|
|
var l : longint;
|
|
Begin
|
|
Keypressed := FALSE;
|
|
nodelay(stdscr,bool(TRUE));
|
|
l := getch;
|
|
If l <> ERR Then Begin { ERR = -(1) from unit ncurses }
|
|
ungetch(l);
|
|
Keypressed := TRUE;
|
|
End;
|
|
nodelay(stdscr,bool(FALSE));
|
|
End;
|
|
|
|
{ silently read a key from stdscr }
|
|
Function Readkey : char;
|
|
Begin
|
|
Readkey := nReadkey(stdscr);
|
|
End;
|
|
|
|
{
|
|
read a keystroke from a window, including function keys
|
|
and extended keys (arrows, etc.)
|
|
Note: Make sure that keypad(win,true) has been issued prior to use.
|
|
( nWindow does this )
|
|
}
|
|
Function nReadkey(win : pWindow) : char;
|
|
var
|
|
c : char;
|
|
l : longint;
|
|
xtnded : boolean;
|
|
Begin
|
|
l := wgetch(win);
|
|
{ if it's an extended key, then map to the IBM values }
|
|
if l > 255 then begin
|
|
xtnded := true;
|
|
c := #27;
|
|
Case l of
|
|
KEY_BREAK : Begin xtnded := false; c := #3; End;
|
|
KEY_BACKSPACE : Begin xtnded := false; c := #8; End;
|
|
KEY_IC : c := #82; { insert }
|
|
KEY_DC : c := #83; { delete }
|
|
KEY_HOME : c := #71; { home }
|
|
KEY_END : c := #79; { end }
|
|
KEY_UP : c := #72; { up arrow }
|
|
KEY_DOWN : c := #80; { down arrow }
|
|
KEY_LEFT : c := #75; { left arrow }
|
|
KEY_RIGHT : c := #77; { right arrow }
|
|
KEY_NPAGE : c := #81; { page down }
|
|
KEY_PPAGE : c := #73; { page up }
|
|
Else
|
|
Begin
|
|
If l = Key_f(1) Then c := #59 Else
|
|
If l = Key_f(2) Then c := #60 Else
|
|
If l = Key_f(3) Then c := #61 Else
|
|
If l = Key_f(4) Then c := #62 Else
|
|
If l = Key_f(5) Then c := #63 Else
|
|
If l = Key_f(6) Then c := #64 Else
|
|
If l = Key_f(7) Then c := #65 Else
|
|
If l = Key_f(8) Then c := #66 Else
|
|
If l = Key_f(9) Then c := #67 Else
|
|
If l = Key_f(10) Then c := #68;
|
|
End;
|
|
End;
|
|
If xtnded Then Begin
|
|
nReadKey := #0;
|
|
ungetch(ord(c));
|
|
Exit;
|
|
End Else
|
|
nReadkey := c;
|
|
End Else
|
|
nReadkey := chr(ord(l));
|
|
End;
|
|
|
|
{ read input string from a window }
|
|
{ note: by default, echo is false }
|
|
Function nReadln(win : pWindow) : string;
|
|
Begin
|
|
wgetstr(win,ps);
|
|
nReadln := StrPas(ps);
|
|
End;
|
|
|
|
{ write a string to a window at the current cursor position }
|
|
Procedure nWrite(win : pWindow; s : string);
|
|
Begin
|
|
waddstr(win,StrPCopy(ps,s));
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ write a string to a window at the current cursor position }
|
|
{ followed by a newline }
|
|
Procedure nWriteln(win : pWindow; s : string);
|
|
Begin
|
|
waddstr(win,StrPCopy(ps,s+#10));
|
|
wrefresh(win);
|
|
End;
|
|
|
|
{ write a string to a window without refreshing screen }
|
|
Procedure nWriteScr(win : pWindow; x,y,att : integer; s : string);
|
|
Var
|
|
xx,yy,
|
|
cp : longint;
|
|
Begin
|
|
cp := SetColorPair(att);
|
|
{ write string with current attributes }
|
|
mvwaddstr(win,y-1,x-1,StrPCopy(ps,s));
|
|
{ save the new cursor position }
|
|
getyx(win,yy,xx);
|
|
{ update with new attributes }
|
|
If IsBold(att) Then
|
|
mvwchgat(win,y-1,x-1,-1,A_BOLD,cp,0)
|
|
Else
|
|
mvwchgat(win,y-1,x-1,-1,A_NORMAL,cp,0);
|
|
{ return cursor to saved position }
|
|
wmove(win,yy,xx);
|
|
End;
|
|
|
|
{ scroll a window, up or down, a specified number of lines }
|
|
Procedure nScroll(win : pwindow; lines,dir : integer);
|
|
var i : integer;
|
|
Begin
|
|
ScrollOk(win,bool(True));
|
|
For i := 1 to lines Do Begin
|
|
wscrl(win,dir);
|
|
End;
|
|
wRefresh(win);
|
|
End;
|
|
|
|
{ draw a colored box, with or without a border }
|
|
Procedure nDrawBox(LineStyle,x1,y1,x2,y2,att : Integer);
|
|
Var
|
|
win : pWindow;
|
|
Begin
|
|
win := SubWin(stdscr,y2-y1+1,x2-x1+1,y1-1,x1-1);
|
|
If win = nil Then Begin
|
|
write('drawbox: could not allocate window: ',
|
|
(y2-y1+1),',',(x2-x1+1),',',(y1-1),',',(x1-1));
|
|
exit;
|
|
end;
|
|
wbkgd(win,COLOR_PAIR(SetColorPair(att)));
|
|
If IsBold(att) Then
|
|
wattr_set(win,A_BOLD);
|
|
werase(win);
|
|
case LineStyle of
|
|
1,2 : box(win, ACS_VLINE, ACS_HLINE);
|
|
End;
|
|
wrefresh(win);
|
|
nDelWindow(win);
|
|
End;
|
|
|
|
{ add a border to a window }
|
|
{ waits for a refresh }
|
|
Procedure nFrame(win : pWindow);
|
|
Begin
|
|
box(win, ACS_VLINE, ACS_HLINE);
|
|
End;
|
|
|
|
Function nHL : char;
|
|
Begin
|
|
nHL := char(ACS_HLINE);
|
|
End;
|
|
|
|
Function nVL : char;
|
|
Begin
|
|
nVL := char(ACS_VLINE);
|
|
End;
|
|
|
|
Function nUL : char;
|
|
Begin
|
|
nUL := char(ACS_ULCORNER);
|
|
End;
|
|
|
|
Function nLL : char;
|
|
Begin
|
|
nLL := char(ACS_LLCORNER);
|
|
End;
|
|
|
|
Function nUR : char;
|
|
Begin
|
|
nUR := char(ACS_URCORNER);
|
|
End;
|
|
|
|
Function nLR : char;
|
|
Begin
|
|
nLR := char(ACS_LRCORNER);
|
|
End;
|
|
|
|
Function nLT : char;
|
|
Begin
|
|
nLT := char(ACS_LTEE);
|
|
End;
|
|
|
|
Function nRT : char;
|
|
Begin
|
|
nRT := char(ACS_RTEE);
|
|
End;
|
|
|
|
Function nTT : char;
|
|
Begin
|
|
nTT := char(ACS_TTEE);
|
|
End;
|
|
|
|
Function nBT : char;
|
|
Begin
|
|
nBT := char(ACS_BTEE);
|
|
End;
|
|
|
|
Function nPL : char;
|
|
Begin
|
|
nPL := char(ACS_PLUS);
|
|
End;
|
|
|
|
Function nLA : char;
|
|
Begin
|
|
nLA := char(ACS_LARROW);
|
|
End;
|
|
|
|
Function nRA : char;
|
|
Begin
|
|
nRA := char(ACS_RARROW);
|
|
End;
|
|
|
|
Function nUA : char;
|
|
Begin
|
|
nUA := char(ACS_UARROW);
|
|
End;
|
|
|
|
Function nDA : char;
|
|
Begin
|
|
nDA := char(ACS_DARROW);
|
|
End;
|
|
|
|
{ see if the specified attribute is high intensity, }
|
|
{ used by fwrite() }
|
|
Function IsBold(att : integer) : boolean;
|
|
Begin
|
|
bg := att div 16;
|
|
fg := att - ((att div 16) * 16);
|
|
isbold := (fg > 7);
|
|
End;
|
|
|
|
{ initialize a color pair, used by fwrite() }
|
|
Function SetColorPair(att : integer) : integer;
|
|
var
|
|
i : integer;
|
|
{ ncurses constants
|
|
COLOR_BLACK = 0;
|
|
COLOR_RED = 1;
|
|
COLOR_GREEN = 2;
|
|
COLOR_YELLOW = 3;
|
|
COLOR_BLUE = 4;
|
|
COLOR_MAGENTA = 5;
|
|
COLOR_CYAN = 6;
|
|
COLOR_WHITE = 7;
|
|
}
|
|
Begin
|
|
bg := att div 16;
|
|
fg := att - ((att div 16) * 16);
|
|
While bg > 7 Do dec(bg,8);
|
|
While fg > 7 Do dec(fg,8);
|
|
{ map to ncurses color values }
|
|
case bg of
|
|
0 : bg := COLOR_BLACK;
|
|
1 : bg := COLOR_BLUE;
|
|
2 : bg := COLOR_GREEN;
|
|
3 : bg := COLOR_CYAN;
|
|
4 : bg := COLOR_RED;
|
|
5 : bg := COLOR_MAGENTA;
|
|
6 : bg := COLOR_YELLOW;
|
|
7 : bg := COLOR_WHITE;
|
|
end;
|
|
case fg of
|
|
0 : fg := COLOR_BLACK;
|
|
1 : fg := COLOR_BLUE;
|
|
2 : fg := COLOR_GREEN;
|
|
3 : fg := COLOR_CYAN;
|
|
4 : fg := COLOR_RED;
|
|
5 : fg := COLOR_MAGENTA;
|
|
6 : fg := COLOR_YELLOW;
|
|
7 : fg := COLOR_WHITE;
|
|
end;
|
|
i := cp[bg,fg];
|
|
init_pair(i,fg,bg);
|
|
SetColorPair := i;
|
|
End;
|
|
|
|
{---------------------------------------------------------------
|
|
write a string to stdscr with color, without moving the cursor
|
|
|
|
Col = x position
|
|
Row = y position
|
|
Attrib = color (0..127)
|
|
Clear = clear line up to x position
|
|
s = string to write
|
|
---------------------------------------------------------------}
|
|
procedure FWrite(Col,Row,Attrib:byte;Clear:Integer;s:String);
|
|
Const
|
|
ClearLine = { Following line is 80 Spaces }
|
|
' ';
|
|
|
|
Var
|
|
cs : string;
|
|
win : pWindow;
|
|
Begin
|
|
if Clear > 0 Then Begin
|
|
If Clear > 80 Then Clear := 80;
|
|
cs := Copy(ClearLine,1,(Clear-Col)-Length(s)+1);
|
|
End Else
|
|
cs := '';
|
|
s := s+cs;
|
|
If s = '' Then Exit;
|
|
win := subwin(stdscr,1,Length(s),row-1,col-1);
|
|
If win = nil Then Begin
|
|
s := ' FWrite: failed to create sub-window for '+s;
|
|
write(s,':',length(s));
|
|
Exit;
|
|
End;
|
|
wbkgd(win,COLOR_PAIR(SetColorPair(Attrib)));
|
|
If isbold(Attrib) then
|
|
wattr_set(win,A_BOLD);
|
|
mvwaddstr(win,0,0,StrPCopy(ps,s));
|
|
wrefresh(win);
|
|
delwin(win);
|
|
refresh;
|
|
End;
|
|
|
|
Begin
|
|
{ load the color pairs array with color pair indices (0..63) }
|
|
For bg := 0 to 7 Do For fg := 0 to 7 do cp[bg,fg] := (bg*8)+fg;
|
|
End. { of Unit nCrt }
|