stsort.pas

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

    while (MOpenCount < MergeOrder) and (MFileMerged < MFileCount) do begin
      inc(MOpenCount);
      inc(MFileMerged);
      inc(OutputSpace, MFileSizeP^[MFileMerged]);
    end;
    inc(MFileCount);
    {Save size of output file}
    MFileSizeP^[MFileCount] := OutputSpace;
    {Output file and input files coexist temporarily}
    inc(DiskSpace, OutputSpace);
    {Store new peak disk space}
    if DiskSpace > PeakDiskSpace then
      PeakDiskSpace := DiskSpace;
    {Account for deleting input files}
    dec(DiskSpace, OutputSpace);
  end;
  Result.MaxDiskSpace := PeakDiskSpace;

  FreeMem(MFileSizeP, SizeBufSize);
end;

function MinimumHeapToUse(RecLen : Cardinal) : LongInt;
var
  HeapToUse : LongInt;
begin
  HeapToUse := (MergeOrder+1)*RecLen;
  Result := (MinRecsPerRun+2)*RecLen;
  if Result < HeapToUse then
    Result := HeapToUse;
end;

function OptimumHeapToUse(RecLen : Cardinal; NumRecs : LongInt) : LongInt;
begin
  if (NumRecs < MergeOrder+1) then
    NumRecs := MergeOrder+1;
  Result := LongInt(RecLen)*(NumRecs+2);
end;

{----------------------------------------------------------------------}

constructor TStSorter.Create(MaxHeap : LongInt; RecLen : Cardinal);
begin
  if (RecLen = 0) or (MaxHeap <= 0) then
    RaiseError(stscBadSize);

  FMergeName := DefaultMergeName;
  FRecLen := RecLen;

  {Allocate a sort work buffer using at most MaxHeap bytes}
  sorAllocBuffer(MaxHeap);

{$IFDEF ThreadSafe}
  Windows.InitializeCriticalSection(sorThreadSafe);
{$ENDIF}
end;

destructor TStSorter.Destroy;
begin
{$IFDEF ThreadSafe}
  Windows.DeleteCriticalSection(sorThreadSafe);
{$ENDIF}
  sorDeleteMergeFiles;
  sorFreeBuffer;
end;

procedure TStSorter.EnterCS;
begin
{$IFDEF ThreadSafe}
  EnterCriticalSection(sorThreadSafe);
{$ENDIF}
end;

function TStSorter.Get(var X) : Boolean;
var
  NextIndex : Integer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Result := False;

    if sorState <> 2 then begin
      {First call to Get}
      if sorRunCount > 0 then begin
        {Still have elements to sort}
        sorRunSort(0, sorRunCount-1);
        if sorMergeFileCount > 0 then begin
          {Already have other merge files}
          sorStoreNewMergeFile;
          sorPrimaryMerge;
          sorOpenMergeFiles;
        end else
          {No merging necessary}
          sorGetIndex := 0;
      end else if FCount = 0 then
        {No elements were sorted}
        Exit;

      sorState := 2;
    end;

    if sorMergeFileCount > 0 then begin
      {Get next record from merge files}
      NextIndex := sorGetNextElementIndex;
      if NextIndex <> 0 then begin
        {Return the element}
        sorMoveElement(sorMergePtrs[NextIndex], @X);
        {Get pointer to next element in the stream just used}
        sorGetMergeElementPtr(NextIndex);
        Result := True;
      end;
    end else if sorGetIndex < sorRunCount then begin
      {Get next record from run buffer}
      sorMoveElement(sorElementPtr(sorGetIndex), @X);
      inc(sorGetIndex);
      Result := True;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStSorter.LeaveCS;
begin
{$IFDEF ThreadSafe}
  LeaveCriticalSection(sorThreadSafe);
{$ENDIF}
end;

