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, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$INCLUDE a_modes.inc}
  16 // binary heap
  17 unit binheap;
  18
  19 interface
  20
  21
  22 (*
  23  * CmpObjT: class that contains class methods:
  24  *   class function less (const[ref] a, b: KeyT): Boolean;
  25  *)
  26 type
  27   // WARNING! don't put structures into heap, use ponters or ids!
  28   generic TBinaryHeapBase<ITP, CmpObjT> = class(TObject)
  29   private
  30     elem: array of ITP;
  31     elemUsed: Integer;
  32
  33   private
  34     procedure heapify (root: Integer);
  35
  36   public
  37     constructor Create ();
  38     destructor Destroy (); override;
  39
  40     procedure clear ();
  41
  42     procedure insert (val: ITP);
  43
  44     function front (): ITP;
  45     procedure popFront ();
  46
  47     property count: Integer read elemUsed;
  48   end;
  49
  50
  51 type
  52   TBinHeapKeyIntLess = class
  53   public
  54     class function less (const a, b: Integer): Boolean; inline;
  55   end;
  56
  57   TBinHeapKeyIntGreat = class
  58   public
  59     class function less (const a, b: Integer): Boolean; inline;
  60   end;
  61
  62
  63 type
  64   TBinaryHeapIntLess = specialize TBinaryHeapBase<Integer, TBinHeapKeyIntLess>;
  65   TBinaryHeapIntGreat = specialize TBinaryHeapBase<Integer, TBinHeapKeyIntGreat>;
  66
  67
  68 implementation
  69
  70 uses
  71   SysUtils;
  72
  73
  74 // ////////////////////////////////////////////////////////////////////////// //
  75 class function TBinHeapKeyIntLess.less (const a, b: Integer): Boolean; inline; begin result := (a < b); end;
  76 class function TBinHeapKeyIntGreat.less (const a, b: Integer): Boolean; inline; begin result := (a > b); end;
  77
  78
  79 // ////////////////////////////////////////////////////////////////////////// //
  80 constructor TBinaryHeapBase.Create ();
  81 begin
  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 CmpObjT.less(elem[smallest], elem[root]) then smallest := root;
 111     if (right < elemUsed) and (CmpObjT.less(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 CmpObjT.less(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.