DEADSOFTWARE

Fix crash in some commands
[d2df-sdl.git] / 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;
19 interface
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;
33 private
34 procedure heapify (root: Integer);
36 public
37 constructor Create ();
38 destructor Destroy (); override;
40 procedure clear ();
42 procedure insert (val: ITP);
44 function front (): ITP;
45 procedure popFront ();
47 property count: Integer read elemUsed;
48 end;
51 type
52 TBinHeapKeyIntLess = class
53 public
54 class function less (const a, b: Integer): Boolean; inline;
55 end;
57 TBinHeapKeyIntGreat = class
58 public
59 class function less (const a, b: Integer): Boolean; inline;
60 end;
63 type
64 TBinaryHeapIntLess = specialize TBinaryHeapBase<Integer, TBinHeapKeyIntLess>;
65 TBinaryHeapIntGreat = specialize TBinaryHeapBase<Integer, TBinHeapKeyIntGreat>;
68 implementation
70 uses
71 SysUtils;
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;
79 // ////////////////////////////////////////////////////////////////////////// //
80 constructor TBinaryHeapBase.Create ();
81 begin
82 SetLength(elem, 128); // 'cause why not?
83 elemUsed := 0;
84 end;
87 destructor TBinaryHeapBase.Destroy ();
88 begin
89 elem := nil;
90 inherited;
91 end;
94 procedure TBinaryHeapBase.clear ();
95 begin
96 elemUsed := 0;
97 end;
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;
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;
147 function TBinaryHeapBase.front (): ITP;
148 begin
149 if elemUsed > 0 then result := elem[0] else result := Default(ITP);
150 end;
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;
164 end.