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