home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / sorting.swg / 0011_IMROVSRT.PAS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  2.5 KB  |  143 lines
  1. {
  2. MARK OUELLET
  3.  
  4. > I code these things this way:
  5. >
  6. > for I := 1 to MAX-1 do
  7. > for J := I+1 to MAX do
  8. > if A[I] < A[J] then
  9. > begin
  10. > ( swap code )
  11. > end
  12.  
  13.     this can be improved even more. By limiting the MAX value on each
  14. successive loop by keeping track of the highest swaped pair.
  15.  
  16.     If on a particular loop, no swap is performed from element MAX-10
  17. onto the end. Then the next loop does not need to go anyhigher than
  18. MAX-11. Remember you are moving the highest value up, if no swap is
  19. performed from MAX-10 on, it means all values above MAX-11 are in order
  20. and all values below MAX-10 are smaller than MAX-10.
  21. }
  22.  
  23. {$X+}
  24. program MKOSort;
  25.  
  26. USES
  27.   Crt;
  28.  
  29. Const
  30.   MAX = 1000;
  31.  
  32. var
  33.   A : Array[1..MAX] of word;
  34.   Loops : word;
  35.  
  36. procedure Swap(Var A1, A2 : word);
  37. var
  38.   Temp : word;
  39. begin
  40.   Temp := A1;
  41.   A1   := A2;
  42.   A2   := Temp;
  43. end;
  44.  
  45. procedure working;
  46. const
  47.   cursor : array[0..3] of char = '\|/-';
  48.   CurrentCursor : byte = 1;
  49.   Update : word = 0;
  50. begin
  51.   update := (update + 1) mod 2500;
  52.   if update = 0 then
  53.   begin
  54.     DirectVideo := False;
  55.     write(Cursor[CurrentCursor], #13);
  56.     CurrentCursor := ((CurrentCursor + 1) mod 4);
  57.     DirectVideo := true;
  58.   end;
  59. end;
  60.  
  61. procedure Bubble;
  62. var
  63.   Highest,
  64.   Limit, I  : word;
  65.   NotSwaped : boolean;
  66. begin
  67.   Limit := MAX;
  68.   Loops := 0;
  69.   repeat
  70.     I := 1;
  71.     Highest := 2;
  72.     NotSwaped := true;
  73.     repeat
  74.       working;
  75.       if A[I] > A[I + 1] then
  76.       begin
  77.         Highest := I;
  78.         NotSwaped := False;
  79.         Swap(A[I], A[I + 1]);
  80.       end;
  81.       Inc(I);
  82.     until (I = Limit);
  83.     Limit := Highest;
  84.     Inc(Loops);
  85.   until (NotSwaped) or (Limit <= 2);
  86. end;
  87.  
  88. procedure InitArray;
  89. var
  90.   I, J : word;
  91.   Temp : word;
  92. begin
  93.   randomize;
  94.   for I := 1 to MAX do
  95.     A[I] := I;
  96.   for I := MAX - 1 downto 1 do
  97.   begin
  98.     J := random(I) + 1;
  99.     Swap(A[I + 1], A[J]);
  100.   end;
  101. end;
  102.  
  103. procedure Pause;
  104. begin
  105.   writeln;
  106.   writeln('Press any key to continue...');
  107.   while keypressed do
  108.     readkey;
  109.   while not keypressed do;
  110.   readkey;
  111. end;
  112.  
  113. procedure PrintOut;
  114. var
  115.   I : word;
  116. begin
  117.   ClrScr;
  118.   For I := 1 to MAX do
  119.   begin
  120.     if WhereY >= 22 then
  121.     begin
  122.       Pause;
  123.       ClrScr;
  124.     end;
  125.     if (WhereX >= 70) then
  126.       Writeln(A[I] : 5)
  127.     else
  128.       Write(A[I] : 5);
  129.   end;
  130.   writeln;
  131.   Pause;
  132. end;
  133.  
  134. begin
  135.   ClrScr;
  136.   InitArray;
  137.   PrintOut;
  138.   Bubble;
  139.   PrintOut;
  140.   writeln;
  141.   writeln('Took ', Loops, ' Loops to complete');
  142. end.
  143.