home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / txtutl / sortdemo.arc / HEAP.PAS < prev    next >
Pascal/Delphi Source File  |  1987-09-03  |  3KB  |  133 lines
  1.                                             { K.L. Noell, fhw  03.Sep.87 }
  2.   Program HeapSort_Demo (output);
  3.  
  4.   CONST n = 639;                   {  number of columns :  x-coordinates }
  5.         range = 199;               {  actual values :      y-coordinates }
  6.         clear_pixel = 0;
  7.         set_pixel   = 3;
  8.  
  9.   VAR
  10.         k: INTEGER;
  11.         num,loops,swaps,aloops,aswaps: REAL;
  12.         D : ARRAY [1..n] OF INTEGER;
  13.  
  14.  
  15.   PROCEDURE Swap ( VAR x,y: INTEGER );
  16.   VAR
  17.         temp: INTEGER;
  18.  
  19.   BEGIN
  20.         temp := x;
  21.         x := y;
  22.         y := temp;
  23.         swaps := swaps + 1;
  24.   END;  { Swap }
  25.  
  26.  
  27.   PROCEDURE HeapSort;
  28.   VAR
  29.        h,i,j,l,r: INTEGER;
  30.        continue : BOOLEAN;
  31.  
  32.   BEGIN
  33.        l := (n DIV 2) + 1;
  34.        r := n;
  35.        REPEAT
  36.           loops := loops + 1;
  37.              IF l > 1 THEN
  38.                 l := l -1
  39.              ELSE
  40.                 IF r > 1 THEN
  41.                    BEGIN
  42.                    Plot (l,d[l],clear_pixel);
  43.                    Plot (r,D[r],clear_pixel);
  44.                    Swap (D[l],D[r]);
  45.                    Plot (l,d[l],set_pixel);
  46.                    Plot (r,D[r],set_pixel);
  47.                    r := r - 1;
  48.                    END;
  49.  
  50.         { next element moves through the heap: }
  51.           i := l;
  52.           j := 2*i;
  53.           h := D[i];
  54.           continue := j<=r;
  55.  
  56.           WHILE continue DO BEGIN
  57.              loops := loops + 1;
  58.              IF j < r THEN
  59.                 IF D[j] < D[j+1] THEN j := j+1;
  60.              IF j <= r THEN
  61.                 continue := H < D[j] ELSE continue := FALSE;
  62.              IF continue THEN
  63.                  BEGIN       { Einordnung }
  64.                     Plot (i,d[i],clear_pixel);
  65.                     D[i] := D[j];
  66.                     Plot (i,d[i],set_pixel);
  67.                     i := j;
  68.                     j := 2*i;
  69.                  END;
  70.           END;  { WHILE continue }
  71.  
  72.           Plot (i,D[i],clear_pixel);
  73.           D[i] := h;
  74.           Plot (i,D[i],set_pixel);
  75.        UNTIL r = 1;
  76.   END;   { HeapSort }
  77.  
  78. { ----------------------------------------- }
  79.  
  80.  BEGIN  (************  Mainrogram  HeapSort_Demo ******************)
  81.  
  82.       HiRes;
  83.       HiResColor (Magenta);
  84.  
  85.       FOR k:=1 to n DO BEGIN
  86.           num := range*RANDOM;
  87.           D [k] := TRUNC (num);
  88.           Plot (k,D[k],set_pixel);
  89.       END;
  90.  
  91.       GraphBackground (Magenta);
  92.       Palette (2);
  93.  
  94.     {Sorting start:}
  95.      loops := 0;
  96.      swaps := 0;
  97.      DELAY (1000);
  98.  
  99.      HeapSort;
  100.  
  101.      aloops := loops;
  102.      aswaps := swaps;
  103.      Writeln ('   Heap Sort a)  Loops,Swaps: ',loops,swaps);
  104.      Writeln;
  105.      Writeln ('b) Press any key to process with an array already sorted,');
  106.      Writeln ('   but in opposite direction.');
  107.  
  108.      REPEAT UNTIL KeyPressed;
  109.  
  110.      Hires;
  111.      FOR k:=1 TO n DO BEGIN
  112.          num := (n-k)/(n/range);
  113.          D [k] := TRUNC (num);
  114.          Plot (k,D[k],set_pixel);
  115.      END;
  116.  
  117.    {Sorting start:}
  118.      loops := 0;
  119.      swaps := 0;
  120.      DELAY (1000);
  121.  
  122.      HeapSort;
  123.  
  124.      Writeln ('   Heap Sort a)  Loops,Swaps: ',aloops,aswaps);
  125.      Writeln ('   Heap Sort b)  Loops,Swaps: ',loops,swaps);
  126.      Writeln;
  127.      Writeln ('   Press any key to exit.');
  128.  
  129.      REPEAT UNTIL KeyPressed;
  130.      TextMode;
  131.  
  132.  END.   (************  Mainrogram  BubbleSort_Demo ******************)
  133.