tpsystools_4.04/source/StPQueue.pas

// Upgraded to Delphi 2009: Sebastian Zierer

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StPQueue.pas 4.04                           *}
{*********************************************************}
{* SysTools: Priority Queue Classes                      *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
   Based on the double-ended heap (deap) described in Horowitz and Sahni,
   Data Structures and Algorithms in C.

   The deap was first reported in:
     Svante Carlsson, "The Deap - a double-ended heap to implement double-
     ended priority queues", Information Processing Letters, 26,
     pp. 33-36, 1987.

   A deap is a complete binary tree. The root node holds no data. Its
   left subtree is a min heap. Its right subtree is a max heap. If the right
   subtree is not empty, let i be any node in the left subtree. Let j be
   the node at the corresponding position in the right subtree. If such a
   j does not exist, let j be the node in the right subtree at the position
   corresponding to i's parent. The deap has the property that the data in
   node i is less than or equal to the data in node j.

   Insertion is an O(log2(n)) operation. Deletion of the min or max node
   is also an O(log2(n)) operation.

   Data elements in the deap are pointers, which can point to any record
   structure or class, or can contain any data type of 4 bytes or less.
   The deap needs an ordering relationship, so it is essential to assign
   to the Compare property inherited from the TStContainer class.

   STPQUEUE uses the DisposeData procedure of TStContainer to determine
   how to free elements in the collection. By default, it does nothing.

   In 16-bit programs the deap is limited to 16380 elements. In 32-bit
   programs the limit is set by memory usage or performance.
}

unit StPQueue;

interface

uses
  Windows, SysUtils, Classes,
  StConst, StBase;

type
  {first actual element is at index 2}
  {.Z+}
  TStPQData = array[2..(StMaxBlockSize div SizeOf(Pointer))+1] of Pointer;
  PStPQData = ^TStPQData;
  {.Z-}

  TStPQueue = class(TStContainer)
    {.Z+}
    protected {private}
      pqData     : PStPQData;         {data - the complete binary tree}
      pqCapacity : Integer;           {max elements currently possible}
      pqDelta    : Integer;           {delta elements to grow when needed}

      procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : Pointer);
        override;
      function StoresPointers : Boolean;
        override;

      procedure Expand(Need : Integer);
      procedure InsertMin(I : Integer; Data : Pointer);
      procedure InsertMax(I : Integer; Data : Pointer);
      procedure ModifiedInsert(I : Integer; Data : Pointer);

    {.Z-}
    public
      constructor Create(InitCapacity, Delta : Integer);
        virtual;
        {-Initialize an empty PQueue of given capacity. If it overflows
          grow the PQueue by Delta elements}
      destructor Destroy;
        override;
        {-Free a PQueue}

      procedure LoadFromStream(S : TStream);
        override;
        {-Create a PQueue and its data from a stream}
      procedure StoreToStream(S : TStream);
        override;
        {-Write a PQueue and its data to a stream}

      procedure Clear;
        override;
        {-Remove all data from container but leave it instantiated and
          with its current capacity}

      procedure Insert(Data : Pointer);
        {-Add a new node}
      function DeleteMin : Pointer;
        {-Remove the minimum node and return its Pointer}
      function DeleteMax : Pointer;
        {-Remove the maximum node and return its Pointer}

      procedure Assign(Source : TPersistent);
        override;
        {-Assign another container's contents to this one. Only SysTools
          containers that store pointers are allowed.}
      procedure Join(Q : TStPQueue);
        {-Add PQueue Q into this one and dispose Q}

      function Iterate(Action : TIteratePointerFunc;
        OtherData : Pointer) : Pointer;
        {-Call Action for all the nodes or until Action returns false. Note
          that the nodes are visited in no particular order.}

      function Test : Boolean;
        {-Determine whether deap properties are currently valid (for debugging)}
  end;

  {.Z+}
  TStPQueueClass = class of TStPQueue;
  {.Z-}