procedure TStSorter.Reset;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    sorDeleteMergeFiles;
    FCount := 0;
    sorState := 0;
    sorRunCount := 0;
    sorMergeFileCount := 0;
    sorMergeFileMerged := 0;
    sorMergeOpenCount := 0;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStSorter.Put(const X);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if sorState = 2 then
      {Can't Put after calling Get}
      RaiseError(stscBadState);

    sorState := 1;

    if sorRunCount >= sorRunCapacity then begin
      {Run buffer full; sort buffer and store to disk}
      sorRunSort(0, sorRunCount-1);
      sorStoreNewMergeFile;
      sorRunCount := 0;
    end;

    {Store new element into run buffer}
    sorMoveElement(@X, sorElementPtr(sorRunCount));
    inc(sorRunCount);
    inc(FCount);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStSorter.sorAllocBuffer(MaxHeap : LongInt);
  {-Allocate a work buffer of records in at most MaxHeap bytes}
var
  Status : Integer;
  AllocRecs : LongInt;
begin
  Status := stscBadSize;
  repeat
    AllocRecs := MaxHeap div LongInt(FRecLen);
    if AllocRecs < MergeOrder+1 then
      RaiseError(Status);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
    sorBuffer := GlobalAllocPtr(HeapAllocFlags, AllocRecs*LongInt(FRecLen));
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
    if sorBuffer = nil then begin
      Status := ecOutOfMemory;
      MaxHeap := MaxHeap div 2;
    end else
      break;
  until False;

  sorMergeBufSize := LongInt(FRecLen)*(AllocRecs div (MergeOrder+1));

  sorRunCapacity := AllocRecs-2;
  if sorRunCapacity < MinRecsPerRun then
    RaiseError(Status);

  sorPivotPtr := sorElementPtr(AllocRecs-1);
  sorSwapPtr := sorElementPtr(AllocRecs-2);
end;

procedure TStSorter.sorCreateNewMergeFile(var Handle : Integer);
  {-Create another merge file and return its handle}
begin
  if sorMergeFileCount = MaxInt then
    {Too many merge files}
    RaiseError(stscTooManyFiles);

  {Create new merge file}
  inc(sorMergeFileCount);
  Handle := FileCreate(FMergeName(sorMergeFileCount));
  if Handle < 0 then begin
    dec(sorMergeFileCount);
    RaiseError(stscFileCreate);
  end;
end;

procedure TStSorter.sorDeleteMergeFiles;
  {-Delete open and already-closed merge files}
var
  I : Integer;
begin
  for I := 1 to sorMergeOpenCount do begin
    FileClose(sorMergeFiles[I]);
    SysUtils.DeleteFile(FMergeName(sorMergeFileNumber[I]));
  end;

  for I := sorMergeFileMerged+1 to sorMergeFileCount do
    SysUtils.DeleteFile(FMergeName(I));
end;

function TStSorter.sorElementPtr(Index : LongInt) : Pointer;
  {-Return a pointer to the given element in the sort buffer}
begin
  Result := PChar(sorBuffer)+Index*LongInt(FRecLen);
end;

procedure TStSorter.sorFlushOutBuffer;
  {-Write the merge output buffer to disk}
var
  BytesWritten : LongInt;
begin
  if sorOutBytesUsed <> 0 then begin
    BytesWritten := FileWrite(sorOutFile, sorOutPtr^, sorOutBytesUsed);
    if BytesWritten <> sorOutBytesUsed then
      RaiseError(stscFileWrite);
  end;
end;

procedure TStSorter.sorFreeBuffer;
begin
  GlobalFreePtr(sorBuffer);
end;

procedure TStSorter.sorGetMergeElementPtr(M : Integer);
  {-Update head pointer in input buffer of specified open merge file}
var
  BytesRead : LongInt;
begin
  if sorMergeBytesUsed[M] >= sorMergeBytesLoaded[M] then begin
    {Try to load new data into buffer}
    BytesRead := FileRead(sorMergeFiles[M], sorMergeBases[M]^, sorMergeBufSize);
    if BytesRead < 0 then
      {Error reading file}
      RaiseError(stscFileRead);
    if BytesRead < LongInt(FRecLen) then begin                         
      {End of file. Close and delete it}
      FileClose(sorMergeFiles[M]);
      SysUtils.DeleteFile(FMergeName(sorMergeFileNumber[M]));
      {Remove file from merge list}
      if M <> sorMergeOpenCount then begin
        sorMergeFileNumber[M] := sorMergeFileNumber[sorMergeOpenCount];
        sorMergeFiles[M] := sorMergeFiles[sorMergeOpenCount];
        sorMergePtrs[M] := sorMergePtrs[sorMergeOpenCount];
        sorMergeBytesLoaded[M] := sorMergeBytesLoaded[sorMergeOpenCount];
        sorMergeBytesUsed[M] := sorMergeBytesUsed[sorMergeOpenCount];
        sorMergeBases[M] := sorMergeBases[sorMergeOpenCount];
      end;
      dec(sorMergeOpenCount);
      Exit;
    end;
    sorMergeBytesLoaded[M] := BytesRead;
    sorMergeBytesUsed[M] := 0;
  end;

  sorMergePtrs[M] := PChar(sorMergeBases[M])+sorMergeBytesUsed[M];
  inc(sorMergeBytesUsed[M], FRecLen);
end;

function TStSorter.sorGetNextElementIndex : Integer;
  {-Return index into open merge file of next smallest element}
var
  M : Integer;
  MinElPtr : Pointer;
begin
  if sorMergeOpenCount = 0 then begin
    {All merge streams are empty}
    Result := 0;
    Exit;
  end;

  {Assume first element is the least}
  MinElPtr := sorMergePtrs[1];
  Result := 1;

  {Scan the other elements}
  for M := 2 to sorMergeOpenCount do
    if FCompare(sorMergePtrs[M]^, MinElPtr^) < 0 then begin
      Result := M;
      MinElPtr := sorMergePtrs[M];
    end;
end;

procedure TStSorter.sorMergeFileGroup;
  {-Merge a group of input files into one output file}
var
  NextIndex : Integer;
begin
  sorOutBytesUsed := 0;
  repeat
    {Find index of minimum element}
    NextIndex := sorGetNextElementIndex;
    if NextIndex = 0 then
      break
    else begin
      {Copy element to output}
      sorStoreElement(sorMergePtrs[NextIndex]);
      {Get the next element from its merge stream}
      sorGetMergeElementPtr(NextIndex);
    end;
  until False;

  {Flush and close the output file}
  sorFlushOutBuffer;
  FileClose(sorOutFile);
end;

procedure TStSorter.sorMoveElement(Src, Dest : Pointer); assembler;
  {-Copy one record to another location, non-overlapping}
register;
asm
  {eax = Self, edx = Src, ecx = Dest}
  push esi
  mov esi,Src
  mov edx,edi
  mov edi,Dest
  mov ecx,TStSorter([eax]).FRecLen
  mov eax,ecx
  shr ecx,2
  rep movsd
  mov ecx,eax
  and ecx,3
  rep movsb
  mov edi,edx