home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
ENTERPRS
/
CPM
/
UTILS
/
S
/
TURBTOOL.ARC
/
CHAPTER2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-09-27
|
7KB
|
300 lines
{chapter2.pas}
{
copyright (c) 1981
by: bell telephone laboratories, inc. and
whitesmith's ltd.,
this software is derived from the book
"software tools in pascal", by
brian w. kernighan and p. j. plauger
addison-wesley, 1981
isbn 0-201-10342-7
right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
procedure translit;forward;
procedure entab;forward;
procedure expand;forward;
procedure echo;forward;
procedure compress;forward;
procedure overstrike;forward;
procedure overstrike;
const
skip=blank;
noskip=plus;
var
c:character;
col,newcol,i:integer;
begin
col:=1;
repeat
newcol:=col;
while(getc(c)=backspace) do
newcol:=max(newcol-1,1);
if (newcol<col) then begin
putc(newline);
putc(noskip);
for i:=1 to newcol-1 do
putc(blank);
col:=newcol
end
else if (col=1) and (c<>endfile) then
putc(skip);
if(c<>endfile)then begin
putc(c);
if (c=newline) then
col:=1
else
col:=col+1
end
until (c=endfile)
end;
procedure compress;
const
warning=caret;
var
c,lastc:character;
n:integer;
procedure putrep(n:integer;c:character);const
maxrep=26;
thresh=4;
begin
while(n>=thresh)or((c=warning)and(n>0))do begin
putc(warning);
putc(min(n,maxrep)-1+ord('a'));
putc(c);
n:=n-maxrep
end;
for n:=n downto 1 do
putc(c)
end;
begin(*compress*)
n:=1;
lastc:=getc(lastc);
while(lastc<>endfile) do begin
if(getc(c)=endfile)then begin
if(n>1) or(lastc=warning) then
putrep(n,lastc)
else
putc(lastc)
end
else if (c=lastc) then
n:=n+1
else if (n>1) or (lastc=warning) then begin
putrep(n,lastc);
n:=1
end
else
putc(lastc);
lastc:=c
end
end;
procedure expand;
const
warning=caret;
var
c:character;
n:integer;
begin
while(getc(c)<>endfile) do
if (c<>warning)then
putc(c)
else if(isupper(getc(c))) then begin
n:=c-ord('a')+1;
if(getc(c)<>endfile)then
for n:=n downto 1 do
putc(c)
else begin
putc(warning);
putc(n-1+ord('a'))
end
end
else begin
putc(warning);
if(c<>endfile) then
putc(c)
end
end;
procedure echo;
var
i,j:integer;
argstr:xstring;
begin
i:=2;
while(getarg(i,argstr,maxstr))do begin
if(i>1) then putc(blank);
for j:=1 to xlength(argstr) do
putc(argstr[j]);
i:=i+1
end;
if(i>1)then putc(newline)
end;
procedure entab;
const
maxline=1000;
type
tabtype=array[1..maxline] of boolean;
var
c:character;
col,newcol:integer;
tabstops:tabtype;
function tabpos(col:integer;var tabstops:tabtype):boolean;
begin
if(col>maxline)then
tabpos:=true
else
tabpos:=tabstops[col]
end;
procedure settabs(var tabstops:tabtype);
const
tabspace=4;
var
i:integer;
begin
for i:=1 to maxline do
tabstops[i]:=(i mod tabspace = 1)
end;
begin
settabs(tabstops);
col:=1;
repeat
newcol:=col;
while(getc(c)=blank) do begin
newcol:=newcol+1;
if(tabpos(newcol,tabstops))then begin
putc(tab);
col:=newcol;
end
end;
while (col<newcol) do begin
putc(blank);
col:=col+1
end;
if(c<>endfile) then begin
putc(c);
if(c=newline) then
col:=1
else
col:=col+1
end
until(c=endfile)
end;
procedure translit;
const
negate=caret;
var
arg,fromset,toset:xstring;
c:character;
i,lastto:0..maxstr;
allbut,squash:boolean;
function xindex(var inset:xstring;c:character;
allbut:boolean;lastto:integer):integer;
begin
if(c=endfile)then xindex:=0
else if (not allbut) then
xindex:=index(inset,c)
else if(index(inset,c)>0)then
xindex:=0
else
xindex:=lastto+1
end;
function makeset(var inset:xstring;k:integer;
var outset:xstring;maxset:integer):boolean;
var j:integer;
procedure dodash(delim:character;var src:xstring;
var i:integer;var dest:xstring;
var j:integer;maxset:integer);
var
k:integer;
junk:boolean;
begin
while (src[i]<>delim)and(src[i]<>endstr)do begin
if(src[i]=atsign)then
junk:=addstr(esc(src,i),dest,j,maxset)
else if (src[i]<>dash) then
junk:=addstr(src[i],dest,j,maxset)
else if (j<=1)or(src[i+1]=endstr)then
junk:=addstr(dash,dest,j,maxset)
else if (isalphanum(src[i-1]))
and (isalphanum(src[i+1]))
and (src[i-1]<=src[i+1]) then begin
for k:=src[i-1]+1 to src[i+1] do
junk:=addstr(k,dest,j,maxset);
i:=i+1
end
else
junk:=addstr(dash,dest,j,maxset);
i:=i+1
end
end;(*dodash*)
begin(*makeset*)
j:=1;
dodash(endstr,inset,k,outset,j,maxset);
makeset:=addstr(endstr,outset,j,maxset)
end;(*makeset*)
begin(*translit*)
if (not getarg(2,arg,maxstr))then
error('usage:translit from to');
allbut:=(arg[1]=negate);
if(allbut)then
i:=2
else
i:=1;
if (not makeset(arg,i,fromset,maxstr)) then
error('translit:"from"set too large');
if(not getarg(3,arg,maxstr))then
toset[1]:=endstr
else if (not makeset(arg,1,toset,maxstr)) then
error('translit:"to"set too large')
else if (xlength(fromset)<xlength(toset))then
error('translit:"from"shorter than "to');
lastto:=xlength(toset);
squash:=(xlength(fromset)>lastto) or (allbut);
repeat
i:=xindex(fromset,getc(c),allbut,lastto);
if (squash) and(i>=lastto) and (lastto>0) then begin
putc(toset[lastto]);
repeat
i:=xindex(fromset,getc(c),allbut,lastto)
until (i<lastto)
end;
if(c<>endfile) then begin
if(i>0)and(lastto>0) then
putc(toset[i])
else if (i=0)then
putc(c)
(*else delete*)
end
until(c=endfile)
end;