implementation

{$IFDEF ThreadSafe}
var
  ClassCritSect : TRTLCriticalSection;
{$ENDIF}

type
  TStoreInfo = record
    Wtr : TWriter;
    SDP : TStoreDataProc;
  end;

function AssignData(Container : TStContainer;
                    Data, OtherData : Pointer) : Boolean; far;
begin
  TStPQueue(OtherData).Insert(Data);
  AssignData := True;
end;

function DestroyNode(Container : TStContainer;
  Data, OtherData : Pointer) : Boolean; far;
begin
  if Assigned(Data) then
    Container.DoDisposeData(Data);
  DestroyNode := True;
end;

procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
  EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;

function JoinData(Container : TStContainer;
  Data, OtherData : Pointer) : Boolean; far;
begin
  TStPQueue(OtherData).Insert(Data);
  JoinData := True;
end;

procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
  LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;

function log2(I : Integer) : Integer;
  {-Return the Integer below log2(I)}
begin
  Result := 0;
  while (I > 1) do begin
    Inc(Result);
    I := I shr 1;
  end;
end;

function StoreNode(Container : TStContainer;
  Data, OtherData : Pointer) : Boolean; far;
begin
  StoreNode := True;
  with TStoreInfo(OtherData^) do
    SDP(Wtr, Data);
end;

