stpqueue.pas

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

  IncNodeProtection;
  inherited Destroy;
end;

procedure TStPQueue.Expand(Need : Integer);
var
  NewCapacity : Integer;
  Size        : LongInt;
  NewData     : PStPQData;
begin
  if Need > pqCapacity then begin
    {determine new capacity}
    NewCapacity := pqCapacity+pqDelta;
    if (NewCapacity < Need) then
      NewCapacity := Need;

    {make sure it's feasible to allocate it}
    Size := LongInt(NewCapacity)*SizeOf(Pointer);
    {if Size > MaxBlockSize then}
      {RaiseContainerError(stscBadSize);}                              

    {allocate new data}
    GetMem(NewData, Size);

    {copy old data to it and free old data}
    if (pqData <> nil) then begin
      move(pqData^, NewData^, pqCapacity*SizeOf(Pointer));
      FreeMem(pqData, pqCapacity*SizeOf(Pointer));
    end;

    {update instance variables}
    pqData := NewData;
    pqCapacity := NewCapacity;
  end;
end;

procedure TStPQueue.ForEachPointer(Action : TIteratePointerFunc; OtherData : Pointer);
var
  I : Integer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {first element is 2, last is FCount+1}
    for I := 2 to FCount+1 do
      if not Action(Self, pqData^[I], OtherData) then
        Exit;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStPQueue.Insert(Data : Pointer);
var
  I, n, p : Integer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {adding an element, make sure there's space}
    Inc(FCount);
    Expand(FCount);

    if (FCount = 1) then
      {insert into empty deap}
      pqData^[2] := Data
    else begin
      {n is the actual array index}
      n := FCount+1;
      {determine whether n is in the min or max subtree}
      p := n;
      while (p > 3) do
        p := p shr 1;
      if (p = 2) then begin
        {n is a position on the min side}
        {I is its partner on the max side}
        I := (n+(1 shl (log2(n)-1))) shr 1;
        if (DoCompare(Data, pqData^[I]) > 0) then begin
          pqData^[n] := pqData^[I];
          InsertMax(I, Data);
        end else
          InsertMin(n, Data);
      end else begin
        {n is a position on the max side}
        {I is its partner on the min side}
        I := n-(1 shl (log2(n)-1));
        if (DoCompare(Data, pqData^[I]) < 0) then begin
          pqData^[n] := pqData^[I];
          InsertMin(I, Data);
        end else
          InsertMax(n, Data);
      end;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStPQueue.InsertMin(I : Integer; Data : Pointer);
  {-Insert into min-heap rooted at node 2}
var
  j : Integer;
begin
  while (I > 2) and (DoCompare(Data, pqData^[I shr 1]) < 0) do begin
    j := I shr 1;
    pqData^[I] := pqData^[j];
    I := j;
  end;
  pqData^[I] := Data;
end;

procedure TStPQueue.InsertMax(I : Integer; Data : Pointer);
  {-Insert into max-heap rooted at node 3}
var
  j : Integer;
begin
  while (I > 3) and (DoCompare(Data, pqData^[I shr 1]) > 0) do begin
    j := I shr 1;
    pqData^[I] := pqData^[j];
    I := j;
  end;
  pqData^[I] := Data;
end;

function TStPQueue.Iterate(Action : TIteratePointerFunc;
  OtherData : Pointer) : Pointer;
var
  I : Integer;
begin
  Iterate := nil;
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {first element is 2, last is FCount+1}
    for I := 2 to FCount+1 do
      if not Action(Self, pqData^[I], OtherData) then begin
        Iterate := pqData^[I];
        Exit;
      end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStPQueue.Join(Q : TStPQueue);
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  Q.EnterCS;
  try
{$ENDIF}
    if (not Assigned(Q)) then
      RaiseContainerError(stscBadType);
    Q.ForEachPointer(JoinData, Self);
    Q.IncNodeProtection;
    Q.Free;
{$IFDEF ThreadSafe}
  finally
    Q.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

procedure TStPQueue.LoadFromStream(S : TStream);
var
  Data : Pointer;
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedClassName : string;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do begin
        StreamedClassName := ReadString;
        StreamedClass := GetClass(StreamedClassName);
        if (StreamedClass = nil) then
          RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
        if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
            (not IsOrInheritsFrom(TStPQueue, StreamedClass)) then
          RaiseContainerError(stscWrongClass);
        ReadListBegin;
        while not EndOfList do begin
          Data := DoLoadData(Reader);
          Insert(Data);
        end;
        ReadListEnd;
      end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStPQueue.ModifiedInsert(I : Integer; Data : Pointer);
  {-Special insert after a delete. I is the actual array index where
    insertion of Data occurs. Tree does not grow.}
var
  p, j : Integer;
begin
  if (I > 1) then begin
    {determine whether I is in the min or max subtree}
    p := I;
    while (p > 3) do
      p := p shr 1;
    if (p = 2) then begin
      {I is a position on the min side}
      {j is its partner on the max side}
      j := I+(1 shl (log2(I)-1));
      if (j > FCount+1) then
        j := j shr 1;
      if (j < 3) then
        {empty max heap}
        pqData^[I] := Data
      else if (DoCompare(Data, pqData^[j]) > 0) then begin
        pqData^[I] := pqData^[j];
        InsertMax(j, Data);
      end else
        InsertMin(I, Data);
    end else begin
      {I is a position on the max side}
      {j is its partner on the min side}
      j := I-(1 shl (log2(I)-1));
      {check its children too to preserve deap property}
      if (j shl 1 <= FCount+1) then begin
        j := j shl 1;
        if (j+1 <= FCount+1) then
          if (DoCompare(pqData^[j], pqData^[j+1]) < 0) then
            Inc(j);
      end;
      if (DoCompare(Data, pqData^[j]) < 0) then begin
        pqData^[I] := pqData^[j];
        InsertMin(j, Data);
      end else
        InsertMax(I, Data);
    end;
  end;
end;

function TStPQueue.StoresPointers : Boolean;
begin
  StoresPointers := True;
end;

procedure TStPQueue.StoreToStream(S : TStream);
var
  Writer : TWriter;
  StoreInfo : TStoreInfo;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do begin
        WriteString(Self.ClassName);
        WriteListBegin;
        StoreInfo.Wtr := Writer;
        StoreInfo.SDP := StoreData;
        Iterate(StoreNode, @StoreInfo);
        WriteListEnd;
      end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStPQueue.Test : Boolean;
var
  I, i2, j, n, p : Integer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Test := True;
    if (FCount = 0) then
      exit;
    n := FCount+1;
    {start with each leaf node}
    for I := (1 shl log2(n)) to n do begin
      p := I;
      while (p > 3) do
        p := p shr 1;
      if (p = 2) then begin
        {I is a position on the min side}
        {test min-heap condition}
        i2 := I;
        while (i2 shr 1 >= 2) do begin
          j := i2 shr 1;
          if (DoCompare(pqData^[j], pqData^[i2]) > 0) then begin
            Test := false;
            {writeln('min: j=', j, ' i2=', i2,
              ' d[j]=', Integer(pqData^[j]), ' d[i2]=', Integer(pqData^[i2]));}
            exit;
          end;
          i2 := j;
        end;
        {test deap condition}
        if n >= 3 then begin
          j := I+(1 shl (log2(I)-1));
          if (j > n) then
            j := j shr 1;
          if (DoCompare(pqData^[I], pqData^[j]) > 0) then begin
            Test := false;
            {writeln('deap: j=', j, ' I=', I,
              ' d[j]=', Integer(pqData^[j]), ' d[I]=', Integer(pqData^[I]));}
            exit;
          end;
        end;
      end else begin
        {I is a position on the max side}
        {test max-heap condition}
        i2 := I;
        while (i2 shr 1 >= 3) do begin
          j := i2 shr 1;
          if (DoCompare(pqData^[j], pqData^[i2]) < 0) then begin
            Test := false;
            {writeln('max: j=', j, ' i2=', i2,
              ' d[j]=', Integer(pqData^[j]), ' d[i2]=', Integer(pqData^[i2]));}
            exit;
          end;
          i2 := j;
        end;
      end;
    end;

{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.