Delphi 排序算法总结

在工作中，用到了排序。顺便总结了一下。以下排序的各算法，我都验证无误。

包含冒泡排序、摇动排序、梳子排序、标准插入排序、优化的插入排序、

希尔排序、标准归并排序、优化的归并排序、

标准快速排序、无递归的快速排序、随机的快速排序、中间值的快速排序、

堆排序。

unit unit2;  
  
interface  
  
// 冒泡排序  
procedure BubbleSort(var abc: array of Integer);  
  
// 摇动排序  
procedure ShakerSort(var abc: array of Integer);  
  
// 梳子排序  
procedure CombSort(var abc: array of Integer);  
  
// 选择排序  
procedure SelectionSort(var abc: array of Integer);  
  
// 标准插入排序  
procedure InsertionSortStd(var abc: array of Integer);  
  
// 优化的插入排序  
procedure InsertionSort(var abc: array of Integer);  
  
// 希尔排序  
procedure ShellSort(var abc: array of Integer);  
  
// 标准归并排序  
procedure MergeSortStd(var abc: array of Integer);  
  
// 优化的归并排序  
procedure MergeSort(var abc: array of Integer);  
  
// 标准快速排序  
procedure QuickSortStd(var abc: array of Integer);  
  
// 无递归的快速排序  
procedure QuickSortNoRecurse(var abc: array of Integer);  
  
// 随机的快速排序  
procedure QuickSortRandom(var abc: array of Integer);  
  
// 中间值的快速排序  
procedure QuickSortMedian(var abc: array of Integer);  
  
// 优化的插入快速排序  
procedure QuickSort(var abc: array of Integer);  
  
// 堆排序  
procedure HeapSort(var abc: array of Integer);  
  
implementation  
  
// 冒泡排序  
procedure BubbleSort(var abc: array of Integer);  
var  
  i, j: Integer;  
  Temp: Integer;  
  Done: boolean;  
begin  
  for i := 0 to High(abc) do  
  begin  
    Done  := true;  
    for j := High(abc) + 1 downto 0 do  
      if abc[j] < abc[j - 1] then  
      begin  
        Temp       := abc[j];  
        abc[j]     := abc[j - 1];  
        abc[j - 1] := Temp;  
        Done       := false;  
      end;  
    if Done then  
      Exit;  
  end;  
end;  
  
// 梳子排序  
procedure CombSort(var abc: array of Integer);  
var  
  i, j: Integer;  
  Temp: Integer;  
  Done: boolean;  
  Gap:  Integer;  
begin  
  Gap := High(abc);  
  repeat  
    Done := true;  
    Gap  := (longint(Gap) * 10) div 13;  
    if (Gap < 1) then  
      Gap := 1  
    else if (Gap = 9) or (Gap = 10) then  
      Gap := 11;  
    for i := 0 to (High(abc) - Gap) do  
    begin  
      j := i + Gap;  
      if abc[j] < abc[i] then  
      begin  
        Temp   := abc[j];  
        abc[j] := abc[i];  
        abc[i] := Temp;  
        Done   := false;  
      end;  
    end;  
  until Done and (Gap = 1);  
end;  
  
// 标准插入排序  
procedure InsertionSortStd(var abc: array of Integer);  
var  
  i, j: Integer;  
  Temp: Integer;  
begin  
  for i := 0 to High(abc) do  
  begin  
    Temp := abc[i];  
    j    := i;  
    while (j > 0) and (Temp < abc[j - 1]) do  
    begin  
      abc[j] := abc[j - 1];  
      dec(j);  
    end;  
    abc[j] := Temp;  
  end;  
end;  
  
// 优化的插入排序  
procedure InsertionSort(var abc: array of Integer);  
var  
  i, j:       Integer;  
  IndexOfMin: Integer;  
  Temp:       Integer;  
begin  
  IndexOfMin := 0;  
  for i      := 0 to High(abc) do  
    if abc[i] < abc[IndexOfMin] then  
      IndexOfMin := i;  
  if (0 <> IndexOfMin) then  
  begin  
    Temp            := abc[0];  
    abc[0]          := abc[IndexOfMin];  
    abc[IndexOfMin] := Temp;  
  end;  
  for i := 0 + 2 to High(abc) do  
  begin  
    Temp := abc[i];  
    j    := i;  
    while Temp < abc[j - 1] do  
    begin  
      abc[j] := abc[j - 1];  
      dec(j);  
    end;  
    abc[j] := Temp;  
  end;  
