526 lines
13 KiB
ObjectPascal
526 lines
13 KiB
ObjectPascal
{$A+,B+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||
unit myio;
|
||
|
||
interface
|
||
|
||
uses
|
||
{rcg11172000 no overlay under Linux.}
|
||
{crt, dos, overlay;}
|
||
crt, dos;
|
||
|
||
const
|
||
infield_seperators:set of char=[' ','\','.'];
|
||
vidseg:word=$B800;
|
||
ismono:boolean=FALSE;
|
||
|
||
type
|
||
windowrec = array[0..4003] of byte;
|
||
infield_special_function_proc_rec=procedure(c:char);
|
||
|
||
const
|
||
infield_only_allow_on:boolean=FALSE;
|
||
infield_arrow_exit:boolean=FALSE;
|
||
infield_arrow_exited:boolean=FALSE;
|
||
infield_arrow_exited_keep:boolean=FALSE;
|
||
infield_special_function_on:boolean=FALSE;
|
||
infield_arrow_exit_typedefs:boolean=FALSE;
|
||
infield_normal_exit_keydefs:boolean=FALSE;
|
||
infield_normal_exited:boolean=FALSE;
|
||
|
||
var
|
||
infield_out_fgrd,
|
||
infield_out_bkgd,
|
||
infield_inp_fgrd,
|
||
infield_inp_bkgd:byte;
|
||
infield_last_arrow,
|
||
infield_last_normal:byte;
|
||
infield_only_allow:string;
|
||
infield_special_function_proc:infield_special_function_proc_rec;
|
||
infield_special_function_keys:string;
|
||
infield_arrow_exit_types:string;
|
||
infield_normal_exit_keys:string;
|
||
|
||
procedure cursoron(b:boolean);
|
||
procedure infield1(x,y:byte; var s:string; len:byte);
|
||
procedure infielde(var s:string; len:byte);
|
||
procedure infield(var s:string; len:byte);
|
||
function l_yn:boolean;
|
||
function l_pynq(s:string):boolean;
|
||
procedure cwrite(s:string);
|
||
procedure cwriteat(x,y:integer; s:string);
|
||
function cstringlength(s:string):integer;
|
||
procedure cwritecentered(y:integer; s:string);
|
||
procedure box(linetype,TLX,TLY,BRX,BRY:integer);
|
||
procedure checkvidseg;
|
||
procedure savescreen(var wind:windowrec; TLX,TLY,BRX,BRY:integer);
|
||
procedure setwindow(var wind:windowrec; TLX,TLY,BRX,BRY,tcolr,bcolr,boxtype:integer);
|
||
procedure removewindow(wind:windowrec);
|
||
procedure removewindow1(wind:windowrec);
|
||
procedure movewindow(wind:windowrec; TLX,TLY:integer);
|
||
|
||
implementation
|
||
|
||
procedure cursoron(b:boolean);
|
||
var reg:registers;
|
||
begin
|
||
with reg do begin
|
||
if (b) then begin ch:=$07; cl:=$08; end else begin ch:=$09; cl:=$00; end;
|
||
ah:=1;
|
||
intr($10,reg);
|
||
end;
|
||
end;
|
||
|
||
procedure infield1(x,y:byte; var s:string; len:byte);
|
||
var os:string;
|
||
sta,sx,sy,z,i,p:integer;
|
||
c:char;
|
||
ins,done,nokeyyet:boolean;
|
||
|
||
procedure gocpos;
|
||
begin
|
||
gotoxy(x+p-1,y);
|
||
end;
|
||
|
||
procedure exit_w_arrow;
|
||
var i:integer;
|
||
begin
|
||
infield_arrow_exited:=TRUE;
|
||
infield_last_arrow:=ord(c);
|
||
done:=TRUE;
|
||
if (infield_arrow_exited_keep) then begin
|
||
z:=len;
|
||
for i:=len downto 1 do
|
||
if (s[i]=' ') then dec(z) else i:=1;
|
||
s[0]:=chr(z);
|
||
end else
|
||
s:=os;
|
||
end;
|
||
|
||
procedure exit_w_normal;
|
||
var i:integer;
|
||
begin
|
||
infield_normal_exited:=TRUE;
|
||
infield_last_normal:=ord(c);
|
||
done:=TRUE;
|
||
if (infield_arrow_exited_keep) then begin
|
||
z:=len;
|
||
for i:=len downto 1 do
|
||
if (s[i]=' ') then dec(z) else i:=1;
|
||
s[0]:=chr(z);
|
||
end else
|
||
s:=os;
|
||
end;
|
||
|
||
begin
|
||
sta:=textattr; sx:=wherex; sy:=wherey;
|
||
os:=s;
|
||
ins:=FALSE;
|
||
done:=FALSE;
|
||
infield_arrow_exited:=FALSE;
|
||
gotoxy(x,y);
|
||
textattr:=(infield_inp_bkgd*16)+infield_inp_fgrd;
|
||
for i:=1 to len do write(' ');
|
||
for i:=length(s)+1 to len do s[i]:=' ';
|
||
gotoxy(x,y); write(s);
|
||
p:=1; { p:=length(s)+1;}
|
||
gocpos;
|
||
nokeyyet:=TRUE;
|
||
repeat
|
||
repeat c:=readkey
|
||
until ((not infield_only_allow_on) or
|
||
(pos(c,infield_special_function_keys)<>0) or
|
||
(pos(c,infield_normal_exit_keys)<>0) or
|
||
(pos(c,infield_only_allow)<>0) or (c=#0));
|
||
|
||
if ((infield_normal_exit_keydefs) and
|
||
(pos(c,infield_normal_exit_keys)<>0)) then exit_w_normal;
|
||
|
||
if ((infield_special_function_on) and
|
||
(pos(c,infield_special_function_keys)<>0)) then
|
||
infield_special_function_proc(c)
|
||
else begin
|
||
if (nokeyyet) then begin
|
||
nokeyyet:=FALSE;
|
||
if (c in [#32..#255]) then begin
|
||
gotoxy(x,y);
|
||
for i:=1 to len do begin write(' '); s[i]:=' '; end;
|
||
gotoxy(x,y);
|
||
end;
|
||
end;
|
||
case c of
|
||
#0:begin
|
||
c:=readkey;
|
||
if ((infield_arrow_exit) and (infield_arrow_exit_typedefs) and
|
||
(pos(c,infield_arrow_exit_types)<>0)) then exit_w_arrow
|
||
else
|
||
case c of
|
||
#72,#80:if (infield_arrow_exit) then exit_w_arrow;
|
||
#75:if (p>1) then dec(p);
|
||
#77:if (p<len+1) then inc(p);
|
||
#71:p:=1;
|
||
#79:begin
|
||
z:=1;
|
||
for i:=len downto 2 do
|
||
if ((s[i-1]<>' ') and (z=1)) then z:=i;
|
||
if (s[z]=' ') then p:=z else p:=len+1;
|
||
end;
|
||
#82:ins:=not ins;
|
||
#83:if (p<=len) then begin
|
||
for i:=p to len-1 do begin
|
||
s[i]:=s[i+1];
|
||
write(s[i]);
|
||
end;
|
||
s[len]:=' '; write(' ');
|
||
end;
|
||
#115:if (p>1) then begin
|
||
i:=p-1;
|
||
while ((not (s[i-1] in infield_seperators)) or
|
||
(s[i] in infield_seperators))
|
||
and (i>1) do
|
||
dec(i);
|
||
p:=i;
|
||
end;
|
||
#116:if (p<=len) then begin
|
||
i:=p+1;
|
||
while ((not (s[i-1] in infield_seperators)) or
|
||
(s[i] in infield_seperators))
|
||
and (i<=len) do
|
||
inc(i);
|
||
p:=i;
|
||
end;
|
||
#117:if (p<=len) then
|
||
for i:=p to len do begin
|
||
s[i]:=' ';
|
||
write(' ');
|
||
end;
|
||
end;
|
||
gocpos;
|
||
end;
|
||
#27:begin
|
||
s:=os;
|
||
done:=TRUE;
|
||
end;
|
||
#13:begin
|
||
done:=TRUE;
|
||
z:=len;
|
||
for i:=len downto 1 do
|
||
if (s[i]=' ') then dec(z) else i:=1;
|
||
s[0]:=chr(z);
|
||
end;
|
||
#8:if (p<>1) then begin
|
||
dec(p);
|
||
s[p]:=' ';
|
||
gocpos; write(' '); gocpos;
|
||
end;
|
||
else
|
||
if ((c in [#32..#255]) and (p<=len)) then begin
|
||
if ((ins) and (p<>len)) then begin
|
||
write(' ');
|
||
for i:=len downto p+1 do s[i]:=s[i-1];
|
||
for i:=p+1 to len do write(s[i]);
|
||
gocpos;
|
||
end;
|
||
write(c);
|
||
s[p]:=c;
|
||
inc(p);
|
||
end;
|
||
end;
|
||
end;
|
||
until done;
|
||
gotoxy(x,y);
|
||
textattr:=(infield_out_bkgd*16)+infield_out_fgrd;
|
||
for i:=1 to len do write(' ');
|
||
gotoxy(x,y); write(s);
|
||
gotoxy(sx,sy);
|
||
textattr:=sta;
|
||
|
||
infield_only_allow_on:=FALSE;
|
||
infield_special_function_on:=FALSE;
|
||
infield_normal_exit_keydefs:=FALSE;
|
||
end;
|
||
|
||
procedure infielde(var s:string; len:byte);
|
||
begin
|
||
infield1(wherex,wherey,s,len);
|
||
end;
|
||
|
||
procedure infield(var s:string; len:byte);
|
||
begin
|
||
s:=''; infielde(s,len);
|
||
end;
|
||
|
||
function l_yn:boolean;
|
||
var c:char;
|
||
begin
|
||
repeat c:=upcase(readkey) until (c in ['Y','N',#13,#27]);
|
||
if (c='Y') then begin
|
||
l_yn:=TRUE;
|
||
writeln('Yes');
|
||
end else begin
|
||
l_yn:=FALSE;
|
||
writeln('No');
|
||
end;
|
||
end;
|
||
|
||
function l_pynq(s:string):boolean;
|
||
begin
|
||
textcolor(4); write(s); textcolor(11);
|
||
l_pynq:=l_yn;
|
||
end;
|
||
|
||
procedure color(fg,bg:integer);
|
||
begin
|
||
textcolor(fg);
|
||
textbackground(bg);
|
||
end;
|
||
|
||
procedure cwrite(s:string);
|
||
var i:integer;
|
||
c:char;
|
||
lastb,lastc:boolean;
|
||
begin
|
||
lastb:=FALSE; lastc:=FALSE;
|
||
for i:=1 to length(s) do begin
|
||
c:=s[i];
|
||
if ((lastb) or (lastc)) then begin
|
||
if (lastb) then
|
||
textbackground(ord(c))
|
||
else
|
||
if (lastc) then
|
||
textcolor(ord(c));
|
||
lastb:=FALSE; lastc:=FALSE;
|
||
end else
|
||
case c of
|
||
#2:lastb:=TRUE;
|
||
#3:lastc:=TRUE;
|
||
else
|
||
write(c);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure cwriteat(x,y:integer; s:string);
|
||
begin
|
||
gotoxy(x,y);
|
||
cwrite(s);
|
||
end;
|
||
|
||
function cstringlength(s:string):integer;
|
||
var len,i:integer;
|
||
begin
|
||
len:=length(s); i:=1;
|
||
while (i<=length(s)) do begin
|
||
if ((s[i]=#2) or (s[i]=#3)) then begin dec(len,2); inc(i); end;
|
||
inc(i);
|
||
end;
|
||
cstringlength:=len;
|
||
end;
|
||
|
||
procedure cwritecentered(y:integer; s:string);
|
||
begin
|
||
cwriteat(40-(cstringlength(s) div 2),y,s);
|
||
end;
|
||
|
||
{*
|
||
* <20><><EFBFBD>Ŀ <20><><EFBFBD>ͻ <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD>ķ <20><><EFBFBD>
|
||
* <20> 1 <20> <20> 2 <20> <20> 3 <20> <20> 4 <20> <20> 5 <20> <20> 6 <20> <20> 7 <20> <20> 8 <20>
|
||
* <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD>ͼ <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD>Ľ <20><><EFBFBD>;
|
||
*}
|
||
procedure box(linetype,TLX,TLY,BRX,BRY:integer);
|
||
{rcg11172000 variable j was unused.}
|
||
{var i,j:integer;}
|
||
var i:integer;
|
||
TL,TR,BL,BR,hline,vline:char;
|
||
begin
|
||
window(1,1,80,25);
|
||
case linetype of
|
||
1:begin
|
||
TL:=#218; TR:=#191; BL:=#192; BR:=#217;
|
||
vline:=#179; hline:=#196;
|
||
end;
|
||
2:begin
|
||
TL:=#201; TR:=#187; BL:=#200; BR:=#188;
|
||
vline:=#186; hline:=#205;
|
||
end;
|
||
3:begin
|
||
TL:=#176; TR:=#176; BL:=#176; BR:=#176;
|
||
vline:=#176; hline:=#176;
|
||
end;
|
||
4:begin
|
||
TL:=#177; TR:=#177; BL:=#177; BR:=#177;
|
||
vline:=#177; hline:=#177;
|
||
end;
|
||
5:begin
|
||
TL:=#178; TR:=#178; BL:=#178; BR:=#178;
|
||
vline:=#178; hline:=#178;
|
||
end;
|
||
6:begin
|
||
TL:=#219; TR:=#219; BL:=#219; BR:=#219;
|
||
vline:=#219; hline:=#219;
|
||
end;
|
||
7:begin
|
||
TL:=#214; TR:=#183; BL:=#211; BR:=#189;
|
||
vline:=#186; hline:=#196;
|
||
end;
|
||
8:begin
|
||
TL:=#213; TR:=#184; BL:=#212; BR:=#190;
|
||
vline:=#179; hline:=#205;
|
||
end;
|
||
else
|
||
begin
|
||
TL:=#32; TR:=#32; BL:=#32; BR:=#32;
|
||
vline:=#32; hline:=#32;
|
||
end;
|
||
end;
|
||
gotoxy(TLX,TLY); write(TL);
|
||
gotoxy(BRX,TLY); write(TR);
|
||
gotoxy(TLX,BRY); write(BL);
|
||
gotoxy(BRX,BRY); write(BR);
|
||
for i:=TLX+1 to BRX-1 do begin
|
||
gotoxy(i,TLY);
|
||
write(hline);
|
||
end;
|
||
for i:=TLX+1 to BRX-1 do begin
|
||
gotoxy(i,BRY);
|
||
write(hline);
|
||
end;
|
||
for i:=TLY+1 to BRY-1 do begin
|
||
gotoxy(TLX,i);
|
||
write(vline);
|
||
end;
|
||
for i:=TLY+1 to BRY-1 do begin
|
||
gotoxy(BRX,I);
|
||
write(vline);
|
||
end;
|
||
if (linetype>0) then window(TLX+1,TLY+1,BRX-1,BRY-1)
|
||
else window(TLX,TLY,BRX,BRY);
|
||
end;
|
||
|
||
procedure checkvidseg;
|
||
begin
|
||
{rcg11172000 this only flies under DOS.}
|
||
{
|
||
if (mem[$0000:$0449]=7) then vidseg:=$B000 else vidseg:=$B800;
|
||
ismono:=(vidseg=$B000);
|
||
}
|
||
end;
|
||
|
||
procedure savescreen(var wind:windowrec; TLX,TLY,BRX,BRY:integer);
|
||
var x,y,i:integer;
|
||
{rcg12152000 my add.}
|
||
arraypos : integer;
|
||
begin
|
||
checkvidseg;
|
||
|
||
{ !!! uhoh...problems in xterms? }
|
||
|
||
wind[4000]:=TLX; wind[4001]:=TLY;
|
||
wind[4002]:=BRX; wind[4003]:=BRY;
|
||
|
||
|
||
i:=0;
|
||
for y:=TLY to BRY do
|
||
for x:=TLX to BRX do begin
|
||
{rcg11172000 this only flies under DOS.}
|
||
{
|
||
inline($FA);
|
||
wind[i]:=mem[vidseg:(160*(y-1)+2*(x-1))];
|
||
wind[i+1]:=mem[vidseg:(160*(y-1)+2*(x-1))+1];
|
||
inline($FB);
|
||
}
|
||
{ !!! this might be FreePascal/Linux-specific...}
|
||
arraypos := ((y * ScreenWidth) + x);
|
||
wind[i] := byte(ConsoleBuf^[arraypos].ch);
|
||
wind[i+1] := ConsoleBuf^[arraypos].attr;
|
||
inc(i,2);
|
||
end;
|
||
end;
|
||
|
||
procedure setwindow(var wind:windowrec; TLX,TLY,BRX,BRY,tcolr,bcolr,boxtype:integer);
|
||
{rcg11172000 unused variable.}
|
||
{var i:integer;}
|
||
begin
|
||
savescreen(wind,TLX,TLY,BRX,BRY); { save under window }
|
||
window(TLX,TLY,BRX,BRY); { set window size }
|
||
color(tcolr,bcolr); { set window colors }
|
||
clrscr; { clear window for action }
|
||
box(boxtype,TLX,TLY,BRX,BRY); { Set the border }
|
||
end;
|
||
|
||
procedure removewindow(wind:windowrec);
|
||
var TLX,TLY,BRX,BRY,x,y,i:integer;
|
||
{rcg12152000 my add.}
|
||
arraypos : integer;
|
||
begin
|
||
checkvidseg;
|
||
|
||
window(1,1,80,25);
|
||
color(14,0);
|
||
|
||
TLX:=wind[4000]; TLY:=wind[4001];
|
||
BRX:=wind[4002]; BRY:=wind[4003];
|
||
|
||
i:=0;
|
||
for y:=TLY to BRY do
|
||
for x:=TLX to BRX do begin
|
||
{rcg11172000 this only flies under DOS.}
|
||
{
|
||
inline($FA);
|
||
mem[vidseg:(160*(y-1)+2*(x-1))]:=wind[i];
|
||
mem[vidseg:(160*(y-1)+2*(x-1))+1]:=wind[i+1];
|
||
inline($FB);
|
||
}
|
||
{ !!! this might be FreePascal/Linux-specific...}
|
||
arraypos := ((y * ScreenWidth) + x);
|
||
ConsoleBuf^[arraypos].ch := char(wind[i]);
|
||
ConsoleBuf^[arraypos].attr := wind[i+1];
|
||
inc(i,2);
|
||
end;
|
||
end;
|
||
|
||
procedure removewindow1(wind:windowrec);
|
||
var oldx1,oldy1,oldx2,oldy2,sx,sy,sz:byte;
|
||
begin
|
||
sx:=wherex; sy:=wherey; sz:=textattr;
|
||
oldx1:=lo(windmin); oldy1:=hi(windmin);
|
||
oldx2:=lo(windmax); oldy2:=hi(windmax);
|
||
|
||
removewindow(wind);
|
||
|
||
window(oldx1,oldy1,oldx2,oldy2);
|
||
gotoxy(sx,sy); textattr:=sz;
|
||
end;
|
||
|
||
procedure movewindow(wind:windowrec; TLX,TLY:integer);
|
||
var BRX,BRY,x,y,i:integer;
|
||
{rcg12152000 my add.}
|
||
arraypos : integer;
|
||
begin
|
||
checkvidseg;
|
||
|
||
window(1,1,80,25);
|
||
color(14,0);
|
||
|
||
BRX:=wind[4002]; BRY:=wind[4003];
|
||
inc(BRX,TLX-wind[4000]); inc(BRY,TLY-wind[4001]);
|
||
|
||
i:=0;
|
||
for y:=TLY to BRY do
|
||
for x:=TLX to BRX do begin
|
||
{rcg11172000 this only flies under DOS.}
|
||
{
|
||
inline($FA);
|
||
mem[vidseg:(160*(y-1)+2*(x-1))]:=wind[i];
|
||
mem[vidseg:(160*(y-1)+2*(x-1))+1]:=wind[i+1];
|
||
inline($FB);
|
||
}
|
||
{ !!! this might be FreePascal/Linux-specific...}
|
||
arraypos := ((y * ScreenWidth) + x);
|
||
wind[i] := byte(ConsoleBuf^[arraypos].ch);
|
||
wind[i+1] := ConsoleBuf^[arraypos].attr;
|
||
inc(i,2);
|
||
end;
|
||
end;
|
||
|
||
end.
|