source: tags/1.2.0/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.