Programmer 7500/MAX_PROGRAMMERS.iso/INFO/PASCAL/PT03.ZIP/SORTF.AR

Text File | 1983-09-01 | 13.1 KB | 567 lines

-h- bubble.srt 300
{ bubble -- bubble sort v[1] ... v[n] increasing }
procedure bubble (var v : intarray; n : integer);
var
 i, j, k : integer;
begin
 for i := n downto 2 do
  for j := 1 to i-1 do
   if (v[j] > v[j+1]) then begin { compare }
    k := v[j]; { exchange }
    v[j] := v[j+1];
    v[j+1] := k
   end
end;

-h- cmp.srt 825
{ cmp -- compare linebuf[i] with linebuf[j] }
function cmp (i, j : charpos; var linebuf : charbuf; cbeg,cend : charpos)
  : integer;
var ii,jj: charpos;
    kk     : integer;
begin
 ii := 1;
 while (ii < cbeg) do
    if (linebuf[ii+i-1] = ENDSTR) then break
    else ii := ii + 1;
 i := i + ii - 1;
 jj := 1;
 while (jj < cbeg) do
    if (linebuf[jj+j-1] = ENDSTR) then break
    else jj := jj + 1;
 j := j + jj - 1;
 kk := cend - cbeg;
 while (linebuf[i] = linebuf[j])
   and (linebuf[i] <> ENDSTR) and (kk > 0) do begin
  i := i + 1;
  j := j + 1;
  kk := kk - 1;
 end;
 if (linebuf[i] = linebuf[j]) then
  cmp := 0
 else if (linebuf[i] = ENDSTR) then { 1st is shorter }
  cmp := -1
 else if (linebuf[j] = ENDSTR) then { 2nd is shorter }
  cmp := +1
 else if (linebuf[i] < linebuf[j]) then
  cmp := -1
 else
  cmp := +1
end;

-h- cscopy.srt 247
{ cscopy -- copy cb[i]... to string s }
procedure cscopy (var cb : charbuf; i : charpos;
  var s : string);
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;

-h- exchange.srt 174
{ exchange -- exchange linebuf[lp1] with linebuf[lp2] }
procedure exchange (var lp1, lp2 : charpos);
var
 temp : charpos;
begin
 temp := lp1;
 lp1 := lp2;
 lp2 := temp
end;

-h- gname.srt 337
{ gname -- generate unique name for file id n }
procedure gname (n : integer; var name : string);
var
 junk : integer;
begin
 { setstring(name, 'stemp'); }
  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, length(name)+1)
end;

-h- gopen.srt 249
{ gopen -- open group of files f1 ... f2 }
procedure gopen (var infile : fdbuf; f1, f2 : integer);
var
 name : string;
 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;

-h- gremove.srt 253
{ gremove -- remove group of files f1 ... f2 }
procedure gremove (var infile : fdbuf; f1, f2 : integer);
var
 name : string;
 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;

-h- gtext.srt 665
{ gtext -- get text lines into linebuf }
function gtext (var linepos : posbuf; var nlines : pos;
  var linebuf : charbuf; infile : filedesc) : boolean;
var
 i, len, nextpos : integer;
 temp : string;
 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 := length(temp);
   for i := 1 to len do
    linebuf[nextpos+i-1] := temp[i];
   linebuf[nextpos+len] := ENDSTR;
   nextpos := nextpos + len + 1  { 1 for ENDSTR }
  end
 until (done) or (nextpos >= MAXCHARS-MAXSTR)
   or (nlines >= MAXLINES);
 gtext := done
end;

