src/shared/binheap.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 // binary heap
  18 unit binheap;
  19
  20 interface
  21
  22
  23 type
  24   TBinaryHeapLessFn = function (a, b: TObject): Boolean;
  25
  26   TBinaryHeapObj = class(TObject)
  27   private
  28     elem: array of TObject;
  29     elemUsed: Integer;
  30     lessfn: TBinaryHeapLessFn;
  31
  32   private
  33     procedure heapify (root: Integer);
  34
  35   public
  36     constructor Create (alessfn: TBinaryHeapLessFn);
  37     destructor Destroy (); override;
  38
  39     procedure clear ();
  40
  41     procedure insert (val: TObject);
  42
  43     function front (): TObject;
  44     procedure popFront ();
  45
  46     property count: Integer read elemUsed;
  47   end;
  48
  49
  50 implementation
  51
  52 uses
  53   SysUtils;
  54
  55
  56 // ////////////////////////////////////////////////////////////////////////// //
  57 constructor TBinaryHeapObj.Create (alessfn: TBinaryHeapLessFn);
  58 begin
  59   if not assigned(alessfn) then raise Exception.Create('wutafuck?!');
  60   lessfn := alessfn;
  61   SetLength(elem, 8192); // 'cause why not?
  62   elemUsed := 0;
  63 end;
  64
  65
  66 destructor TBinaryHeapObj.Destroy ();
  67 begin
  68   elem := nil;
  69   inherited;
  70 end;
  71
  72
  73 procedure TBinaryHeapObj.clear ();
  74 begin
  75   elemUsed := 0;
  76 end;
  77
  78
  79 procedure TBinaryHeapObj.heapify (root: Integer);
  80 var
  81   smallest, right: Integer;
  82   tmp: TObject;
  83 begin
  84   while true do
  85   begin
  86     smallest := 2*root+1; // left child
  87     if (smallest >= elemUsed) then break; // anyway
  88     right := smallest+1; // right child
  89     if not lessfn(elem[smallest], elem[root]) then smallest := root;
  90     if (right < elemUsed) and (lessfn(elem[right], elem[smallest])) then smallest := right;
  91     if (smallest = root) then break;
  92     // swap
  93     tmp := elem[root];
  94     elem[root] := elem[smallest];
  95     elem[smallest] := tmp;
  96     root := smallest;
  97   end;
  98 end;
  99
 100
 101 procedure TBinaryHeapObj.insert (val: TObject);
 102 var
 103   i, par: Integer;
 104 begin
 105   if (val = nil) then exit;
 106   i := elemUsed;
 107   if (i = Length(elem)) then SetLength(elem, Length(elem)+16384); // arbitrary number
 108   Inc(elemUsed);
 109   while (i <> 0) do
 110   begin
 111     par := (i-1) div 2; // parent
 112     if not lessfn(val, elem[par]) then break;
 113     elem[i] := elem[par];
 114     i := par;
 115   end;
 116   elem[i] := val;
 117 end;
 118
 119 function TBinaryHeapObj.front (): TObject;
 120 begin
 121   if elemUsed > 0 then result := elem[0] else result := nil;
 122 end;
 123
 124
 125 procedure TBinaryHeapObj.popFront ();
 126 begin
 127   if (elemUsed > 0) then
 128   begin
 129     Dec(elemUsed);
 130     elem[0] := elem[elemUsed];
 131     heapify(0);
 132   end;
 133 end;
 134
 135
 136 end.