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/CHAPTER4.PAS

Pascal/Delphi Source File | 1989-09-27 | 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;