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 / CPM / LANGUAGS / MODULA2 / POLYSORT.MOD < prev    next >
Text File  |  2000-06-30  |  5KB  |  211 lines
  1. (* Polyphase sort program.  There are n-1 source files for
  2.    merging and a single output file.  The destination of the
  3.    merged data chabges, when a certain number of runs has been
  4.    distributed.  This number is computed according to a
  5.    Fibonacci distribution. *)
  6.  
  7. MODULE polysort;
  8.  
  9. FROM InOut       IMPORT WriteCard;
  10. FROM Terminal    IMPORT WriteString, WriteLn, Read;
  11. FROM FileSystem  IMPORT File, Lookup, Create, Reset, SetPos, GetPos, Response, Close;
  12. FROM ByteBlockIO IMPORT ReadByteBlock, WriteByteBlock;
  13.  
  14. CONST n = 6;        (* # of files *)
  15.       numrecs = 10;
  16.  
  17. TYPE item = RECORD
  18.               key: CARDINAL;
  19.             END;
  20.  
  21.     tapeno = [1..n];
  22.  
  23. VAR leng,high,low,rand: CARDINAL;
  24.     eot: BOOLEAN;
  25.     buf,next: item;
  26.     f0: File;
  27.     f: ARRAY [1..n] OF File;
  28.     ch: CHAR;
  29.  
  30. PROCEDURE list(VAR f: File; n: tapeno);
  31. VAR z: CARDINAL;
  32.  
  33. BEGIN
  34.   z := 0;
  35.   WriteLn; WriteString(' tape ');
  36.   WriteCard(n,2); WriteLn;
  37.   LOOP
  38.     ReadByteBlock(f,buf);
  39.     IF f.eof THEN EXIT END;
  40.     WriteCard(buf.key,5);
  41.     INC(z);
  42.     IF z = 15 THEN WriteLn; z := 0 END
  43.   END;
  44.   WriteLn;
  45.   Reset(f)
  46. END list;
  47.  
  48.  
  49. PROCEDURE polyphasesort;
  50. VAR i,j,mx,tn,dn,x,min,z: CARDINAL(* tapeno *);
  51.     k,level:CARDINAL;
  52.     a,d,last,t,ta: ARRAY tapeno OF CARDINAL;
  53.       (* a[j] = ideal # of runs on file j *)
  54.       (* d[j] = # of dummy runs on file *)
  55.       (* last[j] = key of tail item on tape *)
  56.       (* t,ta = mappings of tape #'s *)
  57.  
  58.   PROCEDURE selectfile;
  59.   VAR i: tapeno;
  60.       z: CARDINAL;
  61.  
  62.   BEGIN
  63.     IF d[j] < d[j+1] THEN
  64.       INC(j)
  65.     ELSE
  66.       IF d[j] = 0 THEN
  67.         INC(level); z := a[1];
  68.         FOR i := 1 TO n-1 DO
  69.           d[i] := z + a[i+1] - a[i];
  70.           a[i] := z + a[i+1]
  71.         END
  72.       END;
  73.       j := 1
  74.     END;
  75.     DEC(d[j]);
  76.   END selectfile;  
  77.   
  78.   PROCEDURE copyrun;
  79.   VAR buf,next: item;
  80.       high,low : CARDINAL; 
  81.  
  82.   BEGIN (*copy one run from x to y*)
  83.     ReadByteBlock(f0,next);
  84.     REPEAT
  85.       buf := next;
  86.       IF NOT f0.eof THEN
  87.         WriteByteBlock(f[j],buf);
  88.         GetPos(f0,high,low);
  89.         ReadByteBlock(f0,next);
  90.       END;
  91.     UNTIL f0.eof OR (buf.key > next.key);
  92.     IF NOT f0.eof THEN SetPos(f0,high,low) END;
  93.     last[j] := buf.key
  94.   END copyrun;
  95.  
  96. BEGIN  (* polyphasesort *)
  97.   FOR i := 1 TO n(* -1 *) DO
  98.     a[i] := 1; d[i] := 1;
  99.     Create(f[i],'DK.')
  100.   END;
  101.   level := 1; j := 1;
  102.   a[n] := 0; d[n] := 0;
  103.   REPEAT
  104.     selectfile;
  105.     copyrun;
  106.   UNTIL f0.eof OR (j = n-1);
  107.   LOOP
  108.     IF f0.eof THEN EXIT END;
  109.     selectfile;
  110.     GetPos(f0,high,low);
  111.     ReadByteBlock(f0,next);
  112.     SetPos(f0,high,low);
  113.     IF last[j] <= next.key THEN
  114.       copyrun;
  115.       IF f0.eof THEN d[j] := d[j]+1 ELSE copyrun END
  116.     ELSE copyrun
  117.     END
  118.   END;
  119.   FOR i := 1 TO n-1 DO Reset(f[i]) END;
  120.  
  121.   FOR i := 1 TO n DO t[i] := i END;
  122.   REPEAT
  123.     z := a[n-1]; d[n] := 0;
  124.     Close(f[t[n]]); Create(f[t[n]],'DK.');
  125.     WriteString(' level'); WriteCard(level,4); WriteLn;
  126.     WriteString(' tape'); WriteCard(t[n],4); WriteLn;
  127.     FOR i := 1 TO n DO
  128.       WriteCard(t[i],6);
  129.       WriteCard(a[i],6);
  130.       WriteCard(d[i],6);
  131.       WriteLn
  132.     END;
  133.     REPEAT
  134.       k := 0;
  135.       FOR i := 1 TO n-1 DO
  136.         IF d[i] > 0 THEN
  137.           DEC(d[i])
  138.         ELSE
  139.           INC(k);
  140.           ta[k] := t[i]
  141.         END
  142.       END;
  143.       IF k = 0 THEN
  144.         INC(d[n])
  145.       ELSE
  146.         REPEAT
  147.           i := 1; mx := 1;
  148.           GetPos(f[ta[1]],high,low);
  149.           ReadByteBlock(f[ta[1]],next);
  150.           SetPos(f[ta[1]],high,low);
  151.           min := next.key;
  152.           WHILE i < k DO
  153.             INC(i);
  154.             GetPos(f[ta[i]],high,low);
  155.             ReadByteBlock(f[ta[i]],next);
  156.             SetPos(f[ta[i]],high,low);
  157.             x := next.key;
  158.             IF x < min THEN
  159.               min := x;
  160.               mx := i
  161.             END
  162.           END;
  163.           (* ta[mx] has minimal element, move it to t[j] *)
  164.           ReadByteBlock(f[ta[mx]],buf);
  165.           WriteByteBlock(f[t[n]],buf);
  166.           GetPos(f[ta[mx]],high,low);
  167.           ReadByteBlock(f[ta[mx]],next);
  168.           eot := f[ta[mx]].eof;
  169.           SetPos(f[ta[mx]],high,low);
  170.           IF (buf.key > next.key) OR eot THEN
  171.             ta[mx] := ta[k];
  172.             DEC(k)
  173.           END
  174.         UNTIL k = 0;
  175.       END;
  176.       DEC(z);
  177.     UNTIL z = 0;
  178.     Reset(f[t[n]]);
  179.     list(f[t[n]],t[n]);
  180.     tn := t[n];
  181.     dn := d[n];
  182.     z := a[n-1];
  183.     FOR i := n TO 2 BY -1 DO
  184.       t[i] := t[i-1];
  185.       d[i] := d[i-1];
  186.       a[i] := a[i-1] - z
  187.     END;
  188.     t[1] := tn;
  189.     d[1] := dn;
  190.     a[1] := z;
  191.     DEC(level)
  192.   UNTIL level = 0;
  193. END polyphasesort;
  194.  
  195. BEGIN
  196.   leng := numrecs;
  197.   Lookup(f0,'tmp.TEXT',TRUE);
  198.   IF f0.res # done THEN WriteString(' File not opened. ') END;
  199.   REPEAT
  200.     buf.key := leng;
  201.     WriteCard(buf.key,4);
  202.     WriteByteBlock(f0,buf);
  203.     DEC(leng);
  204.     IF (leng MOD 20) = 0 THEN WriteLn END;
  205.   UNTIL leng = 0;
  206.   WriteLn;
  207.   Reset(f0); list(f0,1);
  208.   polyphasesort;
  209.   FOR low := 1 TO n-1 DO Close(f[low]) END;
  210. END  polysort.
  211.