end;  
  
// 选择排序  
procedure SelectionSort(var abc: array of Integer);  
var  
  i, j:       Integer;  
  IndexOfMin: Integer;  
  Temp:       Integer;  
begin  
  for i := 0 to High(abc) do  
  begin  
    IndexOfMin := i;  
    for j      := i to High(abc) + 1 do  
      if abc[j] < abc[IndexOfMin] then  
        IndexOfMin  := j;  
    Temp            := abc[i];  
    abc[i]          := abc[IndexOfMin];  
    abc[IndexOfMin] := Temp;  
  end;  
end;  
  
// 摇动排序  
procedure ShakerSort(var abc: array of Integer);  
var  
  i:          Integer;  
  Temp:       Integer;  
  iMin, iMax: Integer;  
begin  
  iMin := 0;  
  iMax := High(abc) - Low(abc) + 1;  
  
  while (iMin < iMax) do  
  begin  
    for i := iMax downto 0 do  
      if abc[i] < abc[i - 1] then  
      begin  
        Temp       := abc[i];  
        abc[i]     := abc[i - 1];  
        abc[i - 1] := Temp;  
      end;  
    inc(iMin);  
    for i := 0 to iMax do  
      if abc[i] < abc[i - 1] then  
      begin  
        Temp       := abc[i];  
        abc[i]     := abc[i - 1];  
        abc[i - 1] := Temp;  
      end;  
    dec(iMax);  
  end;  
end;  
  
// 希尔排序  
procedure ShellSort(var abc: array of Integer);  
var  
  i, j:  Integer;  
  h:     Integer;  
  Temp:  Integer;  
  Ninth: Integer;  
begin  
  h     := 1;  
  Ninth := High(abc) div 9;  
  while (h <= Ninth) do  
    h := (h * 3) + 1;  
  while (h > 0) do  
  begin  
    for i := h to High(abc) do  
    begin  
      Temp := abc[i];  
      j    := i;  
      while (j >= (0 + h)) and (Temp < abc[j - h]) do  
      begin  
        abc[j] := abc[j - h];  
        dec(j, h);  
      end;  
      abc[j] := Temp;  
    end;  
    h := h div 3;  
  end;  
end;  
  
// 标准归并排序  
procedure MergeSortStd(var abc: array of Integer);  
  procedure MSS(var abc: array of Integer; aFirst: Integer; aLast: Integer; aTempList: array of Integer);  
  var  
    Mid:        Integer;  
    i, j:       Integer;  
    ToInx:      Integer;  
    FirstCount: Integer;  
  begin  
    Mid := (aFirst + aLast) div 2;  
    if (aFirst < Mid) then  
      MSS(abc, aFirst, Mid, aTempList);  
    if (succ(Mid) < aLast) then  
      MSS(abc, succ(Mid), aLast, aTempList);  
    FirstCount := succ(Mid - aFirst);  
    Move(abc[aFirst], aTempList[0], FirstCount * sizeof(pointer));  
    i     := 0;  
    j     := succ(Mid);  
    ToInx := aFirst;  
    while (i < FirstCount) and (j <= aLast) do  
    begin  
      if (aTempList[i] <= abc[j]) then  
      begin  
        abc[ToInx] := aTempList[i];  
        inc(i);  
      end  
      else  
      begin  
        abc[ToInx] := abc[j];  
        inc(j);  
      end;  
      inc(ToInx);  
    end;  
    if (i < FirstCount) then  
      Move(aTempList[i], abc[ToInx], (FirstCount - i) * sizeof(pointer));  
  end;  
  
var  
  TempList: array of Integer;  
begin  
  if (0 < High(abc)) then  
  begin  
    SetLength(TempList, High(abc) div 2);  
    MSS(abc, 0, High(abc), TempList);  
  end;  
end;  
  
