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
6 :- module(custom_explicit_sets,[is_set_value/2,
7 is_custom_explicit_set/1, is_custom_explicit_set/2, is_custom_explicit_set_nonvar/1,
8 %equal_explicit_sets/2,
9 equal_explicit_sets_wf/3,
10 not_equal_explicit_sets_wf/3,
11 equality_explicit_sets_wf/4, same_texpr_body/2, same_closure/2,
12 is_empty_explicit_set/1, is_empty_explicit_set_wf/2, is_empty_closure_wf/4,
13 is_non_empty_explicit_set/1, is_non_empty_explicit_set_wf/2,
14 is_non_empty_closure_wf/4,
15 test_empty_explicit_set_wf/3, test_empty_closure_wf/5,
16 is_definitely_maximal_set/1,
17 explicit_set_cardinality/2, explicit_set_cardinality_wf/3,
18 explicit_set_cardinality_for_wf/2,
19 card_for_specific_custom_set/3, % only succeeds if we can compute it efficiently
20 card_for_specific_closure/4,
21 efficient_card_for_set/3, % same, but also for lists
22 quick_custom_explicit_set_approximate_size/2,
23 avl_approximate_size/2, avl_approximate_size/3,
24 is_infinite_explicit_set/1, is_infinite_closure/3,
25 is_infinite_global_set/2, is_simple_infinite_set/1,
26 is_infinite_or_symbolic_set/1,
27 dont_expand_this_explicit_set/1, dont_expand_this_explicit_set/2,
28 dont_expand_symbolic_explicit_set/1,
29 definitely_expand_this_explicit_set/1,
30 is_infinite_or_very_large_explicit_set/1,
31 is_infinite_or_very_large_explicit_set/2,
32 is_cartesian_product_closure/3,
33 expand_custom_set/2, expand_custom_set_wf/4,
34 try_expand_custom_set/2, try_expand_custom_set_with_catch/3,
35 try_expand_custom_set_wf/4,
36 expand_custom_set_to_list/2, expand_custom_set_to_list/4,
37 expand_custom_set_to_list_wf/5,
38 try_expand_custom_set_to_list_wf/5,
39 expand_custom_set_to_list_no_dups_wf/5,
40 expand_custom_set_to_list_gg/4,
41 try_expand_custom_set_to_list/4,
42 expand_interval_closure_to_avl/3,
43 expand_custom_set_to_list_now/2,
44 expand_closure_to_avl_or_list/6,
45 expand_closure_to_list/7,
46 expand_only_custom_closure_global/4, %try_expand_only_custom_closure_global/2,
47 expand_and_convert_to_avl_set/4,
48 ord_list_to_avlset_direct/3, sorted_ground_normalised_list_to_avlset/3,
49 try_expand_and_convert_to_avl/2, convert_to_avl/2,
50 should_be_converted_to_avl_from_lists/1, should_be_converted_to_avl/1,
51 try_expand_and_convert_to_avl_with_check/3,
52 try_expand_and_convert_to_avl_with_check/4,
53 try_expand_and_convert_to_avl_unless_large_wf/3,
54 %try_expand_and_convert_to_avl_unless_large_wf/3,
55 try_expand_and_convert_to_avl_if_smaller_than/3,
56 is_small_specific_custom_set/2,
57 quick_propagation_element_information/4,
58 element_of_custom_set/2, element_of_custom_set_wf/3,
59 element_of_closure/5,
60 check_element_of_function_closure/6,
61 not_element_of_custom_set_wf/3,
62 membership_custom_set/3, membership_custom_set_wf/4, membership_avl_set_wf/4,
63 quick_test_avl_membership/3,
64 lazy_check_elements_of_closure/6,
65
66 is_efficient_custom_set/1,
67 remove_minimum_element_custom_set/3,
68
69 is_maximal_global_set/1, quick_is_definitely_maximal_set/1,
70 quick_definitely_maximal_set_avl/1,
71 is_one_element_custom_set/2, singleton_set/2, construct_singleton_avl_set/2,
72 is_one_element_avl/2,
73 construct_one_element_custom_set/2,
74 avl_is_interval/3,
75
76 %closure0_for_explicit_set/2,
77 closure1_for_explicit_set/2, closure1_for_explicit_set_from/3,
78 check_in_domain_of_avlset_wf/3, check_unique_in_domain_of_avlset/2,
79 domain_of_explicit_set_wf/3, range_of_explicit_set_wf/3,
80 is_avl_partial_function/1, is_not_avl_partial_function/2,
81 is_avl_total_function_over_domain/2,
82 quick_definitely_maximal_total_function_avl/1,
83 is_avl_relation/1,
84 is_avl_relation_over_domain/3,
85 is_avl_relation_over_range/3,
86 is_not_avl_relation_over_domain_range/4, is_not_avl_relation_over_range/3,
87 is_avl_sequence/1, safe_is_avl_sequence/1,
88 get_avl_sequence/2,
89 is_injective_avl_relation/2,
90 invert_explicit_set/2, union_of_explicit_set/3,
91 union_generalized_explicit_set/3,
92 difference_of_explicit_set_wf/4,
93 intersection_of_explicit_set_wf/4, intersection_with_interval_closure/3,
94 disjoint_intervals_with_inf/4,
95 image_for_id_closure/3, image_for_explicit_set/4,
96 rel_composition_for_explicit_set/3,
97 element_can_be_added_or_removed_to_avl/1,
98 add_element_to_explicit_set_wf/4, remove_element_from_explicit_set/3,
99 delete_element_from_explicit_set/3,
100 at_most_one_match_possible/3,
101 apply_to_avl_set/5, try_apply_to_avl_set_wf/4,
102 min_of_explicit_set_wf/3, max_of_explicit_set_wf/3,
103 sum_or_mul_of_explicit_set/3,
104 %sum_of_range_custom_explicit_set/2, mul_of_range_custom_explicit_set/2,
105 domain_restriction_explicit_set_wf/4,
106 range_restriction_explicit_set_wf/4,
107 domain_subtraction_explicit_set_wf/4,
108 range_subtraction_explicit_set_wf/4,
109 override_pair_explicit_set/4,
110 direct_product_explicit_set/3,
111 override_custom_explicit_set_wf/4,
112 symbolic_functionality_check_closure/2, symbolic_injectivity_check_closure/2,
113
114 subset_of_explicit_set/4, not_subset_of_explicit_set/4,
115 test_subset_of_explicit_set/5,
116
117 conc_custom_explicit_set/2,
118 prefix_of_custom_explicit_set/4, suffix_of_custom_explicit_set/4,
119 concat_custom_explicit_set/4, prepend_custom_explicit_set/3,
120 append_custom_explicit_set/4,
121 tail_sequence_custom_explicit_set/5,
122 last_sequence_explicit_set/2, %first_sequence_explicit_set/2,
123 front_sequence_custom_explicit_set/3,
124 reverse_custom_explicit_set/2,
125 size_of_custom_explicit_set/3,
126
127 get_first_avl_elements/4,
128 construct_avl_from_lists/2, construct_avl_from_lists_wf/3,
129 equal_avl_tree/2,
130 check_avl_in_interval/3, check_interval_in_custom_set/4,
131 check_avl_subset/2,
132 construct_closure/4, is_closure/4, % from closures
133 construct_member_closure/5, % from closures
134
135 construct_interval_closure/3,
136 is_interval_closure/3, % checks if we have a finite interval closure Low..Up (but bounds can be variables)
137 is_interval_closure/5,
138 is_interval_closure_or_integerset/3, is_interval_closure_or_integerset/4,
139 is_interval_with_integer_bounds/3, % checks that bounds are known
140 intersect_intervals_with_inf/6,
141
142 is_powerset_closure/3,
143
144 dom_range_for_specific_closure/5,
145 dom_for_specific_closure/4,
146 dom_for_lambda_closure/2,
147 portray_custom_explicit_set/1,
148 closure_occurs_check/4
149 ]).
150
151 :- meta_predicate call_card_for_relations(-,-,0).
152
153 :- use_module(module_information,[module_info/2]).
154 :- module_info(group,kernel).
155 :- module_info(description,'This module provides customised operations for the custom explicit set representations of ProB (closures, avl_sets and global_sets).').
156
157 :- use_module(error_manager).
158 :- use_module(self_check).
159 :- use_module(preferences,[get_preference/2]).
160 :- use_module(library(avl)).
161 :- use_module(kernel_waitflags).
162 :- use_module(kernel_tools).
163 :- use_module(delay).
164 :- use_module(tools).
165 :- use_module(avl_tools).
166 :- use_module(library(clpfd)).
167 :- use_module(debug).
168 :- use_module(tools_printing,[print_term_summary/1, print_error/1]).
169 :- use_module(preferences,[preference/2]).
170 :- use_module(kernel_objects,[equal_object/2, equal_object/3]).
171 :- use_module(kernel_freetypes,[enumerate_freetype_wf/4,freetype_cardinality/2,
172 is_infinite_freetype/1, is_empty_freetype/1,
173 is_non_empty_freetype/1, test_empty_freetype/2]).
174 :- use_module(clpfd_interface,[try_post_constraint/1, clpfd_reify_inlist/4]).
175 :- use_module(closures).
176 :- use_module(performance_messages).
177 :- use_module(b_compiler).
178 :- use_module(btypechecker,[couplise_list/2, unify_types_strict/2, merge_types/3]).
179
180 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
181
182 /* These meta_predicate declarations do not seem to have the right effect;
183 the predicates below return code, they do not get passed code
184 :- meta_predicate card_for_specific_custom_set(*,*,0).
185 :- meta_predicate card_for_specific_closure(*,*,0).
186 :- meta_predicate is_a_relation(*,*,*,*,*,*,0).
187 :- meta_predicate subset_of_explicit_set(*,*,0,*).
188 :- meta_predicate not_subset_of_explicit_set(*,*,0,*).
189 */
190
191 construct_avl_from_lists(S,Res) :-
192 (convert_to_avl(S,CS) -> true ; print(convert_to_avl_failed(S,CS)),nl,CS=S),
193 Res = CS.
194
195 % version with WF to see call stack in case of virtual time-outs due to expansions
196 construct_avl_from_lists_wf(S,Res,WF) :-
197 (convert_to_avl_wf(S,CS,WF) -> true ; print(convert_to_avl_wf_failed(S,CS)),nl,CS=S),
198 Res = CS.
199
200 :- use_module(tools,[safe_sort/3]).
201 :- block normalised_list_to_avl_when_ground(-,?).
202 normalised_list_to_avl_when_ground(S,R) :- % call if you are not sure that S will be ground; e.g. after closure expansion
203 ground_value_check(S,GS),
204 blocking_normalised_list_to_avl(GS,S,R).
205 :- block blocking_normalised_list_to_avl(-,?,?).
206 blocking_normalised_list_to_avl(_,S,R) :- normalised_list_to_avl(S,R).
207
208 normalised_list_to_avl(S,R) :- safe_sort(normalised_list_to_avl,S,SS),
209 ord_list_to_avlset_direct(SS,AVL,normalised_list_to_avl),
210 equal_object(AVL,R). % due to co-routine, R can now be instantiated
211
212 %set_to_avl(List,R) :- empty_avl(A), add_to_avl(List,A,AR), R=avl_set(AR).
213 add_to_avl([],R,R).
214 add_to_avl([H|T],AVL,AVLOUT) :- avl_store(H,AVL,true,AVL1),
215 add_to_avl(T,AVL1,AVLOUT).
216
217
218 % get only the first x elements of an AVL tree
219 get_first_avl_elements(empty,_,R,all) :- !,R=[].
220 get_first_avl_elements(AVL,X,FirstXEls,CutOff) :-
221 avl_min(AVL,Min), get_first_els(X,Min,AVL,FirstXEls,CutOff).
222
223 get_first_els(X,_,_AVL,R,CutOff) :- X<1,!,R=[], CutOff=not_all.
224 get_first_els(X,Cur,AVL,[Cur|T],CutOff) :-
225 (avl_next(Cur,AVL,Nxt) -> X1 is X-1,get_first_els(X1,Nxt,AVL,T,CutOff)
226 ; T=[],CutOff=all).
227
228 %expand_and_try_convert_to_avl(C,R) :- is_closure(C,_,_,_), expand_custom_set(C,EC), expand_and_convert_to_avl
229 %expand_and_convert_to_avl(C,R) :- convert_to_avl(C,R).
230
231 /* convert all list data-values (with all-sub-values) into avl-form */
232 /* assumption: the value is ground when convert_to_avl is called */
233
234 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
235 :- if(environ(prob_safe_mode,true)).
236 convert_to_avl(X,R) :- \+ ground_value(X), !, add_error(convert_to_avl,'Non-ground argument: ',convert_to_avl(X,R)), R=X.
237 :- endif.
238 convert_to_avl(X,R) :- var(X), !, add_error(convert_to_avl,'Variable argument: ',convert_to_avl(X,R)), R=X.
239 ?convert_to_avl(Term,R) :- no_conversion_necessary(Term),!,
240 R=Term.
241 convert_to_avl(closure(P,T,B),R) :- !,
242 R=closure(P,T,B).
243 convert_to_avl(avl_set(A),R) :- !,(A==empty -> add_warning(convert_to_avl,'Emtpy avl_set'), R=[]
244 ; R=avl_set(A)).
245 convert_to_avl((A,B),(CA,CB)) :- !,convert_to_avl(A,CA), convert_to_avl(B,CB).
246 convert_to_avl(freetype(X),R) :- !, R=freetype(X).
247 convert_to_avl(freeval(ID,Case,Value),R) :- !, R=freeval(ID,Case,CValue),convert_to_avl(Value,CValue).
248 convert_to_avl(rec(Fields),R) :- !, convert_fields(Fields,CFields), R=rec(CFields).
249 convert_to_avl(global_set(GS),R) :- !, R=global_set(GS).
250 convert_to_avl([H|T],R) :- !, convert_cons_to_avl_inside_set_wf(H,T,R,no_wf_available).
251 %convert_to_avl(abort(X),_R) :- print(deprecetated_convert_to_avl(abort(X))),nl,!, fail.
252 convert_to_avl(X,R) :- add_internal_error('Unknown term: ',convert_to_avl(X,R)), R=X.
253
254 % pass WF for call stack in case of expansions TODO: complete
255 convert_to_avl_wf((A,B),(CA,CB),WF) :- !,convert_to_avl_wf(A,CA,WF), convert_to_avl_wf(B,CB,WF).
256 convert_to_avl_wf([H|T],R,WF) :- !, convert_cons_to_avl_inside_set_wf(H,T,R,WF).
257 convert_to_avl_wf(X,R,_) :- convert_to_avl(X,R).
258
259 convert_fields(Var,R) :- var(Var),!,
260 add_internal_error('Var arg: ',convert_fields(Var,R)),fail.
261 convert_fields([],[]).
262 convert_fields([field(FieldName,Value)|T],[field(FieldName,CValue)|CT]) :-
263 convert_to_avl_inside_set(Value,CValue),
264 convert_fields(T,CT).
265
266 l_convert_to_avl_wf(Var,_,WF) :- var(Var),!,
267 add_warning_wf(l_convert_to_avl_wf,'Cannot expand variable to avl: ',Var,unknown,WF),
268 fail.
269 l_convert_to_avl_wf([],[],_).
270 l_convert_to_avl_wf(avl_set(A),R,WF) :-
271 expand_custom_set_wf(avl_set(A),ES,l_convert_to_avl,WF),
272 l_convert_to_avl_wf(ES,R,WF).
273 l_convert_to_avl_wf(closure(P,T,B),R,WF) :-
274 expand_custom_set_wf(closure(P,T,B),ES,l_convert_to_avl,WF),
275 l_convert_to_avl_wf(ES,R,WF).
276 l_convert_to_avl_wf([H|T],[CH-true|CT],WF) :-
277 convert_to_avl_inside_set_wf(H,CH,WF), l_convert_to_avl_wf(T,CT,WF).
278
279 :- assert_must_succeed((X=(fd(1,'Name'),fd(2,'Name')),
280 custom_explicit_sets:convert_to_avl_inside_set(X,R), R==X)).
281
282 convert_to_avl_inside_set(Var,R) :- var(Var),!,
283 add_internal_error('Var arg: ',convert_to_avl_inside_set(Var,R)),fail.
284 :- if(environ(prob_safe_mode,true)).
285 convert_to_avl_inside_set(fd(A,T),R) :- var(A),!,
286 add_error(convert_to_avl,'Non-ground FD-Term: ',convert_to_avl_inside_set(fd(A,T),R)), R=fd(A,T).
287 convert_to_avl_inside_set(int(X),R) :- var(X),!,
288 add_error(convert_to_avl,'Non-ground integer: ',convert_to_avl_inside_set(int(X),R)), R=int(X).
289 convert_to_avl_inside_set(string(X),R) :- var(X),!,
290 add_error(convert_to_avl,'Non-ground string: ',convert_to_avl_inside_set(string(X),R)), R=string(X).
291 convert_to_avl_inside_set(term(X),R) :- (var(X) ; X=floating(F), var(F)), !,
292 add_error(convert_to_avl,'Non-ground term: ',convert_to_avl_inside_set(term(X),R)), R=term(X).
293 :- endif.
294 ?convert_to_avl_inside_set(Term,R) :- no_conversion_necessary(Term),!,R=Term.
295 convert_to_avl_inside_set(closure(P,T,B),R) :- !,
296 % inside a set, closures need to be expanded to check against other elements
297 expand_closure_to_avl_wf(P,T,B,R,no_wf_available).
298 %convert_to_avl_inside_set(closure_x(_P,_T,_B,E),R) :- !, convert_to_avl_inside_set(E,R).
299 convert_to_avl_inside_set(avl_set(A),R) :- !, normalise_avl_set(A,R). %AVL's inside other AVL's need to be normalised !
300 convert_to_avl_inside_set((A,B),(CA,CB)) :- !,convert_to_avl_inside_set(A,CA), convert_to_avl_inside_set(B,CB).
301 convert_to_avl_inside_set(freetype(X),R) :- !,
302 expand_custom_set(freetype(X),EC,check), convert_to_avl_inside_set(EC,R).
303 convert_to_avl_inside_set(freeval(ID,Case,Value),R) :- !,
304 R=freeval(ID,Case,CValue),convert_to_avl_inside_set(Value,CValue).
305 convert_to_avl_inside_set(rec(Fields),R) :- !, convert_fields(Fields,CFields), R=rec(CFields).
306 convert_to_avl_inside_set(global_set(GS),R) :- !,
307 % first check if GS infinite integer set: in this case do not expand; there can be no confusion with finite avl_sets
308 (is_infinite_global_set(GS,_) -> R = global_set(GS)
309 ; expand_only_custom_closure_global(global_set(GS),EC,check,no_wf_available), convert_to_avl_inside_set(EC,R)).
310 convert_to_avl_inside_set([H|T],R) :- !,convert_cons_to_avl_inside_set_wf(H,T,R,no_wf_available).
311 convert_to_avl_inside_set(X,R) :-
312 add_internal_error('Unknown or non-ground argument: ',convert_to_avl_inside_set(X,R)),
313 fail.
314
315 ?convert_to_avl_inside_set_wf(Term,R,_WF) :- no_conversion_necessary(Term),!,R=Term.
316 convert_to_avl_inside_set_wf(closure(P,T,B),R,WF) :- !,
317 expand_closure_to_avl_wf(P,T,B,R,WF). % inside a set, closures need to be expanded to check against other elements
318 convert_to_avl_inside_set_wf((A,B),(CA,CB),WF) :- !,
319 convert_to_avl_inside_set_wf(A,CA,WF), convert_to_avl_inside_set_wf(B,CB,WF).
320 convert_to_avl_inside_set_wf([H|T],R,WF) :- !,convert_cons_to_avl_inside_set_wf(H,T,R,WF).
321 convert_to_avl_inside_set_wf(V,CV,_WF) :- % use version without WF; TO DO: adapt fully
322 convert_to_avl_inside_set(V,CV).
323
324 % true when we have a simple value that does not need to be converted for use within an avl_set:
325 no_conversion_necessary([]).
326 no_conversion_necessary(pred_false). /* bool_false */
327 no_conversion_necessary(pred_true). /* bool_true */
328 no_conversion_necessary(fd(FD,_)) :- nonvar(FD).
329 no_conversion_necessary(int(I)) :- nonvar(I).
330 no_conversion_necessary(string(S)) :- nonvar(S).
331 ?no_conversion_necessary(term(T)) :- nonvar(T), no_conversion_nec_term(T).
332
333 no_conversion_nec_term(floating(T)) :- nonvar(T).
334 no_conversion_nec_term(T) :- atom(T).
335
336 normalise_avl_set(A,R) :- A=node(_,_,0,empty,empty), !,R=avl_set(A).
337 normalise_avl_set(A,R) :-
338 avl_to_list(A,L),
339 ord_list_to_avlset_direct(L,R,convert_to_avl_inside_set). %AVL's inside other AVL's need to be normalised !
340
341 convert_cons_to_avl_inside_set_wf(H,T,R,WF) :- T==[], !,
342 convert_to_avl_inside_set_wf(H,CH,WF),
343 R = avl_set(node(CH,true,0,empty,empty)).
344 convert_cons_to_avl_inside_set_wf(H,T,R,WF) :- l_convert_to_avl_wf([H|T],S,WF),
345 sort(S,SS),
346 ord_list_to_avlset_direct(SS,R,convert_to_avl_inside_set).
347
348 construct_singleton_avl_set(Val,avl_set(node(Val,true,0,empty,empty))).
349
350
351 is_set_value(X,Origin) :- var(X), !,print(is_set_value(Origin)),nl,fail.
352 is_set_value([],_) :- !.
353 is_set_value([_|_],_) :- !.
354 is_set_value(X,_) :- is_custom_explicit_set(X).
355
356 is_custom_explicit_set(X,Origin) :- var(X), !,print(var_is_custom_explicit_set(Origin)),nl,fail.
357 is_custom_explicit_set(X,_) :- is_custom_explicit_set(X).
358
359 is_custom_explicit_set(X) :- var(X), !,print(var_is_custom_explicit_set),nl,fail.
360 is_custom_explicit_set(global_set(_)).
361 is_custom_explicit_set(freetype(_)).
362 %is_custom_explicit_set(integer_global_set(_)).
363 is_custom_explicit_set(avl_set(_)).
364 is_custom_explicit_set(closure(_Parameters,_PT,_Cond)).
365
366 % use if you know the argument to be nonvar
367 is_custom_explicit_set_nonvar(global_set(_)).
368 is_custom_explicit_set_nonvar(freetype(_)).
369 is_custom_explicit_set_nonvar(avl_set(_)).
370 is_custom_explicit_set_nonvar(closure(_Parameters,_PT,_Cond)).
371
372 %:- assert_must_succeed(( custom_explicit_sets:portray_custom_explicit_set(avl_set(empty)) )). % now generates error
373 :- use_module(translate,[translate_bvalue/2]).
374 portray_custom_explicit_set(S) :- translate_bvalue(S,A), format(A,[]),nl.
375
376 /* a predicate to check equality of two custom explicit sets */
377
378 %equal_explicit_sets(A,B) :- equal_explicit_sets_wf(A,B,no_wf_available).
379
380 %equal_explicit_sets(X,Y) :- print_term_summary(equal_explicit_sets(X,Y)),fail.
381 :- block equal_explicit_sets_wf(-,?,?), equal_explicit_sets_wf(?,-,?).
382 ?equal_explicit_sets_wf(A,B,WF) :- equal_explicit_sets4(A,B,allow_expansion,WF).
383
384 equal_explicit_sets4(global_set(X),global_set(Y),_,_WF) :- !,X=Y.
385 equal_explicit_sets4(global_set(B),avl_set(A),E,WF) :- !,equal_explicit_sets4(avl_set(A),global_set(B),E,WF).
386 equal_explicit_sets4(freetype(X),freetype(Y),_,_WF) :- !,X=Y.
387 equal_explicit_sets4(avl_set(A),avl_set(B),_,_WF) :- !,
388 equal_avl_tree(A,B). % alternatively, we could normalise avl_trees and only store normalised versions
389 equal_explicit_sets4(avl_set(A),I2,_,_WF) :-
390 is_interval_closure_or_integerset(I2,L2,U2,Finite2),!, % also covers I2=global_set(...)
391 Finite2=finite, % only a finite interval can be equal to an AVL set
392 avl_equal_to_interval(A,L2,U2).
393 equal_explicit_sets4(avl_set(A),global_set(B),_,WF) :- \+ b_global_sets:b_integer_set(B), !, % integersets dealt with above
394 explicit_set_cardinality_wf(global_set(B),Card,WF),
395 is_finite_card(Card), % Card \= inf as avl_set must be finite
396 explicit_set_cardinality_wf(avl_set(A),Card,WF). /* the sets must be identical as global_set contains all values */
397 equal_explicit_sets4(avl_set(A),CPB,_,WF) :-
398 is_cartesian_product_closure(CPB,B1,B2),!,
399 decompose_avl_set_into_cartesian_product_wf(A,A1,A2,WF),
400 kernel_objects:equal_object_wf(A1,B1,equal_explicit_sets4,WF),
401 kernel_objects:equal_object_wf(A2,B2,equal_explicit_sets4,WF).
402 ?equal_explicit_sets4(closure(P,T,B),avl_set(A),E,WF) :- !, equal_explicit_sets4(avl_set(A),closure(P,T,B),E,WF).
403 equal_explicit_sets4(I1,I2,_,_WF) :- is_interval_closure_or_integerset(I1,L1,U1,Finite1),
404 is_interval_closure_or_integerset(I2,L2,U2,Finite2), !,
405 Finite1=Finite2, % either both finite or infinite
406 L1=L2, U1=U2.
407 equal_explicit_sets4(CPA,CPB,_,WF) :-
408 ? is_cartesian_product_closure(CPA,A1,A2),
409 ? is_cartesian_product_closure(CPB,B1,B2),!,
410 equal_cartesian_product_wf(A1,A2,B1,B2,WF).
411 % what if both subset or relations or functions ... closure: TO DO: add support
412 equal_explicit_sets4(S1,S2,_,WF) :-
413 is_not_member_value_closure_or_integerset(S1,TYPE,MS1),
414 is_not_member_value_closure_or_integerset(S2,TYPE,MS2),
415 !,
416 kernel_objects:equal_object_wf(MS1,MS2,equal_explicit_sets4,WF).
417 equal_explicit_sets4(closure(P1,T1,B1),closure(P2,T2,B2),_,_WF) :-
418 same_closure_body(P1,T1,B1,P2,T2,B2),!.
419 %equal_explicit_sets4(X,Y) :- X==Y,!.
420 equal_explicit_sets4(Set1,Set2,allow_expansion,WF) :-
421 %kernel_objects:test_finite_set_wf(Set1,F1,WF), kernel_objects:test_finite_set_wf(Set2,F2,WF), equal_expansions(F1,F2,Set1,Set2)
422 card_for_specific_custom_set(Set1,Card1,Code1), % TO DO: do not throw info away if Set2 cannot be determined
423 card_for_specific_custom_set(Set2,Card2,Code2),
424 !,
425 ? call(Code1), call(Code2),
426 % TO DO: if one of the two sets is infinite, then it would be enough to know that the other is not infinite for failure without expansion
427 equal_expansions(Card1,Card2,Set1,Set2,WF).
428 equal_explicit_sets4(Set1,Set2,allow_expansion,WF) :- equal_expansions(0,0,Set1,Set2,WF).
429
430
431 % detect e.g. when one closure has seq(Type) and the other one set(integer,Type)
432 same_types([],[]).
433 same_types([H1|T1],[H2|T2]) :- unify_types_strict(H1,H2), same_types(T1,T2).
434
435 :- block equal_expansions(-,?,?,?,?).
436 equal_expansions(F1,F2,Set1,Set2,WF) :- (number(F1);number(F2)),!,
437 % NOTE: sometimes we get inf for finite but very large sets
438 F1=F2, % unify; can propagate info back to closure; e.g. prj2(BOOL,NAT) = prj2(BOOL,0..n)
439 equal_expansions2(F1,F2,Set1,Set2,WF).
440 equal_expansions(F1,F2,Set1,Set2,WF) :-
441 equal_expansions2(F1,F2,Set1,Set2,WF).
442
443 :- block equal_expansions2(-,?,?,?,?), equal_expansions2(?,-,?,?,?).
444 %equal_expansions(0,0,avl_set(A),closure(P,T,B)) :- check_subset ?? in both directions ?
445 %equal_expansions2(inf,inf,Set1,Set2,WF) :- WF \= no_wf_available, !, % symbolic treatment
446 equal_expansions2(F,F,Set1,Set2,WF) :-
447 % only expand if both sets have same cardinality
448 % print_term_summary(equal_expansions3(F,Set1,Set2)),nl,
449 equal_expansions3(F,Set1,Set2,WF).
450
451 % TO DO: check if this brings something:
452 %equal_expansions3(avl_set(A),closure(P,T,B),_WF) :- !,
453 % expand_closure_to_avl_or_list(P,T,B,E2,check), % in case E2 is avl_set; we can use equal_avl_tree
454 % ((nonvar(E2),E2=avl_set(B2))
455 % -> print(eql_avl),nl, print_term_summary(equal_avl_tree(A,B2)),nl, equal_avl_tree(A,B2)
456 % ; print(eql_non_avl),nl,equal_object(avl_set(A),E2,equal_expansions3)
457 % ).
458 %:- use_module(library(lists),[perm2/4]).
459 %equal_expansions3(F,Set1,Set2,_WF) :- number(F), F>100, % test with: {{},{TRUE},{FALSE},{TRUE,FALSE}} = /*@symbolic */ {x|x<:BOOL} or
460 % {x|x<:POW(BOOL*BOOL) & (x={} or card(x)>0)} = /*@symbolic */ {x|x<:POW(BOOL*BOOL)} 26 sec -> 14 sec
461 % case does not seem to appear very often
462 % perm2(Set1,Set2,avl_set(_),Set),
463 % is_definitely_maximal_set(Set),
464 %Set2 is maximal and has the same cardinality as F, hence Set1 must be identical to Set2
465 % !,
466 % debug_println(9,equal_to_maximal_closure(F)).
467 equal_expansions3(F,Set1,Set2,WF) :-
468 ? get_identity_as_equivalence(F,Set1,Set2,EQUIV),
469 !,% translate:print_bexpr(EQUIV),nl,
470 opt_push_wait_flag_call_stack_info(WF,b_operator_call(equal,[Set1,Set2],unknown),WF2),
471 copy_wf_start(WF2,equal_expansions,CWF),
472 b_test_boolean_expression(EQUIV,[],[],CWF),
473 copy_wf_finish(WF2,CWF).
474 % Alternative could be, if difference were to be fully treated symbolically:
475 % difference_of_explicit_set_wf(Set1,Set2,R12,WF), difference_of_explicit_set_wf(Set2,Set1,R21,WF),
476 % kernel_objects:empty_set_wf(R12,WF), kernel_objects:empty_set_wf(R21,WF).
477 equal_expansions3(_,Set1,Set2,WF) :-
478 expand_custom_set_wf(Set1,E1,equal_expansions1,WF),
479 expand_custom_set_wf(Set2,E2,equal_expansions2,WF),
480 E1=E2. /* ensure that ordering and normalization is same for all representations ! */
481
482
483 :- use_module(bsyntaxtree, [create_forall/3]).
484 :- use_module(b_ast_cleanup, [clean_up/3]).
485 get_identity_as_equivalence(F,Set1,Set2,CleanedEQUIV) :-
486 (F=inf %; is_infinite_explicit_set(Set1) ; is_infinite_explicit_set(Set2)
487 ; Set1 \= avl_set(_),Set2 \= avl_set(_), % if one of the two sets is an AVL Set: better compute the other set explicitly instead of using this symbolic treatment
488 (dont_expand_this_explicit_set(Set1,100000) ;
489 dont_expand_this_explicit_set(Set2,100000)
490 )
491 % avl_test check for test 1081; TO DO: instead of test try to expand set and if this leads to enum warning use symbolic check
492 ),
493 ? get_identity_as_equivalence_aux(Set1,Set2,EQUIV),
494 clean_up(EQUIV,[],CleanedEQUIV).
495 % can be useful to replace x : {v|P(v)} --> x:P(x) (remove_member_comprehension) and reuse predicates, see 2483
496 get_identity_as_equivalence_aux(Set1,Set2,EQUIV) :-
497 ? kernel_objects:infer_value_type(Set1,S1Type),
498 ? kernel_objects:infer_value_type(Set2,S2Type),
499 merge_types(S1Type,S2Type,SType),
500 is_set_type(SType,Type),
501 % Construct: !x.(x:Set1 <=> x:Set2) ?? see test 2009
502 get_pos_infos_for_explicit_set(Set1,I1),
503 get_pos_infos_for_explicit_set(Set2,I2),
504 I12 = I1, % we could merge position_info; but two sets could be very far apart
505 TID = b(identifier('_equality_sets_'),Type,[]),
506 Mem1 = b(member(TID,b(value(Set1),SType,I1)),pred,I1),
507 Mem2 = b(member(TID,b(value(Set2),SType,I2)),pred,I2),
508 Body1 = b(equivalence(Mem1,Mem2),pred,I12),
509 create_forall([TID],Body1,EQUIV).
510 %translate:print_bexpr(EQUIV),nl.
511
512 :- use_module(bsyntaxtree, [get_texpr_pos/2]).
513 get_pos_infos_for_explicit_set(closure(_,_,Body),[Pos]) :- get_texpr_pos(Body,Pos),!.
514 get_pos_infos_for_explicit_set(_,[]).
515
516 :- use_module(kernel_equality,[eq_atomic/4, equality_objects/3,
517 equality_objects_wf_no_enum/4, equality_objects_with_type_wf/5]).
518 /* maybe rewrite equal_explicit_sets and not_... to use this to avoid maintaining multiple versions */
519 equality_explicit_sets_wf(global_set(X),global_set(Y),R,_WF) :- !, eq_atomic(X,Y,set,R).
520 equality_explicit_sets_wf(global_set(B),avl_set(A),R,WF) :- !,equality_explicit_sets_wf(avl_set(A),global_set(B),R,WF).
521 equality_explicit_sets_wf(freetype(X),freetype(Y),R,_) :- !, eq_atomic(X,Y,set,R).
522 equality_explicit_sets_wf(avl_set(A),avl_set(B),R,_) :- !,
523 (equal_avl_tree(A,B) -> R=pred_true ; R=pred_false). % alternatively, we could normalise avl_trees and only store normalised versions
524 equality_explicit_sets_wf(avl_set(A),I2,R,WF) :- is_interval_closure_or_integerset(I2,L2,U2),!,
525 % also covers I2=global_set(...)
526 avl_equality_to_interval(A,L2,U2,R,WF).
527 equality_explicit_sets_wf(avl_set(A),global_set(B),R,WF) :- \+ b_global_sets:b_integer_set(B), !,
528 explicit_set_cardinality_wf(global_set(B),Card,WF),
529 (is_finite_card(Card), % Card \= inf, %as avl_set must be finite
530 explicit_set_cardinality_wf(avl_set(A),Card,WF)
531 -> R=pred_true /* the sets must be identical as global_set contains all values */
532 ; R=pred_false).
533 equality_explicit_sets_wf(avl_set(A),CPB,R,WF) :-
534 is_cartesian_product_closure(CPB,B1,B2),!,
535 if(decompose_avl_set_into_cartesian_product_wf(A,A1,A2,WF), % should not produce pending co-routines
536 equality_cartesian_product_wf(A1,A2,B1,B2,R,WF),
537 R=pred_false % no cartesian product can be equal to this avl_set
538 ).
539 equality_explicit_sets_wf(closure(P,T,B),avl_set(A),R,WF) :- !,
540 equality_explicit_sets_wf(avl_set(A),closure(P,T,B),R,WF).
541 equality_explicit_sets_wf(I1,I2,R,WF) :- is_interval_closure_or_integerset(I1,L1,U1,Finite1),
542 is_interval_closure_or_integerset(I2,L2,U2,Finite2), !,
543 (Finite1=Finite2 -> equality_objects_wf_no_enum((int(L1),int(U1)),(int(L2),int(U2)),R,WF)
544 ; R = pred_false).
545 equality_explicit_sets_wf(CPA,CPB,R,WF) :-
546 is_cartesian_product_closure(CPA,A1,A2), is_cartesian_product_closure(CPB,B1,B2),!,
547 equality_cartesian_product_wf(A1,A2,B1,B2,R,WF).
548 equality_explicit_sets_wf(S1,S2,R,WF) :-
549 is_not_member_value_closure_or_integerset(S1,TYPE,MS1),
550 is_not_member_value_closure_or_integerset(S2,TYPE,MS2),!,
551 equality_objects_with_type_wf(TYPE,MS1,MS2,R,WF).
552 equality_explicit_sets_wf(closure(P,T,B),closure(P,T,B2),R,_) :-
553 same_texpr_body(B,B2),!,R=pred_true.
554 equality_explicit_sets_wf(Set1,Set2,R,WF) :-
555 Set1 \= [_|_], Set2 \= [_|_], % below we check for avl_set; i.e., useful are only closure/3, global_set/1, ...
556 ? get_identity_as_equivalence(unknown,Set1,Set2,EQUIV),!,
557 opt_push_wait_flag_call_stack_info(WF,b_operator_call(equal,[Set1,Set2],unknown),WF2),
558 copy_wf_start(WF2,equal_expansions,CWF),
559 % EQUIV is a universal quantification, usually over an infinite domain
560 b_interpreter_check:b_force_check_boolean_expression(EQUIV,[],[],CWF,R), % we know EQUIV cannot be reified
561 copy_wf_finish(WF2,CWF).
562 % TO DO: add complement sets,
563
564 /* Cartesian Product Comparison */
565 :- use_module(kernel_equality,[empty_cartesian_product_wf/4]).
566 % A1*A2 = B1*B2 <=> (((A1={} or A2={}) & (B1={} or B2={})) or (A1=B1 & A2=B2))
567 equal_cartesian_product_wf(A1,A2,B1,B2,WF) :-
568 equality_cartesian_product_wf(A1,A2,B1,B2,pred_true,WF).
569 not_equal_cartesian_product_wf(A1,A2,B1,B2,WF) :-
570 equality_cartesian_product_wf(A1,A2,B1,B2,pred_false,WF).
571
572 equality_cartesian_product_wf(A1,A2,B1,B2,R,_WF) :-
573 nonvar(A1), A1=closure(P,T,BdyA1),
574 nonvar(B1), B1=closure(P,T,BdyB1),
575 nonvar(A2), A2=closure(P2,T2,BdyA2),
576 nonvar(B2), B2=closure(P2,T2,BdyB2),
577 % they have the same names; probably we are comparing identical values (e.g., in bvisual2)
578 same_texpr_body(BdyA1,BdyB1),
579 % note: we cannot simply call equality of A2 and B2 as cartesian products can be empty, see test 2072
580 same_texpr_body(BdyA2,BdyB2),
581 !,
582 R=pred_true.
583 equality_cartesian_product_wf(A1,A2,B1,B2,R,WF) :-
584 empty_cartesian_product_wf(A1,A2,EmptyA,WF),
585 equality_cart_product2(EmptyA,A1,A2,B1,B2,R,WF).
586 :- block equality_cart_product2(-, ?,?,?,?,?,?).
587 equality_cart_product2(pred_true,_,_,B1,B2,R,WF) :- empty_cartesian_product_wf(B1,B2,R,WF).
588 equality_cart_product2(pred_false,A1,A2,B1,B2,R,WF) :- equality_objects_wf_no_enum((A1,A2),(B1,B2),R,WF).
589
590 /* COMPARING AVL-SET with INTERVAL */
591
592 % check if an avl tree is equal to an interval range
593 avl_equal_to_interval(_A,L2,U2) :-
594 infinite_interval(L2,U2),!,fail. % otherwise infinite & avl_set is finite
595 % we can now assume L2, U2 are numbers (but could not yet be instantiated)
596 avl_equal_to_interval(A,L2,U2) :-
597 avl_min(A,int(L2)), avl_max(A,int(U2)),
598 Card is 1+U2-L2,
599 explicit_set_cardinality(avl_set(A),Card). % sets are equal: same size + same lower & upper bound
600
601 avl_not_equal_to_interval(A,L2,U2,WF) :- avl_equality_to_interval(A,L2,U2,pred_false,WF).
602
603 avl_equality_to_interval(_A,L2,U2,R,_WF) :-
604 infinite_interval(L2,U2),!,R=pred_false. % interval infinite & avl_set is finite
605 % we can now assume L2, U2 are numbers (but could not yet be instantiated)
606 avl_equality_to_interval(A,L2,U2,R,WF) :-
607 avl_min(A,int(AL)), avl_max(A,int(AU)),
608 Card is 1+AU-AL,
609 explicit_set_cardinality_wf(avl_set(A),ACard,WF),
610 equality_objects_wf_no_enum((int(ACard),(int(AL),int(AU))),
611 (int(Card),(int(L2),int(U2))),R,WF).
612 % sets are equal if same size + same lower & upper bound
613
614 /* COMPARING TWO CLOSURES */
615
616 % a variation of equal_explicit_sets which tries not expand and just compares two closures
617
618 same_closure(I1,I2) :-
619 is_interval_closure_or_integerset(I1,L1,U1,Finite1),
620 is_interval_closure_or_integerset(I2,L2,U2,Finite2), !,
621 Finite1=Finite2,
622 L1=L2, U1=U2.
623 same_closure(CPA,CPB) :-
624 is_cartesian_product_closure(CPA,A1,A2),
625 is_cartesian_product_closure(CPB,B1,B2),!,
626 equal_cartesian_product_wf(A1,A2,B1,B2,no_wf_available). % could be expensive
627 same_closure(S1,S2) :-
628 is_not_member_value_closure_or_integerset(S1,TYPE,MS1),
629 is_not_member_value_closure_or_integerset(S2,TYPE,MS2),
630 !,
631 kernel_objects:equal_object(MS1,MS2,same_closure). % could be expensive
632 same_closure(closure(P1,T1,B1),closure(P2,T2,B2)) :- same_closure_body_with_parameter_renaming(P1,T1,B1,P2,T2,B2).
633
634 same_closure_body(P,T1, B1, P,T2,B2) :-
635 same_types(T1,T2),
636 same_texpr_body(B1,B2).
637
638 % a version of same_closure_body which allows renaming of the parameters
639 same_closure_body_with_parameter_renaming(P1,T1, B1, P2,T2,B2) :-
640 same_types(T1,T2),
641 create_renaming(P1,P2,Renaming),
642 % TO DO: pass Renaming in AVL tree and rename on the fly
643 rename_bt(B2,Renaming,RenamedB2),
644 same_texpr_body(B1,RenamedB2).
645
646 create_renaming([],[],[]).
647 create_renaming([ID|T1],[ID|T2],TR) :- !, create_renaming(T1,T2,TR).
648 create_renaming([ID1|T1],[ID2|T2],[rename(ID2,ID1)|TR]) :-
649 create_renaming(T1,T2,TR).
650
651
652 % check if two wrapped expressions are equal (modulo associated Info, e.g. source loc info)
653 % and checking inserted values for equality (sometimes storing a closure will convert small inner closures into AVL sets)
654 same_texpr_body(E1,E2) :- empty_avl(E),same_texpr_body(E1,E,E2).
655 same_texpr_body(b(E1,Type1,_),AVL,b(E2,Type2,_)) :-
656 unify_types_strict(Type1,Type2), % check in principle redundant
657 same_texpr2(E1,AVL,E2).
658
659 :- use_module(value_persistance,[cache_is_activated/0]).
660 :- use_module(bsyntaxtree,[safe_syntaxelement_det/5, is_set_type/2,get_texpr_ids/2,
661 get_texpr_expr/2, get_negated_operator_expr/2]).
662 same_texpr2(value(V1),AVL,RHS) :- !,same_texpr_value2(RHS,AVL,V1).
663 same_texpr2(LHS,AVL,value(V2)) :- !,same_texpr_value2(LHS,AVL,V2).
664 same_texpr2(lazy_let_expr(ID,LHS,RHS),AVL,lazy_let_expr(ID2,LHS2,RHS2)) :- !,
665 same_texpr_body(LHS,AVL,LHS2),
666 avl_store(ID,AVL,ID2,NewAVL),
667 same_texpr_body(RHS,NewAVL,RHS2).
668 same_texpr2(lazy_let_pred(ID,LHS,RHS),AVL,lazy_let_pred(ID2,LHS2,RHS2)) :- !,
669 same_texpr_body(LHS,AVL,LHS2),
670 avl_store(ID,AVL,ID2,NewAVL),
671 same_texpr_body(RHS,NewAVL,RHS2).
672 same_texpr2(lazy_lookup(ID1), AVL,lazy_lookup(ID2)) :- !, avl_fetch(ID1,AVL,ID2).
673 same_texpr2(E1,AVL,E2) :- % Should we only enable this for same_closure_body_with_parameter_renaming?
674 quantifier_construct(E1,Functor,TParas1,Body1),
675 quantifier_construct(E2,Functor,TParas2,Body2),
676 !,
677 same_quantified_expression(TParas1,Body1,AVL,TParas2,Body2).
678 same_texpr2(assertion_expression(Pred,MsgStr,EXPR),AVL,assertion_expression(Pred2,MsgStr2,EXPR2)) :- !,
679 (MsgStr==MsgStr2 -> true
680 ; cache_is_activated,
681 debug_println(19,ignoring_difference_in_assertion_msg(MsgStr,MsgStr2))),
682 % difference can happen when constant was computed in other context,
683 % e.g, when cache_is_activated with different position info (with and wo file info, see Debug_6min_zone_du_PAS)
684 % Value-wise MsgStr cannot make a difference; only makes a difference in error message when expr not WD
685 same_texpr_body(Pred,AVL,Pred2),
686 same_texpr_body(EXPR,AVL,EXPR2).
687 same_texpr2(E1,AVL,E2) :-
688 functor(E1,F,Arity),
689 functor(E2,F,Arity),!,
690 safe_syntaxelement_det(E1,Subs1,_Names1,_List1,Constant1),
691 safe_syntaxelement_det(E2,Subs2,_Names2,_List2,Constant2),
692 Constant2==Constant1,
693 same_sub_expressions(Subs1,AVL,Subs2).
694 same_texpr2(E1,AVL,E2) :- same_texpr_with_rewrite(E1,AVL,E2),!.
695 same_texpr2(E1,AVL,E2) :- same_texpr_with_rewrite(E2,AVL,E1).
696 %same_texpr2(E1,_,E2) :-
697 % functor(E1,F1,Arity1),
698 % functor(E2,F2,Arity2), print(not_eq(F1,Arity1,F2,Arity2)),nl, print(E1),nl, print(E2),nl,nl,fail.
699 % some differences: assertion_expression/3 and function/2, ...
700
701 % some rewrite rules from ast_cleanup; but we cannot replicate all rules here
702 same_texpr_with_rewrite(negation(TE1),AVL,E2) :-
703 get_negated_operator_expr(b(E2,pred,[]),NegE2),!,
704 get_texpr_expr(TE1,E1),
705 same_texpr2(E1,AVL,NegE2).
706 same_texpr_with_rewrite(member(X1,b(value(Set1),_,_)),AVL,equal(X2,b(El2,_,_))) :-
707 singleton_set(Set1,El1), !,
708 % X : {El} <===> X = El ; required for JSON trace replay of test 1491
709 same_texpr_body(X1,X2),
710 same_texpr_value2(El2,AVL,El1).
711 same_texpr_with_rewrite(not_member(X1,b(value(Set1),_,_)),AVL,not_equal(X2,b(El2,_,_))) :-
712 singleton_set(Set1,El1), !,
713 % X /: {El} <===> X /= El ; required for JSON trace replay of test 1491
714 same_texpr_body(X1,X2),
715 same_texpr_value2(El2,AVL,El1).
716
717 % constructs with local quantified parameters:
718 quantifier_construct(comprehension_set(TParas,Body),comprehension_set,TParas,Body).
719 quantifier_construct(exists(TParas,Body),exists,TParas,Body).
720 quantifier_construct(forall(TParas,LHS,RHS),forall,TParas,Body) :-
721 Body = b(implication(LHS,RHS),pred,[]).
722 % TODO?: SIGMA, PI, UNION, INTER
723
724 :- use_module(bsyntaxtree,[split_names_and_types/3]).
725 same_quantified_expression(TParas1,Body1,AVL,TParas2,Body2) :-
726 split_names_and_types(TParas1,P1,T1),
727 split_names_and_types(TParas2,P2,T2),
728 same_types(T1,T2),
729 create_renaming(P1,P2,Renaming),
730 rename_bt(Body2,Renaming,RenamedB2), % TODO: store renaming in AVL and lookup on the fly
731 same_texpr_body(Body1,AVL,RenamedB2).
732
733 same_texpr_value2(E2,_,V2) :- var(V2),!,V2==E2.
734 same_texpr_value2(interval(Min,Max),_,avl_set(A)) :- !, % occurs in JSON trace replay for test 268
735 avl_equal_to_interval(A,Min,Max). % TODO: also compare the other way around above; only apply if Card not too large?
736 same_texpr_value2(value(V2),_,V1) :- !,
737 same_value_inside_closure(V1,V2).
738 %(same_value_inside_closure(V1,V2) -> true ; print(not_eq_vals(V1,V2)),nl,fail).
739 same_texpr_value2(comprehension_set(Paras,B2),AVL,closure(P,_,B1)) :- !,
740 get_texpr_ids(Paras,P),!,
741 same_texpr_body(B1,AVL,B2).
742 same_texpr_value2(cartesian_product(TB1,TB2),AVL,V1) :-
743 decompose_value_into_cartesian_product(V1,A1,A2), !,
744 %print(cart(A1,A2)),nl,
745 get_texpr_expr(TB1,B1),
746 same_texpr_value2(B1,AVL,A1),
747 get_texpr_expr(TB2,B2),
748 same_texpr_value2(B2,AVL,A2).
749 same_texpr_value2(StaticExpr,_,int(Nr)) :- number(Nr),
750 b_ast_cleanup:pre_compute_static_int_expression(StaticExpr,Nr),!.
751 % TO DO: maybe also check if both sides can be evaluated
752 % TO DO: move pre_compute_static_int_expression to another module
753 same_texpr_value2(E2,AVL,V1) :- rewrite_value(V1,E2,NewE1),!,
754 same_texpr2(NewE1,AVL,E2).
755 %same_texpr_value2(E1,_,E2) :-
756 % functor(E1,F1,Arity1),
757 % functor(E2,F2,Arity2), print(not_eq_val(F1,Arity1,F2,Arity2)),nl, fail,print(E1),nl, print(E2),nl,nl,fail.
758
759 decompose_value_into_cartesian_product(avl_set(A),A1,A2) :- !,
760 decompose_avl_set_into_cartesian_product_wf(A,A1,A2,no_wf_available).
761 decompose_value_into_cartesian_product(Closure,A1,A2) :- is_cartesian_product_closure(Closure,A1,A2).
762
763
764 % rewrite values back to AST nodes
765 rewrite_value(value(V),OtherVal,New) :- nonvar(V),
766 rewrite_value_aux(V,OtherVal,New).
767 %rewrite_value(function(Lambda,Argument),assertion_expression(_,_,_),assertion_expression(Cond,Msg,Expr)) :- b_ast_cleanup:rewrite_function_application(Lambda,Argument,[],assertion_expression(Cond,Msg,Expr)).
768 rewrite_value_aux(closure(P,T,B),_,Set) :-
769 is_member_closure(P,T,B,_,Set). % TO DO: ensure that ast_cleanup does not generate useless member closures ?
770 rewrite_value_aux(global_set(GS),_,AST) :-
771 rewrite_glob_set(GS,AST).
772 rewrite_value_aux(avl_set(A),interval(_,_),interval(TLow,TUp)) :-
773 avl_equal_to_interval(A,Low,Up),
774 TLow = b(integer(Low),integer,[]), TUp = b(integer(Up),integer,[]).
775 rewrite_value_aux(int(A),integer(_),integer(A)) :- number(A).
776 rewrite_value_aux(pred_true,_,boolean_true).
777 rewrite_value_aux(pred_false,_,boolean_false).
778 rewrite_value_aux(string(A),integer(_),string(A)) :- % value(string(A)) rewritten to AST node string(A)
779 atom(A).
780
781
782 rewrite_glob_set('REAL',real_set).
783 rewrite_glob_set('FLOAT',float_set).
784 rewrite_glob_set('STRING',string_set).
785 rewrite_glob_set(I,integer_set(I)) :-
786 kernel_objects:integer_global_set(I).
787
788 allow_expansion(avl_set(_),closure(P,T,B)) :-
789 is_small_specific_custom_set(closure(P,T,B),100).
790 allow_expansion(closure(P,T,B),avl_set(_)) :-
791 is_small_specific_custom_set(closure(P,T,B),100).
792
793 same_sub_expressions([],_,[]).
794 same_sub_expressions([H1|T1],AVL,[H2|T2]) :-
795 same_texpr_body(H1,AVL,H2),
796 same_sub_expressions(T1,AVL,T2).
797
798 same_value_inside_closure(V1,V2) :- var(V1),!, V1==V2.
799 same_value_inside_closure(_,V2) :- var(V2),!,fail.
800 same_value_inside_closure(rec(Fields1),rec(Fields2)) :- !,
801 % sets of records come in this form: struct(b(value(rec(FIELDS)),record(_),_))
802 same_fields_inside_closure(Fields1,Fields2).
803 same_value_inside_closure(V1,V2) :-
804 % we could attempt this only if the outer closure was large/infinite ??
805 is_custom_explicit_set(V1), is_custom_explicit_set(V2),
806 !,
807 (allow_expansion(V1,V2) -> EXP=allow_expansion ; EXP = no_expansion),
808 equal_explicit_sets4(V1,V2,EXP,no_wf_available). % usually only sets compiled differently inside closures
809 same_value_inside_closure([H1|T1],avl_set(A2)) :- !, % relevant for JSON trace replay for test 1263
810 try_convert_to_avl([H1|T1],V1), V1=avl_set(A1),
811 equal_avl_tree(A1,A2).
812 same_value_inside_closure(avl_set(A2),[H1|T1]) :- !,
813 try_convert_to_avl([H1|T1],V1), V1=avl_set(A1),
814 equal_avl_tree(A1,A2).
815 same_value_inside_closure(V1,V2) :- V1==V2.
816
817 same_fields_inside_closure(V1,V2) :- var(V1),!, V1==V2.
818 same_fields_inside_closure(_,V2) :- var(V2),!,fail.
819 same_fields_inside_closure([],[]).
820 same_fields_inside_closure([field(Name,V1)|T1],[field(Name,V2)|T2]) :-
821 same_value_inside_closure(V1,V2),
822 same_fields_inside_closure(T1,T2).
823
824 /*
825 same_texpr_body_debug(H1,H2) :-
826 (same_texpr_body(H1,H2) -> true
827 ; print('FAIL: '),nl,
828 translate:print_bexpr(H1),nl, translate:print_bexpr(H2),nl, print(H1),nl, print(H2),nl, fail). */
829
830 %test(Y2,Z2) :- empty_avl(X), avl_store(1,X,2,Y), avl_store(2,X,3,Z),
831 % avl_store(2,Y,3,Y2), avl_store(1,Z,2,Z2), equal_avl_tree(Y2,Z2).
832
833 %equal_avl_tree(A,B) :- avl_min(A,Min), avl_min(B,Min), cmp(Min,A,B).
834 %cmp(El,A,B) :-
835 % (avl_next(El,A,Nxt) -> (avl_next(El,B,Nxt), cmp(Nxt,A,B))
836 % ; \+ avl_next(El,B,Nxt) ).
837
838 % The following is faster than using avl_next
839 equal_avl_tree(A,B) :-
840 % statistics(walltime,[WT1,_]),if(equal_avl_tree2(A,B),true,(statistics(walltime,[_,W]),print(wall(W)),nl)).
841 %equal_avl_tree2(A,B) :-
842 avl_min(A,Min),
843 !,
844 avl_min(B,Min),
845 avl_max(A,Max), avl_max(B,Max),
846 % maybe also check avl_height +/- factor of 1.4405 (page 460, Knuth 3) ? but it seems this would trigger only extremely rarely
847 %avl_height(A,H1), avl_height(A,H2), log(check(Min,Max,H1,H2)),
848 avl_domain(A,L), avl_domain(B,L).
849 equal_avl_tree(empty,_) :- !, format(user_error,'*** Warning: empty AVL tree in equal_avl_tree~n',[]).
850 equal_avl_tree(A,B) :- add_internal_error('Illegal AVL tree: ',equal_avl_tree(A,B)),fail.
851
852 /* a predicate to check equality of two custom explicit sets */
853
854 % TO DO: deal with second set being a variable with kernel_cardinality_attr attribute
855 :- block not_equal_explicit_sets_wf(-,?,?), not_equal_explicit_sets_wf(?,-,?).
856 not_equal_explicit_sets_wf(global_set(X),global_set(Y),_) :- !,dif(X,Y).
857 not_equal_explicit_sets_wf(global_set(B),avl_set(A),WF) :- !,
858 \+ equal_explicit_sets4(avl_set(A),global_set(B),allow_expansion,WF).
859 not_equal_explicit_sets_wf(freetype(X),freetype(Y),_) :- !,dif(X,Y).
860 not_equal_explicit_sets_wf(avl_set(A),avl_set(B),_) :- !,
861 \+ equal_avl_tree(A,B).
862 %not_equal_explicit_sets_wf(X,Y,_) :- X==Y,!,fail.
863 not_equal_explicit_sets_wf(avl_set(A),I2,WF) :- is_interval_closure_or_integerset(I2,L2,U2),!, % also covers I2=global_set(...)
864 avl_not_equal_to_interval(A,L2,U2,WF).
865 not_equal_explicit_sets_wf(avl_set(A),global_set(B),WF) :- !,
866 \+ equal_explicit_sets4(avl_set(A),global_set(B),allow_expansion,WF).
867 not_equal_explicit_sets_wf(avl_set(A),CPB,WF) :-
868 is_cartesian_product_closure(CPB,B1,B2),!,
869 if(decompose_avl_set_into_cartesian_product_wf(A,A1,A2,WF), % should not produce pending co-routines, but better safe
870 kernel_objects:not_equal_object_wf((A1,A2),(B1,B2),WF),
871 true % no cartesian product can be equal to this avl_set
872 ).
873 not_equal_explicit_sets_wf(closure(P,T,B),avl_set(A),WF) :- !,
874 not_equal_explicit_sets_wf(avl_set(A),closure(P,T,B),WF).
875 not_equal_explicit_sets_wf(I1,I2,_) :- is_interval_closure_or_integerset(I1,L1,U1,Finite1),
876 is_interval_closure_or_integerset(I2,L2,U2,Finite2), !,
877 dif((Finite1,L1,U1),(Finite2,L2,U2)). % maybe we should call not_equal_objects on integers (not on inf values)?
878 not_equal_explicit_sets_wf(CPA,CPB,WF) :-
879 is_cartesian_product_closure(CPA,A1,A2), is_cartesian_product_closure(CPB,B1,B2),!,
880 not_equal_cartesian_product_wf(A1,A2,B1,B2,WF).
881 not_equal_explicit_sets_wf(S1,S2,WF) :-
882 is_not_member_value_closure_or_integerset(S1,TYPE,MS1),
883 is_not_member_value_closure_or_integerset(S2,TYPE,MS2),!,
884 kernel_objects:not_equal_object_wf(MS1,MS2,WF).
885 not_equal_explicit_sets_wf(closure(P,T,B),closure(P,T,B2),_) :-
886 same_texpr_body(B,B2),!,fail.
887 % TO DO: maybe support interval & avl_set comparison
888 not_equal_explicit_sets_wf(Set1,Set2,WF) :-
889 card_for_specific_custom_set(Set1,Card1,Code1), card_for_specific_custom_set(Set2,Card2,Code2),
890 call(Code1), call(Code2),!,
891 not_equal_expansions(Card1,Card2,Set1,Set2,WF).
892 not_equal_explicit_sets_wf(Set1,Set2,WF) :- not_equal_expansions(0,0,Set1,Set2,WF).
893
894
895 :- block not_equal_expansions(-,?,?,?,?), not_equal_expansions(?,-,?,?,?).
896 not_equal_expansions(F1,F2,_,_,_) :- F1 \= F2,!. % sets guaranteed to be different
897 not_equal_expansions(F,F,Set1,Set2,WF) :-
898 ? get_identity_as_equivalence(F,Set1,Set2,EQUIV),
899 !, %write(not),nl,translate:print_bexpr(EQUIV),nl,
900 opt_push_wait_flag_call_stack_info(WF,b_operator_call(equal,[Set1,Set2],unknown),WF2),
901 copy_wf_start(WF2,equal_expansions,CWF),
902 b_not_test_boolean_expression(EQUIV,[],[],CWF),
903 copy_wf_finish(WF2,CWF).
904 not_equal_expansions(F,F,Set1,Set2,WF) :-
905 % only expand if both sets have same cardinality
906 expand_custom_set_wf(Set1,E1,not_equal_expansions1,WF),
907 expand_custom_set_wf(Set2,E2,not_equal_expansions2,WF),
908 dif(E1,E2). /* TO DO: ensure that ordering and normalization is same for all representations ! */
909
910
911
912
913 :- use_module(b_global_sets,[b_empty_global_set/1, b_non_empty_global_set/1, b_global_set_cardinality/2]).
914 is_empty_explicit_set_wf(closure(P,T,B),WF) :- !,
915 is_empty_closure_wf(P,T,B,WF).
916 is_empty_explicit_set_wf(S,_WF) :- is_empty_explicit_set(S).
917
918 % with WF we can delay computing Card; see test 1272 / card({x|x:1..10 & x*x<i}) = 0 & i>1
919 % TO DO: ideally we could just write this: is_empty_closure_wf(P,T,B,WF) :- closure_cardinality(P,T,B,0,WF). ; but empty_set / not_exists optimisation not triggered in closure_cardinality (yet); would avoid duplicate code
920 is_empty_closure_wf(P,T,B,WF) :-
921 is_lambda_value_domain_closure(P,T,B, DomainValue,_Expr),!,
922 kernel_objects:empty_set_wf(DomainValue,WF).
923 is_empty_closure_wf(P,T,B,WF) :- is_cartesian_product_closure_aux(P,T,B,A1,A2),!,
924 very_approximate_cardinality(A1,C1,WF),
925 very_approximate_cardinality(A2,C2,WF),
926 blocking_safe_mul(C1,C2,0).
927 is_empty_closure_wf(P,T,B,_WF) :-
928 card_for_specific_closure2(P,T,B,CC,Code),
929 !,
930 call(Code),CC=0.
931 is_empty_closure_wf(P,T,Body,WF) :-
932 WF \== no_wf_available, % only do this if we have a WF store; see comments for closure_cardinality ; code relevant for test 1272; card({x|x:1..10 & x*x<i}) = 0 & i>1
933 \+ ground_bexpr(Body), % otherwise better to use not_test_exists below (e.g., Bosch v6 Codespeed benchmark)
934 b_interpreter_check:reify_closure_with_small_cardinality(P,T,Body, WF, ReifiedList),
935 !,
936 domain(ReifiedList,0,1),
937 sum(ReifiedList,'#=',0).
938 is_empty_closure_wf(P,T,B,WF) :-
939 get_recursive_identifier_of_closure_body(B,TRID),!,
940 def_get_texpr_id(TRID,RID),
941 gen_typed_ids(P,T,TypedParas),
942 % now add Recursive ID's value to local state:
943 b_interpreter:b_not_test_exists(TypedParas,B,[used_ids([RID])],[bind(RID,closure(P,T,B))],[],no_compile,WF).
944 is_empty_closure_wf(P,T,B,WF) :- !, % try and check that not(#(P).(B)); i.e., there is no solution for the Body B; solves tests 1542, detecting that {x|x>100 & x mod 102 = 2} = {} is false
945 gen_typed_ids(P,T,TypedParas),
946 b_interpreter:b_not_test_exists(TypedParas,B,[used_ids([])],[],[],no_compile,WF). % used_ids are empty, as all variables already compiled into values
947
948 % very_approximate_cardinality: only required to return 0 for empty set, and number or inf for non-empty set, tested in 1893
949 :- block very_approximate_cardinality(-,?,?).
950 very_approximate_cardinality(avl_set(A),C,_) :- !, (A=empty -> print(empty_avl),nl,C=0 ; C=1).
951 very_approximate_cardinality([],C,_) :- !, C=0.
952 very_approximate_cardinality([_|_],C,_) :- !, C=1.
953 very_approximate_cardinality(Set,C,WF) :- kernel_objects:cardinality_as_int_wf(Set,int(C),WF).
954 % TO DO: maybe call is_empty_closure or similar for closures
955
956 gen_typed_ids([],[],R) :- !, R=[].
957 gen_typed_ids([ID|IT],[Type|TT],[b(identifier(ID),Type,[])|TTT]) :- !,
958 % TO DO: add Info field from outer set comprehension
959 gen_typed_ids(IT,TT,TTT).
960 gen_typed_ids(I,T,TI) :- add_internal_error('Call failed: ',gen_typed_ids(I,T,TI)),fail.
961
962 % version with WF can also deal with closures via exists !
963 is_empty_explicit_set(global_set(GS)) :- !, b_empty_global_set(GS).
964 is_empty_explicit_set(freetype(ID)) :- !, is_empty_freetype(ID).
965 is_empty_explicit_set(avl_set(A)) :- !,
966 (var(A) -> add_warning(is_empty_explicit_set,'Variable avl_set')
967 ; empty_avl(A), add_warning(is_empty_explicit_set,'Empty avl_set')
968 ).
969 is_empty_explicit_set(C) :- card_for_specific_closure(C,CC,Code),!,call(Code),CC=0.
970 is_empty_explicit_set(ES) :- expand_custom_set(ES,[],is_empty_explicit_set).
971
972
973 is_non_empty_explicit_set(CS) :- is_non_empty_explicit_set_wf(CS,no_wf_available).
974
975 is_non_empty_explicit_set_wf(global_set(GS),_WF) :- !, b_non_empty_global_set(GS).
976 is_non_empty_explicit_set_wf(freetype(ID),_WF) :- !, is_non_empty_freetype(ID).
977 is_non_empty_explicit_set_wf(avl_set(A),_WF) :- !,
978 (empty_avl(A) -> print('### Warning: empty avl_set (2)'),nl,fail
979 ; true).
980 is_non_empty_explicit_set_wf(closure(P,T,B),WF) :- !, is_non_empty_closure_wf(P,T,B,WF).
981 %is_non_empty_explicit_set_wf(ES,_WF) :- expand_custom_set(ES,[_|_],is_non_empty_explicit_set).
982
983
984 % TO DO: this code is a bit redundant with is_empty_closure_wf
985 is_non_empty_closure_wf(P,T,B,WF) :-
986 is_lambda_value_domain_closure(P,T,B, DomainValue,_Expr),!,
987 kernel_objects:not_empty_set_wf(DomainValue,WF).
988 is_non_empty_closure_wf(P,T,B,WF) :- is_cartesian_product_closure_aux(P,T,B,A1,A2),!,
989 very_approximate_cardinality(A1,C1,WF),
990 very_approximate_cardinality(A2,C2,WF),
991 blocking_safe_mul(C1,C2,CC),gt0(CC).
992 is_non_empty_closure_wf(P,T,B,_WF) :-
993 card_for_specific_closure2(P,T,B,CC,Code),!,call(Code),gt0(CC).
994 % TO DO: reify_closure_with_small_cardinality
995 is_non_empty_closure_wf(P,T,B,WF) :- WF \== no_wf_available,
996 ? get_recursive_identifier_of_closure_body(B,TRID),!,
997 def_get_texpr_id(TRID,RID),
998 gen_typed_ids(P,T,TypedParas),
999 % now add Recursive ID's value to local state:
1000 b_interpreter:b_test_exists(TypedParas,B,[used_ids([RID])],[bind(RID,closure(P,T,B))],[],WF).
1001 is_non_empty_closure_wf(P,T,B,WF) :- WF \== no_wf_available,
1002 % otherwise enumeration of test_exists will behave strangely; leading to enumeration warnings,... [TO DO: ensure we always have a WF or fix this below ?]
1003 % try and check that not(#(P).(B)); i.e., there is no solution for the Body B; solves tests 1542; test 1146 also triggers this code
1004 (debug_level_inactive_for(19) -> true ; print(non_empty_closure_test(P)),nl, translate:print_bexpr(B),nl),
1005 gen_typed_ids(P,T,TypedParas),
1006 !,
1007 b_interpreter:b_test_exists(TypedParas,B,[used_ids([])],[],[],WF). % used_ids are empty, as all variables already compiled into values
1008 % some rules for set_subtraction, ... closures ?? if left part infinite and right part finite it must be infinite
1009 is_non_empty_closure_wf(P,T,B,WF) :-
1010 expand_custom_set_wf(closure(P,T,B),[_|_],is_non_empty_closure_wf,WF).
1011
1012
1013 % TO DO: expand cart / reify and use for pf_test
1014 test_empty_closure_wf(P,T,B,Res,WF) :-
1015 is_lambda_value_domain_closure(P,T,B, DomainValue,_Expr),!,
1016 kernel_equality:empty_set_test_wf(DomainValue,Res,WF).
1017 %test_empty_closure_wf(P,T,B,WF) :- is_cartesian_product_closure_aux(P,T,B,A1,A2),!,
1018 test_empty_closure_wf(P,T,B,Res,_WF) :-
1019 card_for_specific_closure2(P,T,B,CC,Code),!,call(Code),leq0(CC,Res).
1020 test_empty_closure_wf(P,T,B,Res,WF) :-
1021 \+ is_memoization_closure(P,T,B,_MemoID),
1022 preferences:preference(use_closure_expansion_memoization,false),
1023 !,
1024 bexpr_variables(B,ClosureWaitVars),
1025 % this does not perform a few optimisations of expand_normal closure:
1026 % memoization, stored_memo_expansion, is_closure1_value_closure, is_lambda_closure
1027 % print(test_empty_closure_wf),nl, translate:print_bexpr(B),nl,
1028 when((ground(ClosureWaitVars) ; nonvar(Res)),
1029 test_empty_closure_wf2(P,T,B,Res,WF)).
1030 test_empty_closure_wf(P,T,B,Res,WF) :- % print(expand_test(P)),nl,
1031 % was expand_custom_set_wf(closure(P,T,B),ExpES,test_empty_closure_wf,WF), in turn calls expand_closure_to_list
1032 expand_normal_closure(P,T,B,ExpES,_CDone,check(test_empty_closure_wf),WF),
1033 kernel_equality:empty_set_test_wf(ExpES,Res,WF).
1034 % /*@symbolic */ {x|x:1..100000000 & x mod 22=1} = x & (x={} <=> B=TRUE)
1035
1036 test_empty_closure_wf2(P,T,B,Res,WF) :-
1037 Res == pred_true,!,
1038 is_empty_closure_wf(P,T,B,WF).
1039 test_empty_closure_wf2(P,T,B,Res,WF) :- Res == pred_false,!,
1040 is_non_empty_closure_wf(P,T,B,WF).
1041 test_empty_closure_wf2(P,T,B,Res,WF) :-
1042 (is_empty_closure_now(P,T,B,WF) % we need to force expansion here to be able to use local cut ->
1043 % expand_normal_closure would now also expand the closure;
1044 -> Res=pred_true
1045 ; Res=pred_false).
1046
1047 % check if closure now; ground everything except WFE
1048 is_empty_closure_now(P,T,B,OuterWF) :-
1049 create_inner_wait_flags(OuterWF,is_empty_closure_now,WF),
1050 debug_opt_push_wait_flag_call_stack_info(WF,
1051 external_call('Check if empty set',[closure(P,T,B)],unknown),WF2),
1052 is_empty_closure_wf(P,T,B,WF2),
1053 ground_inner_wait_flags(WF2). % does not ground WFE in case WD errors are pending
1054
1055 :- block leq0(-,?).
1056 leq0(inf,Res) :- !, Res=pred_false.
1057 leq0(inf_overflow,Res) :- !, Res=pred_false.
1058 leq0(CC,Res) :- (CC>0 -> Res=pred_false ; Res=pred_true).
1059
1060 test_empty_explicit_set_wf(V,Res,_) :- var(V),!,
1061 add_internal_error('Illegal call: ',test_empty_explicit_set(V,Res,_)),fail.
1062 test_empty_explicit_set_wf(global_set(GS),Res,_WF) :- !,
1063 (b_empty_global_set(GS) -> Res=pred_true ; Res=pred_false).
1064 test_empty_explicit_set_wf(freetype(ID),Res,_WF) :- !, test_empty_freetype(ID,Res).
1065 test_empty_explicit_set_wf(avl_set(A),Res,_WF) :- !,
1066 (var(A) -> add_warning(test_empty_explicit_set_wf,'Variable avl_set'), Res=pred_true
1067 ; empty_avl(A), add_warning(test_empty_explicit_set_wf,'Empty avl_set'), Res = pred_true
1068 ; Res=pred_false).
1069 test_empty_explicit_set_wf(closure(P,T,B),Res,WF) :- !,
1070 test_empty_closure_wf(P,T,B,Res,WF).
1071 test_empty_explicit_set_wf(ES,Res,WF) :-
1072 expand_custom_set(ES,ExpES,test_empty_explicit_set),
1073 kernel_equality:empty_set_test_wf(ExpES,Res,WF).
1074
1075 :- block gt0(-).
1076 gt0(CC) :- (CC=inf -> true ; CC=inf_overflow -> true ; CC>0).
1077
1078 % a version to compute cardinality for
1079 explicit_set_cardinality_for_wf(closure(P,T,B),Card) :-
1080 (is_symbolic_closure_or_symbolic_mode(P,T,B) ; \+ ground_bexpr(B)),
1081 !,
1082 Card = inf. % assume card is infinite for WF computation; it may be finite!
1083 %explicit_set_cardinality_for_wf(avl_set(AVL),Size) :- !, quick_avl_approximate_size(AVL,Size).
1084 explicit_set_cardinality_for_wf(CS,Card) :- card_for_specific_custom_set(CS,Card,Code),!,
1085 on_enumeration_warning(call(Code),Card=inf). % see test 1519 for relevance
1086 explicit_set_cardinality_for_wf(_,inf). % assume card is infinite for WF computation; it may be finite!
1087 % TO DO: maybe never expand closures here !? -> closure_cardinality can expand closure !!!!!!
1088 %explicit_set_cardinality_for_wf(CS,Card) :-
1089 % on_enumeration_warning(
1090 % explicit_set_cardinality(CS,Card),
1091 % (debug_println(assuming_inf_card_for_wf), % see test 1519 for relevance
1092 % Card = inf)). % assume card is infinite for WF computation; it may be finite!
1093
1094 explicit_set_cardinality(CS,Card) :-
1095 % init_wait_flags(WF,[explicit_set_cardinality]), % there are a few checks for no_wf_available below
1096 explicit_set_cardinality_wf(CS,Card,no_wf_available).
1097 % ground_wait_flags(WF).
1098
1099 explicit_set_cardinality_wf(global_set(GS),Card,_) :- !,b_global_set_cardinality(GS,Card).
1100 explicit_set_cardinality_wf(freetype(GS),Card,_WF) :- !, freetype_cardinality(GS,Card).
1101 explicit_set_cardinality_wf(avl_set(S),Card,_WF) :- !,avl_size(S,Card).
1102 ?explicit_set_cardinality_wf(closure(P,T,B),Card,WF) :- closure_cardinality(P,T,B,Card,WF).
1103
1104 closure_cardinality(P,T,B,Card,WF) :-
1105 is_lambda_value_domain_closure(P,T,B, DomainValue,_Expr),!,
1106 kernel_objects:cardinality_as_int_wf(DomainValue,int(Card),WF). % always compute it; card_for_specific_closure will only compute it if it can be done efficiently
1107 closure_cardinality(P,T,B,Card,WF) :- is_cartesian_product_closure_aux(P,T,B,A1,A2),!,
1108 kernel_objects:cardinality_as_int_wf(A1,int(C1),WF),
1109 kernel_objects:cardinality_as_int_wf(A2,int(C2),WF),
1110 blocking_safe_mul(C1,C2,Card).
1111 % TO DO: card_for_specific_closure2 calls is_lambda_value_domain_closure and is_cartesian_product_closure_aux again !
1112 closure_cardinality(P,T,B,Card,_WF) :-
1113 card_for_specific_closure2(P,T,B,CC,Code),
1114 !,
1115 call(Code),Card=CC.
1116 closure_cardinality(P,T,Body,Card,WF) :-
1117 (WF == no_wf_available -> CBody=Body
1118 ? ; b_compiler:b_compile(Body,P,[],[],CBody)
1119 ),
1120 % reify will work better if we used b_compiler:compile so that more sets can be detected as small
1121 closure_cardinality2(P,T,CBody,Card,WF).
1122 closure_cardinality2(P,T,Body,Card,WF) :-
1123 WF \== no_wf_available, % only do this if we have a WF store
1124 ? if(b_interpreter_check:reify_closure_with_small_cardinality(P,T,Body, WF, ReifiedList),
1125 true,
1126 (perfmessagecall(reify,reification_of_closure_for_card_failed(P),translate:print_bexpr(Body),Body),fail)),
1127 !,
1128 domain(ReifiedList,0,1),
1129 sum(ReifiedList,'#=',Card),
1130 % in this case we know card to be finite ! TO DO: ensure that check_finite propagates Card variable
1131 debug_println(9,reified_cardinality_sum(ReifiedList,Card)). % fd_dom(Card,Dom),print(dom(Card,Dom)),nl.
1132 % should we add a special check if Card=0 ? usually Card not instantiated at this point !
1133 %closure_cardinality(P,T,B,Card,WF) :- Card==0, %is_symbolic_closure(P,T,B),
1134 % !, is_empty_closure_wf(P,T,B,WF).
1135 closure_cardinality2(P,T,B,Card,WF) :-
1136 % TO DO: bexpr_variables(ClosureBody,ClosureWaitVars) and wait until those are bound; if Card = 0 -> empty_set; we can try to reifiy again
1137 expand_custom_set_wf(closure(P,T,B),Expansion,closure_cardinality,WF),
1138 my_length(Expansion,0,Card).
1139
1140 :- block my_length(-,?,?).
1141 my_length([],A,A).
1142 my_length([_|T],A,R) :- A1 is A+1, my_length(T,A1,R).
1143
1144 % compute domain and range for specific relations;
1145 % not the closure is total over the domain and surjective over the range
1146 % WARNING: this should never enumerate on its own, it is often called with
1147 % a cut straight after it; if some enumeration happens then only first solution
1148 % will be pursued (e.g., cond_assign_eq_obj)
1149 dom_range_for_specific_closure([],[],[],function(bijection),_WF).
1150 dom_range_for_specific_closure(closure(P,T,Pred),Domain,Range,Functionality,WF) :-
1151 dom_range_for_specific_closure2(P,T,Pred, Domain,Range,dom_and_range,Functionality,WF).
1152
1153 dom_range_for_specific_closure2(Par,Typ,Body, Domain,Range,Required,Functionality,WF) :-
1154 is_member_closure(Par,Typ,Body,_TYPE,SET),
1155 ? dom_range_for_member_closure(SET,Domain,Range,Required,Functionality,WF),!.
1156 dom_range_for_specific_closure2(Par,Typ,Body, DOMAIN,RANGE,_,Functionality,WF) :-
1157 is_cartesian_product_closure_aux(Par,Typ,Body,SET1,SET2),!,
1158 (singleton_set(SET2,_) % checks nonvar
1159 -> Functionality = function(total) % function if card(SET2)=1
1160 ; Functionality=relation),
1161 kernel_equality:empty_set_test_wf(SET1,EqRes1,WF),
1162 cond_assign_eq_obj_wf(EqRes1,RANGE,[],SET2,WF), % if SET1=[] then Range=[]
1163 kernel_equality:empty_set_test_wf(SET2,EqRes2,WF),
1164 cond_assign_eq_obj_wf(EqRes2,DOMAIN,[],SET1,WF). %if SET2=[] then Domain=[]
1165 dom_range_for_specific_closure2(Par,Typ,Body, DomainRange,DomainRange,_,function(bijection),_WF) :-
1166 is_id_closure_over(Par,Typ,Body,DomainRange,_).
1167
1168
1169 dom_range_for_member_closure(identity(b(value(SET1),ST1,_)),SET1,SET1,_,function(bijection),_) :-
1170 is_set_type(ST1,_). /* _SEQT=id(T1) */
1171 dom_range_for_member_closure(closure(V),Domain,Range,Required,Functionality,WF) :- % closure1 transitive closure
1172 % rx : A <-> B <=> closure1(rx) : A <-> B means we can simply remove closure1(.) wrapper
1173 V = b(value(VAL),_,_), nonvar(VAL),
1174 %write(peel_clos1_dom_range(Required)),nl, tools_printing:print_term_summary(closure(V)),nl,
1175 (VAL = closure(P,T,B)
1176 -> dom_range_for_specific_closure2(P,T,B,Domain,Range,Required,Functionality,WF)
1177 ; Functionality = relation, % we do not know if this is going to be a function
1178 (Required=domain_only -> true ; range_of_explicit_set_or_simple_value_wf(VAL,Range,WF)),
1179 (Required=range_only -> true ; domain_of_explicit_set_or_simple_value_wf(VAL,Domain,WF))
1180 ).
1181 dom_range_for_member_closure(Expr,Domain,Range,Required,Functionality,WF) :-
1182 is_comprehension_set_or_closure(Expr,P,T,Pred),
1183 (Required=domain_only
1184 -> Range = term(undefined), dom_for_specific_closure_aux(P,T,Pred, Domain,Functionality,WF)
1185 ; dom_range_for_specific_closure2(P,T,Pred, Domain,Range,Required,Functionality,WF)).
1186
1187
1188 domain_of_explicit_set_or_simple_value_wf([],Domain,_WF) :- !, Domain=[].
1189 domain_of_explicit_set_or_simple_value_wf([H|T],Domain,WF) :- !, T==[], % see test 2102
1190 H = (DomEl,_), equal_object_wf(Domain,[DomEl],domain_of_explicit_set_or_simple_value_wf,WF).
1191 domain_of_explicit_set_or_simple_value_wf(VAL,Domain,WF) :- domain_of_explicit_set_wf(VAL,Domain,WF).
1192
1193 range_of_explicit_set_or_simple_value_wf([],Range,_WF) :- !, Range=[].
1194 range_of_explicit_set_or_simple_value_wf([H|T],Range,WF) :- !, T==[],
1195 H = (_,RanEl), equal_object_wf(Range,[RanEl],range_of_explicit_set_or_simple_value_wf,WF).
1196 range_of_explicit_set_or_simple_value_wf(VAL,Range,WF) :- range_of_explicit_set_wf(VAL,Range,WF).
1197
1198
1199 is_comprehension_set_or_closure(comprehension_set(TP,Pred),P,T,Pred) :- split_names_and_types(TP,P,T).
1200 is_comprehension_set_or_closure(value(V),P,T,Pred) :- nonvar(V), V = closure(P,T,Pred).
1201
1202 % not sure if we need this: memoized functions are infinite usually and range can never be computed anyway
1203 %dom_range_for_member_closure(Expr,Domain,Range,Func) :-
1204 % expand_memoize_stored_function_reference(Expr,ExpandedValue),
1205 % dom_range_for_specific_closure(ExpandedValue,Domain,Range,Func,no_wf_available).
1206
1207 :- block cond_assign_eq_obj_wf(-,?,?,?,?).
1208 %cond_assign_eq_obj_wf(PTF,R,A,B,_) :- var(PTF), add_error(cond_assign_eq_obj,'block declaration bug warning: ',cond_assign_eq_obj(PTF,R,A,B)),fail. % comment in to detect if affected by block declaration bug
1209 cond_assign_eq_obj_wf(pred_true,Res,A,_,WF) :- equal_object_wf(Res,A,cond_assign_eq_obj_wf_1,WF).
1210 cond_assign_eq_obj_wf(pred_false,Res,_,B,WF) :- equal_object_wf(Res,B,cond_assign_eq_obj_wf_2,WF).
1211
1212 is_cartesian_product_closure(closure(Par,Typ,Body),SET1,SET2) :-
1213 ? is_cartesian_product_closure_aux(Par,Typ,Body,SET1,SET2).
1214 is_cartesian_product_closure_aux(Par,Types,b(truth,pred,Info),SET1,SET2) :- Par=[_,_|_],!,
1215 append(LPar,[RParID],Par), append(LTypes,[RType],Types),
1216 construct_closure_if_necessary(LPar,LTypes,b(truth,pred,Info),SET1),
1217 construct_closure_if_necessary([RParID],[RType],b(truth,pred,Info),SET2).
1218 is_cartesian_product_closure_aux(Par,Types,Body,SET1,SET2) :- Par=[_,_|_],!,
1219 append(LPar,[RParID],Par), append(LTypes,[RType],Types),!,
1220 split_conjunct(Body,[RParID], RConjL, LPar, LConjL),
1221 bsyntaxtree:conjunct_predicates(RConjL,RConj), bsyntaxtree:conjunct_predicates(LConjL,LConj),
1222 construct_closure_if_necessary(LPar,LTypes,LConj,SET1),
1223 construct_closure_if_necessary([RParID],[RType],RConj,SET2).
1224 is_cartesian_product_closure_aux(Par,Typ,Body,SET1,SET2) :-
1225 SET = cartesian_product(b(value(SET1),ST1,_), b(value(SET2),ST2,_)),
1226 is_member_closure(Par,Typ,Body,couple(T1m,T2m),SET),
1227 is_set_type(ST1,T1),unify_types_strict(T1,T1m),
1228 is_set_type(ST2,T2),unify_types_strict(T2,T2m),!.
1229 %is_cartesian_product_closure_aux([ID1,ID2],[T1,T2],FBody,SET1,SET2) :- % is this not redundant wrt split ??
1230 % % a closure of the form {ID1,ID2|ID1 : SET1 & ID2 : SET2} ;
1231 % % can get generated when computing domain symbolically of lambda abstraction
1232 % FBody = b(Body,pred,_),
1233 % is_cartesian_product_body(Body,ID1,ID2,T1,T2,SET1,SET2). % ,print(cart_res(SET1,SET2)),nl.
1234
1235 % try and split conjunct into two disjoint parts (for detecting cartesian products)
1236 % on the specified variables
1237 % fails if it cannot be done
1238 split_conjunct(b(PRED,pred,Info),Vars1,C1,Vars2,C2) :-
1239 split_conjunct_aux(PRED,Info,Vars1,C1,Vars2,C2).
1240 split_conjunct_aux(truth,_Info,_Vars1,C1,_Vars2,C2) :- !,C1=[],C2=[].
1241 split_conjunct_aux(conjunct(A,B),_Info,Vars1,C1,Vars2,C2) :- !, % TO DO: use DCG
1242 split_conjunct(B,Vars1,CB1,Vars2,CB2), !, % Note: conjunct_predicates will create inner conjunct in A and atomic Expression in B
1243 split_conjunct(A,Vars1,CA1,Vars2,CA2),!,
1244 append(CA1,CB1,C1), append(CA2,CB2,C2).
1245 split_conjunct_aux(E,Info,Vars1,C1,_Vars2,C2) :- unique_id_comparison(E,ID),!,
1246 (member(ID,Vars1) -> C1=[b(E,pred,Info)], C2=[] ; C1=[], C2=[b(E,pred,Info)]).
1247
1248 unique_id_comparison(less(b(L,_,_),b(R,_,_)), ID) :- unique_id_comparison_aux(L,R,ID).
1249 unique_id_comparison(less_equal(b(L,_,_),b(R,_,_)), ID) :- unique_id_comparison_aux(L,R,ID).
1250 unique_id_comparison(greater(b(L,_,_),b(R,_,_)), ID) :- unique_id_comparison_aux(L,R,ID).
1251 unique_id_comparison(greater_equal(b(L,_,_),b(R,_,_)), ID) :- unique_id_comparison_aux(L,R,ID).
1252 unique_id_comparison(member(b(identifier(ID),_,_),b(V,_,_)), ID) :- explicit_value(V).
1253 unique_id_comparison(subset(b(identifier(ID),_,_),b(V,_,_)), ID) :- explicit_value(V).
1254 unique_id_comparison(equal(b(L,_,_),b(R,_,_)), ID) :- unique_id_comparison_aux(L,R,ID). % means we also detect something like %x.(x : INTEGER|0) as cartesian product
1255 % what about not_equal
1256
1257 unique_id_comparison_aux(identifier(ID),V,ID) :- !,explicit_value(V).
1258 unique_id_comparison_aux(V,identifier(ID),ID) :- explicit_value(V).
1259
1260 explicit_value(value(_)) :- !.
1261 explicit_value(integer(_)) :- !.
1262 explicit_value(unary_minus(TV)) :- !, explicit_tvalue(TV).
1263 explicit_value(interval(TV1,TV2)) :- !,
1264 explicit_tvalue(TV1), explicit_tvalue(TV2).
1265 explicit_value(seq(B)) :- !, explicit_tvalue(B). % usually encoded as values by b_compile
1266 explicit_value(seq1(B)) :- !, explicit_tvalue(B).
1267 explicit_value(iseq(B)) :- !, explicit_tvalue(B).
1268 explicit_value(iseq1(B)) :- !, explicit_tvalue(B).
1269 explicit_value(struct(B)) :- !, explicit_tvalue(B).
1270 explicit_value(rec(Fields)) :- !,
1271 explicit_tfields(Fields). % triggered in test 2274, 2358, 1983, 2388, 2275, 2484
1272 explicit_value(fin_subset(A)) :- !, explicit_tvalue(A).
1273 explicit_value(fin1_subset(A)) :- !, explicit_tvalue(A).
1274 explicit_value(pow_subset(A)) :- !, explicit_tvalue(A).
1275 explicit_value(pow1_subset(A)) :- !, explicit_tvalue(A).
1276 explicit_value(cartesian_product(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1277 explicit_value(total_bijection(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B). % see test 1897 for cases below
1278 explicit_value(total_injection(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1279 explicit_value(total_function(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1280 explicit_value(total_surjection(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1281 explicit_value(partial_function(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1282 explicit_value(partial_injection(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1283 explicit_value(partial_surjection(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1284 explicit_value(relations(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1285 explicit_value(total_relation(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1286 explicit_value(surjection_relation(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1287 explicit_value(total_surjection_relation(A,B)) :- !, explicit_tvalue(A),explicit_tvalue(B).
1288 explicit_value(real_set) :- !.
1289 explicit_value(string_set) :- !.
1290
1291 explicit_tvalue(b(B,_,_)) :- !, explicit_value(B).
1292
1293 explicit_tfields(V) :- var(V),!,fail.
1294 explicit_tfields([]).
1295 explicit_tfields([field(N,V)|T]) :- ground(N),explicit_tvalue(V),explicit_tfields(T).
1296
1297 % conjunct_predicates([CA1,CB1],C1),
1298 % conjunct_predicates([CA2,CB2],C2).
1299
1300 /* *********
1301 is_cartesian_product_body(conjunct(A,B),ID1,ID2,_T1,_T2,SET1,SET2) :- !,
1302 member_pred_value(A,CID1,CSET1),
1303 member_pred_value(B,CID2,CSET2),
1304 (ID1=CID1,ID2=CID2,SET1=CSET1,SET2=CSET2 ; ID1=CID2,ID2=CID1,SET1=CSET2,SET2=CSET1).
1305 is_cartesian_product_body(A,ID1,ID2,T1,T2,SET1,SET2) :-
1306 member_pred_value2(A,AID,ASET),
1307 ( AID=ID1 -> SET1=ASET, construct_closure_if_necessary([ID2],[T2],b(truth,pred,[]),SET2)
1308 ; AID=ID2 -> SET2=ASET, construct_closure_if_necessary([ID1],[T1],b(truth,pred,[]),SET1)).
1309
1310 member_pred_value(b(B,pred,_), ID,VAL) :- print(member_pred_value2(B,ID,VAL)),nl,
1311 member_pred_value2(B,ID,VAL).
1312 member_pred_value2(member(b(identifier(ID),_CT1,_),b(value(VAL),_SCT1,_)), ID,VAL). %_SCT1 = set(CT1)
1313 */
1314
1315 % check if we have POW(SET1) or SET1<->SET2 (equiv. to POW(SET1*SET2))
1316 is_full_powerset_or_relations_or_struct_closure(closure(Par,Typ,Body),SUBSETS) :-
1317 %TYPE = set(T),
1318 is_member_closure(Par,Typ,Body,TYPE,SET),
1319 is_full_powset_aux(SET,TYPE,SUBSETS).
1320
1321 :- use_module(library(lists),[maplist/3, maplist/4]).
1322 is_full_powset_aux(pow_subset(b(value(SET1),set(T1),_)),set(T1),[SET1]).
1323 is_full_powset_aux(relations(S1,S2),set(couple(T1,T2)),[SET1,SET2]) :-
1324 S1 = b(value(SET1),set(T1),_), S2 = b(value(SET2),set(T2),_).
1325 is_full_powset_aux(struct(b(value(rec(FIELDS)),record(_),_)),record(_),FieldValueSets) :-
1326 maplist(get_field_val,FIELDS,FieldValueSets).
1327
1328 get_field_val(field(_,Val),Val).
1329
1330 %[field(duration,global_set('INTEGER')),field(rhythm,global_set('INTEGER')),field(slot,avl_set(...))]
1331
1332 is_powerset_closure(closure(Par,Typ,Body),PType,Subset) :-
1333 is_member_closure(Par,Typ,Body,TYPE,SET),
1334 is_set_type(TYPE,T),
1335 nonvar(SET),
1336 is_powset_aux(SET,PType,b(VS,set(T),_)), % should never be seq(.) type
1337 nonvar(VS), VS = value(Subset). %,print(powerset(Subset)),nl.
1338 is_powset_aux(pow_subset(A),pow,A).
1339 is_powset_aux(pow1_subset(A),pow1,A).
1340 is_powset_aux(fin_subset(A),fin,A).
1341 is_powset_aux(fin1_subset(A),fin1,A).
1342
1343 % group together closures which can be treated like cartesian products in the sense that:
1344 % Closure is empty if either Set1 or Set2 (could also be empty in other conditions though)
1345 % Closure is subset of other Closure if same Constructor and both sets are subsets
1346 /* is_cartesian_product_like_closure(Closure,Constructor,Set1,Set2) :-
1347 is_cartesian_product_closure(Closure,S11,S12),!,
1348 Constructor = cartesian_product,Set1=S11,Set2=S12.
1349 is_cartesian_product_like_closure(closure(Par,Typ,Body),Constructor,Set1,Set2) :-
1350 is_member_closure(Par,Typ,Body,TYPE,SET),
1351 is_cart_like_relation(SET,Constructor,b(value(Set1),set(_T1),_), b(value(Set1),set(_T2),_)).
1352 is_cart_like_relation(relations(A,B),relations,A,B).
1353 is_cart_like_relation(partial_function(A,B),partial_function,A,B).
1354 is_cart_like_relation(partial_injection(A,B),partial_injection,A,B). */
1355
1356 % (closure([_zzzz_unary],[set(couple(integer,string))],b(member(b(identifier(_zzzz_unary),set(couple(integer,string)),[]),b(relations(b(value(global_set(INTEGER)),set(integer),[]),b(value(global_set(STRING)),set(string),[])),set(set(couple(integer,string))),[])),pred,[])))
1357 % 1 1 Fail: custom_explicit_sets:is_powset_aux(relations(b(value(global_set('INTEGER')),set(integer),[]),b(value(global_set('STRING')),set(string),[])),couple(integer,string),_19584) ?
1358
1359 % card_for_specific_custom_set(+Set,-Cardinality,-CodeToComputeCardinality)
1360 % succeeds if card can be computed efficiently
1361 card_for_specific_custom_set(CS,C,Cd) :- var(CS),!,
1362 add_internal_error('Internal error: var ',card_for_specific_custom_set(CS,C,Cd)),fail.
1363 card_for_specific_custom_set(global_set(GS),Card,true) :- !, b_global_set_cardinality(GS,Card).
1364 card_for_specific_custom_set(freetype(Id),Card,true) :- !, freetype_cardinality(Id,Card).
1365 card_for_specific_custom_set(avl_set(S),Card,true) :- !,avl_size(S,Card).
1366 card_for_specific_custom_set(closure(P,T,B),Card,CodeToComputeCard) :-
1367 card_for_specific_closure3(_,P,T,B,Card,CodeToComputeCard).
1368
1369 card_for_specific_closure(closure(P,T,Pred),Card,CodeToComputeCard) :-
1370 card_for_specific_closure3(_ClosureKind,P,T,Pred,Card,CodeToComputeCard).
1371 card_for_specific_closure(closure(P,T,Pred),ClosureKind,Card,CodeToComputeCard) :-
1372 card_for_specific_closure3(ClosureKind,P,T,Pred,Card,CodeToComputeCard).
1373
1374 :- use_module(bsyntaxtree,[is_truth/1]).
1375 card_for_specific_closure2(Par,Typ,Body, Card,Code) :-
1376 card_for_specific_closure3(_ClosureKind,Par,Typ,Body, Card,Code).
1377
1378 :- use_module(kernel_reals,[is_real_interval_closure_with_known_card/4]).
1379 % first argument for debugging purposes or filtering
1380 card_for_specific_closure3(special_closure,Par,Typ,Body, Card,Code) :-
1381 is_special_infinite_closure(Par,Typ,Body),!,Card=inf, Code=true.
1382 card_for_specific_closure3(truth_closure,_,Types,Body,Card,Code) :- is_truth(Body),!,
1383 % TO DO: also treat multiple parameters
1384 couplise_list(Types,Type),
1385 Code=kernel_objects:max_cardinality(Type,Card).
1386 card_for_specific_closure3(interval_closure,Par,Typ,Body, Card,Code) :-
1387 ? is_geq_leq_interval_closure(Par,Typ,Body,Low,Up), !,
1388 card_of_interval_inf(Low,Up,Card),
1389 Code=true. % should we return card_of_interval_inf as code ?
1390 card_for_specific_closure3(real_interval_closure,Par,Typ,Body, Card,Code) :-
1391 is_real_interval_closure_with_known_card(Par,Typ,Body,CC), !,
1392 Card=CC, Code=true.
1393 % TO DO: deal with non-infinite not_member_closures, prj1, prj2, id, ...
1394 card_for_specific_closure3(lambda_closure,Par,Typ,Body, Card,Code) :-
1395 is_lambda_value_domain_closure(Par,Typ,Body, DomainValue,_Expr),!, nonvar(DomainValue),
1396 efficient_card_for_set(DomainValue,Card,Code).
1397 card_for_specific_closure3(cartesian_product,Par,Typ,Body, Card,Code) :-
1398 is_cartesian_product_closure_aux(Par,Typ,Body,A1,A2),!,
1399 card_for_cartesian_product_of_values(A1,A2,Card,Code).
1400 card_for_specific_closure3(member_closure,Par,Typ,Body, Card,Code) :-
1401 is_member_closure(Par,Typ,Body,TYPE,SET),
1402 nonvar(SET),!,
1403 card_for_member_closure(SET,TYPE,Card,Code).
1404 % Note: _ExprInfo could have: contains_wd_condition,
1405 % but if lambda is well-defined we compute the correct card ; if not then card is not well-defined anyway
1406 % maybe we should check contains_wd_condition produce a warning msg ?
1407
1408 % generate code to compute card for cartesian product closure of two values A and B
1409 card_for_cartesian_product_of_values(A1,A2,Card,Code) :- nonvar(A1), nonvar(A2),
1410 efficient_card_for_set(A1,Card1,Code1),
1411 efficient_card_for_set(A2,Card2,Code2),
1412 Code = (Code1,Code2, custom_explicit_sets:blocking_safe_mul(Card1,Card2,Card)).
1413
1414
1415 % inner values can sometimes be a list, e.g., [pred_true,pred_false] for BOOL
1416 efficient_card_for_set(VAR,_,_) :- var(VAR),!,fail.
1417 efficient_card_for_set([],Card,Code) :- !, Card=0,Code=true.
1418 efficient_card_for_set([_|T],Card,Code) :- known_length(T,1,C), !, Card = C, Code=true.
1419 efficient_card_for_set(CS,Card,Code) :- card_for_specific_custom_set(CS,Card,Code).
1420 known_length(X,_,_) :- var(X),!,fail.
1421 known_length([],A,A).
1422 known_length([_|T],A,R) :- A1 is A+1, known_length(T,A1,R).
1423 known_length(avl_set(S),Acc,Res) :- avl_size(S,Card),
1424 Res is Acc+Card.
1425 % TO DO: also support closures
1426
1427 card_for_member_closure(cartesian_product(A,B),_T,Card,CodeToComputeCard) :- !,
1428 A = b(value(AVal),_,_), B = b(value(BVal),_,_), % TODO: do we need to generalise this?
1429 card_for_cartesian_product_of_values(AVal,BVal,Card,CodeToComputeCard).
1430 card_for_member_closure(parallel_product(A,B),_T,Card,CodeToComputeCard) :- !,
1431 A = b(value(AVal),_,_), B = b(value(BVal),_,_),
1432 card_for_cartesian_product_of_values(AVal,BVal,Card,CodeToComputeCard).
1433 % cardinality computed like for cartesian_product.
1434 card_for_member_closure(seq(b(Value,ST1,_)),_SEQT,Card,CodeToComputeCard) :- !, /* _SEQT=seq(T1) */
1435 is_set_type(ST1,_T1),
1436 get_cart_product_of_values(Value,ListOfSets), % accept a value or cartesian product of values
1437 CodeToComputeCard = custom_explicit_sets:seq_card_of_cart_product(ListOfSets,1,Card). % Card is 1 or inf
1438 card_for_member_closure(seq1(b(Value,ST1,_)),_SEQT,Card,CodeToComputeCard) :- !, /* _SEQT=seq1(T1) */
1439 is_set_type(ST1,_T1),
1440 get_cart_product_of_values(Value,ListOfSets), % accept a value or cartesian product of values
1441 CodeToComputeCard = custom_explicit_sets:seq_card_of_cart_product(ListOfSets,0,Card). % Card is 0 or inf
1442 card_for_member_closure(perm(b(value(SET1),ST1,_)),_SEQT,Card,CodeToComputeCard) :- !, /* _SEQT=perm(T1) */
1443 is_set_type(ST1,_T1),
1444 CodeToComputeCard = (kernel_objects:cardinality_as_int(SET1,int(SCard)),
1445 custom_explicit_sets:blocking_factorial(SCard,Card)).
1446 card_for_member_closure(iseq(b(value(SET1),ST1,_)),_SEQT,Card,CodeToComputeCard) :- !, /* _SEQT=iseq(T1) */
1447 is_set_type(ST1,_T1),
1448 CodeToComputeCard = (kernel_objects:cardinality_as_int(SET1,int(SCard)),
1449 kernel_card_arithmetic:blocking_nr_iseq(SCard,Card)).
1450 card_for_member_closure(iseq1(b(value(SET1),ST1,_)),_SEQT,Card,CodeToComputeCard) :- !, /* _SEQT=iseq1(T1) */
1451 is_set_type(ST1,_T1),
1452 CodeToComputeCard = (kernel_objects:cardinality_as_int(SET1,int(SCard)),
1453 kernel_card_arithmetic:blocking_nr_iseq1(SCard,Card)).
1454 card_for_member_closure(identity(b(value(SET1),ST1,_)),_SEQT,Card,CodeToComputeCard) :- !, /* _SEQT=id(T1) */
1455 is_set_type(ST1,_T1),
1456 CodeToComputeCard =
1457 kernel_objects:cardinality_as_int(SET1,int(Card)).
1458 card_for_member_closure(struct(b(RecVal,record(_FieldSetTypes),_)), record(_FieldTypes), % set of records
1459 Card,CodeToComputeCard) :-
1460 !,
1461 (RecVal=value(RECF), nonvar(RECF), RECF=rec(FIELDS) % value has been computed:
1462 -> CodeToComputeCard = custom_explicit_sets:get_field_cardinality(FIELDS,Card)
1463 ; RecVal = rec(TypedFields), % we still have a typed AST
1464 maplist(get_field_val_type,TypedFields,Exprs,Types),
1465 l_card_for_member_closure(Exprs,Types,Card, CodeToComputeCard)
1466 ).
1467 card_for_member_closure(value(Value), _Type, Card,CodeToComputeCard) :- !,
1468 % we have a closure of the type {x|x:S}; equivalent to S
1469 (nonvar(Value),
1470 Value=closure(P,T,B)
1471 -> % cardinality_as_int may expand it ! is bad if e.g. we called this code to check if a closure is infinite
1472 card_for_specific_closure2(P,T,B,Card,CodeToComputeCard) % will not expand, but fail if cannot be computed
1473 % TO DO: provide an argument: precise_or_efficient
1474 ; CodeToComputeCard = kernel_objects:cardinality_as_int(Value,int(Card))
1475 ).
1476 card_for_member_closure(comprehension_set(TP,B), _Type, Card,CodeToComputeCard) :- !, % see test 2571
1477 split_names_and_types(TP,P,T), % what if Body reads variables; b_compile should have removed them??
1478 card_for_specific_closure3(_ClosureKind,P,T,B,Card,CodeToComputeCard).
1479 % now dealt with separately above: card_for_member_closure(cartesian_product(b(value(SET1),set(T1),_), b(value(SET2),set(T2),_)),
1480 % couple(T1,T2), Card,CodeToComputeCard) :- !,
1481 % CodeToComputeCard =
1482 % (kernel_objects:cardinality_as_int(SET1,int(SCard1)),
1483 % kernel_objects:cardinality_as_int(SET2,int(SCard2)),
1484 % custom_explicit_sets:blocking_safe_mul(SCard1,SCard2,Card) ).
1485 card_for_member_closure(POW,TYPE, Card,CodeToComputeCard) :-
1486 (POW = pow_subset(b(value(SET),TYPE,_)) ;
1487 POW = fin_subset(b(value(SET),TYPE,_))),!,
1488 CodeToComputeCard =
1489 (kernel_objects:cardinality_as_int(SET,int(SCard)),
1490 custom_explicit_sets:blocking_safe_pow2(SCard,Card)
1491 ).
1492 card_for_member_closure(POW,TYPE, Card,CodeToComputeCard) :-
1493 (POW = pow1_subset(b(value(SET),TYPE,_)) ;
1494 POW = fin1_subset(b(value(SET),TYPE,_))),!,
1495 CodeToComputeCard =
1496 (kernel_objects:cardinality_as_int(SET,int(SCard)),
1497 custom_explicit_sets:blocking_safe_pow2(SCard,C1),
1498 custom_explicit_sets:safe_dec(C1,Card)
1499 ).
1500 card_for_member_closure(RELEXPR,SType, Card,CodeToComputeCard) :-
1501 is_set_type(SType,couple(T1,T2)),
1502 is_a_relation(RELEXPR, b(value(DOM),set(T1),_),
1503 b(value(RAN),set(T2),_), DCard,RCard,Card,RELCODE),!,
1504 CodeToComputeCard =
1505 (
1506 kernel_objects:cardinality_as_int(DOM,int(DCard)),
1507 kernel_objects:cardinality_as_int(RAN,int(RCard)),
1508 custom_explicit_sets:call_card_for_relations(DCard,RCard,RELCODE)
1509 ).
1510 card_for_member_closure(BODY, integer, Card,CodeToComputeCard) :-
1511 is_interval_with_integer_bounds(BODY,Low,Up),!,
1512 CodeToComputeCard = custom_explicit_sets:card_of_interval_inf(Low,Up,Card).
1513 %card_for_member_closure(BODY, Type, Card,CodeToComputeCard) :- print(try_card(BODY,Type)),nl,fail.
1514 % TO DO: add maybe other common closures ? simple value closure
1515 % also: what if subexpressions are not of value() type ?
1516
1517 :- public call_card_for_relations/3.
1518 :- block call_card_for_relations(-,?,?), call_card_for_relations(?,-,?).
1519 call_card_for_relations(_,_,RELCODE) :- call(RELCODE).
1520
1521 get_field_val_type(field(_F1,b(Expr1,Type1,_)),Expr1,Type1).
1522
1523 l_card_for_member_closure([Expr1],[Type1],Card,CodeToComputeCard) :- !,
1524 card_for_member_closure(Expr1,Type1,Card, CodeToComputeCard).
1525 l_card_for_member_closure([Expr1|ET],[Type1|TT],Card,CodeToComputeCard) :-
1526 CodeToComputeCard = (Code1,Code2, custom_explicit_sets:blocking_safe_mul(Card1,Card2,Card)),
1527 card_for_member_closure(Expr1,Type1,Card1, Code1),
1528 l_card_for_member_closure(ET,TT,Card2,Code2).
1529
1530 :- public safe_dec/2. % used in card_for_member_closure
1531 :- block safe_dec(-,?).
1532 safe_dec(inf,R) :- !, R=inf.
1533 safe_dec(inf_overflow,R) :- !, R=inf_overflow.
1534 safe_dec(X,R) :- R is X-1.
1535
1536 :- use_module(kernel_equality,[empty_set_test/2]).
1537 :- public seq_card/3. % used in card_for_member_closure
1538 :- block seq_card(-,?,?).
1539 seq_card([],EmptyVal,R) :- !,R=EmptyVal.
1540 seq_card([_|_],_,R) :- !,R=inf.
1541 seq_card(X,EmptyVal,Res) :- empty_set_test(X,EqRes),
1542 set_card_or_inf(EqRes,EmptyVal,Res).
1543
1544 :- block set_card_or_inf(-,?,?).
1545 set_card_or_inf(pred_true,Nr,Nr).
1546 set_card_or_inf(pred_false,_,inf).
1547 % card(seq({n|n>10 & (n mod 20=3 & n mod 20 = 4) }))
1548
1549 % for list [S1,S2,...,Sn] of sets we compute
1550 % cardinality of seq(1)( S1 ** S2 ... ** Sn) to be either 0/1 (if one set is empty) or inf (if all sets are non-empty)
1551 :- public seq_card_of_cart_product/3. % used in card_for_member_closure
1552 seq_card_of_cart_product([Set],EmptyCard,Res) :- !,
1553 seq_card(Set,EmptyCard,Res).
1554 seq_card_of_cart_product([Set1|T],EmptyCard,Res) :-
1555 seq_card(Set1,EmptyCard,Res1),
1556 (Res1==EmptyCard -> Res=Res1
1557 ; combine_card(Res1,Res2,Res),
1558 seq_card_of_cart_product([Set1|T],EmptyCard,Res2)
1559 ).
1560
1561 % combine cardinalities of either 0/1 and inf
1562 :- block combine_card(-,-,?).
1563 combine_card(X,Y,R) :- X==inf,!,R=Y.
1564 combine_card(X,Y,R) :- Y==inf,!,R=X.
1565 combine_card(X,_,R) :- integer(X),!,R=X.
1566 combine_card(_,R,R).
1567
1568 get_cart_product_of_values(Value,ListOfSetValues) :- get_cart_product_of_values(Value,ListOfSetValues,[]). %write(get_cart(ListOfSetValues)),nl,nl.
1569 % check if something is a value or a cartesian product of values
1570 % the result will be used for emptyness check and should NOT be used to compute the cardinality
1571 get_cart_product_of_values(value(SET)) --> !, [SET].
1572 get_cart_product_of_values(cartesian_product(A,B)) --> !,
1573 tcart_product_of_values(A), tcart_product_of_values(B).
1574 get_cart_product_of_values(pow_subset(_)) --> !, [ [] ]. % create some non-empty set; POW({}) is not empty
1575 get_cart_product_of_values(fin_subset(_)) --> !, [ [] ]. % ditto
1576 get_cart_product_of_values(seq(_)) --> !, [ [] ]. % ditto
1577 get_cart_product_of_values(iseq(_)) --> !,[ [] ]. % ditto
1578 get_cart_product_of_values(pow1_subset(A)) --> !, tcart_product_of_values(A). % POW1(S)={} <=> S={}
1579 get_cart_product_of_values(fin1_subset(A)) --> !, tcart_product_of_values(A). % FIN1(S)={} <=> S={}
1580 get_cart_product_of_values(seq1(A)) --> !, tcart_product_of_values(A). % seq1(S)={} <=> S={}
1581 get_cart_product_of_values(iseq1(A)) --> !, tcart_product_of_values(A). % iseq1(S)={} <=> S={}
1582 %get_cart_product_of_values(X) --> {functor(X,F,N), write(uncov_get_cart(F,N)),nl,fail}.
1583 % TODO: records,relations,...
1584
1585 tcart_product_of_values(b(E,_,_)) --> get_cart_product_of_values(E).
1586
1587
1588
1589 :- public get_field_cardinality/2. % used in card_for_member_closure
1590 get_field_cardinality([],1).
1591 get_field_cardinality([field(_Name,Value)|T],ResCard) :-
1592 kernel_objects:cardinality_as_int(Value,int(SCard1)),
1593 get_field_cardinality(T,RestCard), blocking_safe_mul(SCard1,RestCard,ResCard).
1594
1595 :- use_module(kernel_card_arithmetic).
1596
1597 :- block blocking_safe_mul(-,-,?).
1598 blocking_safe_mul(A,B,R) :-
1599 ( A==0 -> R=0
1600 ; B==0 -> R=0
1601 ; A==1 -> R=B
1602 ; B==1 -> R=A
1603 ; blocking_safe_mul2(A,B,R) ).
1604
1605 :- block blocking_safe_mul2(-,?,?), blocking_safe_mul2(?,-,?).
1606 blocking_safe_mul2(A,B,Res) :-
1607 (safe_mul(A,B,AB) -> Res=AB
1608 ; add_warning(blocking_safe_mul2,'Call failed: ',blocking_safe_mul2(A,B,Res)),
1609 % could happen for something like prj2(BOOL,NAT) = prj2(BOOL,0..n)
1610 fail).
1611
1612 :- public blocking_safe_pow2/2. % used in card_for_member_closure above
1613 :- block blocking_safe_pow2(-,?).
1614 blocking_safe_pow2(A,Res) :-
1615 (safe_pow2(A,A2) -> Res=A2
1616 ; add_warning(blocking_safe_pow2,'Call failed: ',safe_pow2(A,Res)),fail).
1617
1618
1619
1620
1621 :- assert_must_succeed((custom_explicit_sets:card_for_specific_closure2(['_zzzz_binary'],[integer],
1622 b(member(b(identifier('_zzzz_binary'),integer,[generated]),
1623 b(interval(b(value(int(1)),integer,[]),b(value(int(10)),integer,[])),set(integer),[])),pred,[]),R,C),
1624 call(C),
1625 R=10)).
1626
1627 %! is_interval_closure_or_integerset(+I,-L,-U)
1628 is_interval_closure_or_integerset(Var,_,_) :- var(Var),!,fail.
1629 is_interval_closure_or_integerset(global_set(X),Low,Up) :- !, get_integer_set_interval(X,Low,Up).
1630 is_interval_closure_or_integerset(Set,El,El) :- singleton_set(Set,ELX),
1631 nonvar(ELX), ELX=int(El),!. % new, useful??
1632 is_interval_closure_or_integerset(closure(P,T,B),Low,Up) :-
1633 ? (is_geq_leq_interval_closure(P,T,B,Low,Up) -> true ; is_interval_closure(P,T,B,Low,Up)).
1634
1635 % with an additional argument to know if the set is finite or infinite:
1636 is_interval_closure_or_integerset(Set,Low,Up,Finite) :-
1637 is_interval_closure_or_integerset(Set,Low,Up),
1638 % if we obtain Low, Up as variables then these must be finite numbers; they cannot stand for inf
1639 (infinite_interval(Low,Up) -> Finite=infinite ; Finite=finite).
1640
1641 % a version that also accepts real intervals
1642 :- use_module(kernel_reals,[is_interval_closure_or_realset/3]).
1643 is_interval_closure_or_numberset(Set,Low,Up) :- is_interval_closure_or_integerset(Set,L,U),!, Low=L,Up=U.
1644 is_interval_closure_or_numberset(Set,Low,Up) :- is_interval_closure_or_realset(Set,Low,Up).
1645
1646 get_integer_set_interval('NAT',0,MAXINT) :- (preferences:preference(maxint,MAXINT)->true).
1647 get_integer_set_interval('NAT1',1,MAXINT) :- (preferences:preference(maxint,MAXINT)->true).
1648 get_integer_set_interval('INT',MININT,MAXINT) :-
1649 ((preferences:preference(maxint,MAXINT),preferences:preference(minint,MININT))->true).
1650 get_integer_set_interval('NATURAL',0,inf).
1651 get_integer_set_interval('NATURAL1',1,inf).
1652 get_integer_set_interval('INTEGER',minus_inf,inf).
1653 % TO DO: add minus_inf to kernel_objects !
1654
1655 :- block geq_inf(-,?), geq_inf(?,-).
1656 geq_inf(inf,_) :- !.
1657 geq_inf(minus_inf,B) :- !, B=minus_inf.
1658 geq_inf(_,minus_inf) :- !.
1659 geq_inf(A,inf) :- !, A=inf.
1660 geq_inf(inf_overflow,_) :- !.
1661 geq_inf(A,inf_overflow) :- !, A=inf_overflow.
1662 geq_inf(A,B) :- A >= B.
1663
1664 :- block minimum_with_inf(-,-,?).
1665 % in the first three cases we can determine outcome without knowing both args
1666 minimum_with_inf(A,B,R) :- (A==minus_inf ; B==minus_inf),!,R=minus_inf.
1667 minimum_with_inf(A,B,R) :- A==inf,!,R=B.
1668 minimum_with_inf(A,B,R) :- B==inf,!,R=A.
1669 minimum_with_inf(A,B,R) :- minimum_with_inf1(A,B,R), geq_inf(A,R), geq_inf(B,R).
1670 :- block minimum_with_inf1(-,?,?), minimum_with_inf1(?,-,?).
1671 minimum_with_inf1(minus_inf,_,R) :- !, R=minus_inf.
1672 minimum_with_inf1(_,minus_inf,R) :- !, R=minus_inf.
1673 minimum_with_inf1(inf,B,R) :- !, R=B.
1674 minimum_with_inf1(A,inf,R) :- !, R=A.
1675 minimum_with_inf1(inf_overflow,B,R) :- !, R=B.
1676 minimum_with_inf1(A,inf_overflow,R) :- !, R=A.
1677 minimum_with_inf1(A,B,R) :- (A<B -> R=A ; R=B).
1678
1679 :- block maximum_with_inf(-,-,?).
1680 % in the first three cases we can determine outcome without knowing both args
1681 maximum_with_inf(A,B,R) :- (A==inf ; B==inf),!,R=inf.
1682 maximum_with_inf(A,B,R) :- A==minus_inf,!,R=B.
1683 maximum_with_inf(A,B,R) :- B==minus_inf,!,R=A.
1684 maximum_with_inf(A,B,R) :- maximum_with_inf1(A,B,R), geq_inf(R,A), geq_inf(R,B).
1685 :- block maximum_with_inf1(-,?,?), maximum_with_inf1(?,-,?).
1686 maximum_with_inf1(inf,_,R) :- !, R=inf.
1687 maximum_with_inf1(_,inf,R) :- !, R=inf.
1688 maximum_with_inf1(minus_inf,B,R) :- !, R=B.
1689 maximum_with_inf1(A,minus_inf,R) :- !, R=A.
1690 maximum_with_inf1(inf_overflow,_,R) :- !, R=inf_overflow.
1691 maximum_with_inf1(_,inf_overflow,R) :- !, R=inf_overflow.
1692 maximum_with_inf1(A,B,R) :- (A>B -> R=A ; R=B).
1693
1694 /* utilities for detecting interval closures */
1695 construct_interval_closure(Low,Up,Res) :- (Low==inf;Up==minus_inf),!,Res=[].
1696 construct_interval_closure(Low,Up,Res) :- number(Low),number(Up), Low>Up,!,Res=[].
1697 construct_interval_closure(Low,Up,Res) :- Up==inf,!,
1698 ( Low==0 -> Res = global_set('NATURAL')
1699 ; Low==1 -> Res = global_set('NATURAL1')
1700 ; Low==minus_inf -> Res = global_set('INTEGER')
1701 ; Low==inf -> Res = []
1702 ; construct_greater_equal_closure(Low,Res)
1703 ).
1704 construct_interval_closure(Low,Up,Res) :- Low==minus_inf,!,
1705 construct_less_equal_closure(Up,Res).
1706 construct_interval_closure(Low,Up,Res) :- Low==Up,!,
1707 (number(Low) -> construct_one_element_custom_set(int(Low),Res)
1708 ; Res = [int(Low)]).
1709 construct_interval_closure(Low,Up,Res) :-
1710 construct_interval_set(Low,Up,Set),
1711 construct_member_closure('_zzzz_unary',integer,[],Set,Res).
1712
1713 transform_global_sets_into_closure(closure(P,T,B),closure(P,T,B)).
1714 transform_global_sets_into_closure(global_set(X),Res) :-
1715 transform_global_set_into_closure_aux(X,Res).
1716 transform_global_set_into_closure_aux('NATURAL',Res) :-
1717 construct_greater_equal_closure(0,Res).
1718 transform_global_set_into_closure_aux('NATURAL1',Res) :-
1719 construct_greater_equal_closure(1,Res).
1720 % TO DO: add INTEGER
1721
1722
1723
1724 is_geq_leq_interval_closure([Par],[integer],b(Body,pred,Span),Low,Up) :-
1725 (var(Par)
1726 -> add_internal_error('Non-ground closure: ',closure([Par],[integer],b(Body,pred,Span))),fail
1727 ? ; get_geq_leq_bounds(Body,Par,Low,Up)).
1728
1729 infinite_interval(Low,Up) :- (Low==minus_inf -> true ; Up==inf).
1730
1731 :- assert_must_succeed((card_of_interval_inf(1,10,10))).
1732 :- assert_must_succeed((card_of_interval_inf(1,inf,R),R==inf)).
1733 :- assert_must_succeed((card_of_interval_inf(_,inf,R),R==inf)).
1734 :- assert_must_succeed((card_of_interval_inf(minus_inf,0,R),R==inf)).
1735 :- assert_must_succeed((card_of_interval_inf(minus_inf,_,R),R==inf)).
1736 :- assert_must_succeed((card_of_interval_inf(minus_inf,inf,R),R==inf)).
1737 :- assert_must_succeed((card_of_interval_inf(2,2,R), R==1)).
1738 :- assert_must_succeed((card_of_interval_inf(12,2,R), R==0)).
1739 :- assert_must_succeed((card_of_interval_inf(2,B,10), B==11)).
1740 :- assert_must_succeed((card_of_interval_inf(A,12,10), A==3)).
1741 :- assert_must_succeed((card_of_interval_inf(A,12,0), A=222)).
1742 :- assert_must_succeed((card_of_interval_inf(12,B,0), B=11)).
1743 :- assert_must_fail((card_of_interval_inf(A,12,0), A=12)).
1744 % compute cardinality of interval; allow bounds to be inf and minus_inf (but if so, they must be bound straightaway)
1745 card_of_interval_inf(A,B,Card) :-
1746 ? at_least_two_vars(A,B,Card), % initially this will usually be true, if only one variable we can compute result
1747 preferences:preference(use_clpfd_solver,true),
1748 !,
1749 clpfd_interface:post_constraint(Card #= max(0,1+B-A),custom_explicit_sets:block_card_of_interval_inf(A,B,Card)).
1750 card_of_interval_inf(A,B,Card) :- A==minus_inf,!,
1751 (B==minus_inf -> add_internal_error('Illegal call: ',card_of_interval_inf(A,B,Card)) ; true),
1752 Card=inf.
1753 card_of_interval_inf(A,B,Card) :- B==inf,!,
1754 (A==inf -> add_internal_error('Illegal call: ',card_of_interval_inf(A,B,Card)) ; true),
1755 Card=inf.
1756 card_of_interval_inf(A,B,Card) :- block_card_of_interval_inf(A,B,Card).
1757
1758 ?at_least_two_vars(A,B,C) :- var(A),!,(var(B) -> not_infinite_bound(C) ; number(B),var(C)).
1759 at_least_two_vars(A,B,C) :- number(A), var(B),var(C).
1760 not_infinite_bound(A) :- (var(A) ; number(A)). % inf can only appear immediately, not for variables
1761
1762 :- block block_card_of_interval_inf(-,?,-),block_card_of_interval_inf(?,-,-).
1763 block_card_of_interval_inf(A,_,Card) :- A==minus_inf,!, Card=inf.
1764 block_card_of_interval_inf(_,B,Card) :- B==inf,!, Card=inf.
1765 block_card_of_interval_inf(From,To,Card) :- number(From),number(To),!,
1766 (From>To -> Card=0 ; Card is (To-From)+1).
1767 block_card_of_interval_inf(A,B,C) :- number(C),!, number_card_of_interval_inf_aux(C,A,B).
1768 block_card_of_interval_inf(A,B,C) :- C==inf,!,
1769 % probably this should systematically fail; if A and B are not inf/minus_inf now they will never be
1770 print(infinite_interval_requested(A,B,C)),nl,
1771 when((nonvar(A),nonvar(B)), block_card_of_interval_inf(A,B,C)).
1772 block_card_of_interval_inf(A,B,C) :- add_internal_error('Illegal call: ',card_of_interval_inf(A,B,C)).
1773 :- use_module(inf_arith,[block_inf_greater/2]).
1774 number_card_of_interval_inf_aux(0,A,B) :- !, % empty interval
1775 % if A and B are variables then they will not become inf later ??
1776 % inf can only be set directly for sets such as {x|x>4} or NATURAL1
1777 (((var(A);number(A)),(var(B);number(B)))
1778 % hence we can use ordinary comparison (with CLPFD) here
1779 -> kernel_objects:less_than_direct(B,A)
1780 % TO DO: we could do this even if both A and B are variables !! ex : {n,m|n..m = {} & m..100={} & 103..n={}}
1781 ; block_inf_greater(A,B)).
1782 %number_card_of_interval_inf_aux(Card,From,B) :- number(From),!, B is (From+Card)-1.
1783 %number_card_of_interval_inf_aux(Card,A,To) :- number(To),!, A is 1+To-Card.
1784 number_card_of_interval_inf_aux(Card,A,B) :-
1785 Card>0, C1 is Card-1,
1786 kernel_objects:int_minus(int(B),int(A),int(C1)).
1787
1788
1789 get_geq_leq_bounds(conjunct(b(LEFT,pred,_),b(RIGHT,pred,_)), Par,Low,Up) :-
1790 ? get_geq_leq_bounds(LEFT,Par,From1,To1),
1791 ? get_geq_leq_bounds(RIGHT,Par,From2,To2),
1792 intersect_intervals_with_inf(From1,To1,From2,To2,Low,Up).
1793 get_geq_leq_bounds(member(b(identifier(Par),integer,_),
1794 b(Value,set(integer),_)),Par,Low,Up) :-
1795 get_value_bounds(Value,Low,Up).
1796 ?get_geq_leq_bounds(greater_equal(b(A,_,_),b(B,_,_)),Par,Low,Up) :- get_bounds2(greater_equal,A,B,Par,Low,Up).
1797 ?get_geq_leq_bounds( less_equal(b(A,_,_),b(B,_,_)),Par,Low,Up) :- get_bounds2(less_equal,A,B,Par,Low,Up).
1798 ?get_geq_leq_bounds( greater(b(A,_,_),b(B,_,_)),Par,Low,Up) :- get_bounds2(greater,A,B,Par,Low,Up).
1799 get_geq_leq_bounds( less(b(A,_,_),b(B,_,_)),Par,Low,Up) :- get_bounds2(less,A,B,Par,Low,Up).
1800
1801 get_value_bounds(value(GS),Low,Up) :- is_interval_closure_or_integerset(GS,Low,Up). % recursive call
1802 % nonvar(GS), GS=global_set(ISET), get_integer_set_interval(ISET,Low,Up).
1803 get_value_bounds(interval(b(TLow,_,_),b(TUp,_,_)),Low,Up) :-
1804 integer_value(TLow,Low),
1805 integer_value(TUp,Up).
1806
1807 get_bounds2(greater_equal,identifier(Par),V,Par,X,inf) :- integer_value(V,X).
1808 get_bounds2(greater_equal,V,identifier(Par),Par,minus_inf,X) :- integer_value(V,X).
1809 get_bounds2(less_equal,identifier(Par),V,Par,minus_inf,X) :- integer_value(V,X).
1810 get_bounds2(less_equal,V,identifier(Par),Par,X,inf) :- integer_value(V,X).
1811 get_bounds2(greater,identifier(Par),V,Par,X1,inf) :- integer_value(V,X), kernel_objects:int_plus(int(X),int(1),int(X1)). %, X1 is X+1.
1812 get_bounds2(greater,V,identifier(Par),Par,minus_inf,X1) :- integer_value(V,X), kernel_objects:int_minus(int(X),int(1),int(X1)). %X1 is X-1.
1813 get_bounds2(less,V,identifier(Par),Par,X1,inf) :- integer_value(V,X), kernel_objects:int_plus(int(X),int(1),int(X1)). %X1 is X+1.
1814 get_bounds2(less,identifier(Par),V,Par,minus_inf,X1) :- integer_value(V,X),
1815 kernel_objects:int_minus(int(X),int(1),int(X1)). %X1 is X-1.
1816 % to do: add negation thereof ??
1817
1818 integer_value(V,_) :- var(V),!, print(var_integer_value(V)),nl,fail.
1819 integer_value(integer(X),R) :- !, R=X.
1820 integer_value(unary_minus(b(X,_,_)),R) :- !, integer_value(X,RM),
1821 number(RM), % if RM is not a number we could setup CLPFD constraint ?!
1822 R is -(RM).
1823 integer_value(minus(b(X,_,_),b(Y,_,_)),R) :- !, % some AST compilation rules generate X-1, X+1 ...
1824 integer_value(X,RMX),
1825 integer_value(Y,RMY),
1826 kernel_objects:int_minus(int(RMX),int(RMY),int(R)).
1827 integer_value(plus(b(X,_,_),b(Y,_,_)),R) :- !, % some AST compilation rules generate X-1, X+1 ...
1828 integer_value(X,RMX),
1829 integer_value(Y,RMY),
1830 kernel_objects:int_plus(int(RMX),int(RMY),int(R)).
1831 integer_value(value(V),R) :- V=int(R).
1832
1833 is_interval_closure(closure(Par,[integer],Pred),Low,Up) :-
1834 is_interval_closure_aux(Par,Pred,Low,Up).
1835 is_interval_closure(Par,[integer],Pred,Low,Up) :-
1836 is_interval_closure_aux(Par,Pred,Low,Up).
1837 is_interval_closure_aux(Par,Pred,Low,Up) :-
1838 is_member_closure(Par,[integer],Pred,integer,Set),
1839 is_interval_with_integer_bounds(Set,Low,Up).
1840 %is_interval_closure(closure_x(Par,[integer],Pred,_),Low,Up) :-
1841 % is_interval_closure(closure(Par,[integer],Pred),Low,Up).
1842
1843 is_interval_closure_body(Body,ID,Low,Up) :-
1844 is_member_closure([ID],[integer],Body,integer,Set),!,
1845 is_interval_with_integer_bounds(Set,Low,Up).
1846 is_interval_closure_body(Body,ID,Low,Up) :-
1847 ? is_geq_leq_interval_closure([ID],[integer],Body,Low,Up),
1848 number(Low), number(Up).
1849
1850 :- use_module(bsyntaxtree,[get_texpr_info/2,get_texpr_id/2]).
1851 % do a single check if we have interval, member or not-member closure, avoiding redundant checking
1852 % TO DO: move this and related predicates to closures module ?
1853 is_special_closure(_Ids,_Types,Pred,Result) :-
1854 get_texpr_info(Pred,Info),memberchk(prob_annotation(recursive(RId)),Info),!,
1855 Result = recursive_special_closure(RId).
1856 is_special_closure(Ids,Types,Pred,Result) :-
1857 ? is_memoization_closure(Ids,Types,Pred,MemoID),!,
1858 Result = memoization_closure(MemoID).
1859 is_special_closure([ID],[TYPE],b(PRED,_,_), Result) :-
1860 ( closures:is_member_closure_aux(PRED, [ID],[TYPE],_,SET) ->
1861 ( (TYPE=integer, is_interval_with_integer_bounds(SET,Low,Up)) ->
1862 Result = interval(Low,Up)
1863 ; Result = member_closure(ID,TYPE,SET))
1864 ; closures:is_not_member_closure_aux(PRED,ID,TYPE,SET) ->
1865 Result = not_member_closure(ID,TYPE,SET)
1866 ? ; (TYPE=integer,get_geq_leq_bounds(PRED,ID,Low,Up),number(Low), number(Up)) ->
1867 Result = interval(Low,Up)
1868 ).
1869
1870
1871 construct_interval_set(Low,Up,Res) :-
1872 Res = interval(b(value(int(Low)),integer,[]),
1873 b(value(int(Up)), integer,[])).
1874 is_interval_with_integer_bounds(X,L,U) :- var(X),!,
1875 add_internal_error('var arg: ',is_interval_with_integer_bounds(X,L,U)),fail.
1876 is_interval_with_integer_bounds(interval(b(TLOW,integer,_),b(TUP, integer,_)),Low,Up) :-
1877 integer_value(TLOW,Low), integer_value(TUP,Up).
1878
1879
1880 is_a_relation(relations(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '<->'
1881 Code = (kernel_card_arithmetic:safe_mul(DCard,RCard,Exp), kernel_card_arithmetic:safe_pow2(Exp,Card)).
1882 is_a_relation(partial_function(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '+->'
1883 Code = (kernel_card_arithmetic:safe_add_card(RCard,1,R1),kernel_card_arithmetic:safe_pown(R1,DCard,Card)).
1884 is_a_relation(total_function(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '-->'
1885 Code = (kernel_card_arithmetic:safe_pown(RCard,DCard,Card)).
1886 is_a_relation(partial_bijection(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '>+>>'
1887 Code = (kernel_card_arithmetic:partial_bijection_card(DCard,RCard,Card)).
1888 is_a_relation(total_bijection(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '>->>'
1889 Code = (kernel_card_arithmetic:total_bijection_card(DCard,RCard,Card)).
1890 is_a_relation(total_injection(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '>->'
1891 Code = (kernel_card_arithmetic:blocking_factorial_k(RCard,DCard,Card)).
1892 is_a_relation(partial_injection(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '>+>'
1893 Code = (kernel_card_arithmetic:partial_injection_card(DCard,RCard,Card)).
1894 is_a_relation(total_surjection(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '-->>'
1895 Code = (kernel_card_arithmetic:total_surjection_card(DCard,RCard,Card)).
1896 is_a_relation(partial_surjection(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '+->>'
1897 Code = (kernel_card_arithmetic:partial_surjection_card(DCard,RCard,Card)).
1898 is_a_relation(total_relation(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '<<->'
1899 Code = (kernel_card_arithmetic:total_relation_card(DCard,RCard,Card)).
1900 is_a_relation(surjection_relation(Domain,Range),Domain,Range,DCard,RCard,Card,Code) :- %% '<->>'
1901 % just swap args: card(A<->>B) = card(B<<->A)
1902 Code = (kernel_card_arithmetic:total_relation_card(RCard,DCard,Card)).
1903 % TO DO: total_surjection_relation <<->>
1904
1905
1906
1907 :- use_module(b_global_sets,[infinite_global_set/1]).
1908
1909 :- block is_infinite_global_set(-,?).
1910 is_infinite_global_set('NATURAL',integer).
1911 is_infinite_global_set('NATURAL1',integer).
1912 is_infinite_global_set('INTEGER',integer).
1913 is_infinite_global_set('FLOAT',real).
1914 is_infinite_global_set('REAL',real).
1915 is_infinite_global_set('STRING',string).
1916 is_infinite_global_set(G,global(G)) :- infinite_global_set(G).
1917
1918 %is_finite_integer_global_set('NAT').
1919 %is_finite_integer_global_set('NAT1').
1920 %is_finite_integer_global_set('INT').
1921
1922 % detects (certain) infinite explict sets
1923 is_infinite_explicit_set(X) :- var(X),!, add_internal_error(is_infinite_explicit_set,var(X)),fail.
1924 ?is_infinite_explicit_set(global_set(X)) :- is_infinite_global_set(X,_).
1925 is_infinite_explicit_set(freetype(X)) :- is_infinite_freetype(X).
1926 is_infinite_explicit_set(closure(Par,T,Body)) :- is_infinite_closure(Par,T,Body).
1927
1928 % this detects infinite and symbolic closures:
1929 is_infinite_or_symbolic_set(X) :- var(X),!, add_internal_error(is_infinite_or_symbolic_set,var(X)),fail.
1930 is_infinite_or_symbolic_set(global_set(X)) :- is_infinite_global_set(X,_).
1931 is_infinite_or_symbolic_set(freetype(X)) :- is_infinite_freetype(X).
1932 is_infinite_or_symbolic_set(closure(Par,T,Body)) :- is_infinite_or_symbolic_closure(Par,T,Body).
1933
1934
1935 % detect some closure that we should definitely expand; even in SYMBOLIC mode or for ABSTRACT_CONSTANTS
1936 definitely_expand_this_explicit_set(Var) :- var(Var),!,fail.
1937 definitely_expand_this_explicit_set(closure(P,T,B)) :-
1938 (B = b(Body,_,_), definitely_expand(Body,P) -> true
1939 ; is_interval_closure(P,T,B,Low,Up), do_expand_interval(Low,Up)).
1940 % some lambda functions have small domain, but are very complicated to compute (test 1078, 1376)
1941 % hence the following is not sufficient:
1942 % ;is_small_specific_custom_set(closure(P,T,B),100), print(exp(T)),nl,translate:print_bexpr(B),nl,fail).
1943
1944 :- use_module(bsyntaxtree,[occurs_in_expr/2]).
1945 definitely_expand(Body,_) :- avl_mem_construct(Body,_).
1946 definitely_expand(exists(ExistsTIDs,Body),P) :- P = [ID],
1947 % detect AVL projection expressions like {res|#y.(y:AVL & res=Expr(y))} % test 1101
1948 Body = b(conjunct(b(Mem,pred,_),Eq),pred,_),
1949 Eq = b(equal(EqA,EqB),pred,_),
1950 avl_mem_construct(Mem,LHS),
1951 tlhs_uses_exists(LHS,ExistsTIDs,[]),
1952 ( get_texpr_id(EqA,ID) -> \+ occurs_in_expr(ID,EqB)
1953 ; get_texpr_id(EqB,ID) -> \+ occurs_in_expr(ID,EqA) ). % we assign to set compr. ID
1954 % example where ID occurs in other expression: {v|#w.(w : (1 .. 10) & v = (v + w) - 2)}; test 2516
1955
1956 tlhs_uses_exists(b(E,_,_)) --> lhs_uses_exists(E).
1957 ?lhs_uses_exists(identifier(EID),In,Out) :-!, select(TEID,In,Out),
1958 get_texpr_id(TEID,EID),!. % TODO: we could allow using an identifier twice
1959 lhs_uses_exists(value(V)) --> {nonvar(V), simple_value(V), ground_value(V)}.
1960 lhs_uses_exists(couple(A,B)) --> tlhs_uses_exists(A), tlhs_uses_exists(B).
1961 lhs_uses_exists(boolean_true) --> [].
1962 lhs_uses_exists(boolean_false) --> [].
1963 lhs_uses_exists(empty_set) --> [].
1964 lhs_uses_exists(empty_sequence) --> [].
1965 lhs_uses_exists(integer(_)) --> [].
1966 lhs_uses_exists(real(_)) --> [].
1967 lhs_uses_exists(string(_)) --> [].
1968
1969 avl_mem_construct(member(LHS,RHS),LHS) :- RHS = b(value(V),_,_), nonvar(V),
1970 (V=avl_set(_) -> true
1971 ; is_interval_closure_or_integerset(V,L,U), integer(L), integer(U), U-L < 1000
1972 ).
1973
1974 % dont_expand_this_explicit_set with default limit (20000)
1975 dont_expand_this_explicit_set(closure(P,T,B)) :- !,
1976 dont_expand_this_closure(P,T,B).
1977 dont_expand_this_explicit_set(S) :-
1978 is_infinite_or_very_large_explicit_set(S).
1979
1980 % dont_expand_this_explicit_set with extra limit argument:
1981 dont_expand_this_explicit_set(closure(P,T,B),Limit) :- !, dont_expand_this_closure(P,T,B,Limit).
1982 dont_expand_this_explicit_set(S,_) :- is_infinite_or_very_large_explicit_set(S).
1983
1984 % true if we have a closure / global_set that should not be expanded
1985 % TO DO: we could detect finite (is_lambda_value_domain_closure) closures which contain infinite elements such as %p.(p : BOOL|%t.(t : NATURAL|t .. t + 7))
1986 dont_expand_symbolic_explicit_set(closure(P,T,B)) :- !,
1987 dont_expand_this_closure(P,T,B).
1988 dont_expand_symbolic_explicit_set(avl_set(_)) :- !,
1989 fail. % already expanded
1990 dont_expand_symbolic_explicit_set(S) :-
1991 is_infinite_or_very_large_explicit_set(S).
1992
1993
1994 dont_expand_this_closure(P,T,B) :-
1995 get_preference(comprehension_set_symbolic_limit,Limit), % Default 20000
1996 dont_expand_this_closure(P,T,B,Limit). % % increase limit in Data valid mode?
1997
1998 dont_expand_this_closure(_P,_T,b(_,_,INFO),_Limit) :-
1999 ? member(prob_annotation(KIND),INFO),
2000 (KIND = 'SYMBOLIC' -> ! % cf is_symbolic_closure in closures
2001 ; KIND = 'FORCE' -> !, fail). % was wrapped in FORCE external_function
2002 dont_expand_this_closure(P,T,B,_Limit) :-
2003 is_interval_closure_or_numberset(closure(P,T,B),Low,Up), !,
2004 % interval closures are quite efficient for certain manipulations
2005 (integer(Low), integer(Up)
2006 -> dont_expand_interval(Low,Up)
2007 % ; float(Low), float(Up) -> Low < Up % probably very many values between; requires new 4.10 solver to detect emptyness TODO
2008 ; true % we have a closure with inf/minus_inf or variables as bounds or floats; in all cases keep the closure
2009 ).
2010 dont_expand_this_closure(P,T,B,Limit) :-
2011 is_infinite_or_very_large_closure(P,T,B,Limit).
2012 %% TODO: also prevent expansion of things like ff = %x.(x:STRING & REGEX_MATCH(x,"[a-z]+")=TRUE|TRUE)
2013
2014 % do not automatically expand these integer intervals
2015 dont_expand_interval(Low,Up) :-
2016 Up+1-Low > 100. % another magic constant ; which value to choose ??
2017 % do expand these integer intervals:
2018 do_expand_interval(Low,Up) :- Up+1-Low =< 100.
2019
2020 is_converted_lambda_closure(_P,_T,b(_,_,INFO)) :-
2021 ? member(prob_annotation('LAMBDA'),INFO).
2022
2023 is_symbolic_closure_or_symbolic_mode(P,T,B) :-
2024 ? (is_symbolic_closure(P,T,B) -> true
2025 ; preference(convert_comprehension_sets_into_closures,true)
2026 % by default suppose closures should be dealt with symbolically
2027 ).
2028 /*
2029 % check both LAMBDA + not RECURSIVE
2030 is_converted_non_recursive_lambda_closure(_,_,b(_,_,INFO)) :- is_conv_lambda_nonrec(INFO).
2031 is_conv_lambda_nonrec([prob_annotation(A)|T]) :- !,
2032 (A='LAMBDA' -> \+ memberchk(prob_annotation('RECURSIVE'),T)
2033 ; A\='RECURSIVE' -> is_conv_lambda_nonrec(T)).
2034 is_conv_lambda_nonrec([_|T]) :- is_conv_lambda_nonrec(T). */
2035
2036
2037
2038 % a set that is so large that expanding it would probably cause problems
2039 is_infinite_or_very_large_explicit_set(S) :-
2040 get_preference(comprehension_set_symbolic_limit,Limit), % Default 20000
2041 is_infinite_or_very_large_explicit_set(S,Limit). % increase limit in Data valid mode?
2042
2043 :- use_module(inf_arith,[infgreater/2]).
2044
2045 is_infinite_or_very_large_explicit_set(X,_) :- var(X),!,print(var_is_infinite_check(X)),nl,fail.
2046 is_infinite_or_very_large_explicit_set(closure(P,T,B),Limit) :- !,
2047 % treat closure separately here; some special rules
2048 is_infinite_or_very_large_closure(P,T,B,Limit).
2049 is_infinite_or_very_large_explicit_set(avl_set(A),Limit) :- !, % we could compute log and use avl_height_less_than
2050 quick_avl_approximate_size(A,Size), Size >= Limit.
2051 is_infinite_or_very_large_explicit_set(X,Limit) :- % closures are checked above
2052 explicit_set_cardinality(X,Card),
2053 nonvar(Card),infgreater(Card,Limit).
2054
2055
2056 is_very_large_or_symbolic_closure(P,T,B,Limit) :-
2057 ? (is_symbolic_closure(P,T,B) -> true ; is_infinite_or_very_large_closure(P,T,B,Limit)).
2058 :- use_module(bsyntaxtree,[is_a_disjunct/3]).
2059 is_infinite_or_very_large_closure(P,T,B,Limit) :-
2060 is_a_disjunct(B,D1,D2), % Assumption: there is no card_for_specific_closure code for disjuncts
2061 !,
2062 (is_infinite_or_very_large_closure(P,T,D1,Limit) -> true
2063 ; is_infinite_or_very_large_closure(P,T,D2,Limit)).
2064 is_infinite_or_very_large_closure(Par,T,Body,Limit) :-
2065 is_closure1_value_closure(Par,T,Body,VAL),!,
2066 nonvar(VAL), % it could still be large or infinite
2067 (Limit>1 -> NLimit is Limit/2 ; NLimit = Limit), % reduce limit as closure1 usually blows up
2068 is_infinite_or_very_large_explicit_set(VAL,NLimit).
2069 is_infinite_or_very_large_closure(P,T,B,Limit) :-
2070 card_for_specific_closure3(Kind,P,T,B,Card,Code),
2071 ? on_enumeration_warning(call(Code),
2072 (debug_println(9,cannot_expand_specific_closure_for_card(Kind,Limit)),
2073 % see test 1519 for relevance
2074 Card=inf)), % assume it is large
2075 !,
2076 nonvar(Card),infgreater(Card,Limit),
2077 perfmessages_bexpr(symbolic_closure,['Keeping comprehension set symbolic, cardinality ',Card,' greater than limit ',Limit,' for '],B).
2078
2079 is_infinite_or_symbolic_closure(P,T,B) :-
2080 ? (is_symbolic_closure(P,T,B) -> true ; is_infinite_closure(P,T,B)).
2081 is_infinite_closure(P,T,B) :-
2082 is_a_disjunct(B,D1,D2), % Assumption: there is no card_for_specific_closure code for disjuncts
2083 !,
2084 (is_infinite_closure(P,T,D1) -> true ; is_infinite_closure(P,T,D2)).
2085
2086 is_infinite_closure(Par,Types,Body) :-
2087 is_member_closure(Par,Types,Body,Type,MemSET), !,
2088 nonvar(MemSET),
2089 is_infinite_member_closure_body(MemSET,Type).
2090 is_infinite_closure(Par,T,Body) :-
2091 card_for_specific_closure(closure(Par,T,Body),Card,Code),
2092 ? call(Code), % TO DO: catch enumeration exceptions (see is_infinite_or_very_large_closure above)
2093 Card == inf. % TODO: instantiate inf before to avoid computing huge numbers
2094
2095 is_infinite_member_closure_body(closure(b(VALExpr,_,_)),couple(A,A)) :-
2096 is_infinite_member_closure_body(VALExpr,couple(A,A)).
2097 % if VALExpr is a var value: it could still be infinite !! TO DO fix
2098 % % TO DO: also check closure1 is infinite
2099 is_infinite_member_closure_body(value(VAL),_) :- nonvar(VAL),
2100 is_infinite_explicit_set(VAL).
2101 is_infinite_member_closure_body(comprehension_set(Par,Body),_) :-
2102 split_names_and_types(Par,P,T),
2103 is_infinite_closure(P,T,Body).
2104 % TODO: call unary_member_closure_for_finite(SET,Check,SET1), with Check=finite
2105 is_infinite_member_closure_body(Body,TYPE) :-
2106 card_for_member_closure(Body,TYPE,Card,Code),
2107 call(Code), % TO DO: catch enumeration exceptions (see is_infinite_or_very_large_closure above)
2108 Card == inf. % TODO: instantiate inf before to avoid computing huge numbers
2109
2110
2111 :- use_module(memoization,[compute_memo_hash/2, get_stored_memo_expansion/3, store_memo_expansion/3]).
2112 /* transitive closure */
2113 closure1_for_explicit_set(avl_set(A),Res) :-
2114 preferences:preference(use_closure_expansion_memoization,true),!,
2115 compute_memo_hash(closure1_for_explicit_set(A),Hash),
2116 (get_stored_memo_expansion(Hash,closure1_for_explicit_set(A),StoredResult)
2117 -> Res = StoredResult
2118 ; closure1_for_explicit_set_direct(avl_set(A),Result),
2119 store_memo_expansion(Hash,closure1_for_explicit_set(A),Result),
2120 Res = Result
2121 ).
2122 closure1_for_explicit_set(avl_set(A),Res) :- closure1_for_explicit_set_direct(avl_set(A),Res).
2123
2124 % sometimes faster, but can also be considerably slower:
2125 %:- use_module(extrasrc(avl_ugraphs),[avl_transitive_closure/2]).
2126 %closure1_for_explicit_set_direct(avl_set(A),Res) :-
2127 % avl_transitive_closure(A,TC),
2128 % construct_avl_set(TC,Res).
2129 closure1_for_explicit_set_direct(avl_set(A),Res) :-
2130 perfmessage_bexpr(closure1,'Computing transitive closure1 of: ',b(value(avl_set(A)),any,[])),
2131 avl_domain(A,AList),
2132 iterate_closure(AList,A,A,IterationRes),
2133 construct_avl_set(IterationRes,Res).
2134
2135 /* transitive closure starting from some initial set */
2136 /* not sure if we should do this:
2137 closure1_for_explicit_set_from(avl_set(A),StartFrom,Res) :-
2138 preferences:preference(use_closure_expansion_memoization,true),
2139 compute_memo_hash(closure1_for_explicit_set(A),Hash),
2140 stored_expansion(Hash,closure1_for_explicit_set(A),StoredResult),!,
2141 domain_restriction_explicit_set(StartFrom,StoredResult,Res). */
2142 % StartFrom can be avl_set(empty)
2143 closure1_for_explicit_set_from(avl_set(A),StartFrom,Res) :-
2144 avl_domain(A,AList),
2145 filter_start_relation(AList,StartFrom,FAList),
2146 (FAList = [] -> Res=[]
2147 ; convert_to_avl(FAList,avl_set(Start)),
2148 iterate_closure(FAList,A,Start,IterationRes),
2149 construct_avl_set(IterationRes,Res)).
2150 filter_start_relation([],_,[]).
2151 filter_start_relation([(X,Y)|T],StartSet,Res) :-
2152 ? (element_of_custom_set(X,StartSet) -> Res = [(X,Y)|RT] ; Res=RT),
2153 filter_start_relation(T,StartSet,RT).
2154
2155 iterate_closure([],_,Res,Res).
2156 iterate_closure([(X,Y)|T],InitialRelation,Relation,Res) :-
2157 %(Key = (X,Y) -> true ; add_error_and_fail(iterate_closure,'Not a relation element: ',Key)),
2158 add_tuples(X,Y,InitialRelation,Relation,NewRelation,AddedTuples),
2159 % better: do added tuples straight away ?
2160 iterate_closure(T,InitialRelation,NewRelation,NewRelation2),
2161 iterate_closure(AddedTuples,InitialRelation,NewRelation2,Res).
2162
2163 add_tuples(X,Y,AVL,AVLClosureSoFar,Res,NewTuples) :-
2164 findall((X,Z), (avl_fetch_pair(Y,AVL,Z), %ok instead of safe_avl_member((Y,Z),AVL),; Y in AVL form, Z var
2165 %Y \= Z, % self-loops are already in initial AVLClosure, this will never add a new pair
2166 % if we use AVLClosureSoFar instead of AVL: considerably slower
2167 \+ avl_fetch((X,Z),AVLClosureSoFar)), NewTuples),
2168 add_to_avl(NewTuples,AVLClosureSoFar,Res).
2169
2170 :- use_module(bsyntaxtree,[create_negation/2]).
2171 % SUBSET_OF <:
2172 % subset_of_explicit_set: returns code to be executed if this subset check can be done in an optimized way
2173 % TO DO: add strict_subset <<: + more cases, e.g., interval & avl_set, ...
2174 % interval & interval already handled in check_subset_of_global_sets
2175 subset_of_explicit_set(AVL,Closure,Code,_WF) :- nonvar(AVL),AVL=avl_set(A),
2176 is_interval_closure_or_integerset(Closure,Low,Up),!,
2177 Code=custom_explicit_sets:check_avl_in_interval(A,Low,Up).
2178 subset_of_explicit_set(Closure,CS,Code,WF) :- nonvar(CS), is_custom_explicit_set(CS),
2179 is_interval_closure_or_integerset(Closure,Low,Up),!,
2180 Code=custom_explicit_sets:check_interval_in_custom_set(Low,Up,CS,WF).
2181 subset_of_explicit_set(AVL1,AVL2,Code,_WF) :-
2182 nonvar(AVL1),AVL1=avl_set(A1), nonvar(AVL2),AVL2=avl_set(A2),!,
2183 Code = custom_explicit_sets:check_avl_subset(A1,A2).
2184 subset_of_explicit_set(C1,AVL2,Code,_WF) :- nonvar(C1),
2185 simple_finite_set(AVL2),
2186 is_simple_infinite_set(C1),!, % infinite set cannot be subset of finite one
2187 Code = fail.
2188 subset_of_explicit_set(C1,C2,Code,WF) :- nonvar(C1),
2189 is_cartesian_product_closure(C1,S11,S12),!,
2190 ((S11==[] ; S12==[]) -> Code=true /* we always have a subset */
2191 ; is_definitely_not_empty(S11),
2192 is_definitely_not_empty(S12), % only use optimisation if we know S11, S12 to be non-empty
2193 nonvar(C2), is_cartesian_product_closure(C2,S21,S22),
2194 Code = (kernel_objects:check_subset_of_wf(S11,S21,WF),
2195 kernel_objects:check_subset_of_wf(S12,S22,WF) )
2196 ).
2197 subset_of_explicit_set(Set1,Set2,Code,WF) :-
2198 nonvar(Set2),is_cartesian_product_closure(Set2,S21,S22),!,
2199 % TO DO: maybe don't do this if Set1 is avl_set ??
2200 debug_println(9,'Applying C <: S21*S22 <=> C : S21 <-> S22'),
2201 Code = bsets_clp:relation_over_wf(Set1,S21,S22,WF).
2202 subset_of_explicit_set(C1,C2,Code,WF) :- nonvar(C1), nonvar(C2),
2203 is_powerset_closure(C1,Constructor1,Set1),
2204 is_powerset_closure(C2,Constructor2,Set2),
2205 subset_constructor(Constructor1,Constructor2,R),
2206 !,
2207 Code = (R=pred_true, kernel_objects:check_subset_of_wf(Set1,Set2,WF)).
2208 subset_of_explicit_set(Set1,Set2,Code,WF) :-
2209 AllowRegularClosure=false,
2210 symbolic_subset_of_explicit_set(Set1,Set2,AllowRegularClosure,Code,WF).
2211
2212 symbolic_subset_of_explicit_set(Set1,Set2,AllowRegularClosure,Code,WF) :-
2213 %print_term_summary(subset(Set1,Set2)),nl,
2214 get_subset_counter_example_closure(Set1,Set2,NewP,NewT,NewB,AllowRegularClosure,DefResult),
2215 % {x|P1} <: {x|P2} <=> {x|P1 & not(P2)}={}
2216 !, %translate:print_bexpr(NewB),nl,
2217 (DefResult==definitely_non_empty -> Code = fail
2218 ; clean_up(NewB,[],CNewB), % can be useful to apply remove_member_comprehension
2219 Code = custom_explicit_sets:is_empty_closure_wf(NewP,NewT,CNewB,WF)).
2220
2221 % get closure representing the counter examples to Set1 <: Set2: i.e. elements in Set1 and not in Set2
2222 % used for symbolic treatment of subset, not_subset and test_subset
2223 % note: in case this fails subset_test1 will expand Set1
2224 % DefiniteResultFlag may return the information that the generated closure is definitely not empty
2225 % AllowRegularClosure=false means it will only be applied for symbolic or infinite closures
2226 get_subset_counter_example_closure(Set1,Set2,NewP,NewT,NewB,AllowRegularClosure,DefiniteResultFlag) :-
2227 get_closure(Set1,P1,T1,B1),
2228 get_subset_counter_aux(P1,T1,B1,Set2,NewP,NewT,NewB,AllowRegularClosure,DefiniteResultFlag).
2229
2230 get_subset_counter_aux(P1,T1,B1,Set2,NewP,NewT,NewB,AllowRegularClosure,DefRes) :-
2231 nonvar(Set2), is_definitely_finite(Set2), !,
2232 create_couple_term(P1,T1,P1Couple), % can currently still fail for more than 2 args
2233 (is_infinite_closure(P1,T1,B1)
2234 -> DefRes=definitely_non_empty % there are definitely counter examples as Set2 is finite
2235 ; AllowRegularClosure=true -> DefRes = unknown
2236 ? ; is_symbolic_closure(P1,T1,B1) -> DefRes=unknown
2237 ),
2238 NewP=P1, NewT=T1,
2239 % {x|P1} <: {a1,...} <=> {x|P1 & x /: {a1,...}}={}
2240 get_texpr_type(P1Couple,CoupleType1),
2241 VSet2 = b(value(Set2),set(CoupleType1),[]),
2242 create_texpr(not_member(P1Couple,VSet2),pred,[],NegPred2),
2243 conjunct_predicates([B1,NegPred2],NewB).
2244 get_subset_counter_aux(P1,T1,B1,Set2,NewP,NewT,NewB,AllowRegularClosure,unknown) :-
2245 get_closure(Set2,P2,T2,B2),
2246 (AllowRegularClosure=true -> true
2247 ; is_infinite_or_symbolic_closure(P1,T1,B1) -> true
2248 % should we also allow ??
2249 % ; is_symbolic_closure(P2,T2,B2)
2250 ),
2251 % not necessary maybe as subset_test1 only expands Set1
2252 % {x|P1} <: {x|P2} <=> {x|P1 & not(P2)}={}
2253 unify_closure_predicates(P1,T1,B1, P2,T2,B2 , NewP,NewT, NewB1,NewB2),
2254 create_negation(NewB2,NegNewB2),
2255 bsyntaxtree:conjunct_predicates([NewB1,NegNewB2],NewB).
2256
2257
2258 % get_closure or infinite global set:
2259 get_closure(V,_,_,_) :- var(V),!,fail.
2260 get_closure(closure(P,T,B),P,T,B).
2261 ?get_closure(global_set(G),P,T,B) :- is_infinite_global_set(G,Type),!,
2262 ID = '_zzzz_unary',
2263 TID = b(identifier(ID),Type,[]),
2264 TSet = b(value(global_set(G)),set(Type),[]),
2265 P = [ID], T=[Type], B= b(member(TID,TSet),pred,[prob_annotation('SYMBOLIC')]).
2266
2267
2268 subset_constructor(X,X,R) :- !,R=pred_true.
2269 subset_constructor(fin1,_,R) :- !,R=pred_true.
2270 subset_constructor(fin,pow,R) :- !,R=pred_true.
2271 subset_constructor(X,Y,R) :- strict_subset_constructor(X,Y),!,R=pred_true.
2272 subset_constructor(X,Y,R) :- strict_subset_constructor(Y,X),!,R=pred_false.
2273 % pow1,fin1 ; pow,fin ; and pow1,fin only ok if type infinite
2274 strict_subset_constructor(pow1,pow).
2275 strict_subset_constructor(fin1,fin).
2276
2277 % more rules for <->, +->, ...
2278 % what if same closure: then we also know it is a subset
2279
2280 % to be completed:
2281 % code that instantiates R to subset or not_subset, may have to delay
2282 test_subset_of_explicit_set(Set1,_,_,_,_) :- var(Set1),!,fail.
2283 test_subset_of_explicit_set(avl_set(A),Closure,R,WF,Code) :-
2284 is_interval_closure_or_integerset(Closure,Low,Up),!,
2285 Code=custom_explicit_sets:test_avl_in_interval(A,Low,Up,R,WF).
2286 test_subset_of_explicit_set(_,Set2,_,_,_) :- var(Set2),!,fail.
2287 test_subset_of_explicit_set(avl_set(A1),avl_set(A2),R,_WF,Code) :-
2288 Code = (custom_explicit_sets:check_avl_subset(A1,A2) -> R=pred_true ; R=pred_false).
2289 test_subset_of_explicit_set(global_set(G),Set2,R,_WF,Code) :-
2290 ? is_infinite_global_set(G,_), % TODO: we could extend this to other infinite sets
2291 is_definitely_finite(Set2), !,
2292 Code =(R=pred_false).
2293 test_subset_of_explicit_set(Set1,Set2,Res,WF,Code) :-
2294 AllowRegular=false,
2295 get_subset_counter_example_closure(Set1,Set2,NewP,NewT,NewB,AllowRegular,DefResult),
2296 % {x|P1} <: {x|P2} <=> {x|P1 & not(P2)}={}
2297 !,
2298 (DefResult==definitely_non_empty -> Code = (Res=pred_false)
2299 ; Code = custom_explicit_sets:test_empty_closure_wf(NewP,NewT,NewB,Res,WF)
2300 ).
2301 % TO DO: add is_cartesian_product_closure case
2302 is_definitely_finite([]).
2303 is_definitely_finite(avl_set(_)).
2304
2305 :- use_module(kernel_equality,[test_interval_subset_wf/6]).
2306
2307 :- public test_avl_in_interval/5. % used in test_subset_of_explicit_set
2308 % see also check_avl_in_interval(A,Low,Up), check_avl_not_in_interval(A,Low,Up).
2309 test_avl_in_interval(A,Low2,Up2,Res,WF) :-
2310 avl_min(A,int(Min)), % not needed if Low2==minus_inf
2311 avl_max(A,int(Max)), % not needed if Up2==inf
2312 test_interval_subset_wf(Min,Max,Low2,Up2,Res,WF).
2313
2314 % ----------------------
2315
2316 is_definitely_not_empty(X) :- nonvar(X),
2317 (X=[_|_] -> true
2318 ; is_custom_explicit_set(X), is_non_empty_explicit_set(X)).
2319
2320 % check if defnitely not empty and provide a witness
2321 is_definitely_not_empty_with_witness(X,El) :- nonvar(X),
2322 get_witness_element(X,El).
2323 get_witness_element([H|_],H).
2324 get_witness_element(avl_set(node(H,_True,_,_,_)),H).
2325 % TO DO: add global_set(GS),...
2326
2327 check_avl_subset(A1,A2) :- avl_max(A1,Max1), avl_max(A2,Max2),
2328 Max1@>Max2,!, % then A1 cannot be subset of A2
2329 fail.
2330 check_avl_subset(A1,A2) :-
2331 avl_min(A1,Cur1), avl_min(A2,Cur2),
2332 check_avl_subset_loop(Cur1,A1,Cur2,A2).
2333 check_avl_subset_loop(Cur1,AVL1,Cur2,AVL2) :-
2334 (Cur1 @> Cur2 -> avl_next(Cur2,AVL2,NC2), check_avl_subset_loop(Cur1,AVL1,NC2,AVL2)
2335 ; Cur1=Cur2 -> (avl_next(Cur1,AVL1,NC1)
2336 -> avl_next(Cur2,AVL2,NC2),
2337 check_avl_subset_loop(NC1,AVL1,NC2,AVL2)
2338 ; true /* all objects of AVL1 inspected */)
2339 ).
2340
2341 % check A <: Low..Up
2342 check_avl_in_interval(A,Low,Up) :- % does not have to delay: if we have minus_inf & inf they will be known straightaway
2343 (Low==minus_inf -> true
2344 ; avl_min(A,Min), kernel_objects:less_than_equal(int(Low),Min)),
2345 (Up==inf -> true
2346 ; avl_max(A,Max), kernel_objects:less_than_equal(Max,int(Up))).
2347
2348 % some experiments:
2349 % 1..x <: {1,2,3,5} & x>1 & !y.(y>x & y<10 => 1..y /<: {1,2,3,5})
2350 % {ss | ss <: 0..0 & ss /= {} & ss=0..max(ss)}
2351 % {ss | ss <: 0..0 & ss /= {} & ss=min(ss)..max(ss)} // does not work yet
2352 % x..x+1 <: {0,2,3,5}
2353 % x..x+2 <: {0,2,3,5} // does not work yet
2354 % r = {x|x:1..400 & x mod 3/=0} & res={v|v:0..1300 & v..v+1 <: r}
2355 % check Low..Up <: Avl
2356
2357 check_interval_in_custom_set(Low,Up,CS,WF) :-
2358 Low \== minus_inf,
2359 Up \== inf,
2360 b_interpreter_check:check_arithmetic_operator('<=',Low,Up,LeqRes),
2361 (var(LeqRes) -> get_binary_choice_wait_flag_exp_backoff(16,check_interval_in_custom_set,WF,WF2) ; true),
2362 ? check_interval_in_custom_set_aux(LeqRes,Low,Up,CS,WF2).
2363
2364 :- block check_interval_in_custom_set_aux(-,?,?,?,-).
2365 check_interval_in_custom_set_aux(pred_true,Low,Up,CS,_WF2) :-
2366 ? element_of_custom_set_wf(int(Low),CS,WF),
2367 ? element_of_custom_set_wf(int(Up),CS,WF),
2368 ? interval_in_avl_block(Low,Up,CS,WF).
2369 check_interval_in_custom_set_aux(pred_false,_Low,_Up,_CS,_WF2). % Interval is empty; but infinitely many solutions for Low and Up exist in principle
2370
2371 :- block interval_in_avl_block(-,?,?,?), interval_in_avl_block(?,-,?,?).
2372 interval_in_avl_block(Low,Up,CS,WF) :-
2373 ? Low1 is Low+1, interval_in_avl_loop(Low1,Up,CS,WF).
2374 interval_in_avl_loop(Low,Up,_CS,_WF) :- Low>=Up,!. % Lower bound and upper bound already checked
2375 interval_in_avl_loop(Low,Up,CS,WF) :-
2376 ? element_of_custom_set_wf(int(Low),CS,WF), L1 is Low+1,
2377 ? interval_in_avl_loop(L1,Up,CS,WF).
2378
2379
2380 :- public not_check_avl_subset/2. % used in not_subset_of_explicit_set_aux
2381 not_check_avl_subset(A1,A2) :- \+ check_avl_subset(A1,A2).
2382
2383 not_subset_of_explicit_set(S1,S2,Code,WF) :- nonvar(S1),
2384 ? not_subset_of_explicit_set_aux(S1,S2,Code,WF).
2385 not_subset_of_explicit_set_aux(avl_set(A),Closure,Code,_WF) :-
2386 is_interval_closure_or_integerset(Closure,Low,Up),!,
2387 Code=custom_explicit_sets:check_avl_not_in_interval(A,Low,Up).
2388 not_subset_of_explicit_set_aux(avl_set(A1),AVL2,Code,_WF) :-
2389 nonvar(AVL2),AVL2=avl_set(A2),
2390 Code = custom_explicit_sets:not_check_avl_subset(A1,A2).
2391 not_subset_of_explicit_set_aux(CS,AVL,Code,_WF) :-
2392 ? is_simple_infinite_set(CS),
2393 % TO DO: provide code for interval/NAT/INT /<: AVL
2394 simple_finite_set(AVL),
2395 !,
2396 Code = true. % G cannot be subset of finite set
2397 not_subset_of_explicit_set_aux(C1,C2,Code,WF) :- is_cartesian_product_closure(C1,S11,S12),
2398 ((S11==[] ; S12==[]) -> Code=fail /* we always have a subset */
2399 ; is_definitely_not_empty(S11),
2400 is_definitely_not_empty(S12), % only use optimisation if we know S11, S12 to be non-empty
2401 nonvar(C2), is_cartesian_product_closure(C2,S21,S22),
2402 Code = (kernel_objects:not_both_subset_of(S11,S12, S21,S22, WF))
2403 ), !.
2404 not_subset_of_explicit_set_aux(C1,C2,Code,WF) :- nonvar(C2),
2405 is_powerset_closure(C1,Constructor1,Set1),
2406 is_powerset_closure(C2,Constructor2,Set2),
2407 subset_constructor(Constructor1,Constructor2,R),!,
2408 Code = (R=pred_false -> true ; kernel_objects:not_subset_of_wf(Set1,Set2,WF)).
2409 not_subset_of_explicit_set_aux(Set1,Set2,Code,WF) :-
2410 AllowRegular=false,
2411 get_subset_counter_example_closure(Set1,Set2,NewP,NewT,NewB,AllowRegular,DefResult),
2412 % {x|P1} <: {x|P2} <=> {x|P1 & not(P2)}={}
2413 !,
2414 (DefResult==definitely_non_empty -> Code = true
2415 ; Code = custom_explicit_sets:is_non_empty_closure_wf(NewP,NewT,NewB,WF)
2416 ).
2417
2418
2419 :- public check_avl_not_in_interval/3. % used in not_subset_of_explicit_set_aux
2420 :- block check_avl_not_in_interval(?,-,?). % TO DO: use non-blocking version, minus_inf, and inf set directly
2421 check_avl_not_in_interval(A,Low,Up) :- avl_min(A,int(Min)),
2422 check_avl_not_in_interval4(Low,Up,A,Min).
2423
2424 check_avl_not_in_interval4(Low,_Up,_A,Min) :- Low \== minus_inf, Min < Low,!.
2425 check_avl_not_in_interval4(_Low,Up,A,_Min) :-
2426 Up \== inf, avl_max(A,Max),
2427 kernel_objects:less_than(int(Up),Max). % Up could still be a variable
2428
2429
2430 % checks for simple infinite sets, without Cartesian Product, ... decomposition
2431 ?is_simple_infinite_set(global_set(X)) :- !, is_infinite_global_set(X,_).
2432 is_simple_infinite_set(CS) :- is_interval_closure_or_integerset(CS,Low,Up), infinite_interval(Low,Up).
2433
2434 simple_finite_set(AVL) :- nonvar(AVL), (AVL=avl_set(_) -> true ; AVL = []).
2435
2436 % IMAGE [.]
2437 image_for_id_closure(closure(Par,Types,Body),Set,Res) :-
2438 is_full_id_closure(Par,Types,Body),!,
2439 Res=Set.
2440
2441 image_for_explicit_set(closure(Par,Types,Body),Set,Res,WF) :-
2442 image_for_closure(Par,Types,Body,Set,Res,WF).
2443 image_for_explicit_set(avl_set(A),Set,Res,WF) :- nonvar(Set),
2444 image_for_explicit_avl_set(A,Set,Res,WF).
2445
2446
2447 image_for_closure(Par,Types,Body,Set,Res,_WF) :-
2448 is_id_closure_over(Par,Types,Body,ID_Domain,Full),!,
2449 (Full=true -> Res=Set ; kernel_objects:intersection(ID_Domain,Set,Res)).
2450 % infinite function case dealt with in image1 in bsets_clp
2451 % TO DO: other closure(); Maybe special case if Set is an interval ?
2452 image_for_closure(Par,Types,Body,Set,Res,WF) :-
2453 is_closure1_value_closure(Par,Types,Body,VAL), % TODO: also detect reflexive closure, iteration (iterate(rel,k))
2454 % compute closure1(VAL)[Set]
2455 bsets_clp:image_for_closure1_wf(VAL,Set,Res,WF).
2456
2457 is_closure1_value_closure(Par,Types,Body,VAL) :-
2458 is_member_closure(Par,Types,Body,couple(A,A),MemSET), nonvar(MemSET),
2459 MemSET = closure(V), % this is the closure1 B operator !
2460 nonvar(V), V=b(value(VAL),_,_).
2461
2462 image_for_explicit_avl_set(A,Set,Res,_WF) :- % Set is nonvar
2463 is_interval_closure_or_integerset(Set,From1,To1),!,
2464 % Note: if From1, To1 not yet known we will block and not revert to other image calculation code
2465 % Important e.g. for performance of San Juan (AdaptedBModelPropCheck/acs_as_env_cfg_ipart.mch)
2466 %we used to check for: ground(From1),ground(To1),
2467 interval_image_for_explicit_avl_set(From1,To1,A,Set,Res).
2468 image_for_explicit_avl_set(A,Set,Res,WF) :-
2469 \+ bsets_clp:keep_symbolic(Set), % in this case we fall back to treatment in bsets_clp (image1)
2470 expand_custom_set_to_list_gg(Set,ESet,GG,image_for_explicit_avl_set),
2471 empty_avl(Empty),
2472 (GG=guaranteed_ground -> image_explicit_ground(ESet,A,Empty,Res,WF)
2473 ; image_explicit(ESet,A,Empty,Res,WF)).
2474
2475 :- block interval_image_for_explicit_avl_set(-,?,?,?,?),
2476 interval_image_for_explicit_avl_set(?,-,?,?,?).
2477 interval_image_for_explicit_avl_set(From1,To1,_A,_Set,Res) :-
2478 number(From1), number(To1), From1>To1,!,
2479 kernel_objects:empty_set(Res).
2480 interval_image_for_explicit_avl_set(From1,To1,A,_Set,Res) :-
2481 findall(Image-true, avl_image_interval(From1,To1, A,Image),ImageList),
2482 normalised_list_to_avl(ImageList,ImageAvl),
2483 ? equal_object(ImageAvl,Res).
2484
2485
2486 %! singleton_set(+Set,-Element).
2487 singleton_set(X,_) :- var(X),!,fail.
2488 singleton_set([H|T],R) :- T==[], R=H.
2489 singleton_set(avl_set(node(Y,_,_,empty,empty)),Y). % same as is_one_element_custom_set
2490
2491 is_one_element_custom_set(avl_set(node(Y,_,_,empty,empty)),Y).
2492 is_one_element_avl(node(Y,_,_,empty,empty),Y).
2493
2494 % requires El to be ground
2495 construct_one_element_custom_set(El,avl_set(AVL)) :-
2496 empty_avl(E),avl_store(El,E,true,AVL).
2497
2498 construct_avl_set(Avl,Res) :- empty_avl(Avl) -> Res = [] ; Res = avl_set(Avl).
2499
2500 :- block image_explicit(-,?,?,?,?).
2501 image_explicit([],_,Acc,Res,WF) :- !,
2502 construct_avl_set(Acc,AVLS),
2503 ? kernel_objects:equal_object_wf(Res,AVLS,image_explicit,WF).
2504 image_explicit([D1|T],AVLRelation,In,Out,WF) :- !,
2505 ground_value_check(D1,G1),
2506 ((var(T);T==[]) % TO DO: see below, make propagation also interesting in other circumstances
2507 -> must_be_in_domain_check(G1,D1,T,AVLRelation,In,Out,WF)
2508 ; true),
2509 image_explicit_aux(G1,D1,AVLRelation,T,In,Out,WF).
2510 image_explicit(Set,_,_,_,_) :- add_error_and_fail(image_explicit,'Unknown set: ',Set).
2511
2512 % a version of image_explicit where the list is guaranteed to be ground
2513 image_explicit_ground([],_,Acc,Res,WF) :- !,
2514 construct_avl_set(Acc,AVLS),
2515 kernel_objects:equal_object_wf(Res,AVLS,image_explicit,WF).
2516 image_explicit_ground([D1|T],AVLRelation,In,Out,WF) :- !,
2517 image_explicit_aux_ground(D1,AVLRelation,T,In,Out,WF).
2518 image_explicit_ground(Set,_,_,_,_) :- add_error_and_fail(image_explicit_ground,'Unknown set: ',Set).
2519
2520 :- block must_be_in_domain_check(-,?,?,?,?,-,?),
2521 must_be_in_domain_check(-,?,-,?,?,?,?).
2522 % if result requires at least one more element, then D must be in domain of Relation
2523 % ensures that we get a domain for j in x = {1|->2,2|->4, 4|->8} & x[{j}]={8}
2524 % we could even propagate using inverse of AVLRelation ?!
2525 must_be_in_domain_check(GroundD,D,T,AVLRelation,In,Out,WF) :-
2526 T==[], % apart from D, there are no more elements to be added
2527 var(GroundD), % otherwise we already have a value for D
2528 delta_witness(In,Out,Witness), % obtain at least one value that D must map to
2529 !,
2530 quick_propagation_element_information(avl_set(AVLRelation),(D,Witness),WF,_). % Witness avoids pending co-routines
2531 % TO DO: we could check that *all* elements of Out have this value
2532 % TO DO: below we could check that In is a subset of Out; e.g., for x = %i.(i:1..10|i+i) & x[{5,j,k}]={16,11}; we could also check that Out is subset of range of relation
2533 must_be_in_domain_check(_,_D,_T,_,_In,_Out,_). % :- print(must_be(D,T,In,Out)),nl.
2534
2535 % provide, if possible, a witness element in Out not in In
2536 delta_witness(In,Out,_Witness) :- (var(In) ; var(Out)),!,fail.
2537 %delta_witness(empty,Out,Witness) :- is_definitely_not_empty_with_witness(Out,Witness).
2538 delta_witness(In,Out,Witness) :-
2539 is_custom_explicit_set(Out,delta_witness),
2540 difference_of_explicit_set(Out,avl_set(In),Diff), % could be expensive to compute !? delay ? print(delta(Diff)),nl,
2541 is_definitely_not_empty_with_witness(Diff,Witness).
2542
2543
2544 :- block image_explicit_aux(-,?,?, ?,?,?,?). % we know that D1 is ground
2545 image_explicit_aux(_,D1,AVLRelation,T,In,Out,WF) :-
2546 all_images(D1,AVLRelation,NewImages), % compute AVLRelation[{D1}]
2547 add_to_avl(NewImages,In,In2),
2548 ? image_explicit(T,AVLRelation,In2,Out,WF).
2549 image_explicit_aux_ground(D1,AVLRelation,T,In,Out,WF) :-
2550 all_images(D1,AVLRelation,NewImages), % compute AVLRelation[{D1}]
2551 add_to_avl(NewImages,In,In2),
2552 image_explicit_ground(T,AVLRelation,In2,Out,WF).
2553
2554 all_images(From,AVLRelation,Images) :-
2555 findall(AY,avl_member_pair_arg1_ground(From,AY,AVLRelation),Images).
2556 % we know that From is ground and AY free variable
2557
2558
2559 % compute relational composition ( ; ) if second arg is an AVL set
2560 % TO DO: add support for infinite closures; avoid expanding them [currently handled by symbolic composition in bsets_clp]
2561 rel_composition_for_explicit_set(Rel1,Rel2,Comp) :- nonvar(Rel2),
2562 Rel2=avl_set(A2), % TO DO: see if we can maybe convert Rel2 to AVL ?
2563 % \+ bsets_clp:keep_symbolic(Rel1), check already done in bsets
2564 expand_custom_set_to_list_gg(Rel1,Relation1,GG,rel_composition_for_explicit_set),
2565 empty_avl(In),
2566 (GG=guaranteed_ground
2567 -> rel_avl_compose2_ground(Relation1,A2,In,Comp)
2568 ; rel_avl_compose2(Relation1,A2,In,Comp)).
2569
2570 :- block rel_avl_compose2(-,?,?,?).
2571 rel_avl_compose2([],_,In,Res) :- construct_avl_set(In,A),
2572 ? equal_object(Res,A,rel_avl_compose2). % as we delay; we need to use equal_object at the end
2573 rel_avl_compose2([(X,Y)|T],A2,In,Out) :-
2574 when((ground(X),ground(Y)),
2575 (all_image_pairs_ground(X,Y,A2,ImagePairs),
2576 add_to_avl(ImagePairs,In,In2),
2577 rel_avl_compose2(T,A2,In2,Out))).
2578
2579 % a version where argument is guaranteed to be ground; no when-ground checks
2580 rel_avl_compose2_ground([],_,In,Res) :- construct_avl_set(In,A),
2581 equal_object(Res,A,rel_avl_compose2). % as we delay; we need to use equal_object at the end
2582 rel_avl_compose2_ground([(X,Y)|T],A2,In,Out) :-
2583 all_image_pairs_ground(X,Y,A2,ImagePairs),
2584 add_to_avl(ImagePairs,In,In2),
2585 rel_avl_compose2_ground(T,A2,In2,Out).
2586
2587 all_image_pairs_ground(From,To,AVLRelation,ImagePairs) :-
2588 findall((From,AY),avl_member_pair_arg1_ground(To,AY,AVLRelation),ImagePairs).
2589 % To: already in AVL format; AY is variable -> we could use avl_fetch_pair directly : findall((From,AY),avl_fetch_pair(To,AVLRelation,AY),ImagePairs).
2590
2591 /* succeeds if it can compute domain by some clever way */
2592 domain_of_explicit_set_wf(global_set(GS),_R,_) :- !,
2593 add_error_and_fail(domain_of_explicit_set_wf,'Cannot compute domain of global set: ',GS).
2594 domain_of_explicit_set_wf(freetype(GS),_R,_) :- !,
2595 add_error_and_fail(domain_of_explicit_set_wf,'Cannot compute domain of freetype: ',GS).
2596 domain_of_explicit_set_wf(avl_set(A),Res,_) :- !,
2597 domain_of_avl_set(A,Res).
2598 ?domain_of_explicit_set_wf(C,R,WF) :- dom_for_specific_closure(C,Dom,_,WF),!,
2599 Dom=R.
2600 domain_of_explicit_set_wf(C,R,_) :-
2601 ? dom_symbolic(C,CC),!,
2602 R=CC.
2603 domain_of_explicit_set_wf(closure(P,T,B),Res,WF) :-
2604 % does not seem to be reached, as dom_symbolic now seems to cover all cases
2605 expand_custom_set_wf(closure(P,T,B),EC,domain_of_explicit_set,WF),
2606 domain_of_list_blocking(EC,R),
2607 normalised_list_to_avl_when_ground(R,Res).
2608
2609 % avl tree is a relation with an integer domain
2610 %avl_integer_domain(node((int(_From),_KeyTo),_True,_,_L,_R)).
2611
2612 % the first clause is in principle faster
2613 % but we don't gain time compared to treatment in second clause; we just avoid building up the domain list
2614 %domain_of_avl_set(A,Res) :- avl_integer_domain(A),
2615 % \+ avl_tools:avl_height_less_than(A,10), % try and detect interval if height >= 10
2616 % avl_is_pf_with_interval_domain(A,First,Last),!,
2617 % construct_interval_closure(First,Last,Res).
2618 domain_of_avl_set(A,Res) :-
2619 avl_domain(A,EC), % -> expand_custom_set(avl_set(A),EC),
2620 domain_of_sorted_list(EC,SizeRes,R), % size of list can be smaller than A if we have a relation
2621 (SizeRes=size_res(Size,int(Last)), R=[int(First)-true|_],
2622 Size>1000,
2623 Size is Last+1-First % we have an interval; quite common that we have functions with intervals as domain
2624 -> debug_println(19,constructing_interval_for_domain(First,Last)),
2625 construct_interval_closure(First,Last,Res)
2626 ; ord_list_to_avlset(R,Res,domain)
2627 ).
2628
2629 % check if an AVL tree represents a function with an interval domain
2630 %avl_is_pf_with_interval_domain(AVL,Min,Max) :-
2631 % avl_min(AVL,(int(Min),_)),avl_max(AVL,(int(Max),_)),
2632 % Size is 1+Max-Min, avl_size_possible(AVL,Size),
2633 % is_avl_partial_function(AVL),
2634 % % now check real size
2635 % avl_size(AVL,Size).
2636
2637 % check if an avl represents a set of integers:
2638 avl_integer_set(node(int(_TOP),_True,_,_L,_R)).
2639
2640 % check if an avl set is an interval:
2641 avl_is_interval(AVL,Min,Max) :-
2642 avl_integer_set(AVL),
2643 avl_min(AVL,int(Min)),avl_max(AVL,int(Max)),
2644 Size is 1+Max-Min,
2645 avl_size_possible(AVL,Size),
2646 avl_size(AVL,Size).
2647
2648
2649
2650 :- use_module(bsyntaxtree,[create_typed_id/3]).
2651 dom_symbolic(closure(Paras,Types,Pred), Res) :-
2652 expand_pair_closure(Paras,Types,Pred,[X,Y],[TX,TY],NewPred),
2653 !, % single argument which is a pair
2654 % simply call code for range ; inverting arguments
2655 bsyntaxtree:check_used_ids_in_ast(Pred),
2656 bsyntaxtree:check_used_ids_in_ast(NewPred),
2657 ran_symbolic_closure(Y,[X],TY,[TX],NewPred,Res).
2658 dom_symbolic(closure(Paras,Types,Pred), Res) :-
2659 append(Xs,[Y],Paras), Xs \= [],
2660 append(TXs,[TY],Types),
2661 % simply call code for range ; inverting arguments
2662 ran_symbolic_closure(Y,Xs,TY,TXs,Pred,Res).
2663 % TO DO: allow computation if Paras is a single argument and more than pair
2664
2665 % just computes domain: it can also be successful for lambda closures
2666 dom_for_specific_closure(closure(P,T,Pred),Domain,Functionality,WF) :-
2667 ? dom_for_specific_closure_aux(P,T,Pred,Domain,Functionality,WF).
2668 dom_for_specific_closure_aux(P,T,Pred,Domain,Functionality,_WF) :-
2669 is_lambda_value_domain_closure(P,T,Pred, DomainValue,Expr),
2670 (preference(find_abort_values,full) -> bsyntaxtree:always_well_defined_or_disprover_mode(Expr)
2671 ; true),
2672 % Warning: this will lead to dom(%x.(x:1..3|1/0)) = 1..3 to be true; discarding WD condition
2673 % this is not as bad as {1|->2}(0) = 3 to be silently failing though; hence only done if TRY_FIND_ABORT = full
2674 !,
2675 Domain=DomainValue,
2676 Functionality=function(total).
2677 %dom_for_specific_closure_aux([ID],[Type],Pred,Domain,Functionality,_WF) :- Functionality=relation,
2678 % Pred = b(exists(Paras,ClosurePred),pred,Info1),
2679 % % dom({res|#(paras).(.... & res= domVal|->ran)}) = {res|#(paras).(.... & res= domVal)}
2680 % closures:select_equality(ClosurePred,ID,RHSExpr,Type,Info,RestPred),
2681 % RHSExpr = couple(DomValue,_),
2682 % closures:does_not_occur_in(ID,RestPred),
2683 % Type = couple(DomT,_),
2684 % TID = b(identifier(ID),DomT,[]),
2685 % % safe_create_texpr
2686 % conjunct_predicates([RestPred,b(equal(TID,DomValue),pred,[])],NewClosurePred),
2687 % NewPred = b(exists(Paras,NewClosurePred),pred,Info1),
2688 % Domain = closure([ID],[DomT],NewPred).
2689 dom_for_specific_closure_aux(P,T,Pred,Domain,Functionality,WF) :-
2690 dom_range_for_specific_closure2(P,T,Pred, Domain,_Range,domain_only,Functionality,WF).
2691 dom_for_specific_closure_aux(P,T,Pred,Domain,Functionality,WF) :-
2692 % see test 2571, also triggered in tests 1970, 2102 for reflexive closure, 1878
2693 Functionality = relation, % TODO: check if DomainA,B disjoint -> Functionality is function(.) if FuncA,FuncB are functions, see invariant rho_c ∈ REAL +-> REAL in f_m1 of Abrial hybrid flight; also do similar treatment for range
2694 is_a_disjunct(Pred,PredA,PredB),
2695 % example from test 2571: f = {x,y| x|->y : %xx.(xx>0|xx) or (x <= 0 & y=1)} & f: INTEGER --> INTEGER
2696 ? dom_for_specific_closure_aux(P,T,PredA,DomainA,_FuncA,WF),
2697 ? dom_for_specific_closure_aux(P,T,PredB,DomainB,_FuncB,WF),
2698 kernel_objects:union_wf(DomainA,DomainB,Domain,WF).
2699
2700
2701
2702 %TO DO treat overwrite closure dom(F1<+F2) = dom(F1) \/ dom(F2)
2703
2704 dom_for_lambda_closure(closure(P,T,Pred),Domain) :-
2705 is_lambda_value_domain_closure(P,T,Pred, DomainValue,_Expr),
2706 Domain=DomainValue.
2707
2708 % TO DO: add total functions
2709 %dom_for_specific_closure2([F],[T],
2710 % b(member(b(identifier(F),T,_), b(total_function(value(A),B),set(couple(DOM,RAN)),_)), pred,_) ,
2711 % A).
2712
2713 :- block domain_of_list_blocking(-,?).
2714 % the list will be sorted according to the term ordering for (_,_); hence it will
2715 % already be sorted for the projection onto the first element
2716 % maybe the speed difference is not worth it ??
2717 domain_of_list_blocking([],[]).
2718 domain_of_list_blocking([(A,_B)|T],[A-true|DT]) :- domain_blocking_aux(T,A,DT).
2719 :- block domain_blocking_aux(-,?,?).
2720 domain_blocking_aux([],_,[]).
2721 domain_blocking_aux([(A,_B)|T],Prev,Res) :-
2722 compare(Comp,A,Prev),
2723 (Comp = '='
2724 -> domain_blocking_aux(T,Prev,Res)
2725 ; Res = [A-true|DT],
2726 (Comp = '<' -> add_error_fail(custom_explicit_sets,'Domain list not_sorted: ',(A,Prev)) ; true),
2727 domain_blocking_aux(T,A,DT) ).
2728
2729 % and now a non-blocking version:
2730 domain_of_sorted_list([],size_res(0,'$none'),[]).
2731 domain_of_sorted_list([(A,_B)|T],Size,[A-true|DT]) :- domain_aux(T,A,DT,1,Size).
2732
2733 % TO DO: count length and determine when we have an interval
2734 domain_aux([],Prev,[],Acc,size_res(Acc,Prev)).
2735 domain_aux([(A,_B)|T],Prev,Res,SizeAcc,Size) :- SA1 is SizeAcc+1,
2736 compare(Comp,A,Prev),
2737 (Comp = '='
2738 -> domain_aux(T,Prev,Res,SA1,Size)
2739 ; Res = [A-true|DT],
2740 (Comp = '<' -> add_error_fail(custom_explicit_sets,'Domain list not_sorted: ',(A,Prev)) ; true),
2741 domain_aux(T,A,DT,SA1,Size) ).
2742
2743 /* succeeds if it can compute domain by some clever way */
2744 range_of_explicit_set_wf(global_set(GS),_R,_) :- !,
2745 add_error_and_fail(range_of_explicit_set_wf,'Cannot compute domain of global set: ',GS).
2746 range_of_explicit_set_wf(freetype(GS),_R,_) :- !,
2747 add_error_and_fail(range_of_explicit_set_wf,'Cannot compute domain of freetype: ',GS).
2748 range_of_explicit_set_wf(avl_set(A),Res,_) :- !,
2749 avl_domain(A,EC), % -> expand_custom_set(avl_set(A),EC),
2750 range(EC,R),
2751 normalised_list_to_avl(R,Res).
2752 range_of_explicit_set_wf(C,R,WF) :-
2753 ran_for_specific_closure(C,Ran,WF),!,
2754 Ran=R.
2755 range_of_explicit_set_wf(C,R,_) :-
2756 ran_symbolic(C,CC),!,
2757 R=CC.
2758 range_of_explicit_set_wf(closure(P,T,B),Res,WF) :-
2759 expand_custom_set_wf(closure(P,T,B),EC,range_of_explicit_set_wf,WF),
2760 % TO DO: it would be more useful here to directly just expand the projection onto the last component of P
2761 range_blocking(EC,R),
2762 normalised_list_to_avl_when_ground(R,Res).
2763
2764 % TO DO: in future it is maybe better to add an in_range_wf kernel predicate
2765 ran_symbolic(closure(Paras,Types,Pred), Res) :-
2766 ? (is_memoization_closure(Paras,Types,Pred,_)
2767 -> !,fail % memoization closures can never be dealt with symbolically; we need expansion
2768 ; true),
2769 expand_pair_closure(Paras,Types,Pred,[Y,X],[TY,TX],NewPred),!,
2770 % following test (1541) works with this: 2 : ran({y|#(x).(y = x |-> x + 2 & x : NATURAL)})
2771 ran_symbolic_closure(Y,[X],TY,[TX],NewPred,Res). %, print('res: '),translate:print_bvalue(Res),nl.
2772 ran_symbolic(closure([Y,X],[TY,TX],Pred), Res) :-
2773 ran_symbolic_closure(Y,[X],TY,[TX],Pred,Res).
2774 % TO DO: treat closures with more arguments: we need to quantify Y1,...Yn [Y1,...,Yn,X]
2775
2776 % Replace single Identifier YX of type pair by pair (Y,X) where Y,X are (fresh) variables not occuring in Pred
2777 % example: {y| #(x).(y = x |-> x + 2 & x : NATURAL)} --> {y__1,y__2|#(x).(y__1 |-> y__2 = x |-> x + 2 & x : NATURAL)}
2778 expand_pair_closure([YX],[TYX],Pred,[Y,X],[TY,TX],NewPred) :- TYX = couple(TY,TX),
2779 % Replace single ID YX of type pair by pair (Y,X) where Y,X are (fresh) variables not occuring in Pred
2780 % example: {y| #(x).(y = x |-> x + 2 & x : NATURAL)} --> {y__1,y__2|#(x).(y__1 |-> y__2 = x |-> x + 2 & x : NATURAL)}
2781 % following test (1541) works with this: 2 : ran({y|#(x).(y = x |-> x + 2 & x : NATURAL)})
2782 gensym:gensym(YX,Y),gensym:gensym(YX,X),
2783 create_typed_id(Y,TY,YTID), create_typed_id(X,TX,XTID),
2784 Pair = b(couple(YTID,XTID),TYX,[]),
2785 bsyntaxtree:replace_id_by_expr(Pred,YX,Pair,NewPred).
2786
2787 :- use_module(bsyntaxtree,[create_exists_opt_liftable/3]).
2788 %:- use_module(bsyntaxtree,[add_texpr_info_if_new/3]).
2789 ran_symbolic_closure(Y,Xs,TY,TXs,Pred,Res) :-
2790 % create closure for {Xs | #Y.(Pred)} where Pred uses Y|->Xs
2791 rename_ran_ids(Xs,Pred,[],XIDs,Pred2),
2792 create_typed_id(Y,TY,YTID),
2793 create_exists_opt_liftable([YTID],Pred2,Exists), % Y is liftable as the source is a closure with all ids
2794 %bsyntaxtree:check_used_ids_in_ast(Exists),
2795 %bsyntaxtree:create_exists_opt([YTID],[Pred2],Exists), %or
2796 %b_interpreter_components:create_and_simplify_exists([YTID],Pred2,Exists),
2797 %bsyntaxtree:add_texpr_info_if_new(Exists,allow_to_lift_exists,Exists2), % leads to pending co-routines in self_checks for bsets for apply_to;
2798 % Reason: the tests ground only det WF; without lifting the exists is fully evaluated (and its waitflags with prio 2 and higher grounded) as the wait arguments are ground; with lifting only the det WF is grounded leading to pending coroutines
2799 Res = closure(XIDs,TXs,Exists).
2800
2801
2802
2803 :- use_module(library(lists),[select/3]).
2804
2805 % rename lambda_results :
2806 rename_ran_ids([],Pred,_,[],Pred).
2807 rename_ran_ids([X|TX],Pred,Acc,[XID|TTX],Pred2) :-
2808 % in case X is _lambda_result_ we need to rename it as it then would not get enumerated !
2809 (X == '_lambda_result_'
2810 -> get_fresh_id('_was_lambda_result_',TX,Acc,XID),
2811 % we could remove lambda_result info field, but it will no longer match new id anyway
2812 rename_bt(Pred,[rename(X,XID)],Pred2),
2813 TTX=TX
2814 % TODO: maybe we should also remove the prob_annotation('LAMBDA-EQUALITY') info inside Pred for the ids and equality !?
2815 ; XID = X, rename_ran_ids(TX,Pred,[X|Acc],TTX,Pred2)
2816 ).
2817
2818 :- use_module(b_ast_cleanup,[get_unique_id/2]).
2819 get_fresh_id(ID,List1,List2,Res) :- nonmember(ID,List1), nonmember(ID,List2),!, Res=ID.
2820 get_fresh_id(ID,_,_,FRESHID) :- nl,print('*** VARIABLE_CLASH PREVENTED: '), print(ID),nl,
2821 get_unique_id(ID,FRESHID).
2822
2823 :- block range_blocking(-,?).
2824 range_blocking([],[]).
2825 range_blocking([(_A,B)|T],[B-true|DT]) :- range_blocking(T,DT).
2826 % and a non-blocking version:
2827 range([],[]).
2828 range([(_A,B)|T],[B-true|DT]) :- range(T,DT).
2829
2830 ran_for_specific_closure(closure(P,T,Pred),Range,WF) :-
2831 dom_range_for_specific_closure2(P,T,Pred, _Domain,Range,range_only,_Functionality,WF).
2832 %ran_for_specific_closure(closure_x(P,T,Pred,_Exp),Card,_) :- ran_for_specific_closure2(P,T,Pred,Card).
2833
2834 :- use_module(bsyntaxtree,[conjunct_predicates/2, disjunct_predicates/2, create_typed_id/3, get_texpr_type/2]).
2835 override_custom_explicit_set_wf(R,S,Res,WF) :- /* R <+ S */
2836 nonvar(R),override_custom_explicit_set_aux(R,S,Res,WF).
2837 override_custom_explicit_set_aux(CL,Rel2,Res,_WF) :-
2838 CL=closure(P0,T,B0),
2839 ( preference(convert_comprehension_sets_into_closures,true), % cf keep_symbolic in bsets_clp
2840 (var(Rel2) -> true
2841 ; Rel2 \= avl_set(_)) % if Rel2 is avl_set then maybe better to compute explicitly; unless infinite
2842 ; quick_size_check_larger_than(Rel2,Size2,133) ->
2843 % if we have a large AVL set; then allow expansion up to a larger limit; cf machine 670_002.mch
2844 % a lot of machines use A*B*C <+ {....} to more compactly define large explicit sets
2845 (Size2=inf -> Limit = 200000
2846 ; Limit is min(200000,Size2*150)),
2847 dont_expand_this_closure(P0,T,B0,Limit)
2848 ; dont_expand_this_closure(P0,T,B0) % use default limit and checks for symbolic closure
2849 ),
2850 !,
2851 rename_ran_ids(P0,B0,[],P,B), % any '_lambda_result_' id is no longer guaranteed to be assigned a value in all cases
2852 NewClosure=closure(P,T,NewBody),
2853 % B <+ Rel2 ---> NewBody = P:Rel2 or (prj1(P) /: dom(Rel2) & B)
2854 % TODO better? : %x.(x:Domain|IF x:dom(SFF) THEN SFF(x) ELSE DEFAULT)?
2855 generate_typed_id_pairs(P,T,NestedPairs),
2856 get_texpr_type(NestedPairs,PairsType),
2857 RelPairsType = set(PairsType),
2858 ValS = b(value(Rel2),RelPairsType,[]),
2859 MemS = b(member(NestedPairs,ValS),pred,[]), % P:Rel2
2860 get_prj1(NestedPairs,DomExpr),
2861 get_texpr_type(DomExpr,DomType),
2862 Domain = b(domain(ValS),set(DomType),[]), % TO DO: perform some optimisations like dom(%x.(P|E)) --> {x|P}
2863 %bsets_clp:domain_wf(Rel2,DomainOfRel2,WF), Domain = b(value(DomainOfRel2),DomType,[]), % this DOES NOT work for 1619, 1706 where override is used for infinite functions
2864 NotMemDomS = b(not_member(DomExpr,Domain),pred,[]), % prj1(P) /: dom(Rel2)
2865 conjunct_predicates([NotMemDomS,B],RHS),
2866 disjunct_predicates([MemS,RHS],NewBody),
2867 %print(override),nl, bsyntaxtree:check_used_ids_in_ast(NewBody),
2868 mark_closure_as_symbolic(NewClosure,Res).
2869 % TO DO: add a case where for second set we have: dont_expand_this_closure
2870 override_custom_explicit_set_aux(R,S,Res,WF) :-
2871 is_custom_explicit_set(R,override_custom_explicit_set),
2872 nonvar(S), is_custom_explicit_set(S,override_custom_explicit_set),
2873 %% hit_profiler:add_profile_hit(override(R,S),3), %%
2874 override_custom_explicit_set2(R,S,Res,WF).
2875
2876 override_custom_explicit_set2(R,S,Res,_WF) :- is_one_element_custom_set(S,(X,Y)),
2877 override_pair_explicit_set(R,X,Y,NewR),!, % override pair only succeeds for avl_set
2878 Res=NewR.
2879 % TO DO: if R is very large and S relatively small : iterate by calling override_pair_explicit_set
2880 override_custom_explicit_set2(R,S,Res,WF) :-
2881 \+ dont_expand_this_explicit_set(S), % see test 2564
2882 expand_custom_set_wf(R,ER,override_custom_explicit_set_aux1,WF),
2883 expand_custom_set_wf(S,ES,override_custom_explicit_set_aux2,WF),
2884 override_list(ER,ES,LRes,Done),
2885 finish_restriction(Done,LRes,Res).
2886
2887 quick_size_check_larger_than(Set,Size,Limit) :-
2888 quick_custom_explicit_set_approximate_size(Set,Size),
2889 (is_inf_or_overflow_card(Size) -> true ; Size > Limit).
2890 get_prj1(b(couple(DomExpr,_),_,_),Prj1) :- !, Prj1 = DomExpr.
2891 get_prj1(BE,b(first_of_pair(BE),DT,[])) :- % some closures have a single identifier; we need to apply prj1
2892 BE = b(_E,couple(DT,_RT),_I).
2893
2894 % translate a parameter name and type list into a nested-pair value
2895 generate_typed_id_pairs([ID|IT],[Type|TT],Res) :- create_typed_id(ID,Type,TypedID),
2896 conv2(IT,TT,TypedID,Res).
2897 conv2([],[],X,X).
2898 conv2([ID|IT],[Type|TT],Acc,Res) :- create_typed_id(ID,Type,TypedID),
2899 get_texpr_type(Acc,AccType),
2900 Couple = b(couple(Acc,TypedID),couple(AccType,Type),[]),
2901 conv2(IT,TT,Couple,Res).
2902
2903 :- block override_list(-,?,?,?), override_list(?,-,?,?).
2904 override_list([],S,Res,Done) :- !, copy_to_true_list(S,Res,Done).
2905 override_list(R,[],Res,Done) :- !, copy_to_true_list(R,Res,Done).
2906 override_list([(From1,To1)|T1],[(From2,To2)|T2],Res,Done) :-
2907 (From1 @< From2
2908 -> Res = [(From1,To1)-true|TR], override_list(T1,[(From2,To2)|T2],TR,Done)
2909 ; From2 @< From1
2910 -> Res = [(From2,To2)-true|TR], override_list([(From1,To1)|T1],T2,TR,Done)
2911 ; override_list(T1,[(From2,To2)|T2],Res,Done)).
2912
2913 :- block copy_to_true_list(-,?,?).
2914 % add -true to get lists that can be converted to avl
2915 copy_to_true_list([],[],true).
2916 copy_to_true_list([H|T],[H-true|CT],Done) :- copy_to_true_list(T,CT,Done).
2917
2918 %:- use_module(extrasrc(b_expression_sharing),[cse_optimize_predicate/2]).
2919 :- use_module(closures,[get_domain_range_for_closure_types/3]).
2920 % compute a closure with the functionality violations of a closure
2921 symbolic_functionality_check_closure(closure(P,T,B),closure([DID,ID1,ID2],[DomType,RanType,RanType],Body)) :-
2922 % construct {d,z_,z__| (d,z_):R & (d,z__):R & z_\= z__}
2923 generate_typed_id_pairs(P,T,NestedPairs),
2924 get_texpr_type(NestedPairs,PairsType),
2925 RelPairsType = set(PairsType),
2926 TRel = b(value(closure(P,T,B)),RelPairsType,[]),
2927 DID = '_domain_el', % element in domain, for which we search for two different range elements:
2928 ID1 = '_zzzz_unary', ID2 = '_zzzz_binary',
2929 TDID = b(identifier(DID),DomType,[]),
2930 TID1 = b(identifier(ID1),RanType,[]),
2931 TID2 = b(identifier(ID2),RanType,[]),
2932 construct_pair_membership(TDID,TID1,PairsType,TRel,Mem1),
2933 construct_pair_membership(TDID,TID2,PairsType,TRel,Mem2),
2934 get_domain_range_for_closure_types(T,DomType,RanType),
2935 NeqRan = b(not_equal(TID1,TID2), pred, []),
2936 conjunct_predicates([Mem1,Mem2,NeqRan],Body),
2937 %TODO: cse_optimize_predicate(UnOptBody,Body),
2938 bsyntaxtree:check_used_ids_in_ast(Body).
2939 %bsyntaxtree:check_ast(Body).
2940
2941 :- use_module(bsyntaxtree,[replace_ids_by_exprs/4]).
2942 % assumes TID1 and TID2 are distinct identifiers
2943 construct_pair_membership(TID1,TID2,_PairsType,b(Rel,_,_),MemPred) :-
2944 is_comprehension_set_or_closure(Rel,P,_T,Pred0),
2945 P = [ID1,ID2],
2946 !, % TID1|->TID2 : {x,y|P(x,y)} ==> P(TID1,TID2); see also remove_member_comprehension ast_cleanup rule
2947 replace_ids_by_exprs(Pred0,[ID1,ID2],[TID1,TID2],MemPred), % simultaneous replacement, in case of clashes !
2948 debug_println(9,inlined_pair_membership(ID1,ID2)).
2949 construct_pair_membership(TID1,TID2,PairsType,TRel,MemPred) :-
2950 MemPred = b(member( b(couple(TID1,TID2),PairsType,[]),TRel),pred,[]).
2951
2952
2953
2954 % compute a closure with the injectivity violations of a closure
2955 symbolic_injectivity_check_closure(closure(P,T,B),closure([RID,ID1,ID2],[RanType,DomType,DomType],Body)) :-
2956 % construct {r,z_,z__| (z_,r):R & (z__,r):R & z_\= z__}
2957 generate_typed_id_pairs(P,T,NestedPairs),
2958 get_texpr_type(NestedPairs,PairsType),
2959 RelPairsType = set(PairsType),
2960 TRel = b(value(closure(P,T,B)),RelPairsType,[]), % what if closure body B has WD condition?
2961 RID = '_range', ID1 = '_zzzz_unary', ID2 = '_zzzz_binary',
2962 TRID = b(identifier(RID),RanType,[]),
2963 TID1 = b(identifier(ID1),DomType,[]),
2964 TID2 = b(identifier(ID2),DomType,[]),
2965 construct_pair_membership(TID1,TRID,PairsType,TRel,Mem1),
2966 construct_pair_membership(TID2,TRID,PairsType,TRel,Mem2),
2967 get_domain_range_for_closure_types(T,DomType,RanType),
2968 NeqRan = b(not_equal(TID1,TID2), pred, []),
2969 conjunct_predicates([Mem1,Mem2,NeqRan],Body),
2970 bsyntaxtree:check_used_ids_in_ast(Body).
2971 %bsyntaxtree:check_ast(Body).
2972
2973 % -------------------------
2974
2975
2976 % check whether we have a partial function
2977 is_avl_partial_function(empty) :- !.
2978 is_avl_partial_function(node((KeyFrom,_KeyTo),_True,_,L,R)) :- !,
2979 is_avl_partial_function2(L,'$$MIN$$',KeyFrom),
2980 is_avl_partial_function2(R,KeyFrom,'$$MAX$$').
2981 is_avl_partial_function(X) :- add_internal_error('Not avl_set or relation: ',is_avl_partial_function(X)),fail.
2982
2983 % we traverse the tree from top to bottom, keeping track of possible upper- and lower-bounds
2984 % if any value matches the upper or lower bound, the we do not have a partial function
2985 is_avl_partial_function2(empty,_,_).
2986 is_avl_partial_function2(node((KeyFrom,_KeyTo),_True,_,L,R),ParentFrom,ParentTo) :-
2987 KeyFrom \= ParentFrom, KeyFrom \= ParentTo,
2988 is_avl_partial_function2(L,ParentFrom,KeyFrom),
2989 is_avl_partial_function2(R,KeyFrom,ParentTo).
2990
2991 % the dual of the above, returning a counter example
2992 is_not_avl_partial_function(node((KeyFrom,_KeyTo),_True,_,L,R),DuplicateKey) :- !,
2993 (is_not_avl_partial_function2(L,'$$MIN$$',KeyFrom,DuplicateKey) -> true
2994 ; is_not_avl_partial_function2(R,KeyFrom,'$$MAX$$',DuplicateKey)).
2995 is_not_avl_partial_function2(node((KeyFrom,_KeyTo),_True,_,L,R),ParentFrom,ParentTo,DuplicateKey) :-
2996 ( KeyFrom = ParentFrom -> DuplicateKey=KeyFrom
2997 ; KeyFrom = ParentTo -> DuplicateKey=KeyFrom
2998 ; is_not_avl_partial_function2(L,ParentFrom,KeyFrom,DuplicateKey) -> true
2999 ; is_not_avl_partial_function2(R,KeyFrom,ParentTo,DuplicateKey) -> true).
3000
3001
3002 % check whether we have a function which is total over a given domain; both as AVL sets
3003 is_avl_total_function_over_domain(empty,empty) :- !.
3004 is_avl_total_function_over_domain(AVLFun,AVLDom) :-
3005 avl_domain(AVLFun,FunList),
3006 avl_domain(AVLDom,DomList),
3007 is_avl_total_fun2(FunList,DomList).
3008
3009 is_avl_total_fun2([],[]).
3010 is_avl_total_fun2([(From,_To)|FT],[From|DomT]) :- is_avl_total_fun2(FT,DomT).
3011
3012
3013 %not_is_avl_partial_function(AVLF) :- \+ is_avl_partial_function(AVLF).
3014
3015 :- use_module(kernel_equality,[membership_test_wf/4]).
3016 % check whether an AVL Relation is not over a specific domain & range
3017 is_not_avl_relation_over_domain_range(AVLRel,Domain,Range,WF) :- AVLRel \= empty,
3018 avl_min_pair(AVLRel,RFrom,RTo),
3019 membership_test_wf(Domain,RFrom,MemRes,WF),
3020 is_not_avl_rel_dom1(MemRes,RFrom,RTo,AVLRel,Domain,Range,WF).
3021
3022 :- block is_not_avl_rel_dom1(-, ?,?,?,?,?,?).
3023 is_not_avl_rel_dom1(pred_false,_,_,_,_,_,_WF).
3024 is_not_avl_rel_dom1(pred_true,RFrom,RTo,AVLRel,Domain,Range,WF) :-
3025 membership_test_wf(Range,RTo,MemRes,WF),
3026 is_not_avl_rel_dom2(MemRes,RFrom,RTo,AVLRel,Domain,Range,WF).
3027
3028 :- block is_not_avl_rel_dom2(-, ?,?,?,?,?,?).
3029 is_not_avl_rel_dom2(pred_false,_,_,_,_,_,_WF).
3030 is_not_avl_rel_dom2(pred_true,RFrom,RTo,AVLRel,Domain,Range,WF) :-
3031 avl_next((RFrom,RTo),AVLRel,(RFrom2,RTo2)),
3032 membership_test_wf(Domain,RFrom2,MemRes,WF),
3033 is_not_avl_rel_dom1(MemRes,RFrom2,RTo2,AVLRel,Domain,Range,WF).
3034
3035 % check whether an AVL Relation is not over a specific range
3036 is_not_avl_relation_over_range(AVLRel,Range,WF) :- AVLRel \= empty,
3037 avl_min_pair(AVLRel,RFrom,RTo),
3038 membership_test_wf(Range,RTo,MemRes,WF),
3039 is_not_avl_rel_ran2(MemRes,RFrom,RTo,AVLRel,Range,WF).
3040
3041 :- block is_not_avl_rel_ran2(-, ?,?,?,?,?).
3042 is_not_avl_rel_ran2(pred_false,_,_,_,_,_WF).
3043 is_not_avl_rel_ran2(pred_true,RFrom,RTo,AVLRel,Range,WF) :-
3044 avl_next((RFrom,RTo),AVLRel,(RFrom2,RTo2)),
3045 kernel_equality:membership_test_wf(Range,RTo2,MemRes,WF),
3046 is_not_avl_rel_ran2(MemRes,RFrom2,RTo2,AVLRel,Range,WF).
3047
3048 % check whether we have a relation
3049 is_avl_relation(node((_KeyFrom,_KeyTo),_True,_,_,_)).
3050
3051 % check whether a Relation has all its range elments in a certain Range (not necessarily AVL)
3052 % TO DO: if Domain is an interval: we could take avl_min and avl_max and rely on lexicographic ordering
3053 is_avl_relation_over_domain(AVL,IntervalClosure,_WF) :-
3054 is_interval_closure_or_integerset(IntervalClosure,Low,Up),!,
3055 ((avl_min(AVL,(int(ALow),_)), avl_max(AVL,(int(AUp),_)))
3056 -> cs_greater_than_equal(ALow,Low), cs_greater_than_equal(Up,AUp) %,print(ok),nl
3057 ; (AVL=empty -> true ; add_error_and_fail(is_avl_relation_over_domain,'Not a relation with integer domain: ',AVL))).
3058 is_avl_relation_over_domain(_,Domain,_) :-
3059 quick_is_definitely_maximal_set(Domain),!.
3060 %is_definitely_maximal_set(Domain),!.
3061 ?is_avl_relation_over_domain(AVL,Domain,WF) :- is_avl_relation_over_domain2(AVL,Domain,WF).
3062 is_avl_relation_over_domain2(empty,_,_).
3063 is_avl_relation_over_domain2(node((KeyFrom,_KeyTo),_,_,L,R), Domain,WF) :-
3064 ? is_avl_relation_over_domain2(L, Domain,WF),
3065 ? is_avl_relation_over_domain2(R, Domain,WF),
3066 ? kernel_objects:check_element_of_wf(KeyFrom,Domain,WF).
3067
3068 % : faster to check than is_definitely_maximal_set
3069 quick_is_definitely_maximal_set(X) :- nonvar(X),
3070 quick_is_definitely_maximal_set_aux(X).
3071 quick_is_definitely_maximal_set_aux(global_set(GS)) :-
3072 nonvar(GS),is_maximal_global_set(GS).
3073 quick_is_definitely_maximal_set_aux(avl_set(AVL)) :-
3074 quick_definitely_maximal_set_avl(AVL).
3075
3076 % check whether a Relation has all its range elments in a certain Range (not necessarily AVL)
3077
3078
3079
3080 is_avl_relation_over_range(empty,_,_) :- !.
3081 is_avl_relation_over_range(_,Range,_) :-
3082 %quick_is_definitely_maximal_set(Range),
3083 is_definitely_maximal_set(Range),
3084 !.
3085 ?is_avl_relation_over_range(AVL,Range,WF) :- is_avl_relation_over_range2(AVL,Range,WF).
3086
3087 is_avl_relation_over_range2(empty,_,_).
3088 is_avl_relation_over_range2(node((_KeyFrom,KeyTo),_,_,L,R), Range,WF) :-
3089 ? is_avl_relation_over_range(L, Range,WF),
3090 ? kernel_objects:check_element_of_wf(KeyTo,Range,WF),
3091 ? is_avl_relation_over_range2(R, Range,WF).
3092
3093 % safe version of is_avl_sequence, does not throw error when type cannot be a sequence
3094 safe_is_avl_sequence(empty) :- !.
3095 safe_is_avl_sequence(node((int(KeyFrom),_KeyTo),_True,_,L,R)) :- !,
3096 is_avl_sequence2(L,0,KeyFrom),
3097 is_avl_sequence2(R,KeyFrom,'$$MAX$$').
3098
3099 is_avl_sequence(empty) :- !.
3100 is_avl_sequence(node((int(KeyFrom),_KeyTo),_True,_,L,R)) :- !,
3101 is_avl_sequence2(L,0,KeyFrom),
3102 is_avl_sequence2(R,KeyFrom,'$$MAX$$').
3103 is_avl_sequence(X) :- add_error_and_fail(is_avl_sequence,'Not avl_set or sequence: ',X).
3104
3105 % we traverse the tree from top to bottom, keeping track of possible upper- and lower-bounds
3106 % if any value matches the upper or lower bound, then we do not have a partial function
3107 is_avl_sequence2(empty,X,Y) :-
3108 (Y=='$$MAX$$' -> true ; Y is X+1). % otherwise there is a gap in the sequence
3109 is_avl_sequence2(node((int(KeyFrom),_KeyTo),_,_,L,R),ParentFrom,ParentTo) :-
3110 KeyFrom > ParentFrom, KeyFrom \= ParentTo,
3111 is_avl_sequence2(L,ParentFrom,KeyFrom),
3112 is_avl_sequence2(R,KeyFrom,ParentTo).
3113
3114 % for performance: it is not worthwhile to make a version that checks that
3115 % we have a sequence over a range using a single traversal
3116
3117
3118 % get avl_sequence elements as sorted list (without indices)
3119 % used by external function REPLACE
3120 get_avl_sequence(AVL,SeqList) :-
3121 get_avl_sequence_dcg(AVL,SeqList,[]).
3122
3123 get_avl_sequence_dcg(empty) --> [].
3124 get_avl_sequence_dcg(node((int(_),SeqEl),_True,_,L,R)) -->
3125 get_avl_sequence_dcg(L),
3126 [SeqEl],
3127 get_avl_sequence_dcg(R).
3128
3129
3130 % ---------------------------
3131 prefix_of_custom_explicit_set(avl_set(A),MinIndex,Result,WF) :-
3132 size_of_avl_sequence(A,Size,WF),
3133 (MinIndex > Size
3134 -> add_wd_error('index larger than size of sequence in prefix_sequence (/|\\)! ', '>'(MinIndex,Size),WF)
3135 % ; MinIndex = 0 -> Result = [] % case already treated in bsets_clp
3136 ; MinIndex = Size -> Result=avl_set(A)
3137 ; prefix_of_custom_explicit_set2(A,MinIndex,OrdList,[]),
3138 ord_list_to_avlset(OrdList,Result,prefix_of_custom_explicit_set)
3139 ).
3140 prefix_of_custom_explicit_set2(empty,_MaxIndex) --> {true}.
3141 prefix_of_custom_explicit_set2(node((int(KeyFrom),KeyTo),_True,_,L,R),MaxIndex) -->
3142 ({KeyFrom = MaxIndex}
3143 -> prefix_of_custom_explicit_set2(L,MaxIndex), [((int(KeyFrom),KeyTo)-true)]
3144 ; {KeyFrom > MaxIndex} -> prefix_of_custom_explicit_set2(L,MaxIndex)
3145 ; prefix_of_custom_explicit_set2(L,MaxIndex), [((int(KeyFrom),KeyTo)-true)],
3146 prefix_of_custom_explicit_set2(R,MaxIndex)
3147 ).
3148
3149 % size is only well-defined for sequences:
3150 size_of_custom_explicit_set(avl_set(AVL),int(Size),WF) :- size_of_avl_sequence(AVL,Size,WF).
3151 size_of_custom_explicit_set(closure(P,T,B),Res,WF) :-
3152 is_lambda_value_domain_closure(P,T,B, DomainValue,_Expr),
3153 kernel_cardinality_attr:finite_cardinality_as_int_wf(DomainValue,Res,WF).
3154
3155 size_of_avl_sequence(AVL,Size,WF) :-
3156 avl_min_pair(AVL,int(One),_), One =\= 1,
3157 !,
3158 avl_size(AVL,Sz),
3159 add_wd_error('Applying size to a value which is not a sequence (minimum index is not 1)',b(value(avl_set(AVL)),seq(any),[]),WF),
3160 Size=Sz. % other calls to size_of_avl_sequence currently expect a value
3161 size_of_avl_sequence(AVL,Size,WF) :-
3162 \+ preference(find_abort_values,false),
3163 \+ is_avl_sequence(AVL),
3164 !,
3165 avl_size(AVL,Sz),
3166 add_wd_error('Applying size to a value which is not a sequence',b(value(avl_set(AVL)),seq(any),[]),WF),
3167 Size=Sz. % other calls to size_of_avl_sequence currently expect a value
3168 size_of_avl_sequence(AVL,Size,WF) :-
3169 avl_max_pair(AVL,int(Sz),_),
3170 avl_height(AVL,H), % we cannot compute the height together with max; we need the longest path!
3171 get_min_max_card(H,MinSize,MaxSize),
3172 %avl_size(AVL,Real),format('AVL SeqSize: ~w, height: ~w, real size:~w, min: ~w, max: ~w~n',[Sz,H,Real,MinSize,MaxSize]),
3173 (Sz > MaxSize
3174 -> add_wd_error('Applying size to a value which is not a sequence (maximum index too large)',b(value(avl_set(AVL)),seq(any),[]),WF),
3175 avl_size(AVL,Size)
3176 % triggered by e.g. size({0|->1,0|->2,1|->3}) or size({0|->1,1|->2,3|->3,1|->22,1|->23,1|->24,1|->25,1|->26})
3177 ; Sz < MinSize
3178 -> add_wd_error('Applying size to a value which is not a sequence (maximum index too small)',b(value(avl_set(AVL)),seq(any),[]),WF),
3179 avl_size(AVL,Size)
3180 % triggered by e.g. size([0,2,2,2] |> {2})
3181 ; Size=Sz).
3182
3183 get_min_max_card(Height,MinCard,MaxCard) :-
3184 % page 460, Knuth 3: The height of a balanced tree with N internal nodes always lies between lg(N+1) and 1.4405 lg(N+2) - 0.3277
3185 MaxCard is 2^Height - 1,
3186 % 1.618034 is golden ration phi 0.5(1+sqrt(5)) , 2.236068 is sqrt(5)
3187 % proof in Knuth uses fact: N > phi^(h+2)/sqrt(5) - 2
3188 MinCard is ceiling((1.61803398875**(Height+2)) / 2.2360679775 - 2).
3189
3190 % check if a candidate size is possible given height:
3191 avl_size_possible(AVL,SizeCandidate) :-
3192 avl_height(AVL,Height), % TO DO: restrict to something like log2 of Height
3193 get_min_max_card(Height,MinCard,MaxCard),
3194 MinCard =< SizeCandidate,
3195 SizeCandidate =< MaxCard.
3196
3197
3198 suffix_of_custom_explicit_set(avl_set(A),MinIndex,Result,WF) :-
3199 size_of_avl_sequence(A,Size,WF),
3200 (MinIndex > Size
3201 -> add_wd_error('index larger than size of sequence in suffix_sequence (\\|/)! ', '>'(MinIndex,Size),WF)
3202 % ; MinIndex = 0 -> Result = avl_set(A) % case already treated in bsets_clp
3203 ; MinIndex = Size -> Result=[]
3204 ; suffix_of_custom_explicit_set2(A,MinIndex,OrdList,[]),
3205 ord_list_to_avlset(OrdList,Result,suffix_of_custom_explicit_set)
3206 ).
3207 suffix_of_custom_explicit_set2(empty,_MinIndex) --> {true}.
3208 suffix_of_custom_explicit_set2(node((int(KeyFrom),KeyTo),_True,_,L,R),MinIndex) -->
3209 ({KeyFrom =< MinIndex} -> suffix_of_custom_explicit_set2(R,MinIndex)
3210 ; {ShiftedKeyFrom is KeyFrom-MinIndex},
3211 ({KeyFrom =:= MinIndex+1}
3212 -> {true} ; suffix_of_custom_explicit_set2(L,MinIndex)),
3213 [((int(ShiftedKeyFrom),KeyTo)-true)],
3214 suffix_of_custom_explicit_set2(R,MinIndex)
3215 ).
3216
3217 shift_avl_sequence_to_ord_list(AVL,Offset,ShiftedOrdList) :-
3218 avl_to_list(AVL,List),shift_seq(List,Offset,ShiftedOrdList).
3219 % it does not seem to be worth to use avl_to_list_dcg_offset or a variation thereof
3220 % it is not really slower to do two traversals (avl_to_list and shift_seq)
3221
3222 shift_seq([],_,[]).
3223 shift_seq([(int(I),Val)-true|T],Offset,[(int(NI),Val)-true|ST]) :- NI is I+Offset,
3224 shift_seq(T,Offset,ST).
3225
3226 concat_custom_explicit_set(avl_set(S1),Seq2,Res,WF) :- nonvar(Seq2), Seq2=avl_set(S2),
3227 size_of_avl_sequence(S1,Size1,WF),
3228 shift_avl_sequence_to_ord_list(S2,Size1,OL2),
3229 % if OL2 is small we could use avl_store like in append_custom_explicit_set
3230 %avl_to_list(S1,OL1),
3231 avl_to_list_dcg(S1,NewOrdList,OL2), % use OL2 rather than [] as tail
3232 %append(OL1,OL2,NewOrdList), % we could avoid traversing OL1 again by doing a custom avl_to_list/3 which specifies tail
3233 ord_list_to_avlset(NewOrdList,Res,concat). % , print_term_summary(res_concat(Res)).
3234
3235 % a DCG version of avl_to_list; allows to call it with something else than [] as tail
3236 avl_to_list_dcg(empty) --> [].
3237 avl_to_list_dcg(node(Key,Val,_,L,R)) -->
3238 avl_to_list_dcg(L), [(Key-Val)],
3239 avl_to_list_dcg(R).
3240
3241 /* conc: concatenation of sequence of sequences (general_concat) */
3242 conc_custom_explicit_set(avl_set(AVL),Res) :-
3243 avl_min_pair(AVL,int(ONE),First),
3244 conc2_cs(First,ONE,AVL,0,NewOrdList),
3245 ord_list_to_avlset(NewOrdList,Res,conc).
3246
3247 conc2_cs(Seq,NrSeq,AVL,Offset,OrdList) :-
3248 add_seq(Seq,Offset,OrdList,NewOffset,TailOrd),
3249 (avl_next((int(NrSeq),Seq),AVL,(int(N2),Seq2))
3250 -> conc2_cs(Seq2,N2,AVL,NewOffset,TailOrd)
3251 ; TailOrd=[]).
3252
3253 add_seq([],Offset,OrdRes,NewOffset,TailOrdRes) :- NewOffset=Offset, TailOrdRes=OrdRes.
3254 add_seq(avl_set(ASeq),Offset,OrdRes,NewOffset,TailOrd) :-
3255 avl_to_list_dcg_offset(ASeq,Offset,NrEls,OrdRes,TailOrd), NewOffset is Offset+NrEls.
3256
3257 % a version of avl_to_list for sequences which autmatically adds an offset
3258 avl_to_list_dcg_offset(empty,_,0) --> [].
3259 avl_to_list_dcg_offset(node((int(Idx),El),Val,_,L,R),Offset,NrEls) -->
3260 {NIdx is Idx+Offset},
3261 avl_to_list_dcg_offset(L,Offset,N1),
3262 [((int(NIdx),El)-Val)],
3263 avl_to_list_dcg_offset(R,Offset,N2), {NrEls is N1+N2+1}.
3264
3265 prepend_custom_explicit_set(avl_set(S1),ObjectToPrepend,Res) :-
3266 %hit_profiler:add_profile_hit(prepend_custom_explicit_set(avl_set(S1),ObjectToPrepend,Res)),
3267 element_can_be_added_or_removed_to_avl(ObjectToPrepend),
3268 shift_avl_sequence_to_ord_list(S1,1,OL1),
3269 ord_list_to_avlset([(int(1),ObjectToPrepend)-true|OL1],Res).
3270
3271 append_custom_explicit_set(avl_set(S1),ObjectToAppend,Res,WF) :-
3272 element_can_be_added_or_removed_to_avl(ObjectToAppend), % implies that ObjectToAppend is ground
3273 size_of_avl_sequence(S1,Size1,WF), NewSize is Size1+1,
3274 add_ground_element_to_explicit_set_wf(avl_set(S1),(int(NewSize),ObjectToAppend),Res,WF).
3275
3276 % compute tail of a sequence and also return first element
3277 tail_sequence_custom_explicit_set(avl_set(S1),First,Res,Span,WF) :-
3278 shift_avl_sequence_to_ord_list(S1,-1,NewOrdList),
3279 (NewOrdList = [(int(0),First)-true|TailOL] -> ord_list_to_avlset(TailOL,Res)
3280 ; add_wd_error_span('tail argument is not a sequence!', avl_set(S1),Span,WF)
3281 % add_error_fail(tail_sequence,'tail applied to ', NewOrdList))
3282 ).
3283 last_sequence_explicit_set(avl_set(AVL),Last) :-
3284 avl_max_pair(AVL,int(_Sz),Last).
3285 % TO DO: we could compute height of the path to max H, then check that Sz is in 2**(H-1)+1 .. 2**(H+1)-1 ?
3286 %first_sequence_explicit_set(avl_set(AVL),First) :- % not used anymore; apply_to used instead
3287 % avl_min_pair(AVL,int(_One),First).
3288
3289 % compute front and return last element at the same time
3290 front_sequence_custom_explicit_set(avl_set(AVL),Last,Res) :-
3291 avl_max_pair(AVL,int(Size),Last),
3292 direct_remove_element_from_avl(AVL, (int(Size),Last), Res). % we know Last is already in AVL-converted format
3293
3294
3295 reverse_custom_explicit_set(avl_set(AVL),Res) :-
3296 avl_to_list_dcg_offset(AVL,0,Size,List,[]),
3297 S1 is Size+1,
3298 reverse_list(List,S1,[],RevList),
3299 ord_list_to_avl(RevList,RevAVL),
3300 Res=avl_set(RevAVL).
3301
3302 reverse_list([],_,Acc,Acc).
3303 reverse_list([(int(Idx),El)-V|T],S1,Acc,Res) :-
3304 NewIdx is S1 - Idx,
3305 reverse_list(T,S1,[(int(NewIdx),El)-V|Acc],Res).
3306
3307 % check if a relation is injective ; compute range at the same time; note AVL can be empty
3308 is_injective_avl_relation(AVL,RangeRes) :-
3309 avl_domain(AVL,ElList),
3310 empty_avl(EmptyAcc),
3311 is_avl_inj_list(ElList,EmptyAcc,Range),
3312 construct_avl_set(Range,RangeRes).
3313
3314 is_avl_inj_list([],Range,Range).
3315 is_avl_inj_list([(_From,To)|T],InRange,OutRange) :-
3316 (avl_fetch(To,InRange) -> fail /* this is not an injection; a range element is repeated */
3317 ; avl_store(To,InRange,true,InRange1),
3318 is_avl_inj_list(T,InRange1,OutRange)
3319 ).
3320
3321 % Example predicates that work with code below:
3322 % card(id((1..1000)*(1..1000))~)=1000*1000
3323 % card(((1..1000)*(1..1000))~)=1000*1000
3324 invert_explicit_set(global_set(GS),_R) :- !,
3325 add_error_and_fail(invert_explicit_set,'Cannot compute inverse of global set: ',GS).
3326 invert_explicit_set(freetype(GS),_R) :- !,
3327 add_error_and_fail(invert_explicit_set,'Cannot compute inverse of freetype: ',GS).
3328 invert_explicit_set(closure([P1,P2],[T1,T2],Clo),R) :- !,
3329 % TODO: also invert closures with single argument or more arguments
3330 % e.g., {a,b,c|a=1 & b=1 &c:1..10}~ = {c,ab|ab=(1,1) & c:1..10}
3331 R = closure([P2,P1],[T2,T1],Clo).
3332 invert_explicit_set(closure([P1],[T1],Clo),R) :-
3333 is_member_closure_with_info([P1],[T1],Clo,_Type,Info,MEM),
3334 invert_member_predicate(MEM,T1,InvMEM,InvT1),!,
3335 construct_member_closure(P1,InvT1,Info,InvMEM,R).
3336 invert_explicit_set(C,AVL) :- expand_custom_set(C,EC,invert_explicit_set), %% convert to AVL ?
3337 inv_and_norm(EC,AVL).
3338
3339 invert_member_predicate(cartesian_product(A,B),couple(TA,TB),
3340 cartesian_product(B,A),couple(TB,TA)).
3341 invert_member_predicate(identity(A),TA,identity(A),TA).
3342
3343
3344 :- block inv_and_norm(-,?).
3345 inv_and_norm(EC,AVL) :- inv(EC,R,Done), norm(Done,R,AVL).
3346
3347 :- block norm(-,?,?).
3348 norm(_,R,AVL) :- normalised_list_to_avl(R,AVL).
3349
3350 :- block inv(-,?,?).
3351 inv([],[],done).
3352 inv([(A,B)|T],[(B,A)-true|DT],Done) :- inv(T,DT,Done).
3353
3354
3355
3356 % checks whether a ground value is in the domain of an AVL relation
3357 check_in_domain_of_avlset_wf(X,AVL,_WF) :-
3358 convert_to_avl_inside_set(X,AX),!,
3359 ? (avl_fetch_pair(AX,AVL,_) -> true ; fail).
3360 check_in_domain_of_avlset_wf(X,AVL,WF) :-
3361 print('### could not convert arg for check_in_domain_of_avlset'),nl,
3362 print(X),nl,
3363 safe_flex_avl_member_default_wf((X,_),AVL,WF).
3364
3365 % checks whether a ground value is in the domain of an AVL relation and has only one solution
3366 check_unique_in_domain_of_avlset(X,AVL) :- convert_to_avl_inside_set(X,AX),!,
3367 avl_fetch_pair(AX,AVL,AY1),!,
3368 (avl_fetch_pair(AX,AVL,AY2), AY1 \= AY2 -> fail
3369 ; true).
3370
3371
3372 % utility to check if for a value there is at most one matching element in an AVL set
3373 % optimized for function application
3374 at_most_one_match_possible(Element,AVL,Matches) :- nonvar(Element),
3375 Element=(Index,_Rest), % Function Application; TO DO: does this cover all func. appl ?
3376 element_can_be_added_or_removed_to_avl(Index),
3377 convert_to_avl_inside_set(Index,AX), % is ground and normalised ?
3378 % TO DO: check AVL size ? Check other patterns ?
3379 findall((AX,Match),avl_tools:avl_fetch_pair(AX,AVL,Match),Matches),
3380 Matches \= [_,_|_].
3381
3382
3383
3384 apply_to_avl_set(A,X,Y,Span,WF) :-
3385 ground_value_check(X,GroundX),
3386 ? apply_to_avl_set_aux(A,X,Y,GroundX,Span,WF).
3387
3388 apply_to_avl_set_aux(A,X,Y,GroundX,Span,WF) :- nonvar(GroundX),!,
3389 apply_check_tuple(X,Y,A,Span,WF). % we could call apply_check_tuple_ground to avoid one ground test
3390 % We know that A is a function: we can deterministically apply if X is ground;
3391 % if Y is ground this is only the cases for injective functions
3392 apply_to_avl_set_aux(A,X,Y,GroundX,Span,WF) :-
3393 %(preference(data_validation_mode,true); % we now reduce priority of backpropagation below
3394 \+ preference(find_abort_values,false),
3395 % do not try inverse propagation onto argument X of function application A(X) = Y
3396 !,
3397 avl_approximate_size(A,3,ApproxSizeA),
3398 apply_check_tuple_delay(X,Y,A,ApproxSizeA,Span,WF,GroundX,_,_).
3399 apply_to_avl_set_aux(A,X,Y,GroundX,Span,WF) :-
3400 ground_value_check(Y,GroundY),
3401 avl_approximate_size(A,3,ApproxSizeA), % exact size for height <= 3; approximate size above
3402 (ApproxSizeA < 4 -> SPrio=ApproxSizeA ; SPrio is ApproxSizeA * 10), % magic number; ideally we want X or Y to be known beforehand; if none are known we may miss WD errors and may enumerate useless intermediate variables
3403 get_bounded_wait_flag(SPrio,apply_to_explicit(X,Y),WF,WF1), % this only makes sense if X is a domain variable to be enumerated
3404 %propagate_avl_element_information((X,Y),A,ApproxSizeA,WF), % could be done; but would prevent WD problems from being detected
3405 % this waitflag is used when neither X nor Y are ground;
3406 % quite often not much is gained by enumerating possible values; unless X or Y are constrained or trigger other computations
3407 % WSz is 10*ApproxSizeA, % magic value
3408 %(ApproxSizeA > 100 -> InversePrioSize = 4
3409 % ; avl_range_size_and_propagate_element_info(A,X,Y,RSize), InversePrioSize is ApproxSizeA // RSize), % we could probably compute the exact worst case with the same complexity
3410 % delay_get_wait_flag(GroundY,GroundX,WF1,InversePrioSize,apply_to_explicit_inverse(X,Y),WF,WF2),
3411 %(ApproxSizeA<4000 -> propagate_apply(X,Y,A,ApproxSizeA,WF,GroundX,GroundY) ; true),
3412 ? apply_check_tuple_delay(X,Y,A,ApproxSizeA,Span,WF,GroundX,WF1,GroundY),
3413 (preference(use_clpfd_solver,false) -> true
3414 % should we also check: preference(find_abort_values,true)?
3415 ; get_wait_flag0(WF,WF0),
3416 ? propagate_apply(X,Y,A,ApproxSizeA,WF,WF0,GroundX,WF1,GroundY)).
3417
3418 :- block propagate_apply(?,?,?,?,?,-,?,?,?).
3419 propagate_apply(X,Y,AVL,ApproxSizeA,WF,_,GroundX,WF1,GroundY) :-
3420 var(GroundX), var(WF1), var(GroundY),
3421 (preference(disprover_mode,true)
3422 -> XX=X % this will also instantiate X and prevent finding WD errors
3423 ; (ApproxSizeA<128 -> true
3424 ; preference(solver_strength,SS), ApproxSizeA < 128+SS*100), % up until 4000 it may make sense to constrain Y
3425 preference(data_validation_mode,false), % note: this can slow down ProB, e.g., test 1105; hence allow disabling it
3426 preference(find_abort_values,false), % TO DO: v = %x.(x:1..20|x+x) & {y,z|y<4 & z=v(y) & (y:{-1,2})} =res: no WD ERROR found
3427 propagate_value(X,XX) % only instantiate X, propagation only makes sense for propagate_avl_element_information_small, as otherwise only X will be bounded
3428 ),
3429 !,
3430 ? propagate_avl_element_information_direct((XX,Y),AVL,ApproxSizeA,WF).
3431 propagate_apply(_,_,_,_,_,_,_,_,_).
3432
3433 % only propagate in one direction to allow to find WD errors but also prevent pending co-routines/constraints
3434 :- block propagate_value(-,?).
3435 propagate_value(int(X),R) :- !,
3436 (
3437 %%integer(X) -> R=int(X) ; % relevant for SWI 8.5.10 and older where fd_set fails for integers, see test 788; should be fixed in next release
3438 propagate_fd_dom(X,RX), R=int(RX), propagate_atomic_value(X,RX)
3439 ).
3440 propagate_value(fd(X,T),R) :- !,
3441 (
3442 %%integer(X) -> R=fd(X,T) ; % for SWI 8.5.10 and older, see above
3443 propagate_fd_dom(X,RX), R=fd(RX,T), propagate_atomic_value(X,RX)
3444 ).
3445 propagate_value((X1,X2),R) :- !, R=(RX1,RX2), propagate_value(X1,RX1), propagate_value(X2,RX2).
3446 propagate_value(pred_true,R) :- !, if(R=pred_true,true,debug_println(9,function_arg_outside_domain(pred_true))).
3447 propagate_value(pred_false,R) :- !, if(R=pred_false,true,debug_println(9,function_arg_outside_domain(pred_false))).
3448 propagate_value(string(X),R) :- !, R=string(RX),propagate_atomic_value(X,RX).
3449 propagate_value(X,RX) :- equal_object(X,RX). % TO DO: get rid of this: this propagates and prevents finding WD errors
3450 :- block propagate_atomic_value(-,?).
3451 propagate_atomic_value(X,Y) :-
3452 if(X=Y,true,debug_println(9,function_arg_outside_domain(X))).
3453
3454 %propagate_fd_dom(X,RX) :- integer(X),!,RX=X. % relevant for SWI 8.5.10 and older where fd_set fails for integers
3455 propagate_fd_dom(X,RX) :- fd_set(X,Dom),in_set(RX,Dom).
3456
3457
3458 /*
3459 :- block propagate_apply(-,?,?,?,?,-,-).
3460 % call propagate as soon as we know something about the function argument and we do not propgagate completely using GroundX/Y anyway
3461 propagate_apply(X,Y,AVL,Size,WF,GroundX,GroundY) :- print(prop_apply(Size,GroundX,GroundY,X,Y)),nl,
3462 (nonvar(GroundX) -> true ; nonvar(GroundY) -> true
3463 ; propagate_avl_element_information((X,Y),AVL,Size,WF)).
3464
3465 % get the waitflag when first WF set and other two not
3466 :- block delay_get_wait_flag(-,-,-,?,?,?,?).
3467 delay_get_wait_flag(_,WF1,WF2, _,_,_,_) :- (nonvar(WF1);nonvar(WF2)),!. % DO NOTHING
3468 delay_get_wait_flag(_,_,_,Prio,Info,WF,WF2) :- get_wait_flag(Prio,Info,WF,WF2).
3469 */
3470
3471 :- block apply_check_tuple_delay(?,?,?, ?,?,?, -,-,-).
3472 apply_check_tuple_delay(X,Y,AVL,_ApproxSizeA,Span,WF,GroundX,WF1,_) :-
3473 (nonvar(GroundX);nonvar(WF1)),!,
3474 ? apply_check_tuple(X,Y,AVL,Span,WF).
3475 apply_check_tuple_delay(X,Y,AVL,ApproxSizeA,Span,WF,_GroundX,_WF1,_GroundY) :-
3476 % Y is ground; try to do an inverse function lookup
3477 inverse_apply_ok(Y,X,AVL,ApproxSizeA,Span),
3478 !,
3479 % print(inverse_apply(Y,X,ApproxSizeA,_GroundX)),nl,
3480 inverse_get_possible_values(X,Y,AVL,Res),
3481 Res=avl_set(InvAVL), % if empty set : we fail
3482 (preference(data_validation_mode,true),
3483 avl_approximate_size(InvAVL,10,ApproxSize),
3484 ApproxSize>1
3485 -> A2 is (ApproxSize*15*ApproxSize)//ApproxSizeA, % used to be A2 is ApproxSize*100,
3486 A22 is max(A2,ApproxSize),
3487 (get_inversion_penalty(Span)
3488 -> A23 is A22 * 100 %, add_message(f,'Inversion Penalty: ',Y:A22,Span)
3489 ; A23=A22),
3490 % give lower priority for backwards propagation, upto 15 times if no reduction from backwards propagation
3491 % but also take into account how much we reduce the size by inverting
3492 % relevant for, e.g., Machines_perf_0111/Thales_All/rule_OPS_SDS_3940.mch
3493 % or rule_OPS_SDS_6496 -> 15 instead of 150 improves performance
3494 get_bounded_wait_flag(A23,element_of_avl_inverse_apply_ok(X),WF,WF2),
3495 % does not call propagate_avl_element_information(X,InvAVL,ApproxSize,WF) or avl_to_table
3496 element_of_avl_set_wf3(X,InvAVL,ApproxSize,WF2,WF) % TODO: pass GroundX
3497 %apply_check_tuple_delay(X,Y,AVL,ApproxSizeA,Span,WF,GroundX,WF1,_) % now wait on WF1 or GroundX
3498 ? ; element_of_avl_set_wf(InvAVL,X,WF)
3499 ).
3500 apply_check_tuple_delay(X,Y,AVL,ApproxSizeA,Span,WF,GroundX,WF1,_GroundY) :-
3501 apply_check_tuple_delay(X,Y,AVL,ApproxSizeA,Span,WF,GroundX,WF1,_). % now wait on WF1 or GroundX
3502
3503 % check if the function call was annotated as not suitable for backwards inverse function lookup propagation
3504 get_inversion_penalty(span_predicate(b(_Function,_,Info),_LS,_S)) :- !,
3505 get_inversion_penalty(Info).
3506 get_inversion_penalty(Info) :-
3507 member(prob_annotation('INVERSION_PENALTY'),Info).
3508
3509 inverse_get_possible_values(X,Y,AVL,Res) :-
3510 get_template(X,XX,_),
3511 copy_term(XX,XX_Copy), % avoid that findall instantiates X
3512 % TODO: copy_value_term similar to ground_value to avoid traversing avl_sets; but usually X is not a set
3513 findall(XX_Copy, safe_avl_member_default((XX_Copy,Y),AVL), PossibleValues),
3514 PossibleValues \= [], % fail straightaway
3515 sort(PossibleValues,SPV),
3516 % length(SPV,Len),print(inverse_image(Y,Len)),nl, print_term_summary(apply_check_tuple_delay(X,Y,AVL)),nl,
3517 convert_to_avl(SPV,Res).
3518
3519 % is it ok to compute inverse ? only makes sense if AVL tree not too big and quite functional
3520 inverse_apply_ok(pred_true,_,_AVL,ApproxSizeA,_) :- !, % only two values possible, probably half of AVL will be returned
3521 ApproxSizeA < 1023. % corresponds to avl_height < 10
3522 inverse_apply_ok(pred_false,_,_AVL,ApproxSizeA,_) :- !,ApproxSizeA < 1023.
3523 % TO DO: other small types, such as fd(_,_)
3524 inverse_apply_ok(_,_,_AVL,ApproxSizeA,_) :- ApproxSizeA < 255,!.
3525 inverse_apply_ok(_,X,_AVL,ApproxSizeA,Span) :- ApproxSizeA < 65535, % corresponds Height < 16
3526 (preference(data_validation_mode,true) ->
3527 (preference(solver_strength,SS), ApproxSizeA < 16383+SS -> true
3528 ; perfmessage(inverse,'Function call not inverted (increase SOLVER_STRENGTH to enable this), approximate function size: ',ApproxSizeA,Span),
3529 fail
3530 )
3531 ; true),
3532 quick_non_ground_check(X).
3533 %inverse_apply_ok(_,_,_,_).
3534
3535 % sometimes the ground_value_check co-routine hasn't grounded GroundX yet ! so do a quick check
3536 quick_non_ground_check(X) :- var(X),!.
3537 quick_non_ground_check([]) :- !,fail.
3538 quick_non_ground_check(avl_set(_)) :- !,fail.
3539 quick_non_ground_check(pred_true) :- !,fail.
3540 quick_non_ground_check(pred_false) :- !,fail.
3541 quick_non_ground_check(int(X)) :- !,var(X).
3542 quick_non_ground_check(string(X)) :- !,var(X).
3543 quick_non_ground_check(fd(X,T)) :- !,(var(X) ; var(T)).
3544 quick_non_ground_check((A,B)) :- !, (quick_non_ground_check(A) -> true ; quick_non_ground_check(B)).
3545 quick_non_ground_check(_). % assume it is non ground
3546
3547
3548
3549 % apply_check_tuple is allowed to enumerate: either X is ground or Y is ground
3550 apply_check_tuple(X,Y,A,Span,WF) :-
3551 ground_value(X),
3552 convert_to_avl_inside_set_wf(X,AX,WF),!, % we can do optimized lookup + checking in one go
3553 % (but avl_apply only does partial check)
3554 avl_apply(AX,A,XY,Span,WF),
3555 ? kernel_objects:equal_object_wf(XY,Y,apply_check_tuple,WF).
3556 :- if(environ(no_wd_checking, true)).
3557 apply_check_tuple(X,Y,A,_Span,WF) :- safe_avl_member_default_wf((X,Y),A,WF).
3558 :- else.
3559 apply_check_tuple(X,Y,A,_Span,WF) :- preferences:preference(find_abort_values,false), !,
3560 safe_flex_avl_member_default_wf((X,Y),A,WF). % will do a ground check again for X in flexible_decompose_index
3561 apply_check_tuple(X,Y,A,Span,WF) :- !,
3562 if(safe_flex_avl_member_default_wf((X,XY),A,WF), % does not detect abort errors if X unbound
3563 kernel_objects:equal_object_wf(XY,Y,apply_check_tuple_avl,WF),
3564 add_wd_error_span('function applied outside of domain (#4): ','@fun'(X,avl_set(A)),Span,WF)).
3565 :- endif.
3566
3567
3568 % ------------------------------------------
3569
3570
3571 :- use_module(b_global_sets,[b_type2_set/2]).
3572 :- use_module(bsyntaxtree,[rename_bt/3]).
3573 union_of_explicit_set(global_set(GS),_,R) :- is_maximal_global_set(GS), !,
3574 R= global_set(GS). /* global_set is already maximal */
3575 union_of_explicit_set(freetype(GS),_,R) :- !, R= freetype(GS). /* freetype is already maximal */
3576 union_of_explicit_set(closure(P,T,B),_,R) :- is_definitely_maximal_closure(P,T,B), !,
3577 R= closure(P,T,B). /* global_set is already maximal */
3578 union_of_explicit_set(_,S2,R) :- is_definitely_maximal_set(S2),!, % will also look at AVL set
3579 R=S2.
3580 union_of_explicit_set(S1,S2,R) :- nonvar(S2), S2 = [], !, R=S1.
3581 union_of_explicit_set(S1,S2,_) :- (var(S1);var(S2)),!,fail. % then we cannot compute it here
3582 union_of_explicit_set(S2,S1,R) :-
3583 is_not_member_value_closure(S1,TYPE,MS1), nonvar(MS1), is_efficient_custom_set(MS1),
3584 % also works if S2 is complement closure
3585 difference_of_explicit_set(MS1,S2,Diff),!,
3586 construct_complement_closure_if_necessary(Diff,TYPE,R).
3587 union_of_explicit_set(avl_set(A1),S2,R) :- !, union_of_avl_set(S2,A1,R).
3588 union_of_explicit_set(S1,S2,R) :-
3589 is_not_member_value_closure(S1,TYPE,MS1), nonvar(MS1), is_efficient_custom_set(MS1),
3590 difference_of_explicit_set(MS1,S2,Diff),!,
3591 construct_complement_closure_if_necessary(Diff,TYPE,R).
3592 union_of_explicit_set(S1,avl_set(A2),R) :- !, union_of_avl_set(S1,A2,R).
3593 union_of_explicit_set(I1,I2,R) :- is_interval_closure_or_integerset(I1,From1,To1), ground(From1), ground(To1),
3594 is_interval_closure_or_integerset(I2,From2,To2), ground(From2), ground(To2),
3595 !,
3596 (union_of_interval(From1,To1,From2,To2,FromRes,ToRes)
3597 -> construct_interval_closure(FromRes,ToRes,R)
3598 ; small_enough_for_expansion(From1,To1),small_enough_for_expansion(From2,To2) ->
3599 % do not attempt union_of_closure below
3600 expand_interval_closure_to_avl(From1,To1,R1), R1=avl_set(A1), % empty interval already dealt with above !?
3601 expand_interval_closure_to_avl(From2,To2,R2), R2=avl_set(A2), % Note: unification after call as expand_interval calls equal_object (which gets confused by partially instantiated avl_set(_))
3602 union_of_avl(A1,A2,ARes),R=avl_set(ARes) /* AVL not normalised */
3603 ; transform_global_sets_into_closure(I1,closure(Par,T,Body)),
3604 union_of_closure(I2,Par,T,Body,R)
3605 ).
3606 union_of_explicit_set(closure(P,T,B),C2,Res) :-
3607 union_of_closure(C2,P,T,B,Res).
3608
3609 small_enough_for_expansion(From1,To1) :- number(To1), number(From1), To1-From1<250.
3610
3611 :- use_module(bsyntaxtree,[extract_info/2, extract_info_wo_used_ids/2, extract_info/3, rename_bt/3, replace_id_by_expr/4]).
3612
3613 union_of_closure(global_set(X),P,T,B,Res) :- !, transform_global_sets_into_closure(global_set(X),C),
3614 union_of_closure(C,P,T,B,Res).
3615 union_of_closure(closure(P2,T2,B2),P,T,B,Res) :- !,
3616 % T2 should be equal to T, module seq(_) <-> set(couple(integer,_))
3617 unify_closure_predicates(P,T,B, P2,T2,B2 , NewP,NewT, NewB1,NewB2),
3618 debug:debug_println(9,union_of_two_closures(P,P2,NewP,NewT)),
3619 extract_info(B,B2,NewInfo),
3620 construct_disjunct(NewB1,NewB2,Disj),
3621 Res = closure(NewP,NewT,b(Disj,pred,NewInfo)).
3622
3623 % rename predicates of two closures so that they work on common closure parameter ids
3624 % and can then be either joined by conjunction or disjunction
3625 unify_closure_predicates(P,T,B, P2,T2,B2 , NewP,NewT, NewB1,NewB2) :-
3626 length(P,Len1), length(P2,Len2),
3627 (Len1=Len2
3628 -> generate_renaming_list(P,P2,RL),
3629 rename_bt(B2,RL,NewB2),
3630 NewP=P, NewT=T, NewB1 = B
3631 ; Len1 < Len2 -> unify_clos_lt(P,T,B, P2,T2,B2 , NewP,NewT, NewB1,NewB2)
3632 ; unify_clos_lt(P2,T2,B2, P,T,B , NewP,NewT, NewB2,NewB1) % inverted the predicate
3633 ).
3634
3635 % TO DO: generalize: currently only works for single identifier on left
3636 % but works for id(NATURAL) \/ %x.(x<0|-x) or abs = id(NATURAL) \/ %x.(x<0|-x) & abs(2)=a2 & abs(-2)=am2
3637 unify_clos_lt([ID1],[couple(_,_)],B, P2,T2,B2 , NewP,NewT, NewB1,NewB2) :-
3638 rename_lambda_result_id(P2,B2,P3,B3),
3639 create_couple_term(P3,T2,Pair),
3640 replace_id_by_expr(B,ID1,Pair,NewB1),
3641 NewP=P3, NewT=T2, NewB2=B3.
3642
3643 % _lambda_result_ id is not enumerated, hence we have to avoid inserting such ids into NewB1 as part of the pPair
3644 rename_lambda_result_id(['_lambda_result_',ID2],B2,[FRESHID,ID2],B3) :- !,get_unique_id('_RANGE_',FRESHID),
3645 rename_bt(B2,[rename('_lambda_result_',FRESHID)],B3).
3646 rename_lambda_result_id([ID1,'_lambda_result_'],B2,[ID1,FRESHID],B3) :- !,get_unique_id('_RANGE_',FRESHID),
3647 rename_bt(B2,[rename('_lambda_result_',FRESHID)],B3).
3648 rename_lambda_result_id(P2,B2,P2,B2).
3649
3650 % translate a list of atomic ids and a list of types into a couple-term
3651 create_couple_term([ID1],[T1],Res) :- !,
3652 create_texpr(identifier(ID1),T1,[],Res).
3653 create_couple_term([ID1,ID2],[T1,T2],Res) :-
3654 bsyntaxtree:create_couple(b(identifier(ID1),T1,[]),b(identifier(ID2),T2,[]),Res).
3655 % TODO: extend for more than two args
3656
3657 generate_renaming_list([],[],[]).
3658 generate_renaming_list([ID|T],[ID2|T2],RL) :-
3659 (ID==ID2 -> generate_renaming_list(T,T2,RL)
3660 ; RL = [rename(ID2,ID)|RL2],
3661 generate_renaming_list(T,T2,RL2)).
3662
3663
3664 % a more clever way of constructing a disjunct; factor out common prefixes
3665 % (A & B1) or (A1 & B2) <=> A1 & (B1 or B2)
3666 % TO DO: we should try and get the leftmost basic conjunct !
3667 /* construct_disjunct(b(conjunct(A1,A2),pred,IA), b(conjunct(B1,B2),pred,_IB), Res) :-
3668
3669 print('TRY DISJUNCT FACTOR: '), translate:print_bexpr(A1),nl,
3670 translate:print_bexpr(B1),nl,
3671 same_texpr_body(A1,B1),!,
3672 print('DISJUNCT FACTOR: '), translate:print_bexpr(A1),nl,
3673 Res = conjunct(A1,b(Disj,pred,IA)),
3674 construct_disjunct(A2,B2,Disj).
3675 */
3676 construct_disjunct(A,B,disjunct(A,B)).
3677
3678 % TO DO: quick_check if AVL A1 is maximal ?
3679 union_of_avl_set(avl_set(A2),A1,R) :- !, union_of_avl(A1,A2,ARes), R=avl_set(ARes). /* AVL not normalised */
3680 union_of_avl_set(I2,A1,R) :- is_interval_closure_or_integerset(I2,From2,To2), !,
3681 ground(From2), ground(To2), % we can only compute it if bounds known
3682 (avl_min(A1,int(Min)), low_border(From2,Min,FromRes), avl_max(A1,int(Max)), up_border(To2,Max,ToRes)
3683 -> /* AVL contained (almost) in Interval */
3684 construct_interval_closure(FromRes,ToRes,R)
3685 ; \+ small_interval(From2,To2) ->
3686 transform_global_sets_into_closure(I2,closure(Par,T,Body)), % we may have something like NATURAL1,...
3687 union_of_avl_set_with_closure(Par,T,Body,A1,R)
3688 ; expand_and_convert_to_avl_set(I2,A2,union_of_avl_set,'? \\/ ARG'), % can generate ARel=empty; will fail if not possible to convert
3689 union_of_avl(A1,A2,ARes), R=avl_set(ARes)
3690 ).
3691 union_of_avl_set(closure(Par,T,Body),A1,Res) :- is_infinite_or_symbolic_closure(Par,T,Body),!,
3692 % TO DO: what if we are in SYMBOLIC mode and the type of T is infinite; maybe we should also keep the union symbolic ?? (cf Ticket/Georghe1)
3693 union_of_avl_set_with_closure(Par,T,Body,A1,Res).
3694 union_of_avl_set(S2,A1,Res) :-
3695 S2 \= freetype(_),
3696 ground_value(S2), % could be a closure
3697 !,
3698 (try_expand_and_convert_to_avl_set(S2,A2,union)
3699 -> union_of_avl(A1,A2,ARes), Res=avl_set(ARes) /* AVL not normalised */
3700 ; S2=closure(Par,T,Body),
3701 union_of_avl_set_with_closure(Par,T,Body,A1,Res)).
3702
3703 try_expand_and_convert_to_avl_set(S2,A2,Source) :-
3704 % false: do not add enumeration warning events as errors
3705 catch_enumeration_warning_exceptions(expand_and_convert_to_avl_set(S2,A2,Source,''),fail,false,ignore(Source)).
3706
3707 % try expanding to list, but catch enumeration warnings and fail if they do occur
3708 % used by override(...)
3709 %try_expand_custom_set_to_list(CS,_,_,_) :- nonvar(CS),CS=global_set(GS),is_infinite_global_set(GS,_),
3710 % !,
3711 % fail.
3712 try_expand_custom_set_to_list(CS,_,_,_) :- nonvar(CS),
3713 (is_symbolic_closure(CS) ; is_infinite_explicit_set(CS)),
3714 !, % we could also check is_symbolic_closure
3715 fail.
3716 try_expand_custom_set_to_list(CS,List,Done,Source) :-
3717 % false: do not add enumeration warning events as errors
3718 catch_enumeration_warning_exceptions(expand_custom_set_to_list(CS,List,Done,Source),fail,false,ignore(Source)).
3719
3720
3721 small_interval(From,To) :- number(From), number(To), To-From < 10000.
3722
3723 union_of_avl_set_with_closure(Par,T,Body,A1,Res) :-
3724 Body = b(_,BodyT,_),
3725 setup_typed_ids(Par,T,TypedPar),
3726 couplise_list(TypedPar,TypedCPar),
3727 generate_couple_types(TypedCPar,ParExpr,ParType),
3728 debug:debug_println(9,union_of_avl_and_infinite_closure(Par,T,BodyT)),
3729 BodyAvl = b(member(ParExpr,b(value(avl_set(A1)),set(ParType),[])),pred,[]),
3730 extract_info_wo_used_ids(Body,NewInfo),
3731 Res = closure(Par,T,b(disjunct(BodyAvl,Body),pred,NewInfo)).
3732 % mark_closure_as_symbolic(closure(Par,T,b(disjunct(BodyAvl,Body),pred,NewInfo)),Res).
3733
3734 low_border(Low,AVLMin,R) :- geq_inf(AVLMin,Low),!,R=Low.
3735 low_border(Low,AVLMin,R) :- number(Low),AVLMin is Low-1,R=AVLMin. % extend lower border by one
3736 up_border(Up,AVLMax,R) :- geq_inf(Up,AVLMax),!,R=Up.
3737 up_border(Up,AVLMax,R) :- number(Up),AVLMax is Up+1,R=AVLMax. % extend upper border by one
3738
3739
3740 setup_typed_ids([],[],[]).
3741 setup_typed_ids([ID|TI],[Type|TT],[b(identifier(ID),Type,[])|BT]) :- setup_typed_ids(TI,TT,BT).
3742
3743 generate_couple_types(couple(A,B),b(couple(TA,TB),Type,[]),Type) :- !, Type = couple(TTA,TTB),
3744 generate_couple_types(A,TA,TTA),
3745 generate_couple_types(B,TB,TTB).
3746 generate_couple_types(b(X,T,I),b(X,T,I),T).
3747
3748
3749 % try to see if two intervals can be unioned into a new interval
3750 union_of_interval(F1,T1,F2,T2,FR,TR) :-
3751 geq_inf(F2,F1), geq_inf(T1,T2),!,FR=F1,TR=T1. % interval [F2,T2] contained in [F1,T1]
3752 union_of_interval(F2,T2,F1,T1,FR,TR) :- geq_inf(F2,F1), geq_inf(T1,T2),!,FR=F1,TR=T1. % see above
3753 union_of_interval(F1,T1,F2,T2,FR,TR) :- number(F2),
3754 geq_inf(F2,F1), number(T1),T11 is T1+1,geq_inf(T11,F2), geq_inf(T2,F2),!,FR=F1,TR=T2. % intervals can be joined
3755 union_of_interval(F2,T2,F1,T1,FR,TR) :- number(F2),
3756 geq_inf(F2,F1), number(T1),T11 is T1+1,geq_inf(T11,F2), geq_inf(T2,F2),!,FR=F1,TR=T2. % see above
3757
3758 :- use_module(library(ordsets),[ord_union/3]).
3759 union_of_avl(A1,A2,ARes) :-
3760 avl_height(A2,Sz2),
3761 (Sz2 < 2 % we have something like Set := Set \/ {x}; no need to compute height of A1
3762 -> union_of_avl1(A1,99999,A2,Sz2,ARes)
3763 ; avl_height(A1,Sz1), % TODO: we could call avl_height_less_than or avl_height_compare
3764 (Sz1<Sz2 -> union_of_avl1(A2,Sz2,A1,Sz1,ARes) ; union_of_avl1(A1,Sz1,A2,Sz2,ARes))
3765 ).
3766 union_of_avl1(A1,Sz1,A2,Sz2,ARes) :- Sz2>2, Sz1 =< Sz2+3, % difference not too big; Sz2 at least a certain size
3767 !,
3768 avl_to_list(A2,List2), % get all members
3769 avl_to_list(A1,List1),
3770 ord_union(List1,List2,L12),
3771 ord_list_to_avl(L12,ARes).
3772 union_of_avl1(A1,_Sz1,A2,_Sz2,ARes) :- % this version is better when A2 is small compared to A1
3773 avl_domain(A2,List2), % get all members
3774 add_to_avl(List2,A1,ARes).
3775
3776 :- use_module(library(lists),[reverse/2]).
3777 % a custom version for union(A) where A is AVL set; avoid converting/expanding accumulators and computing avl_height
3778 % runtime of e.g., UNION(x).(x:1000..1514|0..x) 0.65 sec or UNION(n).(n:10000..10010|UNION(x).(x:n..n+1000|n..x)) 4.8 sec is considerably smaller with this version
3779 union_generalized_explicit_set(avl_set(SetsOfSets),Res,WF) :-
3780 expand_custom_set_to_list_wf(avl_set(SetsOfSets),ESetsOfSets,_,union_generalized_wf,WF),
3781 % length(ESetsOfSets,Len),print(union_gen(Len)),nl,
3782 (ESetsOfSets=[OneSet]
3783 -> Res=OneSet % avoid converting to list and back to Avl
3784 ; reverse(ESetsOfSets,RESetsOfSets), % be sure to insert larger values first, so that ord_union has less work to do below; useful if you have many small singleton sets, for example union(ran(%x.(x : 1 .. 10000|{x * x}))) 2.37 secs --> 0.15 secs
3785 % note: dom({r,x|x:1..50000 & r:{x*x}}) is still 3 times faster
3786 union_of_avls(RESetsOfSets,[],Res)).
3787
3788 % take the union of a list of avl_sets
3789 union_of_avls([],Acc,Res) :- ord_list_to_avl(Acc,ARes), construct_avl_set(ARes,Res).
3790 union_of_avls([H|T],Acc,Res) :-
3791 union_of_avl_with_acc(H,Acc,NewAcc),
3792 union_of_avls(T,NewAcc,Res).
3793
3794 union_of_avl_with_acc(avl_set(H),Acc,NewAcc) :- !,
3795 avl_to_list(H,HList),
3796 ord_union(Acc,HList,NewAcc).
3797 union_of_avl_with_acc([],Acc,Res) :- !,Res=Acc.
3798 % other custom sets should normally not appear, we obtain the list as elements stored in an avl_set
3799 union_of_avl_with_acc(G,_,_) :- add_internal_error('Uncovered element: ',union_of_avl_with_acc(G,_,_)),fail.
3800
3801
3802
3803 % TO DO: there are no rules for is_not_member_value_closure for intersection below
3804 intersection_of_explicit_set_wf(global_set(GS),S2,R,_WF) :- is_maximal_global_set(GS), !, R=S2.
3805 intersection_of_explicit_set_wf(freetype(_GS),S2,R,_WF) :- !, R=S2.
3806 intersection_of_explicit_set_wf(_,S2,_,_WF) :- var(S2),!,fail. % code below may instantiate S2
3807 intersection_of_explicit_set_wf(S1,S2,R,_WF) :- is_definitely_maximal_set(S2), !, R=S1.
3808 intersection_of_explicit_set_wf(_S1,[],R,_WF) :-!, R=[].
3809 intersection_of_explicit_set_wf(avl_set(A1),I2,R,_WF) :-
3810 is_interval_closure_or_integerset(I2,From1,To1),
3811 !,
3812 intersect_avl_interval(A1,From1,To1,R).
3813 intersection_of_explicit_set_wf(I1,I2,R,_WF) :-
3814 ? intersection_with_interval_closure(I1,I2,R),!.
3815 intersection_of_explicit_set_wf(S1,S2,R,_WF) :-
3816 get_avl_sets(S1,S2,A1,A2),
3817 !, % if too large: better to apply normal intersection code ?
3818 % if one of the args is an interval this is already caught in kernel_objects calling intersection_with_interval_closure; see SetIntersectionBig.mch
3819 avl_domain(A1,ES), % A1 has the smaller height; important for e.g. SetIntersectionBig2.mch
3820 inter2(ES,A2,IRes),
3821 ord_list_to_avlset(IRes,R,intersection). % we have generated the elements in the right order already
3822 intersection_of_explicit_set_wf(Set1,Set2,R,WF) :-
3823 transform_global_sets_into_closure(Set1,closure(P1,T1,B1)),
3824 transform_global_sets_into_closure(Set2,closure(P2,T2,B2)),
3825 % gets called, e.g., for {x|x /: NATURAL1} /\ NATURAL1
3826 unify_closure_predicates(P1,T1,B1, P2,T2,B2 , NewP,NewT, NewB1,NewB2),
3827 debug:debug_println(9,intersection_of_two_closures(P1,P2,NewP,NewT)),
3828 conjunct_predicates([NewB1,NewB2],BI),
3829 % create a conjunction: can be much more efficient than seperately expanding;
3830 % also works well if one of the closures is infinite
3831 C = closure(NewP,NewT,BI),
3832 expand_custom_set_wf(C,R,intersection_of_explicit_set_wf,WF). % we could keep it symbolic; maybe use SYMBOLIC pref
3833 % to do: also use above for closure and AVL set with member(P,value(avl_set(A)))
3834 % we could also apply the same principle to difference_of_explicit_set
3835 % currently we enable intersection to be treated symbolically (not_symbolic_binary(intersection) commented out)
3836 % This means the above clause for intersection_of_explicit_set_wf is less useful
3837 % a special case; just for interval closures
3838 intersection_with_interval_closure(I1,I2,R) :-
3839 is_interval_closure_or_integerset(I1,From1,To1), nonvar(I2),
3840 intersection_with_interval_closure_aux(I2,From1,To1,R).
3841 intersection_with_interval_closure(avl_set(A1),I2,R) :-
3842 is_interval_closure_or_integerset(I2,From1,To1),
3843 !,
3844 intersect_avl_interval(A1,From1,To1,R).
3845
3846 % try and get AVL sets from two args; first AVL set is smaller one according to height
3847 get_avl_sets(avl_set(A1),S2,AA1,AA2) :- nonvar(S2), S2=avl_set(A2),
3848 ? (avl_height_compare(A1,A2,R), R=lt
3849 -> (AA1,AA2)=(A1,A2)
3850 ; (AA1,AA2)=(A2,A1)).
3851 %get_avl_sets(S1,S2,AA1,AA2) :- nonvar(S2),S2=avl_set(A2), get_avl_set_arg(S1,A1),
3852 % (avl_height_compare(A1,A2,R),R=gt -> (AA1,AA2)=(A2,A1) ; (AA1,AA2)=(A1,A2)).
3853
3854
3855 %intersection_with_interval_closure_aux(avl_set(A),...
3856 intersection_with_interval_closure_aux(I2,From1,To1,R) :-
3857 is_interval_closure_or_integerset(I2,From2,To2),!,
3858 intersect_intervals_with_inf(From1,To1,From2,To2,FromRes,ToRes),
3859 construct_interval_closure(FromRes,ToRes,R).
3860 % (is_interval_closure_or_integerset(R,F,T) -> print(ok(F,T)),nl ; print(ko),nl).
3861 intersection_with_interval_closure_aux(avl_set(A2),From1,To1,R) :-
3862 intersect_avl_interval(A2,From1,To1,R).
3863
3864 % intersect avl with interval
3865 % TO DO: expand interval if small (or small intersection with AVL) and use avl intersection
3866 intersect_avl_interval(_,From2,To2,_) :- (var(From2) ; var(To2)),!,fail.
3867 intersect_avl_interval(A1,From2,To2,R) :- avl_min(A1,int(Min)),
3868 geq_inf(Min,From2),
3869 geq_inf(To2,Min), avl_max(A1,int(Max)),
3870 geq_inf(To2,Max),
3871 % AVL fully contained in interval; no need to expand to list and back again
3872 !,
3873 construct_avl_set(A1,R).
3874 intersect_avl_interval(A1,From2,To2,R) :-
3875 avl_domain(A1,ES),
3876 inter_interval(ES,From2,To2,IRes),
3877 ord_list_to_avlset(IRes,R,intersect_avl_interval).
3878
3879 inter_interval([],_,_, []).
3880 inter_interval([IH|T],From2,To2, Res) :- IH = int(H),
3881 (geq_inf(To2,H) ->
3882 (geq_inf(H,From2) -> Res = [IH-true|Res2] ; Res = Res2),
3883 inter_interval(T,From2,To2,Res2)
3884 ; Res = [] % we have exceeded the upper limit of the interval
3885 ).
3886
3887 % also works with real/float intervals:
3888 intersect_intervals_with_inf(From1,To1,From2,To2,FromRes,ToRes) :-
3889 minimum_with_inf(To1,To2,ToRes),
3890 maximum_with_inf(From1,From2,FromRes).
3891
3892 % check if two intervals are disjoint
3893 disjoint_intervals_with_inf(From1,To1,From2,To2) :-
3894 intersect_intervals_with_inf(From1,To1,From2,To2,Low,Up),
3895 number(Up), number(Low), Low > Up.
3896
3897 inter2([],_, []).
3898 inter2([H|T],A1, Res) :-
3899 (avl_fetch(H,A1) -> Res = [H-true|Res2] ; Res = Res2), inter2(T,A1,Res2).
3900
3901 ord_list_to_avlset(OL,R) :- ord_list_to_avlset(OL,R,unknown).
3902 ord_list_to_avlset(OrdList,Res,Origin) :-
3903 % assumes that we have generated the elements in the right order already
3904 (OrdList=[] -> Res=[]
3905 ; check_sorted(OrdList,Origin),
3906 ord_list_to_avl(OrdList,ARes), Res=avl_set(ARes)).
3907
3908 % a version which accepts a list of values without -true
3909 % values have to be ground and already converted for use in avl_set
3910 sorted_ground_normalised_list_to_avlset(List,Res,PP) :-
3911 add_true_to_list(List,LT),
3912 ord_list_to_avlset_direct(LT,Res,PP).
3913
3914 add_true_to_list([],[]).
3915 add_true_to_list([H|T],[H-true|TT]) :- add_true_to_list(T,TT).
3916
3917 % the same, but without checking sorted (only use if you are really sure the list is sorted)
3918 ord_list_to_avlset_direct([],[],_).
3919 ord_list_to_avlset_direct([H|T],Res,_):-
3920 (T==[] -> H=Key-Val, Res = avl_set(node(Key,Val,0,empty,empty)) % slightly faster than calling ord_list_to_avl
3921 ; ord_list_to_avl([H|T],ARes), Res = avl_set(ARes)).
3922
3923 check_sorted([],_) :- !.
3924 check_sorted([H-_|T],Origin) :- !, check_sorted2(T,H,Origin).
3925 check_sorted(X,Origin) :- add_error_and_fail(ord_list_to_avlset,'Not a list of -/2 pairs: ',Origin:X).
3926
3927 check_sorted2([],_,_) :- !.
3928 check_sorted2([H-_|T],PH,Origin) :- PH @< H,!, check_sorted2(T,H,Origin).
3929 check_sorted2(X,Prev,Origin) :-
3930 add_error_and_fail(ord_list_to_avlset,'Not a sorted list of -/2 pairs: ',Origin:(X,Prev)).
3931
3932 % ------------------
3933
3934 :- use_module(kernel_freetypes,[is_maximal_freetype/1]).
3935 is_definitely_maximal_set(S) :- nonvar(S),
3936 is_definitely_maximal_set2(S).
3937 is_definitely_maximal_set2(freetype(ID)) :- is_maximal_freetype(ID).
3938 is_definitely_maximal_set2(global_set(GS)) :- is_maximal_global_set(GS).
3939 is_definitely_maximal_set2(closure(P,T,B)) :- is_definitely_maximal_closure(P,T,B).
3940 is_definitely_maximal_set2(avl_set(S)) :- quick_definitely_maximal_set_avl(S).
3941 is_definitely_maximal_set2([H|T]) :- nonvar(H), is_definitely_maximal_list(H,T). %, nl,print(maximal(H,T)),nl,nl.
3942 %H==pred_true, T == [pred_false]. % for some reason BOOL is sometimes presented this way
3943 is_definitely_maximal_set2(empty) :- % detect unwrapped AVL sets
3944 add_internal_error('Not a set: ',is_definitely_maximal_set2(empty)),fail.
3945 is_definitely_maximal_set2(node(A,B,C,D,E)) :-
3946 add_internal_error('Not a set: ',is_definitely_maximal_set2(node(A,B,C,D,E))),fail.
3947
3948 is_definitely_maximal_list(pred_true,T) :- nonvar(T), T=[_|_]. %
3949 is_definitely_maximal_list(pred_false,T) :- nonvar(T), T=[_|_].%
3950 is_definitely_maximal_list(fd(_,Type),T) :- nonvar(T),b_global_set_cardinality(Type,Card),
3951 % check if we have the same number of elements as the type: then the set must me maximal
3952 length_at_least(T,Card).
3953 % We could try and and also treat pairs
3954
3955 length_at_least(1,_) :- !. % we have already removed 1 element; T can be nil
3956 length_at_least(N,T) :- nonvar(T), T=[_|TT], N1 is N-1, length_at_least(N1,TT).
3957
3958 is_definitely_maximal_closure(_,_,b(truth,_Pred,_)) :- !.
3959 is_definitely_maximal_closure(P,T,B) :- is_cartesian_product_closure_aux(P,T,B,S1,S2),!,
3960 is_definitely_maximal_set(S1),is_definitely_maximal_set(S2).
3961 is_definitely_maximal_closure(P,T,B) :-
3962 is_full_powerset_or_relations_or_struct_closure(closure(P,T,B),Sets),
3963 l_is_definitely_maximal_set(Sets).
3964
3965 l_is_definitely_maximal_set([]).
3966 l_is_definitely_maximal_set([H|T]) :- is_definitely_maximal_set(H), l_is_definitely_maximal_set(T).
3967
3968 % check if we have an AVL tree covering all elements of the underlying type
3969 quick_definitely_maximal_set_avl(AVL) :-
3970 AVL=node(El,_True,_,_Left,_Right),
3971 quick_definitely_maximal_set_avl_aux(El,AVL).
3972 quick_definitely_maximal_set_avl_aux(El,AVL) :-
3973 try_get_finite_max_card_from_ground_value(El,Card),
3974 % this could fail if El contains empty sets !
3975 % also: it must fail if Card is infinite (no avl_set can be maximal)
3976 (Card < 1000 -> true
3977 ; preferences:preference(solver_strength,SS), Card < 1000+SS*100
3978 ), % otherwise too expensive a check avl_size
3979 quick_avl_approximate_size(AVL,MaxSize),
3980 MaxSize >= Card, % otherwise no sense in computing avl_size, which is linear in size of AVL
3981 avl_size(AVL,Size),
3982 %(MaxSize>=Size -> print(ok(Size,all(Card))),nl ; print('**** ERROR: '), print(Size),nl,trace),
3983 Size=Card.
3984
3985 % check if we have an AVL function with domain covering all elements of the underlying type
3986 quick_definitely_maximal_total_function_avl(AVL) :-
3987 AVL=node(El,_True,_,_Left,_Right),
3988 El=(DomEl,_),
3989 quick_definitely_maximal_set_avl_aux(DomEl,AVL), % the size is exactly the size of the domain
3990 is_avl_partial_function(AVL).
3991
3992 % ----------------------
3993 % set_subtraction /
3994 difference_of_explicit_set(S1,S2,R) :-
3995 difference_of_explicit_set_wf(S1,S2,R,no_wf_available).
3996 % this is called with first argument nonvar (for set_subtraction operator):
3997 difference_of_explicit_set_wf(_S1,S2,R,_) :-
3998 is_definitely_maximal_set(S2), !, R=[].
3999 difference_of_explicit_set_wf(S1,S2,R,_) :- nonvar(S2), S2=[],!, R=S1.
4000 difference_of_explicit_set_wf(S1,S2,R,_) :-
4001 %nonvar(S1),
4002 ? is_very_large_maximal_global_set(S1,Type), !, % TO DO: also for freetype ? cartesian products,...
4003 /* we have a complement-set */
4004 complement_set(S2,Type,R).
4005 difference_of_explicit_set_wf(S1,S2,Result,_) :-
4006 is_not_member_value_closure(S1,Type,MS1),
4007 nonvar(MS1), is_custom_explicit_set(MS1,difference_of_explicit_set_wf),!,
4008 union_complement_set(MS1,S2,Type,Result).
4009 difference_of_explicit_set_wf(_,S2,_,_) :- var(S2), !, fail. % then we cannot do anything below
4010 difference_of_explicit_set_wf(S1,S2,R,WF) :-
4011 is_not_member_value_closure(S2,_Type,MS2), nonvar(MS2),
4012 intersection_of_explicit_set_wf(MS2,S1,R,WF),!.
4013 difference_of_explicit_set_wf(I1,I2,R,_) :-
4014 is_interval_closure_or_integerset(I1,From1,To1),
4015 is_interval_closure_or_integerset(I2,From2,To2),
4016 difference_interval(From1,To1,From2,To2,FromRes,ToRes),
4017 % TO DO: also treat case when difference yields two disjoint intervals
4018 % i.e., do not fail and forget info about interval bounds in case we cannot compute difference as a an interval, e.g., INT - {0}
4019 !,
4020 construct_interval_closure(FromRes,ToRes,R).
4021 difference_of_explicit_set_wf(avl_set(A1),S2,R,WF) :-
4022 (S2=avl_set(A2) ;
4023 ground_value(S2), expand_and_convert_to_avl_set_unless_very_large(S2,A2,WF)),!,
4024 avl_height(A2,H2),
4025 %avl_min(A1,Min1),avl_max(A1,Max1), avl_min(A2,Min2),avl_max(A2,Max2), avl_height(A1,H1),nl,print(diff(avl(H1,Min1,Max1),avl(H2,Min2,Max2))),nl,
4026 avl_height(A1,H1),
4027 ((H2<2 -> true ; H1 > H2+1) % then it is more efficient to expand A2 and remove the A2 elements from A1;
4028 % note that difference_of_explicit_set2 now also sometimes expands both:
4029 % exact threshold when it is beneficial: difference_of_explicit_set2/3
4030 % for {x|x:1..200000 & x mod 2 = 0} - {y|y:2500..29010 & y mod 2 = 0} -> 150 ms vs 80 ms avl(17,int(2),int(200000)),avl(14,int(2500),int(29010)
4031 % {x|x:1..200000 & x mod 2 = 0} - {y|y:2500..59010 & y mod 2 = 0} -> 180 ms vs 80 ms avl(17,int(2),int(200000)),avl(15,int(2500),int(59010))
4032 % {x|x:1..200000 & x mod 2 = 0} - {y|y:500..159010 & y mod 2 = 0} -> 180 ms vs 250 ms avl(17,int(2),int(200000)),avl(17,int(500),int(159010))
4033 -> expand_custom_set_to_sorted_list(S2,ES,_,difference_of_explicit_set1,WF),
4034 difference_of_explicit_set3(ES,A1,R)
4035 ; expand_custom_set_to_sorted_list(avl_set(A1),ES,Done,difference_of_explicit_set2,WF),
4036 difference_of_explicit_set2(ES,H1,A2,H2,R,Done)).
4037 difference_of_explicit_set_wf(S1,S2,R,WF) :-
4038 (S2=avl_set(A2) ;
4039 ground_value(S2), expand_and_convert_to_avl_set_unless_very_large(S2,A2,WF)),!,
4040 avl_height(A2,A2Height),
4041 difference_with_avl(S1,A2,A2Height,R,WF).
4042 % to do: we could detect same_texpr_body for two closures and return R=[]
4043
4044 :- use_module(avl_tools,[avl_approximate_size_from_height/2]).
4045 :- use_module(bsyntaxtree,[safe_create_texpr/4, create_texpr/4, conjunct_predicates/2, mark_bexpr_as_symbolic/2]).
4046 difference_with_avl(S1,A2,A2Height,R,_) :-
4047 is_closure_or_integer_set(S1,[ID],[T],B),
4048 % check if the first argument is infinite; then do the difference set symbolically
4049 % this could supersed the complement set construction and be generalised to other sets apart from avl_sets as A2
4050 avl_approximate_size_from_height(A2Height,A2Size),
4051 Limit is max(A2Size*10,1000000), % if A2 is more than 10% size of S1, probably better to compute difference explicitly
4052 is_very_large_or_symbolic_closure([ID],[T],B,Limit),
4053 !, % TO DO: also allow multiple identifiers
4054 create_texpr(identifier(ID),T,[],TID),
4055 create_texpr(value(avl_set(A2)),set(T),[],A2Value),
4056 create_texpr(not_member(TID,A2Value),pred,[],NotMemA2),
4057 conjunct_predicates([B,NotMemA2],NewBody),
4058 mark_bexpr_as_symbolic(NewBody,NewBodyS),
4059 R = closure([ID],[T],NewBodyS).
4060 difference_with_avl(S1,A2,A2Height,R,WF) :-
4061 (nonvar(S1),S1=avl_set(A1) -> avl_height(A1,H1) ; H1=unknown),
4062 expand_custom_set_to_sorted_list(S1,ES,Done,difference_of_explicit_set3,WF),
4063 difference_of_explicit_set2(ES,H1,A2,A2Height,R,Done).
4064
4065
4066 % construct complement of a set
4067 union_complement_set(S1,S2,Type,Result) :-
4068 ground_value_check(S2,G2),
4069 when(nonvar(G2),union_complement_set2(S1,S2,Type,Result)).
4070 union_complement_set2(S1,S2,Type,Result) :-
4071 union_of_explicit_set(S1,S2,S12),
4072 construct_complement_closure_if_necessary(S12,Type,R),
4073 kernel_objects:equal_object(R,Result,union_complement_set2).
4074
4075 % construct complement of a set
4076 complement_set(S2,Type,Result) :-
4077 ground_value_check(S2,G2),
4078 when(nonvar(G2),complement_set2(S2,Type,Result)).
4079 complement_set2(S2,Type,Result) :-
4080 is_not_member_value_closure(S2,Type,MS2),!, % complement of complement
4081 kernel_objects:equal_object(MS2,Result,complement_set2).
4082 complement_set2(S2,Type,Result) :-
4083 try_expand_and_convert_to_avl_with_check(S2,ExpandedS2,difference_complement_set),
4084 construct_complement_closure_if_necessary(ExpandedS2,Type,R),
4085 kernel_objects:equal_object(R,Result,complement_set2).
4086
4087 :- block construct_complement_closure_if_necessary(-,?,?).
4088 construct_complement_closure_if_necessary(Set,TYPE,R) :-
4089 (Set=[] -> b_type2_set(TYPE,R)
4090 ; is_not_member_value_closure(Set,TYPE,MS) -> R=MS % complement of complement
4091 ; construct_complement_closure(Set,TYPE,R)).
4092
4093 % succeeds if difference of two intervals is also an interval
4094 % SourceLow..SourceUp \ DiffLow..DiffUp
4095 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,9,11,1,8)).
4096 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,9,inf,1,8)).
4097 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,10,12,1,9)).
4098 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,11,12,1,10)).
4099 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,12,13,1,10)).
4100 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,11,inf,1,10)).
4101 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,inf,11,inf,1,10)).
4102 % :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,9,8,1,10)). % 9..8 empty not detected
4103 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,1,8,9,10)).
4104 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,1,10,11,10)). % empty
4105 :- assert_must_succeed(custom_explicit_sets:difference_interval(1,10,1,inf,inf,10)).
4106 :- assert_must_succeed(custom_explicit_sets:difference_interval(3,10,1,2,3,10)).
4107 :- assert_must_succeed(custom_explicit_sets:difference_interval(3,inf,1,2,3,inf)).
4108 :- assert_must_succeed(custom_explicit_sets:difference_interval(3,10,1,3,4,10)).
4109 :- assert_must_succeed(custom_explicit_sets:difference_interval(3,10,1,9,10,10)).
4110 :- assert_must_succeed(custom_explicit_sets:difference_interval(3,10,1,10,11,10)).
4111 difference_interval(SourceLow,SourceUp,DiffLow,DiffUp,ResLow,ResUp) :-
4112 (nonvar(SourceLow),nonvar(DiffLow),nonvar(DiffUp),
4113 geq_inf(SourceLow,DiffLow)
4114 -> % DiffLow is to left of SourceLow
4115 inc(DiffUp,D1),
4116 maximum_with_inf(D1,SourceLow,ResLow),
4117 ResUp=SourceUp % also works if SourceUp is a variable
4118 ; nonvar(DiffUp),nonvar(SourceUp),nonvar(DiffLow),
4119 geq_inf(DiffUp,SourceUp)
4120 -> % DiffUp is to right of SourceUp
4121 ResLow=SourceLow, % also works if SourceLow is a variable
4122 dec(DiffLow,D1),
4123 minimum_with_inf(SourceUp,D1,ResUp)).
4124
4125 inc(N,R) :- N==inf,!,R=inf.
4126 inc(N,N1) :- N1 is N+1.
4127 dec(N,R) :- N==inf,!,R=inf.
4128 dec(N,N1) :- N1 is N-1.
4129
4130 :- use_module(library(ordsets), [ord_subtract/3]).
4131 :- block difference_of_explicit_set2(?,?,?,?,?,-).
4132 difference_of_explicit_set2(ES,A1Height,A2,A2Height,R,_) :-
4133 (number(A1Height), A1Height+4 >= A2Height -> true
4134 ; A2Height < 5
4135 ; Limit is 2**(A2Height-4),
4136 length_larger_than(ES,Limit)
4137 % TO DO: we could try and pass sizes from specific closures to this predicate
4138 ),
4139 % A1 is not much larger than A2, then it is probably faster to use ord_subtract on expanded A2
4140 % {x|x mod 2 =0 & x:1..10000} - {y|y mod 3 =0 & y : 1..200000} : still more efficient with ord_subtract
4141 !,
4142 avl_domain(A2,A2Expanded),
4143 ord_subtract(ES,A2Expanded,OrdRes),
4144 sorted_ground_normalised_list_to_avlset(OrdRes,AVL,difference_of_explicit_set2),
4145 equal_object(AVL,R).
4146 difference_of_explicit_set2(ES,_A1Height,A2,_A2Height,R,_) :-
4147 avl_min(A2,Min),
4148 diff1(ES,Min,A2,IRes),
4149 ord_list_to_avlset(IRes,AVL,difference), % we have generated the elements in the right order already
4150 equal_object(AVL,R). % due to delays in expansion the result could be instantiated
4151
4152
4153 length_larger_than([_|T],Limit) :-
4154 (Limit<1 -> true
4155 ; L1 is Limit-1, length_larger_than(T,L1)).
4156
4157 diff1([],_, _,[]).
4158 diff1([H|T],Min,A1, Res) :-
4159 (H @< Min -> Res = [H-true|Res2],diff1(T,Min,A1,Res2)
4160 ; diff2([H|T],A1,Res)).% TO DO: compute avl_max
4161
4162 diff2([],_, []).
4163 diff2([H|T],A1, Res) :-
4164 (avl_fetch(H,A1) -> Res = Res2 ; Res = [H-true|Res2]), diff2(T,A1,Res2).
4165
4166 % another version to be used when second set small in comparison to first set
4167 difference_of_explicit_set3([],A1,Res) :- construct_avl_set(A1,AVL),
4168 equal_object(AVL,Res). % due to delay in expansion, Res could now be instantiated
4169 difference_of_explicit_set3([H|T],A1,ARes) :-
4170 (avl_delete(H,A1,_True,A2) -> true ; A2=A1),
4171 difference_of_explicit_set3(T,A2,ARes).
4172
4173 % -------------------------
4174
4175 % a version of add_element_to_explicit_set where we have already done the groundness check
4176 add_ground_element_to_explicit_set_wf(avl_set(A),Element,R,WF) :- !,
4177 convert_to_avl_inside_set_wf(Element,AEl,WF),
4178 avl_store(AEl,A,true,A2),!,R=avl_set(A2).
4179 add_ground_element_to_explicit_set_wf(Set,Element,R,WF) :-
4180 add_element_to_explicit_set_wf(Set,Element,R,WF).
4181
4182 add_element_to_explicit_set_wf(global_set(GS),_,R,_) :- is_maximal_global_set(GS), !, R=global_set(GS).
4183 add_element_to_explicit_set_wf(freetype(ID),_,R,_) :- is_maximal_freetype(ID),!, R=freetype(ID).
4184 add_element_to_explicit_set_wf(avl_set(A),Element,R,WF) :-
4185 ground_value(Element), %% was element_can_be_added_or_removed_to_avl(Element),
4186 convert_to_avl_inside_set_wf(Element,AEl,WF),
4187 avl_store(AEl,A,true,A2),!,R=avl_set(A2). /* AVL not normalised */
4188 /* do we need to add support for (special) closures ??
4189 add_element_to_explicit_set_wf(Clos,Element,R,_) :- nonvar(Element),Element=int(X), nonvar(X),
4190 is_interval_closure_or_integerset(Clos,Low,Up), ground(Low), ground(Up),
4191 union_of_interval(X,X,Low,Up,FromRes,ToRes),
4192 !,
4193 construct_interval_closure(FromRes,ToRes,R).
4194 % not-member closure not dealt with here
4195 */
4196
4197 element_can_be_added_or_removed_to_avl(Element) :-
4198 ground_value(Element),
4199 does_not_contain_closure(Element).
4200 ground_element_can_be_added_or_removed_to_avl(Element) :- /* use if you know the element to be ground */
4201 does_not_contain_closure(Element).
4202
4203 % does not contain closure or infinite other sets
4204 does_not_contain_closure([]).
4205 does_not_contain_closure([H|T]) :-
4206 (simple_value(H) -> true /* TO DO: check if we could have a closure at the end ?? */
4207 ; does_not_contain_closure(H),list_does_not_contain_closure(T)).
4208 does_not_contain_closure(fd(_,_)).
4209 does_not_contain_closure(pred_true /* bool_true */).
4210 does_not_contain_closure(pred_false /* bool_false */).
4211 does_not_contain_closure(int(_)).
4212 does_not_contain_closure(string(_)).
4213 does_not_contain_closure(term(_)). % real/floating number
4214 does_not_contain_closure((X,Y)) :- does_not_contain_closure(X), does_not_contain_closure(Y).
4215 does_not_contain_closure(avl_set(_)).
4216 does_not_contain_closure(global_set(G)) :- \+ is_infinite_global_set(G,_).
4217 %does_not_contain_closure(freetype(_)).
4218 does_not_contain_closure(freeval(_,_,Value)) :- does_not_contain_closure(Value).
4219 does_not_contain_closure(rec(Fields)) :- does_not_contain_closure_fields(Fields).
4220
4221 does_not_contain_closure_fields([]).
4222 does_not_contain_closure_fields([field(_,Val)|T]) :- does_not_contain_closure(Val),
4223 does_not_contain_closure_fields(T).
4224
4225 list_does_not_contain_closure([]).
4226 list_does_not_contain_closure([H|T]) :-
4227 does_not_contain_closure(H),list_does_not_contain_closure(T).
4228 list_does_not_contain_closure(avl_set(_)).
4229 list_does_not_contain_closure(global_set(G)) :- \+ is_infinite_global_set(G,_).
4230
4231 simple_value(fd(_,_)).
4232 simple_value(pred_true /* bool_true */).
4233 simple_value(pred_false /* bool_false */).
4234 simple_value(int(_)).
4235 simple_value((A,B)) :- simple_value(A), simple_value(B).
4236 simple_value(string(_)).
4237
4238
4239 % a version of the above which throws error if element cannot be added
4240 % assumes element_can_be_added_or_removed_to_avl has been checked
4241 remove_element_from_explicit_set(avl_set(A),Element,R) :-
4242 element_can_be_added_or_removed_to_avl(Element), % remove check?
4243 convert_to_avl_inside_set(Element,AEl), !,
4244 direct_remove_element_from_avl(A,AEl,R).
4245 remove_element_from_explicit_set(ES,Element,R) :-
4246 add_internal_error('Cannot remove element from explicit set:',remove_element_from_explicit_set(ES,Element,R)).
4247
4248 direct_remove_element_from_avl(A,AEl,R) :-
4249 avl_delete(AEl,A,_True,A2),
4250 construct_avl_set(A2,R). /* AVL not normalised */
4251
4252 /* same as remove but element can be absent */
4253 delete_element_from_explicit_set(avl_set(A),Element,R) :-
4254 element_can_be_added_or_removed_to_avl(Element),
4255 convert_to_avl_inside_set(Element,AEl), !,
4256 (avl_delete(AEl,A,_True,A2)
4257 -> construct_avl_set(A2,R)
4258 ; R = avl_set(A)
4259 ). /* AVL not normalised */
4260
4261 is_maximal_global_set(GS) :- is_maximal_global_set(GS,_Type).
4262 is_maximal_global_set(GS,_) :- var(GS),!,fail.
4263 is_maximal_global_set('INTEGER',Type) :- !, Type=integer.
4264 is_maximal_global_set('REAL',Type) :- !, Type=real.
4265 is_maximal_global_set('FLOAT',_) :- !, fail.
4266 is_maximal_global_set('STRING',Type) :- !, Type=string.
4267 is_maximal_global_set(GS,global(GS)) :-
4268 \+ kernel_objects:integer_global_set(GS).
4269
4270 % To do: maybe get rid of all complement set code; add in_difference_set as symbolic binary operator
4271 %is_very_large_maximal_global_set(X,_) :- print(very(X)),nl,fail.
4272 is_very_large_maximal_global_set(closure(P,T,B),Type) :- is_definitely_maximal_closure(P,T,B),
4273 couplise_list(T,Type).
4274 is_very_large_maximal_global_set(global_set('INTEGER'),integer).
4275 is_very_large_maximal_global_set(global_set('STRING'),string).
4276 is_very_large_maximal_global_set(global_set('REAL'),string).
4277 is_very_large_maximal_global_set(freetype(ID),freetype(ID)) :- is_infinite_freetype(ID).
4278
4279
4280
4281 remove_minimum_element_custom_set(avl_set(S),X,RES) :- !,
4282 avl_del_min(S,X,_True,Res0),
4283 (empty_avl(Res0) -> RES=[] ; RES = avl_set(Res0)).
4284 %remove_minimum_element_custom_set(closure(P,T,B),X,RES) :-
4285 % is_interval_closure_or_integerset(Clos,Low,Up),!,
4286 % X = Low, TO DO: construct new interval closure
4287 remove_minimum_element_custom_set(CS,X,RES) :-
4288 expand_custom_set_to_list(CS,ECS,Done,remove_minimum_element_custom_set),
4289 remove_minimum_element_custom_set2(ECS,X,RES,Done).
4290
4291 :- block remove_minimum_element_custom_set2(?,?,?,-).
4292 % wait until Done: otherwise the Tail of the list could be instantiated by somebody else; interfering with expand_custom_set_to_list
4293 remove_minimum_element_custom_set2([H|T],X,RES,_) :- equal_object((H,T),(X,RES)).
4294
4295
4296 min_of_explicit_set_wf(avl_set(S),Min,_) :- !, avl_min(S,Min).
4297 min_of_explicit_set_wf(Clos,Min,WF) :-
4298 is_interval_closure_or_integerset(Clos,Low,Up),
4299 (Low == minus_inf
4300 -> add_wd_error('minimum of unbounded infinite set not defined:',Clos,WF)
4301 ; cs_greater_than_equal(Up,Low),
4302 Min=int(Low)).
4303
4304 cs_greater_than_equal(X,Y) :-
4305 ((X==inf;Y==minus_inf) -> true ; kernel_objects:less_than_equal_direct(Y,X)).
4306
4307
4308 max_of_explicit_set_wf(avl_set(S),Max,_) :- !,avl_max(S,Max).
4309 max_of_explicit_set_wf(Clos,Max,WF) :-
4310 is_interval_closure_or_integerset(Clos,Low,Up),
4311 (Up==inf
4312 -> add_wd_error('maximum of unbounded infinite set not defined:',Clos,WF)
4313 ; cs_greater_than_equal(Up,Low),
4314 Max=int(Up)).
4315
4316 % ------------- SIGMA/PI --------------
4317
4318 % compute sum or product of an integer set:
4319 sum_or_mul_of_explicit_set(avl_set(S),SUMorMUL,Result) :-
4320 avl_domain(S,Dom),
4321 (SUMorMUL=sum -> simple_sum_list(Dom,0,R) ; simple_mul_list(Dom,1,R)),
4322 Result = int(R).
4323 sum_or_mul_of_explicit_set(CS,SUMorMUL,Result) :- SUMorMUL == sum,
4324 is_interval_closure(CS,Low,Up),
4325 sum_interval(Low,Up,Result),
4326 sum_interval_clpfd_prop(Low,Up,Result).
4327
4328 :- block sum_interval(-,?,?), sum_interval(?,-,?).
4329 sum_interval(Low,Up,_) :- (\+ number(Low) ; \+ number(Up)),!,
4330 add_error(sum_interval,'Cannot compute sum of interval: ',Low:Up),fail.
4331 sum_interval(Low,Up,Result) :- Low>Up,!, Result=int(0).
4332 sum_interval(Low,Up,Result) :-
4333 R is ((1+Up-Low)*(Low+Up)) // 2, % generalisation of Gauss formula k*(k+1)//2
4334 Result = int(R).
4335
4336 sum_interval_clpfd_prop(Low,Up,Result) :-
4337 preferences:preference(use_clpfd_solver,true), Result=int(R),
4338 var(R), % we haven't computed the result yet; the bounds are not known; set up constraint propagation rules
4339 !,
4340 try_post_constraint((Low #>= 0) #=> (R #> 0)), % we could provide better bounds here for negative numbers
4341 try_post_constraint(((Low #=< Up) #\/ (R #\= 0)) #=> (R #= ((1+Up-Low)*(Low+Up))//2)),
4342 try_post_constraint((Low #> Up) #=> (R #= 0)).
4343 % not working yet: x = SIGMA(i).(i:-3..n|i) & x=0 & n< -1
4344 sum_interval_clpfd_prop(_,_,_).
4345
4346 simple_sum_list([],A,A).
4347 simple_sum_list([int(H)|T],Acc,R) :- NA is Acc+H, simple_sum_list(T,NA,R).
4348 simple_mul_list([],A,A).
4349 simple_mul_list([int(H)|T],Acc,R) :- NA is Acc*H, simple_mul_list(T,NA,R).
4350
4351
4352 /*
4353 direct_product_symbolic(S,R,Res) :- % NOT YET FINISHED
4354 nonvar(S), S=closure(PS,[T1,TS2],RS),
4355 nonvar(R), R=closure(PR,[T1,TR1],RR),
4356 is_lambda_value_domain_closure(PS,TS,RS, SDomainValue,SExpr),
4357 is_lambda_value_domain_closure(PR,TR,RR, RDomainValue,RExpr),
4358 construct_closure(['zzz','_lambda_result_'],[T1,couple(TR1,TR2)],
4359 member(zzz,SDomainValue) , member(zzz,RDomainValue), eq(lambda,pair(SExpr,RExpr))).
4360 */
4361
4362 % we assume that try_expand_and_convert_to_avl_unless_very_large already called on arguments
4363 direct_product_explicit_set(S,R,Res) :-
4364 nonvar(R), %is_custom_explicit_set(R,direct_product),
4365 nonvar(S), %is_custom_explicit_set(S,direct_product),
4366 direct_product_explicit_set_aux(S,R,Res).
4367 %direct_product_explicit_set_aux(S,R,Res) :- (S = closure(_,_,_) ; R = closure(_,_,_)),
4368 % print_term_summary(direct_product_explicit_set_aux(S,R,Res)),nl,
4369 % % TO DO: generate closure
4370 % fail.
4371 direct_product_explicit_set_aux(avl_set(AS),avl_set(AR),Res) :-
4372 % the expansion guarantees that we have the lists ES and ER then in sorted order
4373 avl_domain(AS,ES), % -> expand_custom_set(avl_set(AS),ES),
4374 avl_domain(AR,ER), % -> expand_custom_set(avl_set(AR),ER),
4375 direct_product3(ES,ER,DPList),
4376 ord_list_to_avlset(DPList,DPAVL,direct_product), % is it really ordered ? findall must also return things ordered!
4377 equal_object(DPAVL,Res,direct_product_explicit_set).
4378
4379 direct_product3([],_Rel2,[]).
4380 direct_product3([(From,To1)|T1],Rel2,Res) :-
4381 get_next_mapped_to_eq(T1,From,TTo,Tail1), ToList1 = [To1|TTo],
4382 get_next_mapped_to(Rel2,From,ToList2,Tail2),
4383 calc_direct_product(ToList1,From,ToList2,Res,Rest),
4384 (Tail2=[] -> Rest=[] ; direct_product3(Tail1,Tail2,Rest)).
4385
4386 % get all elements which map to From, supposing that the list is sorted & we have already had a match
4387 get_next_mapped_to_eq([],_,[],[]).
4388 get_next_mapped_to_eq([(From2,To2)|T],From,Result,Tail) :-
4389 (From=From2 -> Result = [To2|RR], get_next_mapped_to_eq(T,From,RR,Tail)
4390 ; Result = [], Tail = [(From2,To2)|T]
4391 ).
4392
4393 % get all elements which map to From, supposing the list is sorted
4394 get_next_mapped_to([],_,[],[]).
4395 get_next_mapped_to([(From2,To2)|T],From,Result,Tail) :-
4396 (From=From2 -> Result = [To2|RR], get_next_mapped_to_eq(T,From,RR,Tail)
4397 ; From2 @> From -> Result = [], Tail = [(From2,To2)|T]
4398 ; get_next_mapped_to(T,From,Result,Tail)
4399 ).
4400
4401 calc_direct_product([],_From,_,Tail,Tail).
4402 calc_direct_product([To1|T1],From,To2List,Result,Tail) :-
4403 findall((From,(To1,To2))-true,member(To2,To2List),Result,ResResult),
4404 calc_direct_product(T1,From,To2List,ResResult,Tail).
4405
4406 % TO DO: maybe also add a special rule for infinite R such as event_b_identity ?
4407 domain_restriction_explicit_set_wf(S,R,Res,WF) :- /* S <| R */
4408 nonvar(R),
4409 (nonvar(S),is_one_element_custom_set(S,El),R \= closure(_,_,_) ->
4410 domain_restrict_singleton_element(El,R,Res)
4411 ; restriction_explicit_set_wf(S,R,Res,domain,pred_true,WF)).
4412 domain_subtraction_explicit_set_wf(S,R,Res,WF) :- /* S <<| R */
4413 (nonvar(S),is_one_element_custom_set(S,El), nonvar(R), R=avl_set(AVL) ->
4414 avl_domain_subtraction_singleton(AVL,El,ARes),
4415 construct_avl_set(ARes,Res) % TO DO: use this also when S is small and R large
4416 ; restriction_explicit_set_wf(S,R,Res,domain,pred_false,WF)).
4417 range_restriction_explicit_set_wf(R,S,Res,WF) :- /* R |> S */
4418 restriction_explicit_set_wf(S,R,Res,range,pred_true,WF).
4419 range_subtraction_explicit_set_wf(R,S,Res,WF) :- /* R |>> S */
4420 restriction_explicit_set_wf(S,R,Res,range,pred_false,WF).
4421
4422
4423 domain_restrict_singleton_element(El,R,Res) :- /* {El} <| R ; TO DO maybe apply this technique for "small" sets as well */
4424 nonvar(R), is_custom_explicit_set(R,domain_restrict_singleton_element),
4425 expand_and_convert_to_avl_set(R,AR,domain_restrict_singleton_element,''), % can generate ARel=empty; will fail if not possible to convert
4426 findall((El,Z)-true, avl_fetch_pair(El,AR,Z), RTuples),
4427 ord_list_to_avlset(RTuples,Res,domain_restrict_singleton_element).
4428
4429 restriction_explicit_set_wf(Set,Rel,Res,_RanOrDom,AddWhen,WF) :- Set==[],!,
4430 (AddWhen=pred_false
4431 -> equal_object_wf(Rel,Res,restriction_explicit_set_wf,WF) % {} <<| Rel = Rel |>> {} = Rel
4432 ; kernel_objects:empty_set_wf(Res,WF)
4433 ).
4434 restriction_explicit_set_wf(Set,Rel,Res,_RanOrDom,AddWhen,WF) :- is_definitely_maximal_set(Set),!,
4435 (AddWhen=pred_true
4436 -> equal_object_wf(Rel,Res,restriction_explicit_set_wf,WF) % TYPE <| Rel = Rel |> TYPE = Rel
4437 ; kernel_objects:empty_set_wf(Res,WF)
4438 ).
4439 restriction_explicit_set_wf(_,Rel,_,_,_,_) :- var(Rel),!,fail.
4440 restriction_explicit_set_wf(Set,closure(Paras,Types,Body),Res,RanOrDom,AddWhen,WF) :-
4441 % perform symbolic treatment by adding restriction predicate to Body
4442 !,
4443 (RanOrDom=domain
4444 -> get_domain_id_or_expr(Paras,Types,TID,TT)
4445 ; get_range_id_or_expr(Paras,Types,TID,TT)
4446 ),
4447 TSet=b(value(Set),set(TT),[]),
4448 (AddWhen = pred_true
4449 -> PRED = member(TID,TSet)
4450 ; PRED = not_member(TID,TSet) ),
4451 conjunct_predicates([b(PRED,pred,[]),Body],NewBody),
4452 % translate:print_bexpr(NewBody),nl,
4453 try_expand_and_convert_to_avl_with_catch_wf(closure(Paras,Types,NewBody),Res,restriction_explicit_set_wf,WF).
4454 restriction_explicit_set_wf(Set,Rel,Res,RanOrDom,AddWhen,WF) :-
4455 is_custom_explicit_set(Rel,restriction_explicit_set_wf),
4456 expand_and_convert_to_avl_set(Rel,ARel,restriction_explicit_set_wf,''), % can generate ARel=empty; will fail if not possible to convert
4457 avl_domain(ARel,ERel), % -> expand_custom_set(avl_set(ARel),ERel),
4458 %try_expand_and_convert_to_avl_unless_large_wf(Set,ES,WF),
4459 (nonvar(Set),Set=avl_set(AVLS)
4460 -> restrict2_avl(ERel,AVLS,DRes,RanOrDom,AddWhen,Done)
4461 ; restrict2(ERel,Set,DRes,RanOrDom,AddWhen,Done,WF)
4462 ),
4463 finish_restriction(Done,DRes,Res).
4464
4465 % extract domain expression for domain restriction/subtraction predicate:
4466 get_domain_id_or_expr([DR],[couple(TD,TR)], PRJ1, TD) :- !, % special case: just one parameter in closure
4467 TID = b(identifier(DR),couple(TD,TR),[]),
4468 PRJ1 = b(first_of_pair(TID),TD,[]).
4469 get_domain_id_or_expr([D1|Paras],[TD1|Types],Expr,Type) :-
4470 get_dom_couple_aux(Paras,Types, b(identifier(D1),TD1,[]), TD1, Expr,Type).
4471
4472 get_dom_couple_aux([_RangeID],[_], AccExpr, AccType, Expr, Type) :- !, Expr=AccExpr, Type=AccType.
4473 get_dom_couple_aux([D2|TParas],[TD2|Types], AccExpr, AccType, Expr, Type) :-
4474 TID2 = b(identifier(D2),TD2,[]),
4475 NewAccType = couple(AccType,TD2),
4476 NewAcc = b(couple(AccExpr,TID2),NewAccType,[]),
4477 get_dom_couple_aux(TParas,Types,NewAcc,NewAccType,Expr,Type).
4478
4479 :- use_module(library(lists),[last/2]).
4480 % extract range expression for range restriction/subtraction predicate:
4481 get_range_id_or_expr( [DR],[CType], PRJ2, TR) :- !, % special case: just one parameter in closure
4482 CType = couple(TD,TR),
4483 TID = b(identifier(DR),CType,[]),
4484 PRJ2 = b(second_of_pair(TID),TD,[]).
4485 get_range_id_or_expr( [_|Paras],[_|Types], b(identifier(R),TR,[]), TR) :-
4486 last(Paras,R), last(Types,TR).
4487
4488 :- block finish_restriction(-,?,?).
4489 finish_restriction(_,DRes,Res) :-
4490 ord_list_to_avlset(DRes,Restriction,restriction),
4491 equal_object(Restriction,Res,finish_restriction). % as we may block below: we need to use equal_object
4492
4493 restrict2([],_,[],_,_,done,_WF).
4494 restrict2([(From,To)|T],S,Res,RanOrDom,AddWhen,Done,WF) :-
4495 (RanOrDom==domain -> El=From ; El=To),
4496 kernel_equality:membership_test_wf(S,El,MemRes,WF), % TO DO: WF Version !!
4497 /* this only makes sense once we have the full result as argument:
4498 (nonvar(MemRes) -> true % it is already decided
4499 ; AddWhen=pred_true -> kernel_equality:membership_test_wf(Res,(From,To),MemRes,WF)
4500 ; kernel_equality:membership_test_wf(Res,(From,To),InResult,WF), bool_pred:negate(InResult,MemRes)
4501 ), */
4502 restrict3(MemRes,From,To,T,S,Res,RanOrDom,AddWhen,Done,WF).
4503 :- block restrict3(-, ?,?, ?,?,?, ?,?,?,?).
4504 restrict3(MemRes, From,To, T,S,Res, RanOrDom,AddWhen,Done,WF) :-
4505 (AddWhen=MemRes -> Res = [(From,To)-true|TRes]
4506 ; Res=TRes),
4507 restrict2(T,S,TRes,RanOrDom,AddWhen,Done,WF).
4508
4509 % optimised version when second set is also an AVL tree: less blocking,...
4510 restrict2_avl([],_,[],_,_,done).
4511 restrict2_avl([(From,To)|T],AVLS,Res,RanOrDom,AddWhen,Done) :-
4512 fetch(RanOrDom,From,To,AVLS,MemRes),
4513 (AddWhen=MemRes -> Res = [(From,To)-true|TRes]
4514 ; Res=TRes),
4515 restrict2_avl(T,AVLS,TRes,RanOrDom,AddWhen,Done).
4516
4517 fetch(domain,El,_,AVLS,MemRes) :- (avl_fetch(El,AVLS) -> MemRes=pred_true ; MemRes = pred_false).
4518 fetch(range,_,El,AVLS,MemRes) :- (avl_fetch(El,AVLS) -> MemRes=pred_true ; MemRes = pred_false).
4519
4520 % override R(X) := Y
4521 override_pair_explicit_set(avl_set(S),X,Y,avl_set(NewAVL)) :- element_can_be_added_or_removed_to_avl(X),
4522 element_can_be_added_or_removed_to_avl(Y),
4523 convert_to_avl_inside_set(X,AX),
4524 convert_to_avl_inside_set(Y,AY),
4525 avl_domain_subtraction_singleton(S,AX,AVL2),
4526 avl_store((AX,AY), AVL2, true, NewAVL).
4527
4528 avl_domain_subtraction_singleton(AVL,AX,NewAVL) :-
4529 avl_delete_pair(AX,AVL,_True,AVL2),
4530 !, % recurse, in case we have multiple entries
4531 % this recursion could be avoided if we know AVL to be a function
4532 avl_domain_subtraction_singleton(AVL2,AX,NewAVL).
4533 avl_domain_subtraction_singleton(AVL,_,AVL).
4534
4535 % try and decompose an AVL set into a cartesian product
4536 % AVL = Set1 * Set2
4537 % much faster e.g. for let xx = ((1..10)*(3..1000)\/ {0}*(3..1000)) and then xx = AA*BB
4538 % should not produce pending co-routines
4539 decompose_avl_set_into_cartesian_product_wf(AVL,DomainSet,RangeSet,WF) :-
4540 avl_domain(AVL,Expansion),
4541 decompose_cart(Expansion,'$none',DomainList,[],RangeList),
4542 construct_avl_from_lists_wf(DomainList,DomainSet,WF),
4543 construct_avl_from_lists_wf(RangeList,RangeSet,WF).
4544
4545 decompose_cart([],_,[],[],_).
4546 decompose_cart([(A,B)|T],Prev,Domain,Range,FullRange) :-
4547 (A=Prev
4548 -> Range = [B|TRange],
4549 decompose_cart(T,Prev,Domain,TRange,FullRange)
4550 ; Domain = [A|TDom], Range=[],
4551 FullRange = [B|TRange],
4552 decompose_cart(T,A,TDom,TRange,FullRange)
4553 ).
4554
4555 /* --------- */
4556 /* EXPANSION */
4557 /* --------- */
4558
4559 :- use_module(b_global_sets,[all_elements_of_type_wf/3, all_elements_of_type_rand_wf/3]).
4560 :- use_module(kernel_freetypes,[expand_freetype/3]).
4561
4562 expand_custom_set(X,R) :- expand_custom_set_wf(X,R,expand_custom_set,no_wf_available).
4563 expand_custom_set(X,R,Src) :- expand_custom_set_wf(X,R,Src,no_wf_available).
4564 expand_custom_set_wf(X,R,Source,WF) :- var(X), !,
4565 add_error_and_fail(expand_custom_set_wf, 'Variable as argument: ',expand_custom_set_wf(X,R,Source,WF)).
4566 expand_custom_set_wf(global_set(GS),ExpandedSet,_,WF) :- !,
4567 all_elements_of_type_wf(GS,ExpandedSet,WF). % they are generated in order
4568 expand_custom_set_wf(freetype(GS),ValueList,_,WF) :- !,
4569 expand_freetype(GS,ValueList,WF).
4570 expand_custom_set_wf(avl_set(AVL),ExpandedSet,_,_) :- !,
4571 avl_domain(AVL,ExpandedSet).
4572 expand_custom_set_wf(closure(Parameters,PTypes,Cond),Res,Source,WF) :- !,
4573 expand_closure_to_list(Parameters,PTypes,Cond,Res,_Done,Source,WF).
4574 %wait_try_expand_custom_set(Res1,Res). % could be in AVL form; no longer the case !
4575 expand_custom_set_wf(Set,_,Source,_) :-
4576 add_error_and_fail(expand_custom_set(Source),'Cannot expand custom set: ',Set).
4577
4578
4579
4580 %try_expand_only_custom_closure_global(X,Y) :-
4581 % (var(X) -> X=Y ; expand_only_custom_closure_global(X,Y,check)).
4582
4583 expand_only_custom_closure_global(X,R,C,_WF) :- var(X), !,
4584 add_error_and_fail(expand_only_custom_closure_global, 'Variable as argument: ',expand_only_custom_closure_global(X,R,C)).
4585 expand_only_custom_closure_global(global_set(GS),ExpandedSet,_,WF) :- !,all_elements_of_type_wf(GS,ExpandedSet,WF).
4586 expand_only_custom_closure_global(freetype(GS),ExpandedSet,_,_WF) :- !,ExpandedSet=freetype(GS).
4587 expand_only_custom_closure_global(avl_set(AVL),ExpandedSet,_,_WF) :- !, ExpandedSet=avl_set(AVL).
4588 expand_only_custom_closure_global(closure(Parameters,PTypes,Cond),Res,CheckTimeOuts,WF) :- !,
4589 (Res==[] -> is_empty_explicit_set(closure(Parameters,PTypes,Cond)) % TO DO: think about other special cases
4590 ; expand_closure_to_avl_or_list(Parameters,PTypes,Cond,Res,CheckTimeOuts,WF)).
4591 expand_only_custom_closure_global(Set,Set,_CheckTimeOuts,_WF).
4592 %:- add_error_and_fail(expand_only_custom_closure_global,'Cannot expand custom set: ',Set).
4593
4594
4595 try_expand_custom_set_with_catch(CS,Expansion,PP) :-
4596 on_enumeration_warning(try_expand_custom_set_wf(CS,Expansion,PP,no_wf_available),
4597 Expansion=CS).
4598
4599 try_expand_custom_set(CS,Expansion) :-
4600 try_expand_custom_set_wf(CS,Expansion,try_expand_custom_set,no_wf_available).
4601
4602
4603 try_expand_custom_set_wf(CS,Res,_,_) :- var(CS),!,Res=CS.
4604 try_expand_custom_set_wf([],Res,_,_) :- !, Res=[].
4605 try_expand_custom_set_wf([H|T],Res,_,_) :- !, Res=[H|T].
4606 try_expand_custom_set_wf(CS,Res,Src,WF) :-
4607 expand_custom_set_wf(CS,Res,Src,WF). % will generate error message for illegal sets
4608
4609
4610 :- assert_must_succeed((expand_custom_set_to_list(closure(['_zzzz_unit_tests'],
4611 [couple(integer,integer)],
4612 b(member(b(identifier('_zzzz_unit_tests'),couple(integer,integer),[generated]),
4613 b(value([(int(1),int(22))]),set(couple(integer,integer)),[])),pred,[])),R),R==[(int(1),int(22))])).
4614
4615 expand_custom_set_to_list(CS,List) :- expand_custom_set_to_list(CS,List,_Done,unknown).
4616
4617 % a version of expansion which returns guaranteed_ground if the List is guaranteed to be ground
4618 expand_custom_set_to_list_gg(CS,List,GuaranteedGround,_PP) :-
4619 nonvar(CS), CS=avl_set(AVL), var(List),
4620 !,
4621 GuaranteedGround = guaranteed_ground,
4622 avl_domain(AVL,List).
4623 expand_custom_set_to_list_gg(CS,List,not_guaranteed_ground,PP) :-
4624 expand_custom_set_to_list(CS,List,_Done,PP).
4625
4626 % a version where the expansion should happen straightaway and should not block:
4627 expand_custom_set_to_list_now(CS,List) :- expand_custom_set_to_list(CS,List,Done,unknown),
4628 (Done==true -> true ; print_error(expand_custom_set_to_list_not_done(CS,List))).
4629
4630 :- block expand_custom_set_to_sorted_list(-,-,?,?,?).
4631 % sorts the resulting list if needed
4632 % due to random enumeration
4633 expand_custom_set_to_sorted_list(From,To,Done,Source,WF) :-
4634 expand_custom_set_to_list(From,UnsortedTo,Done,Source),
4635 (get_preference(randomise_enumeration_order,true)
4636 -> sort_when_done(Done,UnsortedTo,To,WF) ; UnsortedTo = To).
4637
4638 :- block sort_when_done(-,?,?,?).
4639 sort_when_done(_,Unsorted,Res,WF) :- sort(Unsorted,Sorted),
4640 equal_object_wf(Sorted,Res,sort_when_done,WF).
4641
4642 expand_custom_set_to_list(From,To,Done,Source) :-
4643 expand_custom_set_to_list_wf(From,To,Done,Source,no_wf_available).
4644
4645 :- use_module(kernel_objects,[equal_object_wf/4]).
4646
4647 % try expand custom set to list; on enumeration warning set Done to enumeration_warning
4648 try_expand_custom_set_to_list_wf(From,To,Done,Source,WF) :-
4649 on_enumeration_warning(expand_custom_set_to_list_wf(From,To,Done,Source,WF),
4650 (Done=enumeration_warning)).
4651
4652 expand_custom_set_to_list_wf(From,To,Done,Source,WF) :-
4653 expand_custom_set_to_list_k_wf(From,To,Done,_Kind,Source,WF).
4654
4655 % a variation of expand_custom_set_to_list which also checks that there are no duplicates in the list
4656 expand_custom_set_to_list_no_dups_wf(From,To,Done,Source,WF) :-
4657 expand_custom_set_to_list_k_wf(From,To,Done,Kind,Source,WF),
4658 check_dups(Kind,To,WF).
4659
4660 :- block check_dups(-,?,?).
4661 check_dups(unsorted_list,List,WF) :- !,
4662 kernel_objects:check_no_duplicates_in_list(List,[],WF).
4663 check_dups(_,_,_).
4664
4665 % warn if duplicates in list; to do: use in prob_safe mode
4666 %:- block warn_dups(-,?,?,?).
4667 %warn_dups(unsorted_list,List,Src,WF) :- !,
4668 % kernel_objects:warn_if_duplicates_in_list(List,Src,WF).
4669 %warn_dups(_,_,_,_).
4670
4671
4672
4673 :- block expand_custom_set_to_list_k_wf(-,-,?,?,?,?).
4674 % ensures that the output is a pure list; the list skeleton should not be instantiated by anybody else
4675 expand_custom_set_to_list_k_wf(From,To,Done,Kind,Source,WF) :-
4676 (var(From) ->
4677 (is_list_skeleton(To)
4678 ? -> equal_object_wf(To,From,Source,WF), Done=true, Kind=unsorted_list
4679 ? ; expand_custom_set_to_list2(To,From,Done,Kind,Source,WF))
4680 ; var(To),is_list_skeleton(From)
4681 -> To=From, Done=true, Kind=unsorted_list % equal_object_wf will also to a Prolog unification
4682 ? ; expand_custom_set_to_list2(From,To,Done,Kind,Source,WF)).
4683
4684 expand_custom_set_to_list2([],ExpandedSet,Done,Kind,_Source,WF) :- !,
4685 ? equal_object_wf([],ExpandedSet,expand_custom_set_to_list2,WF),Done=true,Kind=empty_set.
4686 expand_custom_set_to_list2([H|T],ExpandedSet,Done,Kind,Source,WF) :- !, Kind=unsorted_list,
4687 ? equal_object_wf([H|ET],ExpandedSet,expand_custom_set_to_list2,WF),
4688 ? expand_custom_set_to_list3(T,ET,Done,Source,WF).
4689 expand_custom_set_to_list2(global_set(GS),ExpandedSet,Done,Kind,_Source,WF) :- !,
4690 all_elements_of_type_rand_wf(GS,R,WF),
4691 check_list(R,expand_custom_set_to_list2),
4692 equal_object_wf(R,ExpandedSet,expand_custom_set_to_list2,WF),Done=true,Kind=sorted_list.
4693 expand_custom_set_to_list2(avl_set(AVL),ExpandedSet,Done,Kind,_Source,WF) :- !,
4694 avl_domain(AVL,R),
4695 ? equal_object_wf(R,ExpandedSet,expand_custom_set_to_list2,WF), Done=true,Kind=sorted_list.
4696 expand_custom_set_to_list2(closure(Parameters,PTypes,Cond),ExpandedSet,Done,Kind,Source,WF) :- !,
4697 ? expand_closure_to_list(Parameters,PTypes,Cond,ExpandedSet,Done,Source,WF),
4698 Kind=sorted_list.
4699 %assign_expand_result(CDone,Res,ExpandedSet,Done).
4700 expand_custom_set_to_list2(freetype(ID),ExpandedSet,Done,Kind,_Source,WF) :- !,
4701 expand_freetype(ID,R,WF),
4702 equal_object_wf(R,ExpandedSet,expand_custom_set_to_list2,WF),
4703 Done=true,Kind=sorted_list.
4704 % missing avl_set wrapper:
4705 expand_custom_set_to_list2(node(A,B,C,D,E),ExpandedSet,Done,Kind,Source,WF) :- !,
4706 add_internal_error('Illegal argument: ',expand_custom_set_to_list2(node(A,B,C,D,E),ExpandedSet,Done,Source)),
4707 expand_custom_set_to_list2(avl_set(node(A,B,C,D,E)),ExpandedSet,Done,Kind,Source,WF).
4708 expand_custom_set_to_list2(E,ES,Done,Kind,Source,WF) :-
4709 add_internal_error('Illegal argument: ',expand_custom_set_to_list2(E,ES,Done,Kind,Source,WF)),fail.
4710
4711 :- block expand_custom_set_to_list3(-,-,?,?,?). % we are no longer sure which was From and which is To
4712 expand_custom_set_to_list3(From,To,Done,Source,WF) :-
4713 ? (var(From) -> expand_custom_set_to_list2(To,From,Done,_,Source,WF) ;
4714 ? expand_custom_set_to_list2(From,To,Done,_,Source,WF)).
4715
4716
4717 is_list_skeleton(X) :- var(X),!,fail.
4718 is_list_skeleton([]).
4719 is_list_skeleton([_|T]) :- is_list_skeleton(T).
4720
4721 % true if it is more efficient to keep this, rather than expand into list
4722 is_efficient_custom_set(avl_set(_)).
4723 is_efficient_custom_set(closure(P,T,B)) :-
4724 (is_interval_closure(closure(P,T,B),_,_) -> true ; is_infinite_or_symbolic_closure(P,T,B)).
4725 is_efficient_custom_set(global_set(X)) :- is_infinite_global_set(X,_).
4726 is_efficient_custom_set(freetype(_)).
4727
4728 % tries to expand & convert to avl_set; fails if not possible: NOTE: also generates empty AVL
4729 expand_and_convert_to_avl_set(R,AER,Origin,Source) :-
4730 try_expand_and_convert_to_avl(R,ER,Origin,Source),
4731 nonvar(ER),(ER==[] -> AER=empty ; ER=avl_set(AER)).
4732
4733
4734 expand_and_convert_to_avl_set_unless_very_large(R,AER,WF) :-
4735 try_expand_and_convert_to_avl_unless_very_large_wf(R,ER,WF),
4736 nonvar(ER),(ER==[] -> AER=empty ; ER=avl_set(AER)).
4737
4738
4739 % similar to unless_large version, but will only expand if it is guaranteed to be small
4740
4741 try_expand_and_convert_to_avl_if_smaller_than(freetype(GS),Res,_) :- !, Res = freetype(GS).
4742 try_expand_and_convert_to_avl_if_smaller_than([H|T],Res,_) :- !, try_expand_and_convert_to_avl([H|T],Res).
4743 try_expand_and_convert_to_avl_if_smaller_than(avl_set(A),Res,_) :- !, Res=avl_set(A).
4744 try_expand_and_convert_to_avl_if_smaller_than(CS,Res,Limit) :-
4745 (is_small_specific_custom_set(CS,Limit)
4746 -> try_expand_and_convert_to_avl(CS,Res,try_expand_and_convert_to_avl_if_smaller_than,'')
4747 ; Res = CS % TO DO: maybe look at cardinality of types and determine max. cardinality
4748 ).
4749 is_small_specific_custom_set(CS,Limit) :- card_for_specific_custom_set(CS,Card,Code),
4750 call(Code), is_finite_card(Card), Card<Limit.
4751 get_card_for_specific_custom_set(CS,Card) :-
4752 card_for_specific_custom_set(CS,Card,Code),
4753 ? call(Code), ground(Card).
4754
4755 try_expand_and_convert_to_avl_unless_very_large_wf(CS,Res,WF) :-
4756 try_expand_and_convert_to_avl_unless_large_wf(CS,Res,10000,WF).
4757
4758 try_expand_and_convert_to_avl_unless_large_wf(CS,Res,WF) :-
4759 try_expand_and_convert_to_avl_unless_large_wf(CS,Res,2000,WF).
4760
4761 try_expand_and_convert_to_avl_unless_large_wf(CS,Res,_,_WF) :- var(CS), !, CS=Res.
4762 try_expand_and_convert_to_avl_unless_large_wf(global_set(GS),Res,_,_WF) :- !, Res = global_set(GS).
4763 try_expand_and_convert_to_avl_unless_large_wf(freetype(GS),Res,_,_WF) :- !, Res = freetype(GS).
4764 %try_expand_and_convert_to_avl_unless_large_wf(CS,Res,_WF) :- is_interval_closure(CS,Low,Up),!,
4765 % ((ground(Low),ground(Up),Size is 1+Up-Low, Size<2000)
4766 %% -> try_expand_and_convert_to_avl(CS,Res)
4767 % ; Res = CS
4768 % ).
4769 try_expand_and_convert_to_avl_unless_large_wf(closure(P,T,B),Res,Limit,_WF) :-
4770 is_very_large_or_symbolic_closure(P,T,B,Limit),!, % is explicitly marked as SYMBOLIC
4771 Res=closure(P,T,B).
4772 try_expand_and_convert_to_avl_unless_large_wf(CS,Res,_Limit,WF) :-
4773 % TO DO: check if maybe we cannot determine card explicitly, but have a large lower-bound
4774 try_expand_and_convert_to_avl_wf(CS,Res,try_expand_and_convert_to_avl_unless_large,'',WF).
4775
4776
4777
4778 % calls try_expand_and_convert_to_avl and returns original value if enumeration warning occured
4779 try_expand_and_convert_to_avl_with_catch_wf(CS,Res,Origin,WF) :-
4780 on_enumeration_warning(try_expand_and_convert_to_avl_wf(CS,Res,Origin,'',WF),
4781 Res=CS).
4782
4783 /* tries to generate an avl-structure, if possible */
4784 try_expand_and_convert_to_avl(CS,Res) :-
4785 try_expand_and_convert_to_avl_wf(CS,Res,try_expand_and_convert_to_avl,'',no_wf_available).
4786
4787 try_expand_and_convert_to_avl(CS,Res,Origin,Source) :-
4788 try_expand_and_convert_to_avl_wf(CS,Res,Origin,Source,no_wf_available).
4789
4790 try_expand_and_convert_to_avl_wf(CS,Res,_,_,_WF) :- var(CS), !, CS=Res.
4791 try_expand_and_convert_to_avl_wf(avl_set(A),R,_,_,_WF) :- !, R=avl_set(A).
4792 try_expand_and_convert_to_avl_wf([],R,_,_,_WF) :- !, R=[].
4793 try_expand_and_convert_to_avl_wf([H|T],R,_,_,WF) :- !, try_convert_to_avl_wf([H|T],R,WF).
4794 try_expand_and_convert_to_avl_wf(closure(P,T,B),Res,Origin,_Source,WF) :- !,
4795 debug_opt_push_wait_flag_call_stack_info(WF,
4796 external_call('TRY EXPANDING',[closure(P,T,B)],unknown),WF2),
4797 expand_only_custom_closure_global(closure(P,T,B),Expansion,check(Origin),WF2),
4798 try_convert_to_avl_wf(Expansion,Res,WF).
4799 try_expand_and_convert_to_avl_wf(CS,Res,Origin,_Source,WF) :-
4800 (\+ is_custom_explicit_set(CS,try_expand_and_convert_to_avl_wf)
4801 -> Expansion = CS
4802 ; expand_only_custom_closure_global(CS,Expansion,check(Origin),WF)
4803 ),
4804 try_convert_to_avl_wf(Expansion,Res,WF).
4805
4806 try_convert_to_avl(Expansion,Res) :-
4807 (should_be_converted_to_avl_from_lists(Expansion) -> construct_avl_from_lists(Expansion,Res) ; Res=Expansion).
4808 try_convert_to_avl_wf(Expansion,Res,WF) :-
4809 (should_be_converted_to_avl_from_lists(Expansion) -> construct_avl_from_lists_wf(Expansion,Res,WF) ; Res=Expansion).
4810
4811 should_be_converted_to_avl_from_lists(Value) :- var(Value),!,fail.
4812 should_be_converted_to_avl_from_lists(Value) :-
4813 \+ is_custom_explicit_set(Value,should_be_converted_to_avl_from_lists), % already avl_set, global_set or closure
4814 ? \+ do_not_convert_aux(Value),
4815 ground_value(Value).
4816
4817 do_not_convert_aux(V) :- var(V),!.
4818 do_not_convert_aux((A,B)) :- !,
4819 (do_not_convert_aux(A) -> true ; do_not_convert_aux(B)).
4820 do_not_convert_aux([H|T]) :- !, % do not convert a set containing a symbolic closure
4821 ? (var(T) -> true ; do_not_convert_aux(H)).
4822 do_not_convert_aux(rec(Fields)) :- !,
4823 (var(Fields) -> true
4824 ? ; member(field(_,V),Fields), do_not_convert_aux(V) -> true).
4825 do_not_convert_aux(H) :-
4826 ? is_symbolic_closure(H).
4827
4828 should_be_converted_to_avl(Value) :- %preference(use_avl_trees_for_sets,true),
4829 ground_value(Value).
4830
4831 try_expand_and_convert_to_avl_with_check(CS,Res,Origin) :-
4832 try_expand_and_convert_to_avl_with_check(CS,Res,do_not_keep_intervals,Origin).
4833
4834 try_expand_and_convert_to_avl_with_check(CS,Res,_,_Origin) :- var(CS),!, Res = CS.
4835 try_expand_and_convert_to_avl_with_check([],Res,_,_Origin) :- !, Res=[].
4836 try_expand_and_convert_to_avl_with_check(avl_set(A),Res,_,_Origin) :- !, Res=avl_set(A).
4837 try_expand_and_convert_to_avl_with_check([H|T],Res,_,Origin) :- !, try_expand_and_convert_to_avl([H|T],Res,Origin,'').
4838 %try_expand_and_convert_to_avl_with_check(CS,Res,_Origin) :-
4839 % \+ is_custom_explicit_set(CS,try_expand_and_convert_to_avl),!, Res = CS.
4840 try_expand_and_convert_to_avl_with_check(CS,Res,KeepIntervals,_Origin) :-
4841 is_interval_closure(CS,Low,Up),
4842 (var(Low) -> true ; var(Up) -> true % better keep this symbolic as we may be able to do constraint propagation
4843 ; KeepIntervals=keep_intervals(Size) -> Up-Low >= Size
4844 ),
4845 !, % TO DO: see if we should do this check in try_expand_and_convert_to_avl above instead
4846 Res=CS.
4847 try_expand_and_convert_to_avl_with_check(CS,Res,_,Origin) :-
4848 ? get_card_for_specific_custom_set(CS,Size), % TO DO: avoid checking for special closures twice (below in try_expand_and_convert_to_avl ?)
4849 !,
4850 try_expconv_to_avl_with_size(Size,CS,Res,Origin).
4851 try_expand_and_convert_to_avl_with_check(CS,Res,_,Origin) :-
4852 try_expand_and_convert_to_avl(CS,Res,Origin,'').
4853
4854 try_expconv_to_avl_with_size(inf,CS,Res,Origin) :- !,
4855 debug_format(9,'### Not expanding infinite set~n### ORIGIN: ~w~n',[Origin]),
4856 Res=CS.
4857 try_expconv_to_avl_with_size(inf_overflow,CS,Res,Origin) :- !,
4858 debug_format(9,'### Not expanding very large set~n### ORIGIN: ~w~n',[Origin]),
4859 Res=CS.
4860 try_expconv_to_avl_with_size(Size,CS,Res,Origin) :- Size>=10000000, !,
4861 /* will probably never terminate */
4862 debug_format(9,'### Not expanding very large set with cardinality ~w~n### ORIGIN: ~w~n',[Size,Origin]),
4863 Res=CS.
4864 try_expconv_to_avl_with_size(Size,CS,Res,Origin) :- Size>=50000, !,
4865 print('### WARNING: expanding very large comprehension set, size = '), print(Size),nl,
4866 print('### ORIGIN: '), print(Origin),nl,
4867 try_expand_and_convert_to_avl(CS,Res,Origin,'').
4868 try_expconv_to_avl_with_size(_Size,CS,Res,Origin) :-
4869 try_expand_and_convert_to_avl(CS,Res,Origin,'').
4870
4871 /* underlying assumption for var case: if G is a global set: we get back the
4872 global_set tag immediately: no need to use when to wait;
4873 better: ensure that b_compute_expression always returns a nonvar term */
4874
4875
4876 :- assert_must_succeed((custom_explicit_sets:try_expand_custom_set(closure([xx],[integer],b(falsity,pred,[])),R),R = [])).
4877 :- assert_must_succeed((custom_explicit_sets:test_closure(X),custom_explicit_sets:expand_custom_set(X,EX),
4878 EX = [(fd(1,'Name'),_),(fd(3,'Name'),_)])).
4879
4880 test_closure(X) :- X = closure(['_zzzz_binary'],[couple(global('Name'),set(global('Name')))],
4881 b(member(b(identifier('_zzzz_binary'),couple(global('Name'),set(global('Name'))),[generated]),
4882 b(cartesian_product(b(value([fd(1,'Name'),fd(3,'Name')]),set(global('Name')),[]),
4883 b(value([[fd(2,'Name'),fd(3,'Name')]]),set(set(global('Name'))),[])),
4884 set(couple(global('Name'),set(global('Name')))),[])),pred,[])).
4885
4886
4887 /* --------- */
4888 /* ELEMENT_OF */
4889 /* --------- */
4890
4891
4892 /* A function that instantiates last argument when membership test can be decided */
4893
4894 membership_custom_set(CS,X,R) :- print(warning_deprecated_non_wf_version(CS,X,R)),nl,
4895 membership_custom_set_wf(CS,X,R,_WF).
4896
4897 ?membership_custom_set_wf(avl_set(A),X,R,WF) :- !, membership_avl_set_wf(A,X,R,WF).
4898 membership_custom_set_wf(freetype(_GS),_X,R,_WF) :- !, R=pred_true. % should be covered by clause above
4899 membership_custom_set_wf(CS,X,R,WF) :- R==pred_true,!, element_of_custom_set_wf(X,CS,WF).
4900 membership_custom_set_wf(CS,X,R,WF) :- R==pred_false,!, not_element_of_custom_set_wf(X,CS,WF).
4901 membership_custom_set_wf(CS,_X,R,_WF) :-
4902 is_definitely_maximal_set(CS),!,
4903 R=pred_true.
4904 membership_custom_set_wf(closure(Par,Types,Body),X,R,WF) :- !,
4905 ? closure_membership_wf(X,Par,Types,Body,R,WF).
4906 %membership_custom_set_wf(CS,X,R,WF) :- is_one_element_custom_set(CS,Y),!, % only succeeds for AVL
4907 % kernel_equality:equality_objects_wf_no_enumr(X,Y,R,WF).
4908 membership_custom_set_wf(global_set(GS),X,R,WF) :- !,
4909 membership_global_set(GS,X,R,WF).
4910 membership_custom_set_wf(CS,X,R,WF) :-
4911 add_internal_error('Illegal custom set: ',membership_custom_set_wf(CS,X,R,WF)),fail.
4912
4913 membership_avl_set_wf(A,X,R,WF) :- R==pred_true,!, element_of_avl_set_wf(A,X,WF).
4914 membership_avl_set_wf(A,X,R,WF) :- R==pred_false,!, not_element_of_custom_set_wf(X,avl_set(A),WF).
4915 membership_avl_set_wf(A,X,R,WF) :- is_one_element_avl(A,Y),!,
4916 ? kernel_equality:equality_objects_wf_no_enum(X,Y,R,WF).
4917 membership_avl_set_wf(A,_X,R,_WF) :-
4918 quick_definitely_maximal_set_avl(A),!,
4919 R=pred_true.
4920 membership_avl_set_wf(A,X,R,WF) :- reify_avl_membership(A,X,R,FullReification),
4921 (FullReification==true
4922 -> true %print_term_summary(full_reification(A,X,R)),nl,nl %% did slow down e.g. Bosch Deadlock v9, seems no longer the case
4923 ? ; when((ground(X);nonvar(R)),membership_avl_set_wf2(A,X,R,WF))).
4924
4925 ?membership_avl_set_wf2(A,X,R,WF) :- R==pred_true,!, element_of_avl_set_wf(A,X,WF).
4926 membership_avl_set_wf2(A,X,R,WF) :- R==pred_false,!, not_element_of_custom_set_wf(X,avl_set(A),WF).
4927 membership_avl_set_wf2(AVL,X,R,_WF) :-
4928 ground_element_can_be_added_or_removed_to_avl(X), !,
4929 ? (safe_avl_member(X,AVL) %safe_avl_member_ground(X,AVL)
4930 -> R=pred_true ; R=pred_false).
4931 membership_avl_set_wf2(AVL,X,Res,WF) :- % X is ground but cannot be added
4932 ? (Res \== pred_false, element_of_avl_set_wf(AVL,X,WF), Res=pred_true
4933 ;
4934 Res \== pred_true, not_element_of_custom_set_wf(X,avl_set(AVL),WF), Res=pred_false).
4935
4936 membership_global_set(GS,_X,R,_WF) :- is_maximal_global_set(GS),!,
4937 R=pred_true.
4938 membership_global_set(GS,X,R,WF) :- ground(X),!,
4939 (element_of_global_set_wf(X,GS,WF) -> R=pred_true ; R=pred_false).
4940 membership_global_set(GS,X,R,_WF) :- get_integer_set_interval(GS,Low,Up),!,
4941 membership_interval(X,Low,Up,R).
4942 membership_global_set(GS,X,R,WF) :- % this case should probably never apply
4943 (GS=='FLOAT' -> true % currently it actually is also treated like REAL
4944 ; print(uncovered_membership(GS,X,R,WF)),nl),
4945 when(ground(X), (element_of_global_set_wf(X,GS,WF) -> R=pred_true ; R=pred_false)).
4946
4947 membership_interval(X,Low,Up,Res) :- nonvar(Up),Up=inf,!,X=int(IX),
4948 b_interpreter_check:check_arithmetic_operator('<=',Low,IX,Res).
4949 membership_interval(X,Low,Up,Res) :- kernel_equality:in_nat_range_test(X,int(Low),int(Up),Res).
4950
4951 :- use_module(bool_pred).
4952 closure_membership_wf(X,[ZZZZ],[integer],CondClosure,Res,_WF) :-
4953 ? is_interval_closure_body(CondClosure,ZZZZ,LOW,UP),!,
4954 kernel_equality:in_nat_range_test(X,int(LOW),int(UP),Res).
4955 % TO DO: deal with open intervals 0..inf ...
4956 closure_membership_wf(X,Par,Types,Body,Res,WF) :-
4957 is_member_closure(Par,Types,Body,_Type,VAL),
4958 (VAL=value(_) ; VAL = cartesian_product(b(value(A),_,_),b(value(B),_,_))),!,
4959 (VAL=value(Set)
4960 ? -> kernel_objects:membership_test_wf(Set,X,Res,WF)
4961 ; kernel_equality:cartesian_pair_test_wf(X,A,B,Res,WF)).
4962 closure_membership_wf(X,Par,Typ,Body,Res,WF) :-
4963 is_not_member_closure(Par,Typ,Body,_Type,value(Set)),!,
4964 bool_pred:negate(ResXSet,Res), % was kernel_equality:inv_mem_obj(ResXSet,Res),
4965 kernel_objects:membership_test_wf(Set,X,ResXSet,WF).
4966 % TO DO: if closure = POW closure -> translate into subset_test pow_subset
4967 % TO DO: support a few other closures related to symbolic unary/binary operators: closure1, POW(..), ... ?
4968 % TO DO: expand if set is small
4969 closure_membership_wf(X,Par,Types,Body,Res,WF) :- ground_value(X),!,
4970 closure_membership_ground_wf(X,closure(Par,Types,Body),Res,WF).
4971 closure_membership_wf(X,Par,Types,Body,Res,WF) :-
4972 CS = closure(Par,Types,Body),
4973 is_small_specific_custom_set(CS,100),
4974 try_expand_and_convert_to_avl_wf(CS,Expanded,closure_membership_wf,'',WF),
4975 nonvar(Expanded), Expanded=avl_set(_),
4976 !,
4977 membership_custom_set_wf(Expanded,X,Res,WF).
4978 closure_membership_wf(X,Par,Types,Body,Res,WF) :-
4979 Body \= b(member(_,_),_,_), % otherwise we may have an infinite loop; b_check_boolean_expression will generate a closure which will call closure_membership_wf again; TO DO: refine to allow certain memberships to go through
4980 get_texpr_info(Body,BodyInfo),
4981 \+ member(prob_annotation(recursive(_RID)),BodyInfo), % otherwise we can get errors as recursive identifier _RID needs to be added to local state ! (test 1151 fails otherwise)
4982 % TO DO: add recursive parameter below in set_up_typed_localstate2; + in which other circumstances do we need to set up recursion identifier !
4983 % Try reifiyng the body
4984 NegationContext=positive,
4985 copy_wf_start(WF,closure_membership_wf,CWF),
4986 b_interpreter:set_up_typed_localstate2(Par,Types,BodyInfo,ParValues,TypedVals,[],State,NegationContext),
4987 %couplise_list(Types,XType),
4988 convert_list_into_pairs(ParValues,SingleParValue),
4989 kernel_objects:equal_object(X,SingleParValue,closure_membership_wf),
4990 b_interpreter_check:b_check_boolean_expression(Body,[],State,CWF,PredRes),
4991 !,
4992 (debug_level_active_for(19) -> print('REIFICATION of closure: '), translate:print_bexpr(Body),nl, print(pred_res(X,PredRes)),nl ; true),
4993 b_enumerate:b_tighter_enumerate_all_values(TypedVals,WF), % not necessary ?? as X should get enumerated
4994 Res=PredRes,
4995 copy_wf_finish(WF,CWF).
4996 closure_membership_wf(X,Par,Types,Body,Res,WF) :-
4997 when( (ground(X);nonvar(Res)), %%
4998 % used to be ground(X), % with (ground(X);nonvar(Res)), test 292 failed {x,t|t : BOOL & (x : POW(1024 .. 1025) & bool(x : POW(NATURAL1)) = t)} = {{} |-> TRUE,{1024} |-> TRUE,{1024,1025} |-> TRUE,{1025} |-> TRUE} and test 1088 failed
4999 closure_membership_ground_wf(X,closure(Par,Types,Body),Res,WF)).
5000
5001 closure_membership_ground_wf(X,CS,Res,WF) :- nonvar(Res),!,
5002 % this optimization is checked in test 1452
5003 (Res==pred_true -> element_of_custom_set_wf(X,CS,WF) ; not_element_of_custom_set_wf(X,CS,WF)).
5004 closure_membership_ground_wf(X,CS,Res,WF) :-
5005 % to ensure that we leave no choice point behind we have to force full evaluation of element/not_element calls:
5006 % hence we do not call element_of_custom_set_wf or not_element_of_custom_set_wf below !!
5007 kernel_waitflags:get_idle_wait_flag(closure_membership_ground_wf,WF,LWF), % enable other triggered co-routines to fire first; some maybe much more efficient to deal with than closure expansion;
5008 % used to be important for test 1146, but this is no longer the case
5009 %term_variables(CS,Vars),print(closure_membership_ground_wf_aux(LWF,vars(Vars),CS)),nl,
5010 ground_value_check(CS,CSGr),
5011 %when((nonvar(LWF),(nonvar(CSGr);nonvar(Res))),closure_membership_ground_wf_aux(X,CS,Res)).
5012 block_closure_membership_ground_wf_aux(X,CS,Res,CSGr,LWF,WF). % Note: wrong block in commit 332cb17487017d819e9140427b1017a3045b3685 caused problem for test 1162
5013
5014 :- block block_closure_membership_ground_wf_aux(?,?,?,?,-,?),
5015 block_closure_membership_ground_wf_aux(?,?,-,-,?,?).
5016 block_closure_membership_ground_wf_aux(X,CS,Res, _,_,WF) :-
5017 ? closure_membership_ground_wf_aux(X,CS,Res,WF).
5018
5019 % X & CS are ground or Res is known
5020 closure_membership_ground_wf_aux(X,CS,Res,WF) :- Res==pred_true,!,
5021 ? element_of_custom_set_wf(X,CS,WF).
5022 closure_membership_ground_wf_aux(X,CS,Res,WF) :- Res==pred_false,!,
5023 ? not_element_of_custom_set_wf(X,CS,WF).
5024 closure_membership_ground_wf_aux(X,CS,Res,_WF) :-
5025 % we know that X is a ground value and CS is ground: we can determine completely whether X is element of CS or not
5026 ? if(element_of_custom_set(X,CS),Res=pred_true, Res=pred_false).
5027 /* used to be: (Res \== pred_false, element_of_custom_set(X,CS), Res=pred_true
5028 ; Res \== pred_true, not_element_of_custom_set(X,CS), Res=pred_false)).
5029 */
5030
5031
5032
5033 :- use_module(kernel_objects,[element_of_global_set/2,element_of_global_set_wf/3]).
5034 element_of_custom_set_wf(X,CS,WF) :-
5035 ? element_of_custom_set_wf2(CS,X,WF). %, print(check_ok(X)),nl.
5036
5037 element_of_custom_set_wf2(node(A,B,C,D,E),X,WF) :-
5038 add_internal_error('Unwrapped avl_set: ',element_of_custom_set_wf2(node(A,B,C,D,E),X,WF)),fail.
5039 element_of_custom_set_wf2(global_set(GS),X,WF) :- element_of_global_set_wf(X,GS,WF).
5040 element_of_custom_set_wf2(freetype(ID),X,WF) :-
5041 (is_maximal_freetype(ID) -> true
5042 ; add_internal_error('Uncovered case: ',element_of_custom_set_wf2(freetype(ID),X,WF))
5043 ). % we assume freetypes to be maximal !
5044 ?element_of_custom_set_wf2(avl_set(AVL),X,WF) :- element_of_avl_set_wf(AVL,X,WF).
5045 element_of_custom_set_wf2(closure(Parameters,PT,Cond),X,WF) :-
5046 ? element_of_closure(X,Parameters,PT,Cond,WF).
5047
5048 element_of_avl_set_wf(node(Y,_,_,empty,empty),X,WF) :- !,
5049 ? kernel_objects:equal_object_wf(X,Y,element_of_custom_set_wf2,WF).
5050 ?element_of_avl_set_wf(AVL,X,_WF) :- ground_value(X),!, safe_avl_member(X,AVL). %safe_avl_member_ground(X,AVL).
5051 element_of_avl_set_wf(AVL,X,WF) :-
5052 avl_approximate_size(AVL,10,ApproxSize),
5053 ? element_of_avl_set_wf(AVL,ApproxSize,X,WF).
5054
5055 :- use_module(clpfd_tables).
5056
5057 element_of_avl_set_wf(AVL,ApproxSize,X,WF) :-
5058 % first check if worthwhile to attempt table treatment
5059 % after fixing table/2 bug runtimes have slowed down and test 1753 became much slower
5060 % for test 1753 a threshold of < 63 would be ideal; but test 1716 requires size 91
5061 % TODO: re-evaluate when SICStus 4.8 available
5062 preferences:preference(use_clpfd_solver,true),
5063 preferences:preference(solver_strength,SS),
5064 ApproxSize < 100+SS,
5065 (var(X) -> true
5066 ; X = (X1,_X2) -> (ground_value(X1) -> ApproxSize < 10+SS ; true)
5067 ; X=rec(_) -> true
5068 %; X=int(_) -> true ; X=fd(_,_) -> true % for scalar values we already use in_fd_value_list_wf via avl_fd_value_check
5069 ),
5070 can_translate_avl_to_table(AVL,SkeletonType,WF),
5071 !,
5072 ? check_element_of_avl_with_table(X,SkeletonType,AVL,WF).
5073 element_of_avl_set_wf(AVL,ApproxSize,X,WF) :-
5074 ? propagate_avl_element_information(X,AVL,ApproxSize,WF), %translate:translate_bvalue(avl_set(AVL),SS),
5075 get_bounded_wait_flag(ApproxSize,element_of_avl(X),WF,WF1),
5076 ? element_of_avl_set_wf3(X,AVL,ApproxSize,WF1,WF).
5077
5078
5079 % compute an approximate size (small sets are computed exactly)
5080 avl_approximate_size(AVL,Size) :- avl_approximate_size(AVL,10,Size).
5081
5082 avl_approximate_size(AVL,HeightBound,Size) :- var(AVL),!,
5083 add_internal_error('AVL Set is variable: ', avl_approximate_size(AVL,HeightBound,Size)),
5084 Size=1000000.
5085 avl_approximate_size(AVL,HeightBound,Size) :- % when the AVL gets too large; not so important that we have a precise estimation anyway
5086 % so: save some time and just compute height
5087 avl_height(AVL,Height),
5088 (Height>HeightBound
5089 -> Size is floor(2**Height-1)
5090 ; avl_size(AVL,Size)).
5091
5092 :- block element_of_avl_set_wf3(-,?,?,-,?).
5093 element_of_avl_set_wf3(X,AVL,_ApproxSize,_WF1,_WF) :- var(X), !,
5094 ? safe_avl_member(X,AVL).
5095 % TO DO: if randomise_enumeration_order is true then choose elements in random order
5096 element_of_avl_set_wf3((X,Y),AVL,ApproxSize,WF1,WF) :- !,
5097 ground_value_check(X,GrX), % as soon as X is ground we can efficiently find possible values for Y
5098 % TODO: it could be that X is also a pair or a record with first field known;
5099 % see flexible_decompose_index and safe_flex_avl_member_default_wf
5100 ? block_couple_element_of_avl_set_grX_wf1(X,Y,AVL,ApproxSize,GrX,WF1,WF).
5101 element_of_avl_set_wf3(X,AVL,_ApproxSize,WF1,_WF) :-
5102 ground_value_check(X,GrX),
5103 ? safe_avl_member_block(X,AVL,GrX,WF1).
5104
5105 :- block safe_avl_member_block(?,?,-,-).
5106 safe_avl_member_block(X,AVL,_,_) :-
5107 ? safe_avl_member(X,AVL).
5108
5109 % ---------------------------------------------------
5110
5111
5112 :- block block_couple_element_of_avl_set_grX_wf1(?, - ,?,?,-,-,?).
5113 block_couple_element_of_avl_set_grX_wf1(X,Y,AVL,ApproxSize,GrX,WF1,WF) :-
5114 var(GrX), var(WF1),
5115 !,
5116 % we know the result Y but not yet fully the input value X
5117 (ApproxSize < 129 % TO DO: improve this; unify with inverse_apply_ok(Y,X,AVL,ApproxSize) ?
5118 -> ground_value_check(Y,GrY) % wait until Y is fully known
5119 ; (preference(solver_strength,SS), ApproxSize < 129+SS)
5120 -> ground_value_check(Y,GrY)
5121 % TO DO: we could look at avl_min and avl_max and estimate spread of range keys
5122 ; cond_perfmessage([data_validation_mode/false],no_inverse_avl_lookup(ApproxSize,Y)) % do not bind GrY; we wait until GrX or WF1 is bound
5123 ),
5124 ? block_couple_element_of_avl_set_grX_grY_wf1(X,Y,AVL,ApproxSize,GrX,GrY,WF1,WF).
5125 block_couple_element_of_avl_set_grX_wf1(X,Y,AVL,_ApproxSize,GrX,WF1,WF) :-
5126 ? couple_element_of_avl_set(X,Y,AVL,GrX,WF1,WF).
5127
5128 :- block block_couple_element_of_avl_set_grX_grY_wf1(?,?,?,?, -,-,-,?).
5129 block_couple_element_of_avl_set_grX_grY_wf1(X,Y,AVL,_ApproxSize, GrX,_GrY,WF1,WF) :-
5130 var(GrX), var(WF1), % i.e., Y is known
5131 % we know the result Y but not yet fully the input value X
5132 %inverse_apply_ok(Y,X,AVL,ApproxSize),
5133 !,
5134 inverse_get_possible_values(X,Y,AVL,Res),
5135 Res = avl_set(InvAVL),
5136 ? element_of_avl_set_wf(InvAVL,X,WF).
5137 block_couple_element_of_avl_set_grX_grY_wf1(X,Y,AVL,_ApproxSize,GrX,_GrY,WF1,WF) :-
5138 ? couple_element_of_avl_set(X,Y,AVL,GrX,WF1,WF).
5139
5140
5141 % special treatment for relations: if the first component is known: then we can check how many images there are
5142 couple_element_of_avl_set(X,Y,AVL,GrX,WF1,WF) :-
5143 nonvar(WF1), var(GrX), %\+ground(X),
5144 !,
5145 ? safe_flex_avl_member_default_wf((X,Y),AVL,WF).
5146 couple_element_of_avl_set(X,Y,AVLRelation,_GrX,_,WF) :- % X must be ground
5147 get_template(Y,TY,_ToUnifyAfter), % was copy_term(Y,CY) but could cause issues with closures with variables
5148 copy_term(TY,CY), % avoid that we instantiate Y and trigger co-routines
5149 findall(CY,avl_member_pair_arg1_ground(X,CY,AVLRelation),Images),
5150 Images \= [],
5151 construct_avl_from_lists_wf(Images,AVL,WF),
5152 ? element_of_custom_set_wf2(AVL,Y,WF). % will set up waitflag if necessary
5153
5154 % a version of safe_avl_member_default_wf which tries to flexibly find a usable index into the AVL first
5155 % it checks if a value can be decomposed into a ground index and the rest of a value
5156 % it also works for records indexing on first field
5157 % see tests 2351, 2353, 1966;
5158 safe_flex_avl_member_default_wf(Element,AVL,WF) :-
5159 \+ avl_height_less_than(AVL,4), % AVL tree large enough for indexing; check not necessary?; see test 2287
5160 flexible_decompose_index(Element,Key,Rest1,Path),!, % TODO: if fails: perfmessage
5161 % see Machine_Nov25/RVF428_MSTE_FOLIO.mch where this optimisation is very useful
5162 avl_fetch_with_flexible_index(Key, Path, AVL ,Rest2),
5163 kernel_objects:equal_object_wf(Rest1,Rest2,avl_fetch_with_flexible_index,WF).
5164 safe_flex_avl_member_default_wf(Element,AVL,WF) :-
5165 ? safe_avl_member_default_wf(Element,AVL,WF).
5166
5167 % set Res -> pred_true or pred_false if membership can be decided early
5168 % interval closures already dealt with by closure_membership
5169 % maximal sets are also already dealt with by membership_custom_set
5170 reify_avl_membership(AVL,Element,Res,FullReification) :-
5171 is_avl_simple_set(AVL,Type),
5172 preferences:preference(use_clpfd_solver,true), % to do: require maybe only for integer type !?
5173 \+ ground_value(Element),
5174 !,
5175 reify_avl_mem2(Type,Element,AVL,Res,FullReification).
5176 reify_avl_membership(_,_,_,false).
5177
5178
5179 is_avl_simple_set(node(El,_True,_,_,_),Type) :- simple_type(El,Type).
5180 simple_type(int(_),integer).
5181 simple_type(fd(_,GS),global(GS)).
5182
5183
5184 reify_avl_mem2(integer,int(El),AVL,Res,FullReification) :-
5185 avl_min(AVL,int(Min)), avl_max(AVL,int(Max)),
5186 (reify_integer_avl_mem(AVL,Min,Max) % reify if AVL small enough
5187 -> avl_domain(AVL,R),project_avl_domain_on_fd(R,FDList),
5188 clpfd_reify_inlist(El,FDList,FDRes,Posted),
5189 propagate_fd_membership(FDRes,Res,inlist(El,FDList)),
5190 FullReification=Posted
5191 ; clpfd_interface:try_post_constraint((El in Min..Max) #<=> FDRes),
5192 propagate_not_membership(FDRes,Res,int(El,Min,Max)),
5193 FullReification=false
5194 ).
5195 % this could also be enabled with CLPFD = FALSE ?? no overflows are possible
5196 reify_avl_mem2(global(GS),fd(El,GS),AVL,Res,FullReification) :-
5197 avl_domain(AVL,R),project_avl_domain_on_fd(R,FDList),
5198 b_global_sets:b_get_fd_type_bounds(GS,Low,Up),
5199 (is_full_fdlist(FDList,Low,Up)
5200 -> Res=pred_true, % all the values are in the list; it must be a member
5201 % normally this should also be detected by clpfd_reify_inlist, unless no constraint was set up for El
5202 % it seems to have an effect for test 426: probcli examples/EventBPrologPackages/SSF/Bepi_Soton/M1_mch.eventb -cbc all -strict -p CLPFD TRUE -p SMT TRUE -strict -p STRICT_RAISE_WARNINGS TRUE
5203 FullReification=true
5204 ; clpfd_reify_inlist(El,FDList,FDRes,Posted),
5205 propagate_fd_membership(FDRes,Res,inlist(El,FDList)),
5206 FullReification=Posted
5207 ).
5208 %reify_avl_mem2(global(GS),fd(El,GS),AVL,Res) :-
5209 % avl_min(AVL,fd(Min,GS)), avl_max(AVL,fd(Max,GS)),
5210 % clpfd_interface:try_post_constraint((El in Min..Max) #<=> FDRes),
5211 % propagate_not_membership(FDRes,Res,fd(El,GS,Min,Max)).
5212
5213 % assumes list is sorted
5214 is_full_fdlist(List,Low,Up) :- integer(Up), is_full_fdlist2(List,Low,Up).
5215 is_full_fdlist2([],Low,Up) :- Low>Up.
5216 is_full_fdlist2([Low|T],Low,Up) :- L1 is Low+1, is_full_fdlist2(T,L1,Up).
5217
5218 % check if avl small enough to call clpfd_reify_inlist
5219 reify_integer_avl_mem(_AVL,Min,Max) :- MaxSizeM1 is Max-Min, MaxSizeM1 =< 20,!.
5220 reify_integer_avl_mem(AVL,_Min,_Max) :- avl_height_less_than_with_solver_strength(AVL,5).
5221
5222
5223
5224 project_avl_domain_on_fd([],[]).
5225 project_avl_domain_on_fd([H|T],[PH|PT]) :- project_avl_domain(H,PH), project_avl_domain_on_fd(T,PT).
5226 project_avl_domain(int(X),X).
5227 project_avl_domain(fd(X,_),X).
5228
5229
5230 :- block propagate_fd_membership(-,-,?).
5231 % if we make it propagate_fd_membership(-,-?) Bosch examples becomes much slower ?
5232 % Indeed: membership_custom_set will already force membership or non-membership !
5233 %propagate_fd_membership(X,M,Info) :- var(X),!, print(propagate_fd(X,M,Info)),nl, (M=pred_true ->X=1 ; X=0).
5234 propagate_fd_membership(1,pred_true,_Info).
5235 propagate_fd_membership(0,pred_false,_Info).
5236
5237 :- block propagate_not_membership(-,?,?).
5238 propagate_not_membership(1,_,_). % there could be elements in the interval which are not in the set
5239 propagate_not_membership(0,Res,_Info) :-
5240 Res=pred_false.
5241
5242 % -----------------
5243
5244 % fails if not possible to quickly compute approximate size
5245 quick_custom_explicit_set_approximate_size(V,_) :- var(V),!,fail.
5246 quick_custom_explicit_set_approximate_size(avl_set(AVL),Size) :- !,
5247 quick_avl_approximate_size(AVL,Size).
5248 quick_custom_explicit_set_approximate_size(CS,Size) :-
5249 card_for_specific_custom_set(CS,Size,Code),
5250 on_enumeration_warning(call(Code),fail),
5251 atomic(Size). % inf or number; sometimes card_for_specific_custom_set can return a variable
5252
5253 :- use_module(clpfd_lists,[try_get_fd_value_list/4, get_fd_value/3, in_fd_value_list_wf/4]).
5254 % a membership propagation, but only done if it can be done quickly
5255
5256
5257 % quick_propagation_element_information(Set, Element, WF, PossiblyCompiledSet)
5258 % use last element for next iteration if you call quick_propagation_element_information in a loop
5259 :- block quick_propagation_element_information(-,?,?,?).
5260 quick_propagation_element_information(Set,_El,_,R) :-
5261 preferences:preference(use_clpfd_solver,false),
5262 !, R=Set.
5263 quick_propagation_element_information(avl_set(AVL),Element,WF,NewSet) :- !,
5264 quick_avl_approximate_size(AVL,Size),
5265 NewSet=avl_set_with_size(AVL,Size),
5266 propagate_avl_element_information_direct(Element,AVL,Size,WF).
5267 quick_propagation_element_information(avl_set_with_size(AVL,Size),Element,WF,NewSet) :- !,
5268 NewSet = avl_set_with_size(AVL,Size),
5269 propagate_avl_element_information_direct(Element,AVL,Size,WF).
5270 quick_propagation_element_information(closure(P,T,B),Element,WF,NewSet) :- !,
5271 NewSet = closure(P,T,B),
5272 element_of_closure(Element,P,T,B,WF).
5273 quick_propagation_element_information(fd_value_list(FDList,GroundList,Type),El,WF,NewSet) :- !,
5274 NewSet = fd_value_list(FDList,GroundList,Type),
5275 get_fd_value(Type,El,ElFD),
5276 in_fd_value_list_wf(GroundList,ElFD,FDList,WF).
5277 quick_propagation_element_information(Set,El,WF,NewSet) :-
5278 ? try_get_fd_value_list(Set,Type,FDList,GroundList),!,
5279 FDList \= [], % if list is empty membership fails
5280 NewSet = fd_value_list(FDList,GroundList,Type),
5281 % clpfd_inlist requires list of integers as second argument
5282 ? get_fd_value(Type,El,ElFD),
5283 % We could apply filter_non_matching_elements here
5284 in_fd_value_list_wf(GroundList,ElFD,FDList,WF).
5285 quick_propagation_element_information(Set,_,_,Set).
5286
5287 % -----------------
5288
5289 % infer information about an element of an AVL set
5290 propagate_avl_element_information(Element,AVL,Size,WF) :-
5291 (preferences:preference(use_clpfd_solver,true)
5292 ? -> propagate_avl_element_information_direct(Element,AVL,Size,WF)
5293 ; true).
5294
5295 propagate_avl_element_information_direct(Element,AVL,Size,WF) :-
5296 (Size<100 -> %30 which magic constant to use here; use larger value in SMT mode ?
5297 ? propagate_avl_element_information_small(Element,AVL,WF)
5298 ; is_avl_fd_index_set(AVL,Type) ->
5299 propagate_avl_element_information_large(Type,Element,AVL),
5300 (Size < 4000, nonvar(Element), Element = (_,_) % another magic constant
5301 -> Prio is Size // 60,
5302 get_wait_flag(Prio,propagate_avl_element_information(Element),WF,LWF),
5303 propagate_avl_el_large_block(Element,AVL,WF,LWF) % will do precise propagation
5304 ; true)
5305 ; true).
5306 % TO DO: we could call in_nat_range_wf; this way it would also work in non-CLPFD mode
5307
5308 :- block propagate_avl_el_large_block(?,?,?,-).
5309 propagate_avl_el_large_block((A,B),_,_,_) :-
5310 (ground(A); ground_value(B)), % in first: case we will apply AVL set ; in second case probably no benefit as propagate_avl_element_information_large already propagated first element
5311 !.
5312 propagate_avl_el_large_block(Element,AVL,WF,_LWF) :-
5313 % TO DO: maybe look if we should not use clpfd_list, but only upper & lower bound
5314 propagate_avl_element_information_small(Element,AVL,WF). % will do precise propagation.
5315
5316 :- use_module(clpfd_lists,[avl_fd_value_check/4]).
5317 :- use_module(clpfd_interface,[catch_and_ignore_clpfd_overflow/2]).
5318 propagate_avl_element_information_small(Element,AVL,WF) :-
5319 ? catch_and_ignore_clpfd_overflow(propagate_avl_element_information_small, % relevant test e.g. 1708 (with used_ids_defined_by_equality)
5320 avl_fd_value_check(AVL,Element,WF,_FullyChecked)).
5321
5322 propagate_avl_element_information_large(Type,El,AVL) :-
5323 avl_min(AVL,Min), avl_max(AVL,Max),
5324 % if Size small enough and smaller than Max-Min we call clpfd_inlist on domain
5325 % Note: overflows should be caught below; we could check that Min/Max are within CLPFD range
5326 couple_prj1_in_range(Type,El,Min,Max).
5327
5328 couple_prj1_in_range(integer,int(El),int(Min),int(Max)) :- clpfd_interface:clpfd_inrange(El,Min,Max).
5329 couple_prj1_in_range(global(GS),fd(El,GS),fd(Min,GS),fd(Max,GS)) :- clpfd_interface:clpfd_inrange(El,Min,Max).
5330 couple_prj1_in_range(couple_prj1(T),(El,_),(Min,_),(Max,_)) :- couple_prj1_in_range(T,El,Min,Max).
5331 couple_prj1_in_range(rec_first_field(Name,T),rec([field(Name,El)|TF]),
5332 rec([field(Name,Min)|TMin]),rec([field(Name,Max)|_])) :-
5333 (var(TF)
5334 -> copy_field_names(TMin,TF) % if Fields not yet instantiated: copy over all fields
5335 ; true),
5336 couple_prj1_in_range(T,El,Min,Max).
5337
5338 copy_field_names([],[]).
5339 copy_field_names([field(N,_)|T],[field(N,_)|CT]) :- copy_field_names(T,CT).
5340
5341 % check if the first component of the AVL elements of a type such that we can propagate FD information
5342 is_avl_fd_index_set(node(El,_True,_,_,_),Type) :-
5343 simple_index_type(El,Type).
5344 simple_index_type((El,_),couple_prj1(T)) :- simple_index_type(El,T).
5345 simple_index_type(int(_),integer).
5346 simple_index_type(fd(_,GS),global(GS)).
5347 simple_index_type(rec(Fields),rec_first_field(Name,T)) :- nonvar(Fields),
5348 Fields = [field(Name,El)|_],
5349 simple_index_type(El,T).
5350 %simple_index_type((int(_),_),couple_integer).
5351 %simple_index_type(((int(_),_),_),couple_couple_integer).
5352 %simple_index_type((fd(_,GS),_),couple_global(GS)).
5353
5354
5355 /* avoid instantiating non-normalised with normalised values leading to failure */
5356 :- assert_must_succeed((X=(fd(1,'Name'),fd(2,'Name')), A=node(X,true,0,empty,empty),
5357 custom_explicit_sets:safe_avl_member(X,A) )).
5358
5359 ?safe_avl_member(X,AVL) :- var(X), !, my_avl_member(X,AVL).
5360 %safe_avl_member(Value,AVL) :- decompose_index(Value,Key,RestVal), avl_fetch_indexed(Value,Key,RestVal,AVL).
5361 %safe_avl_member(X,AVL) :- ground_value(X), convert_to_avl_inside_set(X,AX), !, avl_fetch(AX,AVL).
5362 ?safe_avl_member(X,AVL) :- safe_flex_avl_member_default_wf(X,AVL,no_wf_available).
5363
5364
5365 % a version of safe_avl_member where the first argument is guaranteed to be ground
5366 % somehow using this seems to slow-down evaluation for vesg_Dec12; Caching ??
5367 %safe_avl_member_ground(X,AVL) :-
5368 % convert_to_avl_inside_set(X,AX), !, avl_fetch(AX,AVL).
5369 %safe_avl_member_ground((X,Y),AVL) :- !, avl_member_pair_arg1_ground(X,Y,AVL).
5370 %safe_avl_member_ground(X,AVL) :- safe_avl_member_default_wf(X,AVL,no_wf_available).
5371
5372
5373 % can be used to try and lookup a function value without creating WD errors, ...
5374 % used in b_compiler to compile function applications
5375 try_apply_to_avl_set_wf(X,Y,AVL,WF) :- ground_value(X),
5376 ? avl_member_pair_arg1_ground_wf(X,Y,AVL,WF).
5377
5378 % we know X is ground; typically Y is a free variable and it is used within a findall:
5379 avl_member_pair_arg1_ground(X,Y,AVL) :-
5380 ? avl_member_pair_arg1_ground_wf(X,Y,AVL,no_wf_available).
5381
5382 avl_member_pair_arg1_ground_wf(X,Y,AVL,WF) :- convert_to_avl_inside_set(X,AX), !,
5383 get_template(Y,RY,ToUnifyAfter),
5384 ? avl_fetch_pair(AX,AVL,RY), % see flexible_decompose_index, safe_flex_avl_member_default_wf
5385 unify_after_wf(ToUnifyAfter,WF).
5386 avl_member_pair_arg1_ground_wf(X,Y,AVL,_WF) :-
5387 safe_avl_member_default((X,Y),AVL).
5388
5389 safe_avl_member_default(X,AVL) :-
5390 ? safe_avl_member_default_wf(X,AVL,no_wf_available).
5391 safe_avl_member_default_wf(X,AVL,WF) :- % statistics(runtime,_),
5392 get_template(X,Template,ToUnifyAfter),
5393 ? my_avl_member(Template,AVL),
5394 % statistics(runtime,[_,T2]), print(avl_member(Template,T2)),nl,
5395 ? unify_after_wf(ToUnifyAfter,WF). % kernel_objects:equal_object(Template,X)).
5396
5397 unify_after_wf([],_).
5398 ?unify_after_wf([A/B|T],WF) :- kernel_objects:equal_object_wf(A,B,unify_after,WF),
5399 ? unify_after_wf(T,WF).
5400
5401
5402
5403 get_template(A,R,ToUnifyAfter) :-
5404 (var(A) -> ToUnifyAfter=[A/R]
5405 ; get_template2(A,R,ToUnifyAfter) -> true
5406 ; add_internal_error('Could_not_get_template: ',get_template(A,R,_))).
5407
5408 get_template2((A,B),(TA,TB),ToUnifyAfter) :- get_template(A,TA,ToUnifyAfter1), get_template(B,TB,ToUnifyAfter2),
5409 append(ToUnifyAfter1,ToUnifyAfter2,ToUnifyAfter). % TO DO: use DifferenceLists / DCG
5410 get_template2(int(X),int(X),[]).
5411 get_template2(fd(A,B),fd(A,B),[]).
5412 get_template2([],[],[]).
5413 get_template2(pred_false /* bool_false */,pred_false /* bool_false */,[]).
5414 get_template2(pred_true /* bool_true */,pred_true /* bool_true */,[]).
5415 get_template2([H|T],R,ToUnifyAfter) :-
5416 (ground_value(H),ground_value(T)
5417 -> convert_to_avl_inside_set([H|T],R),ToUnifyAfter=[]
5418 ; ToUnifyAfter=[[H|T]/R]).
5419 % ; R=avl_set(A), ToUnifyAfter=[[H|T]/avl_set(A)]).
5420 get_template2(closure(P,T,B),R,[]) :- ground_value(closure(P,T,B)),
5421 expand_closure_to_avl_wf(P,T,B,R,no_wf_available),!.
5422 get_template2(closure(P,T,B),AVL_OR_EMPTY_OR_GS,[closure(P,T,B)/AVL_OR_EMPTY_OR_GS]). % closure could be empty or an infinite global set ?
5423 %get_template2(closure_x(_,_,_),_AVL_OR_EMPTY).
5424 get_template2(avl_set(A),avl_set(NA),[]) :- convert_to_avl_inside_set(avl_set(A),avl_set(NA)). % do we need to normalise here ??
5425 get_template2(string(X),string(X),[]).
5426 get_template2(term(X),term(X),[]).
5427 get_template2(freetype(X),R,[]) :- convert_to_avl_inside_set(freetype(X),R).
5428 get_template2(rec(Fields),rec(TFields),ToUnifyAfter) :- get_fields_template(Fields,TFields,ToUnifyAfter).
5429 get_template2(freeval(ID,Case,Value),freeval(ID,Case,TValue),ToUnifyAfter) :- get_template(Value,TValue,ToUnifyAfter).
5430 get_template2(global_set(GS),R,[]) :- convert_to_avl_inside_set(global_set(GS),R).
5431
5432
5433 get_fields_template(A,R,[rec(A)/rec(R)]) :- var(A),!.
5434 get_fields_template([],[],ToUnifyAfter) :- !, ToUnifyAfter=[].
5435 get_fields_template([field(Name,Val)|T],[field(Name,TVal)|TT],ToUnifyAfter) :- nonvar(Name),!,
5436 get_template(Val,TVal,ToUnifyAfter1),
5437 get_fields_template(T,TT,ToUnifyAfter2), append(ToUnifyAfter1,ToUnifyAfter2,ToUnifyAfter).
5438 get_fields_template(A,R,[rec(A)/rec(R)]).
5439
5440
5441 % succeed if we can decide membership of an avl_set on the spot
5442 quick_test_avl_membership(AVL,X,Res) :-
5443 element_can_be_added_or_removed_to_avl(X),
5444 convert_to_avl_inside_set(X,AX),
5445 (avl_fetch(AX,AVL) -> Res=pred_true ; Res=pred_false).
5446
5447 % ---------------------
5448
5449 % a dispatch predicate
5450 my_avl_member(Key,AVL) :-
5451 (preferences:preference(randomise_enumeration_order,true)
5452 ? -> random_avl_member(Key,AVL) ; avl_member_opt(Key,AVL)).
5453 :- use_module(library(random),[random/3]).
5454 ?random_avl_member(Key,AVL) :- avl_height(AVL,Height), H1 is Height+1, random_avl_member(Key,H1,AVL).
5455 % TO DO: make more intelligent; this is not really a very uniform way of randomly enumerating an AVL set (e.g., Key never occurs between L and R)
5456 random_avl_member(Key, H, node(K,_,_,L,R)) :-
5457 random(1,H,1), !, H1 is H-1,
5458 ? (Key=K ; random_avl_member(Key,H1,L) ; random_avl_member(Key,H1,R)).
5459 random_avl_member(Key, H, node(K,_,_,L,R)) :- random(1,3,1), !, H1 is H-1,
5460 ? (random_avl_member(Key,H1,L) ; random_avl_member(Key,H1,R) ; Key=K).
5461 random_avl_member(Key, H, node(K,_,_,L,R)) :- H1 is H-1,
5462 ? (random_avl_member(Key,H1,R) ; random_avl_member(Key,H1,L) ; Key=K).
5463
5464 % a variation of avl_member from library(avl) which tries to avoid leaving choice points behind
5465 avl_member_opt(Key, node(K,_,_,L,R)) :-
5466 ? ( avl_member_opt(Key, L)
5467 ; R=empty -> Key = K % avoid trailing choice_point
5468 ? ; (Key=K ; avl_member_opt(Key, R))
5469 ).
5470
5471 % ---------------------
5472
5473 :- use_module(kernel_objects,[check_element_of_wf/3,not_element_of_wf/3]).
5474 :- use_module(memoization,[element_of_memoization_closure/6]).
5475 element_of_special_closure(interval(LOW,UP),X,WF,_,_,_) :- !,
5476 %hit_profiler:add_profile_hit(in_nat_range(X,LOW,UP,CondClosure)),
5477 ? kernel_objects:in_nat_range_wf(X,int(LOW),int(UP),WF).
5478 element_of_special_closure(member_closure(_ID,_Type,VAL),X,WF,_,_,_) :-
5479 (VAL=value(_) ; VAL = cartesian_product(b(value(A),_,_),b(value(B),_,_))),!,
5480 %hit_profiler:add_profile_hit(in_member_closure(X,Par,Typ,Body)),
5481 ? (VAL=value(Set) -> check_element_of_wf(X,Set,WF)
5482 ; X=(XA,XB),
5483 ? kernel_objects:check_element_of_wf(XA,A,WF),
5484 ? kernel_objects:check_element_of_wf(XB,B,WF)).
5485 element_of_special_closure(not_member_closure(_ID,_Type,value(Set)),X,WF,_,_,_) :- !,
5486 %hit_profiler:add_profile_hit(in_not_member_closure(X,Par,Typ,Set)),
5487 not_element_of_wf(X,Set,WF).
5488 % we used to have to add enumerator, as not_element_of does not instantiate; e.g. relevant when doing X :: GS - {y}
5489 % This is no longer required
5490 % see test 6 (../prob_examples/public_examples/B/FeatureChecks/NotMemberCheck.mch)
5491 element_of_special_closure(recursive_special_closure(RId),X,WF,Parameters,PT,CondClosure) :- !,
5492 add_recursive_parameter(Parameters,PT,X,RId,CondClosure,NewParameters,NewPT,Value,WF),
5493 element_of_normal_closure(Value,NewParameters,NewPT,CondClosure,WF).
5494 element_of_special_closure(memoization_closure(MemoID),X,WF,P,T,B) :- !,
5495 element_of_memoization_closure(MemoID,X,WF,P,T,B).
5496 element_of_special_closure(_,X,WF,Parameters,PT,CondClosure) :-
5497 % none of the special cases above apply after all
5498 ? element_of_normal_closure(X,Parameters,PT,CondClosure,WF).
5499
5500 :- block element_of_closure(?,-,?,?,?), element_of_closure(?,?,?,-,?).
5501 % element_of_closure(X,Para,T,Body,_WF): check if X is a member of closure(Para,T,Body)
5502 element_of_closure(X,Parameters,PT,CondClosure,WF) :-
5503 is_special_closure(Parameters,PT,CondClosure, SpecialClosure),!,
5504 %print_term_summary(element_of_special_closure(SpecialClosure,X,WF,Parameters,PT,CondClosure)), trace_in_debug_mode,
5505 ? element_of_special_closure(SpecialClosure,X,WF,Parameters,PT,CondClosure).
5506 element_of_closure(X,Parameters,PT,CondClosure,WF) :-
5507 %print_term_summary(element_of_normal_closure(X,Parameters,PT,CondClosure,WF)), trace_in_debug_mode,
5508 ? element_of_normal_closure(X,Parameters,PT,CondClosure,WF).
5509 element_of_normal_closure(X,Parameters,PT,CondClosure,WF) :-
5510 %hit_profiler:add_profile_hit(element_of_closure(X,Parameters,PT,CondClosure)),
5511 same_length(Parameters,ParValues),
5512 convert_list_into_pairs(ParValues,X),
5513 ? b_test_closure_wo_enum(Parameters,PT,CondClosure,ParValues,WF).
5514
5515 :- use_module(store,[set_up_localstate/4]).
5516 :- block b_test_closure_wo_enum(?,?,-,?,?).
5517 b_test_closure_wo_enum(Parameters,ParameterTypes,ClosurePred,ParValues,WF) :-
5518 % same_length(Parameters,ParValues), % not necessary
5519 set_up_localstate(Parameters,ParValues,[],LocalState),
5520 ? b_enumerate:b_type_values_in_store(Parameters,ParameterTypes,LocalState),
5521 copy_wf_start(WF,b_test_closure_wo_enum(Parameters),InnerWF),
5522 % avoid that WF0 actions triggered before we have had a chance to traverse the expression
5523 ? b_test_boolean_expression(ClosurePred,LocalState,[],InnerWF),
5524 ? copy_wf_finish(WF,InnerWF).
5525
5526 % recursive identifier to list of parameters with body as value
5527 % NewValue is the Value that should be checked for membership in the adapted closure; it has one argument more
5528 add_recursive_parameter(Parameters,Types,Value,TId,CondClosure,NewParameters,NewTypes,NewValue,WF) :-
5529 TId = b(identifier(RId),SetType,_), % unification replaces: get_texpr_id(TId,RId), get_texpr_type(TId,SetType),
5530 append(Parameters,[RId],NewParameters),
5531 append(Types,[SetType],NewTypes),
5532 %tools_printing:print_term_summary(recursion(Value)),nl,
5533 % TO DO check some variant decreases
5534 (kernel_waitflags:pending_abort_error(WF)
5535 -> NewValue = (_,_) % prevent further expansion of recursion, in case WD error in recursive function
5536 % TO DO: detect whether WD error occurs within recursive function,
5537 % indeed, the expansion of the recursive function could be unrelated to WD error and be important to detect inconsistency which prevents WD error: e.g., 1/x=res & recfun(x) \= 0
5538 ,debug_println(19,stopping_recursion_due_to_wd_error)
5539 ; NewValue = (Value,closure(Parameters,Types,CondClosure))
5540 ).
5541
5542
5543 % same as above, but without a waitflag
5544 ?element_of_custom_set(X,CS) :- element_of_custom_set2(CS,X).
5545
5546 element_of_custom_set2(global_set(GS),X) :- !,element_of_global_set(X,GS).
5547 element_of_custom_set2(freetype(ID),_) :- is_maximal_freetype(ID),!. % freetypes are always maximal at the moment
5548 element_of_custom_set2(avl_set(AVL),X) :- !,
5549 ? safe_avl_member(X,AVL).
5550 element_of_custom_set2(CS,X) :- init_wait_flags(WF,[element_of_custom_set2]),
5551 ? element_of_custom_set_wf2(CS,X,WF),
5552 ? ground_wait_flags(WF).
5553
5554 % ---------------
5555
5556 % function application for closure
5557
5558 % same as check_element_of_wf but does not wait on Y:
5559 % should also work for relation ??
5560
5561 check_element_of_function_closure(X,Y,Parameters,PT,CondClosure,WF) :-
5562 is_special_closure(Parameters,PT,CondClosure, SpecialClosure),!, % this covers recursive closures
5563 element_of_special_closure(SpecialClosure,(X,Y),WF,Parameters,PT,CondClosure).
5564 check_element_of_function_closure(X,Y, P,T,ClosureBody, WF) :-
5565 % affects test 1312, unless we add s:seq(0..9) before calling num
5566 % a special rule which tries and avoid enumerating solutions to arguments of function application
5567 % usually a function application will either be given all arguments or maybe be used in inverse
5568 ? is_converted_lambda_closure(P,T,ClosureBody), %is_converted_non_recursive_lambda_closure(P,T,ClosureBody),
5569 % TO DO: also make this work for recursive closures by adding recursive args (see e.g. test 1302)
5570 is_lambda_closure(P,T,ClosureBody, OtherIDs, OtherTypes, DomainPred, EXPR),
5571 (debug:debug_level_active_for(4) ->
5572 print('Apply Fun : '), translate:print_bexpr(DomainPred), print(' | '), translate:print_bexpr(EXPR),nl,
5573 get_texpr_info(ClosureBody,I), print(info(I,WF)),nl,
5574 print_term_summary((X,Y)),nl %,trace
5575 ; true),
5576 !,
5577 % alternative: annotate X,Y as inner variable ?
5578 get_texpr_info(ClosureBody,BInfo),
5579 b_interpreter:set_up_typed_localstate2(OtherIDs,OtherTypes,BInfo,ParValues,_TypedVals,[],LocalState,positive),
5580 convert_list_into_pairs(ParValues,SingleParValue),
5581 kernel_objects:equal_object_wf(X,SingleParValue,check_element_of_function_closure,WF),
5582 (is_truth(DomainPred) -> true
5583 ; init_wait_flags(InnerWF,[check_element_of_function_closure]),
5584 %copy_wf01e_wait_flags(WF,InnerWF), % we could delay copying WF0 until after test_boolean_expression of DomainPred ?
5585 b_test_boolean_expression(DomainPred,LocalState,[],InnerWF),
5586 get_wait_flag0(WF,WF0), get_wait_flag0(InnerWF,WF0), % was: ground_wait_flag0(InnerWF), but this can result in inner WF0 being set when outer is not yet set; see test 1948
5587 ground_value_check(X,GrX),
5588 (nonvar(GrX) -> copy_waitflag_store(InnerWF,WF) % block would trigger already
5589 ; ground_value_check(Y,GrY),
5590 (nonvar(GrY) -> copy_waitflag_store(InnerWF,WF) % block would trigger already
5591 ; get_last_wait_flag(check_element_of_function_closure(OtherIDs),WF,LastWF),
5592 block_copy_waitflag_store(InnerWF,WF,GrX,GrY,LastWF)
5593 )
5594 )
5595 ),
5596 b_interpreter:b_compute_expression(EXPR,LocalState,[],Y,WF).
5597 check_element_of_function_closure(X,Y, P,T,ClosureBody, WF) :-
5598 element_of_normal_closure((X,Y),P,T,ClosureBody,WF).
5599 % we could memoize on X here if /*@symbolic-memo */ pragma used and closure has special ID associated with it
5600
5601 :- block block_copy_waitflag_store(?,?,-,-,-).
5602 block_copy_waitflag_store(InnerWF,WF,_GrX,_GrY,_LWF) :-
5603 % copy waitflags from InnerWF store to WF
5604 copy_waitflag_store(InnerWF,WF).
5605
5606 /* -------------- */
5607 /* NOT_ELEMENT_OF */
5608 /* -------------- */
5609
5610 :- use_module(kernel_objects,[not_element_of_global_set/2]).
5611
5612 not_element_of_custom_set_wf(X,CS,WF) :-
5613 ? not_element_of_custom_set_wf2(CS,X,WF).
5614
5615 not_element_of_custom_set_wf2(global_set(GS),X,_WF) :- not_element_of_global_set(X,GS).
5616 not_element_of_custom_set_wf2(freetype(_),_,_) :- !,fail. % TO DO: what if we have List(1..3) ? can that occur ??
5617 not_element_of_custom_set_wf2(avl_set(node(Y,_,_,empty,empty)),X,WF) :- !,
5618 % X /: {Y} <=> X /= Y
5619 ? kernel_objects:not_equal_object_wf(X,Y,WF). % improve if X is ground
5620 not_element_of_custom_set_wf2(avl_set(AVL),X,_WF) :- !,
5621 ground_value_check(X,GrX),
5622 ? propagate_avl_not_element_information(X,GrX,AVL),
5623 not_element_of_avl_set_block(GrX,X,AVL).
5624 not_element_of_custom_set_wf2(closure(Parameters,PT,Cond),X,WF) :-
5625 ? closure_not_member(X,Parameters,PT,Cond,WF).
5626
5627 :- block not_element_of_avl_set_block(-,?,?).
5628 not_element_of_avl_set_block(_,X,AVL) :-
5629 convert_to_avl_inside_set(X,CX),
5630 \+ avl_fetch(CX,AVL). %% IMPROVE ??
5631
5632 propagate_avl_not_element_information(_,GrEl,_) :- nonvar(GrEl),!.
5633 propagate_avl_not_element_information(Element,_,AVL) :- preferences:preference(use_clpfd_solver,true),
5634 is_avl_simple_set(AVL,Type), % integer or global(GS) \+ground(Element) ,
5635 ((Type=integer -> avl_height_less_than_with_solver_strength(AVL,6) % 16-31 elements - was: avl_size<20
5636 ; true)
5637 -> !,
5638 ? propagate_avl_not_element_information3(Type,Element,AVL) % uses clpfd_not_inlist
5639 ; Type=integer, avl_height_less_than_with_solver_strength(AVL,15),
5640 avl_is_interval(AVL,Min,Max)
5641 -> !,
5642 kernel_objects:not_in_nat_range(Element,int(Min),int(Max)) % WF not used anyway in _wf version
5643 ).
5644 propagate_avl_not_element_information(_Element,_,AVL) :-
5645 quick_definitely_maximal_set_avl(AVL),
5646 !, % we require something not to be an element of the full set; impossible
5647 fail.
5648 % to do: check if all but one element is in set
5649 propagate_avl_not_element_information(_,_,_).
5650
5651 avl_height_less_than_with_solver_strength(AVL,Limit) :- preference(solver_strength,SS),
5652 RealLimit is Limit + SS/100,
5653 avl_height_less_than(AVL,RealLimit).
5654
5655 % try and compute a small finite cardinality for a ground value; fail if not possible
5656 try_get_finite_max_card_from_ground_value(pred_true,2).
5657 try_get_finite_max_card_from_ground_value(pred_false,2).
5658 try_get_finite_max_card_from_ground_value(fd(_,Type),Card) :-
5659 b_global_sets:b_fd_card(Type,Card), integer(Card).
5660 try_get_finite_max_card_from_ground_value((A,B),Card) :-
5661 try_get_finite_max_card_from_ground_value(A,CA),
5662 try_get_finite_max_card_from_ground_value(B,CB),
5663 Card is CA*CB,
5664 Card < 20000.
5665 try_get_finite_max_card_from_ground_value(rec(Fields),Card) :-
5666 try_get_finite_max_card_from_fields(Fields,Card).
5667 try_get_finite_max_card_from_ground_value(freeval(FreetypeId,_CaseId,_EArgs),Card) :-
5668 freetype_cardinality(FreetypeId,Card), number(Card), Card < 20000.
5669 try_get_finite_max_card_from_ground_value(avl_set(node(El,_True,_,_,_)),Card) :-
5670 try_get_finite_max_card_from_ground_value(El,CEl),
5671 CEl < 16,
5672 safe_pow2(CEl,Card).
5673 % int(_), term(floating(_)), string(_) are all infinite
5674
5675 try_get_finite_max_card_from_fields([],1).
5676 try_get_finite_max_card_from_fields([field(_,A)|TF],Card) :-
5677 try_get_finite_max_card_from_ground_value(A,CA),
5678 try_get_finite_max_card_from_fields(TF,CB),
5679 Card is CA*CB,
5680 Card < 20000.
5681
5682 :- use_module(b_global_sets,[get_global_type_value/3]).
5683 propagate_avl_not_element_information3(integer,int(El),AVL) :-
5684 avl_domain(AVL,R),project_avl_domain_on_fd(R,FDList),
5685 clpfd_interface:clpfd_not_inlist(El,FDList).
5686 propagate_avl_not_element_information3(global(GS),FD,AVL) :-
5687 get_global_type_value(FD,GS,El), % sets up the FD constraint if var; maybe we can detect inconsistency straightaway below
5688 avl_domain(AVL,R),project_avl_domain_on_fd(R,FDList), % maybe we can compute directly the complement ?
5689 ? clpfd_interface:clpfd_not_inlist(El,FDList).
5690
5691
5692 :- block closure_not_member(?,-,?,?,?).
5693 %, closure_not_member(-,?,?,?,?). /* El is unlikely to be instantiated by not_element_of test , but test 6 requires commenting out block declaration */
5694
5695 closure_not_member(X,Parameters,Types,Body,WF) :-
5696 is_special_closure(Parameters,Types,Body,SpecialClosure),!,
5697 ? not_element_of_special_closure(SpecialClosure,X,WF,Parameters,Types,Body).
5698 closure_not_member(El,Parameters,PT,Cond,WF) :-
5699 normal_closure_not_member(El,Parameters,PT,Cond,WF).
5700
5701 :- use_module(memoization,[not_element_of_memoization_closure/6]).
5702 not_element_of_special_closure(interval(LOW,UP),X,_WF,_Parameters,_Types,_Body) :-
5703 ? !,kernel_objects:not_in_nat_range(X,int(LOW),int(UP)).
5704 not_element_of_special_closure(member_closure(_ID,_Type,VAL),X,WF,_Parameters,_Types,_Body) :-
5705 ( VAL = value(_)
5706 ; VAL = cartesian_product(b(value(A),_,_),b(value(B),_,_))),!,
5707 %hit_profiler:add_profile_hit(member(X,Par,Typ,Body)),
5708 ( VAL=value(Set) -> kernel_objects:not_element_of_wf(X,Set,WF)
5709 ? ; kernel_objects:not_is_cartesian_pair(X,A,B,WF)).
5710 not_element_of_special_closure(not_member_closure(_ID,_Type,value(Set)),X,WF,_Parameters,_Types,_Body) :-
5711 ? !,kernel_objects:check_element_of_wf(X,Set,WF).
5712 not_element_of_special_closure(memoization_closure(MemoID),X,WF,P,T,B) :- !,
5713 not_element_of_memoization_closure(MemoID,X,WF,P,T,B).
5714 not_element_of_special_closure(recursive_special_closure(RId),X,WF,Parameters,Types,Body) :-
5715 !,
5716 add_recursive_parameter(Parameters,Types,X,RId,Body,NewParameters,NewPT,Value,WF),
5717 normal_closure_not_member(Value,NewParameters,NewPT,Body,WF).
5718
5719 not_element_of_special_closure(SC,_X,_WF,Parameters,Types,Body) :-
5720 SC \= interval(_,_),
5721 SC \= not_member_closure(_,_,_),
5722 is_definitely_maximal_closure(Parameters,Types,Body),
5723 !,
5724 fail.
5725 not_element_of_special_closure(_,X,WF,Parameters,Types,Body) :-
5726 % falling back to normal test
5727 ? normal_closure_not_member(X,Parameters,Types,Body,WF).
5728
5729 :- use_module(library(lists),[same_length/2]).
5730
5731 normal_closure_not_member(El,Parameters,PT,Cond,WF) :-
5732 %hit_profiler:add_profile_hit(closure_not_member(El,Parameters,PT,Cond,WF)),
5733 same_length(Parameters,ParValues),
5734 convert_list_into_pairs(ParValues,El),
5735 ? b_not_test_closure_wf(Parameters,PT,Cond,ParValues,WF).
5736
5737
5738
5739
5740 /* -------------------------- */
5741 /* VARIOUS CLOSURE PREDICATES */
5742 /* -------------------------- */
5743
5744
5745 :- use_module(tools,[convert_list_into_pairs/2]).
5746 :- use_module(b_interpreter,[b_test_boolean_expression/4, b_not_test_boolean_expression/4]).
5747 :- use_module(b_enumerate).
5748
5749 :- assert_pre(custom_explicit_sets:expand_closure_to_list(_,_,ClosureBody,_Result,_Done,_,_WF),
5750 (nonvar(ClosureBody),
5751 bsyntaxtree:check_if_typed_predicate(ClosureBody))).
5752 :- assert_post(custom_explicit_sets:expand_closure_to_list(_,_,_,Result,_Done,_,_WF),
5753 b_interpreter:value_type(Result)).
5754
5755 :- block expand_interval_closure_to_avl(-,?,?), expand_interval_closure_to_avl(?,-,?).
5756 expand_interval_closure_to_avl(Low,Up,Result) :-
5757 Delta is Up-Low,
5758 (Delta>9999 -> perfmessage(expanding_interval(Low,Up)) ; true),
5759 construct_interval_ord_list(Low,Up,OL),
5760 ord_list_to_avlset_direct(OL,ARes,expand_interval),
5761 equal_object(ARes,Result,expand_interval_closure_to_avl).
5762 construct_interval_ord_list(Low,Up,Res) :-
5763 (Low>Up -> Res = []
5764 ; Res = [int(Low)-true|T], L1 is Low+1, construct_interval_ord_list(L1,Up,T)
5765 ).
5766
5767 :- block expand_interval_closure_to_list(-,?,?,?), expand_interval_closure_to_list(?,-,?,?).
5768 expand_interval_closure_to_list(Low,Up,Result,Done) :-
5769 construct_interval_list(Low,Up,OL),
5770 equal_object(OL,Result,expand_interval_closure_to_list),
5771 Done=true.
5772 construct_interval_list(Low,Up,Res) :-
5773 (Low>Up -> Res = []
5774 ; Res = [int(Low)|T], L1 is Low+1, construct_interval_list(L1,Up,T)
5775 ).
5776
5777 expand_closure_to_list([X],[integer],Body,Result,Done,_,_) :-
5778 ? is_interval_closure_body(Body,X,Low,Up),!,
5779 expand_interval_closure_to_list(Low,Up,Result,Done).
5780 expand_closure_to_list(Par,Types,Body,Result,Done,Source,WF) :-
5781 expand_normal_closure(Par,Types,Body,CResult,CDone,expand_closure_to_list(Source),WF),
5782 ? expand_if_avl(CResult,Result,CDone,Done,Source),
5783 lazy_check_elements_of_closure(Result,CDone, Par,Types,Body,WF).
5784
5785 % Note: does slow down test 1306 (91ms mc time becomes 918 ms)
5786 % as long as a closure has not been fully expanded, lazily check elements
5787 % that are instantiated from the outside satisfy the closure predicate
5788 % Note: this can also instantiate unknown values used inside the closure body
5789 lazy_check_elements_of_closure(Result,CDone, Par,Types,Body,WF) :-
5790 (WF==no_wf_available -> true
5791 ? ; lazy_check_elements6(Result,CDone, Par,Types,Body,WF),
5792 propagate_closure_body_value_set(Par,Types,Body,Result,CDone,WF)
5793 ).
5794 % TODO: check if closure is a non-ground projection-member closure and check elements
5795 :- block lazy_check_elements6(-,-, ?,?,?,?).
5796 lazy_check_elements6(_Result,CDone, _Par,_Types,_Body,_WF) :- nonvar(CDone),!.
5797 lazy_check_elements6([H|T],CDone, Par,Types,Body,WF) :- !,
5798 ? element_of_closure(H,Par,Types,Body,WF),
5799 ? lazy_check_elements6(T,CDone, Par,Types,Body,WF).
5800 lazy_check_elements6(avl_set(A),_CDone, Par,Types,Body,WF) :- !,
5801 avl_max(A,X),
5802 element_of_closure(X,Par,Types,Body,WF).
5803 % TO DO: also check avl_min or even all elements ?
5804 lazy_check_elements6(_,_,_,_,_,_).
5805
5806 :- use_module(probsrc(bsyntaxtree),[create_typed_ids/3]).
5807 % lazy check elements from non-var closure body against a result
5808 % for example if we have {x| TRUE |-> x : Value } = Result and Value is not-ground,
5809 % we can check that for all elements TRUE|->x of Value the corresponding x is in Result, see test 2466
5810 % slows down test 1987
5811 :- block propagate_closure_body_value_set(?,?,?,-,-,?).
5812 % we delay until the result is known, possibly in SMT mode it could be useful to propagate earlier
5813 propagate_closure_body_value_set(ParIDs,Types,Body,Result,CDone,WF) :-
5814 var(CDone), % the closure has not yet been fully expanded
5815 % check if this closure can profit from set membership propagation:
5816 b_interpreter:is_for_all_set_membership_predicate2(Body,ParIDs,ParIDs,UnmatchedIDs,Set,_Pattern,_ParValues,_),
5817 UnmatchedIDs=[],
5818 Set = b(value(_Value),_,_), % check that the set is a value; it must be non-ground, otherwise CDone would be true
5819 create_couple_term(ParIDs,Types,CoupleTerm),
5820 SetTerm=b(value(Result),any,[]),
5821 safe_create_texpr(member(CoupleTerm,SetTerm),pred,[],RHS),
5822 create_typed_ids(ParIDs,Types,TIDs),
5823 !,
5824 propagate_closure_body_for_all(TIDs,Body,RHS,Result,CDone,WF).
5825 propagate_closure_body_value_set(_,_,_,_,_,_WF).
5826
5827 :- block propagate_closure_body_for_all(?,?,?,-,-,?).
5828 propagate_closure_body_for_all(TIDs,Body,RHS,_,CDone,WF) :- var(CDone),!,
5829 add_debug_message(closure,'Propagating from closure body to result: ',Body,Body),
5830 Infos=[],
5831 b_interpreter:b_for_all(TIDs,Infos,Body,RHS,[],[],WF).
5832 propagate_closure_body_for_all(_,_,_,_Result,_CDone,_WF). % propagation not required; closure expanded, cf test 1987
5833
5834 %check_valid_avl(AVL,Origin) :-
5835 % (nonvar(AVL) -> true
5836 % ; add_internal_error('Var avl_set: ', check_valid_avl(AVL,Origin)),fail).
5837
5838 :- block expand_if_avl(?,?,-,?,?).
5839 expand_if_avl(avl_set(S),Result,_,Done,Source) :- !, % we could transmit a flag to expand_normal_closure so that transform_result_into_set does not expand to avl
5840 ? expand_custom_set_to_list2(avl_set(S),Result,Done,_,expand_if_avl(Source),no_wf_available).
5841 expand_if_avl(Res,Result,_,Done,Source) :- check_list(Res,expand_if_avl(Source)),
5842 equal_object(Res,Result), Done=true.
5843
5844 check_list(Res,_) :- nonvar(Res), is_list(Res),!.
5845 check_list(Res,Src) :- add_error(Src,'Could not expand to list: ',Res).
5846 is_list([]). is_list([_|_]).
5847
5848 expand_closure_to_avl_or_list([X],[integer],Body,Result,_CheckTimeouts,_WF) :-
5849 ? is_interval_closure_body(Body,X,Low,Up),!,
5850 expand_interval_closure_to_avl(Low,Up,Result).
5851 %expand_closure_to_avl_or_list(P,T,Body,Result,_WF) :- is_member_closure(P,T,Body,TS,Set),
5852 % print(expand_member_closure(P,T,Body,TS,Set)),nl,fail.
5853 expand_closure_to_avl_or_list(Par,Types,Body,Result,CheckTimeouts,WF) :-
5854 expand_normal_closure(Par,Types,Body,CResult,_Done,CheckTimeouts,WF),
5855 kernel_objects:equal_object(Result,CResult,expand_closure_to_avl_or_list). % may convert to AVL, should we wait for _Done?
5856
5857
5858 % use WF just for call stack messages; we should not delay creating result
5859 expand_closure_to_avl_wf([X],[integer],Body,Result,_WF) :-
5860 is_interval_closure_body(Body,X,Low,Up),!,
5861 expand_interval_closure_to_avl(Low,Up,Result). % we could pass WF
5862 expand_closure_to_avl_wf(Par,Types,Body,Result,WF) :-
5863 expand_normal_closure(Par,Types,Body,S,Done,check(expand_closure_to_avl),WF),
5864 (ground_value(S) % ground value is sufficient to proceed; we do not need to check Done
5865 -> convert_to_avl_inside_set(S,R),equal_object(R,Result,expand_closure_to_avl)
5866 ; print(cannot_convert_closure_value_to_avl(closure(Par,Types),done(Done))),nl,
5867 translate:print_bexpr(Body),nl,trace,
5868 fail).
5869
5870
5871 % possible values for CheckTimeouts: check, check_no_inf, no_check, ...
5872 % Note: we no longer check is_infinite_explicit_set(closure(Parameters,ParameterTypes,ClosureBody))
5873 % and no longer raise add_closure_warning(Source,Parameters,ParameterTypes,ClosureBody,'### WARNING: expanding infinite comprehension set: ')
5874 % and no longer use preference warn_when_expanding_infinite_closures
5875 % this is relevant for e.g., test 1291
5876 expand_normal_closure(Parameters,ParameterTypes,ClosureBody,Result,Done,CheckTimeouts,WF) :-
5877 expand_normal_closure_memo(CheckTimeouts,Parameters,ParameterTypes,ClosureBody,Result,Done,WF).
5878
5879 :- public add_closure_warning_wf/6.
5880 add_closure_warning_wf(Source,Parameters,_ParameterTypes,_ClosureBody,_MSG,_WF) :-
5881 preference(provide_trace_information,false),preference(strict_raise_warnings,false),!,
5882 format('### TIME-OUT raised during closure expansion (~w,~w).~n### set TRACE_INFO preference to TRUE for more details.~n',[Parameters,Source]).
5883 add_closure_warning_wf(Source,Parameters,ParameterTypes,ClosureBody,MSG,WF) :-
5884 (debug_mode(on) -> Limit = 2500, AvlLim=10 ; Limit = 500, AvlLim=5),
5885 preferences:temporary_set_preference(expand_avl_upto,AvlLim,CHNG),
5886 call_cleanup(translate:translate_bvalue_with_limit(closure(Parameters,ParameterTypes,ClosureBody),Limit,CT),
5887 preferences:reset_temporary_preference(expand_avl_upto,CHNG)),
5888 bsyntaxtree:get_texpr_info(ClosureBody,Infos),
5889 add_warning_wf(Source,MSG,CT,Infos,WF), debug_print(19,'! infos: '), debug_println(Infos). %,trace.
5890
5891
5892 :- use_module(memoization,[is_memoization_closure/4,get_complete_memoization_expansion/6]).
5893
5894 % a version of closure expansion which memoizes its results; stored_expansion needs to be cleared when new machine loaded
5895 expand_normal_closure_memo(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5896 ? is_memoization_closure(Parameters,ParameterTypes,ClosureBody,MemoID),
5897 !, Span=ClosureBody,
5898 % MemoID can be a variable
5899 (var(MemoID) -> perfmessage(CHECK,'Getting full value of a memoized function',ClosureBody) ; true),
5900 get_complete_memoization_expansion(MemoID,FullResult,Done,Span,expand_normal_closure_memo(CHECK),WF).
5901 expand_normal_closure_memo(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5902 preferences:preference(use_closure_expansion_memoization,false),!,
5903 expand_normal_closure1(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF).
5904 expand_normal_closure_memo(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5905 % maybe we should only memo when ClosureWaitVars are ground ?
5906 MemoLookupTerm = closure(Parameters,ParameterTypes,ClosureBody),
5907 compute_memo_hash(MemoLookupTerm,Hash),
5908 % idea: maybe store expansion only on second hit ?
5909 (get_stored_memo_expansion(Hash,MemoLookupTerm,StoredResult)
5910 -> %print_term_summary(reusing_expansion(Hash,Parameters,ParameterTypes,ClosureBody,StoredResult)),nl,
5911 UPV=StoredResult, %state_packing:unpack_value(StoredResult,UPV),
5912 FullResult = UPV, Done=true
5913 ; %statistics(runtime,[T1,_]), %%
5914 expand_normal_closure1(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF),
5915 %statistics(runtime,[T2,_]), Time is T2-T1, store_memo_computation_time(Hash,Time),
5916 (Done==true/* ,T2-T1>0*/
5917 -> PackedValue=FullResult, %state_packing:pack_value(FullResult,PackedValue),
5918 store_memo_expansion(Hash,MemoLookupTerm,PackedValue)
5919 ; true)
5920 ).
5921
5922 expand_normal_closure1(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5923 preference(provide_trace_information,false),!,
5924 expand_normal_closure2(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF).
5925 expand_normal_closure1(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5926 get_texpr_info(ClosureBody,Info),
5927 push_wait_flag_call_stack_info(WF,
5928 quantifier_call(comprehension_set(all_solutions),Parameters,[],Info),WF2),
5929 expand_normal_closure2(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF2).
5930
5931
5932 expand_normal_closure2(_CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5933 % TO DO: add more symbolic member closures who have expression computation code
5934 is_closure1_value_closure(Parameters,ParameterTypes,ClosureBody,VAL),!,
5935 bsets_clp:relational_trans_closure_wf(VAL,FullResult,WF),
5936 ground_value_check(FullResult,FRGr),
5937 when(nonvar(FRGr),Done=true).
5938 expand_normal_closure2(CHECK,Parameters,ParameterTypes,ClosureBody,FullResult,Done,WF) :-
5939 % special treatment for lambda closures: Advantage: we don't have to wait for variables in EXPR body of closure
5940 % Disadvantage: EXPR only gets evaluated after a solution has been found for args: can mean repeated computations !
5941 % (cf pas_as_env_inv_cv_sui, negated version of !(cv_i).(cv_i : t_cv_pas => closure(%cv_o2.((...|>> {cv_i} : t_cv_pas <-> t_cv_pas) ASSERTION
5942 % Advantage: it can solve constraints such as f = %x.(x:1..10|x+y) & f(5)=1005 (finding y without enumeration); see test 1168
5943 \+ preferences:preference(use_smt_mode,false),
5944 is_lambda_closure(Parameters,ParameterTypes,ClosureBody, OtherIDs,OtherTypes, DomainPred, EXPR),
5945 \+ ground_bexpr(EXPR), % if EXPR is ground, there is nothing to be gained by special treatment here
5946 WF \= no_wf_available, % otherwise we may have to enumerate EXPR result leading to choice points, e.g. in phase 0
5947 !,
5948 bexpr_variables(DomainPred,ClosureWaitVars),
5949 (CHECK=no_check -> TIMEOUTCODE = true ;
5950 TIMEOUTCODE = add_closure_warning_wf(CHECK,Parameters,ParameterTypes,ClosureBody,
5951 'TIME-OUT occurred while ProB was expanding: ',WF)),
5952 (CHECK=check_no_inf -> VIRTUALTIMEOUTCODE=true ; VIRTUALTIMEOUTCODE=TIMEOUTCODE),
5953 delay_setof_check_wf( ParTuple,
5954 (custom_explicit_sets:b_test_closure(OtherIDs,OtherTypes,DomainPred,OtherValues,all_solutions,WF),
5955 convert_list_into_pairs(OtherValues,ParTuple)
5956 % TO DO: compile EXPR when we start expanding the closure: to avoid repeated re-computation of expressions for every instance
5957 ),
5958 Result, ClosureWaitVars, __Done,
5959 TIMEOUTCODE,VIRTUALTIMEOUTCODE,WF,DomainPred),
5960 (WF = no_wf_available
5961 -> init_wait_flags(WF1,[expansion_context(lambda_function_result,Parameters)])
5962 ; WF1=WF
5963 ),
5964 evaluate_result_expr(Result,EXPR,OtherIDs,EvResult,EvDone,WF1),
5965 when(nonvar(EvDone),(
5966 (WF = no_wf_available -> ground_wait_flags(WF1) ; true),
5967 kernel_objects:equal_object_wf(EvResult,FullResult,expand_normal_closure2,WF),
5968 Done=true)).
5969 expand_normal_closure2(no_check,Parameters,ParameterTypes,ClosureBody,Result,Done,WF) :- !,
5970 expand_normal_closure_direct(Parameters,ParameterTypes,ClosureBody,Result,Done,WF).
5971 expand_normal_closure2(CHECK,Parameters,ParameterTypes,ClosureBody,Result,Done,WF) :-
5972 bexpr_variables(ClosureBody,ClosureWaitVars),
5973 TIMEOUTCODE = add_closure_warning_wf(CHECK,Parameters,ParameterTypes,ClosureBody,
5974 'TIME-OUT occurred while ProB was expanding: ',WF),
5975 (CHECK=check_no_inf -> VIRTUALTIMEOUTCODE=true ; VIRTUALTIMEOUTCODE=TIMEOUTCODE),
5976 % Note: delay_setof_check_wf will throw enumeration warning for virtual timeouts, after VIRTUALTIMEOUTCODE
5977 delay_setof_check_wf( ParTuple,
5978 custom_explicit_sets:test_closure_and_convert(Parameters,ParameterTypes,ClosureBody, ParTuple,WF),
5979 Result, ClosureWaitVars, Done, TIMEOUTCODE, VIRTUALTIMEOUTCODE,WF,ClosureBody).
5980
5981 expand_normal_closure_direct(Parameters,ParameterTypes,ClosureBody,Result,Done,WF) :-
5982 bexpr_variables(ClosureBody,ClosureWaitVars),
5983 Span = ClosureBody,
5984 delay_setof_wf( ParTuple,
5985 % TO DO: refresh waitflag in outer WF store to let pending code run to completion and avoid spurious WD errors ?
5986 custom_explicit_sets:test_closure_and_convert(Parameters,ParameterTypes,ClosureBody, ParTuple,WF),
5987 Result, ClosureWaitVars, Done,WF, Span).
5988
5989
5990
5991 :- block evaluate_result_expr(-,?,?,?,?,?).
5992 evaluate_result_expr(avl_set(AVL),EXPR,OtherIDs,Res,Done,WF) :-
5993 avl_domain(AVL,R),
5994 evaluate_result_expr(R,EXPR,OtherIDs,Res,Done,WF).
5995 evaluate_result_expr([],_EXPR,_OtherIDs,[],Done,_WF) :-
5996 %ground_wait_flags(WF),
5997 Done=true.
5998 evaluate_result_expr([ParTuple|T],EXPR,OtherIDs,[FullTuple|ET],Done,WF) :-
5999 % same_length(OtherIDs,ParValues), % not necessary
6000 set_up_localstate(OtherIDs,ParValues,[],LocalState),
6001 convert_list_into_pairs(ParValues,ParTuple), % bind values in ParTuple to LocalState
6002 b_interpreter:b_compute_expression(EXPR,LocalState,[],EXPRVALUE,WF),
6003 append(ParValues,[EXPRVALUE],FullValues),
6004 convert_list_into_pairs(FullValues,FullTuple),
6005 evaluate_result_expr(T,EXPR,OtherIDs,ET,Done,WF).
6006
6007 :- use_module(bsyntaxtree,[split_names_and_types/3]).
6008 :- use_module(probsrc(bsyntaxtree), [def_get_texpr_id/2]).
6009 %:- use_module(library(lists),[prefix_length/3, suffix_length/3]).
6010 % test a closure and convert into pairs; assume we want all solutions
6011 test_closure_and_convert(Parameters,ParameterTypes,ClosureBody, ParTuple, WF) :-
6012 is_recursive_closure(Parameters,ParameterTypes,ClosureBody),
6013 get_recursive_identifier_of_closure_body(ClosureBody,TRID),!,
6014 def_get_texpr_id(TRID,RID), get_texpr_type(TRID,RType),
6015 %print(test_recursion(RID)),nl, translate:nested_print_bexpr(ClosureBody),nl,
6016 RecVal = closure(Parameters,ParameterTypes,ClosureBody), % Recursive Value added to parameters
6017 same_length(Parameters,ParValues),
6018 reset_closure_solution_counter(Parameters),
6019 b_test_closure([RID|Parameters],[RType|ParameterTypes],ClosureBody,[RecVal|ParValues],all_solutions,WF),
6020 convert_sol_list_into_pairs(ParValues,Parameters,ParTuple). % convert tuple without recursive value to ParTuple
6021 test_closure_and_convert(Parameters,ParameterTypes,b(exists(EParAndTypes,ClosureBody),pred,OuterInfo), ParTuple, WF) :-
6022 % Motivation: enumerating Parameters can be quite inefficient
6023 % if for example we have something like {x|#y.(y:SmallSet & x=f(y))}
6024 % Problem: the existential quantifier will be delayed until the Parameters are instantiated !
6025 % relevant test: 1162
6026 % Note: this is duplicating to some extent the code in b_test_exists_wo_expansion
6027 % However, here we can also apply lambda_closure optimisation in b_test_closure below, this is
6028 % relevant for private_examples/2023/.../rule_FICHIER_MRGATKSAATPAR_RVF219_MRGA_DE.mch
6029 ? exists_should_be_lifted(Parameters,ParameterTypes,OuterInfo,ClosureBody),
6030 split_names_and_types(EParAndTypes,EPar,ETypes),
6031 !,
6032 % print(' Lifting existential quantifier (i.e., enumerating paras with closure paras): '), print(EPar),nl,
6033 % print(outer_paras(Parameters)),nl,
6034 % append Parameters at end; in case we have a lambda function
6035 append(EPar,Parameters,FullPar), length(Parameters,NrParas),
6036 append(ETypes,ParameterTypes,FullTypes),
6037 length(EPar,NrExistsParas),
6038 length(IrrelevantParas,NrExistsParas), length(Suffix,NrParas),
6039 append(IrrelevantParas,Suffix,FullParList),
6040 copy_identifier_infos(OuterInfo,ClosureBody,ClosureBody2),
6041 reset_closure_solution_counter(Parameters),
6042 % bsyntaxtree:check_used_ids_in_ast(ClosureBody2),
6043 ? b_test_closure(FullPar,FullTypes,ClosureBody2, FullParList,all_solutions,WF),
6044 convert_sol_list_into_pairs(Suffix,Parameters,ParTuple).
6045 test_closure_and_convert(Parameters,ParameterTypes,ClosureBody, ParTuple, WF) :-
6046 reset_closure_solution_counter(Parameters),
6047 % print(test),nl, translate:nested_print_bexpr(ClosureBody),nl,
6048 length(Parameters,Len), length(ParValues,Len),
6049 %(annotate_exists(Parameters,ParameterTypes,ClosureBody,Body2) -> true ; Body2=ClosureBody),
6050 ? b_test_closure(Parameters,ParameterTypes,ClosureBody,ParValues,all_solutions,WF),
6051 convert_sol_list_into_pairs(ParValues,Parameters,ParTuple). % ,print(solution(ParTuple)),nl,nl.
6052
6053 % Lifting existential quantifier was previously done here, but was duplicating code in b_test_exists_wo_expansion
6054 % we now simply generate the allow_to_lift_exists annotation here and let b_test_exists_wo_expansion do its job
6055 %annotate_exists(Parameters,ParameterTypes,
6056 % b(exists(EParAndTypes,ClosureBody),pred,OuterInfo),
6057 % b(exists(EParAndTypes,ClosureBody),pred,[allow_to_lift_exists|OuterInfo])) :-
6058 % exists_should_be_lifted(Parameters,ParameterTypes,OuterInfo,ClosureBody).
6059
6060 % check if a top-level exists with body ExistsClosureBody should be lifted
6061 % within a closure with paras Parameters of type ParameterTypes:
6062 exists_should_be_lifted(Parameters,ParameterTypes,OuterInfo,ExistsClosureBody) :-
6063 (Parameters == ['_was_lambda_result_'] % here we are quite sure that we gain by this optimisation
6064 ? ; member(allow_to_lift_exists,OuterInfo) % parameters were originally from a set comprehension,
6065 % see test 306: in this case existential quantifier is lifted in b_interpreter anyway;
6066 % Note we counter the rewrite ran({x1,...xn|P}) ---> {xn| #(x1,...).(P)} and similarly for dom({...})
6067 ; ExistsClosureBody = b(member(_,_),_,_) % we have a simple projection closure
6068 % TO DO: maybe support other ones as well
6069 ? ; basic_type_list_cardinality(ParameterTypes,Card),
6070 (Card=inf -> true ; Card=inf_overflow -> true ; Card>10000) % geq_inf(Card,10001)
6071 % if here are only a few parameter values: do not lift existential quantified variables
6072 ).
6073
6074 % we need to copy important infos about the outer Parameters to ClosureBody
6075 copy_identifier_infos(Info,b(InnerPred,T,II),b(InnerPred,T,II2)) :-
6076 findall(I,identifier_info(I,Info),ToCopy),
6077 append(ToCopy,II,II2).
6078 identifier_info(I,Info) :- I=prob_annotation('DO_NOT_ENUMERATE'(ID)),
6079 ? member(I,Info), ID \= '$$NONE$$'.
6080
6081 convert_sol_list_into_pairs(ParaValues,Parameters,ParTuple) :-
6082 convert_list_into_pairs(ParaValues,ParTuple),
6083 update_closure_solution_counter(Parameters,ParTuple).
6084
6085 :- if(environ(prob_debug_flag,true)).
6086 :- dynamic closure_solution_counter/3.
6087 % debugging long expansions of comprehension_set / closures
6088 reset_closure_solution_counter(Parameters) :- retractall(closure_solution_counter(Parameters,_,_)).
6089
6090 update_closure_solution_counter(Parameters,ParTuple) :-
6091 retract(closure_solution_counter(Parameters,OldCount,OldTime)),!,
6092 statistics(walltime,[W2,_]), Delta is W2-OldTime,
6093 NewCount is OldCount+1,
6094 ((Delta > 5000 ; NewCount mod 1000 =:= 0)
6095 -> format('--> Solution ~w for expansion of closure ~w (delta ~w ms): ',[NewCount,Parameters,Delta]),
6096 translate:print_bvalue(ParTuple),nl,
6097 assert(closure_solution_counter(Parameters,NewCount,W2))
6098 ; assert(closure_solution_counter(Parameters,NewCount,OldTime))
6099 ).
6100 update_closure_solution_counter(Parameters,_ParTuple) :-
6101 statistics(walltime,[W2,_]),
6102 assert(closure_solution_counter(Parameters,1,W2)).
6103 :- else.
6104 reset_closure_solution_counter(_).
6105 update_closure_solution_counter(_,_).
6106 :- endif.
6107
6108
6109
6110 % compute cardinality of a list of basic types
6111 basic_type_list_cardinality([],1).
6112 basic_type_list_cardinality([BasicType|T],Res) :-
6113 basic_type_list_cardinality(T,TCard),
6114 (TCard=inf -> Res=inf
6115 ? ; kernel_objects:max_cardinality(BasicType,Card),
6116 safe_mul(Card,TCard,Res)
6117 ).
6118
6119 % for lambda closures we can set up a second waitflag for the expression and only ground it when body enumeration finished
6120 % idea is to avoid perturbation of constraint solving of main closure predicate by lambda expression, see test 1737
6121 % something like %(x,y).(x:1..200 & y:1..100 & y+x<259 & y*x>10|(y+x*x+y) mod 100) is faster
6122 % this is slower : %(x,y).(x:1..200 & y:1..100 |(y+x*x+y))
6123 % currently this slows down test 1336
6124 :- block b_test_closure(?,?,-,?,?,?).
6125 b_test_closure(Parameters,ParameterTypes,ClosureBody, FullParValues, NegationContext, OuterWF) :-
6126 (preference(data_validation_mode,true)
6127 -> true % avoids ineraction between domain and range expression enumeration; see
6128 % private_examples/ClearSy/2019_May/perf_3264/rule_186.mch or
6129 % computation of 631 ic___DMI_MRGATKSAAT___Parametre_Identifiant_indices_function in rule_FICHIER_MRGATKSAATPAR_RVF219_MRGA_DE.mch
6130 % however, as b_optimize below does *not* evaluate nested set comprehensions, there can be a slowdown:
6131 % the nested set comprehension gets re-evaluated for every soluiton of the lambda parameters !
6132 % this was the case of private_examples/ClearSy/2019_Nov/rule_Regle_31C_0005/rule.mch before using SORT
6133 ; \+ preferences:preference(use_smt_mode,false)), % TO DO: enable in normal mode when performance of 1336 fixed
6134 % print(test_closure(Parameters,FullParValues)),nl,
6135 is_lambda_closure(Parameters,ParameterTypes,ClosureBody, OtherIDs,OtherTypes, DomainPred, EXPR),
6136 % TO DO: detect not only equalities at end, but any equality which is irrelevant for the rest
6137 % nl,print(lambda_closure(OtherIDs)),nl, translate:print_bexpr(EXPR),nl,
6138 append(ParValues,[LambdaResult],FullParValues),
6139 !,
6140 get_texpr_info(ClosureBody,BInfo),
6141 ? b_interpreter:set_up_typed_localstate2(OtherIDs,OtherTypes,BInfo,ParValues,TypedVals,[],LocalState,NegationContext),
6142 simplify_span(ClosureBody,BSpan), % sometimes BInfo no longer contains a position info, but first_sub_expr does
6143 init_quantifier_wait_flag(OuterWF,comprehension_set(NegationContext),OtherIDs,ParValues,BSpan,WF),
6144 ? b_test_boolean_expression(DomainPred,LocalState,[],WF),
6145 %print('PRED: '),translate:print_bexpr(ClosureBody),nl,
6146 b_tighter_enumerate_values_in_ctxt(TypedVals,DomainPred,WF), % also does: project_away_useless_enumeration_values
6147 init_quantifier_wait_flag(OuterWF,comprehension_set(NegationContext),OtherIDs,ParValues,BSpan,WF2),
6148 b_compiler:b_optimize(EXPR,[],LocalState,[],CEXPR,WF), % already pre-compile lookup, without constraint processing; is not sufficient for test 1336
6149 ? ground_wait_flags(WF), % TODO: also call ground inner WF in context
6150 b_interpreter:b_compute_expression(CEXPR,LocalState,[],LambdaResult,WF2),
6151 ground_inner_wait_flags_in_context(NegationContext,WF2).
6152 b_test_closure(Parameters,ParameterTypes,ClosureBody,ParValues,NegationContext, OuterWF) :-
6153 % tools:print_bt_message(b_test_closure_testing_closure(Parameters,ParValues)), %%
6154 get_texpr_info(ClosureBody,BInfo),
6155 ? b_interpreter:set_up_typed_localstate2(Parameters,ParameterTypes,BInfo,
6156 ParValues,TypedVals,[],LocalState,NegationContext),
6157 % print_message(b_interpreter:b_test_boolean_expression(ClosureBody,LocalState,[],WF)),
6158 simplify_span(ClosureBody,BSpan), % sometimes BInfo no longer contains a position info, but first_sub_expr does
6159 init_quantifier_wait_flag(OuterWF,comprehension_set(NegationContext),Parameters,ParValues,BSpan,WF),
6160 %external_functions:observe_parameters(Parameters,LocalState), %%
6161 ? b_test_boolean_expression(ClosureBody,LocalState,[],WF),
6162 % tools:print_bt_message(tested_bool_expr), translate:print_bexpr(ClosureBody),nl,
6163 b_enumerate:b_tighter_enumerate_values_in_ctxt(TypedVals,ClosureBody,WF), % also detects useless enumeration ids
6164 ? ground_inner_wait_flags_in_context(NegationContext,WF).
6165
6166
6167
6168 :- block b_not_test_closure_wf(?,?,?,-,?).
6169 b_not_test_closure_wf(Parameters,ParameterTypes,Closure,ParValues,WF) :-
6170 % same_length(Parameters,ParValues), % not necessary
6171 set_up_localstate(Parameters,ParValues,[],LocalState),
6172 b_enumerate:b_type_values_in_store(Parameters,ParameterTypes,LocalState),
6173 ? b_not_test_boolean_expression(Closure,LocalState,[],WF),
6174 get_last_wait_flag(b_not_test_closure_wf(Parameters),WF,WF2),
6175 get_texpr_info(Closure,Infos),
6176 b_not_test_closure_enum(Parameters,ParameterTypes,Infos,LocalState,WF,WF2).
6177
6178 :- block b_not_test_closure_enum(-,?,?,?,?,?).
6179 b_not_test_closure_enum(Parameters,ParameterTypes,Infos,LocalState,WF,WF2) :-
6180 b_enumerate:b_extract_typedvalc(Parameters,ParameterTypes,Infos,LocalState,TypedVals),
6181 (var(WF2) -> ground_typedvals_check(TypedVals,GrVals) ; true),
6182 b_not_test_closure_enum_aux(GrVals,WF2,TypedVals,WF).
6183
6184 :- block b_not_test_closure_enum_aux(-,-,?,?).
6185 b_not_test_closure_enum_aux(_,_,TypedVals,WF) :-
6186 b_enumerate:b_tighter_enumerate_all_values(TypedVals,WF).
6187 % , print(finished_enum(Parameters)),nl.
6188
6189
6190 :- use_module(library(terms)).
6191 % check whether a VARIABLE occurs inside a closure
6192 closure_occurs_check(VARIABLE,_Par,_ParTypes,ClosureBody) :- expression_contains_setvar(ClosureBody,VARIABLE).
6193 % /* occurs check; x = closure1(x) ; for other closures this cannot happen ???!!! TO DO: Check */
6194 % custom_explicit_sets:is_closure1_value_closure(Par,ParTypes,ClosureBody,Val),
6195 % contains_var(VARIABLE,Val).
6196
6197 expression_contains_setvar(b(E,_,_),Variable) :- !,
6198 expression_contains_setvar_aux(E,Variable).
6199 expression_contains_setvar(E,V) :- add_internal_error('Illegal Expression: ', expression_contains_setvar(E,V)),
6200 contains_var(V,E).
6201
6202 expression_contains_setvar_aux(value(Val),Variable) :- !,value_contains_setvar(Val,Variable).
6203 % a few very common cases for performance; currently this predicate is often called for recursive functions
6204 expression_contains_setvar_aux(identifier(_),_) :- !,fail.
6205 expression_contains_setvar_aux(equal(A,B),Variable) :- !,
6206 (expression_contains_setvar(A,Variable) -> true ; expression_contains_setvar(B,Variable)).
6207 expression_contains_setvar_aux(conjunct(A,B),Variable) :- !,
6208 (expression_contains_setvar(A,Variable) -> true ; expression_contains_setvar(B,Variable)).
6209 expression_contains_setvar_aux(function(A,B),Variable) :- !,
6210 (expression_contains_setvar(A,Variable) -> true ; expression_contains_setvar(B,Variable)).
6211 expression_contains_setvar_aux(union(A,B),Variable) :- !,
6212 (expression_contains_setvar(A,Variable) -> true ; expression_contains_setvar(B,Variable)).
6213 expression_contains_setvar_aux(couple(A,B),Variable) :- !,
6214 (expression_contains_setvar(A,Variable) -> true ; expression_contains_setvar(B,Variable)).
6215 % the rest via safe_syntaxelement:
6216 expression_contains_setvar_aux(Expr,V) :-
6217 safe_syntaxelement_det(Expr,Subs,_Names,_,_),!,
6218 ? member(Sub,Subs), expression_contains_setvar(Sub,V),!.
6219 expression_contains_setvar_aux(E,V) :- add_internal_error('Illegal Expression: ', expression_contains_setvar_aux(E,V)),
6220 contains_var(V,E).
6221
6222 value_contains_setvar(Val,V) :- var(Val),!,Val==V.
6223 value_contains_setvar(avl_set(_),_V) :- !, fail. % assume avl_set always properly grounded; avoid looking inside
6224 value_contains_setvar(closure(_,_,Body),V) :- !,
6225 expression_contains_setvar(Body,V).
6226 value_contains_setvar(int(_),_) :- !,fail. % we check for set variables
6227 value_contains_setvar(global_set(_),_) :- !,fail. % we check for set variables
6228 value_contains_setvar(freetype(_),_) :- !,fail. % we check for set variables
6229 value_contains_setvar(freeval(_ID,_Case,Val),V) :- !, value_contains_setvar(Val,V).
6230 value_contains_setvar(string(_),_) :- !,fail. % we check for set variables
6231 value_contains_setvar(fd(_,_),_) :- !,fail. % we check for set variables
6232 value_contains_setvar((A,B),V) :- !, (value_contains_setvar(A,V) ; value_contains_setvar(B,V)).
6233 value_contains_setvar([A|B],V) :- !, (value_contains_setvar(A,V) ; value_contains_setvar(B,V)).
6234 value_contains_setvar(Val,V) :-
6235 contains_var(V,Val).
6236
6237 % ------------------