binaryheap.pas

{$MODE OBJFPC} { -*- delphi -*- }
{$INCLUDE settings.inc}
unit binaryheap;

interface

type
   generic THeap <T, Utils> = record // for Utils see MinHeapAdapter/MaxHeapAdapter below
   public
      type
         P = ^T;
         TArray = array of T;
   strict private
      FData: TArray;
      FCount: Cardinal;
      class operator Initialize(var Rec: THeap);
      class operator Copy(constref Src: THeap; var Dst: THeap); unimplemented;
      class function ParentFor(Index: Cardinal): Cardinal; static; inline;
      class function LeftChildFor(Index: Cardinal): Cardinal; static; inline; 
      function IsOrdered(A, B: Cardinal): Boolean; inline;
      procedure UpHeap(Index: Cardinal);
      procedure DownHeap(Index: Cardinal);
      procedure BuildHeap();
   public
      procedure AdoptInit(var Source: TArray; ExpectedInsertionCount: Cardinal = 0);
      procedure Clear(); // does not release memory, only resets population count
      procedure Free(); // releases memory
      procedure Insert(NewValue: T);
      function Peek(): T; inline;
      function PeekPtr(): P; inline; // pointer is only valid until next call into this structure; which must be Poke if the entry's value is changed
      procedure Poke(); inline; // call this after changing the entry received by PeekPtr
      function Extract(): T;
      function InsertThenExtract(NewValue: T): T;
      function ExtractThenInsert(NewValue: T): T;
      property Count: Cardinal read FCount;
   end;

type
   generic MinHeapAdapter <T, Utils> = record // for Utils see genericutils (only GreaterThan is needed)
      function IsOrdered(const A, B: T): Boolean; inline;
   end;

   generic MaxHeapAdapter <T, Utils> = record // for Utils see genericutils (only LessThan is needed)
      function IsOrdered(const A, B: T): Boolean; inline;
   end;
   
implementation

uses
   sysutils;


function MinHeapAdapter.IsOrdered(const A, B: T): Boolean;
begin
   Result := not Utils.GreaterThan(A, B);
end;


function MaxHeapAdapter.IsOrdered(const A, B: T): Boolean;
begin
   Result := not Utils.LessThan(A, B);
end;


class operator THeap.Initialize(var Rec: THeap);
begin
   Rec.FCount := 0;
end;

class operator THeap.Copy(constref Src: THeap; var Dst: THeap);
begin
   raise Exception.Create('Attempted to copy a THeap.');
end;

class function THeap.ParentFor(Index: Cardinal): Cardinal;
begin
   Assert(Index > 0);
   Result := (Index - 1) div 2; // $R-
end;

class function THeap.LeftChildFor(Index: Cardinal): Cardinal;
begin
   Assert(Index < High(Integer));
   Result := 2 * Index + 1; // $R-
end;

function THeap.IsOrdered(A, B: Cardinal): Boolean;
begin
   Result := Utils.IsOrdered(FData[A], FData[B]);
end;

procedure THeap.UpHeap(Index: Cardinal);
var
   ParentIndex: Cardinal;
   Temp: T;
begin
   while (Index > 0) do
   begin
      ParentIndex := ParentFor(Index);
      if (IsOrdered(ParentIndex, Index)) then
         exit;
      Temp := FData[ParentIndex];
      FData[ParentIndex] := FData[Index];
      FData[Index] := Temp;
      Index := ParentIndex;
   end;
end;

procedure THeap.DownHeap(Index: Cardinal);
var
   ChildIndex: Cardinal;
   WinningIndex: Cardinal;
   Temp: T;
begin
   while (True) do
   begin
      WinningIndex := Index;
      ChildIndex := LeftChildFor(Index);
      if (ChildIndex < FCount) then
      begin
         if (not IsOrdered(WinningIndex, ChildIndex)) then
         begin
            WinningIndex := ChildIndex;
         end;
         Inc(ChildIndex);
         if (ChildIndex < FCount) then
         begin
            if (not IsOrdered(WinningIndex, ChildIndex)) then
            begin
               WinningIndex := ChildIndex;
            end;
         end;
         if (Index <> WinningIndex) then
         begin
            Assert(Utils.IsOrdered(FData[WinningIndex], FData[Index]));
            Temp := FData[Index];
            FData[Index] := FData[WinningIndex];
            FData[WinningIndex] := Temp;
            Index := WinningIndex;
         end
         else
            break;
      end
      else
         break;
   end;
end;

procedure THeap.BuildHeap();
var
   Index: Cardinal;
begin
   if (FCount > 1) then
      for Index := FCount div 2 - 1 downto 0 do // $R-
         DownHeap(Index);
end;

procedure THeap.AdoptInit(var Source: TArray; ExpectedInsertionCount: Cardinal = 0);
begin
   FData := Source;
   Source := nil;
   FCount := Length(FData); // $R-
   SetLength(FData, FCount + ExpectedInsertionCount);
   BuildHeap();
end;

procedure THeap.Clear();
begin
   FCount := 0;
end;

procedure THeap.Free();
begin
   FCount := 0;
   SetLength(FData, 0);
end;

procedure THeap.Insert(NewValue: T);
begin
   if (FCount = Length(FData)) then
      SetLength(FData, (FCount + 1) * 2);
   FData[FCount] := NewValue;
   UpHeap(FCount);
   Inc(FCount);
end;

function THeap.Peek(): T;
begin
   Assert(FCount > 0);
   Result := FData[0];
end;

function THeap.PeekPtr(): P;
begin
   Assert(FCount > 0);
   Result := @FData[0];
end;

procedure THeap.Poke();
begin
   Assert(FCount > 0);
   if (FCount > 1) then
      DownHeap(0);
end;

function THeap.Extract(): T;
begin
   Assert(FCount > 0);
   Result := FData[0];
   Dec(FCount);
   if (FCount > 0) then
   begin
      FData[0] := FData[FCount];
      if (FCount > 1) then
         DownHeap(0);
   end;
end;

function THeap.InsertThenExtract(NewValue: T): T;
begin
   if (Utils.IsOrdered(NewValue, FData[0])) then
   begin
      Result := NewValue;
   end
   else
   begin
      Result := FData[0];
      FData[0] := NewValue;
      if (FCount > 1) then
         DownHeap(0);
   end;
end;

function THeap.ExtractThenInsert(NewValue: T): T;
begin
   Assert(FCount > 0);
   Result := FData[0];
   FData[0] := NewValue;
   if (FCount > 1) then
      DownHeap(0);
end;

{$IFDEF TESTS}
{$PUSH}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$HINTS OFF}
{$INCLUDE binaryheap.tests.inc}
{$POP}
initialization
   RunTests();
{$ENDIF}
end.