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