Advertisement
Janilabo

sorting...

Mar 6th, 2015
259
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 9.51 KB | None | 0 0
  1. {$loadlib MIMUPlugin.dll}
  2.  
  3. procedure SelectionSort(var arr: TIntegerArray);
  4. var
  5.   m, c, h, t: Integer;
  6. begin
  7.   for c := 0 to h do
  8.   begin
  9.     m := c;
  10.     for t := (c + 1) to h do
  11.       if (arr[m] < arr[t]) then
  12.         m := t;
  13.     Swap(arr[m], arr[c]);
  14.   end;
  15. end;
  16.  
  17. procedure BubbleSort(var arr: TIntegerArray);
  18. var
  19.   h, j, b, a: Integer;
  20. begin
  21.   if (mAssign(h, High(arr)) > 0) then
  22.   begin
  23.     j := (h - 1);
  24.     for a := 0 to j do
  25.       for b := 1 to h do
  26.         if (arr[(b - 1)] > arr[b]) then
  27.           Swap(arr[(b - 1)], arr[b]);
  28.   end;
  29. end;
  30.  
  31. procedure ShellSort(var arr: TIntegerArray);
  32. var
  33.   l, z, x, b, a: Integer;
  34. begin
  35.   if (mAssign(l, Length(arr)) > 1) then
  36.   begin
  37.     z := (l - 1);
  38.     x := 0;
  39.     while (x < (l div 3)) do
  40.       x := ((x * 3) + 1);
  41.     case (l > 2) of
  42.       True:
  43.       while (x >= 1) do
  44.       begin
  45.         for a := x to z do
  46.         begin
  47.           b := a;
  48.           while ((b >= x) and (arr[b] < arr[(b - x)])) do
  49.           begin
  50.             Swap(arr[b], arr[(b - x)]);
  51.             b := (b - x);
  52.           end;
  53.         end;
  54.         x := (x div 3);
  55.       end;
  56.       False:
  57.       if (arr[0] > arr[1]) then
  58.         Swap(arr[0], arr[1]);
  59.     end;
  60.   end;
  61. end;
  62.  
  63. procedure InsertionSort(var arr: TIntegerArray);
  64. var
  65.   h, a, b: Integer;
  66. begin
  67.   if (mAssign(h, High(arr)) > 0) then
  68.   for a := 1 to h do
  69.     for b := a downto 1 do
  70.       if (arr[(b - 1)] > arr[b]) then
  71.         Swap(arr[(b - 1)], arr[b])
  72.       else
  73.         Break;
  74. end;
  75.  
  76. procedure SortAlg10(var arr: TIntegerArray);
  77. var
  78.   l, h, i, c, s, d: Integer;
  79. begin
  80.   l := Length(arr);
  81.   if (l > 1) then
  82.   begin
  83.     d := 2;
  84.     c := l;
  85.     while (c > 0) do
  86.     begin
  87.       s := 0;
  88.       for i := 0 to (l - c) do
  89.         if (arr[i] > arr[(i + c)]) then
  90.         begin
  91.           Swap(arr[i], arr[(i + c)]);
  92.           s := (s + 1);
  93.         end;
  94.       if (s = 0) then
  95.       begin
  96.         c := (c div d);
  97.         d := (d + 1);
  98.       end;
  99.     end;
  100.   end;
  101. end;
  102.  
  103. procedure SortAlg9(var arr: TIntegerArray);
  104. var
  105.   l, h, i, c, s: Integer;
  106. begin
  107.   l := Length(arr);
  108.   if (l > 1) then
  109.   begin
  110.     c := (l div 2);
  111.     while (c > 0) do
  112.     begin
  113.       s := 0;
  114.       for i := 0 to (l - c) do
  115.         if (arr[i] > arr[(i + c)]) then
  116.         begin
  117.           Swap(arr[i], arr[(i + c)]);
  118.           s := (s + 1);
  119.         end;
  120.       if (s = 0) then
  121.         c := (c div 2);
  122.     end;
  123.   end;
  124. end;
  125.  
  126. procedure SortAlg8(var arr: TIntegerArray);
  127. var
  128.   l, h, i, c, s: Integer;
  129. begin
  130.   l := Length(arr);
  131.   if (l > 1) then
  132.   begin
  133.     c := (l div 2);
  134.     while (c > 0) do
  135.     begin
  136.       s := 0;
  137.       for i := 0 to (l - c) do
  138.         if (arr[i] > arr[(i + c)]) then
  139.         begin
  140.           Swap(arr[i], arr[(i + c)]);
  141.           s := (s + 1);
  142.         end;
  143.       if (s < 2) then
  144.         c := (c div 2);
  145.     end;
  146.   end;
  147. end;
  148.  
  149. procedure SortAlg7(var arr: TIntegerArray);
  150. var
  151.   l, h, i, c, s: Integer;
  152. begin
  153.   l := Length(arr);
  154.   if (l > 1) then
  155.   begin
  156.     c := l;
  157.     while (c > 0) do
  158.     begin
  159.       s := 0;
  160.       for i := 0 to (l - c) do
  161.         if (arr[i] > arr[(i + c)]) then
  162.         begin
  163.           Swap(arr[i], arr[(i + c)]);
  164.           s := (s + 1);
  165.         end;
  166.       if (s < 2) then
  167.         c := (c div 2);
  168.     end;
  169.   end;
  170. end;
  171.  
  172. procedure SortAlg6(var arr: TIntegerArray);
  173. var
  174.   l, h, i, c, s: Integer;
  175. begin
  176.   l := Length(arr);
  177.   if (l > 1) then
  178.   begin
  179.     c := l;
  180.     while (c > 0) do
  181.     begin
  182.       s := 0;
  183.       for i := 0 to (l - c) do
  184.         if (arr[i] > arr[(i + c)]) then
  185.         begin
  186.           Swap(arr[i], arr[(i + c)]);
  187.           s := (s + 1);
  188.         end;
  189.       if (s = 0) then
  190.         c := (c div 2);
  191.     end;
  192.   end;
  193. end;
  194.  
  195. procedure SortAlg5(var arr: TIntegerArray);
  196. var
  197.   l, h, i, j, c, d: Integer;
  198. begin
  199.   h := High(arr);
  200.   if (h < 1) then
  201.     Exit;
  202.   case (h > 1) of
  203.     True:
  204.     for j := 1 to 2 do
  205.       for i := 0 to (h - j) do
  206.         if (arr[i] > arr[(i + j)]) then
  207.           Swap(arr[i], arr[(i + j)]);
  208.     False:
  209.     if (arr[0] > arr[1]) then
  210.       Swap(arr[0], arr[1]);
  211.   end;
  212. end;
  213.  
  214. procedure SortAlg(var arr: TIntegerArray);
  215. var
  216.   l, h, i, c: Integer;
  217. begin
  218.   l := Length(arr);
  219.   for c := l downto 1 do
  220.     for i := 0 to (l - c) do
  221.       if (arr[i] > arr[(i + c)]) then
  222.         Swap(arr[i], arr[(i + c)]);
  223. end;
  224.  
  225. procedure SortAlg4(var arr: TIntegerArray);
  226. var
  227.   l, h, i, c, d: Integer;
  228. begin
  229.   l := Length(arr);
  230.   if (l < 2) then
  231.     Exit;
  232.   d := (l div 2);
  233.   for c := d downto 1 do
  234.     for i := 0 to (l - c) do
  235.       if (arr[i] > arr[(i + c)]) then
  236.         Swap(arr[i], arr[(i + c)]);
  237. end;
  238.  
  239. procedure SortAlg2(var arr: TIntegerArray);
  240. var
  241.   l, h, i, c: Integer;
  242.   s: Boolean;
  243. begin
  244.   l := Length(arr);
  245.   if (l > 1) then
  246.   for c := l downto 1 do
  247.   begin
  248.     for i := 0 to (l - 1) do
  249.     begin
  250.       s := (arr[i] > arr[(i + 1)]);
  251.       if s then
  252.         Break;
  253.     end;
  254.     if not s then
  255.       Break;
  256.     for i := 0 to (l - c) do
  257.       if (arr[i] > arr[(i + c)]) then
  258.         Swap(arr[i], arr[(i + c)]);
  259.   end;
  260. end;
  261.  
  262. procedure SortAlg3(var arr: TIntegerArray);
  263. var
  264.   l, h, i, c: Integer;
  265.   s: Boolean;
  266. begin
  267.   l := Length(arr);
  268.   if (l > 1) then
  269.   for c := (l div 2) downto 1 do
  270.   begin
  271.     for i := 0 to (l - 1) do
  272.     begin
  273.       s := (arr[i] > arr[(i + 1)]);
  274.       if s then
  275.         Break;
  276.     end;
  277.     if not s then
  278.       Break;
  279.     for i := 0 to (l - c) do
  280.       if (arr[i] > arr[(i + c)]) then
  281.         Swap(arr[i], arr[(i + c)]);
  282.   end;
  283. end;
  284.  
  285. procedure QuickSort2(var arr: TIntegerArray; Lo, Hi: Integer); overload;
  286. var
  287.   A, L, R, C, T: Integer;
  288. begin
  289.   repeat
  290.     case ((Hi - Lo) > 16) of
  291.       True:
  292.       begin
  293.         C := arr[((Hi + Lo) shr 1)];
  294.         L := Lo;
  295.         R := Hi;
  296.         repeat
  297.           while (arr[L] < C) do
  298.             Inc(L);
  299.           while (arr[R] > C) do
  300.             Dec(R);
  301.           if (L <= R) then
  302.           begin
  303.             if (L <> R) then
  304.             begin
  305.               T := arr[L];
  306.               arr[L] := arr[R];
  307.               arr[R] := T;
  308.             end;
  309.             Inc(L);
  310.             Dec(R);
  311.           end;
  312.         until (R < L);
  313.         if (R > Lo) then
  314.           mQuickSortII(arr, Lo, R);
  315.         Lo := L;
  316.       end;
  317.       False:
  318.       begin
  319.         A := (Lo + 1);
  320.         for L := A to Hi do
  321.         begin
  322.           T := arr[L];
  323.           R := L;
  324.           while ((R > Lo) and (arr[(R - 1)] > T)) do
  325.           begin
  326.             arr[R] := arr[(R - 1)];
  327.             Dec(R);
  328.           end;
  329.           arr[R] := T;
  330.         end;
  331.         Exit;
  332.       end;
  333.     end;
  334.   until (Hi <= L);
  335. end;
  336.  
  337. procedure QuickSort2(var arr: TIntegerArray); overload;
  338. var
  339.   h: Integer;
  340. begin
  341.   if (mAssign(h, High(arr)) > 0) then
  342.     QuickSort2(arr, 0, h);
  343. end;
  344.  
  345. var
  346.   i, j, k, t: Integer;
  347.   x, y, z: TIntegerArray;
  348.   n: TStringArray;
  349.   a, b, c: string;
  350.  
  351. begin
  352.   ClearDebug;
  353.   n := ['ShellSort', 'QuickSort2', 'SortAlg6', 'SortAlg7', 'SortAlg8', 'SortAlg9'];
  354.   for i := 0 to 999 do
  355.   begin
  356.     x := mRandom(-55500, 55500, RandomRange(50000, 100000), True);
  357.     mQuickSortII(x);
  358.     a := MD5(ToStr(x));
  359.     for j := 0 to 2 do
  360.     begin
  361.       case j of
  362.         0:
  363.         begin
  364.           c := '';
  365.           for k := 0 to 5 do
  366.           begin
  367.             y := mClone(x);
  368.             t := GetSystemTime;
  369.             case k of
  370.               0: ShellSort(y);
  371.               1: QuickSort2(y);
  372.               2: SortAlg6(y);
  373.               3: SortAlg7(y);
  374.               4: SortAlg8(y);
  375.               5: SortAlg9(y);
  376.             end;
  377.             b := MD5(ToStr(y));
  378.             if (a <> b) then
  379.             begin
  380.               WriteLn(n[k], ' FAILED.');
  381.               TerminateScript;
  382.             end;
  383.             c := (c + ' ' + ToStr(GetSystemTime - t) + ' ms. [' + n[k] + ']');
  384.             SetLength(y, 0);
  385.           end;
  386.           WriteLn('SORTED (', Length(x), '):' + c);
  387.         end;
  388.         1:
  389.         begin
  390.           z := mReversed(x);
  391.           c := '';
  392.           for k := 0 to 5 do
  393.           begin
  394.             y := mClone(z);
  395.             t := GetSystemTime;
  396.             case k of
  397.               0: ShellSort(y);
  398.               1: QuickSort2(y);
  399.               2: SortAlg6(y);
  400.               3: SortAlg7(y);
  401.               4: SortAlg8(y);
  402.               5: SortAlg9(y);
  403.             end;
  404.             b := MD5(ToStr(y));
  405.             if (a <> b) then
  406.             begin
  407.               WriteLn(n[k], ' FAILED.');
  408.               TerminateScript;
  409.             end;
  410.             c := (c + ' ' + ToStr(GetSystemTime - t) + ' ms. [' + n[k] + ']');
  411.             SetLength(y, 0);
  412.           end;
  413.           WriteLn('REVERSED (', Length(x), '):' + c);
  414.         end;
  415.         2:
  416.         begin
  417.           z := mClone(x);
  418.           mRandomize(z);
  419.           c := '';
  420.           for k := 0 to 5 do
  421.           begin
  422.             y := mClone(z);
  423.             t := GetSystemTime;
  424.             case k of
  425.               0: ShellSort(y);
  426.               1: QuickSort2(y);
  427.               2: SortAlg6(y);
  428.               3: SortAlg7(y);
  429.               4: SortAlg8(y);
  430.               5: SortAlg9(y);
  431.             end;
  432.             b := MD5(ToStr(y));
  433.             if (a <> b) then
  434.             begin
  435.               WriteLn(n[k], ' FAILED.');
  436.               TerminateScript;
  437.             end;
  438.             c := (c + ' ' + ToStr(GetSystemTime - t) + ' ms. [' + n[k] + ']');
  439.             SetLength(y, 0);
  440.           end;
  441.           WriteLn('SHUFFLED (', Length(x), '):' + c);
  442.         end;
  443.       end;
  444.     end;
  445.     WriteLn('');
  446.   end;
  447.   WriteLn('NO issues. :)');
  448. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement