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
/
TUTOR.ARC
/
CHAPTER4.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-11-30
|
8KB
|
395 lines
{chapter4.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 sort;
const
maxchars=10000;
maxlines=300;
mergeorder=5;
type
charpos=1..maxchars;
charbuf=array[1..maxchars] of character;
posbuf=array[1..maxlines] of charpos;
pos=0..maxlines;
fdbuf=array[1..mergeorder]of filedesc;
var
linebuf:charbuf;
linepos:posbuf;
nlines:pos;
infile:fdbuf;
outfile:filedesc;
high,low,lim:integer;
done:boolean;
name:xstring;
function gtext(var linepos:posbuf;var nlines:pos;
var linebuf:charbuf;infile:filedesc):boolean;
var
i,len,nextpos:integer;
temp:xstring;
done:boolean;
begin
nlines:=0;
nextpos:=1;
repeat
done:=(getline(temp,infile,maxstr)=false);
if(not done) then begin
nlines:=nlines+1;
linepos[nlines]:=nextpos;
len:=xlength(temp);
for i:=1 to len do
linebuf[nextpos+i-1]:=temp[i];
linebuf[nextpos+len]:=endstr;
nextpos:=nextpos+len+1
end
until (done) or (nextpos>= maxchars-maxstr)
or (nlines>=maxlines);
gtext:=done
end;
procedure ptext(var linepos:posbuf;nlines:integer;
var linebuf:charbuf;outfile:filedesc);
var
i,j:integer;
begin
for i:=1 to nlines do begin
j:=linepos[i];
while (linebuf[j]<>endstr)do begin
putcf(linebuf[j],outfile);
j:=j+1
end
end
end;
procedure exchange(var lp1,lp2:charpos);
var
temp:charpos;
begin
temp:=lp1;
lp1:=lp2;
lp2:=temp
end;
function cmp (i,j:charpos;var linebuf:charbuf)
:integer;
begin
while(linebuf[i]=linebuf[j])
and (linebuf[i]<>endstr) do begin
i:=i+1;
j:=j+1
end;
if(linebuf[i]=linebuf[j]) then
cmp:=0
else if (linebuf[i]=endstr) then
cmp:=-1
else if (linebuf[j]=endstr) then
cmp:=+1
else if (linebuf[i]<linebuf[j]) then
cmp:=-1
else
cmp:=+1
end;(*cmp*)
procedure quick(var linepos:posbuf; nline:pos;
var linebuf:charbuf);
procedure rquick(lo,hi:integer);
var
i,j:integer;
pivline:charpos;
begin
if (lo<hi) then begin
i:=lo;
j:=hi;
pivline:=linepos[j];
repeat
while (i<j)
and (cmp(linepos[i],pivline,linebuf)<=0) do
i:=i+1;
while (j>i)
and (cmp(linepos[j],pivline,linebuf)>=0) do
j:=j-1;
if(i<j) then
(*out of order pair*)
exchange(linepos[i],linepos[j])
until (i>=j);
exchange(linepos[i],linepos[hi]);
if(i-lo<hi-i) then begin
rquick(lo,i-1);
rquick(i+1,hi)
end
else begin
rquick(i+1,hi);
rquick(lo,i-1)
end
end
end;(*rquick*)
begin(*quick*)
rquick(1,nlines)
end;
procedure gname(n:integer;var name:xstring);
var
junk:integer;
begin
name[1]:=ord('s');
name[2]:=ord('t');
name[3]:=ord('e');
name[4]:=ord('m');
name[5]:=ord('p');
name[6]:=endstr;
junk:=itoc(n,name,xlength(name)+1)
end;
procedure gopen(var infile:fdbuf;f1,f2:integer);
var
name:xstring;
i:1..mergeorder;
begin
for i:=1 to f2-f1+1 do begin
gname(f1+i-1,name);
infile[i]:=mustopen(name,ioread)
end
end;
procedure gremove(var infile:fdbuf;f1,f2:integer);
var
name:xstring;
i:1..mergeorder;
begin
for i:= 1 to f2-f1+1 do begin
xclose(infile[i]);
gname(f1+i-1,name);
remove(name)
end
end;
function makefile(n:integer):filedesc;
var
name:xstring;
begin
gname(n,name);
makefile:=mustcreate(name,iowrite)
end;
procedure merge(var infile:fdbuf; nf:integer;
outfile:filedesc);
var
i,j:integer;
lbp:charpos;
temp:xstring;
procedure reheap(var linepos:posbuf;nf:pos;
var linebuf:charbuf);
var
i,j:integer;
begin
i:=1;
j:=2*i;
while(j<=nf)do begin
if(j<nf) then
if(cmp(linepos[j],linepos[j+1],linebuf)>0)then
j:=j+1;
if(cmp(linepos[i],linepos[j],linebuf)<=0)then
i:=nf
else
exchange(linepos[i],linepos[j]);(*percolate*)
i:=j;
j:=2*i
end
end;
procedure sccopy(var s:xstring; var cb:charbuf;
i:charpos);
var j:integer;
begin
j:=1;
while(s[j]<>endstr)do begin
cb[i]:=s[j];
j:=j+1;
i:=i+1
end;
cb[i]:=endstr
end;
procedure cscopy(var cb:charbuf;i:charpos;
var s:xstring);
var j:integer;
begin
j:=1;
while(cb[i]<>endstr)do begin
s[j]:=cb[i];
i:=i+1;
j:=j+1
end;
s[j]:=endstr
end;
begin(*merge*)
j:=0;
for i:=1 to nf do
if(getline(temp,infile[i],maxstr)) then begin
lbp:=(i-1)*maxstr+1;
sccopy(temp,linebuf,lbp);
linepos[i]:=lbp;
j:=j+1
end;
nf:=j;
quick(linepos,nf,linebuf);
while (nf>0) do begin
lbp:=linepos[1];
cscopy(linebuf,lbp,temp);
putstr(temp,outfile);
i:=lbp div maxstr +1;
if (getline(temp,infile[i],maxstr))then
sccopy(temp,linebuf,lbp)
else begin
linepos[1]:=linepos[nf];
nf:=nf-1
end;
reheap(linepos,nf,linebuf)
end
end;
begin
high:=0;
repeat (*initial formtion of runs*)
done:=gtext(linepos,nlines,linebuf,stdin);
quick(linepos,nlines,linebuf);
high:=high+1;
outfile:=makefile(high);
ptext(linepos,nlines,linebuf,outfile);
xclose(outfile)
until (done);
low:=1;
while (low<high) do begin
lim:=min(low+mergeorder-1,high);
gopen(infile,low,lim);
high:=high+1;
outfile:=makefile(high);
merge(infile,lim-low+1,outfile);
xclose(outfile);
gremove(infile,low,lim);
low:=low+mergeorder
end;
gname(high,name);
outfile:=open(name,ioread);
fcopy(outfile,stdout);
xclose(outfile);
remove(name)
end;
procedure unique;
var
buf:array[0..1] of xstring;
cur:0..1;
begin
cur:=1;
buf[1-cur][1]:=endstr;
while (getline(buf[cur],stdin,maxstr))do
if (not equal (buf[cur],buf[1-cur])) then begin
putstr(buf[cur],stdout);
cur:=1-cur
end
end;
procedure kwic;
const
fold=dollar;
var
buf:xstring;
procedure putrot(var buf:xstring);
var i:integer;
procedure rotate(var buf:xstring;n:integer);
var i:integer;
begin
i:=n;
while (buf[i]<>newline) and (buf[i]<>endstr) do begin
putc(buf[i]);
i:=i+1
end;
putc(fold);
for i:=1 to n-1 do
putc(buf[i]);
putc(newline)
end;(*rotate*)
begin(*putrot*)
i:=1;
while(buf[i]<>newline) and (buf[i]<>endstr) do begin
if (isalphanum(buf[i])) then begin
rotate(buf,i);(*token statrs at "i"*)
repeat
i:=i+1
until (not isalphanum(buf[i]))
end;
i:=i+1
end
end;(*putrot*)
begin(*kwic*)
while(getline(buf,stdin,maxstr))do
putrot(buf)
end;
procedure unrotate;
const
maxout=80;
middle=40;
fold=dollar;
var
inbuf,outbuf:xstring;
i,j,f:integer;
begin
while(getline(inbuf,stdin,maxstr))do begin
for i:=1 to maxout-1 do
outbuf[i]:=blank;
f:=index(inbuf,fold);
j:=middle-1;
for i:=xlength(inbuf)-1 downto f+1 do begin
outbuf[j]:=inbuf[i];
j:=j-1;
if(j<=0)then
j:=maxout-1
end;
j:=middle+1;
for i:=1 to f-1 do begin
outbuf[j]:=inbuf[i];
j:=j mod (maxout-1) +1
end;
for j:=1 to maxout-1 do
if(outbuf[j]<>blank) then
i:=j;
outbuf[i+1]:=endstr;
putstr(outbuf,stdout);
putc(newline)
end
end;