// 优化的归并排序  
procedure MergeSort(var abc: array of Integer);  
const  
  MSCutOff = 15;  
  
  procedure MSInsertionSort(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    i, j:       Integer;  
    IndexOfMin: Integer;  
    Temp:       Integer;  
  begin  
    IndexOfMin := aFirst;  
    for i      := succ(aFirst) to aLast do  
      if abc[i] < abc[IndexOfMin] then  
        IndexOfMin := i;  
    if (aFirst <> IndexOfMin) then  
    begin  
      Temp            := abc[aFirst];  
      abc[aFirst]     := abc[IndexOfMin];  
      abc[IndexOfMin] := Temp;  
    end;  
    for i := aFirst + 2 to aLast do  
    begin  
      Temp := abc[i];  
      j    := i;  
      while Temp < abc[j - 1] do  
      begin  
        abc[j] := abc[j - 1];  
        dec(j);  
      end;  
      abc[j] := Temp;  
    end;  
  end;  
  
  procedure MS(var abc: array of Integer; aFirst: Integer; aLast: Integer; aTempList: array of Integer);  
  var  
    Mid:        Integer;  
    i, j:       Integer;  
    ToInx:      Integer;  
    FirstCount: Integer;  
  begin  
    Mid := (aFirst + aLast) div 2;  
    if (aFirst < Mid) then  
      if (Mid - aFirst) <= MSCutOff then  
        MSInsertionSort(abc, aFirst, Mid)  
      else  
        MS(abc, aFirst, Mid, aTempList);  
    if (succ(Mid) < aLast) then  
      if (aLast - succ(Mid)) <= MSCutOff then  
        MSInsertionSort(abc, succ(Mid), aLast)  
      else  
        MS(abc, succ(Mid), aLast, aTempList);  
    FirstCount := succ(Mid - aFirst);  
    Move(abc[aFirst], aTempList[0], FirstCount * sizeof(pointer));  
    i     := 0;  
    j     := succ(Mid);  
    ToInx := aFirst;  
    while (i < FirstCount) and (j <= aLast) do  
    begin  
      if (aTempList[i] <= abc[j]) then  
      begin  
        abc[ToInx] := aTempList[i];  
        inc(i);  
      end  
      else  
      begin  
        abc[ToInx] := abc[j];  
        inc(j);  
      end;  
      inc(ToInx);  
    end;  
    if (i < FirstCount) then  
      Move(aTempList[i], abc[ToInx], (FirstCount - i) * sizeof(pointer));  
  end;  
  
var  
  TempList: array of Integer;  
begin  
  if (0 < High(abc)) then  
  begin  
    SetLength(TempList, High(abc) div 2);  
    MS(abc, 0, High(abc), TempList);  
  end;  
end;  
  
// 标准快速排序  
procedure QuickSortStd(var abc: array of Integer);  
  procedure QSS(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    L, R:  Integer;  
    Pivot: Integer;  
    Temp:  Integer;  
  begin  
    while (aFirst < aLast) do  
    begin  
      Pivot := abc[(aFirst + aLast) div 2];  
      L     := pred(aFirst);  
      R     := succ(aLast);  
      while true do  
      begin  
        repeat  
          dec(R);  
        until (abc[R] <= Pivot);  
  
        repeat  
          inc(L);  
        until (abc[L] >= Pivot);  
  
        if (L >= R) then  
          Break;  
  
        Temp   := abc[L];  
        abc[L] := abc[R];  
        abc[R] := Temp;  
      end;  
      if (aFirst < R) then  
        QSS(abc, aFirst, R);  
      aFirst := succ(R);  
    end;  
  end;  
  
begin  
  QSS(abc, 0, High(abc));  
end;  
  
// 无递归的快速排序  
procedure QuickSortNoRecurse(var abc: array of Integer);  
  procedure QSNR(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    L, R:  Integer;  
    Pivot: Integer;  
    Temp:  Integer;  
    Stack: array [0 .. 63] of Integer; { allows for 2 billion items }  
    SP:    Integer;  
  begin  
    Stack[0] := aFirst;  
    Stack[1] := aLast;  
    SP       := 2;  
    while (SP <> 0) do  
    begin  
      dec(SP, 2);  
      aFirst := Stack[SP];  
      aLast  := Stack[SP + 1];  
      while (aFirst < aLast) do  
      begin  
        Pivot := abc[(aFirst + aLast) div 2];  
        L     := pred(aFirst);  
        R     := succ(aLast);  
        while true do  
        begin  
          repeat  
            dec(R);  
          until (abc[R] <= Pivot);  
          repeat  
            inc(L);  
          until (abc[L] >= Pivot);  
          if (L >= R) then  
            Break;  
          Temp   := abc[L];  
          abc[L] := abc[R];  
          abc[R] := Temp;  
        end;  
        if (R - aFirst) < (aLast - R) then  
        begin  
          Stack[SP]     := succ(R);  
          Stack[SP + 1] := aLast;  
          inc(SP, 2);  
          aLast := R;  
        end  
        else  
        begin  
          Stack[SP]     := aFirst;  
          Stack[SP + 1] := R;  
          inc(SP, 2);  
          aFirst := succ(R);  
        end;  
      end;  
    end;  
  end;  
  
begin  
  QSNR(abc, 0, High(abc));  
end;  
  
// 随机的快速排序  
procedure QuickSortRandom(var abc: array of Integer);  
  procedure QSR(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    L, R:  Integer;  
    Pivot: Integer;  
    Temp:  Integer;  
  begin  
    while (aFirst < aLast) do  
    begin  
      R      := aFirst + Random(aLast - aFirst + 1);  
      L      := (aFirst + aLast) div 2;  
      Pivot  := abc[R];  
      abc[R] := abc[L];  
      abc[L] := Pivot;  
      L      := pred(aFirst);  
      R      := succ(aLast);  
      while true do  
      begin  
        repeat  
          dec(R);  
        until (abc[R] <= Pivot);  
        repeat  
          inc(L);  
        until (abc[L] >= Pivot);  
        if (L >= R) then  
          Break;  
        Temp   := abc[L];  
        abc[L] := abc[R];  
        abc[R] := Temp;  
      end;  
      if (aFirst < R) then  
        QSR(abc, aFirst, R);  
      aFirst := succ(R);  
    end;  
  end;  
  
begin  
  QSR(abc, 0, High(abc));  
end;  
  
// 中间值的快速排序  
procedure QuickSortMedian(var abc: array of Integer);  
  procedure QSM(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    L, R:  Integer;  
    Pivot: Integer;  
    Temp:  Integer;  
  begin  
    while (aFirst < aLast) do  
    begin  
      if (aLast - aFirst) >= 2 then  
      begin  
        R := (aFirst + aLast) div 2;  
        if (abc[aFirst] > abc[R]) then  
        begin  
          Temp        := abc[aFirst];  
          abc[aFirst] := abc[R];  
          abc[R]      := Temp;  
        end;  
        if (abc[aFirst] > abc[aLast]) then  
        begin  
          Temp        := abc[aFirst];  
          abc[aFirst] := abc[aLast];  
          abc[aLast]  := Temp;  
        end;  
        if (abc[R] > abc[aLast]) then  
        begin  
          Temp       := abc[R];  
          abc[R]     := abc[aLast];  
          abc[aLast] := Temp;  
        end;  
        Pivot := abc[R];  
      end  
      else  
        Pivot := abc[aFirst];  
      L       := pred(aFirst);  
      R       := succ(aLast);  
      while true do  
      begin  
        repeat  
          dec(R);  
        until (abc[R] <= Pivot);  
        repeat  
          inc(L);  
        until (abc[L] >= Pivot);  
        if (L >= R) then  
          Break;  
        Temp   := abc[L];  
        abc[L] := abc[R];  
        abc[R] := Temp;  
      end;  
      if (aFirst < R) then  
        QSM(abc, aFirst, R);  
      aFirst := succ(R);  
    end;  
  end;  
  
begin  
  QSM(abc, 0, High(abc));  
end;  
  
// 优化插入的快速排序  
procedure QuickSort(var abc: array of Integer);  
const  
  QSCutOff = 15;  
  
  procedure QSInsertionSort(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    i, j:       Integer;  
    IndexOfMin: Integer;  
    Temp:       Integer;  
  begin  
    IndexOfMin := aFirst;  
    j          := aFirst + QSCutOff; { !!.01 }  
    if (j > aLast) then  
      j   := aLast;  
    for i := succ(aFirst) to j do  
      if abc[i] < abc[IndexOfMin] then  
        IndexOfMin := i;  
    if (aFirst <> IndexOfMin) then  
    begin  
      Temp            := abc[aFirst];  
      abc[aFirst]     := abc[IndexOfMin];  
      abc[IndexOfMin] := Temp;  
    end;  
    { now sort via fast insertion method }  
    for i := aFirst + 2 to aLast do  
    begin  
      Temp := abc[i];  
      j    := i;  
      while Temp < abc[j - 1] do  
      begin  
        abc[j] := abc[j - 1];  
        dec(j);  
      end;  
      abc[j] := Temp;  
    end;  
  end;  
  
  procedure QS(var abc: array of Integer; aFirst: Integer; aLast: Integer);  
  var  
    L, R:  Integer;  
    Pivot: Integer;  
    Temp:  Integer;  
    Stack: array [0 .. 63] of Integer; { allows for 2 billion items }  
    SP:    Integer;  
  begin  
    Stack[0] := aFirst;  
    Stack[1] := aLast;  
    SP       := 2;  
  
    while (SP <> 0) do  
    begin  
      dec(SP, 2);  
      aFirst := Stack[SP];  
      aLast  := Stack[SP + 1];  
  
      while ((aLast - aFirst) > QSCutOff) do  
      begin  
        R := (aFirst + aLast) div 2;  
        if (abc[aFirst] > abc[R]) then  
        begin  
          Temp        := abc[aFirst];  
          abc[aFirst] := abc[R];  
          abc[R]      := Temp;  
        end;  
        if (abc[aFirst] > abc[aLast]) then  
        begin  
          Temp        := abc[aFirst];  
          abc[aFirst] := abc[aLast];  
          abc[aLast]  := Temp;  
        end;  
        if (abc[R] > abc[aLast]) then  
        begin  
          Temp       := abc[R];  
          abc[R]     := abc[aLast];  
          abc[aLast] := Temp;  
        end;  
        Pivot := abc[R];  
  
        L := aFirst;  
        R := aLast;  
        while true do  
        begin  
          repeat  
            dec(R);  
          until (abc[R] <= Pivot);  
          repeat  
            inc(L);  
          until (abc[L] >= Pivot);  
          if (L >= R) then  
            Break;  
          Temp   := abc[L];  
          abc[L] := abc[R];  
          abc[R] := Temp;  
        end;  
  
        if (R - aFirst) < (aLast - R) then  
        begin  
          Stack[SP]     := succ(R);  
          Stack[SP + 1] := aLast;  
          inc(SP, 2);  
          aLast := R;  
        end  
        else  
        begin  
          Stack[SP]     := aFirst;  
          Stack[SP + 1] := R;  
          inc(SP, 2);  
          aFirst := succ(R);  
        end;  
      end;  
    end;  
  end;  
  
begin  
  QS(abc, 0, High(abc));  
  QSInsertionSort(abc, 0, High(abc));  
end;  
  
// 堆排序  
procedure HeapSort(var abc: array of Integer);  
  procedure HSTrickleDown(var abc: array of Integer; root, count: Integer);  
  var  
    KKK: Integer;  
  begin  
    abc[0] := abc[root];  
    KKK    := 2 * root;  
    while KKK <= count do  
    begin  
      if (KKK < count) and (abc[KKK] < abc[KKK + 1]) then  
        inc(KKK);  
      if abc[0] < abc[KKK] then  
      begin  
        abc[root] := abc[KKK];  
        root      := KKK;  
        KKK       := 2 * root;  
      end  
      else  
        KKK := count + 1;  
    end;  
    abc[root] := abc[0];  
  end;  
  
var  
  Inx:       Integer;  
  ItemCount: Integer;  
  tmp:       Integer;  
begin  
  ItemCount := High(abc) - Low(abc) + 1;  
  for Inx   := ItemCount div 2 downto 1 do  
  begin  
    HSTrickleDown(abc, Inx, ItemCount);  
  end;  
  
  for Inx := ItemCount downto 2 do  
  begin  
    tmp      := abc[1];  
    abc[1]   := abc[Inx];  
    abc[Inx] := tmp;  
    HSTrickleDown(abc, 1, Inx - 1);  
  end;  
end;  
  
end.