Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue39/Alfresco/PriQueue.pas

Pascal/Delphi Source File | 1998-10-07 | 19.0 KB | 639 lines

{*********************************************************}
{* PriQueue                                              *}
{* Copyright (c) Julian M Bucknall 1998                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Priority queues                                       *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit PriQueue;

interface

uses
  SysUtils,
  Classes;

type
  TaaItemPriorityCompare = function(const aItem1, aItem2 : pointer) : integer;
    {-Function prototype to take two items and compare their
      priorities: returns < 0 if the first item's priority is less
      than the second's, 0 if they're equal, > 0 otherwise}

type
  TaaPriorityQueueA = class
    {-A priority queue that is fast at insertion, slow at retrieval}
    private
      pqCompare : TaaItemPriorityCompare;
      pqList    : TList;
    protected
      function pqGetCount : integer;
    public
      constructor Create(aCompareFn : TaaItemPriorityCompare);
        {-Create the priority queue}
      destructor Destroy; override;
        {-Dispose of the priority queue - items remaining are NOT
          freed}

      procedure Add(aItem : pointer);
        {-Add an item to the priority queue}
      function Remove : pointer;
        {-Remove and return the item with the largest priority}

      property Count : integer read pqGetCount;
        {-Count of items in the queue}
  end;

type
  TaaPriorityQueueB = class
    {-A priority queue that is slow at insertion, fast at retrieval}
    private
      pqCompare : TaaItemPriorityCompare;
      pqList    : TList;
    protected
      function pqGetCount : integer;
    public
      constructor Create(aCompareFn : TaaItemPriorityCompare);
        {-Create the priority queue}
      destructor Destroy; override;
        {-Dispose of the priority queue - items remaining are NOT
          freed}

      procedure Add(aItem : pointer);
        {-Add an item to the priority queue}
      function Remove : pointer;
        {-Remove and return the item with the largest priority}

      property Count : integer read pqGetCount;
        {-Count of items in the queue}
  end;

type
  TaaPriorityQueue = class
    {-A priority queue that uses the heap algorithm}
    private
      pqCompare      : TaaItemPriorityCompare;
      pqExternalList : boolean;
      pqList         : TList;
    protected
      function pqGetCount : integer;

      procedure pqBubbleUp(aFromInx : integer; aItem : pointer);
      procedure pqMakeIntoHeap;
      procedure pqTrickleDown(aFromInx : integer; aItem : pointer);
    public
      constructor Create(aCompareFn : TaaItemPriorityCompare);
        {-Create the priority queue}
      constructor CreateWithList(aCompareFn : TaaItemPriorityCompare;
                                 aList      : TList);
        {-Create the priority queue with an existing list}
      destructor Destroy; override;
        {-Dispose of the priority queue - items remaining are NOT
          freed}

      procedure Add(aItem : pointer);
        {-Add an item to the priority queue}
      function Remove : pointer;
        {-Remove and return the item with the largest priority}

      property Count : integer read pqGetCount;
        {-Count of items in the queue}


      property List : TList read pqList;
  end;

type
  TaaPQHandle = pointer;

  TaaPriorityQueueEx = class
    {-A priority queue that uses the heap algorithm and that allows
      deletion and reprioritisation of arbitrary items}
    private
      pqCompare : TaaItemPriorityCompare;
      pqHandles : pointer;
      pqList    : TList;
    protected
      function pqGetCount : integer;

      procedure pqBubbleUp(aFromInx : integer; aHandle : pointer);
      procedure pqTrickleDown(aFromInx : integer; aHandle : pointer);

      {$IFOPT D+}
      procedure VerifyIndirection;
      {$ENDIF}

    public
      constructor Create(aCompareFn : TaaItemPriorityCompare);
        {-Create the priority queue}
      destructor Destroy; override;
        {-Dispose of the priority queue - items remaining are NOT
          freed}

      function Add(aItem : pointer) : TaaPQHandle;
        {-Add an item to the priority queue; return handle}
      procedure Delete(var aHandle : TaaPQHandle);
        {-Delete an item referenced by its handle from the priority
          queue; the handle is set to nil on return}
      function Remove : pointer;
        {-Remove and return the item with the largest priority}
      procedure Replace(aHandle : TaaPQHandle; aItem : pointer);
        {-Replace the item referenced by the handle in the priority
          queue}

      property Count : integer read pqGetCount;
        {-Count of items in the queue}

      property List : TList read pqList;
  end;

implementation

{===TaaPriorityQueueA================================================}
constructor TaaPriorityQueueA.Create(aCompareFn : TaaItemPriorityCompare);
begin
  inherited Create;
  pqCompare := aCompareFn;
  pqList := TList.Create;
end;
{--------}
destructor TaaPriorityQueueA.Destroy;
begin
  pqList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaPriorityQueueA.Add(aItem : pointer);
begin
  pqList.Add(aItem);
end;
{--------}
function TaaPriorityQueueA.pqGetCount : integer;
begin
  Result := pqList.Count;
end;
{--------}
function TaaPriorityQueueA.Remove : pointer;
var
  Inx     : integer;
  PQCount : integer;
  MaxInx  : integer;
  MaxItem : pointer;
begin
  PQCount := Count;
  if (PQCount = 0) then
    Result := nil
  else if (PQCount = 1) then begin
    Result := pqList[0];
    pqList.Clear;
  end
  else begin
    MaxItem := pqList[0];
    MaxInx := 0;
    for Inx := 1 to pred(PQCount) do
      if (pqCompare(pqList[Inx], MaxItem) > 0) then begin
        MaxItem := pqList[Inx];
        MaxInx := Inx;
      end;
    Result := MaxItem;
    pqList.Delete(MaxInx);
  end;
end;
{====================================================================}


{===TaaPriorityQueueB================================================}
constructor TaaPriorityQueueB.Create(aCompareFn : TaaItemPriorityCompare);
begin
  inherited Create;
  pqCompare := aCompareFn;
  pqList := TList.Create;
end;
{--------}
destructor TaaPriorityQueueB.Destroy;
begin
  pqList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaPriorityQueueB.Add(aItem : pointer);
var
  Inx : integer;
begin
  {increment the number of items in the list}
  pqList.Count := pqList.Count + 1;
  {find where to put our new item}
  Inx := pqList.Count - 2;
  while (Inx >= 0) and
        (pqCompare(pqList[Inx], aItem) > 0) do begin
    pqList[Inx+1] := pqList[Inx];
    dec(Inx);
  end;
  {put it there}
  pqList[Inx+1] := aItem;
end;
{--------}
function TaaPriorityQueueB.pqGetCount : integer;
begin
  Result := pqList.Count;
end;
{--------}
function TaaPriorityQueueB.Remove : pointer;
begin
  Result := pqList.Last;
  pqList.Count := pqList.Count - 1;
end;
{====================================================================}


{===TaaPriorityQueue=================================================}
constructor TaaPriorityQueue.Create(aCompareFn : TaaItemPriorityCompare);
begin
  inherited Create;
  pqCompare := aCompareFn;
  pqList := TList.Create;
end;
{--------}
constructor TaaPriorityQueue.CreateWithList(aCompareFn : TaaItemPriorityCompare;
                                            aList      : TList);
begin
  inherited Create;
  pqCompare := aCompareFn;
  pqList := aList;
  pqExternalList := true;
  pqMakeIntoHeap;
end;
{--------}
destructor TaaPriorityQueue.Destroy;
begin
  if not pqExternalList then
    pqList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaPriorityQueue.Add(aItem : pointer);
begin
  {add extra space at the end of the queue}
  pqList.Count := pqList.Count + 1;
  {now bubble it up as far as it will go}
  pqBubbleUp(pred(pqList.Count), aItem);
end;
{--------}
procedure TaaPriorityQueue.pqBubbleUp(aFromInx : integer; aItem : pointer);
var
  ParentInx : integer;
begin
  {while the item under consideration is larger than its parent, swap
   it with its parent and continue from its new position}
  {Note: the parent for the child at index N is at (N-1) div 2}
  ParentInx := (aFromInx - 1) div 2;
  {while our item has a parent, and it's greater than the parent...}
  while (aFromInx > 0) and
        (pqCompare(aItem, pqList[ParentInx]) > 0) do begin
    {move our parent down the tree}
    pqList[aFromInx] := pqList[ParentInx];
    aFromInx := ParentInx;
    ParentInx := (aFromInx - 1) div 2;
  end;
  {store our item in the correct place}
  pqList[aFromInx] := aItem;
end;
{--------}
function TaaPriorityQueue.pqGetCount : integer;
begin
  Result := pqList.Count;
end;
{--------}
procedure TaaPriorityQueue.pqMakeIntoHeap;
var
  Inx : integer;
begin
  {starting from the lowest, rightmost parent, trickle down and then
   continue with the rest of the parents from right to left, bottom to
   top. The rightmost parent is the parent of the last item. This is
   ((count-1)-1) div 2}
  for Inx := ((pqList.Count - 2) div 2) downto 0 do
    pqTrickleDown(Inx, pqList[Inx]);
end;
{--------}
procedure TaaPriorityQueue.pqTrickleDown(aFromInx : integer; aItem : pointer);
var
  ChildInx  : integer;
  ListCount : integer;
begin
  {while the item under consideration is smaller than one of its
   children, swap it with the larger child and continue from its new
   position}
  {Note: the children for the parent at index N are at (2N+1) and
         2N+2}
  ListCount := pqList.Count;
  {calculate the left child index}
  ChildInx := succ(aFromInx * 2);
  {while there is at least a left child...}
  while (ChildInx < ListCount) do begin
    {if there is a right child, calculate the index of the larger
     child}
    if (succ(ChildInx) < ListCount) and
       (pqCompare(pqList[ChildInx], pqList[succ(ChildInx)]) < 0) then
      inc(ChildInx);
    {if our item is greater or equal to the larger child, we're done}
    if (pqCompare(aItem, pqList[ChildInx]) >= 0) then
      Break;
    {otherwise move the larger child up the tree, and move our item
     down the tree and repeat}
    pqList[aFromInx] := pqList[ChildInx];
    aFromInx := ChildInx;
    ChildInx := succ(aFromInx * 2);
  end;
  {store our item in the correct place}
  pqList[aFromInx] := aItem;
end;
{--------}
function TaaPriorityQueue.Remove : pointer;
begin
  {return the item at the root}
  Result := pqList[0];
  {replace the root with the child at the lowest, rightmost position,
   and shrink the list}
  pqList[0] := pqList.Last;
  pqList.Count := pqList.Count - 1;
  {now trickle down the root item as far as it will go}
  if (pqList.Count > 0) then
    pqTrickleDown(0, pqList[0]);
end;
{====================================================================}


{===Linked list helper routines======================================}
type
  PllNode = ^TllNode;
  TllNode = packed record
    lliNext : PllNode;
    lliPrev : PllNode;
    lliItem : pointer;
    lliInx  : integer;
  end;
{--------}
function CreateLinkedList : PllNode;
begin
  Result := AllocMem(sizeof(TllNode));
  Result^.lliNext := AllocMem(sizeof(TllNode));
  Result^.lliNext^.lliPrev := Result;
end;
{--------}
procedure DestroyLinkedList(aLinkedList : PllNode);
var
  Temp : PllNode;
begin
  while (aLinkedList <> nil) do begin
    Temp := aLinkedList;
    aLinkedList := aLinkedList^.lliNext;
    FreeMem(Temp, sizeof(TllNode));
  end;
end;
{--------}
function AddLinkedListNode(aLinkedList : PllNode; aItem : pointer) : PllNode;
begin
  Result := AllocMem(sizeof(TllNode));
  Result^.lliNext := aLinkedList^.lliNext;
  Result^.lliPrev := aLinkedList;
  aLinkedList^.lliNext^.lliPrev := Result;
  aLinkedList^.lliNext := Result;
  Result^.lliItem := aItem;
end;
{--------}
procedure DeleteLinkedListNode(aLinkedList : PllNode; aNode : PllNode);
begin
  aNode^.lliPrev^.lliNext := aNode^.lliNext;
  aNode^.lliNext^.lliPrev := aNode^.lliPrev;
  FreeMem(aNode, sizeof(TllNode));
end;
{====================================================================}


{===TaaPriorityQueueEx===============================================}
constructor TaaPriorityQueueEx.Create(aCompareFn : TaaItemPriorityCompare);
begin
  inherited Create;
  pqCompare := aCompareFn;
  pqList := TList.Create;
  pqHandles := CreateLinkedList;
end;
{--------}
destructor TaaPriorityQueueEx.Destroy;
begin
  pqList.Free;
  DestroyLinkedList(pqHandles);
  inherited Destroy;
end;
{--------}
function TaaPriorityQueueEx.Add(aItem : pointer) : TaaPQHandle;
var
  Handle : PllNode;
begin
  {add extra space at the end of the queue}
  pqList.Count := pqList.Count + 1;
  {create a new node for the linked list}
  Handle := AddLinkedListNode(pqHandles, aItem);
  {now bubble it up as far as it will go}
  if (pqList.Count = 1) then begin
    pqList[0] := Handle;
    Handle^.lliInx := 0;
  end
  else
    pqBubbleUp(pred(pqList.Count), Handle);
  {return the handle}
  Result := Handle;
  {$IFOPT D+}
  VerifyIndirection;
  {$ENDIF}
end;
{--------}
procedure TaaPriorityQueueEx.Delete(var aHandle : TaaPQHandle);
var
  Handle    : PllNode absolute aHandle;
  NewHandle : PllNode;
  HeapInx   : integer;
  ParentInx    : integer;
  ParentHandle : PllNode;
begin
  {delete the handle}
  HeapInx := Handle^.lliInx;
  DeleteLinkedListNode(pqHandles, Handle);
  Handle := nil;
  {check to see whether we deleted the last item, if so just shrink
   the heap - the heap property will still apply}
  if (HeapInx = pred(pqList.Count)) then
    pqList.Count := pqList.Count - 1
  else begin
    {replace the heap element with the child at the lowest, rightmost
     position, and shrink the list}
    NewHandle := pqList.Last;
    pqList[HeapInx] := NewHandle;
    NewHandle^.lliInx := HeapInx;
    pqList.Count := pqList.Count - 1;
    {check to see whether we can bubble up}
    if (HeapInx > 0) then begin
      ParentInx := (HeapInx - 1) div 2;
      ParentHandle := PllNode(pqList[ParentInx]);
      if (pqCompare(NewHandle^.lliItem, ParentHandle^.lliItem) > 0) then begin
        pqBubbleUp(HeapInx, NewHandle);
        {$IFOPT D+}
        VerifyIndirection;
        {$ENDIF}
        Exit;
      end;
    end;
    {otherwise trickle down}
    if (pqList.Count > 0) then
      pqTrickleDown(HeapInx, pqList[HeapInx]);
  end;
  {$IFOPT D+}
  VerifyIndirection;
  {$ENDIF}
end;
{--------}
procedure TaaPriorityQueueEx.pqBubbleUp(aFromInx : integer; aHandle : pointer);
var
  ParentInx    : integer;
  ParentHandle : PllNode;
  Handle       : PllNode absolute aHandle;
begin
  {while the handle under consideration is larger than its parent,
   swap it with its parent and continue from its new position}
  {Note: the parent for the child at index N is at (N-1) div 2}
  if (aFromInx > 0) then begin
    ParentInx := (aFromInx - 1) div 2;
    ParentHandle := PllNode(pqList[ParentInx]);
    {while our item has a parent, and it's greater than the parent...}
    while (aFromInx > 0) and
          (pqCompare(Handle^.lliItem, ParentHandle^.lliItem) > 0) do begin
      {move our parent down the tree}
      pqList[aFromInx] := ParentHandle;
      ParentHandle^.lliInx := aFromInx;
      aFromInx := ParentInx;
      ParentInx := (aFromInx - 1) div 2;
      ParentHandle := PllNode(pqList[ParentInx]);
    end;
  end;
  {store our item in the correct place}
  pqList[aFromInx] := Handle;
  Handle^.lliInx := aFromInx;
end;
{--------}
function TaaPriorityQueueEx.pqGetCount : integer;
begin
  Result := pqList.Count;
end;
{--------}
procedure TaaPriorityQueueEx.pqTrickleDown(aFromInx : integer; aHandle : pointer);
var
  ListCount   : integer;
  ChildInx    : integer;
  ChildHandle : PllNode;
  Handle      : PllNode absolute aHandle;
begin
  {while the item under consideration is smaller than one of its
   children, swap it with the larger child and continue from its new
   position}
  {Note: the children for the parent at index N are at (2N+1) and
         2N+2}
  ListCount := pqList.Count;
  {calculate the left child index}
  ChildInx := succ(aFromInx * 2);
  {while there is at least a left child...}
  while (ChildInx < ListCount) do begin
    {if there is a right child, calculate the index of the larger
     child}
    if (succ(ChildInx) < ListCount) and
       (pqCompare(PllNode(pqList[ChildInx])^.lliItem,
                  PllNode(pqList[succ(ChildInx)])^.lliItem) < 0) then
      inc(ChildInx);
    {if our item is greater or equal to the larger child, we're done}
    ChildHandle := PllNode(pqList[ChildInx]);
    if (pqCompare(Handle^.lliItem, ChildHandle^.lliItem) >= 0) then
      Break;
    {otherwise move the larger child up the tree, and move our item
     down the tree and repeat}
    pqList[aFromInx] := ChildHandle;
    ChildHandle^.lliInx := aFromInx;
    aFromInx := ChildInx;
    ChildInx := succ(aFromInx * 2);
  end;
  {store our item in the correct place}
  pqList[aFromInx] := Handle;
  Handle^.lliInx := aFromInx;
end;
{--------}
function TaaPriorityQueueEx.Remove : pointer;
var
  Handle : PllNode;
begin
  {return the item at the root}
  Handle := pqList[0];
  Result := Handle^.lliItem;
  DeleteLinkedListNode(pqHandles, Handle);
  {replace the root with the child at the lowest, rightmost position,
   and shrink the list}
  Handle := pqList.Last;
  pqList[0] := Handle;
  Handle^.lliInx := 0;
  pqList.Count := pqList.Count - 1;
  {now trickle down the root item as far as it will go}
  if (pqList.Count > 0) then
    pqTrickleDown(0, Handle);
  {$IFOPT D+}
  VerifyIndirection;
  {$ENDIF}
end;
{--------}
procedure TaaPriorityQueueEx.Replace(aHandle : TaaPQHandle; aItem : pointer);
var
  Handle : PllNode absolute aHandle;
  ParentInx    : integer;
  ParentHandle : PllNode;
begin
  {first, replace the item}
  Handle^.lliItem := aItem;
  {check to see whether we can bubble up}
  if (Handle^.lliInx > 0) then begin
    ParentInx := (Handle^.lliInx - 1) div 2;
    ParentHandle := PllNode(pqList[ParentInx]);
    if (pqCompare(Handle^.lliItem, ParentHandle^.lliItem) > 0) then begin
      pqBubbleUp(Handle^.lliInx, Handle);
      {$IFOPT D+}
      VerifyIndirection;
      {$ENDIF}
      Exit;
    end;
  end;
  {otherwise trickle down}
  pqTrickleDown(Handle^.lliInx, Handle);
  {$IFOPT D+}
  VerifyIndirection;
  {$ENDIF}
end;
{--------}
{$IFOPT D+}
procedure TaaPriorityQueueEx.VerifyIndirection;
var
  i : integer;
  Handle : PllNode;
begin
  for i := 0 to pred(pqList.Count) do begin
    Handle := PllNode(pqList[i]);
    if (Handle^.lliInx <> i) then begin
      writeln('ERROR: Handle at ', i, ' doesn''t point to it');
      readln;
    end;
  end;
end;
{$ENDIF}
{====================================================================}

end.