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	// 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.