stsort.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

  pop esi
end;

procedure TStSorter.sorOpenMergeFiles;
  {-Open a group of up to MergeOrder input files}
begin
  sorMergeOpenCount := 0;
  while (sorMergeOpenCount < MergeOrder) and
    (sorMergeFileMerged < sorMergeFileCount) do begin
    inc(sorMergeOpenCount);
    {Open associated merge file}
    inc(sorMergeFileMerged);
    sorMergeFiles[sorMergeOpenCount] :=
      FileOpen(FMergeName(sorMergeFileMerged), fmOpenRead);
    if sorMergeFiles[sorMergeOpenCount] < 0 then begin
      dec(sorMergeFileMerged);
      dec(sorMergeOpenCount);
      RaiseError(stscFileOpen);
    end;
    {File number of merge file}
    sorMergeFileNumber[sorMergeOpenCount] := sorMergeFileMerged;
    {Selector for merge file}
    sorMergePtrs[sorMergeOpenCount] := PChar(sorBuffer)+
      (sorMergeOpenCount-1)*sorMergeBufSize;
    {Number of bytes currently in merge buffer}
    sorMergeBytesLoaded[sorMergeOpenCount] := 0;
    {Number of bytes used in merge buffer}
    sorMergeBytesUsed[sorMergeOpenCount] := 0;
    {Save the merge pointer}
    sorMergeBases[sorMergeOpenCount] := sorMergePtrs[sorMergeOpenCount];
    {Get the first element}
    sorGetMergeElementPtr(sorMergeOpenCount);
  end;
end;

procedure TStSorter.sorPrimaryMerge;
  {-Merge until there are no more than MergeOrder merge files left}
begin
  sorOutPtr := PChar(sorBuffer)+MergeOrder*sorMergeBufSize;
  while sorMergeFileCount-sorMergeFileMerged > MergeOrder do begin
    {Open next group of MergeOrder files}
    sorOpenMergeFiles;
    {Create new output file}
    sorCreateNewMergeFile(sorOutFile);
    {Merge these files into the output}
    sorMergeFileGroup;
  end;
end;

procedure TStSorter.sorRunSort(L, R : LongInt);
  {-Sort one run buffer full of records in memory using non-recursive QuickSort}
const
  StackSize = 32;
type
  Stack = array[0..StackSize-1] of LongInt;
var
  Pl : LongInt;            {Left edge within partition}
  Pr : LongInt;            {Right edge within partition}
  Pm : LongInt;            {Mid-point of partition}
  PartitionLen : LongInt;  {Size of current partition}
  StackP : Integer;        {Stack pointer}
  Lstack : Stack;          {Pending partitions, left edge}
  Rstack : Stack;          {Pending partitions, right edge}