-h- inmemqui.srt 613
{ sort -- sort text lines in memory }
procedure inmemquick;
const
 MAXCHARS = 10000; { maximum # of text characters }
 MAXLINES = 100;  { maximum # of line pointers }
type
 charpos = 1..MAXCHARS;
 charbuf = array [1..MAXCHARS] of character;
 posbuf = array [1..MAXLINES] of charpos;
 pos = 0..MAXLINES;
var
 linebuf : charbuf;
 linepos : posbuf;
 nlines : pos;
#include "gtext.p"
#include "quick.p"
#include "ptext.p"
begin
 if (gtext(linepos, nlines, linebuf, STDIN)) then begin
  quick(linepos, nlines, linebuf);
  ptext(linepos, nlines, linebuf, STDOUT)
 end
 else
  error('sort: input too big to sort')
end;

-h- inmemsor.srt 604
{ sort -- sort text lines in memory }
procedure inmemsort;
const
 MAXCHARS = 10000; { maximum # of text characters }
 MAXLINES = 300;  { maximum # of lines }
type
 charbuf = array [1..MAXCHARS] of character;
 charpos = 1..MAXCHARS;
 posbuf = array [1..MAXLINES] of charpos;
 pos = 0..MAXLINES;
var
 linebuf : charbuf;
 linepos : posbuf;
 nlines : pos;
#include "gtext.p"
#include "shell.p"
#include "ptext.p"
begin
 if (gtext(linepos, nlines, linebuf, STDIN)) then begin
  shell(linepos, nlines, linebuf);
  ptext(linepos, nlines, linebuf, STDOUT)
 end
 else
  error('sort: input too big to sort')
end;

-h- makefile.srt 175
{ makefile -- make new file for number n }
function makefile (n : integer) : filedesc;
var
 name : string;
begin
 gname(n, name);
 makefile := mustcreate(name, IOWRITE)
end;

-h- merge.srt 978
{ merge -- merge infile[1] ... infile[nf] onto outfile }
procedure merge (var infile : fdbuf; nf : integer;
  outfile : filedesc; cbeg,cend :charpos);
var
 i, j : integer;
 lbp : charpos;
 temp : string;
{$include:'reheap.srt'}
{$include:'sccopy.srt'}
{$include:'cscopy.srt'}
begin
 j := 0;
 for i := 1 to nf do { get one line from each file }
  if (getline(temp, infile[i], MAXSTR)) then begin
   lbp := (i-1)*MAXSTR + 1; { room for longest }
   sccopy(temp, linebuf, lbp);
   linepos[i] := lbp;
   j := j + 1
  end;
 nf := j;
 quick(linepos, nf, linebuf, cbeg, cend); { make initial heap }
 while (nf > 0) do begin
  lbp := linepos[1]; { lowest line }
  cscopy(linebuf, lbp, temp);
  putstr(temp, outfile);
  i := lbp div MAXSTR + 1; { compute file index }
  if (getline(temp, infile[i], MAXSTR)) then
   sccopy(temp, linebuf, lbp)
  else begin { one less input file }
   linepos[1] := linepos[nf];
   nf := nf - 1
  end;
  reheap(linepos, nf, linebuf, cbeg, cend)
 end
end;

-h- ptext.srt 326
{ ptext -- output text lines from linebuf }
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;

-h- quick.srt 200
{ quick -- quicksort for lines }
procedure quick (var linepos : posbuf; nlines : pos;
  var linebuf : charbuf; cbeg,cend : charpos);
{$include:'rquick.srt'}
begin
 rquick(1, nlines, cbeg, cend)
end;

-h- reheap.srt 566
{ reheap -- put linebuf[linepos[1]] in proper place in heap }
procedure reheap (var linepos : posbuf; nf : pos;
  var linebuf : charbuf; cbeg,cend : charpos);
var
 i, j : integer;
begin
 i := 1;
 j := 2 * i;
 while (j <= nf) do begin
  if (j < nf) then  { find smaller child }
   if (cmp(linepos[j],linepos[j+1],linebuf, cbeg, cend)>0) then
    j := j + 1;
  if (cmp(linepos[i], linepos[j], linebuf, cbeg, cend)<=0) then
   i := nf { proper position found; terminate loop }
  else
   exchange(linepos[i], linepos[j]); { percolate }
  i := j;
  j := 2 * i
 end
end;

-h- rquick.srt 764
{ rquick -- recursive quicksort }
procedure rquick (lo, hi: integer; cbeg,cend : charpos);
var
 i, j : integer;
 pivline : charpos;
begin
 if (lo < hi) then begin
  i := lo;
  j := hi;
  pivline := linepos[j]; { pivot line }
  repeat
   while (i < j)
     and (cmp(linepos[i],pivline,linebuf,cbeg,cend) <= 0) do
    i := i + 1;
   while (j > i)
     and (cmp(linepos[j],pivline,linebuf,cbeg,cend) >= 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]); { move pivot to i }
  if (i - lo < hi - i) then begin
   rquick(lo, i-1,cbeg,cend);
   rquick(i+1, hi,cbeg,cend)
  end
  else begin
   rquick(i+1, hi,cbeg,cend);
   rquick(lo, i-1,cbeg,cend)
  end
 end
end;

-h- sccopy.srt 247
{ sccopy -- copy string s to cb[i]... }
procedure sccopy (var s : string; 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;

-h- shell.srt 550
{ shell -- ascending Shell sort for lines }
procedure shell (var linepos : posbuf; nlines : integer;
  var linebuf : charbuf);
var
 gap, i, j, jg : integer;
#include "cmp.p"
#include "exchange.p"
begin
 gap := nlines div 2;
 while (gap > 0) do begin
  for i := gap+1 to nlines do begin
   j := i - gap;
   while (j > 0) do begin
    jg := j + gap;
    if (cmp(linepos[j],linepos[jg],linebuf)<=0) then
     j := 0 { force loop termination }
    else
     exchange(linepos[j], linepos[jg]);
    j := j - gap
   end
  end;
  gap := gap div 2
 end
end;

-h- shell0.srt 501
{ shell -- Shell sort v[1]...v[n] increasing }
procedure shell (var v : intarray; n : integer);
var
 gap, i, j, jg, k : integer;
begin
 gap := n div 2;
 while (gap > 0) do begin
  for i := gap+1 to n do begin
   j := i - gap;
   while (j > 0) do begin
    jg := j + gap;
    if (v[j] <= v[jg]) then  { compare }
     j := 0 { force loop termination }
    else begin
     k := v[j]; { exchange }
     v[j] := v[jg];
     v[jg] := k
    end;
    j := j - gap
   end
  end;
  gap := gap div 2
 end
end;

-h- sort.srt 1717
{ sort -- external sort of text lines }
procedure sort;
const
 MAXCHARS = 10000; { maximum # of text characters }
 MAXLINES = 300;  { maximum # of lines }
 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 : string;
 cbeg,cend : charpos;      { start/end of chars to be compared }
 arg: string;
 i  : integer;
{$include:'sortproc.srt'}
begin
 { get beg/end positions to be sorted, if any }
 cbeg := 1;
 cend := MAXSTR;
 if (getarg(1,arg,MAXSTR)) then begin
    i := 1;
    cbeg := ctoi(arg,i);
    if (getarg(2,arg,MAXSTR)) then begin
       i := 1;
       cend := ctoi(arg,i);
       end;
    if (cbeg <= 0) or (cend <= 0) or (cend < cbeg) then
       error('Invalid Argument. Syntax: sort [startpos] [endpos]');
    end;
 high := 0;
 repeat { initial formation of runs }
  done := gtext(linepos, nlines, linebuf, STDIN);
  quick(linepos, nlines, linebuf, cbeg, cend);
  high := high + 1;
  outfile := makefile(high);
  ptext(linepos, nlines, linebuf, outfile);
  xclose(outfile)
 until (done);
 low := 1;
 while (low < high) do begin { merge runs }
  lim := imin(low+MERGEORDER-1, high);
  gopen(infile, low, lim);
  high := high + 1;
  outfile := makefile(high);
  merge(infile, lim-low+1, outfile, cbeg, cend);
  xclose(outfile);
  gremove(infile, low, lim);
  low := low + MERGEORDER
 end;
 gname(high, name); { final cleanup }
 outfile := open(name, IOREAD);
 fcopy(outfile, STDOUT);
 xclose(outfile);
 remove(name)
end;

-h- sortproc.srt 297
{ sortproc -- procedures for sort }
{$include:'cmp.srt'     }
{$include:'exchange.srt'}
{$include:'gtext.srt'   }
{$include:'ptext.srt'   }
{$include:'quick.srt'   }
{$include:'gname.srt'   }
{$include:'makefile.srt'}
{$include:'gopen.srt'   }
{$include:'merge.srt'   }
{$include:'gremove.srt' }

-h- sortquic.srt 619
{ sort -- sort text lines in memory }
procedure sort;
const
 MAXCHARS = 1000; { maximum number of text characters }
 MAXLINES = 100; { maximum number of line pointers }
type
 charpos = 1..MAXCHARS;
 charbuf = array [1..MAXCHARS] of character;
 posbuf = array [1..MAXLINES] of charpos;
 pos = 0..MAXLINES;
var
 linbuf : charbuf;
 linpos : posbuf;
 nlines : pos;

#include "gtext.p"
#include "quick.p"
#include "ptext.p"

begin
 if (gtext(linpos, nlines, linbuf, STDIN) = ENDFILE) then begin
  quick(linpos, nlines, linbuf);
  ptext(linpos, nlines, linbuf, STDOUT)
 end
 else
  error('sort: input too big to sort')
end;

-h- sorttest.srt 353
procedure sorttest;
type intarray = array [1..100] of integer;
var
 v : intarray;
 buf : string;
 i, j : integer;
#include "shell0.p"
#include "ctoi.p"
begin
 j := 0;
 while (getline(buf, STDIN, MAXSTR)) do begin
  j := j + 1;
  i := 1;
  v[j] := ctoi(buf, i)
  end;
 shell(v, j);
 for i := 1 to j do begin
  putdec(v[i], 1);
  putc(NEWLINE)
 end
end;

-h- sortf.pas 611
{$debug-}
program outer (input,output);

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{$include:'initio.dcl'}
{$include:'flush.dcl' }

{$include:'getarg.dcl'  }
{$include:'ctoi.dcl'    }
{$include:'error.dcl'   }
{$include:'getline.dcl' }
{$include:'putcf.dcl'   }
{$include:'itoc.dcl'    }
{$include:'length.dcl'  }
{$include:'mustcrea.dcl'}
{$include:'mustopen.dcl'}
{$include:'open.dcl'    }
{$include:'putstr.dcl'  }
{$include:'remove.dcl'  }
{$include:'close.dcl'   }
{$include:'fcopy.dcl'   }
{$include:'imin.dcl'    }


{$include:'sort.srt'    }
BEGIN
  minitio; initio;
  sort;
  flush(0);
END.
-h- sortf.mak 165
sortf+initio+getfcb+error+getarg+nargs+length+getline+
getcf+getc+putstr+putc+putcf+itoc+mustcreate+create+
remove+close+fcopy+mustopen+open+imin+flush+ctoi+isdigit