source: tags/1.3.1/AI/StdAI/Pile.pas

{single instance priority queue
main parts contributed by Rassim Eminli}

{$INCLUDE Switches.inc}

unit Pile;

interface

procedure Create(Size: integer);
procedure Free;
procedure Empty;
function Put(Item, Value: integer): boolean;
function TestPut(Item, Value: integer): boolean;
function Get(var Item, Value: integer): boolean;


implementation

const
  MaxSize = 9600;

type
  TheapItem = record
    Item: integer;
    Value: integer;
  end;

var
  bh: array[0..MaxSize - 1] of TheapItem;
  Ix: array[0..MaxSize - 1] of integer;
  n, CurrentSize: integer;
{$IFDEF DEBUG}InUse: boolean;{$ENDIF}


procedure Create(Size: integer);
begin
  {$IFDEF DEBUG}
  assert(not InUse, 'Pile is a single instance class, ' +
    'no multiple usage possible. Always call Pile.Free after use.');
{$ENDIF}
  assert(Size <= MaxSize);
  if (n <> 0) or (Size > CurrentSize) then
  begin
    FillChar(Ix, Size * sizeOf(integer), 255);
    n := 0;
  end;
  CurrentSize := Size;
        {$IFDEF DEBUG}
  InUse := True;
{$ENDIF}
end;

procedure Free;
begin
        {$IFDEF DEBUG}
  assert(InUse);
  InUse := False;
{$ENDIF}
end;

procedure Empty;
begin
  if n <> 0 then
  begin
    FillChar(Ix, CurrentSize * sizeOf(integer), 255);
    n := 0;
  end;
end;

//Parent(i) = (i-1)/2.
function Put(Item, Value: integer): boolean; //O(lg(n))
var
  i, j: integer;
begin
  assert(Item < CurrentSize);
  i := Ix[Item];
  if i >= 0 then
  begin
    if bh[i].Value <= Value then
    begin
      Result := False;
      exit;
    end;
  end
  else
  begin
    i := n;
    Inc(n);
  end;

  while i > 0 do
  begin
    j := (i - 1) shr 1;  //Parent(i) = (i-1)/2
    if Value >= bh[j].Value then
      break;
    bh[i] := bh[j];
    Ix[bh[i].Item] := i;
    i := j;
  end;
  //  Insert the new Item at the insertion point found.
  bh[i].Value := Value;
  bh[i].Item := Item;
  Ix[bh[i].Item] := i;
  Result := True;
end;

function TestPut(Item, Value: integer): boolean;
var
  i: integer;
begin
  assert(Item < CurrentSize);
  i := Ix[Item];
  Result := (i < 0) or (bh[i].Value > Value);
end;

//Left(i) = 2*i+1.
//Right(i) = 2*i+2 => Left(i)+1
function Get(var Item, Value: integer): boolean; //O(lg(n))
var
  i, j: integer;
  last: TheapItem;
begin
  if n = 0 then
  begin
    Result := False;
    exit;
  end;

  Item := bh[0].Item;
  Value := bh[0].Value;

  Ix[Item] := -1;

  Dec(n);
  if n > 0 then
  begin
    last := bh[n];
    i := 0;
    j := 1;
    while j < n do
    begin
      //  Right(i) = Left(i)+1
      if (j < n - 1) and (bh[j].Value > bh[j + 1].Value) then
        Inc(j);
      if last.Value <= bh[j].Value then
        break;

      bh[i] := bh[j];
      Ix[bh[i].Item] := i;
      i := j;
      j := j shl 1 + 1;  //Left(j) = 2*j+1
    end;

    // Insert the root in the correct place in the heap.
    bh[i] := last;
    Ix[last.Item] := i;
  end;
  Result := True;
end;

initialization
  n := 0;
  CurrentSize := 0;
        {$IFDEF DEBUG}
  InUse := False;
{$ENDIF}
end.