File: dbf\b_tree_avl.adb
1 --::::::::::
2 --btreeavl.adb
3 --::::::::::
4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
5 -- Moscow, Russia,
6 -- Voice: 7 (095) 398-23-38
7 -- e-mail: edv@edv.msk.ru
8 -- This is free software; you can freely redistribute it and/or
9 -- modify it without any restrictions. Please report any errors.
10 -- All corrections will be made as soon as possible.
11 with unchecked_deallocation;
12 package body b_tree_avl is
13
14 type balance is (l_disb, no_disb, r_disb);
15
16 type tree_data is record
17 item: item_type;
18 data: data_type;
19 bal: balance := no_disb;
20 left, right: tree_type := null;
21 end record;
22
23 procedure free is new unchecked_deallocation(tree_data, tree_type);
24
25 --------------------------------------------------------------------
26
27 procedure insert (tree: in out tree_type;
28 item: item_type;
29 data: data_type) is
30
31 upd : boolean := false;
32 hght: boolean;
33
34 procedure tryput (node: in out tree_type; h: in out boolean) is
35 pp1, pp2: tree_type;
36 begin
37 if node = null then
38 node := new tree_data;
39 node.item := item;
40 node.data := data;
41 h := true;
42 elsif item < node.item then
43 tryput (node.left, h);
44 if h then
45 case node.bal is
46 when r_disb => node.bal := no_disb; h:= false;
47 when no_disb => node.bal := l_disb;
48 when l_disb =>
49 pp1 := node.left;
50 if pp1.bal = l_disb then
51 node.left := pp1.right;
52 pp1.right := node;
53 node.bal := no_disb; node := pp1;
54 else
55 pp2 := pp1.right;
56 pp1.right := pp2.left;
57 pp2.left := pp1;
58 node.left := pp2.right;
59 pp2.right := node;
60
61 if pp2.bal = l_disb then
62 node.bal := r_disb;
63 else
64 node.bal := no_disb;
65 end if;
66
67 if pp2.bal = r_disb then
68 pp1.bal := l_disb;
69 else
70 pp1.bal := no_disb;
71 end if;
72 node := pp2;
73 end if;
74 node.bal := no_disb; h:= false;
75 end case;
76 end if;
77 elsif node.item < item then
78 tryput (node.right, h);
79 if h then
80 case node.bal is
81 when l_disb => node.bal := no_disb; h:= false;
82 when no_disb => node.bal := r_disb;
83 when r_disb =>
84 pp1 := node.right;
85 if pp1.bal = r_disb then
86 node.right := pp1.left;
87 pp1.left := node;
88 node.bal := no_disb; node := pp1;
89 else
90 pp2 := pp1.left;
91 pp1.left := pp2.right;
92 pp2.right := pp1;
93 node.right := pp2.left;
94 pp2.left := node;
95
96 if pp2.bal = r_disb then
97 node.bal := l_disb;
98 else
99 node.bal := no_disb;
100 end if;
101
102 if pp2.bal = l_disb then
103 pp1.bal := r_disb;
104 else
105 pp1.bal := no_disb;
106 end if;
107 node := pp2;
108 end if;
109 node.bal := no_disb; h:= false;
110 end case;
111 end if;
112 else -- dup
113 if upd then
114 node.data := data;
115 end if;
116 end if;
117 end tryput;
118 begin
119 tryput (tree, hght);
120 end insert;
121
122 --------------------------------------------------------------------
123
124 procedure free_nodes (node: in out tree_type) is
125 begin
126 if node /= null then
127 free_nodes (node.left);
128 free_nodes (node.right);
129 free (node);
130 end if;
131 end;
132
133 --------------------------------------------------------------------
134
135 procedure delete (tree : in out tree_type) is
136 begin
137 free_nodes (tree);
138 end;
139
140 --------------------------------------------------------------------
141
142 procedure b_left (pp: in out tree_type; h: in out boolean) is
143 pp1, pp2: tree_type;
144 bb1, bb2: balance;
145 begin
146 case pp.bal is
147 when l_disb => pp.bal := no_disb;
148 when no_disb => pp.bal := r_disb; h := false;
149 when r_disb => pp1 := pp.right; bb1 := pp1.bal;
150 if bb1 >= no_disb then
151 pp.right := pp1.left; pp1.left := pp;
152 if bb1 = no_disb then
153 pp.bal := r_disb; pp1.bal := l_disb; h:= false;
154 else
155 pp.bal := no_disb; pp1.bal := no_disb;
156 end if;
157 pp := pp1;
158 else
159 pp2 := pp1.left; bb2 := pp2.bal;
160 pp1.left := pp2.right; pp2.right := pp1;
161 pp.right := pp2.left; pp2.left := pp;
162 if bb2 = r_disb then pp.bal := l_disb; else pp.bal := no_disb; end if;
163 if bb2 = l_disb then pp1.bal := r_disb; else pp1.bal := no_disb; end if;
164 pp := pp2; pp2.bal := no_disb;
165 end if;
166 end case;
167 end b_left;
168
169 --------------------------------------------------------------------
170
171 procedure b_right (pp: in out tree_type; h: in out boolean) is
172 pp1, pp2: tree_type;
173 bb1, bb2: balance;
174 begin
175 case pp.bal is
176 when r_disb => pp.bal := no_disb;
177 when no_disb => pp.bal := l_disb; h := false;
178 when l_disb => pp1 := pp.left; bb1 := pp1.bal;
179 if bb1 <= no_disb then
180 pp.left := pp1.right; pp1.right := pp;
181 if bb1 = no_disb then
182 pp.bal := l_disb; pp1.bal := r_disb; h:= false;
183 else
184 pp.bal := no_disb; pp1.bal := no_disb;
185 end if;
186 pp := pp1;
187 else
188 pp2 := pp1.right; bb2 := pp2.bal;
189 pp1.right := pp2.left; pp2.left := pp1;
190 pp.left := pp2.right; pp2.right := pp;
191 if bb2 = l_disb then pp.bal := r_disb; else pp.bal := no_disb; end if;
192 if bb2 = r_disb then pp1.bal := l_disb; else pp1.bal := no_disb; end if;
193 pp := pp2; pp2.bal := no_disb;
194 end if;
195 end case;
196 end b_right;
197
198 --------------------------------------------------------------------
199
200 procedure delete (tree : in out tree_type;
201 item : item_type;
202 data : out data_type;
203 ok : out boolean) is
204
205 hei: boolean;
206
207 procedure recur_del (p: in out tree_type; h: in out boolean) is
208 q: tree_type;
209 procedure x_del (node: in out tree_type; h: in out boolean) is
210 begin
211 if node.right /= null then
212 x_del (node.right, h);
213 if h then b_right (node, h); end if;
214 else
215 q.item := node.item;
216 q.data := node.data; q := node;
217 node := node.left; h := true;
218 end if;
219 end x_del;
220
221 begin
222 if p = null then return;
223 elsif item < p.item then
224 recur_del (p.left, h);
225 if h then b_left (p, h); end if;
226 elsif p.item = item then
227 q := p;
228 if q.right = null then
229 p := q.left; h:= true;
230 elsif q.left = null then
231 p := q.right; h := true;
232 else
233 x_del (q.left, h);
234 if h then b_left (p, h); end if;
235 end if;
236 data := q.data;
237 ok := true;
238 free (q);
239 else -- not "<"
240 recur_del (p.right, h);
241 if h then b_right (p, h); end if;
242 end if;
243 end recur_del;
244 begin
245 ok := false;
246 recur_del (tree, hei);
247 end delete;
248
249 --------------------------------------------------------------------
250
251 procedure get_first (tree : in tree_type;
252 item : out item_type;
253 data : out data_type;
254 ok : out boolean) is
255
256 x: tree_type := tree;
257 begin
258 ok := false;
259 if x = null then return; end if;
260
261 loop
262 exit when x.left = null;
263 x := x.left;
264 end loop;
265 item := x.item;
266 data := x.data;
267 ok := true;
268 end;
269
270 --------------------------------------------------------------------
271
272 procedure get_last (tree : in tree_type;
273 item : out item_type;
274 data : out data_type;
275 ok : out boolean) is
276
277 x: tree_type := tree;
278 begin
279 ok := false;
280 if x = null then return; end if;
281
282 loop
283 exit when x.right = null;
284 x := x.right;
285 end loop;
286 item := x.item;
287 data := x.data;
288 ok := true;
289 end;
290
291 --------------------------------------------------------------------
292
293 procedure modify (tree : in out tree_type;
294 item : item_type;
295 data : data_type;
296 ok : out boolean) is
297
298 x: tree_type := tree;
299 begin
300 ok := false;
301 loop
302 exit when x = null;
303 exit when x.item = item;
304 if item < x.item then
305 x := x.left;
306 else x := x.right;
307 end if;
308 end loop;
309 if x /= null then
310 x.data := data;
311 ok := true;
312 end if;
313 end;
314
315 --------------------------------------------------------------------
316
317 procedure get_ge (tree : tree_type;
318 item : in out item_type;
319 data : out data_type;
320 ok : out boolean) is
321
322 x: tree_type := tree;
323 g: tree_type := null;
324 begin
325 ok := false;
326 loop
327 exit when x = null;
328 exit when x.item = item;
329 if item < x.item then
330 g := x;
331 x := x.left;
332 else x := x.right;
333 end if;
334 end loop;
335
336 if x = null then
337 x := g;
338 end if;
339
340 if x /= null then
341 item := x.item;
342 data := x.data;
343 ok := true;
344 end if;
345 end;
346
347 --------------------------------------------------------------------
348
349 procedure get_gt (tree : tree_type;
350 item : in out item_type;
351 data : out data_type;
352 ok : out boolean) is
353
354 x: tree_type := tree;
355 g: tree_type;
356 begin
357 ok := false;
358 loop
359 exit when x = null;
360 if item < x.item then
361 g := x;
362 x := x.left;
363 else
364 x := x.right;
365 end if;
366 end loop;
367 if g /= null then
368 item := g.item;
369 data := g.data;
370 ok := true;
371 end if;
372 end;
373
374 --------------------------------------------------------------------
375
376 procedure get_le (tree : tree_type;
377 item : in out item_type;
378 data : out data_type;
379 ok : out boolean) is
380
381 x: tree_type := tree;
382 l: tree_type := null;
383 begin
384 ok := false;
385 loop
386 exit when x = null;
387 exit when x.item = item;
388 if x.item < item then
389 l := x;
390 x := x.right;
391 else x := x.left;
392 end if;
393 end loop;
394
395 if x = null then
396 x := l;
397 end if;
398
399 if x /= null then
400 item := x.item;
401 data := x.data;
402 ok := true;
403 end if;
404 end;
405
406 --------------------------------------------------------------------
407
408 procedure get_lt (tree : tree_type;
409 item : in out item_type;
410 data : out data_type;
411 ok : out boolean) is
412
413 x: tree_type := tree;
414 l: tree_type;
415 begin
416 ok := false;
417 loop
418 exit when x = null;
419 if x.item < item then
420 l := x;
421 x := x.right;
422 else x := x.left;
423 end if;
424 end loop;
425 if l /= null then
426 item := l.item;
427 data := l.data;
428 ok := true;
429 end if;
430 end;
431
432 end;
433