1 unit unit2;  2   3 interface  4   5 // 冒泡排序  6 procedure BubbleSort(var abc: array of Integer);  7   8 // 摇动排序  9 procedure ShakerSort(var abc: array of Integer); 10  11 // 梳子排序 12 procedure CombSort(var abc: array of Integer); 13  14 // 选择排序 15 procedure SelectionSort(var abc: array of Integer); 16  17 // 标准插入排序 18 procedure InsertionSortStd(var abc: array of Integer); 19  20 // 优化的插入排序 21 procedure InsertionSort(var abc: array of Integer); 22  23 // 希尔排序 24 procedure ShellSort(var abc: array of Integer); 25  26 // 标准归并排序 27 procedure MergeSortStd(var abc: array of Integer); 28  29 // 优化的归并排序 30 procedure MergeSort(var abc: array of Integer); 31  32 // 标准快速排序 33 procedure QuickSortStd(var abc: array of Integer); 34  35 // 无递归的快速排序 36 procedure QuickSortNoRecurse(var abc: array of Integer); 37  38 // 随机的快速排序 39 procedure QuickSortRandom(var abc: array of Integer); 40  41 // 中间值的快速排序 42 procedure QuickSortMedian(var abc: array of Integer); 43  44 // 优化的插入快速排序 45 procedure QuickSort(var abc: array of Integer); 46  47 // 堆排序 48 procedure HeapSort(var abc: array of Integer); 49  50 implementation 51  52 // 冒泡排序 53 procedure BubbleSort(var abc: array of Integer); 54 var 55   i, j: Integer; 56   Temp: Integer; 57   Done: boolean; 58 begin 59   for i := 0 to High(abc) do 60   begin 61     Done  := true; 62     for j := High(abc) + 1 downto 0 do 63       if abc[j] < abc[j - 1] then 64       begin 65         Temp       := abc[j]; 66         abc[j]     := abc[j - 1]; 67         abc[j - 1] := Temp; 68         Done       := false; 69       end; 70     if Done then 71       Exit; 72   end; 73 end; 74  75 // 梳子排序 76 procedure CombSort(var abc: array of Integer); 77 var 78   i, j: Integer; 79   Temp: Integer; 80   Done: boolean; 81   Gap:  Integer; 82 begin 83   Gap := High(abc); 84   repeat 85     Done := true; 86     Gap  := (longint(Gap) * 10) div 13; 87     if (Gap < 1) then 88       Gap := 1 89     else if (Gap = 9) or (Gap = 10) then 90       Gap := 11; 91     for i := 0 to (High(abc) - Gap) do 92     begin 93       j := i + Gap; 94       if abc[j] < abc[i] then 95       begin 96         Temp   := abc[j]; 97         abc[j] := abc[i]; 98         abc[i] := Temp; 99         Done   := false;100       end;101     end;102   until Done and (Gap = 1);103 end;104 105 // 标准插入排序106 procedure InsertionSortStd(var abc: array of Integer);107 var108   i, j: Integer;109   Temp: Integer;110 begin111   for i := 0 to High(abc) do112   begin113     Temp := abc[i];114     j    := i;115     while (j > 0) and (Temp < abc[j - 1]) do116     begin117       abc[j] := abc[j - 1];118       dec(j);119     end;120     abc[j] := Temp;121   end;122 end;123 124 // 优化的插入排序125 procedure InsertionSort(var abc: array of Integer);126 var127   i, j:       Integer;128   IndexOfMin: Integer;129   Temp:       Integer;130 begin131   IndexOfMin := 0;132   for i      := 0 to High(abc) do133     if abc[i] < abc[IndexOfMin] then134       IndexOfMin := i;135   if (0 <> IndexOfMin) then136   begin137     Temp            := abc[0];138     abc[0]          := abc[IndexOfMin];139     abc[IndexOfMin] := Temp;140   end;141   for i := 0 + 2 to High(abc) do142   begin143     Temp := abc[i];144     j    := i;145     while Temp < abc[j - 1] do146     begin147       abc[j] := abc[j - 1];148       dec(j);149     end;150     abc[j] := Temp;151   end;152 end;153 154 // 选择排序155 procedure SelectionSort(var abc: array of Integer);156 var157   i, j:       Integer;158   IndexOfMin: Integer;159   Temp:       Integer;160 begin161   for i := 0 to High(abc) do162   begin163     IndexOfMin := i;164     for j      := i to High(abc) + 1 do165       if abc[j] < abc[IndexOfMin] then166         IndexOfMin  := j;167     Temp            := abc[i];168     abc[i]          := abc[IndexOfMin];169     abc[IndexOfMin] := Temp;170   end;171 end;172 173 // 摇动排序174 procedure ShakerSort(var abc: array of Integer);175 var176   i:          Integer;177   Temp:       Integer;178   iMin, iMax: Integer;179 begin180   iMin := 0;181   iMax := High(abc) - Low(abc) + 1;182 183   while (iMin < iMax) do184   begin185     for i := iMax downto 0 do186       if abc[i] < abc[i - 1] then187       begin188         Temp       := abc[i];189         abc[i]     := abc[i - 1];190         abc[i - 1] := Temp;191       end;192     inc(iMin);193     for i := 0 to iMax do194       if abc[i] < abc[i - 1] then195       begin196         Temp       := abc[i];197         abc[i]     := abc[i - 1];198         abc[i - 1] := Temp;199       end;200     dec(iMax);201   end;202 end;203 204 // 希尔排序205 procedure ShellSort(var abc: array of Integer);206 var207   i, j:  Integer;208   h:     Integer;209   Temp:  Integer;210   Ninth: Integer;211 begin212   h     := 1;213   Ninth := High(abc) div 9;214   while (h <= Ninth) do215     h := (h * 3) + 1;216   while (h > 0) do217   begin218     for i := h to High(abc) do219     begin220       Temp := abc[i];221       j    := i;222       while (j >= (0 + h)) and (Temp < abc[j - h]) do223       begin224         abc[j] := abc[j - h];225         dec(j, h);226       end;227       abc[j] := Temp;228     end;229     h := h div 3;230   end;231 end;232 233 // 标准归并排序234 procedure MergeSortStd(var abc: array of Integer);235   procedure MSS(var abc: array of Integer; aFirst: Integer; aLast: Integer; aTempList: array of Integer);236   var237     Mid:        Integer;238     i, j:       Integer;239     ToInx:      Integer;240     FirstCount: Integer;241   begin242     Mid := (aFirst + aLast) div 2;243     if (aFirst < Mid) then244       MSS(abc, aFirst, Mid, aTempList);245     if (succ(Mid) < aLast) then246       MSS(abc, succ(Mid), aLast, aTempList);247     FirstCount := succ(Mid - aFirst);248     Move(abc[aFirst], aTempList[0], FirstCount * sizeof(pointer));249     i     := 0;250     j     := succ(Mid);251     ToInx := aFirst;252     while (i < FirstCount) and (j <= aLast) do253     begin254       if (aTempList[i] <= abc[j]) then255       begin256         abc[ToInx] := aTempList[i];257         inc(i);258       end259       else260       begin261         abc[ToInx] := abc[j];262         inc(j);263       end;264       inc(ToInx);265     end;266     if (i < FirstCount) then267       Move(aTempList[i], abc[ToInx], (FirstCount - i) * sizeof(pointer));268   end;269 270 var271   TempList: array of Integer;272 begin273   if (0 < High(abc)) then274   begin275     SetLength(TempList, High(abc) div 2);276     MSS(abc, 0, High(abc), TempList);277   end;278 end;279 280 // 优化的归并排序281 procedure MergeSort(var abc: array of Integer);282 const283   MSCutOff = 15;284 285   procedure MSInsertionSort(var abc: array of Integer; aFirst: Integer; aLast: Integer);286   var287     i, j:       Integer;288     IndexOfMin: Integer;289     Temp:       Integer;290   begin291     IndexOfMin := aFirst;292     for i      := succ(aFirst) to aLast do293       if abc[i] < abc[IndexOfMin] then294         IndexOfMin := i;295     if (aFirst <> IndexOfMin) then296     begin297       Temp            := abc[aFirst];298       abc[aFirst]     := abc[IndexOfMin];299       abc[IndexOfMin] := Temp;300     end;301     for i := aFirst + 2 to aLast do302     begin303       Temp := abc[i];304       j    := i;305       while Temp < abc[j - 1] do306       begin307         abc[j] := abc[j - 1];308         dec(j);309       end;310       abc[j] := Temp;311     end;312   end;313 314   procedure MS(var abc: array of Integer; aFirst: Integer; aLast: Integer; aTempList: array of Integer);315   var316     Mid:        Integer;317     i, j:       Integer;318     ToInx:      Integer;319     FirstCount: Integer;320   begin321     Mid := (aFirst + aLast) div 2;322     if (aFirst < Mid) then323       if (Mid - aFirst) <= MSCutOff then324         MSInsertionSort(abc, aFirst, Mid)325       else326         MS(abc, aFirst, Mid, aTempList);327     if (succ(Mid) < aLast) then328       if (aLast - succ(Mid)) <= MSCutOff then329         MSInsertionSort(abc, succ(Mid), aLast)330       else331         MS(abc, succ(Mid), aLast, aTempList);332     FirstCount := succ(Mid - aFirst);333     Move(abc[aFirst], aTempList[0], FirstCount * sizeof(pointer));334     i     := 0;335     j     := succ(Mid);336     ToInx := aFirst;337     while (i < FirstCount) and (j <= aLast) do338     begin339       if (aTempList[i] <= abc[j]) then340       begin341         abc[ToInx] := aTempList[i];342         inc(i);343       end344       else345       begin346         abc[ToInx] := abc[j];347         inc(j);348       end;349       inc(ToInx);350     end;351     if (i < FirstCount) then352       Move(aTempList[i], abc[ToInx], (FirstCount - i) * sizeof(pointer));353   end;354 355 var356   TempList: array of Integer;357 begin358   if (0 < High(abc)) then359   begin360     SetLength(TempList, High(abc) div 2);361     MS(abc, 0, High(abc), TempList);362   end;363 end;364 365 // 标准快速排序366 procedure QuickSortStd(var abc: array of Integer);367   procedure QSS(var abc: array of Integer; aFirst: Integer; aLast: Integer);368   var369     L, R:  Integer;370     Pivot: Integer;371     Temp:  Integer;372   begin373     while (aFirst < aLast) do374     begin375       Pivot := abc[(aFirst + aLast) div 2];376       L     := pred(aFirst);377       R     := succ(aLast);378       while true do379       begin380         repeat381           dec(R);382         until (abc[R] <= Pivot);383 384         repeat385           inc(L);386         until (abc[L] >= Pivot);387 388         if (L >= R) then389           Break;390 391         Temp   := abc[L];392         abc[L] := abc[R];393         abc[R] := Temp;394       end;395       if (aFirst < R) then396         QSS(abc, aFirst, R);397       aFirst := succ(R);398     end;399   end;400 401 begin402   QSS(abc, 0, High(abc));403 end;404 405 // 无递归的快速排序406 procedure QuickSortNoRecurse(var abc: array of Integer);407   procedure QSNR(var abc: array of Integer; aFirst: Integer; aLast: Integer);408   var409     L, R:  Integer;410     Pivot: Integer;411     Temp:  Integer;412     Stack: array [0 .. 63] of Integer; {
     allows for 2 billion items }413     SP:    Integer;414   begin415     Stack[0] := aFirst;416     Stack[1] := aLast;417     SP       := 2;418     while (SP <> 0) do419     begin420       dec(SP, 2);421       aFirst := Stack[SP];422       aLast  := Stack[SP + 1];423       while (aFirst < aLast) do424       begin425         Pivot := abc[(aFirst + aLast) div 2];426         L     := pred(aFirst);427         R     := succ(aLast);428         while true do429         begin430           repeat431             dec(R);432           until (abc[R] <= Pivot);433           repeat434             inc(L);435           until (abc[L] >= Pivot);436           if (L >= R) then437             Break;438           Temp   := abc[L];439           abc[L] := abc[R];440           abc[R] := Temp;441         end;442         if (R - aFirst) < (aLast - R) then443         begin444           Stack[SP]     := succ(R);445           Stack[SP + 1] := aLast;446           inc(SP, 2);447           aLast := R;448         end449         else450         begin451           Stack[SP]     := aFirst;452           Stack[SP + 1] := R;453           inc(SP, 2);454           aFirst := succ(R);455         end;456       end;457     end;458   end;459 460 begin461   QSNR(abc, 0, High(abc));462 end;463 464 // 随机的快速排序465 procedure QuickSortRandom(var abc: array of Integer);466   procedure QSR(var abc: array of Integer; aFirst: Integer; aLast: Integer);467   var468     L, R:  Integer;469     Pivot: Integer;470     Temp:  Integer;471   begin472     while (aFirst < aLast) do473     begin474       R      := aFirst + Random(aLast - aFirst + 1);475       L      := (aFirst + aLast) div 2;476       Pivot  := abc[R];477       abc[R] := abc[L];478       abc[L] := Pivot;479       L      := pred(aFirst);480       R      := succ(aLast);481       while true do482       begin483         repeat484           dec(R);485         until (abc[R] <= Pivot);486         repeat487           inc(L);488         until (abc[L] >= Pivot);489         if (L >= R) then490           Break;491         Temp   := abc[L];492         abc[L] := abc[R];493         abc[R] := Temp;494       end;495       if (aFirst < R) then496         QSR(abc, aFirst, R);497       aFirst := succ(R);498     end;499   end;500 501 begin502   QSR(abc, 0, High(abc));503 end;504 505 // 中间值的快速排序506 procedure QuickSortMedian(var abc: array of Integer);507   procedure QSM(var abc: array of Integer; aFirst: Integer; aLast: Integer);508   var509     L, R:  Integer;510     Pivot: Integer;511     Temp:  Integer;512   begin513     while (aFirst < aLast) do514     begin515       if (aLast - aFirst) >= 2 then516       begin517         R := (aFirst + aLast) div 2;518         if (abc[aFirst] > abc[R]) then519         begin520           Temp        := abc[aFirst];521           abc[aFirst] := abc[R];522           abc[R]      := Temp;523         end;524         if (abc[aFirst] > abc[aLast]) then525         begin526           Temp        := abc[aFirst];527           abc[aFirst] := abc[aLast];528           abc[aLast]  := Temp;529         end;530         if (abc[R] > abc[aLast]) then531         begin532           Temp       := abc[R];533           abc[R]     := abc[aLast];534           abc[aLast] := Temp;535         end;536         Pivot := abc[R];537       end538       else539         Pivot := abc[aFirst];540       L       := pred(aFirst);541       R       := succ(aLast);542       while true do543       begin544         repeat545           dec(R);546         until (abc[R] <= Pivot);547         repeat548           inc(L);549         until (abc[L] >= Pivot);550         if (L >= R) then551           Break;552         Temp   := abc[L];553         abc[L] := abc[R];554         abc[R] := Temp;555       end;556       if (aFirst < R) then557         QSM(abc, aFirst, R);558       aFirst := succ(R);559     end;560   end;561 562 begin563   QSM(abc, 0, High(abc));564 end;565 566 // 优化插入的快速排序567 procedure QuickSort(var abc: array of Integer);568 const569   QSCutOff = 15;570 571   procedure QSInsertionSort(var abc: array of Integer; aFirst: Integer; aLast: Integer);572   var573     i, j:       Integer;574     IndexOfMin: Integer;575     Temp:       Integer;576   begin577     IndexOfMin := aFirst;578     j          := aFirst + QSCutOff; {
     !!.01 }579     if (j > aLast) then580       j   := aLast;581     for i := succ(aFirst) to j do582       if abc[i] < abc[IndexOfMin] then583         IndexOfMin := i;584     if (aFirst <> IndexOfMin) then585     begin586       Temp            := abc[aFirst];587       abc[aFirst]     := abc[IndexOfMin];588       abc[IndexOfMin] := Temp;589     end;590     {
     now sort via fast insertion method }591     for i := aFirst + 2 to aLast do592     begin593       Temp := abc[i];594       j    := i;595       while Temp < abc[j - 1] do596       begin597         abc[j] := abc[j - 1];598         dec(j);599       end;600       abc[j] := Temp;601     end;602   end;603 604   procedure QS(var abc: array of Integer; aFirst: Integer; aLast: Integer);605   var606     L, R:  Integer;607     Pivot: Integer;608     Temp:  Integer;609     Stack: array [0 .. 63] of Integer; {
     allows for 2 billion items }610     SP:    Integer;611   begin612     Stack[0] := aFirst;613     Stack[1] := aLast;614     SP       := 2;615 616     while (SP <> 0) do617     begin618       dec(SP, 2);619       aFirst := Stack[SP];620       aLast  := Stack[SP + 1];621 622       while ((aLast - aFirst) > QSCutOff) do623       begin624         R := (aFirst + aLast) div 2;625         if (abc[aFirst] > abc[R]) then626         begin627           Temp        := abc[aFirst];628           abc[aFirst] := abc[R];629           abc[R]      := Temp;630         end;631         if (abc[aFirst] > abc[aLast]) then632         begin633           Temp        := abc[aFirst];634           abc[aFirst] := abc[aLast];635           abc[aLast]  := Temp;636         end;637         if (abc[R] > abc[aLast]) then638         begin639           Temp       := abc[R];640           abc[R]     := abc[aLast];641           abc[aLast] := Temp;642         end;643         Pivot := abc[R];644 645         L := aFirst;646         R := aLast;647         while true do648         begin649           repeat650             dec(R);651           until (abc[R] <= Pivot);652           repeat653             inc(L);654           until (abc[L] >= Pivot);655           if (L >= R) then656             Break;657           Temp   := abc[L];658           abc[L] := abc[R];659           abc[R] := Temp;660         end;661 662         if (R - aFirst) < (aLast - R) then663         begin664           Stack[SP]     := succ(R);665           Stack[SP + 1] := aLast;666           inc(SP, 2);667           aLast := R;668         end669         else670         begin671           Stack[SP]     := aFirst;672           Stack[SP + 1] := R;673           inc(SP, 2);674           aFirst := succ(R);675         end;676       end;677     end;678   end;679 680 begin681   QS(abc, 0, High(abc));682   QSInsertionSort(abc, 0, High(abc));683 end;684 685 // 堆排序686 procedure HeapSort(var abc: array of Integer);687   procedure HSTrickleDown(var abc: array of Integer; root, count: Integer);688   var689     KKK: Integer;690   begin691     abc[0] := abc[root];692     KKK    := 2 * root;693     while KKK <= count do694     begin695       if (KKK < count) and (abc[KKK] < abc[KKK + 1]) then696         inc(KKK);697       if abc[0] < abc[KKK] then698       begin699         abc[root] := abc[KKK];700         root      := KKK;701         KKK       := 2 * root;702       end703       else704         KKK := count + 1;705     end;706     abc[root] := abc[0];707   end;708 709 var710   Inx:       Integer;711   ItemCount: Integer;712   tmp:       Integer;713 begin714   ItemCount := High(abc) - Low(abc) + 1;715   for Inx   := ItemCount div 2 downto 1 do716   begin717     HSTrickleDown(abc, Inx, ItemCount);718   end;719 720   for Inx := ItemCount downto 2 do721   begin722     tmp      := abc[1];723     abc[1]   := abc[Inx];724     abc[Inx] := tmp;725     HSTrickleDown(abc, 1, Inx - 1);726   end;727 end;728 729 end.