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   // WARNING! don't put structures into heap, use ponters or ids!
  25   generic TBinaryHeapBase<ITP> = class(TObject)
  26   private
  27     type
  28       TBinaryHeapLessFn = function (a, b: ITP): Boolean;
  29
  30   private
  31     elem: array of ITP;
  32     elemUsed: Integer;
  33     lessfn: TBinaryHeapLessFn;
  34
  35   private
  36     procedure heapify (root: Integer);
  37
  38   public
  39     constructor Create (alessfn: TBinaryHeapLessFn);
  40     destructor Destroy (); override;
  41
  42     procedure clear ();
  43
  44     procedure insert (val: ITP);
  45
  46     function front (): ITP;
  47     procedure popFront ();
  48
  49     property count: Integer read elemUsed;
  50   end;
  51
  52
  53 type
  54   TBinaryHeapObj = specialize TBinaryHeapBase<TObject>;
  55   TBinaryHeapInt = specialize TBinaryHeapBase<Integer>;
  56
  57
  58 function binHeapNewIntLess (): TBinaryHeapInt;
  59 function binHeapNewIntGreat (): TBinaryHeapInt;
  60
  61
  62 implementation
  63
  64 uses
  65   SysUtils;
  66
  67
  68 // ////////////////////////////////////////////////////////////////////////// //
  69 function intLess (a, b: Integer): Boolean; begin result := (a < b); end;
  70 function intGreat (a, b: Integer): Boolean; begin result := (a > b); end;
  71
  72
  73 function binHeapNewIntLess (): TBinaryHeapInt; begin result := TBinaryHeapInt.Create(@intLess); end;
  74 function binHeapNewIntGreat (): TBinaryHeapInt; begin result := TBinaryHeapInt.Create(@intGreat); end;
  75
  76
  77 // ////////////////////////////////////////////////////////////////////////// //
  78 constructor TBinaryHeapBase.Create (alessfn: TBinaryHeapLessFn);
  79 begin
  80   if not assigned(alessfn) then raise Exception.Create('wutafuck?!');
  81   lessfn := alessfn;
  82   SetLength(elem, 128); // 'cause why not?
  83   elemUsed := 0;
  84 end;
  85
  86
  87 destructor TBinaryHeapBase.Destroy ();
  88 begin
  89   elem := nil;
  90   inherited;
  91 end;
  92
  93
  94 procedure TBinaryHeapBase.clear ();
  95 begin
  96   elemUsed := 0;
  97 end;
  98
  99
 100 procedure TBinaryHeapBase.heapify (root: Integer);
 101 var
 102   smallest, right: Integer;
 103   tmp: ITP;
 104 begin
 105   while true do
 106   begin
 107     smallest := 2*root+1; // left child
 108     if (smallest >= elemUsed) then break; // anyway
 109     right := smallest+1; // right child
 110     if not lessfn(elem[smallest], elem[root]) then smallest := root;
 111     if (right < elemUsed) and (lessfn(elem[right], elem[smallest])) then smallest := right;
 112     if (smallest = root) then break;
 113     // swap
 114     tmp := elem[root];
 115     elem[root] := elem[smallest];
 116     elem[smallest] := tmp;
 117     root := smallest;
 118   end;
 119 end;
 120
 121
 122 procedure TBinaryHeapBase.insert (val: ITP);
 123 var
 124   i, par: Integer;
 125 begin
 126   //if (val = nil) then exit;
 127   i := elemUsed;
 128   // grow?
 129   if (i = Length(elem)) then
 130   begin
 131     if (i <= 65536) then par := i*2 else par := i+65536; // arbitrary numbers
 132     SetLength(elem, par);
 133   end;
 134   // increase counter
 135   Inc(elemUsed);
 136   // insert element
 137   while (i <> 0) do
 138   begin
 139     par := (i-1) div 2; // parent
 140     if not lessfn(val, elem[par]) then break;
 141     elem[i] := elem[par];
 142     i := par;
 143   end;
 144   elem[i] := val;
 145 end;
 146
 147 function TBinaryHeapBase.front (): ITP;
 148 begin
 149   if elemUsed > 0 then result := elem[0] else result := Default(ITP);
 150 end;
 151
 152
 153 procedure TBinaryHeapBase.popFront ();
 154 begin
 155   if (elemUsed > 0) then
 156   begin
 157     Dec(elemUsed);
 158     elem[0] := elem[elemUsed];
 159     heapify(0);
 160   end;
 161 end;
 162
 163
 164 end.