procedure TStPQueue.Assign(Source : TPersistent);
begin
  {$IFDEF ThreadSafe}
  EnterCS;
  try
  {$ENDIF}
    if not AssignPointers(Source, AssignData) then
      inherited Assign(Source);
  {$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
  {$ENDIF}
end;

procedure TStPQueue.Clear;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if conNodeProt = 0 then
      ForEachPointer(StPQueue.DestroyNode, nil);
    FCount := 0;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

constructor TStPQueue.Create(InitCapacity, Delta : Integer);
begin
  if (InitCapacity < 2) or (Delta < 1) then
    RaiseContainerError(stscBadSize);

  FCount := 0;
  {ensure that Expand creates initial capacity InitCapacity}
  pqCapacity := -Delta;
  pqDelta := Delta;
  pqData := nil;

  CreateContainer(TStNode, 0);

  Expand(InitCapacity);
end;

function TStPQueue.DeleteMin : Pointer;
var
  I, j, n : Integer;
  Temp    : Pointer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if (FCount < 1) then begin
      {deap is empty}
      DeleteMin := nil;
      exit;
    end;

    {return min element}
    DeleteMin := pqData^[2];

    {save last element and reset (helps debugging)}
    Temp := pqData^[FCount+1];
    pqData^[FCount+1] := nil;
    {decrement count, n is index of new last element}
    n := FCount;
    dec(FCount);

    if (FCount > 0) then begin
      {move empty min-root down to an appropriate leaf}
      I := 2;
      while (I shl 1 <= n) do begin
        {find child with smaller key}
        j := I shl 1;
        if (j+1 <= n) then
          if (DoCompare(pqData^[j], pqData^[j+1]) > 0) then
            Inc(j);
        pqData^[I] := pqData^[j];
        I := j;
      end;

      {insert the old last element at the given leaf position}
      ModifiedInsert(I, Temp);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStPQueue.DeleteMax : Pointer;
var
  I, j, n : Integer;
  Temp    : Pointer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if (FCount < 1) then begin
      {deap is empty}
      DeleteMax := nil;
      exit;
    end;

    {return max element}
    if (FCount = 1) then
      DeleteMax := pqData^[2]
    else
      DeleteMax := pqData^[3];

    {save last element and reset (helps debugging)}
    Temp := pqData^[FCount+1];
    pqData^[FCount+1] := nil;
    {decrement count, n is index of new last element}
    n := FCount;
    dec(FCount);

    if (FCount > 0) then begin
      {move empty max-root down to an appropriate leaf}
      I := 3;
      while (I shl 1 <= n) do begin
        {find child with larger key}
        j := I shl 1;
        if (j+1 <= n) then
          if (DoCompare(pqData^[j], pqData^[j+1]) < 0) then
            Inc(j);
        pqData^[I] := pqData^[j];
        I := j;
      end;

      {insert the old last element at the given leaf position}
      ModifiedInsert(I, Temp);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

destructor TStPQueue.Destroy;
begin
  if (pqData <> nil) then begin
    Clear;
    FreeMem(pqData, pqCapacity*SizeOf(Pointer));
  end;

  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.
1	torben	2671	// Upgraded to Delphi 2009: Sebastian Zierer
2
3			(* *** BEGIN LICENSE BLOCK ***
4			* Version: MPL 1.1
5			*
6			* The contents of this file are subject to the Mozilla Public License Version
7			* 1.1 (the "License"); you may not use this file except in compliance with
8			* the License. You may obtain a copy of the License at
9			* http://www.mozilla.org/MPL/
10			*
11			* Software distributed under the License is distributed on an "AS IS" basis,
12			* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13			* for the specific language governing rights and limitations under the
14			* License.
15			*
16			* The Original Code is TurboPower SysTools
17			*
18			* The Initial Developer of the Original Code is
19			* TurboPower Software
20			*
21			* Portions created by the Initial Developer are Copyright (C) 1996-2002
22			* the Initial Developer. All Rights Reserved.
23			*
24			* Contributor(s):
25			*
26			* *** END LICENSE BLOCK *** *)
27
28			{*********************************************************}
29			{* SysTools: StPQueue.pas 4.04 *}
30			{*********************************************************}
31			{* SysTools: Priority Queue Classes *}
32			{*********************************************************}
33
34			{$I StDefine.inc}
35
36			{Notes:
37			Based on the double-ended heap (deap) described in Horowitz and Sahni,
38			Data Structures and Algorithms in C.
39
40			The deap was first reported in:
41			Svante Carlsson, "The Deap - a double-ended heap to implement double-
42			ended priority queues", Information Processing Letters, 26,
43			pp. 33-36, 1987.
44
45			A deap is a complete binary tree. The root node holds no data. Its
46			left subtree is a min heap. Its right subtree is a max heap. If the right
47			subtree is not empty, let i be any node in the left subtree. Let j be
48			the node at the corresponding position in the right subtree. If such a
49			j does not exist, let j be the node in the right subtree at the position
50			corresponding to i's parent. The deap has the property that the data in
51			node i is less than or equal to the data in node j.
52
53			Insertion is an O(log2(n)) operation. Deletion of the min or max node
54			is also an O(log2(n)) operation.
55
56			Data elements in the deap are pointers, which can point to any record
57			structure or class, or can contain any data type of 4 bytes or less.
58			The deap needs an ordering relationship, so it is essential to assign
59			to the Compare property inherited from the TStContainer class.
60
61			STPQUEUE uses the DisposeData procedure of TStContainer to determine
62			how to free elements in the collection. By default, it does nothing.
63
64			In 16-bit programs the deap is limited to 16380 elements. In 32-bit
65			programs the limit is set by memory usage or performance.
66			}
67
68			unit StPQueue;
69
70			interface
71
72			uses
73			Windows, SysUtils, Classes,
74			StConst, StBase;
75
76			type
77			{first actual element is at index 2}
78			{.Z+}
79			TStPQData = array[2..(StMaxBlockSize div SizeOf(Pointer))+1] of Pointer;
80			PStPQData = ^TStPQData;
81			{.Z-}
82
83			TStPQueue = class(TStContainer)
84			{.Z+}
85			protected {private}
86			pqData : PStPQData; {data - the complete binary tree}
87			pqCapacity : Integer; {max elements currently possible}
88			pqDelta : Integer; {delta elements to grow when needed}
89
90			procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : Pointer);
91			override;
92			function StoresPointers : Boolean;
93			override;
94
95			procedure Expand(Need : Integer);
96			procedure InsertMin(I : Integer; Data : Pointer);
97			procedure InsertMax(I : Integer; Data : Pointer);
98			procedure ModifiedInsert(I : Integer; Data : Pointer);
99
100			{.Z-}
101			public
102			constructor Create(InitCapacity, Delta : Integer);
103			virtual;
104			{-Initialize an empty PQueue of given capacity. If it overflows
105			grow the PQueue by Delta elements}
106			destructor Destroy;
107			override;
108			{-Free a PQueue}
109
110			procedure LoadFromStream(S : TStream);
111			override;
112			{-Create a PQueue and its data from a stream}
113			procedure StoreToStream(S : TStream);
114			override;
115			{-Write a PQueue and its data to a stream}
116
117			procedure Clear;
118			override;
119			{-Remove all data from container but leave it instantiated and
120			with its current capacity}
121
122			procedure Insert(Data : Pointer);
123			{-Add a new node}
124			function DeleteMin : Pointer;
125			{-Remove the minimum node and return its Pointer}
126			function DeleteMax : Pointer;
127			{-Remove the maximum node and return its Pointer}
128
129			procedure Assign(Source : TPersistent);
130			override;
131			{-Assign another container's contents to this one. Only SysTools
132			containers that store pointers are allowed.}
133			procedure Join(Q : TStPQueue);
134			{-Add PQueue Q into this one and dispose Q}
135
136			function Iterate(Action : TIteratePointerFunc;
137			OtherData : Pointer) : Pointer;
138			{-Call Action for all the nodes or until Action returns false. Note
139			that the nodes are visited in no particular order.}
140
141			function Test : Boolean;
142			{-Determine whether deap properties are currently valid (for debugging)}
143			end;
144
145			{.Z+}
146			TStPQueueClass = class of TStPQueue;
147			{.Z-}
148
149
150			implementation
151
152			{$IFDEF ThreadSafe}
153			var
154			ClassCritSect : TRTLCriticalSection;
155			{$ENDIF}
156
157			type
158			TStoreInfo = record
159			Wtr : TWriter;
160			SDP : TStoreDataProc;
161			end;
162
163			function AssignData(Container : TStContainer;
164			Data, OtherData : Pointer) : Boolean; far;
165			begin
166			TStPQueue(OtherData).Insert(Data);
167			AssignData := True;
168			end;
169
170			function DestroyNode(Container : TStContainer;
171			Data, OtherData : Pointer) : Boolean; far;
172			begin
173			if Assigned(Data) then
174			Container.DoDisposeData(Data);
175			DestroyNode := True;
176			end;
177
178			procedure EnterClassCS;
179			begin
180			{$IFDEF ThreadSafe}
181			EnterCriticalSection(ClassCritSect);
182			{$ENDIF}
183			end;
184
185			function JoinData(Container : TStContainer;
186			Data, OtherData : Pointer) : Boolean; far;
187			begin
188			TStPQueue(OtherData).Insert(Data);
189			JoinData := True;
190			end;
191
192			procedure LeaveClassCS;
193			begin
194			{$IFDEF ThreadSafe}
195			LeaveCriticalSection(ClassCritSect);
196			{$ENDIF}
197			end;
198
199			function log2(I : Integer) : Integer;
200			{-Return the Integer below log2(I)}
201			begin
202			Result := 0;
203			while (I > 1) do begin
204			Inc(Result);
205			I := I shr 1;
206			end;
207			end;
208
209			function StoreNode(Container : TStContainer;
210			Data, OtherData : Pointer) : Boolean; far;
211			begin
212			StoreNode := True;
213			with TStoreInfo(OtherData^) do
214			SDP(Wtr, Data);
215			end;
216
217			procedure TStPQueue.Assign(Source : TPersistent);
218			begin
219			{$IFDEF ThreadSafe}
220			EnterCS;
221			try
222			{$ENDIF}
223			if not AssignPointers(Source, AssignData) then
224			inherited Assign(Source);
225			{$IFDEF ThreadSafe}
226			finally
227			LeaveCS;
228			end;
229			{$ENDIF}
230			end;
231
232			procedure TStPQueue.Clear;
233			begin
234			{$IFDEF ThreadSafe}
235			EnterCS;
236			try
237			{$ENDIF}
238			if conNodeProt = 0 then
239			ForEachPointer(StPQueue.DestroyNode, nil);
240			FCount := 0;
241			{$IFDEF ThreadSafe}
242			finally
243			LeaveCS;
244			end;
245			{$ENDIF}
246			end;
247
248			constructor TStPQueue.Create(InitCapacity, Delta : Integer);
249			begin
250			if (InitCapacity < 2) or (Delta < 1) then
251			RaiseContainerError(stscBadSize);
252
253			FCount := 0;
254			{ensure that Expand creates initial capacity InitCapacity}
255			pqCapacity := -Delta;
256			pqDelta := Delta;
257			pqData := nil;
258
259			CreateContainer(TStNode, 0);
260
261			Expand(InitCapacity);
262			end;
263
264			function TStPQueue.DeleteMin : Pointer;
265			var
266			I, j, n : Integer;
267			Temp : Pointer;
268			begin
269			{$IFDEF ThreadSafe}
270			EnterCS;
271			try
272			{$ENDIF}
273			if (FCount < 1) then begin
274			{deap is empty}
275			DeleteMin := nil;
276			exit;
277			end;
278
279			{return min element}
280			DeleteMin := pqData^[2];
281
282			{save last element and reset (helps debugging)}
283			Temp := pqData^[FCount+1];
284			pqData^[FCount+1] := nil;
285			{decrement count, n is index of new last element}
286			n := FCount;
287			dec(FCount);
288
289			if (FCount > 0) then begin
290			{move empty min-root down to an appropriate leaf}
291			I := 2;
292			while (I shl 1 <= n) do begin
293			{find child with smaller key}
294			j := I shl 1;
295			if (j+1 <= n) then
296			if (DoCompare(pqData^[j], pqData^[j+1]) > 0) then
297			Inc(j);
298			pqData^[I] := pqData^[j];
299			I := j;
300			end;
301
302			{insert the old last element at the given leaf position}
303			ModifiedInsert(I, Temp);
304			end;
305			{$IFDEF ThreadSafe}
306			finally
307			LeaveCS;
308			end;
309			{$ENDIF}
310			end;
311
312			function TStPQueue.DeleteMax : Pointer;
313			var
314			I, j, n : Integer;
315			Temp : Pointer;
316			begin
317			{$IFDEF ThreadSafe}
318			EnterCS;
319			try
320			{$ENDIF}
321			if (FCount < 1) then begin
322			{deap is empty}
323			DeleteMax := nil;
324			exit;
325			end;
326
327			{return max element}
328			if (FCount = 1) then
329			DeleteMax := pqData^[2]
330			else
331			DeleteMax := pqData^[3];
332
333			{save last element and reset (helps debugging)}
334			Temp := pqData^[FCount+1];
335			pqData^[FCount+1] := nil;
336			{decrement count, n is index of new last element}
337			n := FCount;
338			dec(FCount);
339
340			if (FCount > 0) then begin
341			{move empty max-root down to an appropriate leaf}
342			I := 3;
343			while (I shl 1 <= n) do begin
344			{find child with larger key}
345			j := I shl 1;
346			if (j+1 <= n) then
347			if (DoCompare(pqData^[j], pqData^[j+1]) < 0) then
348			Inc(j);
349			pqData^[I] := pqData^[j];
350			I := j;
351			end;
352
353			{insert the old last element at the given leaf position}
354			ModifiedInsert(I, Temp);
355			end;
356			{$IFDEF ThreadSafe}
357			finally
358			LeaveCS;
359			end;
360			{$ENDIF}
361			end;
362
363			destructor TStPQueue.Destroy;
364			begin
365			if (pqData <> nil) then begin
366			Clear;
367			FreeMem(pqData, pqCapacity*SizeOf(Pointer));
368			end;
369
370			IncNodeProtection;
371			inherited Destroy;
372			end;
373
374			procedure TStPQueue.Expand(Need : Integer);
375			var
376			NewCapacity : Integer;
377			Size : LongInt;
378			NewData : PStPQData;
379			begin
380			if Need > pqCapacity then begin
381			{determine new capacity}
382			NewCapacity := pqCapacity+pqDelta;
383			if (NewCapacity < Need) then
384			NewCapacity := Need;
385
386			{make sure it's feasible to allocate it}
387			Size := LongInt(NewCapacity)*SizeOf(Pointer);
388			{if Size > MaxBlockSize then}
389			{RaiseContainerError(stscBadSize);}
390
391			{allocate new data}
392			GetMem(NewData, Size);
393
394			{copy old data to it and free old data}
395			if (pqData <> nil) then begin
396			move(pqData^, NewData^, pqCapacity*SizeOf(Pointer));
397			FreeMem(pqData, pqCapacity*SizeOf(Pointer));
398			end;
399
400			{update instance variables}
401			pqData := NewData;
402			pqCapacity := NewCapacity;
403			end;
404			end;
405
406			procedure TStPQueue.ForEachPointer(Action : TIteratePointerFunc; OtherData : Pointer);
407			var
408			I : Integer;
409			begin
410			{$IFDEF ThreadSafe}
411			EnterCS;
412			try
413			{$ENDIF}
414			{first element is 2, last is FCount+1}
415			for I := 2 to FCount+1 do
416			if not Action(Self, pqData^[I], OtherData) then
417			Exit;
418			{$IFDEF ThreadSafe}
419			finally
420			LeaveCS;
421			end;
422			{$ENDIF}
423			end;
424
425			procedure TStPQueue.Insert(Data : Pointer);
426			var
427			I, n, p : Integer;
428			begin
429			{$IFDEF ThreadSafe}
430			EnterCS;
431			try
432			{$ENDIF}
433			{adding an element, make sure there's space}
434			Inc(FCount);
435			Expand(FCount);
436
437			if (FCount = 1) then
438			{insert into empty deap}
439			pqData^[2] := Data
440			else begin
441			{n is the actual array index}
442			n := FCount+1;
443			{determine whether n is in the min or max subtree}
444			p := n;
445			while (p > 3) do
446			p := p shr 1;
447			if (p = 2) then begin
448			{n is a position on the min side}
449			{I is its partner on the max side}
450			I := (n+(1 shl (log2(n)-1))) shr 1;
451			if (DoCompare(Data, pqData^[I]) > 0) then begin
452			pqData^[n] := pqData^[I];
453			InsertMax(I, Data);
454			end else
455			InsertMin(n, Data);
456			end else begin
457			{n is a position on the max side}
458			{I is its partner on the min side}
459			I := n-(1 shl (log2(n)-1));
460			if (DoCompare(Data, pqData^[I]) < 0) then begin
461			pqData^[n] := pqData^[I];
462			InsertMin(I, Data);
463			end else
464			InsertMax(n, Data);
465			end;
466			end;
467			{$IFDEF ThreadSafe}
468			finally
469			LeaveCS;
470			end;
471			{$ENDIF}
472			end;
473
474			procedure TStPQueue.InsertMin(I : Integer; Data : Pointer);
475			{-Insert into min-heap rooted at node 2}
476			var
477			j : Integer;
478			begin
479			while (I > 2) and (DoCompare(Data, pqData^[I shr 1]) < 0) do begin
480			j := I shr 1;
481			pqData^[I] := pqData^[j];
482			I := j;
483			end;
484			pqData^[I] := Data;
485			end;
486
487			procedure TStPQueue.InsertMax(I : Integer; Data : Pointer);
488			{-Insert into max-heap rooted at node 3}
489			var
490			j : Integer;
491			begin
492			while (I > 3) and (DoCompare(Data, pqData^[I shr 1]) > 0) do begin
493			j := I shr 1;
494			pqData^[I] := pqData^[j];
495			I := j;
496			end;
497			pqData^[I] := Data;
498			end;
499
500			function TStPQueue.Iterate(Action : TIteratePointerFunc;
501			OtherData : Pointer) : Pointer;
502			var
503			I : Integer;
504			begin
505			Iterate := nil;
506			{$IFDEF ThreadSafe}
507			EnterCS;
508			try
509			{$ENDIF}
510			{first element is 2, last is FCount+1}
511			for I := 2 to FCount+1 do
512			if not Action(Self, pqData^[I], OtherData) then begin
513			Iterate := pqData^[I];
514			Exit;
515			end;
516			{$IFDEF ThreadSafe}
517			finally
518			LeaveCS;
519			end;
520			{$ENDIF}
521			end;
522
523			procedure TStPQueue.Join(Q : TStPQueue);
524			begin
525			{$IFDEF ThreadSafe}
526			EnterClassCS;
527			EnterCS;
528			Q.EnterCS;
529			try
530			{$ENDIF}
531			if (not Assigned(Q)) then
532			RaiseContainerError(stscBadType);
533			Q.ForEachPointer(JoinData, Self);
534			Q.IncNodeProtection;
535			Q.Free;
536			{$IFDEF ThreadSafe}
537			finally
538			Q.LeaveCS;
539			LeaveCS;
540			LeaveClassCS;
541			end;
542			{$ENDIF}
543			end;
544
545			procedure TStPQueue.LoadFromStream(S : TStream);
546			var
547			Data : Pointer;
548			Reader : TReader;
549			StreamedClass : TPersistentClass;
550			StreamedClassName : string;
551			begin
552			{$IFDEF ThreadSafe}
553			EnterCS;
554			try
555			{$ENDIF}
556			Clear;
557			Reader := TReader.Create(S, 1024);
558			try
559			with Reader do begin
560			StreamedClassName := ReadString;
561			StreamedClass := GetClass(StreamedClassName);
562			if (StreamedClass = nil) then
563			RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
564			if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
565			(not IsOrInheritsFrom(TStPQueue, StreamedClass)) then
566			RaiseContainerError(stscWrongClass);
567			ReadListBegin;
568			while not EndOfList do begin
569			Data := DoLoadData(Reader);
570			Insert(Data);
571			end;
572			ReadListEnd;
573			end;
574			finally
575			Reader.Free;
576			end;
577			{$IFDEF ThreadSafe}
578			finally
579			LeaveCS;
580			end;
581			{$ENDIF}
582			end;
583
584			procedure TStPQueue.ModifiedInsert(I : Integer; Data : Pointer);
585			{-Special insert after a delete. I is the actual array index where
586			insertion of Data occurs. Tree does not grow.}
587			var
588			p, j : Integer;
589			begin
590			if (I > 1) then begin
591			{determine whether I is in the min or max subtree}
592			p := I;
593			while (p > 3) do
594			p := p shr 1;
595			if (p = 2) then begin
596			{I is a position on the min side}
597			{j is its partner on the max side}
598			j := I+(1 shl (log2(I)-1));
599			if (j > FCount+1) then
600			j := j shr 1;
601			if (j < 3) then
602			{empty max heap}
603			pqData^[I] := Data
604			else if (DoCompare(Data, pqData^[j]) > 0) then begin
605			pqData^[I] := pqData^[j];
606			InsertMax(j, Data);
607			end else
608			InsertMin(I, Data);
609			end else begin
610			{I is a position on the max side}
611			{j is its partner on the min side}
612			j := I-(1 shl (log2(I)-1));
613			{check its children too to preserve deap property}
614			if (j shl 1 <= FCount+1) then begin
615			j := j shl 1;
616			if (j+1 <= FCount+1) then
617			if (DoCompare(pqData^[j], pqData^[j+1]) < 0) then
618			Inc(j);
619			end;
620			if (DoCompare(Data, pqData^[j]) < 0) then begin
621			pqData^[I] := pqData^[j];
622			InsertMin(j, Data);
623			end else
624			InsertMax(I, Data);
625			end;
626			end;
627			end;
628
629			function TStPQueue.StoresPointers : Boolean;
630			begin
631			StoresPointers := True;
632			end;
633
634			procedure TStPQueue.StoreToStream(S : TStream);
635			var
636			Writer : TWriter;
637			StoreInfo : TStoreInfo;
638			begin
639			{$IFDEF ThreadSafe}
640			EnterCS;
641			try
642			{$ENDIF}
643			Writer := TWriter.Create(S, 1024);
644			try
645			with Writer do begin
646			WriteString(Self.ClassName);
647			WriteListBegin;
648			StoreInfo.Wtr := Writer;
649			StoreInfo.SDP := StoreData;
650			Iterate(StoreNode, @StoreInfo);
651			WriteListEnd;
652			end;
653			finally
654			Writer.Free;
655			end;
656			{$IFDEF ThreadSafe}
657			finally
658			LeaveCS;
659			end;
660			{$ENDIF}
661			end;
662
663			function TStPQueue.Test : Boolean;
664			var
665			I, i2, j, n, p : Integer;
666			begin
667			{$IFDEF ThreadSafe}
668			EnterCS;
669			try
670			{$ENDIF}
671			Test := True;
672			if (FCount = 0) then
673			exit;
674			n := FCount+1;
675			{start with each leaf node}
676			for I := (1 shl log2(n)) to n do begin
677			p := I;
678			while (p > 3) do
679			p := p shr 1;
680			if (p = 2) then begin
681			{I is a position on the min side}
682			{test min-heap condition}
683			i2 := I;
684			while (i2 shr 1 >= 2) do begin
685			j := i2 shr 1;
686			if (DoCompare(pqData^[j], pqData^[i2]) > 0) then begin
687			Test := false;
688			{writeln('min: j=', j, ' i2=', i2,
689			' d[j]=', Integer(pqData^[j]), ' d[i2]=', Integer(pqData^[i2]));}
690			exit;
691			end;
692			i2 := j;
693			end;
694			{test deap condition}
695			if n >= 3 then begin
696			j := I+(1 shl (log2(I)-1));
697			if (j > n) then
698			j := j shr 1;
699			if (DoCompare(pqData^[I], pqData^[j]) > 0) then begin
700			Test := false;
701			{writeln('deap: j=', j, ' I=', I,
702			' d[j]=', Integer(pqData^[j]), ' d[I]=', Integer(pqData^[I]));}
703			exit;
704			end;
705			end;
706			end else begin
707			{I is a position on the max side}
708			{test max-heap condition}
709			i2 := I;
710			while (i2 shr 1 >= 3) do begin
711			j := i2 shr 1;
712			if (DoCompare(pqData^[j], pqData^[i2]) < 0) then begin
713			Test := false;
714			{writeln('max: j=', j, ' i2=', i2,
715			' d[j]=', Integer(pqData^[j]), ' d[i2]=', Integer(pqData^[i2]));}
716			exit;
717			end;
718			i2 := j;
719			end;
720			end;
721			end;
722
723			{$IFDEF ThreadSafe}
724			finally
725			LeaveCS;
726			end;
727			{$ENDIF}
728			end;
729
730			{$IFDEF ThreadSafe}
731			initialization
732			Windows.InitializeCriticalSection(ClassCritSect);
733			finalization
734			Windows.DeleteCriticalSection(ClassCritSect);
735			{$ENDIF}
736			end.