begin
  {Make sure there's a compare function}
  if @FCompare = nil then
    RaiseError(stscNoCompare);

  {Initialize the stack}
  StackP := 0;
  Lstack[0] := L;
  Rstack[0] := R;

  {Repeatedly take top partition from stack}
  repeat

    {Pop the stack}
    L := Lstack[StackP];
    R := Rstack[StackP];
    Dec(StackP);

    {Sort current partition}
    repeat
      Pl := L;
      Pr := R;
      PartitionLen := Pr-Pl+1;

      {$IFDEF MidPoint}
      Pm := Pl+(PartitionLen shr 1);
      {$ENDIF}

      {$IFDEF Random}
      Pm := Pl+Random(PartitionLen);
      {$ENDIF}

      {$IFDEF Median}
      Pm := Pl+(PartitionLen shr 1);
      if PartitionLen >= MedianThreshold then begin
        {Sort elements Pl, Pm, Pr}
        if FCompare(sorElementPtr(Pm)^, sorElementPtr(Pl)^) < 0 then
          sorSwapElements(Pm, Pl);
        if FCompare(sorElementPtr(Pr)^, sorElementPtr(Pl)^) < 0 then
          sorSwapElements(Pr, Pl);
        if FCompare(sorElementPtr(Pr)^, sorElementPtr(Pm)^) < 0 then
          sorSwapElements(Pr, Pm);

        {Exchange Pm with Pr-1 but use Pm's value as the pivot}
        sorSwapElements(Pm, Pr-1);
        Pm := Pr-1;

        {Reduce range of swapping}
        inc(Pl);
        dec(Pr, 2);
      end;
      {$ENDIF}

      {Save the pivot element}
      sorMoveElement(sorElementPtr(Pm), sorPivotPtr);

      {Swap items in sort order around the pivot}
      repeat
        while FCompare(sorElementPtr(Pl)^, sorPivotPtr^) < 0 do
          Inc(Pl);
        while FCompare(sorPivotPtr^, sorElementPtr(Pr)^) < 0 do
          Dec(Pr);

        if Pl = Pr then begin
          {Reached the pivot}
          Inc(Pl);
          Dec(Pr);
        end else if Pl < Pr then begin
          {Swap elements around the pivot}
          sorSwapElements(Pl, Pr);
          Inc(Pl);
          Dec(Pr);
        end;
      until Pl > Pr;

      {Decide which partition to sort next}
      if (Pr-L) < (R-Pl) then begin
        {Left partition is bigger}
        if Pl < R then begin
          {Stack the request for sorting right partition}
          Inc(StackP);
          Lstack[StackP] := Pl;
          Rstack[StackP] := R;
        end;
        {Continue sorting left partition}
        R := Pr;
      end else begin
        {Right partition is bigger}
        if L < Pr then begin
          {Stack the request for sorting left partition}
          Inc(StackP);
          Lstack[StackP] := L;
          Rstack[StackP] := Pr;
        end;
        {Continue sorting right partition}
        L := Pl;
      end;
    until L >= R;
  until StackP < 0;
end;

procedure TStSorter.sorSetCompare(Comp : TUntypedCompareFunc);
  {-Set the compare function, with error checking}
begin
  if ((FCount <> 0) or (@Comp = nil)) and (@Comp <> @FCompare) then
    RaiseError(stscBadCompare);
  FCompare := Comp;
end;

procedure TStSorter.sorStoreElement(Src : Pointer);
  {-Store element in the merge output buffer}
begin
  if sorOutBytesUsed >= sorMergeBufSize then begin
    sorFlushOutBuffer;
    sorOutBytesUsed := 0;
  end;
  sorMoveElement(Src, PChar(sorOutPtr)+sorOutBytesUsed);
  inc(sorOutBytesUsed, FRecLen);
end;

procedure TStSorter.sorStoreNewMergeFile;
  {-Create new merge file, write run buffer to it, close file}
var
  BytesToWrite, BytesWritten : Integer;
begin
  sorCreateNewMergeFile(sorOutFile);
  try
    BytesToWrite := sorRunCount*LongInt(FRecLen);
    BytesWritten := FileWrite(sorOutFile, sorBuffer^, BytesToWrite);
    if BytesWritten <> BytesToWrite then
      RaiseError(stscFileWrite);
  finally
    {Close merge file}
    FileClose(sorOutFile);
  end;
end;

procedure TStSorter.sorSwapElements(L, R : LongInt);
  {-Swap elements with indexes L and R}
var
  LPtr : Pointer;
  RPtr : Pointer;
begin
  LPtr := sorElementPtr(L);
  RPtr := sorElementPtr(R);
  sorMoveElement(LPtr, sorSwapPtr);
  sorMoveElement(RPtr, LPtr);
  sorMoveElement(sorSwapPtr, RPtr);
end;

procedure ArraySort(var A; RecLen, NumRecs : Cardinal;
                    Compare : TUntypedCompareFunc);
const
  StackSize = 32;
type
  Stack = array[0..StackSize-1] of LongInt;
var
  Pl, Pr, Pm, L, R : LongInt;
  ArraySize, PartitionLen : LongInt;
  PivotPtr : Pointer;
  SwapPtr : Pointer;
  StackP : Integer;
  Lstack, Rstack : Stack;

  function ElementPtr(Index : Cardinal) : Pointer;
  begin
    Result := PChar(@A)+Index*RecLen;
  end;

  procedure SwapElements(L, R : LongInt);
  var
    LPtr : Pointer;
    RPtr : Pointer;
  begin
    LPtr := ElementPtr(L);
    RPtr := ElementPtr(R);
    Move(LPtr^, SwapPtr^, RecLen);
    Move(RPtr^, LPtr^, RecLen);
    Move(SwapPtr^, RPtr^, RecLen);
  end;

begin
  {Make sure there's a compare function}
  if @Compare = nil then
    RaiseError(stscNoCompare);

  {Make sure the array size is reasonable}
  ArraySize := LongInt(RecLen)*LongInt(NumRecs);
  if (ArraySize = 0) {or (ArraySize > MaxBlockSize)} then
    RaiseError(stscBadSize);

  {Get pivot and swap elements}
  GetMem(PivotPtr, RecLen);
  try
    GetMem(SwapPtr, RecLen);
    try
      {Initialize the stack}
      StackP := 0;
      Lstack[0] := 0;
      Rstack[0] := NumRecs-1;

      {Repeatedly take top partition from stack}
      repeat

        {Pop the stack}
        L := Lstack[StackP];
        R := Rstack[StackP];
        Dec(StackP);

        {Sort current partition}
        repeat
          Pl := L;
          Pr := R;
          PartitionLen := Pr-Pl+1;

          {$IFDEF MidPoint}
          Pm := Pl+(PartitionLen shr 1);
          {$ENDIF}

          {$IFDEF Random}
          Pm := Pl+Random(PartitionLen);
          {$ENDIF}

          {$IFDEF Median}
          Pm := Pl+(PartitionLen shr 1);
          if PartitionLen >= MedianThreshold then begin
            {Sort elements Pl, Pm, Pr}
            if Compare(ElementPtr(Pm)^, ElementPtr(Pl)^) < 0 then
              SwapElements(Pm, Pl);
            if Compare(ElementPtr(Pr)^, ElementPtr(Pl)^) < 0 then
              SwapElements(Pr, Pl);
            if Compare(ElementPtr(Pr)^, ElementPtr(Pm)^) < 0 then
              SwapElements(Pr, Pm);

            {Exchange Pm with Pr-1 but use Pm's value as the pivot}
            SwapElements(Pm, Pr-1);
            Pm := Pr-1;

            {Reduce range of swapping}
            inc(Pl);
            dec(Pr, 2);
          end;
          {$ENDIF}

          {Save the pivot element}
          Move(ElementPtr(Pm)^, PivotPtr^, RecLen);

          {Swap items in sort order around the pivot}
          repeat
            while Compare(ElementPtr(Pl)^, PivotPtr^) < 0 do
              Inc(Pl);
            while Compare(PivotPtr^, ElementPtr(Pr)^) < 0 do
              Dec(Pr);

            if Pl = Pr then begin
              {Reached the pivot}
              Inc(Pl);
              Dec(Pr);
            end else if Pl < Pr then begin
              {Swap elements around the pivot}
              SwapElements(Pl, Pr);
              Inc(Pl);
              Dec(Pr);
            end;
          until Pl > Pr;

          {Decide which partition to sort next}
          if (Pr-L) < (R-Pl) then begin
            {Left partition is bigger}
            if Pl < R then begin
              {Stack the request for sorting right partition}
              Inc(StackP);
              Lstack[StackP] := Pl;
              Rstack[StackP] := R;
            end;
            {Continue sorting left partition}
            R := Pr;
          end else begin
            {Right partition is bigger}
            if L < Pr then begin
              {Stack the request for sorting left partition}
              Inc(StackP);
              Lstack[StackP] := L;
              Rstack[StackP] := Pr;
            end;
            {Continue sorting right partition}
            L := Pl;
          end;
        until L >= R;
      until StackP < 0;

    finally
      FreeMem(SwapPtr, RecLen);
    end;
  finally
    FreeMem(PivotPtr, RecLen);
  end;
end;


end.