unit Heaps;

{ This is a simple priority queue implemented as a heap. }

interface

  Type
    IHeapable =
      Interface(IInterface)
      ['{74437D8D-C30E-42C8-BB01-C27017FB3CE4}']
        Function ComesBefore(Other : IHeapable) : Boolean;
      End;

    THeap =
      Class(TObject)
      Private
        Items : Array Of IHeapable;
        FItemCount : Integer;

        { Promote this item as far as possible, per the standard heap
          algorithm. }
        Procedure FloatItem(Current : Integer);
      Public

        { Items in the heap. }
        Property ItemCount : Integer Read FItemCount;

        { Returns a pointer to the first item, but changes nothing. }
        Function Peek : IHeapable;

        { Returns a pointer to the first item, and removes that item. }
        Function Pop : IHeapable;

        { Add the given item to an appropriate place in the heap. }
        Procedure Push(Item : IHeapable);
      End;

implementation

  Uses
    Math;

  Function THeap.Peek : IHeapable;
    Begin
      If ItemCount = 0 Then
        Result := Nil
      Else
        Result := Items[0]
    End;

  Function THeap.Pop : IHeapable;
    Var
      Current, LeftChild, RightChild, Next : Integer;
      Done : Boolean;
    Begin
      If ItemCount = 0 Then
        Result := Nil
      Else
        Begin
          Result := Items[0];
          Current := 0;
          Done := False;
          Repeat
            LeftChild := Succ(Current * 2);
            RightChild := Succ(LeftChild);
            If RightChild = ItemCount Then
              Begin
                { We only have a left child. }
                Items[Current] := Items[LeftChild];
                Current := LeftChild
              End
            Else If RightChild > ItemCount Then
              Begin
                { We have no children. }
                Done := True;
                Items[Current] := Nil
              End
            Else
              Begin
                { We have two children. }
                If Items[LeftChild].ComesBefore(Items[RightChild]) Then
                  Next := LeftChild
                Else
                  Next := RightChild;
                Items[Current] := Items[Next];
                Current := Next
              End
          Until Done;
          Dec(FItemCount);
          If Current < ItemCount Then
            Begin
              Items[Current] := Items[ItemCount];
              FloatItem(Current)
            End
        End
    End;

  Procedure THeap.Push(Item : IHeapable);
    Begin
      Assert(Assigned(Item));
      If ItemCount = Length(Items) Then
        SetLength(Items, Max(11, 2 * Length(Items)));
      Items[ItemCount] := Item;
      FloatItem(ItemCount);
      Inc(FItemCount)
    End;

  Procedure THeap.FloatItem(Current : Integer);
    Var
      Parent : Integer;
      SwapTemp : IHeapable;
    Begin
      Repeat
        If Current = 0 Then
          Exit;
        Parent := Pred(Succ(Current) Div 2);
        If Items[Parent].ComesBefore(Items[Current]) Then
          Exit;
        SwapTemp := Items[Parent];
        Items[Parent] := Items[Current];
        Items[Current] := SwapTemp;
        Current := Parent
      Until False
    End;

End.