1 % (c) 2009-2025 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2 % Heinrich Heine Universitaet Duesseldorf
3 % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5 :- module(avl_tools,[avl_height_less_than/2,
6 avl_height_compare/3,
7 avl_height_compare_up_to/5,
8 quick_avl_approximate_size/2, avl_approximate_size_from_height/2,
9 avl_min_pair/3, avl_max_pair/3,
10 avl_fetch_pair/3,
11 avl_delete_pair/4,
12 avl_fetch_with_index/3, decompose_index/3,
13 avl_fetch_with_flexible_index/4, flexible_decompose_index/4,
14 avl_fetch_bin/4,
15 avl_apply/5,
16 avl_image_interval/4,
17 ord_domain_list_to_avl/2,
18 check_is_non_empty_avl/1]).
19
20 :- use_module(module_information,[module_info/2]).
21 :- module_info(group,kernel).
22 :- module_info(description,'This module provides AVL-tree utilities used by the kernel.').
23
24 :- use_module(library(avl)).
25
26 :- use_module(error_manager).
27 :- use_module(self_check).
28 :- use_module(kernel_waitflags,[add_wd_error_span/4]).
29
30 % -------------------------------
31
32 test_avl_set(node(((int(2),int(3)),int(6)),true,0,
33 node(((int(1),int(2)),int(2)),true,0,empty,empty),
34 node(((int(3),int(4)),int(12)),true,0,empty,empty))).
35
36 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_height_less_than(A,3) )).
37 :- assert_must_succeed(( avl_tools:avl_height_less_than(empty,1) )).
38 :- assert_must_fail(( avl_tools:test_avl_set(A), avl_tools:avl_height_less_than(A,2) )).
39 :- assert_must_fail(( avl_tools:avl_height_less_than(empty,0) )).
40
41 % a custom version of avl_height; advantage it will stop when reaching MaxHeight
42
43 avl_height_less_than(empty, MaxHeight) :- MaxHeight>0.
44 avl_height_less_than(node(_,_,B,L,R), H0) :- H0>1,
45 H1 is H0-1,
46 ( B >= 0 -> avl_height_less_than(R, H1)
47 ; avl_height_less_than(L, H1)
48 ).
49
50
51 % efficient way of comparing AVL heights without having to fully traverse larger AVL
52
53 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_height_compare(A,A,eq) )).
54 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_height_compare(empty,A,lt) )).
55 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_height_compare(A,empty,gt) )).
56
57 ?avl_height_compare(A,B,Res) :- avl_height_compare_up_to(A,B,0,0,_,Res).
58
59 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_height_compare_up_to(empty,A,2,0,lt) )).
60 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_height_compare_up_to(empty,A,3,0,eq) )).
61
62 % avl_height_compare_up_to(Avl1,Avl2,MaxDiff,ResSz,ResCmp) -> ResSz: Height of smaller AVL, ResCmp = eq,lt,gt
63 avl_height_compare_up_to(Avl1,Avl2,MaxDiff,ResSz,ResCmp) :-
64 avl_height_compare_up_to(Avl1,Avl2,MaxDiff,0,ResSz,ResCmp).
65
66 avl_height_compare_up_to(empty,empty,_,Sz,Sz,eq).
67 avl_height_compare_up_to(empty,node(_,_,B,L,R),MaxDiff,Sz,Sz,Res) :-
68 (avl_height_less_than(node(_,_,B,L,R),MaxDiff) -> Res=eq ; Res=lt).
69 avl_height_compare_up_to(node(_,_,B,L,R),empty,MaxDiff,Sz,Sz,Res) :-
70 (avl_height_less_than(node(_,_,B,L,R),MaxDiff) -> Res=eq ; Res=gt).
71 avl_height_compare_up_to(node(_,_,B1,L1,R1),node(_,_,B2,L2,R2),MaxDiff,AccSz,ResSz,Res) :-
72 ( B1 >= 0 -> A1=R1 ; A1=L1),
73 ( B2 >= 0 -> A2=R2 ; A2=L2),
74 Acc1 is AccSz+1,
75 ? avl_height_compare_up_to(A1,A2,MaxDiff,Acc1,ResSz,Res).
76
77 % -------------------------------
78
79 % compute an upper bound for the size of an AVL based on Height (log runtime):
80 quick_avl_approximate_size(AVL,Size) :- avl_height(AVL,Height), Size is floor(2**Height)-1.
81 % a lower bound could be computed by =POWER(2,(HEIGHT+0.3277)/1.4405)-2 (page 460, Knuth 3)
82 avl_approximate_size_from_height(Height,Size) :- Size is floor(2**Height)-1.
83
84
85 % -------------------------------
86
87
88 avl_min_pair(AVLFun,FFrom,FTo) :-
89 (avl_min(AVLFun,(FFrom,FTo)) -> true
90 ; add_error_fail(avl_min_pair,'Could not extract minimum pair of AVL set',AVLFun)).
91 avl_max_pair(AVLFun,FFrom,FTo) :-
92 (avl_max(AVLFun,(FFrom,FTo)) -> true
93 ; add_error_fail(avl_max_pair,'Could not extract maximum pair of AVL set',AVLFun)).
94
95 % -------------------------------
96
97
98 % a version of avl_fetch that looks for a pair in the AVL tree whose
99 % first component is Key; it assumes that the term ordering gives the
100 % first argument higher priority than the second one.
101
102 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_pair((int(2),int(3)),A,R), R==int(6) )).
103 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_pair((int(1),int(2)),A,R), R==int(2) )).
104 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_pair((int(3),int(4)),A,R), R==int(12) )).
105 :- assert_must_fail(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_pair((int(1),int(4)),A,_) )).
106
107 avl_fetch_pair(Key, node((K,KY),_,_,L,R),Res) :-
108 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
109 ? avl_fetch_pair_1(O, Key, L, R, KY, Res).
110
111 % order of clauses relevant so that safe_avl_member returns elements in order !
112 avl_fetch_pair_1(<, Key, node((K,KY),_,_,L,R), _, _, Res) :-
113 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
114 ? avl_fetch_pair_1(O, Key, L, R, KY, Res).
115 avl_fetch_pair_1(=, _Key, _L, _R, KY, KY).
116 avl_fetch_pair_1(>, Key, _, node((K,KY),_,_,L,R),_,Res) :-
117 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
118 ? avl_fetch_pair_1(O, Key, L, R, KY, Res).
119
120 my_compare(O,K1,K2) :- compare(OK,K1,K2),
121 (OK=('=') -> true /* leave O free variable */
122 % TO DO: think about comparing KY and Res above
123 ; O=OK).
124
125 % -------------------------------
126
127 % now a more generic version; which also works with records and later maybe freetypes, ...
128 % TODO: check if performance difference with avl_fetch_pair can be noticed
129
130 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_with_index((int(2),int(3)),A,R), R==int(6) )).
131 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_with_index((int(1),int(2)),A,R), R==int(2) )).
132 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_with_index((int(3),int(4)),A,R), R==int(12) )).
133 :- assert_must_fail(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_with_index((int(1),int(4)),A,_) )).
134
135 avl_fetch_with_index(Key, node(Value,_,_,L,R),Res) :- decompose_index(Value,K,KY),
136 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
137 ? avl_fetch_idx_1(O, Key, L, R, KY, Res).
138
139 % decompose a value into the index and the rest
140 decompose_index((K,KY),K,KY).
141 decompose_index(rec([field(F,FH)|T]),field(F,FH),rec(T)) :- T\==[]. % we could just use FH as key; assuming typechecker would catch if names mismatch
142 % TODO: freeval(ID,Case,Val1),
143 % TODO: nested pairs?
144 % avl_set(node(TopVal,_,_,L,R)) --> no use in decomposing: avl_set is fully known already
145
146 % order of clauses relevant so that safe_avl_member returns elements in order !
147 avl_fetch_idx_1(<, Key, node(Value,_,_,L,R), _, _, Res) :-
148 decompose_index(Value,K,KY),
149 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
150 ? avl_fetch_idx_1(O, Key, L, R, KY, Res).
151 avl_fetch_idx_1(=, _Key, _L, _R, KY, KY).
152 avl_fetch_idx_1(>, Key, _, node(Value,_,_,L,R),_,Res) :-
153 decompose_index(Value,K,KY),
154 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
155 ? avl_fetch_idx_1(O, Key, L, R, KY, Res).
156
157 % -------------------------------
158
159 % and even more generic version; which also works with flexible indexes computed depending on what is instantiated
160
161 :- assert_must_succeed(( avl_tools:test_avl_set(A), Path=prj1_idx(full_value_idx),
162 avl_tools:avl_fetch_with_flexible_index((int(2),int(3)),Path, A,R), R==(pred_true,int(6)) )).
163 :- assert_must_succeed(( avl_tools:test_avl_set(A), Path=prj1_idx(prj1_idx(full_value_idx)),
164 avl_tools:avl_fetch_with_flexible_index(int(2),Path, A,R), R==((pred_true,int(3)),int(6)) )).
165 :- assert_must_succeed(( avl_tools:test_avl_set(A),
166 avl_tools:flexible_decompose_index(((int(2),int(3)),X),Key,Rest1,Path),
167 Path == prj1_idx(full_value_idx),
168 avl_tools:avl_fetch_with_flexible_index(Key, Path, A,Rest2), Rest1=Rest2, X==int(6) )).
169 :- assert_must_succeed(( avl_tools:test_avl_set(A),
170 avl_tools:flexible_decompose_index(((int(2),Y),int(6)),Key,Rest1,Path),
171 Path == prj1_idx(prj1_idx(full_value_idx)),
172 avl_tools:avl_fetch_with_flexible_index(Key, Path, A,Rest2), Rest1=Rest2, Y==int(3) )).
173 :- assert_must_succeed(( avl_tools:test_avl_set(A),
174 avl_tools:flexible_decompose_index(((int(2),int(3)),int(6)),Key,Rest1,Path),
175 Path == full_value_idx,
176 avl_tools:avl_fetch_with_flexible_index(Key, Path, A,Rest2), Rest1=Rest2 )).
177 :- assert_must_fail(( avl_tools:test_avl_set(A),
178 avl_tools:flexible_decompose_index(((int(2),_Y),int(3)),Key,Rest1,Path),
179 avl_tools:avl_fetch_with_flexible_index(Key, Path, A,Rest2), Rest1=Rest2 )).
180
181
182 % a version where the index is flexibly computed depending on the value to lookup (by flexible_decompose_index)
183 % it can look deeper into couples if necessary to find a leading part of the value that is ground and can be used for efficient lookup in the AVL tree
184
185
186 :- use_module(kernel_tools,[ground_value/1]).
187
188 % try and find a valid ground index, returning a path
189 % note an index must always be the leading elements of pairs/records to be consistent with Prolog's term order
190 % (i.e. we cannot use a middle field as index or the just the right part of a pair)
191 flexible_decompose_index(Var,_,_,_) :- var(Var),!,fail.
192 flexible_decompose_index((Key1,Rest1),Key,Rest,Path) :- !,
193 flexible_decompose_index(Key1,Key2,Rest2,Path2),
194 (Path2 = full_value_idx, % Rest2 == pred_true
195 flexible_decompose_index(Rest1,Key3,Rest3,Path3) % try to use part of Rest1 also as index
196 -> Key = (Key2,Key3), Rest = Rest3, (Path3=full_value_idx -> Path=Path3 ; Path=prj2_idx(Path3))
197 ; Key = Key2, Rest = (Rest2,Rest1), Path = prj1_idx(Path2)
198 ).
199 flexible_decompose_index(rec([field(F,Key1)|T]),Key,Rest,Path) :-
200 T\==[], !,
201 flexible_decompose_index(Key1,Key2,Rest2,Path2),
202 (Path2 = full_value_idx, % Rest2 == pred_true
203 ground_value(rec(T)), custom_explicit_sets:convert_to_avl_inside_set(rec([field(F,Key2)|T]),NormKey)
204 -> Key = NormKey, Path=full_value_idx % we can use full value as index
205 % TODO: use maximal number of leading fields for lookup
206 ; Key = Key2, Rest = (Rest2,rec(T)), Path = rec_field1_idx(F,Path2)
207 ).
208 flexible_decompose_index(Val,NormVal,pred_true,full_value_idx) :-
209 ground_value(Val), custom_explicit_sets:convert_to_avl_inside_set(Val,NormVal).
210
211 % a version where the path is already known and which is used to decompose a ground normalised value coming from the AVL set
212 % decompose_ground_index(Path, Value, Key, RestToUnifyAfter)
213 decompose_ground_index(full_value_idx,Key,Key,pred_true).
214 decompose_ground_index(prj1_idx(Path1),(Key1,Rest1),Key,(Rest2,Rest1)) :-
215 decompose_ground_index(Path1,Key1,Key,Rest2).
216 decompose_ground_index(prj2_idx(Path2),(Key1,Key2),(Key1,Key),Rest2) :-
217 decompose_ground_index(Path2,Key2,Key,Rest2).
218 decompose_ground_index(rec_field1_idx(FieldName,Path2),rec([field(FieldName,Key1)|T]),Key,(Rest2,rec(T))) :-
219 decompose_ground_index(Path2,Key1,Key,Rest2).
220
221
222 avl_fetch_with_flexible_index(Key, full_value_idx, AVL ,Res) :- !, Res=pred_true,
223 avl_fetch(Key,AVL).
224 avl_fetch_with_flexible_index(Key, Path, node(Value,_,_,L,R),Res) :-
225 decompose_ground_index(Path,Value,K,KY), % use same decomposition as used for original lookup
226 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
227 ? avl_fetch_flex_idx_1(O, Key, Path, L, R, KY, Res).
228
229 % order of clauses relevant so that safe_avl_member returns elements in order !
230 avl_fetch_flex_idx_1(<, Key, Path, node(Value,_,_,L,R), _, _, Res) :-
231 decompose_ground_index(Path,Value,K,KY),
232 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
233 avl_fetch_flex_idx_1(O, Key, Path, L, R, KY, Res).
234 avl_fetch_flex_idx_1(=, _Key, _Path, _L, _R, KY, KY).
235 avl_fetch_flex_idx_1(>, Key, Path, _, node(Value,_,_,L,R),_,Res) :-
236 decompose_ground_index(Path,Value,K,KY),
237 my_compare(O, Key, K), %((O='=',nonvar(Res)) -> print(comp(Res,KY)),nl ; true), % see TODO below
238 avl_fetch_flex_idx_1(O, Key, Path, L, R, KY, Res).
239
240 % -------------------------------
241
242 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_bin((int(2),int(3)),',',A,R), R==int(6) )).
243 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_bin((int(1),int(2)),',',A,R), R==int(2) )).
244 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_bin((int(3),int(4)),',',A,R), R==int(12) )).
245 :- assert_must_fail(( avl_tools:test_avl_set(A), avl_tools:avl_fetch_bin((int(1),int(4)),',',A,_) )).
246
247 % fetch binary constructs with first argument known, e.g. member(Key,Res) or equal(Key,Res) or ...construct
248 avl_fetch_bin(Key, BinFunctor, AVL, Res) :- (AVL=empty ; AVL=node(_,_,_,_,_)),!,
249 ? avl_fetch_bin0(Key, BinFunctor, AVL, Res).
250 avl_fetch_bin(Key, BinFunctor, AVL, Res) :-
251 add_internal_error('Illegal AVL tree: ',avl_fetch_bin(Key, BinFunctor, AVL, Res)),fail.
252
253 avl_fetch_bin0(Key, BinFunctor, node(Expr,_,_,L,R),Res) :-
254 my_compare_bin(Expr,BinFunctor, O, Key, KY),
255 ? avl_fetch_bin_1(O, Key, BinFunctor, L, R, KY, Res).
256
257 % order of clauses relevant so that safe_avl_member returns elements in order !
258 avl_fetch_bin_1(<, Key, BinFunctor, node(Expr,_,_,L,R), _, _, Res) :-
259 my_compare_bin(Expr,BinFunctor, O, Key, KY),
260 ? avl_fetch_bin_1(O, Key,BinFunctor, L, R, KY, Res).
261 avl_fetch_bin_1(=, _Key, _, _L, _R, KY, KY).
262 avl_fetch_bin_1(>, Key, BinFunctor, _, node(Expr,_,_,L,R),_,Res) :-
263 my_compare_bin(Expr,BinFunctor, O, Key, KY),
264 ? avl_fetch_bin_1(O, Key,BinFunctor, L, R, KY, Res).
265
266 my_compare_bin(Expr,BinFunctor, O,Key,KY) :- functor(Expr,BinFunctor,2),!,
267 arg(1,Expr,K), arg(2,Expr,KY),
268 my_compare(O,Key,K).
269 my_compare_bin(Other,BinFunctor, O,_Key,'$none') :-
270 functor(Search,BinFunctor,2), % TODO: pass term with Key?
271 compare(O,Search,Other).
272
273
274
275 % -------------------------------
276
277
278 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_delete_pair((int(3),int(4)),A,true,AA), avl_size(AA,2) )).
279 :- assert_must_fail(( avl_tools:test_avl_set(A), avl_tools:avl_delete_pair((int(1),int(3)),A,true,_) )).
280 :- assert_must_succeed(( avl_tools:test_avl_set(A), avl_tools:avl_delete_pair((int(1),int(2)),A,true,AA),
281 avl_tools:avl_delete_pair((int(2),int(3)),AA,true,AAA), avl_size(AAA,1) )).
282
283 % an adaptation of avl_delete which deletes a pair just knowing the first argument of the pair
284 % like avl_fetch_pair it assumes term ordering gives precedence to first argument
285
286 avl_delete_pair(Key, AVL0, Val, AVL) :-
287 avl_delete_pair5(AVL0, Key, Val, AVL, _).
288
289 avl_delete_pair5(node(K,V,B,L,R), Key, Val, AVL, Delta) :-
290 K = (KX,_KY), % crucial difference
291 compare(C, Key, KX),
292 avl_delete_pair(C, Key, Val, AVL, Delta, K, V, B, L, R).
293
294 % If library(avl) has been replaced with avl_custom,
295 % also adjust the module prefixes here.
296 :- if(predicate_property(empty_avl(_), imported_from(avl_custom))).
297
298 avl_delete_pair(<, Key, Val, AVL, Delta, K, V, B, L, R) :-
299 avl_delete_pair5(L, Key, Val, L1, D1),
300 B1 is B+D1,
301 avl_custom:avl(B1, K, V, L1, R, AVL),
302 avl_custom:avl_shrinkage(AVL, D1, Delta).
303 avl_delete_pair(=, _, Val, AVL, Delta, _, Val, B, L, R) :-
304 ( L == empty -> AVL = R, Delta = 1
305 ; R == empty -> AVL = L, Delta = 1
306 ; avl_custom:avl_del_max(L, K, V, L1, D1),
307 B1 is B+D1,
308 avl_custom:avl(B1, K, V, L1, R, AVL),
309 avl_custom:avl_shrinkage(AVL, D1, Delta)
310 ).
311 avl_delete_pair(>, Key, Val, AVL, Delta, K, V, B, L, R) :-
312 avl_delete_pair5(R, Key, Val, R1, D1),
313 B1 is B-D1,
314 avl_custom:avl(B1, K, V, L, R1, AVL),
315 avl_custom:avl_shrinkage(AVL, D1, Delta).
316
317 :- else.
318
319 avl_delete_pair(<, Key, Val, AVL, Delta, K, V, B, L, R) :-
320 avl_delete_pair5(L, Key, Val, L1, D1),
321 B1 is B+D1,
322 avl:avl(B1, K, V, L1, R, AVL),
323 avl:avl_shrinkage(AVL, D1, Delta).
324 avl_delete_pair(=, _, Val, AVL, Delta, _, Val, B, L, R) :-
325 ( L == empty -> AVL = R, Delta = 1
326 ; R == empty -> AVL = L, Delta = 1
327 ; avl:avl_del_max(L, K, V, L1, D1),
328 B1 is B+D1,
329 avl:avl(B1, K, V, L1, R, AVL),
330 avl:avl_shrinkage(AVL, D1, Delta)
331 ).
332 avl_delete_pair(>, Key, Val, AVL, Delta, K, V, B, L, R) :-
333 avl_delete_pair5(R, Key, Val, R1, D1),
334 B1 is B-D1,
335 avl:avl(B1, K, V, L, R1, AVL),
336 avl:avl_shrinkage(AVL, D1, Delta).
337
338 :- endif.
339
340
341 % -------------------------------
342
343
344 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
345 % avl_apply
346 % similar to avl_fetch_pair: but checks whether we have a function
347 % and whether the function is defined for the key
348 :- if(environ(no_wd_checking,true)).
349 /* faster version without WD-checking : */
350 :- nl,print('DISABLING WD-CHECKING FOR FUNCTION APPLICATION!'),nl,nl.
351 avl_apply(Key, node((K,KY),_,_,L,R),Res,_Span,_WF) :-
352 compare(O, Key, K),
353 avl_apply_1(O, Key, L, R, KY, Res).
354 avl_apply_1(<, Key, node((K,KY),_,_,L,R), _, _, Res) :-
355 compare(O, Key, K),
356 avl_apply_1(O, Key, L, R, KY, Res).
357 avl_apply_1(=, _Key, _Left,_Right, KY, KY).
358 avl_apply_1(>, Key, _, node((K,KY),_,_,L,R),_,Res) :-
359 compare(O, Key, K),
360 avl_apply_1(O, Key, L, R, KY, Res).
361 :- else.
362 /* normal version with WD -checking : */
363 avl_apply(Key, node((K,KY),_,_,L,R),Res,Span,WF) :-
364 compare(O, Key, K),
365 avl_apply_1(O, Key, L, R, KY, Res,Span,WF).
366
367 avl_apply_1(<, Key, NODE, _, _, Res,Span,WF) :-
368 (NODE=node((K,KY),_,_,L,R)
369 -> compare(O, Key, K),
370 avl_apply_1(O, Key, L, R, KY, Res,Span,WF)
371 ; add_wd_error_span('function applied outside of domain (#6): ','@fun'(Key,[]),Span,WF)
372 ).
373 avl_apply_1(>, Key, _, NODE,_,Res,Span,WF) :-
374 (NODE=node((K,KY),_,_,L,R)
375 -> compare(O, Key, K),
376 avl_apply_1(O, Key, L, R, KY, Res,Span,WF)
377 ; add_wd_error_span('function applied outside of domain (#7): ','@fun'(Key,[]),Span,WF)
378 ).
379 %%avl_apply_1(=, Key, _Left,_Right, KY, KY, _Span,_WF).
380 avl_apply_1(=, Key, Left,Right, KY, Res,Span,WF) :-
381 ((Left = node((Key,KY2),_,_,_,_) ;
382 Right = node((Key,KY2),_,_,_,_)) % this is only a partial quick test; the next & previous elements could be deeper in the tree
383 % TO DO: use optimized version of avl_fetch((Key,KY2),Left) ; avl_fetch((Key,KY2),Right) if \+ preferences:preference(find_abort_values,false),
384 -> add_wd_error_span('function application used for relation: ','@rel'(Key,KY,KY2),Span,WF)
385 % we do not instantiate Res in this case
386 ; Res=KY).
387
388 :- endif.
389
390 % -------------------------------
391
392
393 % similar to avl_apply but uses interval as lookup key
394 avl_image_interval(From,To, node((K,KY),_,_,L,R),Res) :-
395 ? comp_interval(O, From,To, K),
396 ? avl_image_interval_1(O, From,To, L, R, KY, Res).
397 avl_image_interval_1(<, From,To, NODE, _, _, Res) :-
398 ? NODE=node((K,KY),_,_,L,R),comp_interval(O, From,To, K),
399 ? avl_image_interval_1(O, From,To, L, R, KY, Res).
400 avl_image_interval_1(=, _From,_To, _Left,_Right, KY, Res) :- Res=KY.
401 avl_image_interval_1(>, From,To, _, NODE,_,Res) :-
402 NODE=node((K,KY),_,_,L,R),
403 ? comp_interval(O, From,To, K),
404 ? avl_image_interval_1(O, From,To, L, R, KY, Res).
405
406 comp_interval(O,From,To,int(Key)) :-
407 ( number(From),Key<From -> O = ('>') % could be minus_inf
408 ; number(To), Key>To -> O = ('<')
409 ; O = ('<') ; O = ('=') ; O = ('>')
410 ).
411 % -------------------------------
412
413 % like ord_list_to_avl but does not require list of Dom-Range pairs, adds true automatically
414 :- assert_must_succeed(( avl_tools:ord_domain_list_to_avl([1,2,3],A), avl_fetch(2,A))).
415
416 add_true_to_list([],[]).
417 add_true_to_list([H|T],[H-true|TT]) :- add_true_to_list(T,TT).
418
419 ord_domain_list_to_avl(List,Res) :-
420 add_true_to_list(List,LT),
421 ord_list_to_avl(LT,Res).
422
423 % -------------------------------
424
425 check_is_non_empty_avl(V) :- var(V),!, add_internal_error('Variable AVL tree:',check_is_non_empty_avl(V)).
426 check_is_non_empty_avl(empty) :- !, add_internal_error('Empty AVL tree:',check_is_non_empty_avl(empty)).
427 check_is_non_empty_avl(node(_,_,_,_,_)) :- !.
428 check_is_non_empty_avl(V) :- add_internal_error('Illegal AVL tree:',check_is_non_empty_avl(V)).
429
430