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

interface

type
   generic THeap <T, Utils> = record // for Utils see MinHeapAdapter/MaxHeapAdapter below
   public
      type
         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 Insert(NewValue: T);
      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;
   I: T;
begin
   Write('DownHeap(', Index, ') for [');
   for I in FData do
      Write(' ', I);
   Writeln(' ]');
   repeat
      Writeln('  parent index ', Index, '; value: ', FData[Index]);
      WinningIndex := Index;
      ChildIndex := LeftChildFor(Index);
      if (ChildIndex < FCount) then
      begin
         Writeln('  child index 1: ', ChildIndex, '; value: ', FData[ChildIndex]);
         if (not IsOrdered(WinningIndex, ChildIndex)) then
         begin
            WinningIndex := ChildIndex;
            Writeln('    child 1 is not ordered');
         end;
         Inc(ChildIndex);
         if (ChildIndex < FCount) then
         begin
            Writeln('  child index 2: ', ChildIndex, '; value: ', FData[ChildIndex]);
            if (not IsOrdered(WinningIndex, ChildIndex)) then
            begin
               Writeln('    child 2 is not ordered');
               WinningIndex := ChildIndex;
            end;
         end;
         if (Index <> WinningIndex) then
         begin
            Writeln('  swapping ', Index, ' (', FData[Index], ') with ', WinningIndex, ' (', FData[WinningIndex], ')');
            Assert(Utils.IsOrdered(FData[WinningIndex], FData[Index]));
            Temp := FData[Index];
            FData[Index] := FData[WinningIndex];
            FData[WinningIndex] := Temp;
            Index := WinningIndex;
         end;
      end;
   until Index = WinningIndex;
   Writeln('  done at ', Index);
end;

procedure THeap.BuildHeap();
var
   Index: Cardinal;
begin
   if (FCount > 1) then
      for Index := FCount div 2 downto 1 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.Insert(NewValue: T);
begin
   if (FCount = Length(FData)) then
      SetLength(FData, (FCount + 1) * 2);
   FData[FCount] := NewValue;
   UpHeap(FCount);
   Inc(FCount);
end;

function THeap.Extract(): T;
begin
   Assert(FCount > 0);
   Result := FData[0];
   Dec(FCount);
   if (FCount > 0) then
   begin
      FData[0] := FData[FCount];
      FData[FCount] := $FFFFFFFF;
      if (FCount > 1) then
         DownHeap(0);
   end;
   Writeln('EXTRACTED: ', Result);
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}
{$INCLUDE binaryheap.tests.inc}
{$POP}
initialization
   RunTests();
{$ENDIF}
end.