home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
f
/
faq-s.zip
/
ANSIEDIT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-27
|
24KB
|
979 lines
unit ansiedit;
Interface
uses crt,gentypes,modem,configrt,windows,gensubs,subs1,subs2;
Function ansireedit(Var m:message;gettitle:Boolean):Boolean;
Implementation
Function ansireedit(Var m:message;gettitle:Boolean):Boolean;
Var topline,curline,cx,cy,cols,scrnsize,lines,
rightmargin,savedx,savedy,topscrn:Integer;
insertmode,msgdone,ansimode:Boolean;
Function curx:Integer;
Begin
curx:=WhereX
End;
Function cury:Integer;
Begin
cury:=WhereY-topscrn+1
End;
Procedure writevt52(q:lstr);
Var cnt:Integer;
Begin
If Not carrier Then exit;
For cnt:=1 To Length(q) Do sendchar(q[cnt])
End;
Procedure moveto(x,y:Integer);
Begin
y:=y+topscrn-1;
If ansimode Then Begin
Write(direct,#27'[');
If y<>1 Then Write(direct,strr(y));
If x<>1 Then Write(direct,';',strr(x));
Write('H')
End Else Begin
GoToXY(x,y);
writevt52(#234+#234+#01+Chr(y)+Chr(x))
End
End;
Procedure clearscr;
Begin
If ansimode
Then Write(direct,#27'[2J')
Else Begin
writevt52(#234+#234+#4);
ClrScr
End
End;
Procedure cleareol;
Begin
If ansimode
Then Write(direct,#27'[K')
Else Begin
writevt52(#234+#234+#27);
ClrEol
End
End;
Procedure savecsr;
Begin
If ansimode
Then Write(direct,#27'[s')
Else Begin
savedx:=curx;
savedy:=cury
End
End;
Procedure restorecsr;
Begin
If ansimode
Then Write(direct,#27'[u')
Else moveto(savedx,savedy)
End;
Procedure cmove(k:Char;n,dx,dy:Integer);
Var cnt:Integer;
Begin
If n<1 Then exit;
If ansimode Then Begin
Write(direct,#27'[');
If n<>1 Then Write(direct,strr(n));
Write(direct,k)
End Else
{For cnt:=1 To n Do Begin
writevt52(#27+k);}
GoToXY(WhereX+dx,WhereY+dy);
movexy (wherex,wherey);
End;
Procedure cup(n:Integer);
Begin
cmove('A',n,0,-1)
End;
Procedure cdn(n:Integer);
Begin
cmove('B',n,0,1)
End;
Procedure clf(n:Integer);
Var cnt:Integer;
Begin
cmove('D',n,-1,0)
End;
Procedure crg(n:Integer);
Begin
cmove('C',n,1,0)
End;
Procedure checkspaces;
Var q:^lstr;
Begin
q:=Addr(m.text[curline]);
While q^[Length(q^)]=' ' Do q^[0]:=Pred(q^[0])
End;
Procedure checkcx;
Var n:Integer;
Begin
n:=Length(m.text[curline])+1;
If cx>n Then cx:=n
End;
Procedure computecy;
Begin
cy:=curline-topline+1
End;
Procedure updatecpos;
Begin
computecy;
moveto(cx,cy);
ansicolor (urec.regularcolor);
End;
Procedure insertabove;
Var cnt:Integer;
Begin
If m.numlines=maxmessagesize Then exit;
For cnt:=m.numlines Downto curline Do m.text[cnt+1]:=m.text[cnt];
m.text[curline]:='';
m.numlines:=m.numlines+1
End;
Procedure deletethis;
Var cnt:Integer;
Begin
If m.numlines=1 Then Begin
m.text[1]:='';
exit
End;
For cnt:=curline+1 To m.numlines Do m.text[cnt-1]:=m.text[cnt];
m.text[m.numlines]:='';
m.numlines:=m.numlines-1;
checkcx;
End;
procedure fullrefresh;
var cnt,n,foxx:integer;
begin
if topline<1 then topline:=1;
computecy;
clearscr;
movexy (1,1);
if asciigraphics in urec.config then begin
writeln ('
╔══════════════════════════════════════════════════════════════════');
writeln ('AC════════════╗║
FAQ Version 1.02
FS-Editor
Subject');
writeln ('AC
:C║║C
To
:C║╚══════════════════════════════A');
writeln ('C════════════════════════════════════════════════╝');
end else begin
writeln ('
+==================================================================');
writeln ('AC============+|
FAQ Version 1.02
FS-Editor
Subject');
writeln ('AC
:C||C
To
:C|+==============================A');
writeln ('C================================================+');
end;
printxy2 (42,2,^S+m.title);
if m.anon and (urec.level<sysoplevel) then printxy2 (42,3,^S+anonymousstr);
if (not m.anon) or (urec.level>=sysoplevel) then if length(sendstr)>0 then
printxy2 (42,3,^S+sendstr) else printxy2 (42,3,^S+m.leftto);
moveto (1,1);
ansicolor (urec.regularcolor);
for cnt:=1 to lines do begin
n:=cnt+topline-1;
if n<=m.numlines then begin
write (m.text[n]);
if cnt<>lines then writeln
end
end;
updatecpos
end;
Procedure repos(dorefresh:Boolean);
Var cl,tl:Integer;
Begin
checkspaces;
cl:=curline;
tl:=topline;
If curline<1 Then curline:=1;
If curline>m.numlines Then curline:=m.numlines;
If topline>curline Then topline:=curline;
If topline+lines<curline Then topline:=curline-lines;
If topline<1 Then topline:=1;
checkcx;
computecy;
If (cl=curline) And (tl=topline) And (Not dorefresh)
Then updatecpos
Else fullrefresh
End;
Procedure partrefresh;{ Refreshes from CY }
Var cnt,n:Integer;
Begin
If topline<1 Then repos(True) Else Begin
moveto(1,cy);
For cnt:=cy To lines Do Begin
n:=cnt+topline-1;
If n<=m.numlines Then Write(m.text[n]);
cleareol;
If cnt<>lines Then WriteLn
End;
updatecpos
End;
ansicolor (urec.regularcolor);
End;
Procedure pageup;
Begin
checkspaces;
If curline=1 Then exit;
curline:=curline-lines+4;
topline:=topline-lines+4;
repos(True)
End;
Procedure pagedn;
Begin
checkspaces;
If curline=m.numlines Then exit;
curline:=curline+lines-4;
topline:=topline+lines-4;
repos(True)
End;
Procedure toggleins;
Begin
insertmode:=Not insertmode
End;
Procedure scrolldown;
Begin
topline:=curline-lines+2;
repos(True)
End;
Procedure scrollup;
Begin
If topline<1 Then Begin
topline:=topline+1;
moveto(1,lines);
computecy;
WriteLn
End Else Begin
topline:=curline-1;
repos(True)
End
End;
Procedure topofmsg;
Begin
checkspaces;
cx:=1;
cy:=1;
curline:=1;
If topline=1
Then updatecpos
Else
Begin
topline:=1;
fullrefresh
End
End;
Procedure updatetoeol;
Var cnt:Integer;
Begin
savecsr;
Write(Copy(m.text[curline],cx,255));
cleareol;
restorecsr
End;
Procedure letterkey(k:Char);
Var l:^lstr;
w:lstr;
n,ox:Integer;
q:Char;
inserted,refr:Boolean;
Procedure scrollwwrap;
Begin
If topline>0 Then Begin
scrollup;
exit
End;
cy:=cy-1;
moveto(Length(m.text[curline-1])+1,cy);
cleareol;
WriteLn;
Write(m.text[curline]);
topline:=topline+1;
cx:=curx
End;
Begin
l:=Addr(m.text[curline]);
If Length(l^)>=rightmargin Then Begin
If curline=maxmessagesize Then exit;
If cx<=Length(l^) Then exit;
l^:=l^+k;
w:='';
cx:=Length(l^);
Repeat
q:=l^[cx];
If q<>' ' Then Insert(q,w,1);
cx:=cx-1
Until (q=' ') Or (cx<1);
If cx<1 Then Begin
cx:=Length(l^)-1;
w:=k
End;
l^[0]:=Chr(cx);
checkspaces;
curline:=curline+1;
If curline>m.numlines Then m.numlines:=curline;
inserted:=m.text[curline]<>'';
If inserted Then insertabove;
m.text[curline]:=w;
cy:=cy+1;
ox:=cx;
cx:=Length(w)+1;
refr:=cy>lines;
If refr
Then scrollwwrap
Else Begin
If Length(w)>0 Then Begin
moveto(ox+1,cy-1);
For n:=1 To Length(w) Do Write(' ')
End;
If inserted And (m.numlines>curline)
Then partrefresh
Else Begin
moveto(1,cy);
Write(m.text[curline]);
End
End;
exit
End;
If insertmode
Then Insert(k,l^,cx)
Else Begin
While Length(l^)<cx Do l^:=l^+' ';
l^[cx]:=k
End;
Write(k);
cx:=cx+1;
If insertmode And (cx<=Length(l^)) Then updatetoeol
End;
Procedure Back;
Begin
If cx=1 Then Begin
If curline=1 Then exit;
checkspaces;
curline:=curline-1;
cy:=cy-1;
cx:=Length(m.text[curline])+1;
If cy<1 Then scrolldown Else updatecpos;
End Else Begin
cx:=cx-1;
clf(1)
End
End;
Procedure fowrd;
Begin
If cx>Length(m.text[curline]) Then Begin
If curline=maxmessagesize Then exit;
checkspaces;
curline:=curline+1;
If curline>m.numlines Then m.numlines:=curline;
cy:=cy+1;
cx:=1;
If cy>lines Then scrollup Else updatecpos
End Else Begin
cx:=cx+1;
crg(1)
End
End;
Procedure del;
Begin
If Length(m.text[curline])=0 Then Begin
deletethis;
partrefresh;
exit
End;
Delete(m.text[curline],cx,1);
If cx>Length(m.text[curline])
Then Write(' '^H)
Else updatetoeol
End;
Procedure bkspace;
Begin
If Length(m.text[curline])=0 Then Begin
If curline=1 Then exit;
deletethis;
checkspaces;
curline:=curline-1;
cy:=cy-1;
cx:=Length(m.text[curline])+1;
If cy<1
Then scrolldown
Else partrefresh;
exit
End;
If cx=1 Then exit;
cx:=cx-1;
Write(^H);
del
End;
Procedure beginline;
Begin
If cx=1 Then exit;
cx:=1;
updatecpos
End;
Procedure endline;
Var dx:Integer;
Begin
dx:=Length(m.text[curline])+1;
If cx=dx Then exit;
cx:=dx;
updatecpos
End;
Procedure upline;
Var chx:Boolean;
l:Integer;
Begin
checkspaces;
If curline=1 Then exit;
curline:=curline-1;
l:=Length(m.text[curline]);
chx:=cx>l;
If chx Then cx:=l+1;
cy:=cy-1;
If cy>0
Then If chx
Then updatecpos
Else cup(1)
Else scrolldown
End;
Procedure downline;
Var chx:Boolean;
l:Integer;
Begin
checkspaces;
If curline=maxmessagesize Then exit;
curline:=curline+1;
If curline>m.numlines Then m.numlines:=curline;
l:=Length(m.text[curline]);
chx:=cx>l;
If chx Then cx:=l+1;
cy:=cy+1;
If cy<=lines
Then If chx
Then updatecpos
Else cdn(1)
Else scrollup
End;
Procedure crlf;
Var k:Char;
Begin
If (Length(m.text[curline])=2) And (m.text[curline][1]='/') Then Begin
k:=UpCase(m.text[curline][2]);
Case k Of
'S' :Begin
deletethis;
msgdone:=True;
ansireedit:=True;
exit
End;
'A' :Begin
deletethis;
m.numlines:=0;
msgdone:=True;
exit
End
End
End;
beginline;
downline
End;
Function conword:Boolean;
Var l:^lstr;
Begin
l:=Addr(m.text[curline]);
conword:=False;
If (cx>Length(l^)) Or (cx=0) Then exit;
conword:=True;
If cx=1 Then exit;
If (l^[cx-1]=' ') And (l^[cx]<>' ') Then exit;
conword:=False
End;
Procedure wordleft;
Begin
Repeat
cx:=cx-1;
If cx<1 Then Begin
If curline=1 Then Begin
cx:=1;
repos(False);
exit
End;
checkspaces;
curline:=curline-1;
cy:=cy-1;
cx:=Length(m.text[curline])
End;
Until conword;
If cx=0 Then cx:=1;
If cy<1
Then repos(True)
Else updatecpos
End;
Procedure wordright;
Begin
Repeat
cx:=cx+1;
If cx>Length(m.text[curline]) Then Begin
If curline=m.numlines Then Begin
repos(False);
exit
End;
checkspaces;
curline:=curline+1;
cy:=cy+1;
cx:=1
End;
Until conword;
If cy>lines
Then repos(True)
Else updatecpos
End;
Procedure worddel;
Var l:^lstr;
b:Byte;
s,n:Integer;
Begin
l:=Addr(m.text[curline]);
b:=Length(l^);
If cx>b Then exit;
s:=cx;
Repeat
cx:=cx+1
Until conword Or (cx>b);
n:=cx-s;
Delete(l^,s,n);
cx:=s;
updatetoeol
End;
Procedure deleteline;
Begin
deletethis;
partrefresh
End;
Procedure insertline;
Begin
If m.numlines>=maxmessagesize Then exit;
insertabove;
checkcx;
partrefresh
End;
Procedure help;
Var k:Char;
Begin
clearscr;
if exist (textfiledir+'Edithelp.Ans') then printfile(textfiledir+'Edithelp.ANS');
Write(^B^M'Press any key...');
k:=waitforchar;
fullrefresh
End;
Procedure breakline;
Begin
If (m.numlines>=maxmessagesize) Or (cy=lines) Or
(cx=1) Or (cx>Length(m.text[curline])) Then exit;
insertabove;
m.text[curline]:=Copy(m.text[curline+1],1,cx-1);
Delete(m.text[curline+1],1,cx-1);
partrefresh
End;
Procedure joinlines;
Var n:Integer;
Begin
If curline=m.numlines Then exit;
If Length(m.text[curline])+Length(m.text[curline+1])>rightmargin Then exit;
m.text[curline]:=m.text[curline]+m.text[curline+1];
n:=cx;
curline:=curline+1;
deletethis;
curline:=curline-1;
cx:=n;
partrefresh
End;
Procedure userescape;
Var k:Char;
Begin
Repeat
k:=waitforchar;
Case k Of
'A' :upline;
'B' :downline;
'C' :fowrd;
'D' :Back
End
Until (k<>'[') Or hungupon
End;
Procedure deleteeol;
Begin
cleareol;
m.text[curline][0]:=Chr(cx-1)
End;
Procedure tab;
Var nx,n,cnt:Integer;
Begin
nx:=((cx+8) And 248)+1;
n:=nx-cx;
If (n+Length(m.text[curline])>=cols) Or (nx>=cols) Then exit;
For cnt:=1 To n Do Insert(' ',m.text[curline],cx);
updatetoeol;
cx:=cx+n;
updatecpos
End;
procedure commands;
function youaresure:boolean;
var q:string[1];
begin
youaresure:=false;
movexy (3,3);
write (^R'Abort [y/n]: '^U);
buflen:=1;
getstr (1);
clearbreak;
nobreak:=true;
cup (1);
if asciigraphics in urec.config then
write (^P'║ ') else
write (^P'| ');
if length(input)=0 then begin
updatecpos;
exit;
textcolor (urec.regularcolor)
end;
youaresure:=yes;
clearbreak;
nobreak:=true
end;
procedure savemes;
begin
msgdone:=true;
ansireedit:=true
end;
procedure abortmes;
begin
if youaresure then begin
m.numlines:=0;
msgdone:=true
end
end;
procedure formattext;
var ol,il,c:integer;
oln,wd,iln:lstr;
k:char;
procedure putword;
var cnt:integer;
b:boolean;
begin
b:=true;
for cnt:=1 to length(wd) do if wd[cnt]<>' ' then b:=false;
if b then exit;
while wd[length(wd)]=' ' do wd[0]:=pred(wd[0]);
if length(wd)=0 then exit;
if length(wd)+length(oln)>rightmargin then begin
m.text[ol]:=oln;
ol:=ol+1;
while (wd[1]=' ') and (length(wd)>0) do delete (wd,1,1);
oln:=wd
end else oln:=oln+wd;
if wd[length(wd)] in ['.','?','!']
then wd:=' '
else wd:=' '
end;
begin
il:=curline;
ol:=il;
c:=1;
oln:='';
wd:='';
iln:=m.text[il];
repeat
if length(iln)=0 then begin
putword;
m.text[ol]:=oln;
partrefresh;
checkcx;
updatecpos;
exit
end;
if c>length(iln) then begin
il:=il+1;
if il>m.numlines
then iln:=''
else begin
iln:=m.text[il];
m.text[il]:=''
end;
c:=0;
k:=' '
end else k:=iln[c];
c:=c+1;
if k=' '
then putword
else wd:=wd+k
until 0=1
end;
var cmd:string[1];
k:char;
begin
clearbreak;
nobreak:=true;
movexy (3,3);
write (^R'Command: '^U);
buflen:=1;
getstr (1);
clearbreak;
nobreak:=true;
cup (1);
if asciigraphics in urec.config then
write (^P'║ ') else
write (^P'| ');
if length(input)=0 then begin
updatecpos;
exit
end;
k:=upcase(input[1]);
case k of
'S':savemes;
'A':abortmes;
'F':formattext;
'?':help
end;
updatecpos;
textcolor (urec.regularcolor)
end;
procedure macro_in;
var cmd:string[1];
k:char;
x,y,z:integer;
begin
clearbreak;
nobreak:=true;
movexy(3,3);
write (^R'Macro #[1-3]: '^U);
buflen:=1;
getstr (1);
clearbreak;
nobreak:=true;
cup (1);
if asciigraphics in urec.config then
write (^P'║ ') else
write (^P'| ');
if length(input)=0 then begin
updatecpos;
exit
end;
k:=upcase(input[1]);
case k of
'1':begin
updatecpos;
for x := 1 to length (urec.macro1) do
letterkey (urec.macro1[x]);
end;
'2':begin
updatecpos;
for y := 1 to length (urec.macro2) do
letterkey (urec.macro2[y]);
end;
'3':begin
updatecpos;
for z := 1 to length (urec.macro3) do
letterkey (urec.macro3[z]);
end;
end;
{ updatecpos }
textcolor (urec.regularcolor)
end;
procedure processkey;
var k:char;
begin
clearbreak;
nobreak:=true;
k:=waitforchar;
case k of
' '..#250:letterkey(k);
#251:begin
delay(100);
clearinput;
k:=#0;
end;
#252..#254:letterkey(k);
' '..'~',#27:letterkey (k);
^S:Back;
^D:fowrd;
^H:bkspace;
^M:crlf;
^V:toggleins;
^E:upline;
^X:downline;
^U:help;
^K:commands;
^R:pageup;
^C:pagedn;
^G:del;
^A:wordleft;
^F:wordright;
^T:worddel;
^Q:beginline;
^W:endline;
^L:fullrefresh;
^Y:deleteline;
^N:insertline;
^I:tab;
^B:breakline;
^P:deleteeol;
^J:joinlines;
^Z:macro_in;
#27:userescape
End
End;
Var cnt:Integer;
mp:Boolean;
Begin
clearbreak;
nobreak:=True;
ansireedit:=False;
For cnt:=m.numlines+1 To maxmessagesize Do m.text[cnt]:='';
scrnsize:=urec.displaylen;
winds[0].y2:=scrnsize;
unsplit;
wholescreen;
GoToXY(1,25);
ClrEol;
If eightycols In urec.config
Then cols:=80
Else cols:=40;
ansimode:=ansigraphics In urec.config;
mp:=moreprompts In urec.config;
If mp Then urec.config:=urec.config-[moreprompts];
lines:=21;
topscrn:=scrnsize-lines+1;
insertmode:=False;
rightmargin:=cols-1;
msgdone:=False;
cx:=1;
curline:=1;
topline:=2-lines;
computecy;
updatecpos;
fullrefresh;
If m.numlines>0
Then fullrefresh
Else Begin
m.numlines:=1;updatecpos;
End;
Repeat
processkey
Until msgdone Or hungupon;
AnsiCls;
writeln(^B);
writeln(^B);
If mp Then urec.config:=urec.config+[moreprompts];
winds[0].y2:=25;
bottom;
bottomline;
End;
{$ifdef testansieditor}
{*}
{*}Procedure termmode;
{*}Var k:Char;
{*}Begin
{*}setparam(1,1200,False);
{*}WriteLn('Press ^D when connected.');
{*}Repeat
{*}If KeyPressed Then Begin
{*}Read(Kbd,k);
{*}If k=#4 Then exit;
{*}If k=#3 Then Halt;
{*}sendchar(k)
{*}End;
{*}While numchars>0 Do Write(getchar)
{*}Until 0=1
{*}End;
{*}
{*}Var m:message;
{*}cnt:Integer;
{*}Begin
{*}checkbreak:=False;
{*}urec.displaylen:=22;
{*}urec.config:=[eightycols];{ ,ansigraphics]; }
{*}If Not driverpresent Then Begin
{*}WriteLn('You fool.');
{*}Halt
{*}End;
{*}termmode;
{*}ConInptr:=Ofs(readchar);
{*}ConOutPtr:=Ofs(writechar);
{*}m.numlines:=0;
{*}For cnt:=1 To 100 Do m.text[cnt]:='Hello line '+Chr(cnt+64);
{*}WriteLn(ansireedit(m,False))
{*}
{$endif}
End.