1 % (c) 2009-2025 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2 % Heinrich Heine Universitaet Duesseldorf
3 % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5 :- module(kernel_objects,[basic_type/2,
6 enumerate_basic_type/2, enumerate_basic_type_wf/3, enumerate_basic_type_wf/4,
7 all_objects_of_type/2,
8 max_cardinality/2,
9 enumerate_type/3, % last argument basic or tight
10 enumerate_type_wf/4,
11 enumerate_type/4, % last argument false/true disables/enables enum warning
12 enumerate_basic_type/3,
13 enumerate_tight_type/2, enumerate_tight_type/3, enumerate_tight_type_wf/4,
14 enumerate_int/3,
15 gen_enum_warning_wf/6,
16 all_strings_wf/2, is_string/2, is_not_string/1,
17
18 top_level_dif/2,
19 equal_object_optimized/2, equal_object_optimized/3, equal_object_optimized_wf/4,
20 equal_object/2, equal_object/3, equal_object_wf/3, equal_object_wf/4,
21 not_equal_object/2, not_equal_object_wf/3,
22 equal_cons/3, equal_cons_wf/4, equal_cons_lwf/5,
23 get_next_element/3,
24 is_marked_to_be_computed/1, mark_as_to_be_computed/1,
25
26 %equality_objects/3,
27 membership_test_wf/4,
28
29 %is_a_set/1,
30 empty_set/1, empty_set_wf/2,
31 not_empty_set/1, not_empty_set_wf/2,
32 exact_element_of/2,
33 check_element_of/2, check_element_of_wf/3,
34 not_element_of/2, not_element_of_wf/3,
35
36 add_element/3, add_element/4, add_element_wf/4, add_element_wf/5,
37 add_new_element_wf/4,
38 delete_element_wf/4,
39 %remove_element/3,
40 remove_element_wf/4,remove_element_wf/5,remove_element_wf_if_not_infinite_or_closure/6,
41 remove_exact_first_element/3,
42 check_no_duplicates_in_list/3,
43
44 partition_wf/3, not_partition_wf/3, test_partition_wf/4,
45 %all_different/2,
46 disjoint_sets/3, not_disjoint_sets/3, test_disjoint_wf/4,
47
48 union/3, union_wf/4, union_generalized/2, union_generalized_wf/3,
49 intersection/3, intersection_generalized_wf/4,
50 difference_set/3, difference_set_wf/4,
51 in_difference_set_wf/4, not_in_difference_set_wf/4,
52 in_union_set_wf/4, not_in_union_set_wf/4,
53 in_intersection_set_wf/4, not_in_intersection_set_wf/4,
54
55 strict_subset_of/2, strict_subset_of_wf/3,
56 check_subset_of/2, check_subset_of_wf/3, check_finite_subset_of_wf/3,
57 check_non_empty_subset_of_wf/3, check_finite_non_empty_subset_of_wf/3,
58 not_subset_of/2, not_subset_of_wf/3, not_both_subset_of/5,
59 not_finite_subset_of_wf/3,
60 not_strict_subset_of/2, not_strict_subset_of_wf/3,
61 not_non_empty_subset_of_wf/3, not_non_empty_finite_subset_of_wf/3,
62 both_global_sets/4,check_subset_of_global_sets/2, check_not_subset_of_global_sets/2,
63
64 first_of_pair/2, second_of_pair/2,
65 minimum_of_set_extension_list/4,
66 maximum_of_set_extension_list/4,
67 minimum_of_set/4, maximum_of_set/4,
68 is_finite_set_wf/2, is_infinite_set_wf/2, test_finite_set_wf/3,
69 %finite_cardinality_as_int/3, % now we use kernel_cardinality_attr
70 cardinality_as_int_for_wf/2,
71 cardinality_as_int_wf/3,
72 cardinality_as_int/2, %cardinality_peano_wf/3,
73 card_convert_int_to_peano/2,
74 same_cardinality_wf/3,
75 % card_geq/2,
76 cardinality_greater/5, cardinality_greater_equal/5,
77 cardinality_of_range/3,
78 cardinality_of_set_extension_list/3,
79
80 cartesian_product_wf/4,
81 is_cartesian_pair_wf/4, not_is_cartesian_pair/4,
82
83 power_set/2, non_empty_power_set/2,
84
85 % is_boolean/1, %is_not_boolean/1,
86 is_integer/2, is_not_integer/1,
87 is_natural/2, is_natural1/2,
88 is_implementable_int/2,is_implementable_nat/2, is_implementable_nat1/2,
89 is_not_natural/1, is_not_natural1/1,
90 is_not_implementable_int/1,is_not_implementable_nat/1, is_not_implementable_nat1/1,
91
92 less_than/2, less_than_equal/2,
93 less_than_direct/2, less_than_equal_direct/2,
94 safe_less_than_equal/2, safe_less_than_equal/3,
95
96 greater_than/2, greater_than_equal/2,
97 int_plus/3,
98 division/5, floored_division/5,
99 modulo/5,
100 int_minus/3, unary_minus_wf/3,
101 % nat_range/3, % removed
102 in_nat_range_wf/4, not_in_nat_range/3, not_in_nat_range_wf/4, test_in_nat_range_wf/5,
103 in_nat_range/3, % version without enumeration
104 times/3, square/3,
105 int_power/5,
106 % pred/2, succ/2, removed
107 integer_global_set/1,
108
109 element_of_global_set/2,element_of_global_set_wf/3,not_element_of_global_set/2,
110
111 exhaustive_kernel_check/1, exhaustive_kernel_check_wf/2, exhaustive_kernel_check_wf/3,
112 exhaustive_kernel_check_wfdet/2, exhaustive_kernel_check_wf_upto/3,
113 exhaustive_kernel_succeed_check/1, exhaustive_kernel_fail_check/1,
114 exhaustive_kernel_fail_check_wf/2, exhaustive_kernel_fail_check_wfdet/2,
115 exhaustive_kernel_fail_check_wf_upto/3,
116 exhaustive_kernel_fail_check_wfinit/2,
117 exhaustive_kernel_check/2, exhaustive_kernel_succeed_check/2, exhaustive_kernel_fail_check/2,
118
119 singleton_set_element/4, singleton_set_element_wd/4,
120 infer_value_type/2,
121 check_values_have_same_type/3,
122 contains_any/1
123 ]).
124
125 :- meta_predicate exhaustive_kernel_check_opt(-,0).
126 :- meta_predicate exhaustive_kernel_fail_check_opt(-,0).
127 :- meta_predicate not_strict_eq_check(-,0).
128
129 %:- use_module('../extensions/profiler/profiler.pl').
130 %:- use_module('../extensions/profiler/profiler_te.pl').
131 %:- enable_profiling(enumerate_basic_type/3).
132 %:- enable_profiling(enumerate_type/3).
133 %:- enable_profiling(enumerate_tight_type/2).
134
135 %:- print(loading_kernel_objects),nl.
136
137 %:- multifile user:portray_message/2.
138 %user:portray_message(informational, _).
139 :- use_module(library(terms)).
140 :- use_module(self_check).
141
142 :- use_module(debug).
143 :- use_module(tools_platform, [platform_is_64_bit/0]).
144 :- use_module(tools_printing).
145 :- use_module(tools).
146
147 :- use_module(module_information,[module_info/2]).
148 :- module_info(group,kernel).
149 :- module_info(description,'This module provides operations for the basic datatypes of ProB (equal, not_equal, enumeration).').
150
151 :- use_module(typechecker).
152 :- use_module(error_manager).
153 :- use_module(b_global_sets). %,[global_type/2, b_global_set_cardinality/2, b_empty_global_set/1]).
154 :- use_module(kernel_waitflags).
155 :- use_module(library(lists)).
156 :- use_module(library(avl),[avl_min/2, avl_max/2]).
157 :- use_module(library(clpfd)).
158 :- use_module(fd_utils_clpfd).
159 :- use_module(kernel_freetypes).
160 :- use_module(kernel_card_arithmetic).
161 :- use_module(custom_explicit_sets).
162 :- use_module(typechecker).
163 %:- use_module(clpfd_off_interface). %
164 % on a 32 bit system: use clpfd_off_interface; on 64 bit system clpfd_interface should be ok (integer overflows)
165 :- use_module(clpfd_interface). %
166 :- use_module(bsyntaxtree, [get_texpr_id/2, get_texpr_pos/2]).
167
168 :- type atomic_type +--> (term(integer,[]) ; term(string,[]) ; constant(list(atomic)) ; abort ; boolean ; global(atomic)).
169 :- type atomic_any_type +--> (type(atomic_type) ; term(any,[]) ).
170 :- type basic_type_descriptor +--> (type(atomic_any_type) ; set(basic_type_descriptor) ;
171 seq(basic_type_descriptor) ;
172 couple(basic_type_descriptor,basic_type_descriptor) ;
173 record(list(type(field_type))) ;
174 freetype(atomic)).
175
176 :- type inferred_basic_type_descriptor +--> (var ; type(atomic_type) ; set(inferred_basic_type_descriptor) ;
177 seq(inferred_basic_type_descriptor) ;
178 couple(inferred_basic_type_descriptor,inferred_basic_type_descriptor)).
179
180 :- type fd_index +--> (integer ; var).
181 :- type fd_set +--> (atomic ; var).
182 :- type fd_term +--> fd(fd_index,fd_set).
183 :- type bsets_integer +--> int((integer ; var)).
184 :- type bsets_string +--> string((atomic ; var)).
185 :- type bsets_bool +--> (pred_false /* bool_false */ ; pred_true /* bool_true */).
186 :- type field_type +--> field(atomic,basic_type_descriptor).
187
188 %:- type bsets_sequence +--> (nil_seq ; cons(type(bsets_object),type(bsets_sequence))).
189 %:- type bsets_set +--> vlist(type(bsets_object)).
190 :- functor([_|_],ListFunctor,_),
191 (type bsets_set +--> (term([],[]) ; var ; term(ListFunctor,[type(bsets_object),type(bsets_set)]) ;
192 avl_set( ground ) ;
193 closure(list(type(variable_id)),
194 list(type(basic_type_descriptor)),type(boolean_expression))
195 ; closure_x(list(type(variable_id)),
196 list(type(basic_type_descriptor)),type(boolean_expression),any))).
197 :- type bsets_couple +--> term(',',[type(bsets_object),type(bsets_object)]).
198 :- type bsets_global +--> global_set((atomic ; var)).
199 :- type bsets_field +--> field(atomic,type(bsets_object)).
200 :- type bsets_record +--> rec((var ; list(bsets_field))).
201 :- type bsets_freetype +--> freeval(atomic,(atomic ; var),type(bsets_object)).
202
203 :- type bsets_object +--> (fd_term ; bsets_integer ; bsets_bool ; term(term,[any]) ; bsets_set ;
204 % abort(any) ; % deprecated
205 bsets_couple ; bsets_string ; bsets_global ; var;
206 bsets_record ; bsets_freetype).
207
208
209 :- assert_must_succeed(kernel_waitflags:set_silent(true)). % disable waitflag store not init msgs
210
211
212
213
214 % a predicate to exhaustively check a kernel predicate with all possible modes
215
216 :- use_module(tools_timeout,[time_out_call/1]).
217 exhaustive_kernel_check_opt(C,Cond) :- (Cond -> exhaustive_kernel_check(C) ; true).
218 exhaustive_kernel_check(C) :- exhaustive_kernel_check4([],C,true,true).
219 exhaustive_kernel_check(Opts,C) :- exhaustive_kernel_check4(Opts,C,true,true).
220 exhaustive_kernel_check_wf(C,WF) :- exhaustive_kernel_check_wf([],C,WF).
221 exhaustive_kernel_check_wf(Opts,C,WF) :-
222 exhaustive_kernel_check4(Opts,C,kernel_waitflags:init_wait_flags(WF),
223 kernel_waitflags:ground_wait_flags(WF)).
224 exhaustive_kernel_check_wfdet(C,WF) :-
225 exhaustive_kernel_check4([],C,kernel_waitflags:init_wait_flags(WF),
226 kernel_waitflags:ground_det_wait_flag(WF)).
227 exhaustive_kernel_check_wf_upto(C,WF,Limit) :-
228 exhaustive_kernel_check4([],C,kernel_waitflags:init_wait_flags(WF),
229 (kernel_waitflags:ground_wait_flag_to(WF,Limit),
230 kernel_waitflags:portray_waitflags(WF))).
231
232 ?exhaustive_kernel_check4(Opts,Call,Pre,Post) :- enumerate_kernel_call(Call,Opts,ECall,Code),
233 debug_println(9,exhaustive_kernel_check(ECall,Code)),
234 flatten_call((Pre,ECall,Code,Post),FullCall),
235 ? must_succeed_without_residue_and_time_out(FullCall), debug_println(9,ok),
236 fail.
237 exhaustive_kernel_check4(_,_,_,_).
238
239 flatten_call((A,B),Res) :- !,flatten_call(A,FA), flatten_call(B,FB), conjoin_call(FA,FB,Res).
240 flatten_call(Module:Call,Res) :- !, flatten_call(Call,F), Res=Module:F.
241 flatten_call(X,X).
242
243 conjoin_call(true,X,R) :- !,R=X.
244 conjoin_call(X,true,R) :- !, R=X.
245 conjoin_call(X,Y,(X,Y)).
246
247 exhaustive_kernel_succeed_check(C) :- exhaustive_kernel_succeed_check([],C).
248 ?exhaustive_kernel_succeed_check(Opts,Call) :- enumerate_kernel_call(Call,Opts,ECall,Code),
249 debug_println(9,exhaustive_kernel_succeed_check(ECall,Code)),
250 flatten_call((ECall,Code),FullCall),
251 time_out_call(must_succeed(FullCall)),debug_println(9,ok),
252 fail.
253 exhaustive_kernel_succeed_check(_,_).
254
255 exhaustive_kernel_fail_check_opt(C,Cond) :- (Cond -> exhaustive_kernel_fail_check(C) ; true).
256 exhaustive_kernel_fail_check(C) :- exhaustive_kernel_fail_check4([],C,true,true).
257 exhaustive_kernel_fail_check(Opts,C) :- exhaustive_kernel_fail_check4(Opts,C,true,true).
258 exhaustive_kernel_fail_check_wf(C,WF) :-
259 exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF),
260 kernel_waitflags:ground_wait_flags(WF)).
261 exhaustive_kernel_fail_check_wfdet(C,WF) :-
262 exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF),
263 kernel_waitflags:ground_det_wait_flag(WF)).
264 exhaustive_kernel_fail_check_wf_upto(C,WF,Limit) :-
265 exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF),
266 kernel_waitflags:ground_wait_flag_to(WF,Limit)).
267 exhaustive_kernel_fail_check_wfinit(C,WF) :-
268 exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF), true).
269
270 ?exhaustive_kernel_fail_check4(Opts,Call,Pre,Post) :- enumerate_kernel_call(Call,Opts,ECall,Code),
271 debug_println(9,exhaustive_kernel_fail_check(ECall,Code)),
272 flatten_call((Pre,ECall,Code,Post),FullCall),
273 time_out_call(must_fail(FullCall)),debug_println(9,ok),
274 fail.
275 exhaustive_kernel_fail_check4(_,_,_,_).
276
277 % enumerate_kernel_call(Call, OptionList, NewCall, CodeAfter)
278 enumerate_kernel_call((A,B),Opts,(EA,EB),(CA,CB)) :- !,
279 ? enumerate_kernel_call(A,Opts,EA,CA), enumerate_kernel_call(B,Opts,EB,CB).
280 ?enumerate_kernel_call(Module:Call,Opts,Module:ECall,Code) :- !, enumerate_kernel_call(Call,Opts,ECall,Code).
281 enumerate_kernel_call(Call,Opts,ECall,Code) :- Call=..[KernelPred|CArgs],
282 (member(commutative,Opts)
283 -> (Args=CArgs ; CArgs=[A1,A2|T], Args=[A2,A1|T])
284 ; Args=CArgs
285 ),
286 ? l_enumerate_kernel_args(Args,EArgs,Code,KernelPred,1), ECall=..[KernelPred|EArgs].
287 l_enumerate_kernel_args([],[],true,_,_).
288 l_enumerate_kernel_args([H|T],[EH|ET],Code,KernelPred,Nr) :-
289 ? enumerate_kernel_args(H,EH,C1,KernelPred/Nr),
290 N1 is Nr+1,
291 ? l_enumerate_kernel_args(T,ET,C2,KernelPred,N1),
292 ? permute_code((C1,C2),Code).
293
294 permute_code((true,C),R) :- !,R=C.
295 permute_code((C,true),R) :- !, R=C.
296 permute_code((C1,C2),(C1,C2)).
297 permute_code((C1,C2),(C2,C1)).
298
299 enumerate_kernel_args(Var,Res,Code,_) :- var(Var),!, Res=Var, Code=true.
300 ?enumerate_kernel_args(X,Res,Code,KP_Nr) :- do_not_delay(X,KP_Nr),!, Res=X, Code=true.
301 enumerate_kernel_args(Arg,Arg,true,_). % just keep the argument
302 enumerate_kernel_args(Args,NewArg,Code,KP_Nr) :- arg_is_list(KP_Nr),!,
303 % we have a list of B expressions (e.g., in partition_wf)
304 ? (Code = '='(NewArg,Args) ; l_enumerate_kernel_args(Args,NewArg,Code,arg_is_list,1)).
305 enumerate_kernel_args(Arg,NewArg,Code,_) :- % delay the argument fully
306 (term_is_of_type(Arg,bsets_object,no)
307 -> Code = equal_object(NewArg,Arg,enumerate_kernel_args)
308 ; Code = '='(NewArg,Arg)).
309 enumerate_kernel_args(int(X),int(XX),Code,_) :- nonvar(X), Code = '='(X,XX). % delay setting number content
310 enumerate_kernel_args(string(X),string(XX),Code,_) :- nonvar(X), Code = '='(X,XX). % delay setting string content
311 enumerate_kernel_args(term(floating(X)),term(floating(XX)),Code,_) :- nonvar(X), Code = '='(X,XX). % delay setting real number content
312 enumerate_kernel_args((A,B),(AA,BB),(CodeA,CodeB),KP_Nr) :-
313 ? enumerate_kernel_args(A,AA,CodeA,KP_Nr),enumerate_kernel_args(B,BB,CodeB,KP_Nr),
314 (AA,BB) \== (A,B). % avoid re-generating case 3 above (just keep argument)
315 enumerate_kernel_args(freeval(ID,Case,A),freeval(ID,Case,AA),CodeA,KP_Nr) :-
316 ? enumerate_kernel_args(A,AA,CodeA,KP_Nr),
317 AA \== A. % avoid re-generating case 3 above (just keep argument)
318 enumerate_kernel_args([H|T],[H|NewT],Code,_) :- Code = equal_object(NewT,T). % delay tail
319 enumerate_kernel_args([H|T],[(int(NewI),H2)|T],Code,_) :- nonvar(H), % make index (e.g. of sequence) nonvar first
320 ? H = (II,H2), ground(II), II=int(I), \+ member((int(I),_),T), % the element is unique in domain
321 Code = '='(NewI,I).
322 enumerate_kernel_args([H|T],[(H1,NewH2)|T],Code,_) :- nonvar(H),
323 ? H = (H1,H2), ground(H2), \+ member((_,H2),T), % the element is unique in ragne
324 Code = equal_object(NewH2,H2).
325 enumerate_kernel_args([H|T],Res,Code,KP_Nr) :-
326 try_expand_and_convert_to_avl([H|T],AVL),
327 ? AVL \= [H|T], enumerate_kernel_args(AVL,Res,Code,KP_Nr).
328 enumerate_kernel_args([H|T],Res,Code,KP_Nr) :- ground([H|T]),generate_member_closure([H|T],Closure),
329 ? enumerate_kernel_args(Closure,Res,Code,KP_Nr).
330
331 % check if an argument is a list not a set.
332 arg_is_list(KernelPred/Nr) :- argument_is_list_not_set(KernelPred,Nr).
333 %arg_is_not_list(KernelPred/Nr) :- \+ argument_is_list_not_set(KernelPred,Nr).
334 argument_is_list_not_set(partition_wf,2).
335 argument_is_list_not_set(not_partition_wf,2).
336 argument_is_list_not_set(test_partition_wf,2).
337 argument_is_list_not_set(disjoint_union_generalized_wf,1).
338
339 do_not_delay(b(_,_,_),_). % do not delay instantiation B predicates and expressions
340 ?do_not_delay(global_set(G),KP/ArgNr) :- custom_explicit_sets:is_infinite_global_set(G,_),
341 ? do_not_delay_arg(KP,ArgNr).
342 do_not_delay(no_wf_available,_). % do not delay waitflag store arguments
343 do_not_delay(wfx(_,_,_,_),_). % ditto
344 % these arguments cause difficulty if infinite sets are delayed (i.e., instantiated later)
345 do_not_delay_arg(partial_function_wf,2).
346 do_not_delay_arg(partial_function_wf,3).
347 do_not_delay_arg(subset_test,2).
348 do_not_delay_arg(subset_strict_test,2).
349
350 generate_member_closure(ExplicitSet,closure(['_zzzz_unit_tests'],[Type],Pred)) :-
351 infer_type(ExplicitSet,set(Type)),
352 Pred =
353 b(member(b(identifier('_zzzz_unit_tests'),Type,[generated]),
354 b(value(ExplicitSet),set(Type),[])),pred,[]).
355
356 infer_type(Value,Type) :- (infer_value_type(Value,Type)
357 -> true %,print(inferred(Type,Value)),nl
358 ; print('### Could not infer type: '), print(Value),nl,fail).
359
360 :- use_module(btypechecker,[couplise_list/2]).
361 infer_value_type(Var,Type) :- var(Var),!,Type=any.
362 infer_value_type([],set(any)).
363 infer_value_type([H|T],set(ResType)) :- infer_value_type(H,Type),
364 ((contains_any(Type),T=[H2|_], % try H2; maybe we can infer a better type here
365 infer_value_type(H2,Type2), \+ contains_any(Type2))
366 -> ResType = Type2
367 ; ResType = Type).
368 infer_value_type(avl_set(node(H,_True,_,_,_)),set(Type)) :- infer_value_type(H,Type).
369 infer_value_type(int(_),integer).
370 infer_value_type(string(_),string).
371 infer_value_type((A,B),couple(TA,TB)) :- infer_value_type(A,TA), infer_value_type(B,TB).
372 infer_value_type(fd(_,T),global(T)).
373 infer_value_type(pred_true /* bool_true */,boolean).
374 infer_value_type(pred_false /* bool_false */,boolean).
375 infer_value_type(rec(Fields),record(FieldTypes)) :- infer_field_types(Fields,FieldTypes).
376 infer_value_type(freeval(Id,_Case,_Val),freetype(Id)).
377 infer_value_type(closure(_,Types,_),set(Res)) :- couplise_list(Types,Res).
378 infer_value_type(global_set('STRING'),R) :- !, R=set(string). % what if Event-B/TLA have a deferred set of that name
379 infer_value_type(global_set('FLOAT'),R) :- !, R=set(real).
380 infer_value_type(global_set('REAL'),R) :- !, R=set(real).
381 infer_value_type(global_set(X),R) :- b_integer_set(X),!,R=set(integer).
382 infer_value_type(global_set(Name),set(global(Name))) :- b_global_set(Name).
383 infer_value_type(term(floating(_)),real). % see kernel_reals:is_real(.)
384
385 infer_field_types([],[]).
386 infer_field_types([field(Name1,Val)|T],[field(Name1,VT)|TT]) :-
387 infer_value_type(Val,VT),
388 infer_field_types(T,TT).
389
390 contains_any(any).
391 contains_any(couple(A,B)) :- (contains_any(A) -> true ; contains_any(B)).
392 contains_any(set(A)) :- contains_any(A).
393 % to do: fields
394
395 :- assert_pre(kernel_objects:basic_type(Obj,Type), (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))).
396 :- assert_post(kernel_objects:basic_type(Obj,_), type_check(Obj,bsets_object)).
397
398 %:- block basic_type(-,-).
399
400 basic_type(FD,global(T)) :- !, global_type(FD,T). % will set up CLP(FD) domain for X
401 % TO DO: Also: what about global(T) inside other structures (pairs) ?
402 basic_type(Rec,record(FieldTypes)) :- !, Rec=rec(Fields),
403 ? basic_field_types(Fields,FieldTypes).
404 %basic_type(Set,set(Type)) :- !, basic_type_set(Type,Set,inf).
405 basic_type(_X,_TY). %basic_type2(TY,X) %basic_symbreak(TY,X)
406 %print(ignore_basic_type(X,Y)),nl %, basic_type2(TY,X) %%STILL REQUIRED ?????
407
408 basic_field_types([],[]).
409 basic_field_types([field(Name1,Val)|T],[field(Name2,VT)|TT]) :-
410 check_field_name_compatibility(Name1,Name2,basic_field_types2),
411 ? basic_type(Val,VT),basic_field_types(T,TT).
412
413
414
415 /* ------------------------- */
416 /* enumerate_basic_type/2 */
417 /* ------------------------- */
418 /* a version of basic_type that enumerates */
419
420 :- assert_must_succeed(enumerate_basic_type([],set(couple(integer,integer)) )).
421 :- assert_must_succeed(enumerate_basic_type([([],int(2)), ([int(3)],int(4))],
422 set(couple(set(integer),integer)) )).
423 :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))],
424 set(couple(integer,integer)) )).
425 :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))],
426 seq(integer) )).
427 :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))],
428 seq(integer) )).
429 :- assert_must_succeed((enumerate_basic_type(X,global('Name')),
430 equal_object(X,fd(1,'Name')) )).
431 :- assert_must_succeed((enumerate_basic_type(X,global('Name')),
432 equal_object(X,fd(2,'Name')) )).
433 :- assert_must_succeed((enumerate_basic_type(X,global('Name')),
434 X==fd(2,'Name')) ).
435 :- assert_must_succeed((enumerate_basic_type(X,record([field(a,global('Name'))])),
436 equal_object(X,rec([field(a,fd(1,'Name'))])) )).
437 :- assert_must_succeed((enumerate_basic_type(X,record([field(a,integer),field(b,global('Name'))])),
438 equal_object(X,rec([field(a,int(1)),field(b,fd(1,'Name'))])) )).
439 :- assert_must_succeed((kernel_freetypes:add_freetype(selfc1,[case(a,constant([a])),case(b,integer)]),
440 kernel_freetypes:set_freetype_depth(2),
441 enumerate_basic_type(X,freetype(selfc1)),equal_object(X,freeval(selfc1,a,term(a))),
442 kernel_freetypes:reset_freetypes)).
443 :- assert_must_succeed((kernel_freetypes:add_freetype(selfc5,[case(a,constant([a])),case(b,integer)]),
444 kernel_freetypes:set_freetype_depth(2),
445 enumerate_basic_type(X,freetype(selfc5)),equal_object(X,freeval(selfc5,b,int(1))),
446 kernel_freetypes:reset_freetypes)).
447 :- assert_must_succeed((kernel_freetypes:add_freetype(selfc7,[case(nil,constant([nil])),case(node,couple(freetype(selfc7),freetype(selfc7)))]),
448 kernel_freetypes:set_freetype_depth(3),
449 findall(X,enumerate_basic_type(X,freetype(selfc7)),Solutions),
450 length(Solutions,5),
451 kernel_freetypes:reset_freetypes)).
452 :- assert_must_succeed((kernel_freetypes:add_freetype(selfc2,[case(a,constant([a])),case(b,freetype(selfc3))]),
453 kernel_freetypes:add_freetype(selfc3,[case(c,constant([c])),case(d,freetype(selfc2))]),
454 kernel_freetypes:set_freetype_depth(4),
455 enumerate_basic_type(X,freetype(selfc2)),
456 equal_object(X,freeval(selfc2,b,freeval(selfc3,d,freeval(selfc2,b,freeval(selfc3,c,term(c)))))),
457 kernel_freetypes:reset_freetypes)).
458 :- assert_must_succeed((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ),
459 equal_object(X,[(fd(1,'Name'),fd(1,'Code'))])) ).
460 :- assert_must_succeed((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ),
461 equal_object(X,[(fd(2,'Name'),fd(1,'Code')), (fd(1,'Name'),fd(2,'Code'))])) ).
462 :- assert_must_succeed((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ),
463 equal_object(X,[(fd(1,'Name'),fd(2,'Code')), (fd(2,'Name'),fd(1,'Code'))])) ).
464 :- assert_must_succeed_any((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ),
465 equal_object(X,[(fd(1,'Name'),fd(2,'Code')), (fd(2,'Name'),fd(1,'Code'))])) ).
466 :- assert_must_succeed(enumerate_basic_type([(int(2),(int(1),int(2))),
467 (int(1),(int(3),int(4)))],
468 set(couple(integer,couple(integer,integer))) )).
469 :- assert_must_succeed(enumerate_basic_type([(int(2),(int(1),int(2))),
470 (int(55),(int(3),int(4)))],
471 set(couple(integer,couple(integer,integer))) )).
472 :- assert_must_succeed(enumerate_basic_type([term('err')],set(constant([err])))).
473 :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))],
474 set(couple(integer,integer)))).
475
476 :- assert_must_succeed_multiple(enumerate_basic_type([(int(2),fd(_A,'Name')),(int(3),fd(_B,'Name')),
477 (int(4),fd(_C,'Name')),(int(5),fd(_D,'Name')),(int(6),fd(_E,'Name')),(int(7),fd(_F,'Name')),
478 (int(8),fd(_G,'Name')),(int(9),fd(_H,'Name')),(int(10),fd(_I,'Name')),
479 (int(11),fd(_,'Name')),(int(12),fd(_,'Name')),(int(13),fd(_,'Name')),
480 (int(14),fd(_,'Name'))],set(couple(integer,global('Name'))))).
481
482 :- assert_must_fail(( findall(XX,enumerate_basic_type(XX, set(set(global('Code')))) ,S), member(X,S), remove(S,X,R), member(X2,R), equal_object(X,X2) )).
483
484 :- assert_must_succeed(( enumerate_basic_type(global_set('Code'),
485 set(global('Code'))) )).
486
487 :- assert_must_succeed(exhaustive_kernel_succeed_check(enumerate_basic_type([(fd(1,'Name'),fd(2,'Code')), (fd(2,'Name'),fd(1,'Code'))],set(couple(global('Name'),global('Code')))))).
488 :- assert_must_succeed(exhaustive_kernel_succeed_check(enumerate_basic_type([(fd(1,'Name'),pred_true), (fd(2,'Name'),pred_false), (fd(2,'Name'),pred_true)],set(couple(global('Name'),boolean))))).
489 :- assert_must_succeed(exhaustive_kernel_succeed_check(enumerate_basic_type([pred_true,pred_false],set(boolean)))).
490 :- assert_must_succeed(exhaustive_kernel_succeed_check(enumerate_basic_type([[],[pred_true,pred_false]],set(set(boolean))))).
491
492 :- assert_pre(kernel_objects:enumerate_basic_type(Obj,Type),
493 (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))).
494 :- assert_post(kernel_objects:enumerate_basic_type(Obj,_), (type_check(Obj,bsets_object),ground_check(Obj))).
495
496 enumerate_basic_type_wf(Obj,Type,WF) :-
497 enumerate_basic_type_wf(Obj,Type,enumerate_basic_type,WF).
498 :- block enumerate_basic_type_wf(?,-,?,?).
499 enumerate_basic_type_wf(Obj,Type,EnumWarning,WF) :-
500 enumerate_basic_type4(Type,Obj,basic,trigger_true(EnumWarning),WF). % add WF context info
501
502 :- block enumerate_basic_type(?,-).
503 enumerate_basic_type(Obj,Type) :-
504 %enumerate_basic_type2(Obj,Type).
505 ? enumerate_basic_type4(Type,Obj,basic,trigger_true(enumerate_basic_type),no_wf_available).
506 %(ground(Obj) -> true ; enumerate_basic_type3(Type,Obj,basic)).
507
508 :- block enumerate_basic_type(?,-,-).
509 enumerate_basic_type(Obj,Type,EnumWarning) :-
510 enumerate_basic_type4(Type,Obj,basic,EnumWarning,no_wf_available).
511
512
513 :- block enumerate_type(?,-,?). % last argument: basic or tight
514 enumerate_type(Obj,Type,Tight) :-
515 %enumerate_basic_type2(Obj,Type).
516 ? enumerate_basic_type4(Type,Obj,Tight,trigger_true(enumerate_type_3),no_wf_available).
517
518 :- block enumerate_type(?,-,?,?), enumerate_type(?,?,?,-).
519 enumerate_type(Obj,Type,Tight,EnumWarning) :-
520 enumerate_basic_type4(Type,Obj,Tight,EnumWarning,no_wf_available).
521
522 enumerate_type_wf(Obj,Type,Tight,WF) :-
523 ? enumerate_type_wf(Obj,Type,Tight,trigger_true(enumerate_type_wf),WF).
524
525 :- block enumerate_type_wf(?,-,?,?,?), enumerate_type_wf(?,?,?,-,?).
526 enumerate_type_wf(Obj,Type,Tight,EnumWarning,WF) :-
527 ? enumerate_basic_type4(Type,Obj,Tight,EnumWarning,WF).
528
529 %enumerate_basic_type2(X,Type) :-
530 % (ground(X) -> (basic_type(X,Type) -> true
531 % ; add_internal_error('Type error: ',enumerate_basic_type2(X,Type)))
532 % ; enumerate_basic_type3(Type,X)).
533
534 enumerate_basic_type4(global(T),R,_Tight,EnumWarning,WF) :-
535 ? enumerate_global_type_with_enum_warning(R,T,EnumWarning,WF).
536 enumerate_basic_type4(set(X),Set,Tight,EnumWarning,WF) :-
537 ? enumerate_basic_type_set(Set,X,Tight,EnumWarning,WF).
538 enumerate_basic_type4(seq(SeqRanType),Seq,Tight,EnumWarning,WF) :-
539 ? (Tight = tight -> enumerate_seq_type_wf(Seq,SeqRanType,EnumWarning,WF) % might trigger warning. push flag.
540 ? ; enumerate_basic_type4(set(couple(integer,SeqRanType)),Seq,basic,EnumWarning,WF)).
541 enumerate_basic_type4(couple(XT,YT),(X,Y),Tight,EnumWarning,WF) :-
542 ? enumerate_type_wf(X,XT,Tight,EnumWarning,WF),
543 ? enumerate_type_wf(Y,YT,Tight,EnumWarning,WF).
544 ?enumerate_basic_type4(boolean,B,_Tight,_EnumWarning,_WF) :- enumerate_bool(B).
545 enumerate_basic_type4(real,R,_Tight,EnumWarning,WF) :- enumerate_real_wf(R,EnumWarning,WF).
546 enumerate_basic_type4(string,string(S),_Tight,EnumWarning,WF) :- enumerate_string_wf(S,EnumWarning,WF).
547 enumerate_basic_type4(constant([V]),term(V),_Tight,_EnumWarning,_WF).
548 enumerate_basic_type4(record(FT),rec(F),Tight,EnumWarning,WF) :-
549 ? enumerate_basic_field_types(F,FT,Tight,EnumWarning,WF).
550 enumerate_basic_type4(freetype(Id),freeval(Id2,C,Value),Tight,EnumWarning,WF) :-
551 (Id=Id2 -> true
552 ; add_internal_error('Freetypes do not match:',enumerate_basic_type4(freetype(Id),freeval(Id2,C,Value),Tight,_,_))),
553 (ground_value(freeval(Id2,C,Value)) -> true
554 ; (is_recursive_freetype(Id),
555 max_freetype_enum_depth(Depth)
556 -> gen_enum_warning_wf(Id,0:inf,0:Depth,EnumWarning,unknown,WF)
557 ; true),
558 ? enumerate_freetype_wf(Tight,freeval(Id,C,Value),freetype(Id),WF)
559 ).
560 enumerate_basic_type4(freetype_lim_depth(Id,Depth),freeval(Id2,C,Value),Tight,_EnumWarning,WF) :-
561 (Id=Id2 -> true
562 ; add_internal_error('Freetypes do not match:',enumerate_basic_type4(freetype_lim_depth(Id,Depth),freeval(Id2,C,Value),Tight,_,_))),
563 % freetype_lim_depth is created artificially by enumerate_freetype
564 ? enumerate_freetype_wf(Tight,freeval(Id,C,Value),freetype_lim_depth(Id,Depth),WF).
565 enumerate_basic_type4(integer,int(N),Tight,EnumWarning,WF) :-
566 (nonvar(N)
567 -> (integer(N) -> true
568 ; add_internal_error('Illegal value:',enumerate_basic_type4(integer,int(N),Tight,EnumWarning,WF))
569 )
570 ? ; enumerate_int_with_span(N,EnumWarning,unknown,WF)).
571 enumerate_basic_type4(abort,V,Tight,EnumWarning,WF) :-
572 add_internal_error(deprecated_abort_type,enumerate_basic_type4(abort,V,Tight,EnumWarning,WF)).
573 enumerate_basic_type4(constant,V,Tight,EnumWarning,WF) :-
574 add_internal_error(deprecated_abort_type,enumerate_basic_type4(constant,V,Tight,EnumWarning,WF)).
575 enumerate_basic_type4(any,Obj,_Tight,EnumWarning,WF) :- enumerate_any_wf(Obj,EnumWarning,WF).
576
577 :- use_module(library(random),[random/3]).
578 enumerate_bool(X) :- preferences:preference(randomise_enumeration_order,true),
579 random(1,3,1),!,
580 (X=pred_false ; X=pred_true).
581 enumerate_bool(pred_true). /* was bool_true */
582 enumerate_bool(pred_false).
583
584 max_cardinality_string(inf). % was 2
585 all_strings_wf(AS,WF) :- findall(string(S),enumerate_string_wf(S,trigger_throw(all_strings),WF),AS).
586 :- use_module(btypechecker,[machine_string/1]).
587 enumerate_string_wf(S,_EnumWarning,_WF) :- atomic(S),!.
588 enumerate_string_wf(S,EnumWarning,WF) :- %print('### WARNING, Enumerating STRING'),nl,
589 % frozen(S,Goal), print(enum(S,Goal)),nl,
590 % MAYBE TO DO: we could check if prolog:dif(S,'"STR1"') are in frozen Goal and then enumerate more?
591 % if we do this we need to adapt dont_expand(global('STRING')) :- ... further below
592 gen_enum_warning_wf('STRING',inf,'"STRING1","STRING2",...',EnumWarning,unknown,WF),
593 (S = 'STRING1', \+ machine_string(S) % used to be '"STR1"'
594 ; S = 'STRING2', \+ machine_string(S) % used to be '"STR2"'
595 ; machine_string(S)).
596
597 is_string(string(_),_WF).
598 is_not_string(X) :- top_level_dif(X,string).
599
600
601 :- use_module(library(random),[random/3]).
602 :- use_module(kernel_reals,[is_ground_real/1, construct_real/2, is_real/2]).
603 enumerate_real_wf(S,_EnumWarning,_) :- is_ground_real(S),!.
604 enumerate_real_wf(S,EnumWarning,WF) :-
605 gen_enum_warning_wf('REAL',inf,'"0.0","1.0",...',EnumWarning,unknown,WF),
606 ( construct_real('0.0',S)
607 ; construct_real('1.0',S)
608 ; construct_real('-1.0',S)
609 ; random(0.0,1.0,R), is_real(S,R)
610 ; random(-1.0,0.0,R), is_real(S,R)
611 ; preferences:preference(maxint,MaxInt), random(1.0,MaxInt,R), is_real(S,R)
612 ; preferences:preference(minint,MinInt), random(MinInt,-1.0,R), is_real(S,R)
613 ).
614
615
616 :- block enumerate_any_wf(-,?,?).
617 enumerate_any_wf(fd(X,T),EnumWarning,WF) :- !,
618 when(nonvar(T),enumerate_global_type_with_enum_warning(fd(X,T),T,EnumWarning,WF)).
619 enumerate_any_wf(int(N),EnumWarning,WF) :- !,enumerate_basic_type4(integer,int(N),basic,EnumWarning,WF).
620 enumerate_any_wf(term(X),_EnumWarning,_WF) :- !, print_message(could_not_enumerate_term(X)).
621 enumerate_any_wf(string(S),EnumWarning,WF) :- !, enumerate_string_wf(S,EnumWarning,WF).
622 enumerate_any_wf(pred_true /* bool_true */,_EnumWarning,_WF) :- !.
623 enumerate_any_wf(pred_false /* bool_false */,_EnumWarning,_WF) :- !.
624 enumerate_any_wf([],_EnumWarning,_WF) :- !.
625 enumerate_any_wf([H|T],EnumWarning,WF) :- !, enumerate_any_wf(H,EnumWarning,WF), enumerate_any_wf(T,EnumWarning,WF).
626 enumerate_any_wf(avl_set(_),_EnumWarning,_WF) :- !.
627 enumerate_any_wf(global_set(_),_EnumWarning,_WF) :- !.
628 enumerate_any_wf((H,T),EnumWarning,WF) :- !, enumerate_any_wf(H,EnumWarning,WF), enumerate_any_wf(T,EnumWarning,WF).
629 enumerate_any_wf(rec(Fields),EnumWarning,WF) :- !, enumerate_any_wf(Fields,EnumWarning,WF).
630 enumerate_any_wf(field(_,V),EnumWarning,WF) :- !, enumerate_any_wf(V,EnumWarning,WF).
631 % we could support: closure values...
632 enumerate_any_wf(T,_EnumWarning,_WF) :- add_message(enumerate_any_wf,'Could_not_enumerate value: ',T).
633
634
635 :- use_module(preferences,[preference/2]).
636
637 % enumerate an INTEGER variable
638 enumerate_int_with_span(N,EnumWarning,Span,WF) :-
639 clpfd_domain(N,FDLow,FDUp), % print(enum(N,FDLow,FDUp)),nl,
640 (finite_domain(FDLow,FDUp)
641 ? -> label(N,FDLow,FDUp)
642 ? ; enum_unbounded(FDLow,FDUp,N,EnumWarning,Span,WF)
643 ).
644 label(N,FDLow,FDUp) :-
645 gen_enum_warning_if_large(N,FDLow,FDUp),
646 ? clpfd_interface:clpfd_in_domain(N).
647
648 % when in CLP(FD) mode; try and do a case-split and see if that narrows down the possible ranges
649 enum_unbounded(X,Y,N,EnumWarning,Span,WF) :- preferences:preference(use_clpfd_solver,true),!,
650 ? enum_unbounded_clp(X,Y,N,EnumWarning,Span,WF).
651 enum_unbounded(X,Y,N,EnumWarning,Span,WF) :- %frozen(N,G), print(frozen(N,G,X,Y,EnumWarning)),nl,
652 clpfd_off_domain(N,X,Y,NX,NY),
653 (finite_domain(NX,NY) -> enumerate_int1(N,NX,NY)
654 ? ; enum_unbounded_clpfd_off(NX,NY,N,EnumWarning,Span,WF)).
655
656 enum_unbounded_clpfd_off(_FDLow,_FDUp,N,_EnumWarning,_,_WF) :- is_wd_guarded_result_variable(N),!.
657 enum_unbounded_clpfd_off(FDLow,FDUp,N,EnumWarning,Span,WF) :-
658 make_domain_finite(FDLow,FDUp,Min,Max),
659 gen_enum_warning_wf('INTEGER',FDLow:FDUp,Min:Max,EnumWarning,Span,WF),
660 ? enumerate_int1(N,Min,Max). % will also do a case split, but without posting constraints
661
662 % try to determine integer variable bounds from pending co-routines for CLPFD off mode
663 clpfd_off_domain(Var,Low,Up,NewLow,NewUp) :-
664 frozen(Var,Goal), narrow_down_interval(Goal,Var,Low,Up,NewLow,NewUp).
665 % ((Lowx,Up)==(NewLow,NewUp) -> true ; print(narrowed_down(Var,Low,Up,NewLow,NewUp)),nl).
666 narrow_down_interval((A,B),Var,Low,Up,NewLow,NewUp) :- !,
667 narrow_down_interval(A,Var,Low,Up,Low1,Up1),
668 narrow_down_interval(B,Var,Low1,Up1,NewLow,NewUp).
669 narrow_down_interval(kernel_objects:safe_less_than_equal(_,V1,V2),Var,Low,Up,NewLow,NewUp) :- !,
670 (V1==Var,number(V2) -> NewLow=Low,fd_min(Up,V2,NewUp)
671 ; V2==Var,number(V1) -> fd_max(Low,V1,NewLow),NewUp=Up
672 ; NewLow=Low,NewUp=Up).
673 narrow_down_interval(kernel_objects:safe_less_than(V1,V2),Var,Low,Up,NewLow,NewUp) :- !,
674 (V1==Var,number(V2) -> NewLow=Low,V2m1 is V2-1, fd_min(Up,V2m1,NewUp)
675 ; V2==Var,number(V1) -> V1p1 is V1+1, fd_max(Low,V1p1,NewLow),NewUp=Up
676 ; NewLow=Low,NewUp=Up).
677 narrow_down_interval(_,_,L,U,L,U).
678
679 % check if this variable is marked as being assigned to by currently not-well-defined construct such as min,max,...:
680 is_wd_guarded_result_variable(N) :- % write('-WDG-'),
681 frozen(N,FrozenGoal), % TO DO: use attribute rather than frozen
682 is_wd_guarded_result_variable_aux(FrozenGoal,N).
683 is_wd_guarded_result_variable_aux(kernel_waitflags:is_wd_guarded_result(V),N) :- !, N==V.
684 is_wd_guarded_result_variable_aux((A,B),N) :-
685 is_wd_guarded_result_variable_aux(A,N) ; is_wd_guarded_result_variable_aux(B,N).
686
687 % enumerate unbounded integer variable N in a CLP(FD) fashion:
688 enum_unbounded_clp(0,Y,N,EnumWarning,Span,WF) :- (Y=sup ; Y>0),
689 % we span 0 and positive numbers
690 !,
691 (N=0
692 % for division/modulo... 0 is often a special case
693 ; try_post_constraint(N #>0),
694 force_enumerate_int_wo_case_split(N,'INTEGER',EnumWarning,Span,WF)
695 ).
696 enum_unbounded_clp(X,Y,N,EnumWarning,Span,WF) :-
697 (is_inf_or_overflow_card(X) -> true ; X<0), (Y=sup ; Y>0),
698 % we span both negative and positive numbers
699 !,
700 % do a case split
701 (N=0
702 % Instead of doing a case-split on 0; we could try and detect other relevant values (e.g., what if we have x / (y-1)
703 ; try_post_constraint(N #>0), % TO DO: use clpfd_lt_expr(0,N), ?and in other calls; this is an area where time-outs are more likely, but we cannot do anything about them anyway
704 ? force_enumerate_int_wo_case_split(N,'INTEGER',EnumWarning,Span,WF)
705 ; try_post_constraint(N #<0),
706 ? force_enumerate_int_wo_case_split(N,'INTEGER',EnumWarning,Span,WF)
707 ).
708 enum_unbounded_clp(FDLow,FDUp,N,EnumWarning,Span,WF) :-
709 % we cover only negative or only positive numbers
710 ? force_enumerate_with_warning(N,FDLow,FDUp,'INTEGER',EnumWarning,Span,WF).
711
712 % force enumeration without case split:
713 force_enumerate_int_wo_case_split(N,Msg,EnumWarning,Span,WF) :-
714 clpfd_domain(N,FDLow,FDUp), % print(enum(N,FDLow,FDUp)),nl,
715 (finite_domain(FDLow,FDUp)
716 -> label(N,FDLow,FDUp)
717 ; %print(force_enumerate_int_wo_case_split(FDLow,FDUp)),nl,
718 ? force_enumerate_with_warning(N,FDLow,FDUp,Msg,EnumWarning,Span,WF)
719 ).
720
721 force_enumerate_with_warning(N,_FDLow,_FDUp,_Msg,_EnumWarning,_Span,_WF) :- % check if we should enumerate at all
722 is_wd_guarded_result_variable(N),!. % affects tests 1825, 2017
723 force_enumerate_with_warning(N,FDLow,FDUp,Msg,EnumWarning,Span,WF) :-
724 make_domain_finite(FDLow,FDUp,Min,Max),
725 gen_enum_warning_wf(Msg,FDLow:FDUp,Min:Max,EnumWarning,Span,WF),
726 %try_post_constraint(N in Min..Max), % I am not sure whether this is useful or not
727 ? enumerate_int2(N,Min,Max).
728
729
730 % generate enumeration warning:
731 gen_enum_warning_wf(TYPE,RANGE,RESTRICTED_RANGE,Trigger,Span,WF) :-
732 Warning = enumeration_warning(enumerating(Info),TYPE,RANGE,RESTRICTED_RANGE,critical),
733 (get_trigger_info(Trigger,Info)
734 -> (Span=unknown,Info=b(_,_,_),get_texpr_pos(Info,Span2) -> true ; Span2=Span)
735 ; Info=unknown, Span2=Span
736 ),
737 (add_new_event_in_error_scope(Warning,
738 print_enum_warning(Trigger,TYPE,RANGE,RESTRICTED_RANGE,Span2,WF))
739 % may also throw(Warning)
740 ->
741 (preference(allow_enumeration_of_infinite_types,false)
742 -> formatsilent('### VIRTUAL TIME-OUT generated because ENUMERATE_INFINITE_TYPES=false~n',[]),
743 % print_pending_abort_error(WF),
744 (silent_mode(on) -> true ; print_span_nl(Span2)),
745 throw(Warning)
746 ; Trigger = trigger_throw(Source)
747 -> (silent_mode(on) -> true
748 ; Source=b(identifier(ID),_,_) ->
749 format('### VIRTUAL TIME-OUT generated for ~w ',[ID]),
750 print_span_nl(Span2)
751 ; format('### VIRTUAL TIME-OUT generated for ~w ',[Source]),
752 print_span_nl(Span2)
753 ),
754 throw(Warning)
755 ; true)
756 ; true).
757
758 %get_trigger_info(trigger_false(I),Info) :- get_trigger_info2(I,Info). % was non_critical ; no longer used
759 get_trigger_info(trigger_true(I),Info) :- get_trigger_info2(I,Info).
760 get_trigger_info(trigger_throw(I),Info) :- get_trigger_info2(I,Info).
761 %get_trigger_info2(enum_wf_context(_,Info),Res) :- !,Res=Info. % no longer used; WF now passed
762 get_trigger_info2(Info,Info).
763
764
765 % TO DO: pass WF explicitly rather than extracting it from enumeration warning terms
766 :- use_module(translate,[translate_span/2, translate_error_term/3]).
767 print_pending_abort_error(WF) :-
768 pending_abort_error(WF,Msg,ErrTerm,Span),
769 !, % just print one error
770 translate_span(Span,TSpan),
771 translate_error_term(ErrTerm,Span,TT),
772 (get_wait_flag_infos(WF,WFInfos),
773 member(expect_explicit_value,WFInfos)
774 -> ajoin(['Potential WD-Error: ',Msg],WDMsg),
775 add_warning(eval_expr_command,WDMsg,TT,Span)
776 ; format_with_colour(user_output,[bold],' (could be due to WD-Error ~w: ~w ~w)~n',[TSpan,Msg,TT])).
777 print_pending_abort_error(_).
778
779 % try and get get_pending_abort_error_for_trigger
780 get_pending_abort_error_for_info(WF,Span,FullMsg,ErrTerm) :-
781 pending_abort_error(WF,Msg,ErrTerm,Span),
782 ajoin(['Enumeration warning occured, probably caused by WD-Error: ',Msg],FullMsg).
783
784 :- use_module(translate,[print_span/1, print_span_nl/1]).
785 % THROWING,OuterSpan added by add_new_event_in_error_scope
786 print_enum_warning(_,_,_,_,_,_WF,THROWING,_) :-
787 silent_mode(on), % we could also check: performance_monitoring_on,
788 \+ will_throw_enum_warning(THROWING), % maybe we should also be silent if THROWING=throwing; see test 1522,
789 % see also test 2554 (if run with STRICT_RAISE_ENUM_WARNINGS = TRUE)
790 !. % do not print
791 print_enum_warning(Trigger,_,_,_,_LocalSpan,WF,THROWING,OuterThrowSpan) :-
792 will_throw_enum_warning(THROWING),
793 debug_mode(off),
794 !, % do not print detailed enumeration warning with reduced scopes; we print another message instead
795 print_throwing_wf(THROWING,Trigger,OuterThrowSpan,WF).
796 print_enum_warning(_,_,_,_,_,_WF,THROWING,_) :- THROWING \= throwing,
797 inc_counter(non_critical_enum_warnings,Nr), Nr>50,!, % do not print anymore
798 (Nr=51 -> write('### No longer printing non-critical enumeration warnings; limit exceeded.'),nl
799 ; true).
800 print_enum_warning(Trigger,TYPE,RANGE,RESTRICTED_RANGE,LocalSpan,WF,THROWING,OuterThrowSpan) :-
801 write('### Unbounded enumeration of '), % error_manager:trace_if_user_wants_it,
802 print_trigger_var(Trigger),
803 format('~w : ~w ---> ~w ',[TYPE,RANGE,RESTRICTED_RANGE]),
804 print_wf_context(WF),
805 print_span(LocalSpan),nl,
806 print_throwing_wf(THROWING,Trigger,OuterThrowSpan,WF).
807
808 % just count number of enum warnings
809 :- use_module(extension('counter/counter'),
810 [counter_init/0, new_counter/1, inc_counter/2, reset_counter/1]).
811 kernel_objects_startup :- % call once at startup to ensure all counters exist
812 counter_init,
813 new_counter(non_critical_enum_warnings).
814 kernel_objects_reset :- reset_counter(non_critical_enum_warnings).
815
816 :- use_module(probsrc(eventhandling),[register_event_listener/3]).
817 :- register_event_listener(startup_prob,kernel_objects_startup,
818 'Initialise kernel_objects counters.').
819 :- register_event_listener(clear_specification,kernel_objects_reset,
820 'Reset kernel_objects counters.').
821
822 % -----------
823
824 will_throw_enum_warning(THROWING) :-
825 (THROWING=throwing -> true ; preference(strict_raise_enum_warnings,true)).
826
827 :- use_module(tools_printing,[format_with_colour/4]).
828 print_throwing(THROWING,Span) :- print_throwing_wf(THROWING,unknown_info,Span,no_wf_available).
829 print_throwing_wf(THROWING,TriggerInfo,ThrowSpan,WF) :-
830 peel_trigger(TriggerInfo,Info),
831 (preference(strict_raise_enum_warnings,true)
832 -> (get_pending_abort_error_for_info(WF,Span,Msg,ErrTerm)
833 -> add_error(strict_raise_enum_warnings,Msg,ErrTerm,Span)
834 ; (get_trigger_info_variable(Info,VID) -> true ; VID='?'),
835 add_error(strict_raise_enum_warnings,'Enumeration warning occured for ',VID,ThrowSpan)
836 )
837 ; true
838 ),
839 (THROWING=throwing ->
840 (get_trigger_info_variable(Info,VarID)
841 -> format_with_colour(user_output,[bold],'Generating VIRTUAL TIME-OUT for unbounded enumeration of ~w!~n',[VarID])
842 ; format_with_colour(user_output,[bold],'Generating VIRTUAL TIME-OUT for unbounded enumeration warning!~n',[])
843 ),
844 print_pending_abort_error(WF),
845 (get_wait_flags_context_msg(WF,Msg) % % get call stack or other context message from WF
846 -> format_with_colour(user_output,[bold],' ~w~n',[Msg])
847 ; true),
848 (extract_span_description(ThrowSpan,PosMsg) -> format_with_colour(user_output,[bold],' ~w~n',[PosMsg]) ; true)
849 ; true).
850
851 peel_trigger(trigger_true(Info),Info) :- !.
852 peel_trigger(trigger_throw(Info),Info) :- !.
853 peel_trigger(Info,Info).
854
855 print_trigger_var(trigger_true(Info)) :- !, print_trigger_var_info(Info), write(' : ').
856 print_trigger_var(trigger_throw(Info)) :- !, print_trigger_var_info(Info), write(' : (all_solutions) : ').
857 %print_trigger_var(trigger_false(Info)) :- !, print_trigger_var_info(Info), print(' (not critical [unless failure]) : '). % no longer used
858 print_trigger_var(X) :- write(' UNKNOWN TRIGGER: '), print(X), write(' : ').
859
860 print_wf_context(WF) :-
861 (get_wait_flags_context_msg(WF,Msg)
862 -> format('~n### ~w~n ',[Msg]) %format(' : (~w)',[Msg])
863 ; true).
864 :- use_module(translate,[print_bexpr/1]).
865 print_trigger_var_info(b(E,T,I)) :- !, print_bexpr(b(E,T,I)), write(' '), print_span(I).
866 print_trigger_var_info(VarID) :- print(VarID).
867
868 % get variable name from trigger info field
869 get_trigger_info_variable(b(identifier(ID),_,_),VarID) :- !, VarID=ID.
870 get_trigger_info_variable(ID,VarID) :- atom(ID), VarID=ID.
871
872
873 % generate a warning if a large range is enumerated
874 gen_enum_warning_if_large(Var,FDLow,FDUp) :-
875 (FDUp>FDLow+8388608 /* 2**23 ; {x|x:1..2**23 & x mod 2 = x mod 1001} takes about 2 minutes */
876 % however the domain itself could be very small, we also check clpfd_size instead
877 -> fd_size(Var,Size), % no need to call clpfd_size; we know we are in CLP(FD) mode
878 (Size =< 8388608 -> true
879 ; enum_warning_large(Var,'INTEGER',FDLow:FDUp)
880 )
881 ; true).
882 enum_warning_large(_Var,TYPE,RANGE) :-
883 Warning = enumeration_warning(enumerating,TYPE,RANGE,RANGE,non_critical),
884 (add_new_event_in_error_scope(Warning,print_enum_warning_large(TYPE,RANGE))
885 -> true
886 ; true).
887
888 print_enum_warning_large(TYPE,RANGE,THROWING,Span) :-
889 print('### Warning: enumerating large range '),
890 print(TYPE), print(' : '),
891 print(RANGE),nl,
892 print_throwing(THROWING,Span).
893
894 :- block finite_warning(-,?,?,?,?).
895 finite_warning(_,Par,Types,Body,Source) :-
896 add_new_event_in_error_scope(enumeration_warning(checking_finite_closure,Par,Types,finite,critical),
897 print_finite_warning(Par,Types,Body,Source) ),
898 fail. % WITH NEW SEMANTICS OF ENUMERATION WARNING WE SHOULD PROBABLY ALWAYS FAIL HERE !
899 print_finite_warning(Par,Types,Body,Source,THROWING,Span) :-
900 print('### Warning: could not determine set comprehension to be finite: '),
901 translate:print_bvalue(closure(Par,Types,Body)),nl,
902 print('### Source: '), print(Source),nl,
903 print_throwing(THROWING,Span).
904
905 :- block enumerate_natural(-,?,-,?,?).
906 ?enumerate_natural(N,From,_,Span,WF) :- nonvar(N) -> true ; enumerate_natural(N,From,Span,WF).
907 enumerate_natural(N,From,Span,WF) :- preference(use_clpfd_solver,false),!,
908 clpfd_off_domain(N,From,sup,NewLow,NewUp), % try narrow down domain using co-routines
909 (finite_domain(NewLow,NewUp) -> enumerate_int1(N,NewLow,NewUp)
910 ? ; force_enumerate_with_warning(N,NewLow,NewUp,'NATURAL(1)',trigger_true('NATURAL(1)'),Span,WF)).
911 enumerate_natural(N,From,Span,WF) :- clpfd_domain(N,FDLow,FDUp),
912 fd_max(FDLow,From,Low),
913 (finite_domain(Low,FDUp)
914 -> label(N,Low,FDUp)
915 ? ; enumerate_natural_unbounded(N,Low,FDUp,Span,WF)
916 ).
917 enumerate_natural_unbounded(N,FDLow1,FDUp,Span,WF) :-
918 (FDLow1=0
919 -> (N=0 ; /* do a case split */
920 try_post_constraint(N #>0), % this can sometimes make the domain finite
921 ? force_enumerate_int_wo_case_split(N,'NATURAL',trigger_true('NATURAL'),Span,WF)
922 )
923 ; force_enumerate_with_warning(N,FDLow1,FDUp,'NATURAL(1)',trigger_true('NATURAL(1)'),Span,WF)
924 ).
925
926
927 % assumes one of FDLow and FDUp is not a number
928 make_domain_finite(FDLow,_FDUp,Min,Max) :- number(FDLow),!,Min=FDLow,
929 preferences:preference(maxint,MaxInt),
930 (MaxInt>=FDLow -> Max=MaxInt ; Max=FDLow). % ensure that we try at least one number
931 make_domain_finite(_FDLow,FDUp,Min,Max) :- number(FDUp),!,Max=FDUp,
932 preferences:preference(minint,MinInt),
933 (MinInt=<FDUp -> Min=MinInt ; Min=FDUp).
934 make_domain_finite(_FDLow,_FDUp,Min,Max) :-
935 ((preferences:preference(maxint,Max),
936 preferences:get_preference(minint,Min))->true). % ensure that we try at least one number
937
938 enumerate_int1(N,Min,Max) :-
939 (Min<0 /* enumerate positive numbers first; many specs only use NAT/NATURAL */
940 ? -> (enumerate_int2(N,0,Max) ; enumerate_int2(N,Min,-1))
941 ? ; enumerate_int2(N,Min,Max)
942 ).
943 enumerate_int(X,Low,Up) :- get_int_domain(X,Low,Up,RL,RU),
944 %% print(enumerate_int(X,Low,Up, RL,RU)),nl, %%
945 ? enumerate_int2(X,RL,RU).
946
947 get_int_domain(X,Low,Up,RL,RU) :- clpfd_domain(X,FDLow,FDUp),
948 fd_max(FDLow,Low,RL),fd_min(FDUp,Up,RU).
949
950 finite_domain(Low,Up) :- \+ infinite_domain(Low,Up).
951 infinite_domain(inf,_) :- !.
952 infinite_domain(_,sup).
953
954 % second arg should always be a number
955 fd_max(inf,L,R) :- !,R=L.
956 fd_max(FDX,Y,R) :- (nonvar(FDX),nonvar(Y),FDX>Y -> R=FDX ; R=Y).
957 fd_min(sup,L,R) :- !,R=L.
958 fd_min(FDX,Y,R) :- (nonvar(FDX),nonvar(Y),FDX<Y -> R=FDX ; R=Y).
959
960 :- use_module(clpfd_interface,[clpfd_randomised_enum/3]).
961
962 enumerate_int2(N,X,Y) :- % mainly called when CLPFD false
963 (preferences:get_preference(randomise_enumeration_order,true)
964 ? -> clpfd_randomised_enum(N,X,Y) ; enumerate_int2_linear(N,X,Y)).
965
966 enumerate_int2_linear(N,X,Y) :- X=<Y,
967 ? (N=X ; X1 is X+1, enumerate_int2_linear(N,X1,Y)).
968
969
970 enumerate_basic_type_set(X,Type,Tight,EnumWarning,WF) :- var(X),!,
971 max_cardinality_with_check(Type,Card),
972 ? enumerate_basic_type_set2(X,[],Card,Type,none,Tight,EnumWarning,WF).
973 enumerate_basic_type_set([],_,_,_EnumWarning,_WF) :- !.
974 enumerate_basic_type_set(avl_set(_),_,_,_EnumWarning,_WF) :- !.
975 enumerate_basic_type_set(freetype(_),_,_,_EnumWarning,_WF) :- !.
976 enumerate_basic_type_set(global_set(GS),Type,_Tight,_EnumWarning,_WF) :- !,
977 (Type = global(GT)
978 -> (GS = GT -> true
979 ; nonvar(GS), add_error_and_fail(enumerate_basic_type_set,'Type error in global set: ',GS:GT))
980 ; Type = integer,integer_global_set(GS)
981 ; Type = string, string_global_set(GS)
982 ; Type = real, real_global_set(GS)
983 ).
984 enumerate_basic_type_set(closure(Parameters, PT, Body),_Type,_Tight,_EnumWarning,WF) :- !,
985 (ground(Body) -> true
986 ; add_message_wf(kernel_objects,'Enumerating non-ground closure body: ',closure(Parameters, PT, Body),Body,WF),
987 % this did happen for symbolic total function closures set up for f : NATURAL1 --> ..., see test 2022
988 %term_variables(Body,Vars), print('### Variables: '), print(Vars),nl,
989 enumerate_values_inside_expression(Body,WF)
990 ).
991 enumerate_basic_type_set([H|T],Type,Tight,EnumWarning,WF) :- !,
992 % collect bound elements; avoid enumerating initial elements with elements that already appear later
993 collect_bound_elements([H|T], SoFar,Unbound,Closed),
994 (Closed=false -> max_cardinality_with_check(Type,Card)
995 ; Card = Closed),
996 % print(enum(Card,Unbound,SoFar,[H|T],Closed)),nl,
997 ? enumerate_basic_type_set2(Unbound,SoFar,Card,Type,none,Tight,EnumWarning,WF).
998 %enumerate_basic_type_set([H|T],Type,Tight,WF) :- !,
999 % (is_list_skeleton([H|T],Card) -> true
1000 % ; max_cardinality_with_check(Type,Card)
1001 % ),
1002 % enumerate_basic_type_set2([H|T],[],Card,Type,none,Tight,WF).
1003 enumerate_basic_type_set(S,Type,Tight,EnumWarning,WF) :-
1004 add_internal_error('Illegal set: ',enumerate_basic_type_set(S,Type,Tight,EnumWarning,WF)).
1005
1006 enumerate_basic_type_set2(HT,ElementsSoFar,_Card,_Type,_Last,_Tight,_EnumWarning,_WF) :- nonvar(HT),
1007 is_custom_explicit_set(HT,enumerate_basic_type),!,
1008 disjoint_sets(HT,ElementsSoFar). % I am not sure this is necessary; probably other constraints already ensure this holds
1009 enumerate_basic_type_set2(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) :- var(HT),
1010 preferences:preference(randomise_enumeration_order,true),!,
1011 (random(1,3,1)
1012 -> (enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF)
1013 ; HT = [])
1014 ; (HT = [] ;
1015 enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF))
1016 ).
1017 enumerate_basic_type_set2([],_,_,_,_,_Tight,_EnumWarning,_WF).
1018 enumerate_basic_type_set2(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) :-
1019 ? enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF).
1020
1021 enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) :- positive_card(Card),
1022 %debug:trace_point(enum(HT,ElementsSoFar,Card,Type,Last,Tight)),
1023 (var(HT) -> HT=[H|T], NewLast=NormH /* the enumerator has completely determined H */
1024 % Note: HT=[H|T] may wake up co-routines and then attach infos to H; but these should hold indpendently for all elements
1025 ; HT=[H|T],
1026 (unbound_value(H)
1027 -> NewLast=NormH /* the enumerator has completely determined H */
1028 ; NewLast=Last) /* H was not freely chosen by the enumerator */
1029 ),
1030 ? not_element_of(H,ElementsSoFar), % this is only needed for elements generated by the enumerator itself
1031 % if we pass WF to not_element_of then test 479 fails due to different enumeration order
1032 ? enumerate_type_wf(H,Type,Tight,EnumWarning,WF),
1033 % TO DO: extract normal form from add_new_element
1034 % Note: if H is_wd_guarded_result_variable then H may not be ground !!
1035 (ground_value(H)
1036 -> val_greater_than(H,NormH,Last),
1037 add_new_element(NormH,ElementsSoFar,SoFar2) % TODO : use add_new_element_wf ?
1038 ; add_new_element(H,ElementsSoFar,SoFar2),
1039 NormH=none
1040 ),
1041 C1 is Card-1,
1042 ? enumerate_basic_type_set2(T,SoFar2,C1,Type,NewLast,Tight,EnumWarning,WF).
1043
1044 :- assert_must_succeed((collect_bound_elements([int(1),int(2),int(4),X,int(5)|T],_,U,C),U==[X|T],C==false)).
1045 :- assert_must_succeed((collect_bound_elements([int(1),int(2),int(4),X,int(5)],_,U,C),U==[X],C==1)).
1046 :- assert_must_succeed(exhaustive_kernel_succeed_check(collect_bound_elements([int(1),int(2),int(4),int(5)],_,_,_))).
1047
1048 % collect the bound and unbound elements in a list; also return if the list is closed (then return length) or return false
1049 collect_bound_elements(T, SoFar,Unbound,Closed) :- var(T),!, SoFar=[],Unbound=T,Closed=false.
1050 collect_bound_elements([],[],[],0).
1051 collect_bound_elements(avl_set(A),avl_set(A),[],0).
1052 collect_bound_elements(global_set(GS),SoFar,Unbound,Closed) :- expand_custom_set(global_set(GS),ES),
1053 collect_bound_elements(ES,SoFar,Unbound,Closed).
1054 collect_bound_elements(freetype(FS),SoFar,Unbound,Closed) :- expand_custom_set(freetype(FS),ES),
1055 collect_bound_elements(ES,SoFar,Unbound,Closed).
1056 collect_bound_elements(closure(P,T,B),SoFar,Unbound,Closed) :- expand_custom_set(closure(P,T,B),ES),
1057 collect_bound_elements(ES,SoFar,Unbound,Closed).
1058 collect_bound_elements([H|T],SoFar,Unbound,Closed) :-
1059 collect_bound_elements(T,TSoFar,TUnbound,TClosed),
1060 (ground(H) -> add_new_element(H,TSoFar,SoFar), Unbound=TUnbound, TClosed=Closed
1061 ; SoFar = TSoFar, Unbound = [H|TUnbound],
1062 (TClosed=false -> Closed=false ; Closed is TClosed+1)
1063 ).
1064
1065
1066 % perform order checking on terms, normalising them first
1067 % val_greater_than(A,NormA,NormB)
1068 val_greater_than(A,NormA,NormB) :- !,
1069 (nonvar(A),custom_explicit_sets:convert_to_avl_inside_set(A,NormA)
1070 -> (NormB==none -> true ; NormA @> NormB)
1071 ; add_internal_error('Call failed: ',custom_explicit_sets:convert_to_avl_inside_set(A,NormA)),
1072 NormA = A).
1073
1074 positive_card(inf) :- !, print('$').
1075 positive_card(C) :- (integer(C) -> C>0
1076 ; add_internal_error('Not an integer: ',positive_card(C)),fail).
1077
1078
1079
1080 :- block enumerate_basic_field_types(?,-,?,-,?).
1081 enumerate_basic_field_types([],[],_Tight,_EnumWarning,_).
1082 enumerate_basic_field_types(Fields,[field(Name,VT)|TT],Tight,EnumWarning,WF) :-
1083 ? enumerate_basic_field_types2(Fields,Name,VT,TT,Tight,EnumWarning,WF).
1084
1085 :- block enumerate_basic_field_types2(?,-,?,?,?,?,?).
1086 enumerate_basic_field_types2([field(Name1,V)|T], Name2,VT,TT,Tight,EnumWarning,WF) :-
1087 check_field_name_compatibility(Name1,Name2,enumerate_basic_field_types2),
1088 ? enumerate_type_wf(V,VT,Tight,EnumWarning,WF),
1089 ? enumerate_basic_field_types(T,TT,Tight,EnumWarning,WF).
1090
1091
1092 :- block all_objects_of_type(-,?).
1093 all_objects_of_type(Type,Res) :-
1094 findall(O,enumerate_basic_type(O,Type),Res).
1095
1096 :- use_module(library(avl),[avl_size/2]).
1097 :- use_module(kernel_cardinality_attr,[clpfd_card_domain_for_var/3]).
1098 % obtain info for enumerating sequence lists: length of list skeleton and maximum index inferred to be in the list
1099 % (MaxIndex is not the maximum index that can appear in the full sequence !)
1100 list_length_info(X,LenSoFar,Len,Type,MaxIndex) :- var(X),!,Len=0,
1101 clpfd_card_domain_for_var(X,MinCard,MaxCard),
1102 ( number(MinCard)
1103 -> MaxIndex is MinCard+LenSoFar % we know a valid list must be at least LenSoFar+MinCard long
1104 ; MaxIndex=0),
1105 ( number(MaxCard) -> Max1 is MaxCard+Len, Type = open_bounded(Max1) ; Type = open).
1106 list_length_info([],_,0,closed,0).
1107 list_length_info([H|T],LenSoFar,C1,Type,MaxIndex1) :- Len1 is LenSoFar+1,
1108 list_length_info(T,Len1,C,Type,MaxIndex),
1109 C1 is C+1,
1110 (nonvar(H),H=(I,_),nonvar(I),I=int(Idx),number(Idx),Idx>MaxIndex
1111 -> MaxIndex1 = Idx ; MaxIndex1 = MaxIndex).
1112 list_length_info(avl_set(A),LenSoFar,Size,closed,0) :- % case arises e.g. in private_examples/ClearSy/2019_Dec/well_def
1113 (LenSoFar=0 -> Size=1000000 % then length not used anyway
1114 ; avl_size(A,Size)). % we could check that this is a sequence tail!
1115 list_length_info(closure(_,_,_),_,0,open,0).
1116
1117 :- assert_must_succeed((max_cardinality(set(couple(global('Name'),global('Code'))),64))).
1118 :- assert_must_succeed((max_cardinality(set(set(set(couple(global('Name'),global('Code'))))),_))).
1119 :- assert_must_succeed((kernel_freetypes:add_freetype(selfc4,[case(a,boolean),case(b,couple(boolean,boolean))]),
1120 max_cardinality(freetype(selfc4),6),
1121 kernel_freetypes:reset_freetypes)).
1122 :- assert_must_succeed((kernel_freetypes:add_freetype(selfc6,[case(a,boolean),case(b,freetype(selfc6)),case(c,constant([c]))]),
1123 kernel_freetypes:set_freetype_depth(3),
1124 findall(X,enumerate_tight_type(X,freetype(selfc6)),Solutions),
1125 length(Solutions,NumberOfSolutions),
1126 max_cardinality(freetype(selfc6),NumberOfSolutions),
1127 kernel_freetypes:reset_freetypes)).
1128
1129 :- use_module(tools_printing,[print_error/1]).
1130 max_cardinality_with_check(Set,CCard) :-
1131 ? (max_cardinality(Set,Card) ->
1132 (is_inf_or_overflow_card(Card)
1133 -> debug_println(9,very_large_cardinality(Set,Card)),
1134 CCard = 20000000
1135 ; CCard=Card,
1136 (Card>100 -> debug_println(9,large_cardinality(Set,Card)) ; true)
1137 )
1138 ; print_error(failed(max_cardinality(Set,CCard))), CCard = 10
1139 ).
1140 max_cardinality(global(T),Card) :- b_global_set_cardinality(T,Card).
1141 max_cardinality(boolean,2).
1142 max_cardinality(constant([_V]),1).
1143 max_cardinality(any,inf). % :- print_message(dont_know_card_of_any). /* TODO: what should we do here ? */
1144 max_cardinality(string,MC) :- max_cardinality_string(MC). % is inf now
1145 %max_cardinality(abort,1).
1146 max_cardinality(integer,Card) :- Card=inf. %b_global_set_cardinality('INTEGER',Card).
1147 max_cardinality(real,Card) :- Card=inf.
1148 max_cardinality(seq(X),Card) :- % Card=inf, unless a freetype can be of cardinality 0
1149 max_cardinality(set(couple(integer,X)),Card).
1150 max_cardinality(couple(X,Y),Card) :-
1151 ? max_cardinality(X,CX), max_cardinality(Y,CY), safe_mul(CX,CY,Card).
1152 max_cardinality(record([]),1).
1153 max_cardinality(record([field(_,T1)|RF]),Card) :-
1154 ? max_cardinality(record(RF),RC),
1155 max_cardinality(T1,C1),
1156 safe_mul(C1,RC,Card).
1157 ?max_cardinality(set(X),Card) :- max_cardinality(X,CX),
1158 safe_pow2(CX,Card).
1159 max_cardinality(freetype(Id),Card) :- max_cardinality_freetype(freetype(Id),Card).
1160 max_cardinality(freetype_lim_depth(Id,Depth),Card) :- max_cardinality_freetype(freetype_lim_depth(Id,Depth),Card).
1161
1162
1163
1164 /* ---------------------------- */
1165
1166
1167 /* use a cleverer, better enumeration than enumerate_basic_type */
1168 /* can only be used in certain circumstances: operation preconditions,
1169 properties,... but not for VARIABLES as there is no guarantee that
1170 something declared as a sequence will actually turn out to be a sequence */
1171
1172 :- assert_pre(kernel_objects:enumerate_tight_type(Obj,Type),
1173 (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))).
1174 :- assert_post(kernel_objects:enumerate_tight_type(Obj,_), (type_check(Obj,bsets_object),ground_check(Obj))).
1175 :- assert_pre(kernel_objects:enumerate_tight_type(Obj,Type,_),
1176 (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))).
1177 :- assert_post(kernel_objects:enumerate_tight_type(Obj,_,_), (type_check(Obj,bsets_object),ground_check(Obj))).
1178
1179 :- assert_must_succeed(enumerate_tight_type([(int(1),int(2)),(int(2),int(4))],
1180 seq(integer) )).
1181 :- assert_must_succeed(enumerate_tight_type([(int(1),int(2))],seq(integer) )).
1182 :- assert_must_succeed(enumerate_tight_type([],seq(integer) )).
1183 :- assert_must_succeed((enumerate_tight_type(X,record([field(a,integer),field(b,global('Name'))])),
1184 equal_object(X,rec([field(a,int(1)),field(b,fd(1,'Name'))])) )).
1185 :- assert_must_fail(enumerate_tight_type([(int(1),int(2)),(int(3),int(_))],
1186 seq(integer) )).
1187 :- assert_must_fail(enumerate_tight_type([(int(3),int(_))],seq(integer) )).
1188 :- assert_must_succeed((bsets_clp:is_sequence(X,global_set('Name')),
1189 enumerate_tight_type(X,seq(global('Name')) ),
1190 X = [(int(1),fd(2,'Name'))] )).
1191 :- assert_must_succeed(( enumerate_tight_type(XX, record([field(balance,integer),field(name,global('Name'))])) ,
1192 XX = rec([field(balance,int(1)),field(name,fd(3,'Name'))]) )).
1193 :- assert_must_succeed(( enumerate_tight_type(XX, set(record([field(balance,global('Name')),field(name,global('Name'))]))) , /* STILL TAKES VERY LONG !! */
1194 XX = [rec([field(balance,fd(3,'Name')),field(name,fd(3,'Name'))])] )).
1195 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(balance,global('Name')),field(name,global('Name'))]))) ,S),
1196 length(S,Len), Len = 512 )).
1197 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(name,global('Code'))]))) ,S),
1198 length(S,Len), Len = 4 )).
1199 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(fname,global('Code')),field(name,global('Code'))]))) ,S),
1200 length(S,Len), Len = 16 )).
1201 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(fname,global('Code')),field(name,global('Name'))]))) ,S),
1202 length(S,Len), Len = 64 )).
1203 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(global('Name'))) ,S),
1204 length(S,Len), Len = 8 )).
1205 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(boolean))) ,S),
1206 length(S,Len), Len = 16 )).
1207 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(global('Name')))) ,S),
1208 length(S,Len), Len = 256 )).
1209 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(global('Code')))) ,S),
1210 length(S,Len), Len = 16 )).
1211 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(boolean))) ,S),
1212 length(S,Len), Len = 16 )).
1213 :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(couple(global('Code'),global('Name')))) ,S),
1214 length(S,Len), Len = 64 )).
1215 %:- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(couple(global('Code'),integer))) ,S),
1216 % length(S,Len), Len = 64 )).
1217 :- assert_must_succeed(( enumerate_tight_type(XX, set(record([field(balance,integer)]))) ,
1218 XX = [rec([field(balance,int(1))])] )).
1219 :- assert_must_succeed(( enumerate_tight_type(global_set('Code'),set(global('Code'))) )).
1220
1221 enumerate_tight_type(Obj,Type) :-
1222 ? enumerate_tight_type_wf(Obj,Type,no_wf_available).
1223
1224 enumerate_tight_type_wf(Obj,Type,WF) :-
1225 ? enumerate_tight_type_wf(Obj,Type,trigger_true(enumerate_tight_type),WF).
1226
1227 enumerate_tight_type(Obj,Type,EnumWarning) :- %enumerate_tight_type2(Type,Obj).
1228 enumerate_tight_type_wf(Obj,Type,EnumWarning,no_wf_available).
1229
1230 :- block enumerate_tight_type_wf(?,-,?,?), enumerate_tight_type_wf(?,?,-,?).
1231 enumerate_tight_type_wf(Obj,Type,EnumWarning,WF) :- %enumerate_tight_type2(Type,Obj).
1232 (ground_value(Obj) -> true ; % print(enumerate_tight_type(Obj,Type)),nl,
1233 ? enumerate_basic_type4(Type,Obj,tight,EnumWarning,WF)
1234 ).
1235
1236 /* TO DO: provide tight enumerators for nat, functions, ... ?? */
1237
1238
1239
1240 :- assert_must_succeed((X=[(int(I1),pred_true /* bool_true */),Y], dif(I1,1),
1241 kernel_objects:enumerate_seq_type(X,boolean,true),I1==2,Y=(int(1),pred_false /* bool_false */))).
1242
1243 ?enumerate_seq_type(X,Type,EnumWarning) :- enumerate_seq_type_wf(X,Type,EnumWarning,no_wf_available).
1244
1245 enumerate_seq_type_wf(X,Type,EnumWarning,WF) :-
1246 list_length_info(X,0,Len,ListType,MaxIndex), % ListType can be open or closed
1247 % determine MaxIndexForEnum:
1248 (ListType=closed
1249 -> MaxIndexForEnum=Len, EW = no_enum_warning,
1250 MaxIndex =< Len % otherwise this is obviously not a sequence (Index in set which is larger than size)
1251 ; ListType=open_bounded(MaxSize)
1252 -> MaxIndexForEnum=MaxSize, EW = no_enum_warning,
1253 MaxIndex =< MaxSize % otherwise cannot be a sequence
1254 % TO DO: use MinSize?
1255 ; (MaxIndex>Len -> Card = MaxIndex ; Card=Len), % in case we already have an explicit index which is higher than the length we use that as index
1256 b_global_set_cardinality('NAT1',NatCard),
1257 (NatCard<Card -> Max1=Card ; Max1=NatCard),
1258 (Max1<1 -> MaxIndexForEnum = 1 ; MaxIndexForEnum=Max1), % ensure that we generate enumeration warning
1259 EW = EnumWarning
1260 ),
1261 ? enumerate_seq(X,range(1,MaxIndexForEnum),MaxIndexForEnum,Type,EW,WF).
1262
1263 enumerate_seq([],_,_,_,_,_WF).
1264 enumerate_seq(V,_,_,_,_,_WF) :- nonvar(V),V=avl_set(_),!.
1265 enumerate_seq(V,_,_,Type,EnumWarning,WF) :- nonvar(V),V=closure(_,_,_),!,
1266 enumerate_basic_type_set(V,Type,not_tight,EnumWarning,WF).
1267 enumerate_seq(Seq,_,_,_,_,_WF) :- nonvar(Seq),
1268 is_custom_explicit_set(Seq,enumerate_seq),!.
1269 enumerate_seq(Seq,Indexes,Card,Type,EnumWarning,WF) :-
1270 (unbound_variable_for_cons(Seq)
1271 -> positive_card(Card),
1272 get_next_index(Indexes,Index,RemIndexes), % force next index
1273 Seq = [(int(Index),Element)|TSeq], VarEl=true
1274 ; Seq = [El|TSeq],
1275 (unbound_variable(El)
1276 -> VarEl=true, get_next_index(Indexes,Index,RemIndexes) % force next index
1277 ; VarEl=false),
1278 El = (int(Index),Element)
1279 ),
1280 (VarEl=true
1281 -> true % index already forced above
1282 ; number(Index) -> remove_index_ground(Indexes,Index,RemIndexes) % this can fail if Index > MaxIndex found above ! but not first time around, i.e., we will generate enum warning anyway
1283 ? ; remove_index(Indexes,Index,RemIndexes)
1284 ),
1285 (EnumWarning==no_enum_warning -> true
1286 ; gen_enum_warning_wf('seq (length)',inf,Card,EnumWarning,unknown,WF)), % delay enum_warning until we have made the first case-split (sometimes instantiating the sequence to at least one element will trigger an inconsistency)
1287 ? enumerate_tight_type_wf(Element,Type,WF),
1288 C1 is Card-1,
1289 ? enumerate_seq(TSeq,RemIndexes,C1,Type,no_enum_warning,WF).
1290
1291 get_next_index([Index1|RestIndexes],Index1,RestIndexes).
1292 get_next_index(range(I1,I2),I1,Res) :-
1293 I11 is I1+1,
1294 (I11>I2 -> Res=[] ; Res=range(I11,I2)).
1295
1296 remove_index_ground(Indexes,X,Res) :- get_next_index(Indexes,H,T),
1297 (X=H -> Res=T ; Res=[H|R2], remove_index_ground(T,X,R2)).
1298
1299 remove_index(Indexes,X,Res) :- get_next_index(Indexes,H,T),
1300 ? (X=H,Res=T ; X\==H, Res=[H|R2], remove_index(T,X,R2)).
1301
1302
1303
1304 /* a few more unit tests: */
1305
1306 :- assert_must_succeed(( findall(X,enumerate_type(X,set(couple(boolean,boolean)),tight) ,L), length(L,16) )).
1307 :- assert_must_succeed(( findall(X,enumerate_type(X,set(couple(boolean,boolean)),basic) ,L), length(L,16) )).
1308
1309 :- assert_must_succeed(( enumerate_tight_type(
1310 [rec([field(balance,int(0)),field(name,fd(2,'Name'))])],[
1311 rec([field(balance,int(1)),field(name,fd(3,'Name'))]),
1312 rec([field(balance,int(1)),field(name,fd(2,'Name'))]),
1313 rec([field(balance,int(0)),field(name,fd(1,'Name'))]),
1314 rec([field(balance,int(-1)),field(name,fd(1,'Name'))])],
1315 set(record([field(balance,integer),field(name,global('Name'))]))) )).
1316 :- assert_must_succeed(( enumerate_tight_type([
1317 rec([field(balance,int(1)),field(name,fd(2,'Name'))]),
1318 rec([field(balance,int(1)),field(name,fd(1,'Name'))]),
1319 rec([field(balance,int(0)),field(name,fd(1,'Name'))]),
1320 rec([field(balance,int(-1)),field(name,fd(1,'Name'))])|X],
1321 set(record([field(balance,integer),field(name,global('Name'))]))) ,
1322 X = [rec([field(balance,int(1)),field(name,fd(3,'Name'))])] )).
1323
1324 :- assert_must_succeed((not_element_of(X,[(pred_true /* bool_true */,pred_true /* bool_true */),
1325 (pred_true /* bool_true */,pred_false /* bool_false */),(pred_false /* bool_false */,pred_false /* bool_false */)]),
1326 enumerate_tight_type(X,couple(boolean,boolean)))).
1327
1328 :- assert_must_succeed(( not_equal_object(X,(pred_true /* bool_true */,pred_false /* bool_false */)),
1329 not_equal_object(X,(pred_false /* bool_false */,pred_false /* bool_false */)),
1330 not_equal_object(X,(pred_true /* bool_true */,pred_true /* bool_true */)),
1331 enumerate_tight_type(X,couple(boolean,boolean)))).
1332
1333 :- assert_must_succeed(( X = [fd(3,'Name')|T],enumerate_tight_type(X,set(global('Name'))),
1334 T == [fd(1,'Name'),fd(2,'Name')] )).
1335
1336
1337
1338 unbound_value(V) :-
1339 (var(V) -> unbound_variable(V)
1340 ; V = (V1,W1),unbound_value(V1), unbound_value(W1)).
1341
1342 :- use_module(bsyntaxtree,[syntaxtraversion/6]).
1343 enumerate_values_inside_expression(TExpr,WF) :-
1344 syntaxtraversion(TExpr,Expr,Type,_Infos,Subs,_),
1345 nonvar(Expr),!,
1346 enumerate_expr(Expr,Type,Subs,WF).
1347 enumerate_values_inside_expression(X,WF) :-
1348 add_internal_error('Unexpected B expression: ',enumerate_values_inside_expression(X,WF)).
1349
1350 %:- block enumerate_expr(-,?,?,?).
1351 enumerate_expr(value(X),Type,Subs,WF) :- !,
1352 (ground(Type) -> enumerate_value(X,Type,WF)
1353 ; add_internal_error('Value type not ground: ',enumerate_expr(value(X),Type,Subs,WF))).
1354 enumerate_expr(_,_,Subs,WF) :- l_enumerate_values_inside_expression(Subs,WF).
1355
1356 :- use_module(bsyntaxtree,[is_set_type/2]).
1357 % catch a few type errors:
1358 enumerate_value(X,Type,_) :- X==[], !,
1359 (is_set_type(Type,_) -> true ; add_internal_error('Illegal type: ',enumerate_value(X,Type,_))).
1360 enumerate_value(X,Type,WF) :- enumerate_basic_type_wf(X,Type,WF).
1361
1362 :- block l_enumerate_values_inside_expression(-,?).
1363 l_enumerate_values_inside_expression([],_WF).
1364 l_enumerate_values_inside_expression([H|T],WF) :-
1365 enumerate_values_inside_expression(H,WF),
1366 l_enumerate_values_inside_expression(T,WF).
1367
1368
1369 /* --------------- */
1370 /* top_level_dif/2 */
1371 /* --------------- */
1372 /* checks whether two terms have a different top-level functor */
1373
1374 :- assert_must_succeed(top_level_dif(a,b)).
1375 :- assert_must_succeed(top_level_dif(f(_X),g(_Z))).
1376 :- assert_must_fail(top_level_dif(f(a),f(_Z))).
1377 :- assert_must_fail(top_level_dif(f(a),f(b))).
1378
1379 :- block top_level_dif(-,?),top_level_dif(?,-).
1380 top_level_dif(X,Y) :-
1381 functor(X,FX,_),functor(Y,FY,_), FX\=FY. /* check arities ? */
1382
1383
1384 /* ------------------------------------------------------------------- */
1385 /* EQUAL OBJECT */
1386 /* ------------------------------------------------------------------- */
1387
1388 sample_closure(C) :-
1389 construct_closure([xx],[integer],Body,C),
1390 Body = b(conjunct(b(conjunct(
1391 b(member(b(identifier(xx),integer,[]),b(integer_set('NAT'),set(identifier(xx)),[])),pred,[]),
1392 b(greater(b(identifier(xx),integer,[]),b(integer(0),integer,[])),pred,[])),pred,[]),
1393 b(less(b(identifier(xx),integer,[]),b(integer(3),integer,[])),pred,[])),pred,[]).
1394
1395 :- assert_must_succeed(equal_object([int(3),int(1)],
1396 closure([zz],[integer],b(member(b(identifier(zz),integer,[]),b(value([int(1),int(3)]),set(integer),[])),pred,[])))).
1397 :- assert_must_succeed(( equal_object( (fd(1,'Name'),fd(1,'Name')) , (fd(1,'Name'),fd(1,'Name')) ) )).
1398 :- assert_must_succeed(( equal_object( (X,Y) , (fd(2,'Name'),fd(2,'Name')) ) , X = fd(2,'Name'), Y=fd(2,'Name') )).
1399 :- assert_must_fail(equal_object(term(a),term(b))).
1400 :- assert_must_fail(equal_object(int(1),int(2))).
1401 :- assert_must_fail(equal_object([term(a),term(b)],[term(a),term(c)])).
1402 :- assert_must_fail((equal_object([(int(1),[Y])],[(int(X),[Z])]),
1403 Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[int(2)])).
1404 :- assert_must_fail(equal_object(rec([field(a,int(1))]),rec([field(a,int(2))]))).
1405 :- assert_must_fail(equal_object(rec([field(a,int(2)),field(b,int(3))]),
1406 rec([field(a,int(2)),field(b,int(4))]))).
1407 :- assert_must_succeed(equal_object(rec([field(a,int(2))]),rec([field(a,int(2))]))).
1408 :- assert_must_succeed(equal_object(rec([field(a,int(2)),field(b,[int(3),int(2)])]),
1409 rec([field(a,int(2)),field(b,[int(2),int(3)])]) )).
1410 :- assert_must_succeed(equal_object([(term(a),[])],[(term(a),[])])).
1411 :- assert_must_succeed(equal_object(_X,[int(1),int(2)])).
1412 :- assert_must_succeed(equal_object([int(1),int(2)],_X)).
1413 :- assert_must_succeed((equal_object([(int(1),[Y])],[(int(X),[Z])]),
1414 Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[])).
1415 :- assert_must_succeed(equal_object([int(1),int(2)],[int(2),int(1)])).
1416 :- assert_must_succeed(equal_object(global_set('Name'),[fd(2,'Name'),fd(3,'Name'),fd(1,'Name')])).
1417 :- assert_must_succeed(equal_object(global_set('Name'),[fd(1,'Name'),fd(3,'Name'),fd(2,'Name')])).
1418 :- assert_must_succeed((equal_object([fd(3,'Name'),fd(2,'Name'),fd(1,'Name')],global_set('Name')))).
1419 %:- assert_must_succeed((equal_object([fd(3,'Name'),fd(2,'Name'),fd(1,'Name')],X),X=global_set('Name'))).
1420 :- assert_must_succeed((equal_object(Y,X),X=global_set('Name'),equal_object(Y,[fd(3,'Name'),fd(2,'Name'),fd(1,'Name')]))).
1421 :- assert_must_succeed((equal_object(X,X),X=global_set('Name'))).
1422 :- assert_must_succeed((equal_object(_,X),X=global_set('Name'))).
1423 :- assert_must_succeed((equal_object(X,global_set('Name')),X=global_set('Name'))).
1424 :- assert_must_succeed((equal_object([_A,_B],[int(2),int(1)]))).
1425 :- assert_must_fail((equal_object(X,global_set('Code')),X=global_set('Name'))).
1426 :- assert_must_fail((equal_object(Y,global_set('Name')),Y=[fd(3,'Name'),fd(1,'Name')])).
1427 :- assert_must_fail((equal_object(Y,global_set('Name')),Y=[_,_])).
1428 :- assert_must_succeed((equal_object(X,closure([xx],[integer],b(truth,pred,[]))),X==closure([xx],[integer],b(truth,pred,[])))).
1429 :- assert_must_succeed((sample_closure(C), equal_object([int(1),int(2)],C))).
1430 :- assert_must_succeed((sample_closure(C), equal_object(C,[int(1),int(2)]))).
1431 :- assert_must_fail((sample_closure(C), equal_object(C,[int(1),int(0)]))).
1432 :- assert_must_fail((sample_closure(C), equal_object(C,global_set('NAT')))).
1433 :- assert_must_succeed((equal_object(freeval(selfcx,a,int(5)),freeval(selfcx,a,int(5))))).
1434 :- assert_must_fail((equal_object([int(1),int(2),int(3)],global_set('NATURAL1')))).
1435 :- assert_must_fail((equal_object(X,global_set('NATURAL1')),equal_object(X,[int(1),int(2),int(3)]))).
1436 :- assert_must_fail((equal_object(X,[int(1),int(2),int(3)]),equal_object(X,global_set('NATURAL1')))).
1437 :- assert_must_fail((equal_object(X,global_set('NATURAL')),equal_object(X,global_set('NATURAL1')))).
1438 :- assert_must_succeed((equal_object(X,global_set('NATURAL')),equal_object(X,global_set('NATURAL')))).
1439 % :- assert_must_fail((equal_object(freeval(selfcx,a,int(5)),freeval(selfcy,a,int(5))))). % is a type error
1440 :- assert_must_fail((equal_object(freeval(selfcx,b,int(5)),freeval(selfcx,a,int(5))))).
1441 :- assert_must_fail((equal_object(freeval(selfcx,a,int(5)),freeval(selfcx,a,int(6))))).
1442 :- assert_must_succeed((equal_object(
1443 [[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')],
1444 [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(3,'Name'),fd(2,'Name')]]
1445 ,[[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')],
1446 [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(2,'Name'),fd(3,'Name')]])
1447 )).
1448 :- assert_must_succeed(exhaustive_kernel_check( (equal_object([int(3),int(2),int(1)],[int(2)|T]),
1449 equal_object(T,[int(1),int(3)])))).
1450 :- assert_must_succeed(exhaustive_kernel_check([commutative],equal_object([int(3),int(1)],[int(1),int(3)]))).
1451 :- assert_must_succeed(exhaustive_kernel_check([commutative],equal_object([int(3),int(4),int(1)],[int(4),int(1),int(3)]))).
1452
1453 %:- assert_must_succeed(exhaustive_kernel_fail_check([commutative],equal_object([int(1),int(2),int(3)],global_set('NATURAL1')))).
1454 :- assert_must_succeed(( equal_object([int(0),int(5)|T],avl_set(node(int(1),true,1,node(int(0),true,0,empty,empty),node(int(3),true,1,empty,node(int(5),true,0,empty,empty))))), nonvar(T),equal_object(T,[int(_A),int(_B)]) )).
1455 % NOTE: had multiple solutions; after solving Ticket #227 it no longer has :-)
1456 :- assert_must_succeed(( equal_object([int(0),int(5)|T],avl_set(node(int(1),true,1,node(int(0),true,0,empty,empty),node(int(3),true,1,empty,node(int(5),true,0,empty,empty))))), nonvar(T),equal_object(T,[_A,_B]) )).
1457
1458 :- assert_must_succeed((equal_object([_X,_Y],[int(1),int(2)]))).
1459 :- assert_must_succeed((equal_object([(int(1),X),(int(2),Y),(int(3),Z),(int(4),A),(int(5),B),(int(6),C),(int(7),D),(int(8),E),(int(9),F),(int(10),G)],avl_set(node((int(5),int(25)),true,0,node((int(2),int(4)),true,1,node((int(1),int(1)),true,0,empty,empty),node((int(3),int(9)),true,1,empty,node((int(4),int(16)),true,0,empty,empty))),node((int(8),int(64)),true,0,node((int(6),int(36)),true,1,empty,node((int(7),int(49)),true,0,empty,empty)),node((int(9),int(81)),true,1,empty,node((int(10),int(100)),true,0,empty,empty)))))),
1460 A == int(16), B == int(25),C == int(36),D == int(49),E == int(64),F == int(81),G == int(100),X == int(1),Y == int(4), Z == int(9))).
1461
1462 :- use_module(bool_pred).
1463
1464 ?equal_object(V1,V2) :- equal_object_wf(V1,V2,no_wf_available).
1465 ?equal_object(V1,V2,Origin) :- equal_object_wf(V1,V2,Origin,no_wf_available).
1466 ?equal_object_optimized(V1,V2,Origin) :- equal_object_optimized_wf(V1,V2,Origin,no_wf_available).
1467 ?equal_object_optimized(V1,V2) :- equal_object_optimized(V1,V2,unknown).
1468
1469 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
1470 :- if(environ(prob_safe_mode,true)).
1471 /* a version of equal_object which will convert lists to avl if possible */
1472 equal_object_optimized_wf(V1,V2,Origin,WF) :-
1473 ( var(V1) -> (var(V2) -> V1=V2 ; equal_object_opt3(V2,V1,WF))
1474 ; equal_object_opt3(V1,V2,WF)),
1475 check_value(V1,Origin), check_value(V2,Origin).
1476 equal_object_wf(V1,V2,Origin,WF) :- ( (var(V1);var(V2)) -> V1=V2
1477 ; nonvar(V1) -> equal_object3(V1,V2,WF)
1478 ; equal_object3(V2,V1,WF)),
1479 check_value(V1,val1(Origin)), check_value(V2,val2(Origin)).
1480 equal_object_wf(V1,V2,WF) :- ( (var(V1);var(V2)) -> V1=V2
1481 ; nonvar(V1) -> equal_object3(V1,V2,WF)
1482 ; equal_object3(V2,V1,WF)),
1483 check_value(V1,equal_object1), check_value(V2,equal_object2).
1484 check_value(X,Origin) :- nonvar(X) -> check_value_aux(X,Origin) ; true.
1485 check_value_aux((A,B),Origin) :- !, check_value(A,pair1(Origin)), check_value(B,pair2(Origin)).
1486 check_value_aux([H|T],Origin) :- !, check_value(H,head(Origin)), check_value(T,tail(Origin)).
1487 check_value_aux(avl_set(X),Origin) :- !,
1488 (var(X) -> add_warning(Origin,'Variable avl_set')
1489 ; X=empty -> add_warning(Origin,'Empty avl_set') ; true).
1490 check_value_aux(closure(P,T,B),Origin) :- !,
1491 (ground(P),ground(T),nonvar(B) -> true
1492 ; add_warning(Origin,illegal_closure(P,T,B))).
1493 check_value_aux(_,_Origin).
1494 :- else.
1495 /* a version of equal_object which will convert lists to avl if possible */
1496 equal_object_optimized_wf(V1,V2,_Origin,WF) :-
1497 ? ( var(V1) -> (var(V2) -> V1=V2 ; equal_object_opt3(V2,V1,WF))
1498 ? ; equal_object_opt3(V1,V2,WF)).
1499
1500 equal_object_wf(V1,V2,_Origin,WF) :- ( (var(V1);var(V2)) -> V1=V2
1501 ? ; nonvar(V1) -> equal_object3(V1,V2,WF)
1502 ; equal_object3(V2,V1,WF)).
1503 equal_object_wf(V1,V2,WF) :- ( (var(V1);var(V2)) -> V1=V2
1504 ? ; nonvar(V1) -> equal_object3(V1,V2,WF)
1505 ; equal_object3(V2,V1,WF)).
1506 :- endif.
1507
1508
1509 equal_object_opt3(int(X),Y,_WF) :- !, Y=int(X).
1510 equal_object_opt3(fd(X,T),Y,_WF) :- !, Y=fd(X,T).
1511 equal_object_opt3(string(X),Y,_WF) :- !, Y=string(X).
1512 equal_object_opt3(pred_false,Y,_WF) :- !, Y=pred_false.
1513 equal_object_opt3(pred_true,Y,_WF) :- !, Y=pred_true.
1514 equal_object_opt3(X,S2,WF) :- var(S2), %unbound_variable(S2), % is it ok to assing an AVL set in one go ?!
1515 should_be_converted_to_avl_from_lists(X), !, % does a ground(X) check
1516 ? construct_avl_from_lists_wf(X,S2,WF).
1517 %equal_object_opt3([H|T],S2) :- var(S2),ground(H),ground(T), !, construct_avl_from_lists([H|T],S2).
1518 ?equal_object_opt3(X,Y,WF) :- equal_object3(X,Y,WF).
1519
1520
1521 %%equal_object3c(X,Y) :- if(equal_object3(X,Y),true,
1522 %% (print_message(equal_object3_failed(X,Y)),equal_object3(X,Y),fail)). %%
1523 :- if(environ(prob_safe_mode,true)).
1524 equal_object3(X,Y,_WF) :- (nonvar(Y) -> type_error(X,Y) ; illegal_value(X)),
1525 add_internal_error('Internal Typing Error (please report as bug !) : ',equal_object(X,Y)),fail.
1526 :- endif.
1527 equal_object3(closure(Par,ParTypes,Clo),Y,WF) :- var(Y),!,
1528 ( closure_occurs_check(Y,Par,ParTypes,Clo)
1529 -> print(occurs_check(Y,Par)),nl,
1530 expand_custom_set_wf(closure(Par,ParTypes,Clo),Expansion,equal_object3,WF),
1531 equal_object_optimized_wf(Y,Expansion,equal_object3,WF)
1532 ; Y = closure(Par,ParTypes,Clo)).
1533 equal_object3(closure(Parameters,PT,Cond),Y,WF) :-
1534 equal_object_custom_explicit_set(closure(Parameters,PT,Cond),Y,WF).
1535 %equal_object3(Obj,Y) :- is_custom_explicit_set(Obj,equal_object3_Obj),
1536 % equal_object_custom_explicit_set(Obj,Y,WF). % inlined below for performance
1537 equal_object3(global_set(X),Y,WF) :- equal_object_custom_explicit_set(global_set(X),Y,WF).
1538 equal_object3(freetype(X),Y,WF) :- equal_object_custom_explicit_set(freetype(X),Y,WF).
1539 ?equal_object3(avl_set(X),Y,WF) :- equal_object_custom_explicit_set(avl_set(X),Y,WF).
1540 equal_object3(pred_true /* bool_true */,pred_true /* bool_true */,_WF).
1541 equal_object3(pred_false /* bool_false */,pred_false /* bool_false */,_WF).
1542 equal_object3(term(X),term(X),_WF).
1543 equal_object3(string(X),string(X),_WF).
1544 ?equal_object3(rec(F1),rec(F2),WF) :- equal_fields_wf(F1,F2,WF).
1545 equal_object3(freeval(Id,C,F1),freeval(Id,C,F2),WF) :-
1546 instantiate_freetype_case(Id,C,C),
1547 equal_object_wf(F1,F2,WF).
1548 equal_object3(int(X),int(X),_WF).
1549 equal_object3(fd(X,Type),fd(Y,Type),_WF) :- eq_fd(X,Y).
1550 equal_object3((X,Y),(X2,Y2),WF) :- %write(eq(X,Y,X2,Y2)),nl,
1551 (check_if_can_unify(Y,Y2)
1552 -> true %before unifying X/X2 quickly check if Y/Y2 definitely not_equal
1553 ; %write(no_unify((X,Y),(X2,Y2))),nl,
1554 fail), %
1555 ? equal_object_wf(X,X2,WF),
1556 ? equal_object_wf(Y,Y2,WF). % initially order was reversed; but this can lead to issues in e.g. g(f("f2")), for f = {"f0"|->0, "f2"|->2} where g gets called for 0 before "f2"="f0" fails
1557 equal_object3([],X,WF) :- empty_set_wf(X,WF).
1558 equal_object3([H|T],S2,WF) :- nonvar(S2), is_custom_explicit_set_nonvar(S2),!,
1559 ? equal_custom_explicit_set_cons_wf(S2,H,T,WF).
1560 %equal_object3([H|T],S2,WF) :- equal_cons_wf(S2,H,T,WF). % leads to time-out for test 1270 : TODO investigate
1561 ?equal_object3([H|T],S2,_WF) :- equal_cons(S2,H,T).
1562
1563 % relevant for test 1419 for SICStus 4.10 for formula
1564 % card(x)=1 & !(y).(y:x & prj1(INTEGER,BOOL)(y)<50 => (prj1(INTEGER,BOOL)(y)+1,TRUE):x) & x<:(1..50)*BOOL
1565 % due to issue SPRM-21542 indomain/labeling triggers reifications without labeled value being visible to triggered code
1566 % triggered also in tests 654, 659, 995, 1079, 2142, 2341 or for !x.(x:1..10 => (x,TRUE) = (f(x),FALSE)) & f: 1..10 --> 1..10
1567 check_if_can_unify(X,Y) :- nonvar(X), nonvar(Y),!, check_if_can_unify_nv(X,Y).
1568 % should we do more checks ground string(.), ground integers, nested couple (X1,X2)
1569 check_if_can_unify(_,_).
1570 check_if_can_unify_nv(pred_true,R) :- !, R=pred_true.
1571 check_if_can_unify_nv(pred_false,R) :- !, R=pred_false.
1572 check_if_can_unify_nv(int(X),int(Y)) :- !,check_if_can_unify_atomic(X,Y).
1573 check_if_can_unify_nv(string(X),string(Y)) :- !,check_if_can_unify_atomic(X,Y).
1574 check_if_can_unify_nv(fd(X,T),fd(Y,T)) :- !,check_if_can_unify_atomic(X,Y).
1575 check_if_can_unify_nv(_,_).
1576
1577 check_if_can_unify_atomic(X,Y) :- nonvar(X),nonvar(Y),!,X=Y.
1578 check_if_can_unify_atomic(_,_).
1579
1580 equal_object_custom_explicit_set(Obj,Y,WF) :-
1581 (var(Y) -> Y = Obj
1582 ; (is_custom_explicit_set_nonvar(Y) -> equal_explicit_sets_wf(Obj,Y,WF)
1583 ; (Y=[] -> is_empty_explicit_set_wf(Obj,WF)
1584 ? ; Y=[H|T] -> equal_custom_explicit_set_cons_wf(Obj,H,T,WF)
1585 ; add_internal_error('Illegal set: ',equal_object_custom_explicit_set(Obj,Y,WF)),fail
1586 )
1587 )).
1588
1589 equal_custom_explicit_set_cons_wf(CS,H,T,_WF) :- CS \= avl_set(_),
1590 var(H),var(T), % TO DO: should we move this treatment below ? to equal_cons_lwf
1591 % YES, I THINK WE CAN DELETE THIS NOW for avl_sets; but not yet for global_set,...
1592 % print_term_summary(equal_custom_explicit_set_cons(CS,H,T)),nl, (debug_mode(on) -> trace ; true),
1593 unbound_variable(H),
1594 unbound_variable_for_cons(T),
1595 !,
1596 remove_minimum_element_custom_set(CS,Min,NewCS),
1597 (H,T) = (Min,NewCS).
1598 equal_custom_explicit_set_cons_wf(avl_set(AVL),H,T,_WF) :- var(H),
1599 is_unbound_ordered_list_skeleton(H,T),!, % TO DO: provide this also for global_set(_)
1600 % below we check if H can be removed from AVL and remove it
1601 remove_minimal_elements([H|T],avl_set(AVL),SkeletonToUnify),
1602 [H|T] = SkeletonToUnify.
1603 equal_custom_explicit_set_cons_wf(Obj,H,T,WF) :-
1604 ? equal_cons_lwf(Obj,H,T,2,WF).
1605 %equal_cons_wf(Obj,H,T,WF). % equal_cons_wf causes issues to tests 799, (but not anymore 1751, 1642, 1708)
1606
1607
1608 :- block equal_fields_wf(-,-,?).
1609 equal_fields_wf([],[],_).
1610 equal_fields_wf([field(Name1,V1)|T1],[field(Name2,V2)|T2],WF) :-
1611 check_field_name_compatibility(Name1,Name2,equal_fields_wf),
1612 % TODO: check check_if_can_unify applied to T1/T2?
1613 equal_object_wf(V1,V2,field,WF),
1614 ? equal_fields_wf(T1,T2,WF).
1615
1616
1617 % is just like equal_cons, but H and T are guaranteed by the caller to be free
1618 % this just gives one next element of the set; can be used to iterate over sets.
1619 get_next_element(R,H,T) :- var(R),!,R=[H|T].
1620 get_next_element([H1|T1],H,T) :- !,(H1,T1)=(H,T).
1621 get_next_element(R,H,T) :- equal_cons(R,H,T).
1622
1623
1624 ?equal_cons_wf(R,H,T,WF) :- WF == no_wf_available,!, equal_cons_lwf(R,H,T,2,WF).
1625 equal_cons_wf(R,H,T,WF) :-
1626 %get_cardinality_wait_flag(R,equal_cons_wf,WF,LWF),
1627 %get_binary_choice_wait_flag(equal_cons_wf,WF,LWF), %old version
1628 LWF = lwf_card(R,equal_cons_wf,WF), % will be instantiated by instantiate_lwf
1629 ? equal_cons_lwf(R,H,T,LWF,WF).
1630
1631 % a deterministic version; will never instantiate non-deterministically:
1632 % probably better to use equal_cons_wf if possible
1633 %equal_cons_det(R,H,T) :- equal_cons_lwf4(R,H,T,_).
1634
1635 equal_cons(R,H,T) :-
1636 ? equal_cons_lwf(R,H,T,2,no_wf_available). %lwf_first(2)).
1637
1638 :- block blocking_equal_cons_lwf(-,?,?,?,?).
1639 ?blocking_equal_cons_lwf(E,H,T,LWF,WF) :- equal_cons_lwf(E,H,T,LWF,WF).
1640
1641 %equal_cons_lwf4(R,H,T,LWF) :- equal_cons_lwf(R,H,T,LWF,no_wf_available).
1642
1643 ?equal_cons_lwf(R,H,T,_,_) :- var(R),!,add_new_el(T,H,R).
1644 equal_cons_lwf([HR|TR],H,T,_,WF) :- ground_value(H), %print(delete_exact(H,[HR|TR])),nl,
1645 try_quick_delete_exact_member([HR|TR],H,Rest), % try and see if we can find an exact member in the list
1646 % adds quadratic complexity if TR is a list; TODO: maybe do a sort
1647 !,
1648 %equal_object(Rest,T,equal_cons_lwf_1).
1649 ? equal_object_wf(Rest,T,equal_cons_lwf_1,WF).
1650 ?equal_cons_lwf([HR|TR],H,T,LWF,WF) :- !, equal_cons_cons(HR,TR,H,T,LWF,WF).
1651 equal_cons_lwf(avl_set(AVL),H,T,LWF,WF) :- !,
1652 (is_one_element_custom_set(avl_set(AVL),El)
1653 ? -> empty_set(T), % was T=[], but T could be an empty closure !
1654 ? equal_object_wf(El,H,equal_cons_lwf_2,WF)
1655 ; T==[] -> fail % we have a one element set and AVL is not
1656 ; element_can_be_added_or_removed_to_avl(H) ->
1657 remove_element_from_explicit_set(avl_set(AVL),H,AR),
1658 ? equal_object_wf(AR,T,equal_cons_lwf_3,WF)
1659 ; nonvar(T),T=[H2|T2],element_can_be_added_or_removed_to_avl(H2) ->
1660 remove_element_from_explicit_set(avl_set(AVL),H2,AR),
1661 ? equal_object_wf(AR,[H|T2],equal_cons_lwf_4,WF)
1662 % TO DO: move all such H2 to the front ??
1663 % Common pattern for function application patterns f(a) = 1 & f(b) = 2 & f = AVL
1664 % We have f = [(a,1),(b,2)|_] to be unified with an avl_set
1665 ; at_most_one_match_possible(H,AVL,Pairs) -> Pairs=[H2], % unification could fail if no match found
1666 % this optimisation is redundant wrt definitely_not_in_list optimisation below; check test 1716
1667 % but it has better performance for large sets, e.g., when unifying with a large sequence skeleton
1668 % TODO: it could be useful even if there are more than one matches??
1669 ? equal_object_wf(H,H2,WF),
1670 % element_can_be_added_or_removed_to_avl not checked !
1671 % we may need to call another predicate to remove, which only checks index
1672 % or at_most_one_match_possible should remove the element itself
1673 remove_element_from_explicit_set(avl_set(AVL),H2,AR), % print(removed_from_avl_by_equal_cons(H)),nl,
1674 ? equal_object_wf(AR,T,equal_cons_lwf_3,WF) %%
1675 ; expand_custom_set_wf(avl_set(AVL),ES,equal_cons_lwf,WF), % length(ES,LenES),print(expanded(LenES,T)),nl,
1676 % before attempting unification quickly look if lengths are compatible:
1677 ? quick_check_length_compatible(ES,[H|T]), % not really sure this is worth it: we have propagate_card in equal_cons_cons below
1678 %we could do the following: (nonvar(LWF),LWF=lwf_card(_,_,WF) -> quick_propagation_element_information(avl_set(AVL),H,WF,NS) ; true) % we could also do it for T, but both H/T can cause issues with free_var detection
1679 equal_cons_perf_message(AVL,H,T,WF),
1680 ? equal_cons_lwf(ES,H,T,LWF,WF) ).
1681 equal_cons_lwf(C,H,T,LWF,WF) :-
1682 is_interval_closure_or_integerset(C,Low,Up),
1683 (T==[] -> true ; finite_bound(Low), finite_bound(Up)),
1684 !,
1685 ? equal_cons_interval(H,T,Low,Up,LWF,WF).
1686 equal_cons_lwf(closure(P,Ty,B),H,T,LWF,WF) :- !,
1687 ? equal_cons_closure(P,Ty,B,H,T,LWF,WF).
1688 equal_cons_lwf(freetype(ID),H,T,LWF,WF) :- !, expand_custom_set_wf(freetype(ID),ES,equal_cons_lwf,WF),
1689 blocking_equal_cons_lwf(ES,H,T,LWF,WF).
1690 ?equal_cons_lwf(global_set(G),H,T,LWF,WF) :- equal_cons_global_set(G,H,T,LWF,WF).
1691
1692
1693 :- use_module(probsrc(avl_tools),[avl_height_less_than/2]).
1694 :- use_module(performance_messages,[perf_format_wf/3]).
1695 equal_cons_perf_message(AVL,H,T,WF) :- preference(performance_monitoring_on,true),
1696 \+ avl_height_less_than(AVL,5),
1697 \+ is_unbound_ordered_list_skeleton(H,T), % otherwise H will be set to minimum of AVL deterministically
1698 !,
1699 translate:translate_bvalue(avl_set(AVL),AS),
1700 translate:translate_bvalue([H|T],HTS),
1701 perf_format_wf('Expanding avl_set for set-unification~n ~w~n =~n ~w~n',[AS,HTS],WF).
1702 equal_cons_perf_message(_,_,_,_).
1703
1704 equal_cons_closure(P,Ty,B,_H,T,_LWF,_WF) :- nonvar(T),
1705 is_definitely_finite(T), % move earlier; is_infinite_closure can perform expansions, e.g., for nested closures
1706 is_infinite_closure(P,Ty,B),
1707 !,
1708 fail. % an infinite set cannot be equal to a finite one.
1709 equal_cons_closure(Par,Types,B,H,T,LWF,WF) :-
1710 % used to be expand_custom_set_wf(closure(Par,Types,B),ES,equal_cons_closure,WF) which calls:
1711 expand_closure_to_list(Par,Types,B,ES,Done,equal_cons_closure,WF),
1712 ? lazy_check_elements_of_closure([H|T],Done, Par,Types,B,WF), % relevant for test 2466
1713 % the lazy check in custom_explicit_sets does not trigger, as we cannot unify [H|T] with ES (unlike in equal_expansions3)
1714 % because we do not know if [H|T] is ordered
1715 ? blocking_equal_cons_lwf(ES,H,T,LWF,WF).
1716
1717 is_definitely_finite(Var) :- var(Var),!,fail.
1718 is_definitely_finite([]).
1719 is_definitely_finite([_|T]) :- is_definitely_finite(T).
1720 is_definitely_finite(avl_set(_)).
1721
1722 %get_wf_from_lwf(LWF,WF) :- % TO DO: a cleaner, less hacky version; passing WF around if possible
1723 % (nonvar(LWF),LWF=lwf_card(_,_,WF1) -> WF=WF1 ; WF = no_wf_available).
1724
1725 finite_bound(I) :- (var(I) -> true /* inf would be created straightaway */ ; number(I)).
1726
1727 % Purpose: treat some specific closures better; e.g., interval closures and constraint a..b = {1,y,5,x,4} or a..b = {x} & x:100..1002
1728 equal_cons_interval(H,T,Low,Up,_LWF,_WF) :- T==[],!, % Low..Up = {H} -> Low=H & Up=H
1729 % unification will fail if Low or Up are not numbers (inf)
1730 (int(Low),int(Up)) = (H,H).
1731 %equal_cons_interval(_H,_T,Low,Up,_LWF,WF) :- (nonvar(Low),\+ number(Low) ; nonvar(Up),\+ number(Up)),!,
1732 % gen_enum_warning_wf('OPEN INTERVAL',Low:Up,'cannot expand',trigger_throw(equal_cons_interval),WF),
1733 % % we could try and instantiate T to an infinite closure
1734 % fail.
1735 equal_cons_interval(H,T,Low,Up,LWF,WF) :-
1736 (number(Low),number(Up) -> true % we can expand interval fully
1737 ; propagate_in_interval([H|T],int(Low),int(Up),0)),
1738 expand_interval_closure_to_avl(Low,Up,ES),
1739 ? blocking_equal_cons_lwf(ES,H,T,LWF,WF).
1740
1741 :- block propagate_in_interval(-,?,?,?).
1742 propagate_in_interval([],Low,Up,Sze) :-
1743 (Sze > 0 -> S1 is Sze-1, int_plus(Low,int(S1),Up) ; true). % Test should always be true
1744 propagate_in_interval([H|T],Low,Up,Sze) :-
1745 in_nat_range(H,Low,Up), % without enumeration
1746 S1 is Sze+1,
1747 propagate_in_interval(T,Low,Up,S1).
1748 propagate_in_interval(avl_set(_A),_Low,_Up,_). % TO DO: propagate if Low/Up not instantiated
1749 propagate_in_interval(closure(_,_,_),_,_,_).
1750 propagate_in_interval(global_set(_),_,_,_).
1751
1752 quick_check_length_compatible([],R) :- !,
1753 (var(R) -> R=[] % can we force R=[] here ??
1754 ; R \= [_|_]). %(R \= [_|_] -> true ; print(incompatible(R)),fail).
1755 quick_check_length_compatible([_|T],R) :-
1756 (var(R) -> true
1757 ; R = [] -> fail
1758 ? ; R = [_|RT] -> quick_check_length_compatible(T,RT)
1759 ; true).
1760
1761 :- block equal_cons_global_set(-,?,?,?,?).
1762 ?equal_cons_global_set(G,H,T,LWF,WF) :- is_infinite_global_set(G,_),!,
1763 % for maximal sets we could complement_set([H],global(G),Res),
1764 /* should normally fail, unless T is not a list but contains closure or global set */
1765 test_finite_set_wf(T,Finite,WF), dif(Finite,pred_true),
1766 when((nonvar(Finite);nonvar(LWF)),equal_cons_global_set_warning(LWF,G,H,T,WF)).
1767 % used to be : expand_custom_set(global_set(G),ES), equal_cons_lwf4(ES,H,T,LWF))).
1768 equal_cons_global_set(G,H,T,LWF,WF) :-
1769 %(is_infinite_global_set(G,_) -> test_finite_set_wf(T,Finite,WF), Finite \== pred_true ; true),
1770 expand_custom_set_wf(global_set(G),ES,equal_cons_global_set,WF),
1771 ? equal_cons_lwf(ES,H,T,LWF,WF).
1772
1773
1774 :- block equal_cons_global_set_warning(-,?,?,?,?).
1775 equal_cons_global_set_warning(_,G,H,T,WF) :-
1776 add_new_event_in_error_scope(enumeration_warning(enumerating(G),G,'{}',finite,critical),
1777 print_equal_cons_warning(G,H,T,WF)),
1778 fail. % WITH NEW SEMANTICS OF ENUMERATION WARNING WE SHOULD PROBABLY ALWAYS FAIL HERE !
1779
1780 % THROWING, Span added by add_new_event_in_error_scope
1781 print_equal_cons_warning(G,H,T,WF,THROWING,Span) :-
1782 print('### Enumeration Warning: trying to deconstruct infinite set: '),
1783 translate:print_bvalue(global_set(G)),nl,
1784 print('### Source: '), print(equal_cons_global_set(G,H,T)),nl,
1785 print_throwing_wf(THROWING,unknown_info,Span,WF).
1786
1787 add_new_el(T,H,R) :- var(T),!,R=[H|T].
1788 add_new_el(T,H,R) :- nonvar(T), is_custom_explicit_set_nonvar(T),
1789 add_element_to_explicit_set_wf(T,H,Res,no_wf_available), % will fail for closure/3
1790 !,
1791 Res=R.
1792 add_new_el([HT|TT],H,R) :- !,R=[H,HT|TT].
1793 add_new_el([],H,R) :- !, R=[H].
1794 add_new_el(Set,H,R) :- expand_custom_set_to_list(Set,ESet,_,add_new_el),
1795 add_new_el(ESet,H,R).
1796
1797 %delete_exact_member(V,_,_) :- var(V),!,fail.
1798 %delete_exact_member([H|T],El,Res) :-
1799 % (H==El -> Res=T
1800 % ; Res=[H|TR], delete_exact_member(T,El,TR)).
1801
1802 % a version of delete_exact_member with a cut off
1803 % avoids spending useless time traversing large non-ground lists
1804 % for a list consisting only of non-ground elements delete_exact_member will never succeed !
1805 % this occurs e.g., when a large list skeleton generated by e.g. size_of_sequence is unified with an avl_set
1806 % (e.g., m = READ_PGM_IMAGE_FILE("pgm_files/yuv_1.pgm") & %i.(i:1..550| m(i) /|\ 725))
1807 try_quick_delete_exact_member(List,El,Result) :-
1808 try_quick_delete_exact_member(List,1,El,Result).
1809 try_quick_delete_exact_member(V,_,_,_) :- var(V),!,fail.
1810 try_quick_delete_exact_member([H|T],Sz,El,Res) :-
1811 (H==El -> Res=T
1812 ; Res=[H|TR],
1813 (Sz>50
1814 -> ground_value(H), % after a certain limit we only proceed if there are ground elements
1815 % we could also check: preferences:preference(use_smt_mode,true)
1816 Sz=30 % check again in 20 steps
1817 ; Sz1 is Sz+1),
1818 try_quick_delete_exact_member(T,Sz1,El,TR)).
1819
1820
1821 %unbound_variable(V) :- !, unbound_variable_check(V).
1822 unbound_variable(V) :- free_var(V), frozen(V,Residue),
1823 %unbound_residue(Residue,V).
1824 (unbound_residue(Residue,V) -> true ; %print(bound_var(V,Residue)),nl,trace,unbound_residue(Residue,V),
1825 fail).
1826 unbound_residue((A,B),V) :- !,unbound_residue(A,V), unbound_residue(B,V).
1827 unbound_residue(true,_) :- !.
1828 unbound_residue(Module:Call,Variable) :- unbound_residue_m(Module,Call,Variable).
1829
1830 unbound_residue_m(external_functions,to_string_aux(GrV,_Val,Str),V) :- !, %GrV checks for groundness of _Val
1831 V==GrV,unbound_variable(Str).
1832 unbound_residue_m(external_functions,format_to_string_aux(GrV,_Format,_Val,Str),V) :- !,
1833 %GrV checks for groundness of _Val
1834 V==GrV,unbound_variable(Str).
1835 % TO DO: we need to detect other functions (e.g., B function application,...) which result in values which are not used
1836 %unbound_residue_m(_,ground_value_check(V1,V2),V) :- !, V1==V, unbound_variable(V2). % V1==V not necessary?! cycle check
1837 unbound_residue_m(Module,Residue,Var) :- unbound_basic_residue(Module,Residue,Var).
1838
1839 %unbound_basic_residue(_,true,_).
1840 unbound_basic_residue(_,ground_value_check(V1,V2),Var) :- !, Var==V1, % == check to prevent loops
1841 % in particularly in SWI, where residues also contain calls where Var==V2; e.g., test 639
1842 unbound_variable(V2).
1843 unbound_basic_residue(_,ground_value_check_aux(V1,V2,V3),Var) :- !, (Var==V1 -> true ; Var==V2), unbound_variable(V3).
1844 % we could also treat ground_value_opt_check
1845 unbound_basic_residue(b_interpreter_components,observe_variable_block(_,_,_,_,_),_). % when in -p TRACE_INFO TRUE mode
1846 unbound_basic_residue(b_interpreter_components,observe_variable1_block(_,_,_,_),_). % (provide_trace_information pref)
1847 unbound_basic_residue(kernel_objects,mark_as_to_be_computed(_),_).
1848 unbound_basic_residue(custom_explicit_sets,block_copy_waitflag_store(_,_,_,_,_),_). % this stems from checking the domain predicate of function application check_element_of_function_closure
1849 %unbound_basic_residue(kernel_objects,ordered_value(V,_),_). % <-- TO DO: treat this and then assign minimal value !
1850 %unbound_basic_residue(kernel_ordering,ordered_value2(V,_),_).
1851 % b_tighter_enumerate_sorted_value_and_continue
1852 %unbound_basic_residue(M,U,Var) :- print(bound_basic_residue(M,U,Var)),nl,fail.
1853
1854 % check if we have an unbound list_skeleton with optionally just ordering constraints
1855 % check if it is safe to assign H minimal value
1856 % TO DO: also accept if all elements have the same co-routines constraints attached (e.g., because of +-> check)
1857 is_unbound_ordered_list_skeleton(H,T) :-
1858 is_unbound_ordered_list_skeleton3(H,T,[allow_ordered_values]).
1859 is_unbound_list_skeleton(H,T) :-
1860 ? is_unbound_ordered_list_skeleton3(H,T,[]).
1861
1862 is_unbound_ordered_list_skeleton(H,T,Ordered) :-
1863 ? is_unbound_ordered_list_skeleton3(H,T,List),
1864 % if List gets instantiated it will become [allow_ordered_values|_]
1865 (var(List) -> Ordered=unordered ; Ordered=ordered).
1866
1867 is_unbound_ordered_list_skeleton3(H,T,Options) :-
1868 free_var(H),
1869 (var(T) -> unbound_variable(H),
1870 ? unbound_ordered_tail(T,Options) % or ? unbound_variable_for_cons(T)
1871 ; T = [H2|T2],
1872 unbound_variable_or_ordered(H,'$$',H2,T,Options),
1873 is_unbound_ordered_list_skeleton5(H,H2,T2,[H|T],Options)).
1874 is_unbound_ordered_list_skeleton5(Prev,H,T,All,Options) :-
1875 free_var(H),
1876 (var(T) -> unbound_variable_or_ordered(H,Prev,'$$',All,Options),
1877 unbound_ordered_tail(T,Options)
1878 ; T==[] -> unbound_variable_or_ordered(H,Prev,'$$',All,Options)
1879 ; T = [H2|T2],
1880 unbound_variable_or_ordered(H,Prev,H2,All,Options),
1881 is_unbound_ordered_list_skeleton5(H,H2,T2,All,Options)).
1882
1883 % utility: if is_unbound_ordered_list_skeleton is true, extract for every element in the list one minimal element from CS
1884 remove_minimal_elements(T,CS,Res) :- var(T),!,Res=CS.
1885 remove_minimal_elements([],CS,Res) :- !, empty_set(CS),Res=[].
1886 remove_minimal_elements([_H|T],CS,[Min|Rest]) :-
1887 remove_minimum_element_custom_set(CS,Min,NewCS), % _H will be unified in one go with Min later
1888 remove_minimal_elements(T,NewCS,Rest).
1889
1890 % it is unbound or can be assigned the minimal value of a set
1891 unbound_variable_or_ordered(Var,Prev,Nxt,All,Options) :-
1892 free_var(Var), frozen(Var,Residue),
1893 unbound_ord_residue_aux(Residue,Prev,Var,Nxt,All,Options).
1894 unbound_ord_residue_aux(true,_Prev,_,_Nxt,_All,_Options).
1895 unbound_ord_residue_aux((A,B),Prev,V,Nxt,All,Options) :- !,
1896 unbound_ord_residue_aux(A,Prev,V,Nxt,All,Options),
1897 unbound_ord_residue_aux(B,Prev,V,Nxt,All,Options).
1898 unbound_ord_residue_aux(Module:Call,Prev,V,Nxt,All,Options) :-
1899 unbound_ord_residue_m(Module,Call,Prev,V,Nxt,All,Options).
1900 unbound_ord_residue_m(Module,Residue,_,Var,_,_,_) :- unbound_basic_residue(Module,Residue,Var),!.
1901 unbound_ord_residue_m(bsets_clp,check_index(V2,_),_,V,_,_,_) :- !,
1902 V2==V. % assumes all index elements in the sequence are being checked; this is the case
1903 unbound_ord_residue_m(kernel_objects,ordered_value(A,B),Prev,V,Nxt,_,Options) :- !,
1904 % there is also a bsets_clp version
1905 ((A,B)==(Prev,V) ; (A,B)==(V,Nxt)),
1906 (member(allow_ordered_values,Options) -> true).
1907 unbound_ord_residue_m(kernel_objects,not_equal_object_wf(A,B,_),_,V,_,All,_) :- !,
1908 % check for all diff constraint; e.g., set up by not_element_of_wf(H,SoFar,WF) in cardinality_as_int2;
1909 % anyway: all elements in a list must be different
1910 (A==V -> exact_member_in_skel(B,All) ; B==V, exact_member_in_skel(A,All)).
1911 unbound_ord_residue_m(kernel_objects,not_element_of_wf1(Set,Val,_),_,V,_,All,_) :- !, Val==V,
1912 open_tail(All,Tail), Tail==Set. % ditto, again just stating that Values are distinct in the list
1913 %unbound_ord_residue_m(A,Prev,V,Nxt,All) :-
1914 % print(unbound_ord_residue_aux(A,Prev,V,Nxt,All)),nl,fail.
1915
1916 % get tail of an open list:
1917 open_tail(X,Res) :- var(X),!,Res=X.
1918 open_tail([_|T],Res) :- open_tail(T,Res).
1919 % exact member in a possibly open list:
1920 exact_member_in_skel(X,List) :- nonvar(List), List=[Y|T],
1921 (X==Y -> true ; exact_member_in_skel(X,T)).
1922
1923
1924 unbound_ordered_tail(T,Options) :- free_var(T), frozen(T,Residue),
1925 ? unbound_ordered_tail_aux(Residue,T,Options).
1926 unbound_ordered_tail_aux(true,_,_).
1927 unbound_ordered_tail_aux(kernel_objects:propagate_card(A,B,_Eq),V,_) :-
1928 (V==A ; V==B). % just specifies A and B have same cardinality
1929 unbound_ordered_tail_aux(prolog:dif(X,Y),V,_) :- (V==X,Y==[] ; V==Y,X==[]).
1930 unbound_ordered_tail_aux(dif(X,Y),V,_) :- (V==X,Y==[] ; V==Y,X==[]).
1931 unbound_ordered_tail_aux(kernel_objects:lazy_ordered_value(W,_),T,Options) :-
1932 W==T, %% difference with just_cardinality_constraints
1933 (member(allow_ordered_values,Options)->true).
1934 unbound_ordered_tail_aux(bsets_clp:propagate_empty_set(_,_),_,_).
1935 unbound_ordered_tail_aux(kernel_objects:prop_non_empty(_,W,_),T,_) :- W==T.
1936 unbound_ordered_tail_aux(kernel_objects:cardinality_as_int2(W,_,_,_,_,_),T,_) :- W==T.
1937 unbound_ordered_tail_aux(kernel_objects:cardinality3(W,_,_),Var,_) :- W==Var.
1938 unbound_ordered_tail_aux((A,B),T,Options) :-
1939 ? (unbound_ordered_tail_aux(A,T,Options) -> true ; unbound_ordered_tail_aux(B,T,Options)).
1940 % TODO: call unbound_basic_residue
1941
1942 % co-routine used to mark certain values as to be computed; avoid instantiating them
1943 :- block mark_as_to_be_computed(-).
1944 mark_as_to_be_computed(_).
1945
1946 is_marked_to_be_computed(X) :- var(X),frozen(X,G), %nl,print(check_frozen(X,G)),nl,
1947 marked_aux(G,X).
1948 marked_aux((A,B),V) :- (marked_aux(A,V) -> true ; marked_aux(B,V)).
1949 marked_aux(kernel_objects:mark_as_to_be_computed(M),V) :- V==M.
1950
1951 :- public unbound_variable_check/1.
1952 % currently not used; but can be useful for debugging
1953 unbound_variable_check(V) :- free_var(V), % check no bool_pred attributes
1954 (frozen(V,Goal), Goal\=true
1955 -> nl,print('### WARNING: goal attached to unbound variable expression'),nl,print(V:Goal),nl, %trace,
1956 fail
1957 ; true).
1958
1959 % check if a variable is unbound or only dif(_,[]) attached; we do not need to check for bool_pred attributes as we have a set
1960 unbound_variable_for_cons(Set) :- var(Set),frozen(Set,F),
1961 \+ contains_problematic_coroutine_for_cons(F,Set). % for equal cons we can allow more co-routines than when we want to freely determine a value in enumeration; the head of the list is unbound
1962
1963 % prolog:dif(X,Y) with Y == [] is ok
1964 contains_problematic_coroutine_for_cons(custom_explicit_sets:element_of_avl_set_wf3(Var,_,_,_,_),V) :- V==Var. % occurs in test 1270
1965 contains_problematic_coroutine_for_cons(kernel_objects:non_free(_),_). % has been marked as non-free
1966 contains_problematic_coroutine_for_cons(kernel_objects:mark_as_to_be_computed(_),_). % has been marked to be computed by closure expansion
1967 % contains_problematic_coroutine_for_cons(bsets_clp:range_wf(_,Var,_),V) :- V==Var. % will be computed by range, range does not propagate well backwards (does it?)
1968 % contains_problematic_coroutine_for_cons(custom_explicit_sets:expand_custom_set_to_list3(_From,Var,_Done,_Source,_WF),V) :- V==Var. % this can propagate backwards
1969 contains_problematic_coroutine_for_cons((A,B),Var) :-
1970 (contains_problematic_coroutine_for_cons(A,Var) -> true
1971 ; contains_problematic_coroutine_for_cons(B,Var)).
1972 %contains_problematic_coroutine_for_cons(M:Call,Var) :-
1973 % functor(Call,F,N), format('~w:~w/~w for ~w~n',[M,F,N,Var]),fail.
1974
1975 unbound_variable_for_card(Set) :- % when do we allow card to instantiate a list skeleton
1976 preference(data_validation_mode,true),
1977 !,
1978 unbound_variable(Set).
1979 unbound_variable_for_card(Set) :- unbound_variable_for_cons(Set).
1980
1981
1982
1983 % handling equal_object for [HR|TR] = [H|T]
1984
1985 equal_cons_cons(HR,TR,H,T,_LWF,WF) :- TR==[],!,
1986 ? empty_set_wf(T,WF), % was T=[], but T could be an empty closure
1987 ? equal_object_wf(HR,H,equal_cons_cons_1,WF).
1988 equal_cons_cons(HR,TR,H,T,_LWF,WF) :- T==[],!,
1989 ? empty_set_wf(TR,WF), % was TR=[], but TR could be an empty closure
1990 equal_object_wf(HR,H,equal_cons_cons_2,WF).
1991 equal_cons_cons(HR,TR,H,T,_LWF,WF) :-
1992 %(is_unbound_list_skeleton(H,T) -> true ; is_unbound_list_skeleton(HR,TR)),
1993 ? (is_unbound_ordered_list_skeleton(H,T,Ordered)
1994 -> (Ordered = unordered -> true
1995 ; is_unbound_ordered_list_skeleton(HR,TR))
1996 ? ; is_unbound_list_skeleton(HR,TR)),
1997 % if both are ordered: then the first elements must be equal,
1998 % if one or both are not ordered: the unification HR=H is only ok if the other is unbound
1999 % beware of tests 1078 and 1101 when allowing ordered lists
2000 !,
2001 % HR is variable: no constraints/co-routines attached to it; no other element in TR is constrained either
2002 %(HR,TR)=(H,T). %fails, e.g., if TR=[] and T= empty closure !
2003 % at the moment : unbound_check does not allow ordered set skeletons
2004 HR=H, equal_object_wf(TR,T,equal_cons_cons3,WF).
2005 equal_cons_cons(HR,TR,H,T,LWF,WF) :-
2006 % here we use LWF for the first time
2007 %(number(LWF) -> LWF2=LWF ; true),
2008 equality_objects_lwf(HR,H,EqRes,LWF2,WF),
2009 ? equal_cons1(EqRes,HR,TR,H,T,LWF,LWF2,WF).
2010
2011 equal_cons1(EqRes,_HR,TR,_H,T,_LWF,_LWF2,WF) :- EqRes == pred_true,!,
2012 ? equal_object_wf(TR,T,equal_cons1,WF).
2013 equal_cons1(EqRes,HR,TR,H,T,_LWF,_LWF2,WF) :- var(EqRes),
2014 (definitely_not_in_list(TR,H)
2015 ; definitely_not_in_list(T,HR) % this can induce a quadratic complexity for large list skeletons
2016 ),
2017 !,
2018 EqRes=pred_true, % H cannot appear in TR; it must match HR
2019 ? equal_object_wf(TR,T,equal_cons1,WF).
2020 equal_cons1(EqRes,HR,TR,H,T,LWF,LWF2,WF) :-
2021 ? instantiate_lwf(LWF,LWF2), % instantiate later to ensure var(EqRes) can hold if LWF already bound
2022 %print(eq_cons_cons_lwf2(HR,H,EqRes,LWF2)),nl,
2023 ? equal_cons2(EqRes,HR,TR,H,T,LWF2,WF),
2024 propagate_card(TR,T,EqRes). % prevents tail recursion; move earlier/remove if EqRes nonvar?
2025 %,instantiate_lwf(LWF,LWF2) % we could instantiate LWF2 later here to give propagate_card a chance to figure out value of EqRes first ? this slows down examples/B/Alstom/CompilatonProject/Regles/Rule_DB_Route_0001ori.his
2026
2027
2028 % this will instantiate LWF if it has not yet been computed
2029 % (Idea: get_cardinality_wait_flag can be expensive; only do it if we really need the wait_flag)
2030 instantiate_lwf(LWF,R) :- var(LWF),!,R=LWF.
2031 instantiate_lwf(lwf_card(Set,Info,WF),LWF) :- !, % TO DO: in prob_data_validation_mode: increase or get_last_waitflag
2032 ? get_cardinality_wait_flag(Set,Info,WF,LWF).
2033 %% get_cardinality_powset_wait_flag(Set,Info,WF,_,LWF).
2034 %instantiate_lwf(lwf_first(X),R) :- !, R=X.
2035 instantiate_lwf(LWF,LWF).
2036
2037 :- block equal_cons2(-,?,?,?,?,?,?).
2038 ?equal_cons2(pred_true,_HR,TR,_H,T,_,WF) :- equal_object_wf(TR,T,equal_cons2,WF).
2039 equal_cons2(pred_false,HR,TR, H,T,LWF,WF) :-
2040 ? equal_cons_lwf(T,HR,TR2,LWF,WF), % look for HR inside T
2041 T2=TR2,
2042 ? equal_cons_lwf(TR,H,T2,LWF,WF). %, was instead of T2=TR2: equal_object(TR2,T2).
2043
2044 :- use_module(kernel_tools,[cannot_match/2]).
2045 % TO DO: investigate whether we should not use kernel_equality or at least a blocking version
2046 definitely_not_in_list(V,_) :- var(V),!,fail.
2047 definitely_not_in_list([],_).
2048 definitely_not_in_list([H|T],X) :- cannot_match(H,X), definitely_not_in_list(T,X).
2049
2050
2051 :- block propagate_card(-,-,-).
2052 propagate_card(X,Y,EqRes) :-
2053 (nonvar(EqRes) -> true % we no longer need to propagate; equal_cons will traverse
2054 ; nonvar(X) -> propagate_card2(X,Y,EqRes)
2055 ; propagate_card2(Y,X,EqRes)).
2056 propagate_card2([],Y,_) :- !,empty_set(Y).
2057 propagate_card2([_|TX],Y,EqRes) :- !,
2058 (var(Y) -> Y= [_|TY], propagate_card(TX,TY,EqRes)
2059 ; Y=[] -> fail
2060 ; Y=[_|TY] -> propagate_card(TX,TY,EqRes)
2061 ; true
2062 ). % TO DO: add more propagation
2063 propagate_card2(_,_,_).
2064
2065 %same_card_and_expand(A,B,ExpA,ExpB) :- .... + reorder ??
2066
2067
2068 % CODE FOR CHECKING FOR TYPE ERRORS AT RUNTIME
2069
2070 % explicitly check for type errors between two terms
2071 % can be useful for some external functions were users provide predicates/values at runtime
2072 % should be called before attempting e.g., equal_object
2073 check_values_have_same_type(TermA,TermB,_Pos) :- (var(TermA) ; var(TermB)),!.
2074 check_values_have_same_type((A1,A2),(B1,B2),Pos) :- !,
2075 check_values_have_same_type(A1,B1,Pos),
2076 check_values_have_same_type(A2,B2,Pos).
2077 % TODO: better checking for fields
2078 check_values_have_same_type(TermA,TermB,Pos) :- type_error(TermA,TermB),!,
2079 add_error(kernel_objects,'Type error, values are incompatible:',(TermA,TermB),Pos).
2080 check_values_have_same_type(_,_,_).
2081
2082 % the following is used by some kernel predicates if(environ(prob_safe_mode,true)).
2083 :- assert_must_succeed(type_error([],int(1))).
2084 :- assert_must_succeed(type_error((int(1),int(2)),[pred_true])).
2085 :- assert_must_succeed(type_error(string('Name'),global_set('Name'))).
2086 :- assert_must_fail((type_error([],[_]))).
2087 type_error(pred_true,Y) :- \+ bool_val(Y).
2088 type_error(pred_false,Y) :- \+ bool_val(Y).
2089 type_error([],Y) :- no_set_type_error(Y).
2090 type_error([_|_],Y) :- no_set_type_error(Y).
2091 %type_error(X,Y) :- is_custom_explicit_set(X,type_error1), no_set_type_error(Y).
2092 type_error(avl_set(A),Y) :- illegal_avl_set(A) -> true ; no_set_type_error(Y).
2093 type_error(global_set(_),Y) :- no_set_type_error(Y).
2094 type_error(freetype(_),Y) :- no_set_type_error(Y).
2095 type_error(closure(P,_,B),Y) :-
2096 (var(P) -> true ; var(B) -> true ; P=[] -> true ; P=[P1|_], var(P1) -> true ; no_set_type_error(Y)).
2097 type_error((_,_),Y) :- Y \= (_,_).
2098 type_error(fd(_,T1),Y) :- (Y= fd(_,T2) -> nonvar(T1),nonvar(T2),T1 \=T2 ; true).
2099 type_error(int(_),Y) :- Y\= int(_).
2100 type_error(term(_),Y) :- Y\= term(_).
2101 type_error(rec(FX),Y) :- (Y = rec(FY) -> type_error_fields(FX,FY,'$') ; true).
2102 type_error(freeval(ID,_,_),Y) :- Y \= freeval(ID,_,_).
2103 type_error(string(_),Y) :- Y \= string(_).
2104 % Should raise type error: kernel_objects:union([int(1)],[[]],R).
2105
2106 bool_val(pred_true).
2107 bool_val(pred_false).
2108
2109 type_error_fields(X,Y,_) :- (var(X);var(Y)),!,fail.
2110 type_error_fields([],[_|_],_).
2111 type_error_fields([_|_],[],_).
2112 type_error_fields([F1|T1],[F2|T2],PrevField) :-
2113 nonvar(F1),nonvar(F2),F1=field(Name1,_),F2=field(Name2,_),
2114 nonvar(Name1),
2115 (Name1 @=< PrevField -> true % not sorted
2116 ; Name1 \= Name2 -> true % other record has different field
2117 ; type_error_fields(T1,T2,Name1)).
2118
2119 :- public illegal_value/1.
2120 illegal_value(X) :- var(X),!,fail.
2121 illegal_value(avl_set(A)) :- illegal_avl_set(A).
2122 illegal_value([H|T]) :- illegal_value(H) -> true ; illegal_value(T).
2123 illegal_value(global_set(G)) :- \+ ground(G).
2124 illegal_value(N) :- number(N).
2125 illegal_value((A,B)) :- illegal_value(A) -> true ; illegal_value(B).
2126 % TO DO: complete this
2127
2128 illegal_avl_set(X) :- var(X),!.
2129 illegal_avl_set(empty).
2130 illegal_avl_set(X) :- (X=node(_,_,_,_,_) -> \+ ground(X) ; true).
2131
2132 no_set_type_error(int(_)).
2133 no_set_type_error(fd(_,_)).
2134 no_set_type_error((_,_)).
2135 no_set_type_error(rec(_)).
2136 no_set_type_error(pred_true /* bool_true */).
2137 no_set_type_error(pred_false /* bool_false */).
2138 no_set_type_error(term(_)).
2139 no_set_type_error(string(_)).
2140 no_set_type_error(freeval(_,_,_)).
2141 no_set_type_error(avl_set(A)) :- illegal_avl_set(A).
2142 %% END OF TYPE CHECKING CODE
2143
2144
2145 :- assert_must_succeed(not_equal_object(term(a),term(b))).
2146 :- assert_must_succeed(not_equal_object(string('a'),string('b'))).
2147 :- assert_must_succeed(not_equal_object(int(1),int(2))).
2148 :- assert_must_succeed(not_equal_object(rec([field(a,int(1))]),rec([field(a,int(2))]))).
2149 :- assert_must_succeed(not_equal_object(rec([field(a,int(1)),field(b,int(2))]),
2150 rec([field(a,int(1)),field(b,int(3))]))).
2151 :- assert_must_fail(not_equal_object(rec([field(a,int(1))]),rec([field(a,int(1))]))).
2152 :- assert_must_fail(not_equal_object(rec([field(a,int(1)),field(b,int(2))]),
2153 rec([field(a,int(1)),field(b,int(2))]))).
2154 :- assert_must_fail(not_equal_object(term(msg),int(2))).
2155 :- assert_must_fail(not_equal_object(fd(1,a),term(msg))).
2156 :- assert_must_succeed(not_equal_object(global_set(a),global_set(b))).
2157 :- assert_must_succeed(not_equal_object([term(a),term(b)],[term(a),term(c)])).
2158 :- assert_must_succeed((not_equal_object([(int(1),[Y])],[(int(X),[Z])]),
2159 Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[int(2)])).
2160 :- assert_must_succeed(not_equal_object((int(1),int(2)),(int(3),int(4)))).
2161 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_equal_object((int(1),int(2)),(int(1),int(4))))).
2162 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_equal_object((int(1),int(4)),(int(3),int(4))))).
2163 :- assert_must_fail(not_equal_object((int(1),int(4)),(int(1),int(4)))).
2164 :- assert_must_succeed(not_equal_object((int(1),string('a')),(int(1),string('b')))).
2165 :- assert_must_fail(not_equal_object((int(1),string('b')),(int(1),string('b')))).
2166 :- assert_must_fail(not_equal_object([(term(a),[])],[(term(a),[])])).
2167 :- assert_must_fail((not_equal_object([(int(1),[Y])],[(int(X),[Z])]),
2168 Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[])).
2169 :- assert_must_fail(not_equal_object([int(1),int(2)],[int(2),int(1)])).
2170 :- assert_must_succeed(not_equal_object(term(msg),term(another_msg))).
2171 :- assert_must_succeed(not_equal_object([int(1),int(2)],[int(0),int(4)])).
2172 :- assert_must_fail((sample_closure(C),
2173 not_equal_object(C,[int(1),int(2)]))).
2174 :- assert_must_succeed((sample_closure(C),
2175 not_equal_object(C,[int(1),int(0)]))).
2176 :- assert_must_succeed((sample_closure(C),
2177 not_equal_object(C,global_set('NAT')))).
2178 :- assert_must_fail((not_equal_object(
2179 [[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')],
2180 [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(3,'Name'),fd(2,'Name')]]
2181 ,[[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')],
2182 [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(2,'Name'),fd(3,'Name')]])
2183 )).
2184 :- assert_must_fail((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,a,int(2))))).
2185 :- assert_must_succeed((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,a,int(3))))).
2186 :- assert_must_succeed((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,b,int(2))))).
2187 :- assert_must_succeed((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,a,int(3))))).
2188
2189 :- assert_must_succeed((not_equal_object(pred_true /* bool_true */,X), X==pred_false /* bool_false */)).
2190 :- assert_must_succeed((not_equal_object([],X),X=[_|_])).
2191 %:- assert_must_succeed((not_equal_object([],X), nonvar(X),X=[_|_])).
2192 :- assert_must_succeed((not_equal_object(X,[]), X=[_|_])).
2193 :- assert_must_succeed((not_equal_object(X,pred_false /* bool_false */), X==pred_true /* bool_true */)).
2194
2195 :- assert_must_succeed(not_equal_object([_X],[int(1),int(3)])). % Inefficiency example of setlog
2196 :- assert_must_succeed_any(not_equal_object([_X],[int(1)])). % Inefficiency example of setlog
2197 :- assert_must_succeed((not_equal_object([X],[pred_true /* bool_true */]),X==pred_false /* bool_false */)).
2198 :- assert_must_succeed((not_equal_object([pred_true /* bool_true */],[X]),X==pred_false /* bool_false */)).
2199 :- assert_must_succeed((not_equal_object([[X]],[[pred_true /* bool_true */]]),X==pred_false /* bool_false */)).
2200 :- assert_must_succeed((not_equal_object([[pred_true /* bool_true */]],[[X]]),X==pred_false /* bool_false */)).
2201 :- assert_must_succeed((custom_explicit_sets:construct_one_element_custom_set(pred_true /* bool_true */, A), kernel_objects:not_equal_object(A,[X]), X==pred_false /* bool_false */)).
2202 :- assert_must_succeed((custom_explicit_sets:construct_one_element_custom_set(pred_true /* bool_true */,A), kernel_objects:not_equal_object([X],A), X==pred_false /* bool_false */)).
2203 :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([],[int(3333)]))).
2204 :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([],[int(2),int(1),int(3)]))).
2205 :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([int(3)],[int(2),int(1),int(3)]))).
2206 :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([int(3),int(1),int(4)],[int(2),int(1),int(3)]))).
2207 :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([int(2),int(1),int(3),int(5)],[int(2),int(1),int(3)]))).
2208 % X in 3..4, kernel_objects:not_equal_object([int(2),int(3)],[int(2),int(X)]), X==4. in clpfd Mode
2209
2210
2211 not_equal_object_wf(X,Y,WF) :-
2212 (var(X)
2213 -> (var(Y)
2214 -> X \== Y,
2215 when((nonvar(X);nonvar(Y);?=(X,Y)), not_equal_object_wf0(X,Y,WF))
2216 ; not_equal_object_wf1(Y,X,WF) % invert arguments
2217 )
2218 ? ; not_equal_object_wf1(X,Y,WF)).
2219
2220 %:- block not_equal_object_wf0(-,-,?).
2221 /* TO DO: implement a better _wf version ; use bool_dif if possible */
2222 % block is relevant for tests 1374, 1737
2223 not_equal_object_wf0(X,Y,WF) :-
2224 %(X==Y -> print(not_eq_pruned(X,Y)),nl,fail ; true),
2225 %X\==Y, % could be expensive if X,Y assigned to large term simultaneously (just woken up by when)
2226 (var(X) -> X\==Y, not_equal_object_wf1(Y,X,WF)
2227 ; not_equal_object_wf1(X,Y,WF)).
2228
2229 not_equal_object_wf1([],R,WF) :- !, not_empty_set_wf(R,WF).
2230 not_equal_object_wf1(R,E,WF) :- E==[],!, not_empty_set_wf(R,WF).
2231 ?not_equal_object_wf1(X,Y,WF) :- not_equal_object2_wf(X,Y,WF).
2232
2233 not_equal_object(X,Y) :-
2234 ? ( nonvar(X) -> not_equal_object2_wf(X,Y,no_wf_available)
2235 ; nonvar(Y) -> not_equal_object2_wf(Y,X,no_wf_available)
2236 ; X\==Y, when((?=(X,Y);nonvar(X);nonvar(Y)), not_equal_object0(X,Y))).
2237
2238 not_equal_object0(X,Y) :- X\==Y,(var(X) -> not_equal_object2_wf(Y,X,no_wf_available)
2239 ; not_equal_object2_wf(X,Y,no_wf_available)).
2240
2241 %not_equal_object2_wf(X,Y,_) :- print(not_equal_object2_wf(X,Y)),nl,fail.
2242 not_equal_object2_wf(pred_true /* bool_true */,R,_) :- !, R=pred_false /* bool_false */.
2243 not_equal_object2_wf(pred_false /* bool_false */,R,_) :- !, R=pred_true /* bool_true */.
2244 not_equal_object2_wf(fd(X,Type),R,_) :- !, get_global_type_value(R,Type,Y), % also sets up FD range for Y if R was var
2245 neq_fd(X,Y,Type).
2246 ?not_equal_object2_wf(int(X),R,_WF) :- !, R=int(Y), integer_dif(X,Y).
2247 not_equal_object2_wf(string(X),R,_) :- !, R=string(Y), dif(X,Y).
2248 not_equal_object2_wf(term(X),R,WF) :- !, R=term(Y), not_equal_term_wf(X,Y,WF).
2249 not_equal_object2_wf(rec(F1),R,WF) :- !, R=rec(F2),
2250 not_equal_fields_wf(F1,F2,WF).
2251 not_equal_object2_wf([],X,WF) :- !, not_empty_set_wf(X,WF).
2252 not_equal_object2_wf((X1,X2),R,WF) :- !, R=(Y1,Y2),
2253 ? not_equal_couple_wf(X1,Y1,X2,Y2,WF).
2254 not_equal_object2_wf(X,Y,WF) :- is_custom_explicit_set(X,not_equal_object2),!,
2255 ? not_equal_explicit_set_wf(X,Y,WF).
2256 ?not_equal_object2_wf(X,Y,WF) :- not_equal_object3(X,Y,WF).
2257
2258 :- block not_equal_term_wf(-,-,?).
2259 not_equal_term_wf(X,Y,_WF) :- % triggered e.g. in test 1225 or 1227 for nil (freetypes)
2260 dif(X,Y).
2261 % TO DO: should we treat floating/1 in a special way?
2262
2263 :- block not_equal_explicit_set_wf(?,-,?).
2264 not_equal_explicit_set_wf(X,Y,WF) :-
2265 is_custom_explicit_set_nonvar(Y),!,
2266 not_equal_explicit_sets_wf(X,Y,WF).
2267 not_equal_explicit_set_wf(X,[],WF) :- !,
2268 is_non_empty_explicit_set_wf(X,WF).
2269 not_equal_explicit_set_wf(CS,[H|T],WF) :-
2270 is_simple_infinite_set(CS), % global_set(.) or open interval
2271 !, % TODO: maybe also detect other infinite sets
2272 test_finite_set_wf(T,Finite,WF),
2273 when(nonvar(Finite),(Finite=pred_true -> true % infinite set cannot be equal finite one
2274 ; not_equal_explicit_set_expand(CS,[H|T],WF))).
2275 not_equal_explicit_set_wf(X,Y,WF) :-
2276 ? not_equal_explicit_set_expand(X,Y,WF).
2277
2278 not_equal_explicit_set_expand(X,Y,WF) :-
2279 expand_custom_set_wf(X,EX,not_equal_explicit_set_wf,WF),
2280 ? not_equal_object3_block(EX,Y,WF).
2281
2282 :- block not_equal_object3_block(-,?,?).
2283 ?not_equal_object3_block(EX,Y,WF) :- not_equal_object3(EX,Y,WF).
2284
2285 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
2286 :- block not_equal_object3(?,-,?).
2287 :- if(environ(prob_safe_mode,true)).
2288 not_equal_object3(X,Y,_) :- nonvar(X),type_error(X,Y),
2289 add_internal_error('Internal Typing Error (please report as bug !) : ',not_equal_object(X,Y)),
2290 fail.
2291 :- endif.
2292 not_equal_object3(X,Y,WF) :- is_custom_explicit_set(Y,not_equal_object2),!,
2293 ? not_equal_explicit_set_wf(Y,X,WF). % TODO: will uselessly check for X being custom_set or []
2294 not_equal_object3(freeval(ID,Case1,Value1),freeval(ID,Case2,Value2),WF) :-
2295 instantiate_freetype_case(ID,Case1,Case2),
2296 when(?=(Case1,Case2), % we first have to be able to decide the case; if cases are different types of values may be different
2297 not_equal_freeval_wf(Case1,Value1,Case2,Value2,WF)).
2298 not_equal_object3([],X,WF) :- not_empty_set_wf(X,WF).
2299 not_equal_object3([H|T],Set2,WF) :-
2300 (Set2==[] -> true % note second argument is nonvar
2301 ; cardinality_peano_wf([H|T],N1,no_wf_available),
2302 cardinality_peano_wf(Set2,N2,no_wf_available), % TODO(?): pending co-routines if Set2 infinite
2303 ? when(?=(N1,N2), % when we trigger code below, = can be decided:
2304 (N1=N2 -> neq_cons_wf(Set2,H,T,WF) ; true))).
2305 % (dif(N1,N2) ; (N1=N2, neq_cons_wf(Set2,H,T,WF)))). %not_equal_object_sets(Set1,Set2) )) ).
2306
2307 not_equal_freeval_wf(Case1,Value1,Case2,Value2,WF) :-
2308 (Case1=Case2 -> not_equal_object_wf(Value1,Value2,WF) ; true).
2309
2310 :- block not_equal_object_sets_wf(-,?,?), not_equal_object_sets_wf(?,-,?).
2311 not_equal_object_sets_wf([H|T],Set2,WF) :- !,
2312 ( Set2=[H2|_T2]
2313 ? -> not_equal_object_sets2(H,T,H2,Set2,WF)
2314 ; Set2=[] -> true
2315 ; not_equal_object2_wf(Set2,[H|T],WF) % avl_set probably
2316 ).
2317 not_equal_object_sets_wf(Set1,Set2,WF) :- % Note : if Set1 =[] then we can fail, as both sets have same length
2318 % we could have empty set or avl_set can sometimes creep into end of lists
2319 not_equal_object2_wf(Set1,Set2,WF).
2320
2321 :- block not_equal_object_sets2(-,?,?,?,?), not_equal_object_sets2(?,?,-,?,?).
2322 not_equal_object_sets2(H,_T,_H2,Set2,WF) :-
2323 % TO DO: should we not use kernel_equality:membership_test_wf here ??
2324 not_element_of_wf(H,Set2,WF).
2325 not_equal_object_sets2(H,T,_H2,Set2,WF) :-
2326 remove_element_wf(H,Set2,Del2,WF), % used to be remove_element(X,Set,Res) :- equal_cons(Set,X,Res).
2327 not_equal_object_wf(T,Del2,WF).
2328
2329
2330 :- block neq_cons_wf(-,?,?,?).
2331 neq_cons_wf([],_,_,_) :- !.
2332 neq_cons_wf([H2|T2],H1,T1,WF) :- !,
2333 (T2==[],T1==[]
2334 -> not_equal_object_wf(H1,H2,WF)
2335 ; check_and_remove([H2|T2],H1,NewSet2,RemoveSuccesful),
2336 ? neq_cons2(RemoveSuccesful,T1,NewSet2,WF)
2337 ).
2338 neq_cons_wf(avl_set(A),H1,T1,WF) :- element_can_be_added_or_removed_to_avl(H1),!,
2339 (remove_element_from_explicit_set(avl_set(A),H1,RA)
2340 -> not_equal_object_wf(T1,RA,WF)
2341 ; true ).
2342 neq_cons_wf(ES,H1,T1,WF) :- is_custom_explicit_set(ES,neq_cons),
2343 expand_custom_set_wf(ES,ExpSet,neq_cons_wf,WF),
2344 neq_cons_wf(ExpSet,H1,T1,WF).
2345
2346 :- block neq_cons2(-,?,?,?).
2347 neq_cons2(not_successful,_T1,_NewSet2,_WF). % one element could not be removed: the sets are different
2348 ?neq_cons2(successful,T1,NewSet2,WF) :- not_equal_object_sets_wf(T1,NewSet2,WF).
2349
2350 % kernel_objects:not_equal_couple(int(1),int(Y),B,pred_true).
2351 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(1),int(Y),B,pred_true,no_wf_available),Y=1, B==pred_false)).
2352 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),B,pred_true,no_wf_available),Y=1, B==pred_false)).
2353 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),B,pred_false,no_wf_available),Y=1, B==pred_true)).
2354 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),pred_false,B,no_wf_available),Y=1, B==pred_true)).
2355 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),B,pred_true,no_wf_available),Y=2, var(B))).
2356 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(B,pred_true,int(Y),int(1),no_wf_available),Y=1, B==pred_false)).
2357 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(B,fd(C,'Code'),fd(Y,'Name'),F,no_wf_available),F=fd(1,'Name'),Y=1,B=fd(1,'Code'),C=2 )).
2358 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(B,pred_true,fd(Y,'Name'),F,no_wf_available),F=fd(1,'Name'),Y=1, B==pred_false)).
2359
2360 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(2500),int(50),_,_,no_wf_available))).
2361 :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(_,_,int(2500),int(50),no_wf_available))).
2362
2363
2364 %was too lax (but works): :- block not_equal_couple_wf(-,?,-,?,?),not_equal_couple_wf(?,-,?,-,?).
2365 % but not sure if this new declaration below is worth it, also since X1==Y1 or X2==Y2 is possible
2366 :- block not_equal_couple_wf(-,?,-,?,?), % X1 or X2 must be known
2367 not_equal_couple_wf(?,-,?,-,?), % Y1 or Y2 must be known
2368 not_equal_couple_wf(?,-,-,?,?), % X2 or Y1 must be known
2369 not_equal_couple_wf(-,?,?,-,?). % X1 or Y2 must be known
2370 % (X1,X2) /= (Y1,Y2)
2371
2372 % using CLPFD results in less propagation it seems
2373 % e.g. post_constraint((A1 #\= A2 #\/ B1 #\= B2), dif((A1,B1),(A2,B2))) will not propagate if A1=A2 or B1=B2
2374 % we could do something like
2375 % post_constraint((N*A1 + B1 #\= N*A2 + B2), dif((A1,B1),(A2,B2))). ; but we need to know good value for N
2376 % TO DO: pass typing information when available ?? or not needed because type info extracted ?
2377
2378 not_equal_couple_wf(X1,Y1,X2,Y2,WF) :- var(X1), var(Y1),!,
2379 (X1==Y1 -> not_equal_object_wf(X2,Y2,WF)
2380 ; not_equal_couple_wf_aux(X2,Y2,X1,Y1,WF)). % change order to test
2381 not_equal_couple_wf(X1,Y1,X2,Y2,WF) :-
2382 ? not_equal_couple_wf_aux(X1,Y1,X2,Y2,WF).
2383
2384 not_equal_couple_wf_aux(X1,Y1,X2,Y2,WF) :-
2385 ? equality_objects_wf(X1,Y1,EqRes1,WF),
2386 (var(EqRes1)
2387 -> equality_objects_wf(X2,Y2,EqRes2,WF),
2388 ? not_equal_couple4(EqRes1,X1,Y1,EqRes2,X2,Y2)
2389 ? ; EqRes1=pred_true -> not_equal_object_wf(X2,Y2,WF)
2390 ; true).
2391
2392 :- block not_equal_couple4(-,?,?,-,?,?).
2393 not_equal_couple4(EqRes1,X1,Y1,EqRes2,X2,Y2) :-
2394 (var(EqRes1)
2395 ? -> not_equal_couple5(EqRes2,X1,Y1,EqRes1)
2396 ; not_equal_couple5(EqRes1,X2,Y2,EqRes2)).
2397
2398 not_equal_couple5(pred_true,_X2,_Y2,EqResOther) :- EqResOther=pred_false.
2399 not_equal_couple5(pred_false,_,_,_).
2400
2401
2402 /* To do: provide special support for things like
2403 couple of fd's [done], list of fd's, set of fd's */
2404
2405 :- use_module(kernel_records,[check_field_name_compatibility/3]).
2406 :- block not_equal_fields_wf(-,-,?).
2407 not_equal_fields_wf([field(ID1,V1)|T1],[field(ID2,V2)|T2],WF) :-
2408 % should we wait for ID1 or ID2 to become nonvar?
2409 check_field_name_compatibility(ID1,ID2,not_equal_fields_wf),
2410 (T1==[]
2411 -> T2=[], not_equal_object_wf(V1,V2,WF)
2412 ; not_equal_couple_wf(V1,V2,rec(T1),rec(T2),WF) % would be slightly more efficient to have a custom version of not_equal_couple
2413 ).
2414
2415
2416 /* ------------------------------------------- */
2417 /* equality_objects/3 function */
2418 /* ------------------------------------------- */
2419
2420 %% :- ensure_loaded(kernel_equality).
2421
2422 % ----------------------------------------------------------
2423 % ----------------------------------------------------------
2424
2425
2426
2427 :- use_module(kernel_equality).
2428
2429 % ----------------------------------------------------------
2430 % ----------------------------------------------------------
2431
2432 /* ---------------> */
2433 /* This should probably be more systematically applied before every kernel call
2434 + expanded for other symbolic representations !! */
2435
2436
2437
2438 /* underlying assumption: if G is a global set: we get back the
2439 global_set tag immediately: no need to use when to wait;
2440 better: ensure that b_compute_expression always returns a nonvar term */
2441
2442 integer_global_set('NAT').
2443 integer_global_set('NATURAL').
2444 integer_global_set('NAT1').
2445 integer_global_set('NATURAL1').
2446 integer_global_set('INT').
2447 integer_global_set('INTEGER').
2448
2449 string_global_set('STRING'). % TODO : check what happens when we have STRING in Event-B as a set
2450 real_global_set('REAL'). % TODO: ditto
2451 real_global_set('FLOAT'). % TODO: ditto
2452
2453
2454 :- assert_must_succeed(( kernel_objects:element_of_global_set(int(0),'NATURAL'))).
2455 :- assert_must_fail(( kernel_objects:element_of_global_set(int(0),'NATURAL1'))).
2456 :- assert_must_fail(( kernel_objects:element_of_global_set(int(-1),'NATURAL'))).
2457 :- assert_must_succeed(( kernel_objects:element_of_global_set(int(-1),'INTEGER'))).
2458 :- assert_must_succeed(( kernel_objects:element_of_global_set(int(0),'NAT'))).
2459 :- assert_must_fail(( kernel_objects:element_of_global_set(int(0),'NAT1'))).
2460 :- assert_must_succeed(( kernel_objects:element_of_global_set(X,'NAT'),X=int(1))).
2461 :- assert_must_succeed(( kernel_objects:element_of_global_set(X,'NATURAL'),X=int(1))).
2462
2463 element_of_global_set(X,GS) :-
2464 ? init_wait_flags(WF),element_of_global_set_wf(X,GS,WF),ground_wait_flags(WF).
2465
2466 element_of_global_set_wf(El,Set,WF) :- element_of_global_set_wf(El,Set,WF,unknown).
2467
2468 :- use_module(kernel_reals,[is_real/1, is_float_wf/2, is_not_float/1]).
2469 :- block element_of_global_set_wf(?,-,?,?).
2470 ?element_of_global_set_wf(El,Set,WF,_) :- b_global_set(Set),!,
2471 global_type_wf(El,Set,WF).
2472 element_of_global_set_wf(X,'STRING',_WF,_) :- !, X=string(_).
2473 element_of_global_set_wf(X,'REAL',_WF,_) :- !, is_real(X).
2474 element_of_global_set_wf(X,'FLOAT',WF,_) :- !, is_float_wf(X,WF).
2475 element_of_global_set_wf(int(X),GS,WF,Span) :-
2476 element_of_global_integer_set_wf(GS,X,WF,Span).
2477
2478 /* what about BOOL ?? */
2479 element_of_global_integer_set_wf('NAT',X,WF,_) :-
2480 preferences:get_preference(maxint,MAXINT),
2481 in_nat_range_wf(int(X),int(0),int(MAXINT),WF).
2482 element_of_global_integer_set_wf('NATURAL',X,WF,Span) :-
2483 (ground(X) -> X>=0
2484 ; is_natural(int(X),WF),
2485 %get_last_wait_flag(element_of_global_set(int(X),'NATURAL'),WF,LWF),
2486 get_integer_enumeration_wait_flag(X,'NATURAL',WF,LWF),
2487 enumerate_natural(X,0,LWF,Span,WF)
2488 ).
2489 element_of_global_integer_set_wf('NAT1',X,WF,_) :-
2490 preferences:get_preference(maxint,MAXINT),
2491 in_nat_range_wf(int(X),int(1),int(MAXINT),WF).
2492 element_of_global_integer_set_wf('NATURAL1',X,WF,Span) :-
2493 (ground(X) -> X>=1
2494 ; is_natural1(int(X),WF),
2495 %get_last_wait_flag(element_of_global_set_wf(int(X),'NATURAL1'),WF,LWF),
2496 get_integer_enumeration_wait_flag(X,'NATURAL1',WF,LWF),
2497 enumerate_natural(X,1,LWF,Span,WF)
2498 ).
2499 element_of_global_integer_set_wf('INT',X,WF,_) :-
2500 preferences:get_preference(minint,MININT),
2501 preferences:get_preference(maxint,MAXINT),
2502 in_nat_range_wf(int(X),int(MININT),int(MAXINT),WF).
2503 element_of_global_integer_set_wf('INTEGER',X,WF,Span) :-
2504 (ground(X) -> true
2505 ; get_integer_enumeration_wait_flag(X,'INTEGER',WF,LWF),
2506 enumerate_int_wf(X,LWF,'INTEGER',WF,Span)
2507 ).
2508
2509
2510 get_integer_enumeration_wait_flag(X,SET,WF,LWF) :-
2511 clpfd_domain(X,FDLow,FDUp), finite_domain(FDLow,FDUp),!,
2512 Size is 1+FDUp-FDLow,
2513 get_wait_flag(Size,element_of_global_set_wf(int(X),SET),WF,LWF).
2514 get_integer_enumeration_wait_flag(X,SET,WF,LWF) :-
2515 get_integer_enumeration_wait_flag(element_of_global_set_wf(int(X),SET),WF,LWF).
2516 % important for e.g., solving r = /*@symbolic*/ {u|#x.(x : NATURAL & u : {x |-> x * x,x |-> x + x})} & 10|->20 : r
2517 % see test 1933, the code was: get_enumeration_starting_wait_flag(element_of_global_set_wf(int(X),SET),WF,LWF), which is a lower number
2518
2519 :- assert_must_succeed((kernel_objects:enumerate_int_wf(X,4,self_check,no_wf_available,unknown),X==2)).
2520 :- block enumerate_int_wf(-,-,?,?,?).
2521 enumerate_int_wf(X,_LWF,Source,WF,Span) :-
2522 (ground(X) -> true
2523 ; add_call_stack_to_span(Span,WF,Span2), % TODO: necessary?
2524 ? enumerate_int_with_span(X,trigger_true(Source),Span2,WF)).
2525
2526 :- assert_must_succeed(not_element_of_global_set(int(-1),'NAT')).
2527 :- assert_must_succeed(not_element_of_global_set(int(-1),'NATURAL')).
2528 :- assert_must_succeed(not_element_of_global_set(int(0),'NAT1')).
2529 :- assert_must_succeed(not_element_of_global_set(int(0),'NATURAL1')).
2530 not_element_of_global_set(_,GS) :- is_maximal_global_set(GS),!, fail. % covers REAL, STRING, INTEGER
2531 not_element_of_global_set(X,'FLOAT') :- !, is_not_float(X).
2532 not_element_of_global_set(int(X),GS) :-
2533 (var(GS) -> add_error(kernel_objects,var_not_element_of_global_set,(int(X),GS)) ; true),
2534 ? not_element_of_global_set2(GS,X).
2535 not_element_of_global_set2('NAT',X) :-
2536 preferences:get_preference(maxint,MAXINT),
2537 ? clpfd_not_in_non_empty_range(X,0,MAXINT). %when(nonvar(X), (X<0 ; X>MAXINT)).
2538 not_element_of_global_set2('NATURAL',X) :- is_not_natural(int(X)).
2539 not_element_of_global_set2('NAT1',X) :-
2540 preferences:get_preference(maxint,MAXINT),
2541 ? clpfd_not_in_non_empty_range(X,1,MAXINT). %when(nonvar(X),(X<1 ; X>MAXINT)).
2542 not_element_of_global_set2('NATURAL1',X) :- is_not_natural1(int(X)).
2543 not_element_of_global_set2('INT',X) :-
2544 preferences:get_preference(minint,MININT),
2545 preferences:get_preference(maxint,MAXINT),
2546 clpfd_not_in_non_empty_range(X,MININT,MAXINT). %when(nonvar(X), (X < MININT ; X > MAXINT)).
2547 %not_element_of_global_set(string(_X),'STRING') :- fail.
2548 %not_element_of_global_set(int(_X),'INTEGER') :- fail.
2549 %not_element_of_global_set(_El,Set) :- b_global_set(Set), fail.
2550
2551
2552
2553 /* ---- */
2554 /* SETS */
2555 /* ---- */
2556
2557 %:- block is_a_set(-).
2558 %is_a_set(X) :- is_a_set2(X).
2559 %is_a_set2([]) :- !.
2560 %is_a_set2([_|_]) :- !.
2561 %is_a_set2(X) :- is_custom_explicit_set(X,is_a_set2).
2562
2563
2564
2565
2566 :- assert_must_succeed(exhaustive_kernel_fail_check(empty_set([int(4),int(3)]))).
2567 :- assert_must_fail((empty_set([int(2),int(1)]))).
2568 :- assert_must_fail((empty_set([int(1)]))).
2569 :- assert_must_fail((empty_set([[]]))).
2570 :- assert_must_fail((empty_set(global_set('Name')))).
2571 :- assert_must_fail((empty_set(X),X=[int(1)])).
2572 :- assert_must_succeed((empty_set([]))).
2573 empty_set(X) :- (var(X) -> X=[]
2574 ; X=[] -> true
2575 % ; X=[_|_] -> fail
2576 ; is_custom_explicit_set_nonvar(X),is_empty_explicit_set(X)).
2577 empty_set_wf(X,WF) :- (var(X) -> X=[]
2578 ; X=[] -> true
2579 % ; X=[_|_] -> fail
2580 ; is_custom_explicit_set_nonvar(X),is_empty_explicit_set_wf(X,WF)).
2581
2582
2583 :- assert_must_succeed(exhaustive_kernel_check(not_empty_set([int(4),int(3)]))).
2584 :- assert_must_succeed((kernel_objects:not_empty_set([int(2),int(1)]))).
2585 :- assert_must_succeed((kernel_objects:not_empty_set([int(1)]))).
2586 :- assert_must_succeed((kernel_objects:not_empty_set([[]]))).
2587 :- assert_must_succeed((kernel_objects:not_empty_set(global_set('Name')))).
2588 :- assert_must_succeed((kernel_objects:not_empty_set_lwf(X,1),nonvar(X),X=[_|_])).
2589 :- assert_must_succeed((kernel_objects:not_empty_set_lwf([int(1)],_))).
2590 :- assert_must_fail((kernel_objects:not_empty_set([]))).
2591
2592 :- use_module(kernel_non_empty_attr,[mark_var_set_as_non_empty/1]).
2593
2594 not_empty_set_wf(S,WF) :- WF==no_wf_available,!, not_empty_set2(S,WF).
2595 not_empty_set_wf(S,WF) :- var(S), !,
2596 (preferences:preference(use_smt_mode,true) -> S=[_|_]
2597 % ; WF=no_wf_available -> not_empty_set(S)
2598 ; get_large_finite_wait_flag(not_empty_set_wf,WF,LWF),
2599 % print(not_empty(S)),nl, % TO DO: set kernel_cardinality attribute if variable
2600 mark_var_set_as_non_empty(S),
2601 not_empty_set_lwf(S,LWF)).
2602 not_empty_set_wf(closure(P,T,B),WF) :- !, is_non_empty_explicit_set_wf(closure(P,T,B),WF).
2603 not_empty_set_wf(S,WF) :- not_empty_set2(S,WF).
2604
2605 :- block not_empty_set_lwf(-,-).
2606 % the instantiation with a list skeleton can easily cause multiple solutions for the same
2607 % set to be found: hence we guard it by a wait flag
2608 not_empty_set_lwf(S,_LWF) :- var(S),!,
2609 S=[_|_].
2610 not_empty_set_lwf(S,_) :- not_empty_set(S).
2611
2612 not_empty_set(Set) :- not_empty_set2(Set,no_wf_available).
2613
2614 :- use_module(error_manager,[add_warning/2]).
2615 :- block not_empty_set2(-,?).
2616 %not_empty_set(S) :- var(S),!,S=[_|_].
2617 % not_empty_set(X) :- not_equal_object([],X).
2618 not_empty_set2([_|_],_).
2619 not_empty_set2(avl_set(A),_) :- (A==empty -> add_warning(not_empty_set,'Empty avl_set'),fail ; true).
2620 not_empty_set2(closure(P,T,B),WF) :- is_non_empty_explicit_set_wf(closure(P,T,B),WF). % TO DO: also use WF
2621 not_empty_set2(global_set(Type),_) :- b_non_empty_global_set(Type).
2622 not_empty_set2(freetype(ID),_) :- kernel_freetypes:is_non_empty_freetype(ID).
2623
2624 % there also exists: eq_empty_set , a reified version, i.e., test_empty_set
2625
2626
2627 :- assert_must_succeed((exact_element_of(int(1),[int(2),int(1)]))).
2628 :- assert_must_succeed((exact_element_of(int(1),[int(2),int(3),int(4),int(1)]))).
2629 :- assert_must_succeed((exact_element_of(int(4),[int(2),int(3),int(4),int(1)]))).
2630 :- assert_must_succeed((exact_element_of(int(1),[int(2),int(3)|T]), T=[int(4),int(1)])).
2631 :- assert_must_fail((exact_element_of(int(5),[int(2),int(3)|T]), T=[int(4),int(1)])).
2632 :- assert_must_succeed((exact_element_of(fd(1,'Name'),global_set('Name')))).
2633 :- assert_must_succeed((exact_element_of([int(2),int(1)],[[],[int(2),int(1)]]))).
2634 :- assert_must_fail((exact_element_of([int(1),int(2)],[[],[int(2),int(1)]]))).
2635 %:- assert_must_succeed((exact_element_of([(int(1),fd(2,'Name'))],
2636 % closure([zzzz],[set(couple(integer,global('Name')))], 'In'('ListExpression'(['Identifier'(zzzz)]),
2637 % 'Seq'(value([fd(1,'Name'),fd(2,'Name')]))))) )).
2638 %:- assert_must_succeed((exact_element_of(XX,
2639 % closure([zzzz],[set(couple(integer,global('Name')))], 'In'('ListExpression'(['Identifier'(zzzz)]),
2640 % 'Seq'(value([fd(1,'Name'),fd(2,'Name')]))))),
2641 % equal_object(XX,[(int(1),fd(1,'Name'))]) )).
2642 %:- assert_must_succeed((
2643 %exact_element_of(XX,closure([zzzz],[set(couple(integer,global('Name')))],
2644 % 'In'('ListExpression'(['Identifier'(zzzz)]),
2645 % 'Perm'(value([fd(1,'Name'),fd(2,'Name')]))))),
2646 % equal_object(XX,[(int(1),fd(2,'Name')),(int(2),fd(1,'Name'))]) )).
2647
2648 %:- assert_must_succeed(( exact_element_of(X,
2649 % closure([zzzz],[set(record([field(balance,integer),field(name,global('Code'))]))],
2650 % 'In'('ListExpression'(['Identifier'(zzzz)]),
2651 % 'PowerSet'(value(closure([zzzz],
2652 % [record([field(balance,integer),field(name,global('Code'))])],'In'('ListExpression'(['Identifier'(zzzz)]),
2653 % 'SetOfRecords'(value(cons_expr(field(balance,global_set('NAT')),
2654 % cons_expr(field(name,global_set('Code')),nil_expr))))))))))),
2655 % X=[rec([field(balance,int(0)),field(name,fd(2,'Code'))])] )).
2656 %:- assert_must_fail(( exact_element_of(X,
2657 % closure([zzzz],[set(record([field(balance,integer),field(name,global('Code'))]))],
2658 % 'In'('ListExpression'(['Identifier'(zzzz)]),
2659 % 'PowerSet'(value(closure([zzzz],
2660 % [record([field(balance,integer),field(name,global('Code'))])],'In'('ListExpression'(['Identifier'(zzzz)]),
2661 % 'SetOfRecords'(value(cons_expr(field(balance,global_set('NAT')),
2662 % cons_expr(field(name,global_set('Code')),nil_expr))))))))))),
2663 % X=[rec([field(balance,int(-1)),field(name,fd(2,'Code'))])] )).
2664
2665
2666 /* use this to compute elements */
2667 exact_element_of(X,Set) :-
2668 dif(Set,[]),
2669 ? exact_element_of2(Set,X).
2670 :- block exact_element_of2(-,?).
2671 exact_element_of2([H|_],H).
2672 ?exact_element_of2([_|T],E) :- exact_element_of3(T,E).
2673 exact_element_of2(X,E) :- is_custom_explicit_set_nonvar(X), check_element_of(E,X).
2674 :- block exact_element_of3(-,?).
2675 exact_element_of3([H|_],H).
2676 ?exact_element_of3([_|T],E) :- exact_element_of3(T,E).
2677
2678
2679 :- assert_must_succeed(exhaustive_kernel_check(check_element_of(int(1),[int(2),int(1)]))).
2680 :- assert_must_succeed(exhaustive_kernel_fail_check(check_element_of(int(3),[int(2),int(1)]))).
2681 :- assert_must_succeed(exhaustive_kernel_fail_check(check_element_of(int(1),[]))).
2682
2683 /* uses equal_object instead of unification */
2684 :- assert_must_succeed((check_element_of(X,
2685 [(int(1),(int(1),(int(1),int(1)))),(int(2),(int(1),(int(1),int(1)))),
2686 (int(1),(int(1),(int(1),int(2)))),(int(2),(int(1),(int(1),int(2))))]),
2687 equal_object(X, (int(2),(int(1),(int(1),int(2))))) )).
2688 :- assert_must_succeed((check_element_of(X,
2689 [ (((int(1),int(1)),int(1)),int(1)), (((int(1),int(1)),int(1)),int(2)),
2690 (((int(1),int(1)),int(1)),int(3)), (((int(1),int(1)),int(1)),int(4)),
2691 (((int(1),int(1)),int(2)),int(1)), (((int(1),int(1)),int(2)),int(2))
2692 ]), equal_object(X, (((int(1),int(1)),int(2)),int(1)))
2693 )).
2694 :- assert_must_succeed((check_element_of(fd(1,'Name'),global_set('Name')))).
2695 %:- assert_must_succeed_multiple(check_element_of(X,[[fd(1,'Name')],[]])).
2696 :- assert_must_succeed((check_element_of((int(1),int(2)),[(int(1),int(2))]))).
2697 :- assert_must_succeed((check_element_of((_X,_Y),[(fd(2,'Code'),fd(2,'Code'))]))).
2698 :- assert_must_succeed((init_wait_flags(WF),
2699 check_element_of_wf((X,Y),[(fd(2,'Code'),fd(2,'Code'))],WF),
2700 ground_det_wait_flag(WF), X= fd(2,'Code'), Y= fd(2,'Code'),
2701 kernel_waitflags:ground_wait_flags(WF) )).
2702 :- assert_must_succeed((init_wait_flags(WF),
2703 check_element_of_wf((Y,X),[(fd(2,'Code'),fd(2,'Code'))],WF),
2704 ground_det_wait_flag(WF), X= fd(2,'Code'), Y= fd(2,'Code'),
2705 kernel_waitflags:ground_wait_flags(WF) )).
2706 :- assert_must_succeed((check_element_of([int(1),int(2)],[[int(2),int(1)]]))).
2707
2708 :- assert_must_succeed((check_element_of([int(1),int(2)],[[],[int(2),int(1)]]))).
2709 :- assert_must_succeed((check_element_of(X,[[],[int(2),int(1)]]), X==[] )).
2710 :- assert_must_succeed((check_element_of_wf(X,[[],[int(2),int(1)]],_WF),
2711 equal_object(X,[int(1),int(2)]) )).
2712 :- assert_must_succeed((check_element_of_wf(XX,global_set('Name'),WF),kernel_waitflags:ground_wait_flags(WF), XX==fd(3,'Name') )).
2713 :- assert_must_fail(check_element_of([fd(2,'Name')],[[fd(1,'Name')],[]])).
2714 :- assert_must_fail((check_element_of([int(2)],[[],[int(2),int(1)]]))).
2715 :- assert_must_succeed((check_element_of(int(1),_X))).
2716 :- assert_must_succeed((check_element_of((int(2),_X),[(int(1),[(int(1),int(22))]),(int(2),[(int(1),int(55))])]))).
2717
2718 check_element_of(X,Set) :- init_wait_flags(WF,[check_element_of]),
2719 ? check_element_of_wf(X,Set,WF),
2720 ? ground_wait_flags(WF).
2721
2722 % new test: check_element_of(int(1),X).
2723 % new test: check_element_of(int(1),[int(2)|X]).
2724
2725 check_element_of_wf(X,Set,WF) :- %print(el_of(X,Set)),nl,
2726 dif(Set,[]),
2727 % TO do: mark Set as non-empty not_empty_set_wf from kernel_cardinality_attr
2728 ? check_element_of1(X,Set,WF).
2729
2730 %check_element_of1(X,Set,WF) :- var(X),var(Set),unbound_variable_check(Set),!,
2731 % Set=[_|_], check_element_of2(Set,X,WF).
2732 %:- block check_element_of1(-,-,?). %%
2733
2734
2735 %:- block check_element_of1(-,-,?). % leads to time-out in test 292 for {x,S,S2|x : S & S <: (1 .. 213) & S \/ {x} = S2 & x /: S2} and test 1976 in data_validation mode and CLPFD false
2736 check_element_of1(X,Set,WF) :-
2737 (unbound_variable_for_element_of(Set),
2738 preference(data_validation_mode,false) % TODO: this leads to failure of test 1976 with CLPFD FALSE
2739 % but avoids instantiating Sets to lists early on: can disturb enumeration and efficient computation/unification of large sets
2740 ? -> check_element_of_unbound_set(X,Set,WF)
2741 ? ; check_element_of2(Set,X,WF)
2742 ).
2743
2744 check_element_of_unbound_set(X,Set,_WF) :-
2745 mark_as_non_free(X,check_element_of_unbound_set),
2746 Set=[X|_]. % Note: X needs to be nonvar so that other code knows X is not free anymore
2747 % TO DO: normalise X ?
2748 % TO DO: do this using CHR/attributes rather than by instantiation
2749
2750
2751 unbound_variable_for_element_of(Set) :- unbound_variable_for_cons(Set).
2752
2753 % attach co-routine to mark a given term as not a real variable
2754 mark_as_non_free(X,_Info) :- var(X) -> non_free(X) ; true.
2755 mark_as_non_free(X) :- var(X) -> non_free(X) ; true.
2756 :- block non_free(-).
2757 non_free([H|T]) :- !, mark_as_non_free(H), mark_as_non_free(T).
2758 non_free((A,B)) :- !, mark_as_non_free(A), mark_as_non_free(B).
2759 non_free(rec(Fields)) :- !, mark_as_non_free_fields(Fields).
2760 non_free(_).
2761 :- block mark_as_non_free_fields(-).
2762 mark_as_non_free_fields([]).
2763 mark_as_non_free_fields([field(_,Val)|T]) :- mark_as_non_free(Val),mark_as_non_free_fields(T).
2764
2765 :- use_module(clpfd_lists,[lazy_fd_value_check/4]).
2766
2767 :- block check_element_of2(-,?,?).
2768 check_element_of2(CS,El,WF) :-
2769 ? is_custom_explicit_set_nonvar(CS),!, element_of_custom_set_wf(El,CS,WF).
2770 check_element_of2([],_,_) :- !,fail.
2771 %check_element_of2([H|T],El,WF) :- try_expand_and_convert_to_avl([H|T],AVL),AVL=avl_set(_),!, % much better support exists for AVL trees; should we enable this conversion ?? %nl,print(converted_list_to_AVL([H|T])),nl,nl,
2772 % element_of_custom_set_wf(El,AVL,WF).
2773 check_element_of2([H|T],E,WF) :- !, % print(check_element_of4w(E,H,T,WF)),nl,
2774 % try and transform E : Set into clpfd:element(_,FDVals,EFD) check:
2775 ? lazy_fd_value_check([H|T],E,WF,FullyChecked),
2776 %get_partial_set_priority([H|T],WF,LWF), %%
2777 %get_wait_flag(2,check_element_of2([H|T],E),WF,LWF), %%
2778 (FullyChecked==true,ground(E) -> true % no need to check
2779 ; get_cardinality_wait_flag([H|T],check_element_of2,WF,LWF),
2780 ? check_element_of4w(E,H,T,WF,LWF) % this call is somewhat redundant if FullyChecked=true; but otherwise in_fd_value_list will not enumerate on its own (e.g., self-checks for relation_over will fail)
2781 ).
2782 check_element_of2(freetype(Id),E,WF) :- !, is_a_freetype_wf(E,Id,WF).
2783 check_element_of2(term(Z),_E,_WF) :- Z==undefined,!,
2784 add_error_fail(check_element_of2,'Encountered uninitialised set variable', '').
2785 check_element_of2(Set,E,WF) :-
2786 add_internal_error('Illegal argument: ',check_element_of2(Set,E,WF)),fail.
2787
2788
2789 % call if you already have an explicit waitflag (LWF) setup for the cardinality of the set
2790 :- block check_element_of_wf_lwf(?,-,?,?).
2791 check_element_of_wf_lwf(El,CS,WF,_LWF) :-
2792 ? is_custom_explicit_set_nonvar(CS),!, element_of_custom_set_wf(El,CS,WF).
2793 ?check_element_of_wf_lwf(E,[H|T],WF,LWF) :- check_element_of4w(E,H,T,WF,LWF).
2794 check_element_of_wf_lwf(E,freetype(Id),WF,_) :- !, is_a_freetype_wf(E,Id,WF).
2795
2796 :- block check_element_of4w(-,?,-,?,-).
2797 % check_element_of4w(E,H,T,_WF,_LWF) :- print(check_element_of4w(E,H,T,_WF,_LWF)),nl,fail.
2798 ?check_element_of4w(E,H,T,_WF,_LWF) :- T==[],!,equal_object(E,H,check_element_of4w).
2799 check_element_of4w(E,H,_T,_WF,_LWF) :- E==H ,!. %,print(eq(E,H)),nl. % added by mal, 17.10 2007
2800 check_element_of4w(E,H,T,WF,LWF) :- T\==[],
2801 ? equality_objects_lwf(E,H,Res,LWF,WF),
2802 ? check_element_of4(Res,E,T,WF,LWF).
2803
2804 :- block check_element_of4(-,?,?,?,-).
2805 check_element_of4(pred_true,_E,_,_WF,_LWF).
2806 check_element_of4(pred_false,E,T,WF,LWF) :-
2807 ? (var(T) -> T = [E|_] ; check_element_of5(E,T,WF,LWF)).
2808
2809 :- block check_element_of5(?,-,?,?).
2810 check_element_of5(E,R,WF,LWF) :-
2811 get_next_element(R,H,T),
2812 ? check_element_of4w(E,H,T,WF,LWF).
2813
2814
2815
2816 :- assert_must_succeed(exhaustive_kernel_check(not_element_of(int(3),[int(2),int(1)]))).
2817 :- assert_must_succeed(exhaustive_kernel_check(not_element_of(int(3),[int(2),int(1),int(4)]))).
2818 :- assert_must_succeed(exhaustive_kernel_fail_check(not_element_of(int(1),[int(2),int(1)]))).
2819 :- assert_must_succeed((kernel_objects:not_element_of(int(3),[int(2),int(1)]))).
2820 :- assert_must_succeed((kernel_objects:not_element_of(fd(1,'Name'),[]))).
2821 :- assert_must_fail((kernel_objects:not_element_of(fd(1,'Name'),global_set('Name')))).
2822 :- assert_must_succeed((kernel_objects:not_element_of(X,[fd(1,'Name')]),X = fd(2,'Name'))).
2823 :- assert_must_fail((kernel_objects:not_element_of(X,[fd(1,'Name')]),X = fd(1,'Name'))).
2824 :- assert_must_succeed(kernel_objects:not_element_of(term(a),[])).
2825 :- assert_must_fail((kernel_objects:not_element_of(int(1),[int(2),int(1)]))).
2826 :- assert_must_succeed((kernel_objects:not_element_of([int(1),int(2)],
2827 [[int(1)],[int(0),int(4)],[int(0),int(3)],[int(0),int(1)],[int(0)],[]]))).
2828 :- assert_must_fail((kernel_objects:not_element_of(term(3),[int(2),int(1)]))).
2829
2830
2831 not_element_of(X,Set) :- init_wait_flags(WF,[not_element_of]),
2832 ? not_element_of_wf(X,Set,WF),
2833 ? ground_wait_flags(WF).
2834
2835 :- use_module(b_global_sets,[b_get_fd_type_bounds/3]).
2836 :- block not_element_of_wf(-,-,?).
2837 not_element_of_wf(_,Set,_) :- Set==[],!.
2838 not_element_of_wf(El,Set,WF) :- nonvar(El),El=fd(X,GS),b_get_fd_type_bounds(GS,N,N),!,
2839 % we have a global set with a single element; Set must be empty
2840 X=N,empty_set_wf(Set,WF).
2841 ?not_element_of_wf(El,Set,WF) :- not_element_of_wf1(Set,El,WF).
2842
2843 :- block not_element_of_wf1(-,?,?).
2844 not_element_of_wf1(X,E,WF) :- is_custom_explicit_set_nonvar(X),!,
2845 not_element_of_custom_set_wf(E,X,WF).
2846 not_element_of_wf1([],_E,_WF).
2847 not_element_of_wf1([H|T],E,WF) :-
2848 ? not_equal_object_wf(E,H,WF),
2849 ? not_element_of_wf1(T,E,WF).
2850
2851
2852 :- assert_must_succeed(exhaustive_kernel_check(add_element(int(3),[int(2),int(1)],[int(1),int(3),int(2)]))).
2853 :- assert_must_succeed(exhaustive_kernel_fail_check(add_element(int(2),[int(2),int(1)],[int(1),int(3),int(2)]))).
2854 :- assert_must_succeed(exhaustive_kernel_fail_check(add_element(int(4),[int(2),int(1)],[int(1),int(3),int(2)]))).
2855 :- assert_must_succeed((kernel_objects:add_element(int(3),[int(2),int(1)],R),
2856 kernel_objects:equal_object(R,[int(1),int(2),int(3)]))).
2857 :- assert_must_succeed((kernel_objects:add_element([int(2)],[[int(2),int(1)],[]],R),
2858 kernel_objects:equal_object(R,[[],[int(1),int(2)],[int(2)]]))).
2859 :- assert_must_succeed((kernel_objects:add_element([int(1),int(2)],[[int(2),int(1)],[]],R),
2860 kernel_objects:equal_object(R,[[],[int(1),int(2)]]))).
2861 :- assert_must_succeed((kernel_objects:add_element(X,[int(2),int(1)],R),
2862 kernel_objects:equal_object(R,[int(1),int(2)]), X = int(1))).
2863 :- assert_must_succeed((kernel_objects:add_element([int(1),int(2)],
2864 [[int(1)],[int(0),int(4)],[int(0),int(3)],[int(0),int(1)],[int(0)],[]], _R))).
2865
2866 :- assert_must_succeed((kernel_objects:add_element(int(3),[int(X),int(1)],R,D),
2867 var(D), X=3, R==[int(3),int(1)], D==done)).
2868
2869 :- assert_must_fail((kernel_objects:add_element(term(msg),[int(2),int(1)],_R))).
2870 :- assert_must_succeed((kernel_objects:add_element(int(3),[int(2),int(X)],R),
2871 nonvar(R), R =[H|T], H==int(2), nonvar(T),T=[_HH|TT],var(TT),
2872 X=4, T==[int(4),int(3)])).
2873 :- assert_must_succeed((kernel_objects:add_element(int(3),[int(2),int(X)],R),
2874 nonvar(R), R =[H|T], H==int(2), nonvar(T),T=[_HH|TT],var(TT),
2875 X=3, T==[int(3)])).
2876 :- assert_must_succeed((kernel_objects:add_element(int(3),X,[int(2),int(3)]),
2877 kernel_objects:equal_object(X,[int(2)]) )).
2878 :- assert_must_succeed((kernel_objects:add_element(int(3),X,[int(3)]),
2879 kernel_objects:equal_object(X,[]) )).
2880 :- assert_must_succeed((add_element(X,[int(1)],[int(1)]),X==int(1))).
2881 :- assert_must_succeed((add_element(X,[],[int(1)]),X==int(1))).
2882 % kernel_objects:add_element(E,[H],R,Done), H = int(X), E=int(Y), X in 1..10, Y in 11..20.
2883
2884
2885 ?add_element(E,Set,NewSet) :- add_element(E,Set,NewSet,_).
2886 ?add_element(Element,Set,NewSet,Done) :- add_element_wf(Element,Set,NewSet,Done,no_wf_available).
2887 add_element_wf(E,Set,NewSet,WF) :- add_element_wf(E,Set,NewSet,_,WF).
2888
2889 :- block add_element_wf(?,-,?,?,?).
2890 add_element_wf(Element,Set,NewSet,Done,_WF) :- Set==[],!,
2891 % try and convert to AVL if possible:
2892 ? equal_object_optimized(NewSet,[Element]), % we could call equal_object_opt3 directly
2893 Done=done.
2894 ?add_element_wf(E,Set,NewSet,Done,WF) :- add_element1_wf(E,Set,NewSet,Done,WF).
2895
2896 :- block %add_element1(-,?,-,?),
2897 add_element1_wf(?,-,?,?,?).
2898 add_element1_wf(E,Set,NewSet,Done,WF) :- var(E),!, add_element_var(Set,NewSet,E,Done,WF).
2899 add_element1_wf(E,[H|T],NewSet,Done,WF) :- E==H,!,
2900 % avoid running [H|T] through expand_custom_set_to_list, in case T is a variable this will create a pending co-routine
2901 equal_object_wf(NewSet,[H|T],add_element1_1,WF),Done=done.
2902 add_element1_wf(E,Set,NewSet,Done,WF) :-
2903 nonvar(Set), is_custom_explicit_set_nonvar(Set),
2904 add_element_to_explicit_set_wf(Set,E,R,WF),!,
2905 ? equal_object_wf(R,NewSet,add_element1_2,WF),Done=done.
2906 add_element1_wf(E,Set,NewSet,Done,WF) :-
2907 expand_custom_set_to_list_wf(Set,ESet,_,add_element1,WF),
2908 % we could avoid this expansion by treating avl_set,... below in add_element3
2909 ? add_element2_wf(ESet,E,NewSet,Done,WF).
2910
2911
2912 add_element_var([],Res,Element,Done,WF) :- !,
2913 equal_cons_wf(Res,Element,[],WF),Done=done.
2914 add_element_var(Set,Res,Element,Done,WF) :- Set \= [], Set \= closure(_,_,_),
2915 is_one_element_set(Res,ResEl), !,
2916 % the result is a one element set; hence Element *must* be the element in that set
2917 equal_object_wf(Element,ResEl,add_element_var_1,WF),
2918 equal_object_wf(Set,Res,add_element_var_2,WF), Done=done.
2919 add_element_var(Set,Res,Element,Done,WF) :- %when(nonvar(Element), add_element(Element,Set,Res,Done)).
2920 expand_custom_set_to_list_wf(Set,ESet,_,add_element_var,WF),
2921 add_element2_wf(ESet,Element,Res,Done,WF).
2922
2923 is_one_element_set(S,_) :- var(S),!,fail.
2924 is_one_element_set([H|T],H) :- T==[].
2925 is_one_element_set(avl_set(S),El) :- is_one_element_custom_set(avl_set(S),El).
2926
2927 :- block add_element2_wf(-,?,?,?,?).
2928 add_element2_wf([],E,Res,Done,WF) :- var(Res),should_be_converted_to_avl(E),
2929 construct_avl_from_lists_wf([E],R,WF),!,
2930 (R,Done)=(Res,done).
2931 ?add_element2_wf(S,E,Res,Done,WF) :- copy_list_skeleton(S,Res,WF),
2932 ? add_element3_wf(S,E,Res,Done,WF).
2933
2934 % TO DO: use something else, like subset to propagate info that Set1 <: Set1 \/ {New}
2935 :- block copy_list_skeleton(-,?,?).
2936 copy_list_skeleton([],_,_WF) :- !.
2937 copy_list_skeleton([H|T],R,WF) :- !, % H must be in R, but not all elements of R are in [H|T] !; it could be the added element
2938 ((ground_value(H) ; unbound_variable_for_cons(R) ;
2939 custom_explicit_sets:singleton_set(R,_) % if R is a singleton set {EL} then H must be EL and T=[]
2940 )
2941 ? -> equal_cons_wf(R,H,RR,WF),
2942 copy_list_skeleton(T,RR,WF)
2943 ; %nl,print(not_copying([H|T],R)),nl,
2944 true % otherwise equal_cons_wf can backpropagate elements from R into H !! see {x,y| x = {1,2} & x \/ y = {1,2,3} & 1:y } test 1535
2945 ).
2946 copy_list_skeleton(Set,R,WF) :- !,is_custom_explicit_set(Set,copy_list_skeleton),
2947 expand_custom_set_to_list_wf(Set,ESet,_,copy_list_skeleton,WF), copy_list_skeleton(ESet,R,WF).
2948 copy_list_skeleton(Skel,R,WF) :- add_internal_error('Argument not a set: ',copy_list_skeleton(Skel,R,WF)).
2949
2950 :- block add_element3_wf(-,?,?,?,?).
2951 add_element3_wf([],E,Res,Done,WF) :- % Res must be {E}
2952 equal_cons_wf(Res,E,[],WF),
2953 Done=done.
2954 add_element3_wf([H|T],E,Res,Done,WF) :-
2955 equality_objects_wf(H,E,EqRes,WF),
2956 ? equal_cons_wf(Res,H,TailRes,WF), % was: equal_object([H|TailRes],Res), % use WF?
2957 (var(EqRes)
2958 -> has_not_to_be_added([H|T],Res,EqRes,0)
2959 ; true),
2960 %(when(nonvar(EqRes),(print(nv(EqRes,H,T,WF)),nl))),
2961 ? add_element4_wf(EqRes,T,E,TailRes,Done,WF).
2962
2963
2964 % check if an element has not to be added to arg1 to obtain arg2
2965 :- block has_not_to_be_added(?,-,?,?),has_not_to_be_added(-,?,?,?).
2966 %has_not_to_be_added(A,B,R,Sz) :- print(has_not_to_be_added(A,B,R,Sz)),nl,fail.
2967 has_not_to_be_added([],[],R,Sz) :- !,(Sz=1 -> R=pred_true % we have 1 element: force equality with first element
2968 ; true).
2969 has_not_to_be_added([],[_H|T],R,_Sz) :- !, %(var(R) -> print(add_f([],[_H|T],R,_Sz)),nl ; true),
2970 empty_set(T),R=pred_false. % R=pred_false means with add an element
2971 has_not_to_be_added([_|_],[],_,_) :- !,fail. % we can either add or not; in both cases we do not obtain []
2972 has_not_to_be_added([_|T1],[_|T2],R,Sz) :- !, S1 is Sz+1, has_not_to_be_added(T1,T2,R,S1).
2973 has_not_to_be_added(_,_,_,_). % to do: support custom explicit sets
2974
2975 :- block add_element4_wf(-,?,?,?,?,?).
2976 add_element4_wf(pred_true, T,_E,TRes,Done,WF) :- equal_object_wf(T,TRes,add_element4_wf,WF), Done=done.
2977 ?add_element4_wf(pred_false,T, E,TRes,Done,WF) :- add_element3_wf(T,E,TRes,Done,WF).
2978
2979
2980 :- assert_must_succeed((kernel_objects:add_new_element(int(3),[int(2),int(1)],R),
2981 kernel_objects:equal_object(R,[int(1),int(2),int(3)]))).
2982 :- assert_must_succeed((kernel_objects:add_new_element([int(2)],[[int(2),int(1)],[]],R),
2983 kernel_objects:equal_object(R,[[],[int(1),int(2)],[int(2)]]))).
2984
2985 % TO DO : get rid of need for non-WF version in enumeration basic type:
2986 add_new_element(E,Set,NewSet) :- init_wait_flags(WF),
2987 add_new_element_wf(E,Set,NewSet,WF), ground_wait_flags(WF).
2988
2989 % use when you are sure the element to add is not in the set
2990 % to be used for adding elements to an accumulator
2991 :- block add_new_element_wf(?,-,?,?).
2992 %%add_new_element(E,Set,NewSet) :- add_element(E,Set,NewSet). % TO DO : Improve
2993 add_new_element_wf(E,Set,NewSet,WF) :-
2994 is_custom_explicit_set(Set,add_element),
2995 add_element_to_explicit_set_wf(Set,E,R,WF),!,
2996 equal_object_wf(R,NewSet,add_new_element_wf,WF).
2997 add_new_element_wf(E,Set,NewSet,WF) :-
2998 expand_custom_set_to_list_wf(Set,ESet,_,add_new_element_wf,WF),
2999 add_new_element2(ESet,E,NewSet,WF).
3000
3001 :- block add_new_element2(-,?,?,?).
3002 add_new_element2([],E,Res,WF) :- var(Res),should_be_converted_to_avl(E),
3003 construct_avl_from_lists_wf([E],R,WF),!,equal_object_wf(R,Res,add_new_element2,WF).
3004 add_new_element2(S,E,Res,WF) :- equal_cons_wf(Res,E,S,WF).
3005
3006
3007
3008
3009 :- assert_must_succeed(exhaustive_kernel_check(remove_element_wf(int(3),[int(3),int(1)],
3010 [int(1)],_WF))).
3011 :- assert_must_succeed(exhaustive_kernel_check(remove_element_wf(int(1),[int(3),int(1)],
3012 [int(3)],_WF))).
3013 :- assert_must_succeed(exhaustive_kernel_fail_check(remove_element_wf(int(1),[int(3),int(1)],
3014 [int(1)],_WF))).
3015 :- assert_must_succeed(exhaustive_kernel_fail_check(remove_element_wf(int(11),[int(1)],
3016 [int(1)],_WF))).
3017 :- assert_must_succeed(exhaustive_kernel_fail_check(remove_element_wf(int(1),[int(3),int(1)],
3018 [],_WF))).
3019 :- assert_must_succeed((kernel_objects:remove_element_wf(fd(1,'Name'),X,[fd(2,'Name'),fd(3,'Name')],_WF),
3020 kernel_objects:equal_object(X,global_set('Name')))).
3021 :- assert_must_succeed((kernel_objects:remove_element_wf(int(1),X,[int(2)],_WF),
3022 kernel_objects:equal_object(X,[int(2),int(1)]))).
3023 :- assert_must_succeed(( kernel_objects:remove_element_wf(int(1),[int(X),int(2)],R,WF), kernel_waitflags:ground_wait_flags(WF),X==1,R==[int(2)] )).
3024 :- assert_must_succeed(( kernel_objects:remove_element_wf(X,[int(1),int(2)],R,WF), kernel_waitflags:ground_wait_flags(WF),X==int(2),R==[int(1)] )).
3025 :- assert_must_succeed(( kernel_objects:remove_element_wf(X,[pred_true /* bool_true */,pred_false /* bool_false */],R,WF), kernel_waitflags:ground_wait_flags(WF),X==pred_false /* bool_false */,R==[pred_true /* bool_true */] )).
3026
3027 ?remove_element_wf(X,Set,Res,WF) :- remove_element_wf(X,Set,Res,WF,_DONE).
3028
3029 :- block remove_element_wf(?,-, -,?,?).
3030 remove_element_wf(X,Set,Res,WF,_DONE) :- Res==[],!, % we know that X must be the only element in Set
3031 equal_object_wf(Set,[X],remove_element_wf,WF).
3032 remove_element_wf(X,Set,Res,WF,DONE) :-
3033 ? remove_element_wf1(X,Set,Res,WF,DONE).
3034
3035 :- block remove_element_wf1(?,-, ?,?,?).
3036 remove_element_wf1(X,avl_set(A),Res,WF,DONE) :- element_can_be_added_or_removed_to_avl(X),!,
3037 /* TO DO: try and move the check about whether X can be added to later; when either X is known
3038 or LWF is instantiated */
3039 remove_element_from_explicit_set(avl_set(A),X,AR),
3040 equal_object_wf(AR,Res,remove_element_wf1,WF), DONE=done.
3041 remove_element_wf1(X,Set,Res,WF,DONE) :- /* DONE is ground when element actually removed */
3042 expand_custom_set_to_list_wf(Set,ESet,_,remove_element_wf1,WF),
3043 %% nl,print(remove_element_wf1(X,Set,ESet,Res,WF,DONE)),nl,nl, %%
3044 remove_element_wf2(X,ESet,Res,LWF,DONE),
3045 %when(nonvar(DONE), print_bt_message(removed(X,ESet,Res,LWF))),
3046 (DONE==done -> true
3047 ; same_card_prop(ESet,[X|Res]), % in case result is instantiated: check compatible with inputs
3048 ? get_cardinality_wait_flag(ESet,remove_element_wf1(X,ESet,Res),WF,LWF),
3049 quick_propagation_element_information(Set,X,WF,_) % use Set rather than ESet; better if still closure or AVL
3050 ).
3051
3052 :- block same_card_prop(-,?), same_card_prop(?,-).
3053 same_card_prop([],[_|_]) :- !, fail.
3054 same_card_prop([_|T],R) :- !,
3055 (R=[] -> fail
3056 ; R=[_|RT] -> same_card_prop(T,RT)
3057 ; true). % just ignore
3058 same_card_prop(_,_).
3059
3060 :- block remove_element_wf2(?,-,?,?,?).
3061 remove_element_wf2(H1,[H2|T],Res,LWF,DONE) :- Res==[],!,
3062 equal_object(H1,H2,remove_element_wf2),
3063 remove_element_wf3(pred_true,H1,H2,T,Res,LWF,DONE).
3064 remove_element_wf2(H1,[H2|T],Res,LWF,DONE) :-
3065 prop_empty_set(T,EqRes),
3066 ? equality_objects_lwf(H1,H2,EqRes,LWF,no_wf_available), % TODO: pass WF
3067 ? remove_element_wf3(EqRes,H1,H2,T,Res,LWF,DONE).
3068 /* important for total_bijection that this has higher priority than other expansions */
3069
3070 :- block prop_empty_set(-,?).
3071 % force second argument to pred_true if first arg is empty set
3072 prop_empty_set([],R) :- !, R=pred_true.
3073 prop_empty_set(_,_).
3074
3075 :- block remove_element_wf3(-,?,?,?,?,-,?).
3076 % remove_element_wf3(EqRes,H1,H2,T,Res,LWF,DONE) :- print(remove_element_wf3(EqRes,H1,H2,T,Res,LWF,DONE)),nl,fail.
3077 remove_element_wf3(pred_true,_H1,_H2,T,Res,_LWF,DONE) :-
3078 ? equal_object(T,Res,remove_element_wf3_1),DONE=done.
3079 remove_element_wf3(pred_false,E,H,T,Res,LWF,DONE) :-
3080 ? equal_object([H|RT],Res,remove_element_wf3_2),
3081 ? remove_element_wf2(E,T,RT,LWF,DONE).
3082
3083 /* the same as above: but do not remove if infinite or closure */
3084
3085 :- block remove_element_wf_if_not_infinite_or_closure(?,-,?,?,?,?).
3086 remove_element_wf_if_not_infinite_or_closure(X,Set, Res,WF,LWF,Done) :-
3087 (dont_expand(Set)
3088 -> check_element_of_wf(X,Set,WF),
3089 equal_object_wf(Res,Set,remove_element_wf_if_not_infinite_or_closure,WF),
3090 Done=true % or should we wait until X known ?
3091 %(var(Res)->Res=Set ; equal_object(Res,Set))
3092 ; expand_custom_set_to_list_wf(Set,ESet,_,remove_element_wf_if_not_infinite_or_closure,WF),
3093 ? remove_element_wf2(X,ESet,Res,LWF,Done)
3094 ).
3095
3096 %:- use_module(bmachine_construction,[external_procedure_used/1]).
3097 %dont_expand(global_set('STRING')) :- !. % s: STRING +-> ... will generate new strings !
3098 %(external_procedure_used(_) -> true). % we could check if there is a STRING generating procedure involved
3099 % unless we use external functions, there is *no* way that new strings can be generated from a B machine !
3100 % Hence: we can expand STRING safely and thus avoid infinite enumeration of partial functions, ...
3101 % example: procs : STRING +-> {"waiting"} & card( dom(procs) ) = 6 thus fails quickly
3102 dont_expand(avl_set(_)) :- !,fail.
3103 dont_expand(closure(_,_,_)) :- !. % relevant for tests 283, 1609, 1858
3104 dont_expand(Set) :-
3105 is_infinite_or_very_large_explicit_set(Set).
3106 % should we use a smaller bound than 20000 (comprehension_set_symbolic_limit)? see test 1609
3107
3108
3109 :- assert_must_succeed((kernel_objects:check_no_duplicates_in_list([int(1),int(2)],[],no_wf_available))).
3110 :- assert_must_fail((kernel_objects:check_no_duplicates_in_list([int(1),int(2),int(1)],[],no_wf_available))).
3111
3112 :- block check_no_duplicates_in_list(-,?,?).
3113 check_no_duplicates_in_list([],_,_) :- !.
3114 check_no_duplicates_in_list([H|T],ElementsSoFar,WF) :- !,
3115 not_element_of_wf(H,ElementsSoFar,WF),
3116 add_new_element_wf(H,ElementsSoFar,ElementsSoFar2,WF),
3117 check_no_duplicates_in_list(T,ElementsSoFar2,WF).
3118 check_no_duplicates_in_list(CS,ElementsSoFar,WF) :-
3119 disjoint_sets(CS,ElementsSoFar,WF).
3120
3121 :- public warn_if_duplicates_in_list/3.
3122 % code for debugging / safe mode execution to check for duplicates
3123 warn_if_duplicates_in_list(List,Src,WF) :-
3124 %get_last_wait_flag(warn_if_duplicates_in_list,WF,WFX), % we may wish to use another WF here !?
3125 get_enumeration_finished_wait_flag(WF,WFX),
3126 when(nonvar(WFX),warn_if_duplicates_in_list(List,[],Src,WF)).
3127
3128 :- block warn_if_duplicates_in_list(-,?,?,?).
3129 warn_if_duplicates_in_list([],_,_,_) :- !.
3130 warn_if_duplicates_in_list([H|T],ElementsSoFar,Src,WF) :- !,
3131 membership_test_wf(ElementsSoFar,H,MemRes,WF),
3132 warn_aux(MemRes,H,T,ElementsSoFar,Src,WF).
3133 warn_if_duplicates_in_list(CS,ElementsSoFar,Src,WF) :-
3134 when(ground(CS),
3135 (disjoint_sets(CS,ElementsSoFar,WF)
3136 -> true
3137 ; add_error(Src,'Duplicates in list: ',CS:ElementsSoFar:Src))).
3138
3139 :- block warn_aux(-,?,?,?,?,?).
3140 warn_aux(pred_true,H,_,ElementsSoFar,Src,_WF) :-
3141 add_error(Src,'Duplicate in list: ',H:ElementsSoFar:Src).
3142 warn_aux(pred_false,H,T,ElementsSoFar,Src,WF) :-
3143 add_new_element_wf(H,ElementsSoFar,ElementsSoFar2,WF),
3144 warn_if_duplicates_in_list(T,ElementsSoFar2,Src,WF).
3145
3146
3147 :- assert_must_succeed((kernel_objects:remove_exact_first_element([int(1),int(2)],X,[[]]),
3148 X = [[int(1),int(2)],[]])).
3149 :- assert_must_succeed((kernel_objects:remove_exact_first_element(X,global_set('Name'),T),
3150 X==fd(1,'Name'),T==[fd(2,'Name'),fd(3,'Name')])).
3151 :- assert_must_fail((kernel_objects:remove_exact_first_element([[]],X,_),
3152 X = [[int(1),int(2)],[]])).
3153
3154 :- assert_must_succeed((kernel_objects:remove_exact_first_element(X,C,R),
3155 kernel_objects:gen_test_interval_closure(1,2,C),
3156 X == int(1), R == [int(2)] )).
3157
3158 gen_test_interval_closure(From,To,CL) :-
3159 CL=closure(['_zzzz_unary'],[integer],b(member( b(identifier('_zzzz_unary'),integer,[]),
3160 b(interval(b(value(int(From)),integer,[]),
3161 b(value(int(To)),integer,[])),set(integer),[])),pred,[])).
3162
3163 :- block remove_exact_first_element(?,-,?).
3164 remove_exact_first_element(X,Set,Res) :- remove_exact_first_element1(Set,X,Res).
3165
3166 remove_exact_first_element1([],_,_) :- fail.
3167 remove_exact_first_element1([H|T],H,T).
3168 remove_exact_first_element1(avl_set(A),H,T) :- remove_minimum_element_custom_set(avl_set(A),H,T).
3169 remove_exact_first_element1(global_set(GS),H,T) :-
3170 remove_minimum_element_custom_set(global_set(GS),H,T).
3171 remove_exact_first_element1(freetype(GS),H,T) :-
3172 remove_minimum_element_custom_set(freetype(GS),H,T).
3173 remove_exact_first_element1(closure(P,Types,B),H,T) :-
3174 remove_minimum_element_custom_set(closure(P,Types,B),H,T).
3175
3176
3177 :- assert_must_succeed((kernel_objects:delete_element_wf(fd(1,'Name'),X,[fd(2,'Name'),fd(3,'Name')],_WF),
3178 X = global_set('Name'))).
3179 :- assert_must_succeed((kernel_objects:delete_element_wf(int(1),X,[int(2)],_WF),
3180 X = [int(2),int(1)])).
3181 :- assert_must_succeed((kernel_objects:delete_element_wf([int(1),int(2)],X,[],_WF),
3182 X = [[int(2),int(1)]])).
3183 :- assert_must_succeed((kernel_objects:delete_element_wf(int(3),X,[int(2),int(1)],_WF),
3184 X = [int(2),int(1)])).
3185 :- assert_must_succeed((kernel_objects:delete_element_wf(int(1),X,X,_WF),
3186 X = [])).
3187 :- assert_must_fail((kernel_objects:delete_element_wf(int(X),[int(1)],[int(1)],_WF),
3188 X = 1)).
3189
3190 /* WARNING: only use when R is not instantiated by something else;
3191 (except for R=[]) */
3192
3193
3194 :- block delete_element_wf(?,-,?,?).
3195 delete_element_wf(X,Set,Res,WF) :-
3196 ground(X),
3197 try_expand_and_convert_to_avl_with_check(Set,ESet,delete_element_wf),!,
3198 delete_element0(X,ESet,Res,WF).
3199 delete_element_wf(X,Set,Res,WF) :- delete_element1(X,Set,Res,WF).
3200
3201 :- block delete_element0(?,-,?,?).
3202 delete_element0(X,ESet,Res,WF) :-
3203 ( is_custom_explicit_set(ESet,delete_element),
3204 delete_element_from_explicit_set(ESet,X,DS)
3205 -> equal_object_wf(DS,Res,delete_element0,WF)
3206 ; delete_element1(X,ESet,Res,WF)
3207 ).
3208
3209 delete_element1(X,Set,Res,WF) :- expand_custom_set_to_list_wf(Set,ESet,_,delete_element1,WF),
3210 %check_is_expanded_set(ESet,delete_element2),
3211 delete_element2(ESet,X,Res,WF).
3212
3213 :- block delete_element2(-,?,?,?).
3214 delete_element2([],_,[],_). /* same as above, but allow element to be absent */
3215 delete_element2([H2|T],E,R,WF) :-
3216 equality_objects_wf(H2,E,EqRes,WF),
3217 delete_element3(EqRes,H2,T,E,R,WF).
3218 %when_sufficiently_instantiated(E,H2,delete_element3(H1,[H2|T],R)). /* added by Michael Leuschel, 16/3/06 */
3219
3220 :- block delete_element3(-,?,?,?,?,?).
3221 delete_element3(pred_true,_H2,T,_,R,WF) :- equal_object_wf(R,T,delete_element3,WF).
3222 delete_element3(pred_false,H2,T,E,Res,WF) :- equal_cons_wf(Res,H2,RT,WF),delete_element2(T,E,RT,WF).
3223
3224
3225
3226
3227 :- assert_must_succeed(kernel_objects:check_is_expanded_set([int(1)],test)).
3228
3229 :- public check_is_expanded_set/2.
3230 check_is_expanded_set(X,Source) :-
3231 (nonvar(X),(X=[] ; X= [_|_]) -> true
3232 ; add_internal_error('Is not expanded set: ',check_is_expanded_set(X,Source))
3233 ).
3234
3235
3236 /* union/3 */
3237
3238 :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(3)],[int(2),int(1),int(3)],[int(1),int(3),int(2)]))).
3239 :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(1)],[int(1),int(2)],[int(1),int(2)]))).
3240 :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(3)],[int(2),int(1)],[int(1),int(3),int(2)]))).
3241 :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(3),int(2)],[int(2),int(1)],[int(1),int(3),int(2)]))).
3242 :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],union([int(3),int(4)],[int(2),int(1)],[int(1),int(3),int(2)]))).
3243 :- assert_must_succeed((kernel_objects:union([int(1)],[int(2)],Res),kernel_objects:equal_object(Res,[_,_]))).
3244 :- assert_must_succeed((kernel_objects:union([],[int(2)],Res),
3245 kernel_objects:equal_object(Res,[int(2)]))).
3246 :- assert_must_succeed((kernel_objects:union([int(2)],[],Res),
3247 kernel_objects:equal_object(Res,[int(2)]))).
3248 :- assert_must_succeed((kernel_objects:union([int(2)],[int(2)],Res),
3249 kernel_objects:equal_object(Res,[int(2)]))).
3250 :- assert_must_succeed((kernel_objects:union([int(1)],Res,[int(1),int(2)]),
3251 kernel_objects:equal_object(Res,[int(2)]))).
3252 :- assert_must_succeed((kernel_objects:union([fd(1,'Name')],X,Res),X=global_set('Name'),
3253 kernel_objects:equal_object(Res,X))).
3254 :- assert_must_succeed((kernel_objects:union(X,global_set('Name'),Res),X=[fd(2,'Name'),fd(1,'Name')],
3255 kernel_objects:equal_object(Res,global_set('Name')))).
3256 :- assert_must_succeed((kernel_objects:union([fd(1,'Name')],[fd(3,'Name'),fd(2,'Name')],Res),
3257 kernel_objects:equal_object(Res,global_set('Name')))).
3258 %:- assert_must_succeed((kernel_objects:union([fd(1,'Name')],[fd(3,'Name'),fd(2,'Name')],Res),
3259 % kernel_objects:equal_object(Res,X),X=global_set('Name'))).
3260 :- assert_must_fail((kernel_objects:union([int(1)],[int(2)],Res),
3261 (kernel_objects:equal_object(Res,[_]);kernel_objects:equal_object(Res,[_,_,_|_])))).
3262 :- assert_must_fail((kernel_objects:union([int(1)],[int(1)],Res),(Res=[];kernel_objects:equal_object(Res,[_,_|_])))).
3263 :- assert_must_fail((kernel_objects:union([fd(1,'Name')],[fd(2,'Name')],Res),
3264 kernel_objects:equal_object(Res,global_set('Name')))).
3265 % kernel_objects:union([int(1),int(2)],X,[int(1),int(2),int(3)])
3266
3267 ?union(S1,S2,Res) :- init_wait_flags(WF,[union]), union_wf(S1,S2,Res,WF), ground_wait_flags(WF).
3268
3269 :- block union_wf(-,-,-,?).
3270 %union_wf(Set1,Set2,Res,_WF) :- print(union_wf(Set1,Set2,Res)),nl,fail.
3271 union_wf(Set1,Set2,Res,WF) :- Set1==[],!,equal_object_wf(Set2,Res,union_wf_1,WF).
3272 union_wf(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,union_wf_2,WF).
3273 union_wf(Set1,Set2,Res,WF) :- Res==[],!,empty_set_wf(Set1,WF), empty_set_wf(Set2,WF).
3274 ?union_wf(Set1,Set2,Res,WF) :- union0(Set1,Set2,Res,WF).
3275
3276 :- block union0(-,-,?,?), union0(-,?,-,?), union0(?,-,-,?). % require two arguments to be known
3277 ?union0(Set1,Set2,Res,WF) :- Set1==[],!,equal_object_wf(Set2,Res,union0_1,WF).
3278 union0(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,union0_2,WF).
3279 union0(Set1,Set2,Res,WF) :- Res==[],!,empty_set_wf(Set1,WF), empty_set_wf(Set2,WF).
3280 union0(Set1,Set2,Res,WF) :- nonvar(Res), singleton_set(Res,X),!,
3281 (var(Set1) -> union0_to_singleton_set(Set2,Set1,X,WF) ; union0_to_singleton_set(Set1,Set2,X,WF)).
3282 ?union0(Set1,Set2,Res,WF) :- (var(Set1) -> union1(Set2,Set1,Res,WF) ; union1(Set1,Set2,Res,WF)).
3283
3284 % optimized version for Set1 \/ Set2 = {X}
3285 % TO DO: is not triggered when Set1 and Set2 are instantiated first (before result)
3286 % >>> z:11..12 & {x,y} \/ {v} = {z} does not work
3287 union0_to_singleton_set([],Set2,X,WF) :- !, equal_object_wf(Set2,[X],union0_3,WF). % cannot be reached, due to checks above
3288 union0_to_singleton_set([H|T],Set2,X,WF) :- !, empty_set_wf(T,WF), equal_object_wf(H,X,WF),
3289 check_subset_of_wf(Set2,[X],WF).
3290 union0_to_singleton_set(avl_set(A),Set2,X,WF) :- !, singleton_set(avl_set(A),AEl),
3291 equal_object_wf(AEl,X,WF),
3292 check_subset_of_wf(Set2,[X],WF).
3293 union0_to_singleton_set(Set1,Set2,X,WF) :- % closure or global_set; revert to normal treatment
3294 union1(Set1,Set2,[X],WF).
3295
3296 union1(Set1,Set2,Res,WF) :- var(Set2), dont_expand_this_explicit_set(Set1), !,
3297 block_union1e(Set2,Set1,Res,WF). % try avoid expanding Set1 and wait until Set2 becomes known, may enable symbolic union
3298 union1(Set1,Set2,Res,WF) :-
3299 try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set1,ESet1,WF),
3300 try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set2,ESet2,WF),
3301 ? union1e(ESet1,ESet2,Res,WF).
3302
3303 try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set,ESet,_) :-
3304 (var(Set);Set=closure(_,_,_)),!,ESet=Set.
3305 try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set,ESet,WF) :-
3306 try_expand_and_convert_to_avl_unless_large_wf(Set,ESet,WF).
3307
3308 :- block block_union1e(-,?,?,?).
3309 block_union1e(Set1,Set2,Res,WF) :- Res==[],!,
3310 empty_set_wf(Set1,WF), empty_set_wf(Set2,WF).
3311 block_union1e(Set1,Set2,Res,WF) :-
3312 union1e(Set1,Set2,Res,WF).
3313
3314 union1e(Set1,Set2,Res,WF) :-
3315 is_custom_explicit_set(Set1,union1e),
3316 union_of_explicit_set(Set1,Set2,Union),
3317 !, equal_object_wf(Union,Res,union1e,WF).
3318 union1e(Set2,Set1,Res,WF) :- % Set2=avl_set(_), nonvar(Set1), Set1 \= avl_set(_),
3319 nonvar(Set1), Set1=avl_set(_), Set2 \= avl_set(_), \+ ground(Set2),
3320 !, % avoid expanding Set2
3321 expand_custom_set_to_list_wf(Set1,ESet1,_,union1e_1,WF),
3322 ? union2(ESet1,Set2,Res,WF), lazy_check_subset_of(Set2,Res,WF).
3323 union1e(Set1,Set2,Res,WF) :-
3324 expand_custom_set_to_list_wf(Set1,ESet1,_,union1e_2,WF), % we could avoid this expansion by treating avl_set,... below in union2
3325 ? union2(ESet1,Set2,Res,WF),
3326 ? lazy_check_subset_of(Set1,Res,WF), % ADDED to solve {x,y| { x \/ y } <: {{1} \/ {2}}}
3327 ? lazy_check_subset_of(Set2,Res,WF) % could perform additional constraint checking
3328 % ,try_prop_card_leq(ESet1,Res), try_prop_card_leq(Set2,Res). %%% seems to slow down ProB: investigate
3329 .
3330
3331 /* not yet used:
3332 % lazy_check_in_union(R,Set1,Set2,WF): check if all elements of R appear in at least one of the sets Sets1/2:
3333 :- block lazy_check_in_union(-,?,?,?).
3334 lazy_check_in_union([],_,_,_) :- !.
3335 lazy_check_in_union([H|T],Set1,Set2,WF) :- !,
3336 in_one_of_sets(H,Set1,Set2,WF),
3337 lazy_check_in_union(T,Set1,Set2,WF).
3338 lazy_check_in_union(_,_,_,_).
3339
3340 % check if an element appear in at least one of the two sets:
3341 in_one_of_sets(H,Set1,Set2,WF) :-
3342 membership_test_wf(Set1,H,MemRes1,WF),
3343 (MemRes1==pred_true -> true
3344 ; one_true(MemRes1,MemRes2),
3345 membership_test_wf(Set2,H,MemRes2,WF)
3346 ).
3347
3348 :- block one_true(-,-).
3349 one_true(MemRes1,MemRes2) :- var(MemRes1),!,
3350 (MemRes2=pred_false -> MemRes1=pred_true ; true).
3351 one_true(pred_true,_).
3352 one_true(pred_false,pred_true).
3353 */
3354
3355
3356 :- block lazy_try_check_element_of(?,-,?).
3357 ?lazy_try_check_element_of(H,Set,WF) :- lazy_check_element_of_aux(Set,H,WF).
3358
3359 ?lazy_check_element_of_aux(closure(P,T,B),H,WF) :- !, check_element_of_wf(H,closure(P,T,B),WF).
3360 ?lazy_check_element_of_aux(avl_set(A),H,WF) :- !, check_element_of_wf(H,avl_set(A),WF).
3361 lazy_check_element_of_aux([X|T],H,WF) :- !, lazy_check_element_of_list(T,X,H,WF).
3362 lazy_check_element_of_aux(_,_,_).
3363
3364 :- block lazy_check_element_of_list(-,?,?,?).
3365 lazy_check_element_of_list([],X,H,WF) :- !, equal_object_wf(X,H,WF).
3366 lazy_check_element_of_list([Y|T],X,H,WF) :- !,
3367 quick_propagation_element_information([X,Y|T],H,WF,_). % TO DO: check that we loose no performance due to this
3368 lazy_check_element_of_list(_,_,_,_).
3369
3370 % an incomplete subset check without enumeration
3371 :- block lazy_check_subset_of(-,?,?), lazy_check_subset_of(?,-,?).
3372 lazy_check_subset_of(Set1,Set2,WF) :- nonvar(Set2),
3373 ? (Set2=closure(_,_,_) ; Set2=avl_set(_)),!, lazy_check_subset_of2(Set1,Set2,WF).
3374 lazy_check_subset_of(_,_,_). % ignore other set representations
3375 :- block lazy_check_subset_of2(-,?,?).
3376 lazy_check_subset_of2([],_,_WF) :- !.
3377 ?lazy_check_subset_of2([H|T],Set,WF) :- !, check_element_of_wf(H,Set,WF), lazy_check_subset_of2(T,Set,WF).
3378 lazy_check_subset_of2(_,_,_). % ignore other set representations
3379
3380 :- block union2(-,?,?,?).
3381 ?union2([],S,Res,WF) :- equal_object_optimized_wf(S,Res,union2,WF).
3382 union2([H|T],Set2,Res,WF) :-
3383 (T\==[],nonvar(Set2), Set2=[H2|T2], T2==[] % minor optimisation for improved propagation; e.g., for x:S & S<:1..13 & S \/ {x} = S2 & x/: S2
3384 % the constraint is not yet detected straight away: x:S & S<:1..12 & S \/ {x} /= S
3385 ? -> union3(H2,T2,[H|T],Res,WF)
3386 ? ; union3(H,T,Set2,Res,WF)
3387 ).
3388 union3(H,T,Set2,Res,WF) :-
3389 add_element_wf(H,Set2,R,Done,WF),
3390 ? lazy_try_check_element_of(H,Res,WF), % TO DO: propagate constraint that H is in Res
3391 (T==[]
3392 ? -> equal_object_optimized_wf(R,Res,union3,WF) %union2(T,R,Res,WF)
3393 ? ; union4(Done,T,R,Res,WF)).
3394 :- block union4(-,?,?,?,?).
3395 ?union4(_Done,T,R,Res,WF) :- union2(T,R,Res,WF). % if WF not set to 2 there maybe equality_objects pending from add_element_wf ! TO DO: investigate; see test 293
3396
3397
3398 :- assert_must_succeed(exhaustive_kernel_check(union_generalized([[int(3)],[int(2),int(1),int(3)]],[int(1),int(3),int(2)]))).
3399 :- assert_must_succeed(exhaustive_kernel_check(union_generalized([[int(3),int(2)],[],[int(2),int(1),int(3)]],[int(1),int(3),int(2)]))).
3400 :- assert_must_succeed(exhaustive_kernel_fail_check(union_generalized([[int(3)],[int(3),int(4)],[int(2),int(1),int(3)]],[int(1),int(3),int(2)]))).
3401 :- assert_must_succeed((kernel_objects:union_generalized([[]],Res),Res=[])).
3402 :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2)]],Res),
3403 kernel_objects:equal_object(Res,[_,_]))).
3404 :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2),int(1)]],Res),
3405 kernel_objects:equal_object(Res,[_,_]))).
3406 :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2),int(1)],[],[int(2)]],Res),
3407 kernel_objects:equal_object(Res,[_,_]))).
3408 :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2)],X],Res),
3409 kernel_objects:equal_object(X,Res), X = [int(2),int(1),int(3)])).
3410 :- assert_must_succeed((kernel_objects:union_generalized([global_set('Name'),X,X,X],Res),
3411 kernel_objects:equal_object(global_set('Name'),Res), X = [fd(2,'Name'),fd(1,'Name')])).
3412 :- assert_must_succeed((kernel_objects:union_generalized([X,global_set('Name')],Res),
3413 kernel_objects:equal_object(global_set('Name'),Res), X = [fd(2,'Name'),fd(1,'Name')])).
3414 :- assert_must_fail((kernel_objects:union_generalized([[int(1)],[int(2)]],Res),(Res=[_];
3415 kernel_objects:equal_object(Res,[_,_,_|_])))).
3416 :- assert_must_fail((kernel_objects:union_generalized([[int(1)],[int(1)]],Res),(Res=[];
3417 kernel_objects:equal_object(Res,[_,_|_])))).
3418
3419 % treates the general_union AST node (union(.) in B syntax)
3420 ?union_generalized(S,Res) :- init_wait_flags(WF), union_generalized_wf(S,Res,WF), ground_wait_flags(WF).
3421
3422 :- block union_generalized_wf(-,-,?).
3423 union_generalized_wf(SetsOfSets,Res,WF) :- var(SetsOfSets), Res==[],!,
3424 expand_custom_set_to_list_wf(SetsOfSets,ESetsOfSets,_,union_generalized_wf,WF),
3425 all_empty_sets_wf(ESetsOfSets,WF).
3426 union_generalized_wf(SetsOfSets,Res,WF) :-
3427 ? union_generalized_wf2(SetsOfSets,Res,WF).
3428
3429 :- block union_generalized_wf2(-,?,?).
3430 union_generalized_wf2(SetsOfSets,Res,WF) :-
3431 custom_explicit_sets:union_generalized_explicit_set(SetsOfSets,ARes,WF),!,
3432 equal_object_optimized_wf(ARes,Res,union_generalized_avl_set,WF).
3433 union_generalized_wf2(SetsOfSets,Res,WF) :-
3434 expand_custom_set_to_list_wf(SetsOfSets,ESetsOfSets,_,union_generalized_wf2,WF),
3435 ? union_generalized2(ESetsOfSets,[],Res,WF).
3436
3437 :- block union_generalized2(-,?,?,?).
3438 union_generalized2([],S,Res,WF) :- equal_object_optimized_wf(S,Res,union_generalized2,WF).
3439 union_generalized2([H|T],UnionSoFar,Res,WF) :-
3440 Res==[],
3441 !,
3442 empty_set_wf(H,WF),
3443 empty_set_wf(UnionSoFar,WF),
3444 all_empty_sets_wf(T,WF).
3445 union_generalized2([H|T],UnionSoFar,Res,WF) :- union_wf(H,UnionSoFar,UnionSoFar2,WF),
3446 ((var(T);var(UnionSoFar2)),
3447 nonvar(Res),is_custom_explicit_set(Res,union_generalized2) % check important for Schneider2_Trees/NewSolver_v3_complex.mch and query CHOOSE_MODULES("bk-phi-H-2013", solution) (0.1 vs 0.9 secs)
3448 ? -> check_subset_of_wf(H,Res,WF)
3449 % this is only a very weak propagation; example, for union(v) = {4444} & v={{x},{y},{z}} we will instantiate v={{4444},...} and z=4444; see also test 1216
3450 ; true),
3451 union_generalized2(T,UnionSoFar2,Res,WF).
3452
3453 :- block all_empty_sets_wf(-,?).
3454 all_empty_sets_wf([],_).
3455 all_empty_sets_wf([H|T],WF) :- empty_set_wf(H,WF), all_empty_sets_wf(T,WF).
3456
3457 :- assert_must_succeed(exhaustive_kernel_check([commutative],intersection([int(3)],[int(2),int(1),int(3)],[int(3)]))).
3458 :- assert_must_succeed(exhaustive_kernel_check([commutative],intersection([int(4),int(3),int(2)],[int(2),int(1),int(3)],[int(2),int(3)]))).
3459 :- assert_must_succeed(exhaustive_kernel_check([commutative],intersection([int(4),int(3),int(2)],[],[]))).
3460 :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],intersection([int(1),int(3)],[int(4),int(3),int(2)],[]))).
3461 :- assert_must_succeed((kernel_objects:intersection(Y,X,Res),X=global_set('Name'),
3462 kernel_objects:equal_object(Res,Y), Y =[fd(1,'Name')])).
3463 :- assert_must_succeed((kernel_objects:intersection([int(1)],[int(2)],Res),Res=[])).
3464 :- assert_must_succeed((kernel_objects:intersection([int(1)],[int(2)],[]))).
3465 :- assert_must_fail((kernel_objects:intersection([int(1),int(4),int(3)],[int(2),int(3)],[]))).
3466 :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(1)],_))).
3467 :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(1)],[int(2),int(1)]))).
3468 :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(1)],[int(1),int(2)]))).
3469 :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(3)],Res),
3470 kernel_objects:equal_object(Res,[int(2)]))).
3471 :- assert_must_succeed((kernel_objects:intersection([int(2)],[int(2)],Res),
3472 kernel_objects:equal_object(Res,[int(2)]))).
3473 :- assert_must_succeed((kernel_objects:intersection([int(2),int(3)],[int(3),int(4),int(2)],Res),
3474 kernel_objects:equal_object(Res,[int(2),int(3)]))).
3475 :- assert_must_fail((kernel_objects:intersection([int(1)],[int(2)],Res),(
3476 kernel_objects:equal_object(Res,[_|_])))).
3477 :- assert_must_fail((kernel_objects:intersection([int(1)],[int(1)],Res),(Res=[];
3478 kernel_objects:equal_object(Res,[_,_|_])))).
3479 :- assert_must_fail((kernel_objects:intersection([fd(1,'Name')],X,Res),X=global_set('Name'),
3480 kernel_objects:equal_object(Res,X))).
3481
3482
3483 ?intersection(S1,S2,Res) :- init_wait_flags(WF,[intersection]), intersection(S1,S2,Res,WF), ground_wait_flags(WF).
3484
3485 :- block intersection(-,-,-,?).
3486 intersection(Set1,Set2,Res,WF) :- (Set1==[] ; Set2==[]),!, empty_set_wf(Res,WF).
3487 intersection(Set1,Set2,Res,WF) :- quick_same_value(Set1,Set2),!,
3488 equal_object_wf(Res,Set1,inter0_equal,WF).
3489 intersection(Set1,Set2,Res,WF) :- Res==[],!,
3490 disjoint_sets(Set1,Set2,WF).
3491 intersection(Set1,Set2,Res,WF) :- % now we need to know at least a bit about both Set1 and Set2; at least given the current code below; TO DO: infer that {x} /\ s = {x} => x:s
3492 intersection0(Set1,Set2,Res,WF),
3493 ? propagate_intersection(Set1,Set2,Res,WF).
3494
3495 :- block propagate_intersection(?,?,-,?). % propagate constraint that result elements must be in both sets
3496 propagate_intersection(Set1,Set2,[H|T],WF) :-
3497 preference(data_validation_mode,false),
3498 !,
3499 ? propagate_intersection_aux(Set1,Set2,H,T,WF).
3500 propagate_intersection(Set1,Set2,avl_set(A),WF) :- !,
3501 ((unknown_set(Set1) ; unknown_set(Set2)) % otherwise intersection0 has already triggered below
3502 -> custom_explicit_sets:avl_approximate_size(A,Size),
3503 (Size<20
3504 -> expand_custom_set_to_list_wf(avl_set(A),ESet,_,propagate_intersection,WF)
3505 ; avl_min(A,Min), avl_max(A,Max), ESet=[Min,Max]
3506 ),
3507 ? propagate_intersection(Set1,Set2,ESet,WF)
3508 ; true).
3509 % other cases: Set1,2,3 could be interval closure with unknown bounds,...
3510 propagate_intersection(_,_,_,_).
3511
3512 :- block propagate_intersection_aux(-,-,-,?,?).
3513 propagate_intersection_aux(Set1,Set2,H,T,WF) :-
3514 ((unknown_set(Set1) ; unknown_set(Set2)) % otherwise intersection0 has already triggered below
3515 ? -> check_element_of_wf(H,Set1,WF), % should we do this lazily ?
3516 ? check_element_of_wf(H,Set2,WF),
3517 ? propagate_intersection(Set1,Set2,T,WF)
3518 ; true).
3519
3520 unknown_set(Set) :- var(Set),!.
3521 unknown_set([H|T]) :- (unknown_val(H) -> true ; unknown_set(T)).
3522 unknown_val(Val) :- var(Val),!.
3523 unknown_val(int(X)) :- var(X).
3524 unknown_val(string(X)) :- var(X).
3525 unknown_val(fd(X,_)) :- var(X).
3526 unknown_val((A,B)) :- (unknown_val(A) -> true ; unknown_val(B)).
3527 unknown_val([H|T]) :- (unknown_val(H) -> true ; unknown_set(T)).
3528
3529 :- block intersection0(-,?,?,?), intersection0(?,-,?,?).
3530 intersection0(Set1,Set2,Res,WF) :-
3531 (Set1==[] ; Set2==[]),!, empty_set_wf(Res,WF).
3532 intersection0(Set1,Set2,Res,WF) :- quick_same_value(Set1,Set2),!,
3533 equal_object_wf(Res,Set1,inter0_equal,WF).
3534 intersection0(Set1,Set2,Res,WF) :- Res==[],!,
3535 disjoint_sets(Set1,Set2,WF).
3536 intersection0([El1|T1],[El2|T2],Res,WF) :- T1==[],T2==[],
3537 !, % avoid doing intersection_with_interval_closure, especially for nonvar El1,El2 ; see test 2021
3538 equality_objects_wf(El1,El2,EqRes,WF),
3539 kernel_equality:empty_set_test_wf(Res,Empty,WF),
3540 bool_pred:negate(Empty,EqRes),
3541 intersection_pair(EqRes,El1,El2,Res,WF).
3542 intersection0(Set1,Set2,Res,WF) :-
3543 ? intersection_with_interval_closure(Set1,Set2,Inter),!, % avoid expanding intervals at all
3544 equal_object_wf(Inter,Res,intersection0,WF).
3545 intersection0(Set1,Set2,Res,WF) :-
3546 try_expand_and_convert_to_avl_unless_large_wf(Set1,ESet1,WF),
3547 try_expand_and_convert_to_avl_unless_large_wf(Set2,ESet2,WF),
3548 ? intersection1(ESet1,ESet2,Res,WF).
3549
3550 % treat {El1} /\ {El2} = Res
3551 :- block intersection_pair(-,?,?,?,?).
3552 intersection_pair(pred_false,_,_,_,_). % empty_set_test_wf above will set Res to empty_set
3553 intersection_pair(pred_true,El1,_El2,Res,WF) :- equal_object_wf(Res,[El1],intersection_pair,WF).
3554
3555 intersection1(Set1,Set2,Res,WF) :- nonvar(Set1),is_custom_explicit_set(Set1,intersection),
3556 intersection_of_explicit_set_wf(Set1,Set2,Inter,WF), !,
3557 equal_object_wf(Inter,Res,intersection1,WF).
3558 intersection1(Set1,Set2,Res,WF) :-
3559 (Res==[] ->
3560 disjoint_sets(Set1,Set2,WF)
3561 ;
3562 ? (swap_set(Set1,Set2) -> intersection2(Set2,Set1,Res,WF)
3563 ? ; intersection2(Set1,Set2,Res,WF))
3564 ).
3565
3566 swap_set(Set1,_Set2) :- var(Set1),!.
3567 swap_set(_Set1,Set2) :- var(Set2),!,fail.
3568 %swap_set(_Set1,Set2) :- is_infinite_explicit_set(Set2),!,fail.
3569 swap_set(avl_set(_),Set2) :- \+ functor(Set2,avl_set,2), %Set2 \= avl_set(_),
3570 Set2 \= [],
3571 \+ functor(Set2,closure,3), %Set2 \= closure(_,_,_),
3572 \+ functor(Set2,global_set,1). %Set2 \= global_set(_). % if it was a small closure, intersection_of_explicit_set should have triggered
3573 swap_set(closure(_P,_T,_B),Set2) :- ok_to_swap(Set2). % TO DO: for two closures: we could try and use the smallest one as first argument to intersection2
3574 swap_set(global_set(_GS),Set2) :- ok_to_swap(Set2).
3575
3576 ok_to_swap(global_set(GS)) :- !, \+ is_infinite_or_very_large_explicit_set(global_set(GS),1000000).
3577 ok_to_swap(closure(P,T,B)) :- !,\+ is_infinite_or_very_large_explicit_set(closure(P,T,B),1000000).
3578 ok_to_swap(_).
3579 % maybe also use is_efficient_custom_set as below ??
3580 % what about freetype ?
3581
3582
3583 intersection2(Set1,Set2,Res,WF) :-
3584 expand_custom_set_to_list_wf(Set1,ESet1,_,intersection2,WF),
3585 ? intersection3(ESet1,Set2,Res,WF).
3586 :- block intersection3(-,?,?,?).
3587 intersection3([],_,Res,WF) :- empty_set_wf(Res,WF).
3588 intersection3([H|T],Set,Res,WF) :-
3589 (Res==[]
3590 -> not_element_of_wf(H,Set,WF),intersection3(T,Set,Res,WF)
3591 ; membership_test_wf(Set,H,MemRes,WF),
3592 ? intersection4(MemRes,H,T,Set,Res,WF)
3593 ).
3594
3595 :- block intersection4(-,?,?, ?,?,?).
3596 intersection4(pred_true,H,T,Set,Result,WF) :-
3597 ? equal_object_wf([H|Res],Result,intersection4,WF),
3598 intersection3(T,Set,Res,WF).
3599 intersection4(pred_false,_H,T,Set,Res,WF) :-
3600 ? intersection3(T,Set,Res,WF).
3601
3602
3603 :- assert_must_succeed(exhaustive_kernel_check_wfdet(disjoint_sets([int(5)],[int(2),int(1),int(3)],WF),WF)).
3604 :- assert_must_succeed(exhaustive_kernel_check_wfdet(disjoint_sets([int(5)],[],WF),WF)).
3605 :- assert_must_succeed(exhaustive_kernel_check_wfdet(disjoint_sets([int(5),int(2)],[int(6),int(1),int(3)],WF),WF)).
3606
3607 disjoint_sets(S1,S2) :- init_wait_flags(WF,[disjoint_sets]),
3608 disjoint_sets(S1,S2,WF),
3609 ground_wait_flags(WF).
3610
3611 :- block disjoint_sets(-,?,?), disjoint_sets(?,-,?).
3612 disjoint_sets(S1,S2,WF) :-
3613 % TO DO: we could provide faster code for two avl sets / intervals; but probably caught in intersection code above?
3614 ((S1==[];S2==[]) -> true
3615 ; is_interval_closure_or_integerset(S1,Low1,Up1),
3616 nonvar(Low1), nonvar(Up1), % avoid applying it to e.g., {x} /\ 0..2000 = {} from test 1165
3617 is_interval_closure_or_integerset(S2,Low2,Up2), nonvar(Low2), nonvar(Up2) ->
3618 custom_explicit_sets:disjoint_intervals_with_inf(Low1,Up1,Low2,Up2)
3619 ; is_efficient_custom_set(S2) -> expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_1,WF),
3620 % TODO: treat is_infinite_or_symbolic_closure S1
3621 disjoint_sets2(ESet1,S2,WF)
3622 ; is_efficient_custom_set(S1) -> expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_2,WF),
3623 disjoint_sets2(ESet2,S1,WF)
3624 ; expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_3,WF),
3625 %expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_4,WF),
3626 disjoint_sets2(ESet1,S2,WF)
3627 ).
3628
3629 % TO DO: we could infer some constraints on the possible max sizes of the sets
3630 % for finite types (sum of size must be <= size of type)
3631 :- block disjoint_sets2(-,?,?).
3632 disjoint_sets2([],_,_WF).
3633 disjoint_sets2([H|T],S2,WF) :- not_element_of_wf(H,S2,WF), disjoint_sets2(T,S2,WF).
3634
3635 % NOT YET USED: not_disjoint_sets could be used for S /\ R /= {}
3636 :- assert_must_succeed(exhaustive_kernel_check_wfdet(not_disjoint_sets([int(3)],[int(2),int(1),int(3)],WF),WF)).
3637 :- block not_disjoint_sets(-,?,?), not_disjoint_sets(?,-,?).
3638 not_disjoint_sets(S1,S2,WF) :-
3639 ((S1==[];S2==[]) -> fail
3640 ; is_efficient_custom_set(S2) -> expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_1,WF),
3641 not_disjoint_sets2(ESet1,S2,WF)
3642 ; is_efficient_custom_set(S1) -> expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_2,WF),
3643 not_disjoint_sets2(ESet2,S1,WF)
3644 ; expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_3,WF),
3645 %expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_4,WF),
3646 not_disjoint_sets2(ESet1,S2,WF)
3647 ).
3648
3649 :- block not_disjoint_sets2(-,?,?).
3650 not_disjoint_sets2([],_,_WF).
3651 not_disjoint_sets2([H|T],S2,WF) :- membership_test_wf(S2,H,MemRes,WF), not_disjoint3(MemRes,T,S2,WF).
3652
3653 :- block not_disjoint3(-,?,?,?).
3654 not_disjoint3(pred_true,_,_,_).
3655 not_disjoint3(pred_false,T,S2,WF) :- not_disjoint_sets2(T,S2,WF).
3656
3657 test_disjoint_wf(S1,S2,DisjRes,WF) :-
3658 intersection(S1,S2,Inter,WF), % TODO: could be done more efficiently, without computing full intersection
3659 empty_set_test_wf(Inter,DisjRes,WF).
3660
3661 :- assert_must_succeed(exhaustive_kernel_check_wfdet(intersection_generalized_wf([[int(3)],[int(2),int(1),int(3)]],[int(3)],unknown,WF),WF)).
3662 :- assert_must_succeed(exhaustive_kernel_check_wfdet(intersection_generalized_wf([[int(3),int(2)],[int(2),int(1),int(3)],[int(4),int(3)]],[int(3)],unknown,WF),WF)).
3663 :- assert_must_succeed((kernel_objects:intersection_generalized_wf(avl_set(node(avl_set(node(fd(1,'Name'),true,1,empty,node(fd(2,'Name'),true,0,empty,empty))),
3664 true,1,empty,node(avl_set(node(fd(2,'Name'),true,1,empty,node(fd(3,'Name'),true,0,empty,empty))),true,0,empty,empty))),
3665 avl_set(node(fd(2,'Name'),true,0,empty,empty)),unknown,_WF))).
3666 :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(1)],[int(2)]],Res,unknown,_WF),Res=[])).
3667 :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(1)],[int(2),int(1)]],Res,unknown,_WF),
3668 kernel_objects:equal_object(Res,[int(1)]))).
3669 :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(1)],X,[int(2),int(3),int(1)]],Res,unknown,_WF),
3670 X = [int(2),int(1)],
3671 kernel_objects:equal_object(Res,[int(1)]))).
3672 :- assert_must_succeed((kernel_objects:intersection_generalized_wf([X,X,[int(2),int(3),int(1)]],Res,unknown,_WF),
3673 X = [int(2),int(1)], kernel_objects:equal_object(Res,[int(1),int(2)]))).
3674 :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(2),int(1),int(3)],X,[int(1),int(2)],X],Res,unknown,_WF),
3675 kernel_objects:equal_object(X,Res), X = [int(2),int(1)])).
3676 :- assert_must_succeed((kernel_objects:intersection_generalized_wf([global_set('Name'),X],Res,unknown,_WF),
3677 kernel_objects:equal_object(X,Res), X = [fd(2,'Name'),fd(1,'Name')])).
3678 :- assert_must_fail((kernel_objects:intersection_generalized_wf([[int(1)],[int(2)]],Res,unknown,_WF),(
3679 kernel_objects:equal_object(Res,[_|_])))).
3680 :- assert_must_fail((kernel_objects:intersection_generalized_wf([[int(1)],[int(1)]],Res,unknown,_WF),(Res=[];
3681 kernel_objects:equal_object(Res,[_,_|_])))).
3682 :- assert_must_abort_wf(kernel_objects:intersection_generalized_wf([],_R,unknown,WF),WF).
3683
3684 % code for general_intersection
3685 :- block intersection_generalized_wf(-,?,?,?).
3686 intersection_generalized_wf(SetsOfSets,Res,Span,WF) :-
3687 expand_custom_set_to_list_wf(SetsOfSets,ESetsOfSets,_,intersection_generalized_wf,WF),
3688 intersection_generalized2(ESetsOfSets,Res,Span,WF).
3689
3690 intersection_generalized2([],Res,Span,WF) :- /* Atelier-B manual requires argument to inter to be non-empty */
3691 add_wd_error_set_result('inter applied to empty set','',Res,[],Span,WF).
3692 intersection_generalized2([H|T],Res,_Span,WF) :- intersection_generalized3(T,H,Res,WF).
3693 :- block intersection_generalized3(-,?,?,?).
3694 intersection_generalized3([],SoFar,Res,WF) :- equal_object_optimized_wf(SoFar,Res,intersection_generalized3,WF).
3695 intersection_generalized3([H|T],InterSoFar,Res,WF) :-
3696 intersection(H,InterSoFar,InterSoFar2,WF),
3697 intersection_generalized3(T,InterSoFar2,Res,WF).
3698
3699 :- assert_must_succeed(exhaustive_kernel_check(difference_set([int(3),int(2)],[int(2),int(1),int(3)],[]))).
3700 :- assert_must_succeed(exhaustive_kernel_check(difference_set([int(3),int(2)],[int(2),int(1),int(4)],[int(3)]))).
3701 :- assert_must_succeed((kernel_objects:difference_set(SSS,[[int(1),int(2)]],[]),
3702 kernel_objects:equal_object(SSS,[[int(2),int(1)]]))).
3703 :- assert_must_succeed((kernel_objects:difference_set(SSS,[[int(1),int(2)]],R), kernel_objects:equal_object(R,[]),
3704 kernel_objects:equal_object(SSS,[[int(2),int(1)]]))).
3705 :- assert_must_succeed((kernel_objects:difference_set(SSS,[[fd(1,'Name'),fd(2,'Name')]],R),
3706 kernel_objects:equal_object(R,[]),
3707 kernel_objects:equal_object(SSS,[[fd(2,'Name'),fd(1,'Name')]]))).
3708 :- assert_must_succeed((kernel_objects:difference_set(SSS,[[int(1),int(2)]],[]),
3709 kernel_objects:equal_object(SSS,[[int(1),int(2)]]))).
3710 :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[int(1)],_))).
3711 :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[int(2)],_))).
3712 :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[int(2)],[int(1)]))).
3713 :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[],[int(2),int(1)]))).
3714 :- assert_must_succeed((kernel_objects:difference_set([],[int(1),int(2)],[]))).
3715 :- assert_must_succeed((kernel_objects:difference_set(Y,X,Res),X=global_set('Name'),
3716 kernel_objects:equal_object(Res,[]), Y =[fd(1,'Name')])).
3717 :- assert_must_succeed((kernel_objects:difference_set(X,Y,Res),X=global_set('Name'),
3718 kernel_objects:equal_object(Res,[fd(3,'Name'),fd(1,'Name')]), Y =[fd(2,'Name')])).
3719 :- assert_must_fail((kernel_objects:difference_set(X,Y,Res),X=global_set('Name'),
3720 kernel_objects:equal_object(Res,[]), Y =[fd(1,'Name'),fd(2,'Name')])).
3721 :- assert_must_fail((kernel_objects:difference_set(Y,X,Res),X=global_set('Name'),
3722 kernel_objects:equal_object(Res,Y), Y =[fd(1,'Name')])).
3723
3724 % deals with set_subtraction AST node
3725 difference_set(Set1,Set2,Res) :- init_wait_flags(WF),
3726 ? difference_set_wf(Set1,Set2,Res,WF),
3727 ? ground_wait_flags(WF).
3728
3729 :- block difference_set_wf(-,-,?,?).
3730 difference_set_wf(Set1,_,Res,WF) :- Set1==[],!,empty_set_wf(Res,WF).
3731 difference_set_wf(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,difference_set_wf,WF).
3732 ?difference_set_wf(Set1,Set2,Res,WF) :- difference_set1(Set1,Set2,Res,WF).
3733
3734
3735 :- block difference_set1(?,-,-,?), difference_set1(-,?,-,?).
3736 difference_set1(Set1,Set2,Res,WF) :-
3737 nonvar(Set1),is_custom_explicit_set(Set1,difference_set),
3738 difference_of_explicit_set_wf(Set1,Set2,Diff,WF), !,
3739 equal_object_wf(Diff,Res,difference_set1_1,WF).
3740 difference_set1(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,difference_set1_2,WF).
3741 ?difference_set1(Set1,Set2,Res,WF) :- Res==[],!, check_subset_of_wf(Set1,Set2,WF).
3742 difference_set1(Set1,Set2,Res,WF) :-
3743 expand_custom_set_to_list_wf(Set1,ESet1,_,difference_set1,WF),
3744 compute_diff(ESet1,Set2,Res,WF),
3745 propagate_into2(Res,ESet1,Set2,WF).
3746
3747 :- block compute_diff(-,?,?,?).
3748 compute_diff([],_Set2,Res,WF) :- empty_set_wf(Res,WF).
3749 compute_diff([H|T],Set2,Res,WF) :-
3750 membership_test_wf(Set2,H,MemRes,WF),compute_diff2(MemRes,H,T,Set2,Res,WF).
3751
3752 :- block compute_diff2(-,?,?,?,?,?).
3753 compute_diff2(pred_true,_H,T,Set2,Res,WF) :- compute_diff(T,Set2,Res,WF).
3754 ?compute_diff2(pred_false,H,T,Set2,Res,WF) :- equal_object_wf([H|R2],Res,compute_diff2,WF),
3755 compute_diff(T,Set2,R2,WF).
3756
3757 % propagate all elements from one set into another one; do not use for computation; may skip elements ...
3758 /* this version not used at the moment:
3759 :- block propagate_into(-,?,?).
3760 propagate_into(_,Set2,_WF) :- nonvar(Set2),
3761 is_custom_explicit_set(Set2,propagate_into),!. % second set already fully known
3762 propagate_into([],_,_WF) :- !.
3763 propagate_into([H|T],Set,WF) :- !,check_element_of_wf(H,Set,WF), propagate_into(T,Set,WF).
3764 propagate_into(Set1,Set2,WF) :- is_custom_explicit_set(Set1,propagate_into),!,
3765 (is_infinite_explicit_set(Set1) -> true ;
3766 expand_custom_set_to_list(Set1,ESet1), propagate_into(ESet1,Set2,WF)). */
3767
3768 :- block propagate_into2(-,?,?,?).
3769 propagate_into2(_,Set2,_NegSet,_WF) :- nonvar(Set2),
3770 is_custom_explicit_set(Set2,propagate_into),!. % second set already fully known
3771 propagate_into2([],_,_,_WF) :- !.
3772 propagate_into2([H|T],PosSet,NegSet,WF) :- !,
3773 check_element_of_wf(H,PosSet,WF),
3774 not_element_of_wf(H,NegSet,WF),propagate_into2(T,PosSet,NegSet,WF).
3775 propagate_into2(Set1,PosSet,NegSet,WF) :- is_custom_explicit_set(Set1,propagate_into),!,
3776 (is_infinite_explicit_set(Set1) -> true ;
3777 expand_custom_set_to_list_wf(Set1,ESet1,_,propagate_into2,WF), propagate_into2(ESet1,PosSet,NegSet,WF)).
3778
3779 :- assert_must_succeed(exhaustive_kernel_check_wf(in_difference_set_wf(int(33),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3780 :- block in_difference_set_wf(-,-,-,?).
3781 in_difference_set_wf(A,X,Y,WF) :-
3782 (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)),
3783 % symbolic treatment would also make sense when A is nonvar and X var to force A to be in X ?!
3784 !,
3785 check_element_of_wf(A,X,WF), not_element_of_wf(A,Y,WF).
3786 in_difference_set_wf(A,X,Y,WF) :-
3787 difference_set_wf(X,Y,Diff,WF),
3788 check_element_of_wf(A,Diff,WF).
3789
3790 treat_arg_symbolically(X) :- var(X),!.
3791 treat_arg_symbolically(global_set(_)).
3792 treat_arg_symbolically(freetype(_)).
3793 treat_arg_symbolically(closure(P,T,B)) :- \+ small_interval(P,T,B).
3794
3795 small_interval(P,T,B) :- is_interval_closure(P,T,B,Low,Up),
3796 integer(Low), integer(Up),
3797 Up-Low < 500. % Magic Constant; TO DO: determine good value
3798
3799
3800 :- assert_must_succeed(exhaustive_kernel_check_wf(not_in_difference_set_wf(int(2),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3801 :- assert_must_succeed(exhaustive_kernel_check_wf(not_in_difference_set_wf(int(111),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3802 :- assert_must_succeed(exhaustive_kernel_check_wf(not_in_difference_set_wf(int(1),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3803
3804 :- block not_in_difference_set_wf(-,-,-,?).
3805 not_in_difference_set_wf(A,X,Y,WF) :-
3806 (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)),
3807 !,
3808 % A : (X-Y) <=> A:X & not(A:Y)
3809 % A /: (X-Y) <=> A/: X or A:Y
3810 membership_test_wf(X,A,AX_Res,WF),
3811 (AX_Res==pred_false -> true
3812 ; bool_pred:negate(AX_Res,NotAX_Res),
3813 b_interpreter_check:disjoin(NotAX_Res,AY_Res,pred_true,priority(16384),priority(16384),WF), % better: uese a version that does not do a case split ?! or use last wait flag ?
3814 ? membership_test_wf(Y,A,AY_Res,WF)
3815 ).
3816 not_in_difference_set_wf(A,X,Y,WF) :-
3817 difference_set_wf(X,Y,Diff,WF),
3818 not_element_of_wf(A,Diff,WF).
3819
3820
3821 :- assert_must_succeed(exhaustive_kernel_check_wf(in_intersection_set_wf(int(2),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3822
3823 :- block in_intersection_set_wf(-,-,-,?).
3824 in_intersection_set_wf(A,X,Y,WF) :-
3825 (treat_arg_symbolically(X) ; treat_arg_symbolically(Y)
3826 ; preference(convert_comprehension_sets_into_closures,true)),
3827 (preference(data_validation_mode,true) -> nonvar(X) ; true),
3828 % otherwise we may change enumeration order and enumerate with Y first;
3829 % see private_examples/ClearSy/2019_May/perf_3264/rule_186.mch (but also test 1976);
3830 % we could check if A is ground
3831 !,
3832 Y \== [], % avoid setting up check_element_of for X then
3833 ? check_element_of_wf(A,X,WF), check_element_of_wf(A,Y,WF).
3834 in_intersection_set_wf(A,X,Y,WF) :-
3835 ? intersection(X,Y,Inter,WF),
3836 ? check_element_of_wf(A,Inter,WF).
3837
3838 :- assert_must_succeed(exhaustive_kernel_check_wf(not_in_intersection_set_wf(int(3),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3839 :- block not_in_intersection_set_wf(-,-,-,?).
3840 not_in_intersection_set_wf(_A,_X,Y,_WF) :- Y == [], !. % intersection will be empty; avoid analysing X
3841 not_in_intersection_set_wf(A,X,Y,WF) :-
3842 (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)),
3843 !,
3844 % A : (X /\ Y) <=> A:X & A:Y
3845 % A /: (X /\ Y) <=> A/:X or A/:Y
3846 membership_test_wf(X,A,AX_Res,WF),
3847 (AX_Res==pred_false -> true
3848 ; bool_pred:negate(AX_Res,NotAX_Res), bool_pred:negate(AY_Res,NotAY_Res),
3849 b_interpreter_check:disjoin(NotAX_Res,NotAY_Res,pred_true,priority(16384),priority(16384),WF), % better: uese a version that does not do a case split ?! or use last wait flag ?
3850 membership_test_wf(Y,A,AY_Res,WF)
3851 ).
3852 not_in_intersection_set_wf(A,X,Y,WF) :-
3853 ? intersection(X,Y,Inter,WF),
3854 not_element_of_wf(A,Inter,WF).
3855
3856 :- assert_must_succeed(exhaustive_kernel_check_wf(in_union_set_wf(int(2),[int(33),int(2)],[int(2),int(1),int(3)],WF),WF)).
3857 :- assert_must_succeed(exhaustive_kernel_check_wf(in_union_set_wf(int(33),[int(32),int(2)],[int(2),int(1),int(33)],WF),WF)).
3858
3859 :- block in_union_set_wf(-,-,-,?).
3860 in_union_set_wf(A,X,Y,WF) :-
3861 (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)),
3862 % symbolic treatment would also make sense when A is nonvar and X var to force A to be in X ?!
3863 !,
3864 membership_test_wf(X,A,AX_Res,WF),
3865 (AX_Res==pred_true -> true
3866 ; b_interpreter_check:disjoin(AX_Res,AY_Res,pred_true,priority(16384),priority(16384),WF), % better: use a version that does not do a case split ?! or use last wait flag ?
3867 membership_test_wf(Y,A,AY_Res,WF)
3868 ).
3869 in_union_set_wf(A,X,Y,WF) :-
3870 union_wf(X,Y,Union,WF),
3871 ? check_element_of_wf(A,Union,WF).
3872
3873 :- assert_must_succeed(exhaustive_kernel_check_wf(not_in_union_set_wf(int(3),[int(32),int(2)],[int(2),int(1),int(33)],WF),WF)).
3874
3875 :- block not_in_union_set_wf(-,-,-,?).
3876 not_in_union_set_wf(A,X,Y,WF) :-
3877 not_element_of_wf(A,X,WF),
3878 not_element_of_wf(A,Y,WF).
3879
3880 % ---------------------
3881
3882
3883 strict_subset_of(X,Y) :-
3884 init_wait_flags(WF,[strict_subset_of]),
3885 strict_subset_of_wf(X,Y,WF),
3886 ground_wait_flags(WF).
3887
3888 :- assert_must_succeed(exhaustive_kernel_check(strict_subset_of_wf([int(3),int(2)],[int(2),int(1),int(3)],_))).
3889 :- assert_must_succeed(exhaustive_kernel_check(strict_subset_of_wf([],[int(2),int(1),int(3)],_))).
3890 :- assert_must_succeed(exhaustive_kernel_check(strict_subset_of_wf([],[ [] ],_))).
3891 :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([int(3),int(2),int(1)],[int(2),int(1),int(3)],_))).
3892 :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([int(1),int(4)],[int(2),int(1),int(3)],_))).
3893 :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([[]],[],_))).
3894 :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([],[],_))).
3895 :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [int(1)], X=[int(2),int(1)])).
3896 :- assert_must_succeed((kernel_objects:strict_subset_of(Y,X), Y = [int(1)], X=[int(2),int(1)])).
3897 :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [], X=[int(2),int(1)])).
3898 :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [[int(1),int(2)]], X=[[int(2)],[int(2),int(1)]])).
3899 :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [fd(1,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
3900 :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [fd(3,'Name'),fd(2,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
3901 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))).
3902 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [fd(1,'Name'),fd(3,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
3903 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(1)], X=[int(2),int(1)])).
3904 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(1),int(2)], X=[int(2),int(1)])).
3905 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(2)], X=[int(2)])).
3906 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(2)], X=[int(1)])).
3907 :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [], X=[int(1)])).
3908
3909
3910 :- use_module(chrsrc(chr_set_membership),[chr_subset_strict/2, chr_not_subset_strict/2]).
3911 :- use_module(chrsrc(chr_integer_inequality),[chr_in_interval/4]).
3912
3913 strict_subset_of_wf(Set1,Set2,WF) :-
3914 (preference(use_chr_solver,true) -> chr_subset_strict(Set1,Set2)
3915 ; Set1 \== Set2), % relevant for test 1326
3916 strict_subset_of_wf_aux(Set1,Set2,WF).
3917
3918 %:- block strict_subset_of_wf(-,-,?).
3919 strict_subset_of_wf_aux(Set1,Set2,WF) :- Set1==[],!,not_empty_set_wf(Set2,WF).
3920 %strict_subset_of_wf_aux(Set1,Set2,WF) :- var(Set2),nonvar(Set1), print(subs(Set1,Set2)),nl,fail.
3921 strict_subset_of_wf_aux(Set1,Set2,WF) :- nonvar(Set2), singleton_set(Set2,_),!, empty_set_wf(Set1,WF).
3922 strict_subset_of_wf_aux(Set1,Set2,WF) :-
3923 not_empty_set_wf(Set2,WF),
3924 get_cardinality_powset_wait_flag(Set2,strict_subset_of_wf,WF,_,LWF),
3925 % we could subtract 1 from priority !? (get_cardinality_pow1set_wait_flag)
3926 when(((nonvar(LWF),(nonvar(Set1);ground(Set2))) ; (nonvar(Set1),nonvar(Set2)) ),
3927 strict_subset_of_aux_block(Set1,Set2,WF,LWF)).
3928
3929 strict_subset_of_aux_block(Set1,_Set2,_WF,_LWF) :-
3930 Set1==[],
3931 !. % we have already checked that Set2 is not empty
3932 strict_subset_of_aux_block(Set1,Set2,WF,_LWF) :-
3933 nonvar(Set2), is_definitely_maximal_set(Set2),
3934 !,
3935 not_equal_object_wf(Set1,Set2,WF).
3936 strict_subset_of_aux_block(Set1,Set2,WF,_LWF) :- nonvar(Set2), singleton_set(Set2,_),!,
3937 empty_set_wf(Set1,WF).
3938 strict_subset_of_aux_block(Set1,Set2,_WF,_LWF) :-
3939 both_global_sets(Set1,Set2,G1,G2),
3940 !, %(print(check_strict_subset_of_global_sets(G1,G2)),nl,
3941 check_strict_subset_of_global_sets(G1,G2).
3942 strict_subset_of_aux_block(Set1,Set2,WF,LWF) :-
3943 var(Set1), nonvar(Set2), Set2=avl_set(_),
3944 check_card_waitflag_less(LWF,4097), % if the number is too big strict_subset_of0 has better chance of working ?!
3945 % without avl_set check test 1003 leads to time out for plavis-TransData_SP_13.prob, with
3946 % memp : seq(STRING) & dom(memp) <<: ( mdp + 1 .. ( mdp + 43 ) )
3947 !,
3948 %non_free(Set1), % as we used to force order, now we use equal_object_wf in gen_strict_subsets and no longer need non_free checking
3949 expand_custom_set_to_list_wf(Set2,ESet2,_,strict_subset_of_wf,WF),
3950 gen_strict_subsets(Set1,ESet2,WF).
3951 strict_subset_of_aux_block(Set1,Set2,WF,LWF) :-
3952 ? strict_subset_of0(Set1,Set2,WF,LWF).
3953 % TO DO (26.10.2014): test 1270 now passes thanks to maximal set check above
3954 % but we should need a better way of ensuring that something like {ssu|ssu<<:POW(elements)} is efficiently computed
3955 % (which it no longer is once the unbound_variable check had been fixed)
3956 % we could also just generally use Set1 <: Set2 & Set1 /= Set2
3957
3958 check_card_waitflag_less(float(Nr),Limit) :- number(Nr), Nr<Limit.
3959
3960 % avoid generating different ordering of the same subset ([1,2] and [2,1] for example), useful for test 642
3961 % Note: remove_element_wf in strict_subset_of2 will create different orders
3962 % for sequence domains gen_strict_subsets uses just the wrong order (deciding to remove 1 first);
3963 % cf test 1003 where not including 1 in domain is bad: memp : seq(STRING) & dom(memp) <<: ( mdp + 1 .. ( mdp + 43 ) )
3964 gen_strict_subsets(T,[H2|T2],WF) :-
3965 not_element_of_wf(H2,T,WF),
3966 gen_subsets(T,T2,WF).
3967 gen_strict_subsets(SubSet,[H2|T2],WF) :-
3968 equal_object_wf([H2|T],SubSet,gen_strict_subsets,WF),
3969 gen_strict_subsets(T,T2,WF).
3970
3971
3972 %:- block strict_subset_of0(-,?,?,?). % required to wait: we know Set2 must be non-empty, but Set1 could be an avl-tree or closure
3973 strict_subset_of0(Set1,Set2,WF,_) :-
3974 subset_of_explicit_set(Set1,Set2,Code,WF),!,
3975 call(Code),
3976 not_equal_object_wf(Set1,Set2,WF).
3977 strict_subset_of0(Set1,Set2,WF,LWF) :-
3978 expand_custom_set_to_list_wf(Set1,ESet1,_,strict_subset_of0,WF),
3979 (ESet1==[] -> true %not_empty_set(Set2) already checked above
3980 ? ; is_infinite_explicit_set(Set2) ->
3981 % Set1 is expanded to a list ESet1 and thus finite: it is sufficient to check subset relation
3982 check_subset_of_wf(ESet1,Set2,WF)
3983 ; try_expand_custom_set_wf(Set2,ESet2,strict_subset_of0,WF),
3984 %%try_prop_card_lt(ESet1,ESet2), try_prop_card_gt(ESet2,ESet1),
3985 ? strict_subset_of2(ESet1,[],ESet2,WF,LWF)
3986 ).
3987
3988 :- block strict_subset_of2(-,?,?,?,-).
3989 %strict_subset_of2(S,SoFar,Set2,WF,LWF) :- nl,print(strict_subset_of2(S,SoFar,Set2,WF,LWF)),nl,fail.
3990 strict_subset_of2([],SoFar,RemS,WF,_LWF) :-
3991 not_empty_set_wf(RemS,WF), % check remaining set (elements in Set2 not in Set1) is not empty
3992 disjoint_sets(RemS,SoFar). % ensure we have not accidentally created Set2 with duplicates
3993 % if a duplicate is in RemS, we may not have a strict_subset (test 2480) !
3994 strict_subset_of2([H|T],SoFar,Set2,WF,LWF) :- var(Set2),!,
3995 equal_cons_wf(Set2,H,Set2R,WF), %was Set2 = [H|Set2R],
3996 not_element_of_wf(H,SoFar,WF),
3997 add_new_element_wf(H,SoFar,SoFar2,WF), %was SoFar2 = [H|SoFar],
3998 strict_subset_of2(T,SoFar2,Set2R,WF,LWF).
3999 strict_subset_of2([H|T],SoFar,Set2,WF,LWF) :-
4000 % when_sufficiently_for_member(H,Set2,WF,
4001 ? remove_element_wf(H,Set2,RS2,WF),
4002 not_empty_set_wf(RS2,WF),
4003 not_element_of_wf(H,SoFar,WF), /* consistent((H,SoFar)), necessary? */
4004 when((nonvar(T) ; (ground(LWF),ground(RS2))),
4005 (add_new_element_wf(H,SoFar,SoFar2,WF), %SoFar2 = [H|SoFar],
4006 strict_subset_of2(T,SoFar2,RS2,WF,LWF) )).
4007
4008
4009
4010
4011 :- assert_must_succeed(exhaustive_kernel_check(partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ],_))).
4012 :- assert_must_succeed(exhaustive_kernel_check(partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)] ],_))).
4013 :- assert_must_succeed(exhaustive_kernel_check(partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5)],[int(1)] ],_))).
4014 :- assert_must_succeed(exhaustive_kernel_fail_check(partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)], [int(3)] ],_))).
4015 :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ], _))).
4016 :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2)],[ [int(2)], [int(1)], [] ], _))).
4017 :- assert_must_fail((kernel_objects:partition_wf([int(1),int(2)],[ [int(2)], [int(1),int(2)] ], _))).
4018 :- assert_must_fail((kernel_objects:partition_wf([int(1),int(3)],[ [int(1)], [int(2)] ], _))).
4019 :- assert_must_fail((kernel_objects:partition_wf([int(1),int(2),int(3)],[ [int(1)], [int(2)] ], _))).
4020 :- assert_must_succeed((kernel_objects:partition_wf([int(1)],[S1,S2],_WF), S1=[H|T], S2==[],T==[],H==int(1))).
4021 :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2)],[S1,S2],_WF), S1=[H|T], S2=[int(1)],(preferences:preference(use_clpfd_solver,true) -> T==[],H==int(2) ; T=[],H=int(2)))).
4022 :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2),int(3)],[S1,S2,S3],_WF), S1=[H2|T], S3=[int(3)],T=[H1|TT],H2=int(2),TT==[],S2==[],H1==int(1))).
4023 :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2),int(3)],[[int(1)],X,[int(2)]],_WF),
4024 X==[int(3)])).
4025
4026 :- use_module(bsets_clp,[disjoint_union_generalized_wf/3]).
4027 :- use_module(kernel_tools,[ground_value/1]).
4028 :- block partition_wf(?,-,?).
4029 partition_wf(Set,ListOfSets,WF) :-
4030 ? partition_disj_union_wf(Set,ListOfSets,WF),
4031 all_disjoint(ListOfSets,WF).
4032
4033 % just check that the disjoint union of all sets is equal to Set
4034 partition_disj_union_wf(Set,ListOfSets,WF) :-
4035 ground_value(Set),find_non_ground_set(ListOfSets,NGS,Rest),!,
4036 disjoint_union_generalized_wf(Rest,RestSet,WF),
4037 ? check_subset_of_wf(RestSet,Set,WF), % otherwise this is not a partition of Set
4038 difference_set(Set,RestSet,NGS).
4039 partition_disj_union_wf(Set,ListOfSets,WF) :-
4040 disjoint_union_generalized_wf(ListOfSets,Set,WF).
4041
4042 :- assert_must_succeed((kernel_objects:find_non_ground_set([int(1),int(2),A,int(5)],B,C), B==A,C==[int(1),int(2),int(5)])).
4043 find_non_ground_set([H|T],NG,Rest) :-
4044 (ground_value(H) -> Rest=[H|TR], find_non_ground_set(T,NG,TR)
4045 ; ground_value(T),NG=H, Rest=T).
4046
4047 :- block all_disjoint(-,?).
4048 % check if a list of sets is all disjoint (Note: this is not a set of sets)
4049 all_disjoint([],_WF) :- !.
4050 all_disjoint([H|T],WF) :- !,
4051 all_disjoint_with(T,H,WF),
4052 all_disjoint(T,WF).
4053 all_disjoint(S,WF) :- add_internal_error('Not a list for partition:',all_disjoint(S,WF)),fail.
4054
4055 :- block all_disjoint_with(-,?,?).
4056 all_disjoint_with([],_,_WF).
4057 all_disjoint_with([H|T],Set1,WF) :- disjoint_sets(Set1,H,WF), all_disjoint_with(T,Set1,WF).
4058
4059
4060 % a utility to check for duplicates in set lists and enter debugger
4061 %:- block check_set_for_repetitions(-,?).
4062 %check_set_for_repetitions([],_) :- !.
4063 %check_set_for_repetitions([H|T],Acc) :- !,
4064 % when(ground(H),(member(H,Acc) -> tools:print_bt_message(duplicate(H,Acc)),trace
4065 % ; check_set_for_repetitions(T,[H|Acc]))).
4066 %check_set_for_repetitions(_,_).
4067
4068 :- assert_must_succeed(exhaustive_kernel_fail_check(not_partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ],_))).
4069 :- assert_must_succeed(exhaustive_kernel_fail_check(not_partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)] ],_))).
4070 :- assert_must_succeed(exhaustive_kernel_fail_check(not_partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5)],[int(1)] ],_))).
4071 :- assert_must_succeed(exhaustive_kernel_check(not_partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)], [int(3)] ],_))).
4072 :- assert_must_fail((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ], _))).
4073 :- assert_must_fail((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(2)], [int(1)], [] ], _))).
4074 :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(2)], [int(1),int(2)] ], _))).
4075 :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(3)],[ [int(1)], [int(2)] ], _))).
4076 :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(2),int(3)],[ [int(1)], [int(2)] ], _))).
4077 :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(1),int(2)], [int(1),int(2)] ], _))).
4078
4079 not_partition_wf(FullSet,ListOfSets,WF) :-
4080 ? test_partition_wf(FullSet,ListOfSets,pred_false,WF).
4081
4082
4083 :- use_module(b_interpreter_check,[imply_true/2]). % TODO: move to another module
4084 :- block test_partition_wf(?,-,?,?).
4085 test_partition_wf(FullSet,ListOfSets,PredRes,WF) :-
4086 bool_pred:negate(PredRes,NotPredRes),
4087 propagate_partition_true(FullSet,ListOfSets,PredRes,WF),
4088 ? test_partition_wf2(ListOfSets,[],FullSet,PredRes,NotPredRes,WF).
4089
4090 :- block propagate_partition_true(?,?,-,?).
4091 propagate_partition_true(FullSet,ListOfSets,pred_true,WF) :-
4092 % ensure we propagate more info; required for tests 1059, 1060
4093 partition_disj_union_wf(FullSet,ListOfSets,WF).
4094 propagate_partition_true(_,_,pred_false,_).
4095
4096 :- block test_partition_wf2(-,?,?, ?,?,?).
4097 %test_partition_wf2(Sets,SoFar,_,Pred,_,_) :- print_term_summary(test_partition_wf2(Sets,SoFar,Pred)),nl,fail.
4098 ?test_partition_wf2([],ElementsSoFar,FullSet,PredRes,_,WF) :- !, equality_objects_wf(ElementsSoFar,FullSet,PredRes,WF).
4099 test_partition_wf2([Set1|Rest],ElementsSoFar,FullSet,PredRes,NotPredRes,WF) :- !,
4100 expand_custom_set_to_list_wf(Set1,ESet1,_,test_partition_wf2,WF), % TODO: requires finite set; choose instantiated sets first
4101 ? test_partition_wf3(ESet1,ElementsSoFar,ElementsSoFar,Rest,FullSet,PredRes,NotPredRes,WF).
4102 test_partition_wf2(A,E,FS,PR,NPR,WF) :-
4103 add_internal_error('Not a list for partition:',test_partition_wf2(A,E,FS,PR,NPR,WF)),fail.
4104
4105 :- block test_partition_wf3(-,?,?,?, ?,?,?,?).
4106 test_partition_wf3([],_,NewElementsSoFar,OtherSets,FullSet,PredRes,NPR,WF) :-
4107 ? test_partition_wf2(OtherSets,NewElementsSoFar,FullSet,PredRes,NPR,WF). % finished treating this set
4108 test_partition_wf3([H|T],ElementsSoFar,NewElementsSoFar,OtherSets,FullSet,PredRes,NotPredRes,WF) :-
4109 imply_true(MemRes,NotPredRes), % if not disjoint (MemRes=pred_true) then we do not have a partition
4110 membership_test_wf(ElementsSoFar,H,MemRes,WF),
4111 ? test_partition_wf4(MemRes,H,T,ElementsSoFar,NewElementsSoFar,OtherSets,FullSet,PredRes,NotPredRes,WF).
4112
4113 :- block test_partition_wf4(-,?,?,?,?, ?,?,?,?,?).
4114 test_partition_wf4(pred_true,_,_,_,_,_,_,pred_false,_,_). % Not disjoint
4115 test_partition_wf4(pred_false,H,T,ElementsSoFar,NewElementsSoFar,OtherSets,FullSet,PredRes,NotPredRes,WF) :-
4116 add_element_wf(H,NewElementsSoFar,NewElementsSoFar2,WF), % we could also already check whether H in FullSet or not
4117 %(PredRes==pred_true -> check_element_of_wf(H,FullSet,WF) ; true),
4118 ? test_partition_wf3(T,ElementsSoFar,NewElementsSoFar2,OtherSets,FullSet,PredRes,NotPredRes,WF).
4119
4120
4121
4122 :- assert_must_succeed(exhaustive_kernel_succeed_check(check_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1),int(3)]))).
4123 :- assert_must_succeed(exhaustive_kernel_succeed_check(check_subset_of([int(1),int(2),int(5)],[int(2),int(5),int(1)]))).
4124 :- assert_must_succeed(exhaustive_kernel_fail_check(check_subset_of([int(1),int(3),int(5)],[int(2),int(5),int(1)]))).
4125 :- assert_must_succeed((kernel_objects:power_set(global_set('Name'),PS),kernel_objects:check_subset_of(X,PS),
4126 kernel_objects:equal_object(X,[[fd(2,'Name'),fd(1,'Name')]]))).
4127 :- assert_must_succeed(findall(X,kernel_objects:check_subset_of(X,[[int(1),int(2)],[]]),[_1,_2,_3,_4])).
4128 :- assert_must_succeed((kernel_objects:check_subset_of(X,[[int(1),int(2)],[]]),
4129 nonvar(X),
4130 kernel_objects:equal_object(X,[[int(2),int(1)]]))).
4131 :- assert_must_succeed((kernel_objects:check_subset_of_wf(Y,X,_WF), Y = [fd(1,'Name')],
4132 nonvar(X),X=[H|T], var(T), H==fd(1,'Name'), X=Y)).
4133 :- assert_must_succeed((kernel_objects:check_subset_of(Y,X), Y = [fd(1,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
4134 :- assert_must_succeed((kernel_objects:check_subset_of(Y,X), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
4135 :- assert_must_succeed((kernel_objects:check_subset_of(X,Y), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
4136 :- assert_must_succeed((kernel_objects:sample_closure(C),kernel_objects:check_subset_of(C,global_set('NAT')))).
4137 :- assert_must_succeed((kernel_objects:check_subset_of(global_set('NAT'),global_set('NAT')))).
4138 :- assert_must_succeed((kernel_objects:check_subset_of(global_set('NAT'),global_set('NATURAL')))).
4139 :- assert_must_fail((kernel_objects:check_subset_of(global_set('NAT'),global_set('NATURAL1')))).
4140 :- assert_must_fail((kernel_objects:check_subset_of(global_set('NAT'),global_set('NAT1')))).
4141 :- assert_must_fail((kernel_objects:check_subset_of(X,Y), Y = [fd(1,'Name')], kernel_objects:equal_object(X,global_set('Name')))).
4142 /* TO DO: add special treatment for closures and type checks !! */
4143
4144 check_subset_of(Set1,Set2) :- init_wait_flags(WF),
4145 ? check_subset_of_wf(Set1,Set2,WF),
4146 ? ground_wait_flags(WF).
4147
4148 check_finite_subset_of_wf(Set1,Set2,WF) :-
4149 check_subset_of_wf(Set1,Set2,WF),
4150 is_finite_set_wf(Set1,WF).
4151
4152 :- block check_subset_of_wf(-,-,?).
4153 check_subset_of_wf(Set1,Set2,WF) :-
4154 (both_global_sets(Set1,Set2,G1,G2)
4155 -> check_subset_of_global_sets(G1,G2)
4156 ? ; check_subset_of0(Set1,Set2,WF)
4157 ).
4158
4159 both_global_sets(S1,S2,G1,G2) :- nonvar(S1),nonvar(S2),
4160 is_global_set(S1,G1), is_global_set(S2,G2).
4161
4162 % check if we have a global set or interval
4163 % is_global_set([],R) :- !, R=interval(0,-1). % useful ???
4164 is_global_set(global_set(G1),R) :- !,
4165 (custom_explicit_sets:get_integer_set_interval(G1,Low,Up) -> R=interval(Low,Up) ; R=G1).
4166 is_global_set(Closure,R) :-
4167 custom_explicit_sets:is_interval_closure_or_integerset(Closure,Low,Up),!,
4168 R=interval(Low,Up).
4169
4170
4171 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(0,0),interval(minus_inf,inf))).
4172 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(-200,1000),interval(minus_inf,inf))).
4173 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(10,1000),interval(0,inf))).
4174 :- assert_must_fail(kernel_objects:check_subset_of_global_sets(interval(-10,1000),interval(0,inf))).
4175 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(0,inf),interval(0,inf))).
4176 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(0,inf),interval(minus_inf,inf))).
4177 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(1,inf),interval(0,inf))).
4178 :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(1,inf),interval(minus_inf,inf))).
4179
4180 % to do: also extend to allow intervals with inf/minus_inf
4181 check_subset_of_global_sets(X,Y) :- (var(X) ; var(Y)),
4182 add_internal_error('Illegal call: ',check_subset_of_global_sets(X,Y)),fail.
4183 check_subset_of_global_sets(interval(Low1,Up1),interval(Low2,Up2)) :- !,
4184 interval_subset(Low1,Up1,Low2,Up2).
4185 check_subset_of_global_sets(X,X) :- !. % both args must be atomic and ground (global set names)
4186 % BUT WE COULD HAVE {x|x>0} <: NATURAL1 ? interval(0,inf) <: NATURAL1
4187 check_subset_of_global_sets(X,Y) :- check_strict_subset_of_global_sets(X,Y).
4188
4189 % To do: perform some treatment of inf, minus_inf values here <----
4190 interval_subset(Low1,Up1,Low2,Up2) :-
4191 (var(Low1) ; var(Up1)), % otherwise we can use code below
4192 finite_interval(Low1,Up1), finite_interval(Low2,Up2), % inf can appear as term; but only directly not later
4193 !,
4194 % Maybe to do: try to avoid CLPFD overflows if possible; pass WF to force case distinction between empty/non-empty intervals
4195 clpfd_in_interval(Low1,Up1,Low2,Up2).
4196 interval_subset(Low1,Up1,Low2,Up2) :-
4197 interval_subset_aux(Low1,Up1,Low2,Up2).
4198
4199 % check if we have a finite interval (fails for inf/minus_inf terms)
4200 finite_interval(Low1,Up1) :- (var(Low1) -> true ; integer(Low1)), (var(Up1) -> true ; integer(Up1)).
4201 finite_val(LowUp) :- (var(LowUp) -> true ; integer(LowUp)).
4202
4203
4204
4205 % assert Low1..Up1 <: Low2..Up2
4206 clpfd_in_interval(Low1,Up1,Low2,Up2) :-
4207 (preferences:preference(use_chr_solver,true)
4208 -> chr_in_interval(Low1,Up1,Low2,Up2) ; true),
4209 % TO DO: improve detection of Low1 #=< Up1; maybe outside of CHR ?; we could also add a choice point here
4210 % example: p..q <: 0..25 & p<q -> should constrain p,q to p:0..24 & q:1..25
4211 clpfd_interface:post_constraint2((Low1 #=< Up1) #=> ((Low2 #=< Low1) #/\ (Up1 #=< Up2)),Posted),
4212 (Posted==true -> true ; interval_subset_aux(Low1,Up1,Low2,Up2)).
4213
4214 :- block interval_subset_aux(-,?,?,?), interval_subset_aux(?,-,?,?).
4215 interval_subset_aux(Low1,Up1,_,_) :- safe_less_than_with_inf(Up1,Low1). %Set 1 is empty.
4216 interval_subset_aux(Low1,Up1,Low2,Up2) :-
4217 safe_less_than_equal_with_inf(Low1,Up1), % Set 1 is not empty
4218 safe_less_than_equal_with_inf_clpfd(Low2,Low1), safe_less_than_equal_with_inf_clpfd(Up1,Up2). % may call CLPFD
4219
4220 % a version of safe_less_than which allows minus_inf and inf, but only if those terms appear straightaway at the first call
4221 % assumes any variable will only be bound to a number
4222 safe_less_than_with_inf(X,Y) :- (X==Y ; X==inf ; Y==minus_inf), !,fail.
4223 safe_less_than_with_inf(X,Y) :- (X==minus_inf ; Y==inf), !.
4224 safe_less_than_with_inf(X,Y) :- safe_less_than(X,Y).
4225
4226 safe_less_than_with_inf_clpfd(X,Y) :- (X==Y ; X==inf ; Y==minus_inf), !,fail.
4227 safe_less_than_with_inf_clpfd(X,Y) :- (X==minus_inf ; Y==inf), !.
4228 safe_less_than_with_inf_clpfd(X,Y) :- less_than_direct(X,Y). % this can also call CLPFD
4229
4230 % a version of safe_less_than_equal which allows minus_inf and inf, but only if those terms appear straightaway at the first call
4231 safe_less_than_equal_with_inf(X,Y) :- X==Y,!.
4232 safe_less_than_equal_with_inf(X,Y) :- (X==inf ; Y==minus_inf), !,fail.
4233 safe_less_than_equal_with_inf(X,Y) :- (X==minus_inf ; Y==inf), !.
4234 safe_less_than_equal_with_inf(X,Y) :- safe_less_than_equal(X,Y).
4235
4236 safe_less_than_equal_with_inf_clpfd(X,Y) :- X==Y,!.
4237 safe_less_than_equal_with_inf_clpfd(X,Y) :- (X==inf ; Y==minus_inf), !,fail.
4238 safe_less_than_equal_with_inf_clpfd(X,Y) :- (X==minus_inf ; Y==inf), !.
4239 safe_less_than_equal_with_inf_clpfd(X,Y) :- less_than_equal_direct(X,Y). % this can also call CLPFD
4240
4241 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,2),interval(1,3))).
4242 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,1),interval(1,2))).
4243 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,1),interval(0,1))).
4244 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(2,1),interval(33,34))).
4245 :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(3,1),interval(4,2))).
4246 :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(3,1),interval(2,1))).
4247 :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(1,2),interval(1,2))).
4248 :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(1,2),interval(2,3))).
4249 :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(2,3),interval(1,2))).
4250 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(0,1000),interval(0,inf))).
4251 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,1000),interval(1,inf))).
4252 :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(-200,1000),interval(minus_inf,inf))).
4253 % for any other term we have global enumerated or deferred sets: they cannot be a strict subset of each other
4254 check_strict_subset_of_global_sets('FLOAT','REAL').
4255 check_strict_subset_of_global_sets(interval(Low1,Up1),interval(Low2,Up2)) :-
4256 ? check_strict_subset_intervals(Low1,Up1,Low2,Up2).
4257
4258 check_strict_subset_intervals(Low1,Up1,Low2,Up2) :-
4259 safe_less_than_equal_with_inf_clpfd(Low2,Up2), % Low2..Up2 not empty
4260 ? check_strict_subset_intervals1(Low1,Up1,Low2,Up2).
4261
4262 check_strict_subset_intervals1(Low1,Up1,Low2,Up2) :- % we cannot have inf as term (yet) here
4263 %preferences:preference(use_clpfd_solver,true),
4264 (var(Low1) ; var(Up1)),
4265 finite_interval(Low1,Up1), finite_interval(Low2,Up2),
4266 !,
4267 clpfd_interface:post_constraint2((Low1 #=< Up1) #=> ((Low2 #=< Low1) #/\ (Up1 #=< Up2) #/\ (Low1 #\= Low2 #\/ Up1 #\= Up2)),Posted),
4268 (Posted==true -> true ; check_strict_subset_intervals2(Low1,Up1,Low2,Up2)).
4269 ?check_strict_subset_intervals1(Low1,Up1,Low2,Up2) :- check_strict_subset_intervals2(Low1,Up1,Low2,Up2).
4270
4271 :- block check_strict_subset_intervals2(-,?,?,?),check_strict_subset_intervals2(?,-,?,?),
4272 check_strict_subset_intervals2(?,?,-,?).
4273 check_strict_subset_intervals2(Low1,Up1,_,_) :- safe_less_than_with_inf(Up1,Low1). % interval 1 empty
4274 check_strict_subset_intervals2(Low1,Up1,Low2,Up2) :-
4275 safe_less_than_equal_with_inf(Low1,Up1), % interval 1 not empty
4276 ( safe_less_than_with_inf(Low2,Low1), safe_less_than_equal_with_inf_clpfd(Up1,Up2)
4277 ;
4278 Low1=Low2,safe_less_than_with_inf_clpfd(Up1,Up2)
4279 ).
4280
4281 :- use_module(custom_explicit_sets,[is_definitely_maximal_set/1,singleton_set/2]).
4282 :- use_module(kernel_tools,[ground_value_check/2, quick_same_value/2]).
4283
4284 check_subset_of0(Set1,_Set2,_WF) :- Set1==[],!.
4285 check_subset_of0(Set1,Set2,WF) :- Set2==[],
4286 %nonvar(Set2),Set2=[], %var(Set1),
4287 !,
4288 empty_set_wf(Set1,WF).
4289 check_subset_of0(_Set1,Set2,_WF) :-
4290 nonvar(Set2),is_definitely_maximal_set(Set2),!.
4291 %singleton
4292 check_subset_of0(Set1,Set2,_) :-
4293 quick_same_value(Set1,Set2), % important for e.g. test 1948 for closures with different info fields
4294 !.
4295 check_subset_of0(Set1,Set2,WF) :- custom_explicit_sets:singleton_set(Set1,El),!,
4296 ? check_element_of_wf(El,Set2,WF).
4297 check_subset_of0(Set1,Set2,WF) :- % Note: two intervals are treated in check_subset_of_global_sets
4298 subset_of_explicit_set(Set1,Set2,Code,WF),!,
4299 ? call(Code).
4300 check_subset_of0(Set1,Set2,WF) :- nonvar(Set1),!,
4301 get_cardinality_powset_wait_flag(Set2,check_subset_of0,WF,_,LWF),
4302 expand_custom_set_to_list_wf(Set1,ESet1,_,check_subset_of1,WF),
4303 try_expand_and_convert_to_avl_unless_large_wf(Set2,ESet2,WF),
4304 % b_interpreter_components:observe_instantiation(ESet1,'ESet1',ESet1),
4305 ? check_subset_of2(ESet1,[],ESet2,WF,LWF,none).
4306 check_subset_of0(Set1,Set2,WF) :-
4307 is_wait_flag_info(WF,wfx_no_enumeration),!,
4308 check_subset_of0_lwf(Set1,Set2,WF,_LWF,_).
4309 check_subset_of0(Set1,Set2,WF) :-
4310 % DO we need LWF if Set1=avl_set(_) ??
4311 get_cardinality_powset_wait_flag(Set2,check_subset_of0,WF,_Card,LWF),
4312 ground_value_check(Set2,GS2),
4313 ? check_subset_of0_lwf(Set1,Set2,WF,LWF,GS2).
4314
4315 :- use_module(custom_explicit_sets,[is_infinite_or_very_large_explicit_set/2]).
4316
4317 :- block check_subset_of0_lwf(-,?,?,-,?),check_subset_of0_lwf(-,?,?,?,-).
4318 check_subset_of0_lwf(Set1,_Set2,_WF,_LWF,_GS2) :- Set1==[],!.
4319 %check_subset_of0_lwf(Set1,Set2,WF,_LWF) :- Set2==[],!, % can never trigger as Set2 was already nonvar
4320 % empty_set_wf(Set1,WF).
4321 check_subset_of0_lwf(Set1,Set2,WF,_LWF,_GS2) :- custom_explicit_sets:singleton_set(Set1,El),!,
4322 check_element_of_wf(El,Set2,WF).
4323 check_subset_of0_lwf(Set1,Set2,_WF,_,_) :-
4324 both_global_sets(Set1,Set2,G1,G2),!, % may now succeed compared to same check above, as Set1/Set2 now instantiated
4325 check_subset_of_global_sets(G1,G2).
4326 check_subset_of0_lwf(Set1,Set2,WF,_LWF,_GS2) :- % Note: two intervals are treated in check_subset_of_global_sets
4327 nonvar(Set1), % otherwise we have already checked this code above
4328 subset_of_explicit_set(Set1,Set2,Code,WF),!,
4329 call(Code).
4330 check_subset_of0_lwf(Set1,Set2,WF,LWF,_GS2) :-
4331 (nonvar(Set1) ; nonvar(Set2),dont_expand_this_explicit_set(Set2)),
4332 !,
4333 expand_custom_set_to_list_wf(Set1,ESet1,_,check_subset_of1,WF),
4334 try_expand_and_convert_to_avl_unless_large_wf(Set2,ESet2,WF),
4335 % b_interpreter_components:observe_instantiation(ESet1,'ESet1',ESet1),
4336 ? check_subset_of2(ESet1,[],ESet2,WF,LWF,none).
4337 check_subset_of0_lwf(Set1,Set2,WF,_LWF,_GS2) :-
4338 expand_custom_set_to_list_wf(Set2,ESet2,_,check_subset_of0_lwf,WF), % Set2 is ground
4339 % THIS WILL ENUMERATE, for something like dom(f) <: SET this is problematic, as information cannot be used
4340 % hence we use wfx_no_enumeration above
4341 %non_free(Set1), % we used to enumerate Set1 in a specific order ESet2; now we use equal_object_wf and we no longer need to mark Set1 as non-free ?
4342 ? gen_subsets(Set1,ESet2,WF).
4343
4344 :- block check_subset_of2(-,?,?,?,-, ?).
4345 check_subset_of2([],_SoFar,_Set2,_WF,_LWF,_Last).
4346 check_subset_of2(HT,SoFar,Set2,WF,LWF,Last) :-
4347 (var(HT),Set2 = avl_set(AVL)
4348 -> % the value is chosen by the enumerator
4349 ? custom_explicit_sets:safe_avl_member(H,AVL),
4350 % this forces H to be ground; if Last /= none then it will be ground
4351 (Last==none -> true ; Last @< H),
4352 % TO DO: we could write a safe_avl_member_greater_than(H,Last,AVL)
4353 not_element_of_wf(H,SoFar,WF),
4354 NewLast=H,
4355 HT = [H|T]
4356 ; % the value may have been chosen by somebody else or will not be enumerated in order below
4357 HT = [H|T],
4358 not_element_of_wf(H,SoFar,WF),
4359 ? check_element_of_wf_lwf(H,Set2,WF,LWF),
4360 %check_element_of_wf(H,Set2,WF),
4361
4362 NewLast = Last
4363 ),
4364 ? check_subset_of3(H,T,SoFar,Set2,WF,LWF,NewLast).
4365
4366 % TO DO: write specific subsets code for avl_set(Set2) + try expand when becomes ground; merge with enumerate_tight_set ,...
4367 % TO DO: ensure that it also works with global_set(T) instead of avl_set(_) or with interval closures
4368
4369
4370 :- block check_subset_of3(?,-,-,?,?,-,?), check_subset_of3(?,-,?,-,?,-,?), check_subset_of3(?,-,-,-,?,?,?).
4371 check_subset_of3(_,T,_,_Set2,_WF,_LWF,_) :- T==[],!.
4372 check_subset_of3(H,T,SoFar,Set2,WF,LWF,Last) :- var(T),!,
4373 % Sofar, Set2 and LWF must be set
4374 ? when((nonvar(T);(ground(Set2),ground(H),ground(SoFar))),
4375 (T==[] -> true
4376 ; add_new_element_wf(H,SoFar,SoFar2,WF), %SoFar2 = [H|SoFar],
4377 check_subset_of2(T,SoFar2,Set2,WF,LWF,Last))).
4378 check_subset_of3(H,T,SoFar,Set2,WF,LWF,Last) :-
4379 % T must be set and not equal to []
4380 T = [H2|T2],
4381 add_new_element_wf(H,SoFar,SoFar2,WF), %SoFar2 = [H|SoFar],
4382 %check_subset_of2(T,SoFar2,Set2,WF,LWF))),
4383 ? check_element_of_wf(H2,Set2,WF),
4384 not_element_of_wf(H2,SoFar2,WF),
4385 ? check_subset_of3(H2,T2,SoFar2,Set2,WF,LWF,Last).
4386
4387
4388 :- block gen_subsets(?,-,?).
4389 gen_subsets([],_,_).
4390 gen_subsets(SubSet,Set,WF) :-
4391 ? ordered_delete(DH,Set,NewSet),
4392 equal_object_wf([DH|T],SubSet,gen_subsets,WF),
4393 ? gen_subsets(T,NewSet,WF).
4394
4395 % note: this is not select/3
4396 ordered_delete(H,[H|T],T).
4397 ?ordered_delete(H,[_|T],R) :- ordered_delete(H,T,R).
4398
4399
4400 :- assert_must_succeed(exhaustive_kernel_check_wf(check_finite_non_empty_subset_of_wf([int(1),int(5)], [int(2),int(5),int(1),int(3)],WF),WF)).
4401 :- assert_must_succeed(exhaustive_kernel_check_wf(check_finite_non_empty_subset_of_wf([int(1),int(5)], [int(5),int(1)],WF),WF)).
4402 check_finite_non_empty_subset_of_wf(Set1,Set2,WF) :-
4403 ? check_non_empty_subset_of_wf(Set1,Set2,WF),
4404 is_finite_set_wf(Set1,WF).
4405
4406 :- assert_must_succeed(exhaustive_kernel_check_wf(check_non_empty_subset_of_wf([int(1),int(5)], [int(2),int(5),int(1),int(3)],WF),WF)).
4407 :- assert_must_succeed(exhaustive_kernel_fail_check_wfdet(check_non_empty_subset_of_wf([int(2)], [int(5),int(1)],WF),WF)).
4408 :- assert_must_succeed(exhaustive_kernel_fail_check_wfdet(check_non_empty_subset_of_wf([], [int(1)],WF),WF)).
4409
4410 check_non_empty_subset_of_wf(S1,S2,WF) :- not_empty_set_wf(S1,WF),
4411 ? check_subset_of_wf(S1,S2,WF).
4412
4413 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_subset_of([int(1),int(2),int(5)], [int(2),int(4),int(1),int(3)]))).
4414 :- assert_must_succeed(exhaustive_kernel_fail_check(not_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1),int(3)]))).
4415 :- assert_must_succeed((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name')], X=global_set('Name'))).
4416 :- assert_must_succeed((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name')], X=[fd(2,'Name')])).
4417 :- assert_must_succeed((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name')], X=[fd(1,'Name'),fd(2,'Name')])).
4418 :- assert_must_fail((kernel_objects:not_subset_of(Y,X), Y = [fd(1,'Name'),fd(3,'Name')], X=global_set('Name'))).
4419 :- assert_must_fail((kernel_objects:not_subset_of(Y,X), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))).
4420 :- assert_must_fail((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))).
4421 :- assert_must_fail((kernel_objects:not_subset_of(global_set('NAT'),global_set('NAT')))).
4422 :- assert_must_succeed((kernel_objects:not_subset_of(global_set('NAT'),global_set('NAT1')))).
4423
4424
4425 not_subset_of(Set1,Set2) :- init_wait_flags(WF),
4426 not_subset_of_wf(Set1,Set2,WF),
4427 ground_wait_flags(WF).
4428
4429 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf([int(1),int(2),int(5)], [int(2),int(4),int(1),int(3)],_WF))).
4430 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf(global_set('NATURAL'), global_set('INTEGER'),_WF))).
4431 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf(global_set('INTEGER'), global_set('INTEGER'),_WF))).
4432 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf([int(1)], [],_WF))).
4433
4434 :- block not_finite_subset_of_wf(-,?,?).
4435 not_finite_subset_of_wf(Set1,Set2,WF) :- test_finite_set_wf(Set1,Finite,WF),
4436 not_finite_subset_of_wf_aux(Finite,Set1,Set2,WF).
4437 :- block not_finite_subset_of_wf_aux(-,?,?,?).
4438 not_finite_subset_of_wf_aux(pred_false,_Set1,_Set2,_WF).
4439 not_finite_subset_of_wf_aux(pred_true,Set1,Set2,WF) :- not_subset_of_wf(Set1,Set2,WF).
4440
4441 :- block not_subset_of_wf(-,?,?).
4442 not_subset_of_wf([],_,_WF) :- !, fail.
4443 not_subset_of_wf(Set1,Set2,WF) :- Set2==[],!, not_empty_set_wf(Set1,WF).
4444 not_subset_of_wf(Set1,Set2,WF) :-
4445 (both_global_sets(Set1,Set2,G1,G2) % also catches intervals
4446 -> check_not_subset_of_global_sets(G1,G2)
4447 ; not_subset_of_wf1(Set1,Set2,WF)
4448 ).
4449 not_subset_of_wf1(_Set1,Set2,_WF) :-
4450 nonvar(Set2), is_definitely_maximal_set(Set2),!,fail.
4451 not_subset_of_wf1(Set1,Set2,_WF) :- quick_same_value(Set1,Set2),
4452 !, fail.
4453 not_subset_of_wf1(Set1,Set2,WF) :- custom_explicit_sets:singleton_set(Set1,El),!,
4454 not_element_of_wf(El,Set2,WF).
4455 ?not_subset_of_wf1(Set1,Set2,WF) :- not_subset_of_explicit_set(Set1,Set2,Code,WF),!,
4456 call(Code).
4457 not_subset_of_wf1(Set1,Set2,WF) :-
4458 expand_custom_set_to_list_wf(Set1,ESet1,_,not_subset_of_wf1,WF),
4459 not_subset_of2(ESet1,Set2,WF).
4460
4461
4462 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(0,2),interval(1,3))).
4463 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(1,2),interval(0,-1))).
4464 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(1,2),interval(4,3))).
4465 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(1,3))).
4466 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(1,9000),interval(2,9999))).
4467 :- assert_must_succeed((kernel_objects:check_not_subset_of_global_sets(interval(X2,X4),interval(1,3)),
4468 X2=2, X4=4)).
4469 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(1,4))).
4470 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(2,4))).
4471 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(0,10))).
4472 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(0,2),interval(1,inf))).
4473 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(-1,2),interval(0,inf))).
4474 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,2),interval(1,inf))).
4475 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(0,2),interval(0,inf))).
4476 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(-1,2),interval(minus_inf,inf))).
4477 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(0,inf),interval(1,inf))).
4478 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(minus_inf,inf),interval(1,inf))).
4479 :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(minus_inf,inf),interval(0,inf))).
4480 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,inf),interval(minus_inf,inf))).
4481 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,inf),interval(1,inf))).
4482 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,inf),interval(0,inf))).
4483 :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(0,inf),interval(0,inf))).
4484
4485 :- block check_not_subset_of_global_sets(-,?), check_not_subset_of_global_sets(?,-).
4486 check_not_subset_of_global_sets(interval(Low1,Up1),G2) :- !,
4487 safe_less_than_equal_with_inf_clpfd(Low1,Up1), % Set 1 is not empty; otherwise it will always be a subset
4488 not_subset_interval_gs_aux(G2,Low1,Up1).
4489 check_not_subset_of_global_sets(G1,G2) :-
4490 \+ check_subset_of_global_sets(G1,G2).
4491
4492 not_subset_interval_gs_aux(interval(Low2,Up2),Low1,Up1) :-
4493 finite_interval(Low1,Up1), finite_interval(Low2,Up2),
4494 !,
4495 % post_constraint2((Low1 #<Low2 #\/ Up1 #> Up2 #\/ Up2 #< Low1),Posted), %% X #<100 #\/ X#<0. does not constraint X ! but X #<max(100,0) does
4496 post_constraint2((Low1 #<Low2 #\/ Up2 #< max(Up1,Low1)),Posted),
4497 (Posted==true -> true ; not_interval_subset(Low1,Up1,Low2,Up2)).
4498 not_subset_interval_gs_aux(interval(Low2,Up2),Low1,Up1) :- !, not_interval_subset(Low1,Up1,Low2,Up2).
4499 not_subset_interval_gs_aux(GS2,Low1,Up1) :-
4500 when((nonvar(Low1),nonvar(Up1)), \+ check_subset_of_global_sets(interval(Low1,Up1),GS2)).
4501
4502 not_interval_subset(Val1,Up1,Low2,Up2) :- var(Val1), Val1==Up1,
4503 !, % better propagation for singleton set
4504 (Up2==inf -> Low2\==minus_inf, less_than_direct(Val1,Low2)
4505 ; Low2=minus_inf -> less_than_direct(Up2,Val1)
4506 ; not_in_nat_range(int(Val1),int(Low2),int(Up2))).
4507 not_interval_subset(Low1,_,Low2,Up2) :- Up2==inf, finite_val(Low2), finite_val(Low1),
4508 % typical case x..y /<: NATURAL <==> x < 0
4509 !,
4510 less_than_direct(Low1,Low2).
4511 not_interval_subset(_,Up1,Low2,Up2) :- Low2==minus_inf, finite_val(Up2), finite_val(Up1),
4512 % covers x..y /<: {x|x<=0} <==> y > 0
4513 !,
4514 less_than_direct(Up2,Up1).
4515 not_interval_subset(Low1,Up1,Low2,Up2) :- not_interval_subset_block(Low1,Up1,Low2,Up2).
4516 :- block not_interval_subset_block(-,?,?,?), not_interval_subset_block(?,-,?,?),
4517 not_interval_subset_block(?,?,-,?), not_interval_subset_block(?,?,?,-).
4518 not_interval_subset_block(Low1,Up1,Low2,Up2) :- % this could be decided earlier, e.g. 1..n /<: 1..inf is false
4519 \+ interval_subset(Low1,Up1,Low2,Up2).
4520
4521
4522 :- block not_subset_of2(-,?,?).
4523 not_subset_of2([H|T],Set2,WF) :-
4524 (T==[]
4525 -> not_element_of_wf(H,Set2,WF)
4526 ; membership_test_wf(Set2,H,MemRes,WF),
4527 propagate_empty_set_to_pred_false(T,MemRes), % if T becomes empty, we know that H must not be in Set2
4528 not_subset_of3(MemRes,T,Set2,WF)
4529 ).
4530
4531 :- block not_subset_of3(-,?,?,?).
4532 not_subset_of3(pred_false,_T,_Set2,_WF).
4533 not_subset_of3(pred_true,T,Set2,WF) :- not_subset_of2(T,Set2,WF).
4534
4535 :- block propagate_empty_set_to_pred_false(-,-).
4536 propagate_empty_set_to_pred_false(X,PredRes) :- X==[],!,PredRes=pred_false.
4537 propagate_empty_set_to_pred_false(_,_).
4538
4539 :- assert_must_succeed(exhaustive_kernel_check_wf(not_both_subset_of([int(1),int(2),int(5)], []
4540 ,[int(2),int(4),int(1),int(3)],[],WF),WF)).
4541 :- assert_must_succeed(exhaustive_kernel_check_wf(not_both_subset_of([int(1),int(2),int(5)], [int(3)],
4542 [int(2),int(5),int(1),int(3)],[int(1),int(4)],WF),WF)).
4543
4544 not_both_subset_of(Set1A,Set1B, Set2A,Set2B, WF) :-
4545 kernel_equality:subset_test(Set1A,Set2A,Result,WF), % not yet implemented ! % TODO ! -> sub_set,equal,super_set
4546 not_both_subset_of_aux(Result,Set1B,Set2B,WF).
4547
4548 :- block not_both_subset_of_aux(-,?,?,?).
4549 not_both_subset_of_aux(pred_false,_Set1B,_Set2B,_WF).
4550 not_both_subset_of_aux(pred_true,Set1B,Set2B,WF) :-
4551 not_subset_of_wf(Set1B,Set2B,WF).
4552
4553 /***********************************/
4554 /* not_strict_subset_of(Set1,Set2) */
4555 /* Set1 /<<: Set2 */
4556 /**********************************/
4557
4558
4559 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_strict_subset_of([int(1),int(2),int(5)], [int(2),int(4),int(1),int(3)]))).
4560 :- assert_must_succeed(exhaustive_kernel_succeed_check(not_strict_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1)]))).
4561 :- assert_must_succeed(exhaustive_kernel_fail_check(not_strict_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1),int(3)]))).
4562 :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [int(1)], X=[int(2),int(1)])).
4563 :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [], X=[int(2),int(1)])).
4564 :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [[int(1),int(2)]], X=[[int(2)],[int(2),int(1)]])).
4565 :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [fd(1,'Name')], X=global_set('Name'))).
4566 :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))).
4567 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))).
4568 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [fd(1,'Name'),fd(3,'Name')], X=global_set('Name'))).
4569 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(1)], X=[int(2),int(1)])).
4570 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(1),int(2)], X=[int(2),int(1)])).
4571 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(2)], X=[int(2)])).
4572 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(2)], X=[int(1)])).
4573 :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [], X=[int(1)])).
4574
4575 not_strict_subset_of(Set1,Set2) :-
4576 (preference(use_chr_solver,true) -> chr_not_subset_strict(Set1,Set2) ; true),
4577 init_wait_flags(WF,[not_strict_subset_of]),
4578 not_strict_subset_of_wf(Set1,Set2,WF),
4579 ground_wait_flags(WF).
4580
4581 :- block not_strict_subset_of_wf(-,?,?),not_strict_subset_of_wf(?,-,?).
4582 not_strict_subset_of_wf(Set1,Set2,WF) :-
4583 (both_global_sets(Set1,Set2,G1,G2)
4584 -> not_strict_subset_of_global_sets(G1,G2)
4585 ; not_strict_subset_of_wf1(Set1,Set2,WF)
4586 ).
4587 ?not_strict_subset_of_wf1(Set1,Set2,WF) :- not_subset_of_explicit_set(Set1,Set2,Code,WF),!,
4588 equality_objects_wf(Set1,Set2,EqRes,WF),
4589 not_strict_eq_check(EqRes,Code).
4590 not_strict_subset_of_wf1(Set1,Set2,WF) :-
4591 % OLD VERSION: not_subset_of(Set1,Set2) ; check_equal_object(Set1,Set2).
4592 expand_custom_set_to_list_wf(Set1,ESet1,_,not_strict_subset_of_wf1,WF),
4593 (nonvar(Set2),is_infinite_explicit_set(Set2) -> Inf=infinite ; Inf=unknown),
4594 not_strict_subset_of2(ESet1,Set2,Inf,WF).
4595
4596 :- block not_strict_eq_check(-,?).
4597 not_strict_eq_check(pred_true,_). % if equal then not strict subset is true
4598 not_strict_eq_check(pred_false,Code) :- call(Code). % check if not subset
4599
4600 :- block not_strict_subset_of2(-,?,?,?).
4601 not_strict_subset_of2([],R,_,WF) :- empty_set_wf(R,WF).
4602 not_strict_subset_of2([H|T],Set2,Inf,WF) :-
4603 membership_test_wf(Set2,H,MemRes,WF),
4604 not_strict_subset_of3(MemRes,H,T,Set2,Inf,WF).
4605
4606 :- block not_strict_subset_of3(-,?,?,?,?,?).
4607 not_strict_subset_of3(pred_false,_H,_T,_Set2,_,_WF).
4608 not_strict_subset_of3(pred_true,H,T,Set2,Inf,WF) :-
4609 (Inf=infinite
4610 -> RS2=Set2 % Set1 is finite; we just have to check that all elements are in Set2 and we have a strict subset
4611 ; remove_element_wf(H,Set2,RS2,WF)),
4612 not_strict_subset_of2(T,RS2,Inf,WF).
4613
4614
4615 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,2),interval(1,3))).
4616 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,2),interval(0,-1))).
4617 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,2),interval(4,3))).
4618 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(1,3))).
4619 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,9000),interval(2,9999))).
4620 :- assert_must_succeed((kernel_objects:not_strict_subset_of_global_sets(interval(X2,X4),interval(1,3)),
4621 X2=2, X4=4)).
4622 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(1,4))).
4623 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(2,4))).
4624 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(0,10))).
4625 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,2),interval(1,inf))).
4626 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(-1,2),interval(0,inf))).
4627 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(1,2),interval(1,inf))).
4628 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(0,2),interval(0,inf))).
4629 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(-1,2),interval(minus_inf,inf))).
4630 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,inf),interval(1,inf))).
4631 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(minus_inf,inf),interval(1,inf))).
4632 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(minus_inf,inf),interval(0,inf))).
4633 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(1,inf),interval(minus_inf,inf))).
4634 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,inf),interval(1,inf))).
4635 :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(1,inf),interval(0,inf))).
4636 :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,inf),interval(0,inf))).
4637
4638 :- block not_strict_subset_of_global_sets(-,?), not_strict_subset_of_global_sets(?,-).
4639 not_strict_subset_of_global_sets(interval(Low1,Up1),interval(Low2,Up2)) :- !,
4640 % Note: if Low2>Up2 then nothing is a strict subset of the empty set, i.e., everything is not a strict subset
4641 (finite_interval(Low1,Up1), finite_interval(Low2,Up2)
4642 -> clpfd_interface:post_constraint2(((Low2 #=< Up2) #=> (Low1 #=< Up1 #/\ ((Low2 #> Low1) #\/ (Up1 #> Up2) #\/ ((Low1 #= Low2 #/\ Up1 #= Up2))))),Posted)
4643 ; Posted=false),
4644 (Posted==true -> true ; not_strict_subset_intervals(Low1,Up1,Low2,Up2)).
4645 not_strict_subset_of_global_sets(G1,G2) :-
4646 when((ground(G1),ground(G2)), \+check_strict_subset_of_global_sets(G1,G2)).
4647
4648 :- block not_strict_subset_intervals(?,?,-,?), not_strict_subset_intervals(?,?,?,-).
4649 % Instead of blocking on Low2,Up2 we could post bigger constraint (Low2 <= Up2 => (Low1 <= Up1 /\ ....
4650 not_strict_subset_intervals(_Low1,_Up1,Low2,Up2) :- safe_less_than_with_inf(Up2,Low2),!.
4651 not_strict_subset_intervals(Low1,Up1,Low2,Up2) :-
4652 safe_less_than_equal_with_inf_clpfd(Low1,Up1), % if Low1..Up1 is empty then it would be a strict subset
4653 not_check_strict_subset_intervals2(Low1,Up1,Low2,Up2).
4654 :- block not_check_strict_subset_intervals2(-,?,?,?),not_check_strict_subset_intervals2(?,-,?,?),
4655 not_check_strict_subset_intervals2(?,?,-,?).
4656 ?not_check_strict_subset_intervals2(Low1,Up1,Low2,Up2) :- \+ check_strict_subset_intervals2(Low1,Up1,Low2,Up2).
4657
4658
4659 /* Set1 /: FIN1(Set2) */
4660 :- assert_must_succeed((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(2)])).
4661 :- assert_must_succeed((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X=[int(1)], Y=[int(1),int(2)])).
4662 :- assert_must_succeed((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[])).
4663 :- assert_must_fail((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(1)])).
4664
4665 :- block not_non_empty_finite_subset_of_wf(-,?,?).
4666 not_non_empty_finite_subset_of_wf(Set1,Set2,WF) :- test_finite_set_wf(Set1,Finite,WF),
4667 not_non_empty_finite_subset_of_aux(Finite,Set1,Set2,WF).
4668 :- block not_non_empty_finite_subset_of_aux(-,?,?,?).
4669 not_non_empty_finite_subset_of_aux(pred_false,_Set1,_Set2,_WF).
4670 not_non_empty_finite_subset_of_aux(pred_true,Set1,Set2,WF) :- not_non_empty_subset_of_wf(Set1,Set2,WF).
4671
4672 /* Set1 /: POW1(Set2) */
4673 :- assert_must_succeed(exhaustive_kernel_check_wf(not_non_empty_subset_of_wf([int(1)], [int(2),int(3)],WF),WF)).
4674 :- assert_must_succeed(exhaustive_kernel_fail_check_wf(not_non_empty_subset_of_wf([int(2)], [int(2),int(3)],WF),WF)).
4675 :- assert_must_succeed((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(2)])).
4676 :- assert_must_succeed((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X=[int(1)], Y=[int(1),int(2)])).
4677 :- assert_must_succeed((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[])).
4678 :- assert_must_fail((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(1)])).
4679
4680 % Set1 /: POW1(Set2)
4681 :- block not_non_empty_subset_of_wf(-,?,?).
4682 not_non_empty_subset_of_wf(Set1,_,_WF) :- Set1==[],!.
4683 not_non_empty_subset_of_wf(Set1,Set2,WF) :- % Maybe introduce binary choice point ?
4684 empty_set_wf(Set1,WF) ;
4685 not_subset_of_wf(Set1,Set2,WF).
4686
4687
4688 /* min, max */
4689
4690 :- assert_must_succeed(exhaustive_kernel_check(minimum_of_set([int(1)],int(1),unknown,_WF))).
4691 :- assert_must_succeed(exhaustive_kernel_check(minimum_of_set([int(2),int(3),int(1)],int(1),unknown,_WF))).
4692 :- assert_must_succeed(exhaustive_kernel_fail_check(minimum_of_set([int(2),int(3),int(1)],int(2),unknown,_WF))).
4693 :- assert_must_succeed((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(1)])).
4694 :- assert_must_succeed((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(2),int(1)])).
4695 :- assert_must_succeed((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(1),int(2),int(1),int(3)])).
4696 :- assert_must_fail((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(2), Y=[int(1),int(2),int(1),int(3)])).
4697 :- assert_must_abort_wf(kernel_objects:minimum_of_set([],_R,unknown,WF),WF).
4698 %:- must_succeed(kernel_waitflags:assert_must_abort2_wf(kernel_objects:minimum_of_set([],_R,WF),WF)).
4699
4700 :- block minimum_of_set_extension_list(-,?,?,?).
4701 minimum_of_set_extension_list(ListOfValues,int(Min),Span,WF) :-
4702 minimum_of_set2(ListOfValues,Min,Span,WF).
4703
4704 :- block minimum_of_set(-,?,?,?).
4705 minimum_of_set(Set1,Res,_Span,WF) :- is_custom_explicit_set(Set1,minimum_of_set),
4706 min_of_explicit_set_wf(Set1,Min,WF), !,
4707 equal_object_wf(Min,Res,minimum_of_set,WF).
4708 minimum_of_set(Set1,int(Min),Span,WF) :-
4709 expand_custom_set_to_list_wf(Set1,ESet1,_,minimum_of_set,WF),
4710 (var(ESet1),Set1=closure(_,_,_)
4711 -> quick_propagation_element_information(Set1,int(Min),WF,_) ; true),
4712 minimum_of_set2(ESet1,Min,Span,WF).
4713 :- block minimum_of_set2(-,?,?,?).
4714 minimum_of_set2([],Res,Span,WF) :-
4715 add_wd_error_set_result('min applied to empty set','',Res,int(0),Span,WF).
4716 minimum_of_set2([int(N)|T],Min,_,_) :- clpfd_geq2(N,Min,_),minimum_of_set3(T,N,Min,[N]).
4717
4718 :- block minimum_of_set3(-,?,?,?). % with CLPFD: makes sense to also unfold if Min Variable; hence no longer block on : minimum_of_set3(?,-,-).
4719 minimum_of_set3([],MinSoFar,MinSoFar,ListOfValues) :-
4720 (var(MinSoFar) -> clpfd_minimum(MinSoFar,ListOfValues) ; true).
4721 minimum_of_set3([int(M)|T],MinSoFar,Min,ListOfValues) :- clpfd_geq2(M,Min,_),
4722 minimum(M,MinSoFar,NewMinSoFar),
4723 minimum_of_set3(T,NewMinSoFar,Min,[M|ListOfValues]).
4724
4725
4726 :- block minimum(-,?,?), minimum(?,-,?).
4727 minimum(M1,M2,Min) :- M1<M2 -> Min=M1 ; Min=M2.
4728
4729 :- assert_must_succeed(exhaustive_kernel_check(maximum_of_set([int(1)],int(1),unknown,_WF))).
4730 :- assert_must_succeed(exhaustive_kernel_check(maximum_of_set([int(2),int(3),int(1)],int(3),unknown,_WF))).
4731 :- assert_must_succeed(exhaustive_kernel_fail_check(maximum_of_set([int(2),int(3),int(1)],int(2),unknown,_WF))).
4732 :- assert_must_succeed((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(1)])).
4733 :- assert_must_succeed((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(2), Y=[int(2),int(1)])).
4734 :- assert_must_succeed((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(3), Y=[int(1),int(2),int(1),int(3)])).
4735 :- assert_must_fail((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(2), Y=[int(1),int(2),int(1),int(3)])).
4736 :- assert_must_fail((preferences:preference(use_clpfd_solver,true),
4737 kernel_objects:maximum_of_set([int(X),int(_Y)],int(3),unknown,_WF), X = 4)). % in CLPFD modus
4738 :- assert_must_fail((preferences:preference(use_clpfd_solver,true),
4739 kernel_objects:maximum_of_set([int(_),int(X)],int(3),unknown,_WF), X = 4)).% in CLPFD modus
4740 :- assert_must_abort_wf(kernel_objects:maximum_of_set([],_R,unknown,WF),WF).
4741
4742 :- block maximum_of_set_extension_list(-,?,?,?).
4743 maximum_of_set_extension_list(ListOfValues,int(Max),Span,WF) :-
4744 maximum_of_set2(ListOfValues,Max,Span,WF).
4745
4746 :- block maximum_of_set(-,?,?,?).
4747 maximum_of_set(Set1,Res,_Span,WF) :-
4748 is_custom_explicit_set(Set1,maximum_of_set),
4749 max_of_explicit_set_wf(Set1,Max,WF), !,
4750 equal_object_wf(Max,Res,maximum_of_set,WF).
4751 maximum_of_set(Set1,int(Max),Span,WF) :-
4752 expand_custom_set_to_list_wf(Set1,ESet1,_,maximum_of_set,WF),
4753 (var(ESet1),Set1=closure(_,_,_)
4754 -> quick_propagation_element_information(Set1,int(Max),WF,_) ; true),
4755 maximum_of_set2(ESet1,Max,Span,WF).
4756 :- block maximum_of_set2(-,?,?,?).
4757 maximum_of_set2([],Res,Span,WF) :-
4758 add_wd_error_set_result('max applied to empty set','',Res,int(0),Span,WF). %preferences:get_preference(maxint,R))). %R=abort(maximum_of_empty_set))).
4759 maximum_of_set2([int(N)|T],Max,_Span,_) :- clpfd_geq2(Max,N,_),
4760 maximum_of_set3(T,N,Max,[N]).
4761
4762 :- block maximum_of_set3(-,?,?,?). % with CLPFD: makes sense to also unfold if Max Variable; hence no longer block on : maximum_of_set3(?,-,-).
4763 maximum_of_set3([],MaxSoFar,MaxSoFar,ListOfValues) :-
4764 (var(MaxSoFar) -> clpfd_maximum(MaxSoFar,ListOfValues) ; true).
4765 maximum_of_set3([int(M)|T],MaxSoFar,Max,ListOfValues) :- clpfd_geq2(Max,M,_),
4766 maximum(M,MaxSoFar,NewMaxSoFar),
4767 maximum_of_set3(T,NewMaxSoFar,Max,[M|ListOfValues]).
4768
4769 :- block maximum(-,?,?), maximum(?,-,?).
4770 maximum(M1,M2,Max) :- M1>M2 -> Max=M1 ; Max=M2.
4771
4772 % card(ran(Function)); useful e.g. for q : 1 .. 16 --> 1 .. 16 & card(ran(q))=16
4773 :- block cardinality_of_range(-,?,?).
4774 cardinality_of_range(CS,Card,WF) :-
4775 is_custom_explicit_set(CS,cardinality_of_range),
4776 range_of_explicit_set_wf(CS,Res,WF),!,
4777 cardinality_as_int_wf(Res,Card,WF).
4778 cardinality_of_range(Function,Card,WF) :-
4779 expand_custom_set_to_list_wf(Function,EF1,Done,cardinality_of_range,WF),
4780 project_on_range(EF1,ERange),
4781 % when Done is set: we have a complete list and can compute MaxCard; TODO: maybe provide a version that can trigger earlier
4782 when(nonvar(Done),cardinality_of_set_extension_list(ERange,Card,WF)).
4783
4784 :- block project_on_range(-,?).
4785 project_on_range([],[]).
4786 project_on_range([(_,Ran)|T],[Ran|TR]) :- project_on_range(T,TR).
4787
4788
4789 :- assert_must_succeed((cardinality_of_set_extension_list([fd(1,'Name')],R,_WF), R = int(1))).
4790 :- assert_must_succeed((cardinality_of_set_extension_list([int(X),int(Y)],int(1),_WF), X=22, Y==22)).
4791
4792 cardinality_of_set_extension_list(List,int(Card),WF) :-
4793 length(List,MaxCard), less_than_equal_direct(Card,MaxCard),
4794 cardinality_of_set_extension_list2(List,[],0,MaxCard,Card,WF).
4795
4796 :- block cardinality_of_set_extension_list2(-,?,?,?,?,?).
4797 cardinality_of_set_extension_list2([],_,AccSz,_MaxCard,Res,_WF) :- Res=AccSz.
4798 cardinality_of_set_extension_list2([H|T],Acc,AccSz,MaxCard,Res,WF) :-
4799 membership_test_wf(Acc,H,MemRes,WF),
4800 (MaxCard==Res -> /* only solution is for H to be not in Acc */ MemRes=pred_false
4801 ; AccSz==Res -> /* only solution is for H to be in Acc */ MemRes=pred_true
4802 ; (var(Res),var(MemRes)) -> kernel_equality:equality_int(MaxCard,Res,EqMaxC),prop_if_pred_true(EqMaxC,MemRes,pred_false),
4803 kernel_equality:equality_int(AccSz,Res,EqAccSz),prop_if_pred_true(EqAccSz,MemRes,pred_true)
4804 ; true),
4805 cardinality_of_set_extension_list3(MemRes,H,T,Acc,AccSz,MaxCard,Res,WF).
4806
4807 :- block prop_if_pred_true(-,?,?).
4808 prop_if_pred_true(pred_true,X,X).
4809 prop_if_pred_true(pred_false,_,_).
4810
4811 :- block cardinality_of_set_extension_list3(-,?,?,?,?,?,?,?).
4812 cardinality_of_set_extension_list3(pred_true,_,T,Acc,AccSz,MaxCard,Res,WF) :-
4813 % H is a member of Acc, do not increase Acc nor AccSz; however MaxCard now decreases
4814 less_than_direct(Res,MaxCard), M1 is MaxCard-1,
4815 cardinality_of_set_extension_list2(T,Acc,AccSz,M1,Res,WF).
4816 cardinality_of_set_extension_list3(pred_false,H,T,Acc,AccSz,MaxCard,Res,WF) :-
4817 A1 is AccSz+1, less_than_equal_direct(A1,Res),
4818 cardinality_of_set_extension_list2(T,[H|Acc],A1,MaxCard,Res,WF).
4819
4820 :- assert_must_succeed(exhaustive_kernel_check(is_finite_set_wf([fd(1,'Name'),fd(2,'Name')],_WF))).
4821 :- assert_must_succeed((is_finite_set_wf(Y,_WF), Y = [])).
4822 :- assert_must_succeed((is_finite_set_wf(Y,_WF), Y = [int(1),int(2)])).
4823 :- use_module(typing_tools,[contains_infinite_type/1]).
4824 :- use_module(custom_explicit_sets,[card_for_specific_custom_set/3]).
4825
4826 is_finite_set_wf(Set,WF) :- test_finite_set_wf(Set,pred_true,WF).
4827
4828 :- assert_must_succeed(exhaustive_kernel_fail_check(is_infinite_set_wf([fd(1,'Name'),fd(2,'Name')],_WF))).
4829 :- assert_must_fail((is_infinite_set_wf(Y,_WF), Y = [int(1),int(2)])).
4830
4831 is_infinite_set_wf(Set,WF) :- test_finite_set_wf(Set,pred_false,WF).
4832
4833 %! test_finite_set_wf(+Set,?X,+WF)
4834 :- block test_finite_set_wf(-,?,?).
4835 %test_finite_set_wf(A,B,C) :- print(test_finite_set_wf(A,B,C)),nl,fail.
4836 test_finite_set_wf([],X,_WF) :- !, X=pred_true.
4837 test_finite_set_wf([_|T],X,WF) :- !, test_finite_set_wf(T,X,WF). % what if Tail contains closure ??
4838 test_finite_set_wf(avl_set(_),X,_WF) :- !, X=pred_true.
4839 test_finite_set_wf(closure(_P,T,_B),X,_WF) :- \+ contains_infinite_type(T), !, X=pred_true.
4840 test_finite_set_wf(closure(P,T,B),X,WF) :- !, test_finite_closure(P,T,B,X,WF).
4841 test_finite_set_wf(Set,X,WF) :- /* also deals with global_set(_) */
4842 /* explicit_set_cardinality may trigger an enum warning */
4843 explicit_set_cardinality_wf(Set,Card,WF),
4844 set_finite_result(Card,Set,explicit_set,X).
4845
4846 :- use_module(bsyntaxtree,[is_a_disjunct/3]).
4847 % we already check that contains_infinite_type above
4848 test_finite_closure(P,T,B,X,WF) :- is_a_disjunct(B,D1,D2),!,
4849 test_finite_closure(P,T,D1,X1,WF),
4850 test_finite_disj2(X1,P,T,D2,X,WF).
4851 % TO DO: add is_closure1_value_closure
4852 test_finite_closure(P,T,B,X,WF) :- when(ground(B), test_finite_closure_ground(P,T,B,X,WF)).
4853
4854 test_finite_disj2(pred_false,_P,_T,_D2,X,_WF) :- X=pred_false.
4855 test_finite_disj2(pred_true,P,T,D2,X,WF) :- test_finite_closure(P,T,D2,X,WF).
4856
4857
4858 % first: we need to check all constructors such as POW, FIN, ... which card_for_specific_custom_set supports
4859 % problem: if card becomes very large it is replaced by inf, which may give wrong results here (for card(.) we just get a spurious WD warning, here we may get wrong results)
4860 test_finite_closure_ground(P,T,B,X,WF) :-
4861 is_powerset_closure(closure(P,T,B),_Type,Subset),
4862 % note: whether Type is fin, fin1, pow, or pow1 does not matter
4863 !,
4864 test_finite_set_wf(Subset,X,WF).
4865 test_finite_closure_ground(P,T,B,X,WF) :-
4866 custom_explicit_sets:is_lambda_value_domain_closure(P,T,B, Subset,_Expr), !,
4867 test_finite_set_wf(Subset,X,WF).
4868 test_finite_closure_ground(P,T,B,X,WF) :-
4869 custom_explicit_sets:is_cartesian_product_closure(closure(P,T,B), A1,B2), !,
4870 test_finite_set_wf(A1,AX,WF),
4871 test_finite_set_wf(B2,BX,WF),
4872 test_finite_cartesian_product_wf(AX,BX,A1,B2,X,WF).
4873 test_finite_closure_ground(Par,Typ,Body, X,_WF) :-
4874 custom_explicit_sets:is_geq_leq_interval_closure(Par,Typ,Body,Low,Up), !,
4875 custom_explicit_sets:card_of_interval_inf(Low,Up,Card),
4876 set_finite_result_no_warn(Card,X).
4877 test_finite_closure_ground(P,T,B,X,WF) :-
4878 closures:is_member_closure(P,T,B,_,SET), nonvar(SET),
4879 unary_member_closure_for_finite(SET,Check,SET1),
4880 !,
4881 (Check==finite -> test_finite_set_wf(SET1,X,WF)
4882 ; kernel_equality:empty_set_test_wf(SET1,X,WF)).
4883 % TO DO: catch other special cases : relations, struct,...
4884 test_finite_closure_ground(P,T,B,X,_WF) :-
4885 custom_explicit_sets:card_for_specific_closure(closure(P,T,B),ClosureKind,Card,Code),!,
4886 call(Code), % TO DO: catch if we convert large integer due to overflow to inf !
4887 % maybe we can set / transmit a flag for is_overflowcheck ? overflow_float_pown ? factorial ?
4888 set_finite_result(Card,closure(P,T,B),ClosureKind,X).
4889 test_finite_closure_ground(P,T,B,X,WF) :-
4890 on_enumeration_warning(expand_only_custom_closure_global(closure(P,T,B),Result,check,WF),fail),
4891 !,
4892 test_finite_set_wf(Result,X,WF).
4893 test_finite_closure_ground(P,T,B,X,WF) :- X==pred_true, !,
4894 get_enumeration_finished_wait_flag(WF,AWF), % only add warning if indeed we find a solution
4895 finite_warning(AWF,P,T,B,is_finite_set_closure(P)).
4896 test_finite_closure_ground(P,T,B,_X,_WF) :- !,
4897 finite_warning(now,P,T,B,test_finite_closure(P)),
4898 fail. % now we fail; used to be X=pred_true. % we assume set to be finite, but print a warning
4899 % we could set up the closure and do a deterministic phase: if it fails or all variables become bounded, then it is finite
4900
4901 unary_member_closure_for_finite(seq(b(value(SET1),_,_)),empty,SET1). % finite if SET1 is empty
4902 unary_member_closure_for_finite(seq1(b(value(SET1),_,_)),empty,SET1).
4903 unary_member_closure_for_finite(perm(b(value(SET1),_,_)),finite,SET1). % finite if SET1 is finite
4904 unary_member_closure_for_finite(iseq(b(value(SET1),_,_)),finite,SET1).
4905 unary_member_closure_for_finite(iseq1(b(value(SET1),_,_)),finite,SET1).
4906 unary_member_closure_for_finite(identity(b(value(SET1),_,_)),finite,SET1).
4907 % we could deal with POW/POW1... here
4908 % succ/pred?
4909
4910 :- block test_finite_cartesian_product_wf(-,?,?,?,?,?), test_finite_cartesian_product_wf(?,-,?,?,?,?).
4911 test_finite_cartesian_product_wf(pred_true, pred_true, _,_,X,_) :- !, X=pred_true. % both finite
4912 test_finite_cartesian_product_wf(pred_false,pred_false,_,_,X,_) :- !, X=pred_false. % both infinite
4913 test_finite_cartesian_product_wf(pred_false,pred_true, _,B,X,WF) :- !,
4914 kernel_equality:empty_set_test_wf(B,X,WF). % only finite if B empty
4915 test_finite_cartesian_product_wf(pred_true, pred_false,A,_,X,WF) :- !,
4916 kernel_equality:empty_set_test_wf(A,X,WF). % only finite if B empty
4917
4918
4919 :- block set_finite_result_no_warn(-,?).
4920 set_finite_result_no_warn(inf,X) :- !, X=pred_false.
4921 set_finite_result_no_warn(_,pred_true).
4922
4923 :- block set_finite_result(-,?,?,?).
4924 set_finite_result(inf,_Set,_ClosureKind,X) :- !,
4925 %(Set=closure(P,T,B), \+ precise_closure_kind(ClosureKind)
4926 % -> finite_warning(now,P,T,B,test_finite_closure(P)) % we sometimes return inf for very large sets % TO DO: fix
4927 % ; true),
4928 X=pred_false.
4929 set_finite_result(_,_,_,pred_true).
4930
4931 % inf is now always real infinity; inf_overflow is finite very large cardinality not representable as number
4932 %precise_closure_kind(special_closure). % is_special_infinite_closure is precise, inf is real infinity %%%
4933 %precise_closure_kind(interval_closure). % here we also should never produce inf for a finite but large set
4934
4935
4936 :- assert_must_succeed(exhaustive_kernel_check(cardinality_as_int([int(2),int(4),int(1)],int(3)))).
4937 :- assert_must_succeed((cardinality_as_int(Y,int(2)), Y = [fd(1,'Name'),fd(2,'Name')])).
4938 :- assert_must_succeed((cardinality_as_int(Y,int(2)),
4939 nonvar(Y), Y = [H1|YY], nonvar(YY), YY=[H2], H1=int(0), H2=int(3) )).
4940 :- assert_must_succeed((cardinality_as_int([A|Y],int(3)),
4941 nonvar(Y), Y = [B|YY], nonvar(YY), YY=[C], A=int(1),B=int(3),C=int(2) )).
4942 :- assert_must_succeed((cardinality_as_int(Y,int(1)), Y = [fd(1,'Name')])).
4943 :- assert_must_succeed((cardinality_as_int(Y,int(0)), Y = [])).
4944 :- assert_must_succeed((cardinality_as_int(X,int(3)), equal_object(X,global_set('Name')))).
4945 :- assert_must_fail((cardinality_as_int(Y,int(X)), Y = [fd(1,'Name'),fd(2,'Name')],dif(X,2))).
4946 :- assert_must_succeed_any((preferences:preference(use_clpfd_solver,false) ;
4947 cardinality_as_int_wf(S,int(C),WF), clpfd_interface:try_post_constraint('#>='(C,2)), kernel_waitflags:ground_wait_flags(WF), nonvar(S),S=[_|T],nonvar(T))).
4948 :- assert_must_succeed((cardinality_as_int([int(1)|avl_set(node(int(3),true,0,empty,empty))],int(2)))).
4949 :- assert_must_succeed((cardinality_as_int([int(1)|avl_set(node(int(3),true,0,empty,empty))],X),X==int(2))).
4950 % check that we deal with repeated elements, in case no other predicate sets up a list !
4951 :- assert_must_fail((cardinality_as_int([int(1),int(1)],int(2)))).
4952 :- assert_must_fail((cardinality_as_int([int(1),int(1)],_))).
4953 :- assert_must_fail((cardinality_as_int(X,int(2)),X=[int(1),int(1)])).
4954 :- assert_must_fail((cardinality_as_int([int(3)|avl_set(node(int(3),true,0,empty,empty))],_))).
4955 :- assert_must_fail((cardinality_as_int([X|avl_set(node(int(3),true,0,empty,empty))],int(2)),X=int(3))).
4956
4957
4958 cardinality_as_int(S,I) :- cardinality_as_int_wf(S,I,no_wf_available). % TO DO: remove this predicate ?
4959 %:- load_files(library(system), [when(compile_time), imports([environ/2])]).
4960 %:- if(environ(prob_data_validation_mode,true)).
4961 %:- block cardinality_as_int_wf(-,?,?). % avoid instantiating list skeletons; cause backtracking in unifications,...
4962
4963 % can return inf !
4964 :- block cardinality_as_int_wf(-,-,?).
4965 cardinality_as_int_wf(Set,int(Card),WF) :-
4966 cardinality_as_int1(Set,Card,Card,WF).
4967
4968 cardinality_as_int1(Set,Card,ResCard,WF) :-
4969 (number(Card)
4970 -> cardinality_as_int1b(Set,Card,ResCard,WF)
4971 ; cardinality_as_int1b(Set,Card,ResCard,WF),
4972 (var(Set) ->
4973 (clpfd_domain(Card,Low,_Up),
4974 number(Low), Low>1,
4975 unbound_variable_for_card(Set)
4976 % TO DO: also use this optimization later in cardinality_as_int2
4977 -> setup_ordered_list_skeleton(Low,Skel,open,WF),
4978 Skel=Set
4979 ; get_wait_flag(1,force_non_empty(Set,Card),WF,LWF),
4980 force_non_empty0(Set,Card,LWF)
4981 )
4982 ; true)
4983 ).
4984 % tests 1418, 1419, 1628, 1776 require that cardinality_as_int1b be triggered quickly
4985 :- block cardinality_as_int1b(-,-,?,?). % with this the self-check with post_constraint('#>='(C,2) fails
4986 % cardinality_as_int1(Set, CardValue, ComputedCardValue) : CardValue should be unified with ComputedCardValue afterwards
4987 cardinality_as_int1b(Set,Card,ResCard,WF) :-
4988 %portray_waitflags(WF),nl,
4989 number(Card), unbound_variable_for_card(Set),
4990 !, % we know the cardinality and the set is not yet bound; this improvement is tested in tests 1417, 1418
4991 setup_ordered_list_skeleton(Card,Skel,closed,WF),
4992 (Card,Set) = (ResCard,Skel). % bypass equal_object: assign variable in one-go
4993 cardinality_as_int1b(Set,Card,ResCard,WF) :- nonvar(Set),!,
4994 cardinality_as_int2(Set,0,Card,ResCard,[],WF).
4995 cardinality_as_int1b(Set,Card,ResCard,WF) :-
4996 % Set is a variable but not unbound_variable_for_cons
4997 % Unifications can be very expensive when we set up long lists
4998 % Idea: multiply Card by a factor and delay instantiating; maybe we get a avl_set; see test 456
4999 Prio is Card*100,
5000 get_wait_flag(Prio,cardinality_as_int1(Set,Card),WF,LWF2),
5001 when((nonvar(Set) ; nonvar(LWF2)),
5002 cardinality_as_int2(Set,0,Card,ResCard,[],WF)).
5003 %force_non_empty0(Set,Card,1).
5004
5005 %:- if(environ(prob_data_validation_mode,true)).
5006 %:- block cardinality_as_int2(-,?,?,?,?,?). % avoid instantiating list skeletons; cause backtracking in unifications,...
5007
5008 :- block cardinality_as_int2(-,?,-,?,?,?).
5009 cardinality_as_int2(X,C,Res,ResultValue,_,WF) :-
5010 C==Res,!,empty_set_wf(X,WF),ResultValue=Res. % avoid choice point below
5011 cardinality_as_int2(X,C,Res,ResultValue,SoFar,WF) :- nonvar(X), X \= [], X\= [_|_],!,
5012 (is_custom_explicit_set(X)
5013 -> explicit_set_cardinality_wf(X,ESC,WF), blocking_add_card(C,ESC,ResultValue),
5014 disjoint_sets(X,SoFar,WF)
5015 ; add_error_fail(cardinality_as_int2,'First argument not set: ',cardinality_as_int2(X,C,Res))
5016 ).
5017 cardinality_as_int2([],C,Res,ResultValue,_,_WF) :- C=ResultValue, Res=ResultValue.
5018 cardinality_as_int2([H|T],C,Res,ResultValue,SoFar,WF) :-
5019 C1 is C+1,
5020 not_element_of_wf(H,SoFar,WF), % do we always need to check this ? relevant for test 1828
5021 add_new_element_wf(H,SoFar,SoFar2,WF),
5022 (ground(Res) -> safe_less_than_equal(cardinality_as_int2,C1,Res)
5023 /* check consistency so far if cardinality provided */
5024 ; clpfd_geq(Res,C1,_)
5025 ),
5026 force_non_empty(T,C1,Res,1), % Use WF ?
5027 cardinality_as_int2(T,C1,Res,ResultValue,SoFar2,WF).
5028
5029 % setup an list skeleton with ordering constraints to avoid duplicate solutions
5030 setup_ordered_list_skeleton(0,R,Closed,_WF) :- !, (Closed=closed -> R=[] ; true).
5031 setup_ordered_list_skeleton(N,[H|T],Closed,WF) :-
5032 all_different_wf([H|T],WF),
5033 N1 is N-1, setup_list_skel_aux(N1,H,T,Closed).
5034
5035
5036 :- use_module(kernel_ordering,[ordered_value/2]).
5037 %setup_list_skel_aux(0,_,R,Closed) :- !, (Closed=closed -> R=[] ; true). % if open: TO DO: impose ordering on rest using lazy_ordered_value ? done in next clause below
5038 setup_list_skel_aux(0,Prev,R,Closed) :- !, (Closed=closed -> R=[] ; lazy_ordered_value(R,Prev)).
5039 setup_list_skel_aux(N,Prev,[H|T],Closed) :- ordered_value(Prev,H),
5040 N>0, N1 is N-1, setup_list_skel_aux(N1,H,T,Closed).
5041
5042 :- block lazy_ordered_value(-,?).
5043 lazy_ordered_value([H|T],Prev) :- !, ordered_value(Prev,H), lazy_ordered_value(T,H).
5044 lazy_ordered_value(_,_).
5045
5046
5047 % TO DO: use clpfd all_different for integers !?
5048 % get_integer_list(Set,IntList), clpfd_alldifferent(IntList).
5049 % ensure we have all different constraint in case ordered_value does not succeed in enforcing order!
5050 all_different_wf(ListOfValues,WF) :-
5051 all_different2(ListOfValues,[],WF).
5052 :- block all_different2(-,?,?).
5053 all_different2([],_,_) :- !.
5054 all_different2([H|T],SoFar,WF) :- !, all_different3(SoFar,H,WF), all_different2(T,[H|SoFar],WF).
5055 all_different2(CS,SoFar,WF) :- is_custom_explicit_set(CS),
5056 disjoint_sets(CS,SoFar,WF). % already done above by cardinality_as_int2 ?
5057 all_different3([],_,_).
5058 all_different3([H|T],X,WF) :- not_equal_object_wf(H,X,WF), all_different3(T,X,WF).
5059
5060 :- block force_non_empty0(-,-,-).
5061 force_non_empty0(Set,Card,LWF) :- var(Set), var(Card),
5062 clpfd_domain(Card,Low,Up),
5063 (integer(Low) ; integer(Up)), !, % we know we have a finite cardinality
5064 clpfd_interface:try_post_constraint((Card#=0) #<=> EmptyR01),
5065 prop_non_empty(EmptyR01,Set,LWF).
5066 force_non_empty0(_,_,_).
5067
5068 % here we assume that the cardinalities cannot be infinite inf
5069 :- block force_non_empty(-,?,-,-).
5070 force_non_empty(Set,CSoFar,TotalCard,LWF) :-
5071 var(Set), var(TotalCard),
5072 preference(data_validation_mode,false),!,
5073 clpfd_interface:try_post_constraint((TotalCard#=CSoFar) #<=> EmptyR01),
5074 prop_non_empty(EmptyR01,Set,LWF).
5075 force_non_empty(_,_,_,_).
5076 :- block prop_non_empty(-,-,?).
5077 prop_non_empty(_,X,_) :- nonvar(X),!. % do nothing; cardinality_as_int2 will be called anyway
5078 prop_non_empty(0,X,LWF) :- /* X is var; first arg nonvar */ !, not_empty_set_lwf(X,LWF).
5079 %prop_non_empty(1,X,_). % empty_set not really required: TotalCard is now instantiated; cardinality_as_int2 will get called
5080 prop_non_empty(_,_,_).
5081
5082
5083
5084 :- assert_must_succeed(exhaustive_kernel_check(cardinality_as_int_for_wf(global_set('NATURAL'),inf))).
5085 :- assert_must_succeed(exhaustive_kernel_check(cardinality_as_int_for_wf([],0))).
5086 :- assert_must_succeed(exhaustive_kernel_check_opt(cardinality_as_int_for_wf([int(2)],1),
5087 preferences:get_preference(convert_comprehension_sets_into_closures,false))). % in this case inf returned for closures
5088 :- assert_must_succeed(exhaustive_kernel_check_opt(cardinality_as_int_for_wf([int(3),int(1),int(-1),int(100)],4),
5089 preferences:get_preference(convert_comprehension_sets_into_closures,false))).
5090 :- assert_must_succeed(exhaustive_kernel_fail_check_opt(cardinality_as_int_for_wf([int(3),int(1),int(-1),int(100)],1000),
5091 preferences:get_preference(convert_comprehension_sets_into_closures,false))).
5092 :- assert_must_succeed(exhaustive_kernel_fail_check_opt(cardinality_as_int_for_wf(global_set('NATURAL'),1000),
5093 preferences:get_preference(convert_comprehension_sets_into_closures,false))).
5094 % a simpler version without propagation to result; for waitflag priority computation or similar
5095 % it may return inf for closures marked as symbolic !
5096 cardinality_as_int_for_wf(Set,Card) :- cardinality_as_int_for_wf0(Set,0,Card).
5097 :- block cardinality_as_int_for_wf0(-,?,-).
5098 cardinality_as_int_for_wf0(X,C,Res) :-
5099 ? (nonvar(X) -> cardinality_as_int_for_wf1(X,C,Res)
5100 ; Res==inf -> cardinality_as_int_for_inf(X,C)
5101 % TODO: what about inf_overflow here
5102 ; cardinality_as_int_for_wf2(X,C,Res)).
5103
5104 :- block cardinality_as_int_for_inf(-,?).
5105 cardinality_as_int_for_inf(X,C) :- cardinality_as_int_for_wf1(X,C,inf).
5106
5107 cardinality_as_int_for_wf1([],C,Res) :- !,C=Res.
5108 cardinality_as_int_for_wf1([_H|T],C,Res) :- !,C1 is C+1,
5109 ? cardinality_as_int_for_wf0(T,C1,Res).
5110 cardinality_as_int_for_wf1(X,C,Res) :- is_custom_explicit_set(X),!,
5111 ? explicit_set_cardinality_for_wf(X,ESC), blocking_add_card(C,ESC,Res).
5112 cardinality_as_int_for_wf1(term(T),C,Res) :- nonvar(T), T=no_value_for(ID),
5113 format_with_colour(user_error,[bold,red],'~nNo value for ~w for cardinality_as_int_for_wf1!~n',[ID]), % can happen with partial_setup_constants
5114 !, C=Res.
5115 cardinality_as_int_for_wf1(X,C,Res) :-
5116 add_internal_error('First arg is not a set: ',cardinality_as_int_for_wf1(X,C,Res)),fail.
5117
5118 % first argument was var, third argument not inf hence third arg must be set
5119 %cardinality_as_int_for_wf2([],C,C).
5120 cardinality_as_int_for_wf2([],C,Res) :- (C==Res -> ! ; C=Res).
5121 cardinality_as_int_for_wf2([_H|T],C,Res) :- C<Res, C1 is C+1,
5122 (var(T) -> cardinality_as_int_for_wf2(T,C1,Res) ; cardinality_as_int_for_wf1(T,C1,Res)).
5123
5124
5125
5126 :- assert_must_succeed(exhaustive_kernel_check_wf(same_cardinality_wf(global_set('NATURAL'),global_set('NATURAL'),WF),WF)).
5127 :- assert_must_succeed(exhaustive_kernel_check_wf(same_cardinality_wf(global_set('NATURAL'),global_set('NATURAL1'),WF),WF)).
5128 :- assert_must_succeed(exhaustive_kernel_check_wf(same_cardinality_wf([int(2),int(1)],[int(11),int(22)],WF),WF)).
5129 :- assert_must_succeed(exhaustive_kernel_fail_check_wf(same_cardinality_wf([],[int(11),int(22)],WF),WF)).
5130 :- assert_must_succeed(exhaustive_kernel_fail_check_wf(same_cardinality_wf([int(11),int(22),int(33)],[int(11),int(22)],WF),WF)).
5131 :- assert_must_succeed(exhaustive_kernel_fail_check_wf(same_cardinality_wf(global_set('NATURAL1'),[int(11),int(22)],WF),WF)).
5132
5133 :- block same_cardinality_wf(-,-,?).
5134 same_cardinality_wf(Set1,Set2,WF) :-
5135 (var(Set1) -> same_card_aux(Set2,Set1,WF) ; same_card_aux(Set1,Set2,WF)).
5136
5137 same_card_aux(Set1,Set2,WF) :-
5138 (nonvar(Set1),is_custom_explicit_set(Set1,cardinality)
5139 -> explicit_set_cardinality_wf(Set1,Card,WF),
5140 (Card==inf -> is_infinite_set_wf(Set2,WF)
5141 % assumption: if inf then immediately infinite; TO DO: distinguish between infinite(s) and very large
5142 ; cardinality_as_int_wf(Set2,int(Card),WF)
5143 )
5144 ; cardinality3(Set1,PCard,WF),
5145 cardinality_peano_wf(Set2,PCard,WF)
5146 ).
5147
5148 :- assert_must_succeed(exhaustive_kernel_check(cardinality_peano_wf([],0,no_wf_available))).
5149 :- assert_must_succeed(exhaustive_kernel_check(cardinality_peano_wf([int(11)],s(0),no_wf_available))).
5150 :- assert_must_succeed(exhaustive_kernel_check(cardinality_peano_wf([int(11),int(22)],s(s(0)),no_wf_available))).
5151 % cardinality as peano number
5152 :- block cardinality_peano_wf(-,-,?).
5153 cardinality_peano_wf(Set,PCard,WF) :-
5154 (nonvar(Set),is_custom_explicit_set(Set,cardinality)
5155 -> explicit_set_cardinality_wf(Set,Card,WF),
5156 card_convert_int_to_peano(Card,PCard)
5157 ; cardinality3(Set,PCard,WF)
5158 ).
5159
5160 :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(3,s(s(s(0)))))).
5161 :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(2,S),S==s(s(0)))).
5162 :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(X,s(s(s(0)))),X==3)).
5163 :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(X,s(s(s(Y)))),X=4,Y==s(0))).
5164 :- assert_must_fail((kernel_objects:card_convert_int_to_peano(X,s(s(s(_Y)))),X=2)).
5165
5166 :- block card_convert_int_to_peano(-,-).
5167 card_convert_int_to_peano(X,S0) :- var(X), !,
5168 peel_s(S0,SX,RemS),
5169 (RemS==0 -> X=SX
5170 ; int_plus(int(X1),int(SX),int(X)),
5171 greater_than_equal(int(X1),int(0)),
5172 card_convert_int_to_peano(X1,RemS)).
5173 card_convert_int_to_peano(inf,X) :- !,
5174 infinite_peano(X),
5175 add_message(cardinality,'*** WARNING: Large or infinite Cardinality.').
5176 %convert_int_to_peano(100,X). % used to limit to 100
5177 card_convert_int_to_peano(X,P) :- convert_int_to_peano(X,P).
5178
5179 :- block infinite_peano(-).
5180 infinite_peano(inf).
5181 infinite_peano(0) :- fail.
5182 infinite_peano(s(X)) :- infinite_peano(X).
5183
5184 peel_s(0,0,0).
5185 peel_s(s(X),Res,SX) :- (var(X) -> Res=1, SX=X ; peel_s(X,RX,SX), Res is RX+1).
5186
5187 :- block cardinality3(-,?,?). % avoids instantiating set; to do: use kernel_cardinality instead
5188 % relevant, e.g., for "BK-ANT-N-2013" for SlotSolver_v7; but makes 'axm2/WD' fail for test 1448; TO DO: hopefully fixed with kernel_cardinality
5189 % :- block cardinality3(-,-,?).
5190 cardinality3(Set,SC,WF) :- var(Set),!,
5191 (SC=0 -> Set=[] ; SC=s(C),Set=[_|T],cardinality3(T,C,WF)).
5192 cardinality3([],0,_).
5193 ?cardinality3([_|T],s(C),WF) :- cardinality3(T,C,WF).
5194 cardinality3(avl_set(AVL),Res,WF) :- cardinality_peano_wf(avl_set(AVL),Res,WF).
5195 cardinality3(closure(P,T,B),Res,WF) :- cardinality_peano_wf(closure(P,T,B),Res,WF).
5196
5197
5198
5199
5200
5201
5202 :- assert_must_succeed(exhaustive_kernel_check(card_geq([int(2),int(4),int(1)],s(s(s(0)))))).
5203 :- assert_must_succeed((kernel_objects:card_geq(global_set('Name'),s(s(s(0)))))).
5204 :- assert_must_succeed((kernel_objects:card_geq([int(1),int(2)],s(s(0))))).
5205 :- assert_must_succeed((kernel_objects:card_geq([int(1),int(2)],s(0)))).
5206 :- assert_must_fail((kernel_objects:card_geq(global_set('Name'),s(s(s(s(0))))))).
5207 :- assert_must_fail((kernel_objects:card_geq([int(1),int(2)],s(s(s(0)))))).
5208
5209 ?card_geq(Set,Card) :- card_geq_wf(Set,Card,no_wf_available).
5210
5211 :- block card_geq_wf(-,-,?).
5212 card_geq_wf(Set,Card,WF) :-
5213 (nonvar(Set),is_custom_explicit_set(Set,card_geq)
5214 ? -> explicit_set_cardinality_wf(Set,CCard,WF), geq_int_peano(CCard,Card)
5215 ; card_geq2(Set,Card,WF) ).
5216 % should we call setup_ordered_list_skeleton(Card,Set,open)
5217 :- block card_geq2(?,-,?).
5218 card_geq2(_,C,_) :- C==0,!.
5219 card_geq2(S,C,_) :- S==[],!,C=0.
5220 card_geq2(S,s(C),WF) :- var(S),!,S=[_|T],card_geq2(T,C,WF).
5221 card_geq2([_|T],s(C),WF) :- card_geq2(T,C,WF).
5222 card_geq2(avl_set(A),s(C),WF) :- card_geq_wf(avl_set(A),s(C),WF).
5223 card_geq2(closure(P,T,B),s(C),WF) :- card_geq_wf(closure(P,T,B),s(C),WF).
5224 card_geq2(global_set(G),s(C),WF) :- card_geq_wf(global_set(G),s(C),WF).
5225
5226 :- block geq_int_peano(-,-).
5227 geq_int_peano(_,0).
5228 ?geq_int_peano(X,s(C)) :- geq_int_peano1(X,C).
5229 :- block geq_int_peano1(-,?).
5230 geq_int_peano1(inf,_) :- !.
5231 geq_int_peano1(inf_overflow,_) :- !.
5232 ?geq_int_peano1(X,C) :- X>0, X1 is X-1, geq_int_peano(X1,C).
5233
5234 :- block convert_int_to_peano(-,?).
5235 convert_int_to_peano(X,Y) :- convert_int_to_peano2(X,Y).
5236 convert_int_to_peano2(inf,_).
5237 convert_int_to_peano2(inf_overflow,_).
5238 convert_int_to_peano2(X,R) :- number(X),
5239 (X>100000
5240 -> print('*** Warning: converting large integer to peano: '),print(X),nl,
5241 (X>1000000000 -> print('*** treat like inf'),nl % no hope of ever finishing, do not instantiate just like inf
5242 ; convert_int_to_peano3(X,R))
5243 ; convert_int_to_peano3(X,R)
5244 ).
5245 convert_int_to_peano3(0,R) :- !, R=0.
5246 convert_int_to_peano3(X,s(P)) :-
5247 (X>0 -> X1 is X-1, convert_int_to_peano3(X1,P)
5248 ; X<0 -> add_error_and_fail(convert_int_to_peano,'Negative nr cannot be converted to peano: ',X)
5249 ).
5250
5251 % not used:
5252 %:- block convert_peano_to_int(-,?).
5253 %convert_peano_to_int(0,0).
5254 %convert_peano_to_int(s(P),X) :- convert_peano_to_int(P,X1), X is X1+1.
5255
5256 :- assert_must_succeed((kernel_objects:cardinality_greater_equal(Set,set(integer),int(X),integer,_WF), X=3,
5257 nonvar(Set),Set=[_|S2],nonvar(S2),S2=[_|S3],nonvar(S3),S3=[_|S4],var(S4), Set=[int(1),int(2),int(3)] )).
5258 :- assert_must_succeed((kernel_objects:cardinality_greater(Set,set(integer),int(X),integer,_WF), X=2,
5259 nonvar(Set),Set=[_|S2],nonvar(S2),S2=[_|S3],nonvar(S3),S3=[_|S4],var(S4), Set=[int(1),int(2),int(3)] )).
5260 /* special predicates called for e.g. card(Set)>X */
5261 cardinality_greater(Set,TypeSet,int(X),_,WF) :-
5262 kernel_objects:max_cardinality(TypeSet,MaxCard),
5263 (number(MaxCard) -> less_than(int(X),int(MaxCard)) ; true),
5264 card_greater2(Set,X,WF).
5265 :- block card_greater2(?,-,?).
5266 card_greater2(Set,X,WF) :- X1 is X+1, card_greater_equal2(Set,X1,WF).
5267
5268 cardinality_greater_equal(Set,TypeSet,int(X),_,WF) :-
5269 kernel_objects:max_cardinality(TypeSet,MaxCard),
5270 (number(MaxCard) -> less_than_equal(int(X),int(MaxCard)) ; true),
5271 card_greater_equal2(Set,X,WF).
5272 :- block card_greater_equal2(?,-,?).
5273 card_greater_equal2(Set,X,WF) :-
5274 (X<1 -> true % potential WD issue, hence this predicates should only be called when no wd issue
5275 ; X=1 -> not_empty_set_wf(Set,WF) % ditto: Set could be infinite
5276 ; var(Set) -> setup_ordered_list_skeleton(X,Set,open,WF)
5277 ; convert_int_to_peano(X,Peano),
5278 card_geq_wf(Set,Peano,WF)).
5279
5280
5281
5282 %is_cartesian_pair_or_times(P,X,Y) :- is_cartesian_pair(P,X,Y).
5283 %is_cartesian_pair_or_times(int(Z),int(X),int(Y)) :- times(int(X),int(Y),int(Z)).
5284
5285 is_cartesian_pair_wf((X,Y),XType,YType,WF) :-
5286 check_element_of_wf(X,XType,WF), check_element_of_wf(Y,YType,WF).
5287
5288 :- assert_must_succeed(exhaustive_kernel_check_wf(kernel_objects:not_is_cartesian_pair((int(1),int(1)),
5289 [int(1),int(2)],[int(2),int(3)],WF),WF)).
5290 :- assert_must_succeed(exhaustive_kernel_check_wf(kernel_objects:not_is_cartesian_pair((int(3),int(2)),
5291 [int(1),int(2)],[int(2),int(3)],WF),WF)).
5292 :- assert_must_succeed((kernel_objects:not_is_cartesian_pair((int(1),int(1)),
5293 [int(1),int(2)],[int(2),int(3)],_WF))).
5294 :- assert_must_succeed((kernel_objects:not_is_cartesian_pair((int(3),int(1)),
5295 [int(1),int(2)],[int(2),int(3)],_WF))).
5296 :- assert_must_fail((kernel_objects:not_is_cartesian_pair((int(1),int(3)),
5297 [int(1),int(2)],[int(2),int(3)],_WF))).
5298 :- assert_must_succeed((kernel_objects:not_is_cartesian_pair((X,int(3)),
5299 [int(1),int(2)],[int(2),int(3)],_WF),X=int(4))).
5300
5301
5302 not_is_cartesian_pair((X,Y),XType,YType,WF) :-
5303 not_is_cartesian_pair0(X,Y,XType,YType,WF).
5304
5305 :- block not_is_cartesian_pair0(-,-,?,?,?).
5306 not_is_cartesian_pair0(X,Y,XType,YType,WF) :-
5307 (nonvar(X) -> not_is_cartesian_pair1(X,Y,XType,YType,WF)
5308 ; not_is_cartesian_pair1(Y,X,YType,XType,WF)).
5309
5310 not_is_cartesian_pair1(X,Y,XType,YType,WF) :-
5311 membership_test_wf(XType,X,MemResX,WF),
5312 (var(MemResX) -> membership_test_wf(YType,Y,MemResY,WF) ; true),
5313 not_is_cartesian_pair3(MemResX,X,XType,MemResY,Y,YType,WF).
5314
5315 :- block not_is_cartesian_pair3(-,?,?, -,?,?, ?).
5316 not_is_cartesian_pair3(MemResX,X,XType, MemResY,Y,YType, WF) :-
5317 (MemResX==pred_false -> true
5318 ; MemResY==pred_false -> true
5319 ; MemResX==pred_true -> not_element_of_wf(Y,YType,WF)
5320 ; not_element_of_wf(X,XType,WF)
5321 ).
5322
5323
5324
5325 /***************************/
5326 /* power_set(Set,TypeSet) */
5327 /* Set : POW(TypeSet) */
5328 /***************************/
5329
5330 :- assert_must_succeed(exhaustive_kernel_check(power_set([int(2),int(4)],[[int(2)],
5331 [int(4)],[],[int(4),int(2)]]))).
5332 :- assert_must_succeed(power_set([int(1)],[[int(1)],[]])).
5333 :- assert_must_succeed((power_set([int(1),int(2)],R),
5334 equal_object(R,[[],[int(1)],[int(2)],[int(1),int(2)]]))).
5335 :- assert_must_succeed(power_set([],[[]])).
5336
5337 % not used anymore, except for empty set and singleton sets (see do_not_keep_symbolic_unary)
5338 :- block power_set(-,?).
5339 power_set([],Res) :- !,equal_object_optimized([[]],Res,power_set).
5340 power_set(Set1,Res) :- custom_explicit_sets:singleton_set(Set1,El),!,
5341 equal_object_optimized([[],[El]],Res,power_set).
5342 power_set(S,Res) :-
5343 cardinality_peano_wf(S,Card,no_wf_available),
5344 when(ground(Card), /* when all elements are known */
5345 (expand_custom_set_to_list_wf(S,SE,Done,power_set,no_wf_available),
5346 when(nonvar(Done),
5347 (gen_all_subsets(SE,PowerS),
5348 equal_object_optimized(PowerS,Res,power_set) )
5349 )
5350 )).
5351
5352 :- assert_must_succeed((kernel_objects:gen_all_subsets([X],R), R== [[],[X]])).
5353 :- assert_must_succeed((kernel_objects:gen_all_subsets([X,Y],R), R== [[],[Y],[X],[Y,X]])).
5354 % we do not use findall to keep variable links, see test 2103
5355 gen_all_subsets(List,AllSubLists) :- gen_all_subsets(List,[[]],AllSubLists).
5356 add_el(H,T,[H|T]).
5357 gen_all_subsets([],Acc,Acc).
5358 gen_all_subsets([H|T],Acc,Res) :- gen_all_subsets(T,Acc,R1),
5359 append(R1,R2,Res), % DCG would be better; but power_set is not really used anymore for longer lists
5360 maplist(add_el(H),Acc,Acc2), gen_all_subsets(T,Acc2,R2).
5361
5362
5363 :- assert_must_succeed(exhaustive_kernel_check(non_empty_power_set([int(2),int(4)],[[int(2)],
5364 [int(4)],[int(4),int(2)]]))).
5365 :- assert_must_succeed(non_empty_power_set([int(1)],[[int(1)]])).
5366 :- assert_must_succeed((non_empty_power_set([int(1),int(2)],R),
5367 equal_object(R,[[int(1)],[int(2)],[int(1),int(2)]]))).
5368 :- assert_must_succeed(non_empty_power_set([],[])).
5369
5370 :- block non_empty_power_set(-,?).
5371 non_empty_power_set([],Res) :- !,equal_object_optimized([],Res,non_empty_power_set).
5372 non_empty_power_set(Set1,Res) :- custom_explicit_sets:singleton_set(Set1,El),!,
5373 equal_object_optimized([[El]],Res,non_empty_power_set).
5374 non_empty_power_set(S,Res) :-
5375 cardinality_peano_wf(S,Card,no_wf_available),
5376 when(ground(Card), /* when all elements are known */
5377 (expand_custom_set_to_list_wf(S,SE,Done,non_empty_power_set,no_wf_available),
5378 when(nonvar(Done),
5379 (gen_all_subsets(SE,PowerS),
5380 delete(PowerS,[],NE_PowerS),
5381 equal_object_optimized(NE_PowerS,Res,non_empty_power_set) )
5382 )
5383 )).
5384
5385
5386
5387 /* ------- */
5388 /* BOOLEAN */
5389 /* ------- */
5390
5391 % following predicates are not used:
5392 %is_boolean(pred_true /* bool_true */).
5393 %is_boolean(pred_false /* bool_false */).
5394 %is_not_boolean(X) :- dif(X,pred_true /* bool_true */), dif(X,pred_false /* bool_false */).
5395
5396 /* ------- */
5397 /* NUMBERS */
5398 /* ------- */
5399
5400
5401 is_integer(int(X),_WF) :- when(ground(X),integer(X)).
5402 :- block is_not_integer(-).
5403 is_not_integer(X) :- X \= int(_), % will be called for x /: INTEGER; should always fail.
5404 add_internal_error('Wrong type argument: ',is_not_integer(X)),fail.
5405
5406 is_natural(int(X),_WF) :- clpfd_geq2(X,0,Posted), (Posted==true -> true ; number_geq(X,0)).
5407 is_natural1(int(X),_WF) :- clpfd_geq2(X,1,Posted), (Posted==true -> true ; number_geq(X,1)).
5408 :- block number_geq(-,?).
5409 number_geq(X,N) :- X>=N.
5410 :- block number_leq(-,?).
5411 number_leq(X,N) :- X=<N.
5412
5413 :- assert_must_succeed(is_implementable_int(int(0),_WF)).
5414 :- assert_must_fail(is_not_implementable_int(int(0))).
5415
5416
5417 is_implementable_int(int(X),WF) :- element_of_global_integer_set_wf('INT',X,WF,unkmown).
5418 is_implementable_nat(int(X),WF) :- element_of_global_integer_set_wf('NAT',X,WF,unknown).
5419 is_implementable_nat1(int(X),WF) :- element_of_global_integer_set_wf('NAT1',X,WF,unknown).
5420 is_not_implementable_int(X) :- not_element_of_global_set(X,'INT').
5421 is_not_implementable_nat(X) :- not_element_of_global_set(X,'NAT').
5422 is_not_implementable_nat1(X) :- not_element_of_global_set(X,'NAT1').
5423
5424 is_not_natural(int(X)) :- clpfd_geq2(-1,X,Posted), (Posted=true -> true ; number_leq(X,-1)).
5425 is_not_natural1(int(X)) :- clpfd_geq2(0,X,Posted), (Posted==true -> true ; number_leq(X,0)).
5426
5427 :- assert_must_succeed(exhaustive_kernel_check(less_than(int(2),int(3)))).
5428 :- assert_must_succeed(( safe_less_than(A,B),A=3,B=5 )).
5429 :- assert_must_succeed(( safe_less_than(A,B),B=5,A=3 )).
5430 :- assert_must_fail(( safe_less_than(A,B),A=5,B=3 )).
5431 :- assert_must_fail(( safe_less_than(A,B),B=3,A=5 )).
5432 :- assert_must_fail(( safe_less_than(A,B),A=5,B=5 )).
5433 :- assert_must_fail(( safe_less_than(A,B),B=5,A=5 )).
5434
5435 less_than(int(X),int(Y)) :-
5436 (number(X),number(Y) -> X < Y
5437 ; clpfd_lt(X,Y,Posted),
5438 (Posted=true -> true ; safe_less_than(X,Y))).
5439 less_than_direct(X,Y) :-
5440 (number(X),number(Y) -> X < Y
5441 ; clpfd_lt(X,Y,Posted),
5442 (Posted=true -> true ; safe_less_than(X,Y))).
5443 :- block safe_less_than(-,?), safe_less_than(?,-).
5444 safe_less_than(X,Y) :-
5445 (number(X),number(Y) -> X<Y
5446 ; add_internal_error('Arguments not numbers: ',safe_less_than(X,Y))).
5447
5448 :- assert_must_succeed(exhaustive_kernel_check(less_than_equal(int(33),int(33)))).
5449 less_than_equal(int(X),int(Y)) :-
5450 (number(X),number(Y) -> X =< Y
5451 ; clpfd_leq(X,Y,Posted),
5452 (Posted=true -> true ; safe_less_than_equal(less_than_equal,X,Y))).
5453 less_than_equal_direct(X,Y) :-
5454 (number(X),number(Y) -> X =< Y
5455 ? ; clpfd_leq(X,Y,Posted),
5456 (Posted=true -> true ; safe_less_than_equal(less_than_equal_direct,X,Y))).
5457
5458 safe_less_than_equal(X,Y) :-
5459 safe_less_than_equal(safe_less_than_equal,X,Y).
5460 :- block safe_less_than_equal(?,-,?), safe_less_than_equal(?,?,-).
5461 safe_less_than_equal(PP,X,Y) :-
5462 (number(X),number(Y) -> X=<Y
5463 ; add_internal_error('Arguments not numbers: ',safe_less_than_equal(PP,X,Y))).
5464
5465 :- assert_must_succeed(exhaustive_kernel_check(greater_than(int(2),int(1)))).
5466 :- assert_must_succeed(exhaustive_kernel_fail_check(greater_than(int(2),int(2)))).
5467 greater_than(int(X),int(Y)) :- less_than_direct(Y,X).
5468 :- assert_must_succeed(exhaustive_kernel_check(greater_than(int(2),int(1)))).
5469 :- assert_must_succeed(exhaustive_kernel_check(greater_than_equal(int(2),int(2)))).
5470 :- assert_must_succeed(exhaustive_kernel_fail_check(greater_than_equal(int(1),int(2)))).
5471 greater_than_equal(int(X),int(Y)) :- less_than_equal_direct(Y,X).
5472
5473
5474
5475
5476
5477 :- assert_must_succeed(exhaustive_kernel_check([commutative],int_plus(int(2),int(3),int(5)))).
5478 :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],int_plus(int(2),int(3),int(6)))).
5479
5480 :- assert_must_succeed(int_plus(int(1),int(2),int(3))).
5481 :- assert_must_succeed(( int_plus2(A,B,C),A=3,B=2,C==5 )).
5482 :- assert_must_succeed(( int_plus2(A,B,C),A=3,C=5,B==2 )).
5483 :- assert_must_succeed(( int_plus2(A,B,C),B=2,A=3,C==5 )).
5484 :- assert_must_succeed(( int_plus2(A,B,C),B=2,C=5,A==3 )).
5485 :- assert_must_succeed(( int_plus2(A,B,C),C=5,A=3,B==2 )).
5486 :- assert_must_succeed(( int_plus2(A,B,C),C=5,B=2,A==3 )).
5487 :- assert_must_succeed(( int_plus2(A,B,C),A=0,B==C )).
5488 :- assert_must_succeed(( int_plus2(A,B,C),B=0,A==C )).
5489
5490 int_plus(int(X),int(Y),int(Plus)) :-
5491 ? (two_vars_or_more(X,Y,Plus)
5492 -> clpfd_eq(Plus,X+Y) % can have performance problems
5493 ; true % otherwise we can compute the value directly below; we could skip the block declaration
5494 ),
5495 ? int_plus2(X,Y,Plus).
5496 two_vars_or_more(X,Y,Z) :- var(X),!, (var(Y) ; var(Z)).
5497 two_vars_or_more(_X,Y,Z) :- var(Y) , var(Z).
5498
5499 :- block int_plus2(-,-,-).
5500 int_plus2(X,Y,Plus) :-
5501 ? ( ground(X) -> int_plus3(X,Y,Plus)
5502 ; ground(Y) -> int_plus3(Y,X,Plus)
5503 ; int_minus3(Plus,X,Y)).
5504
5505 % int_plus3/3: the first argument must be ground when called
5506 int_plus3(0,Y,Plus) :- !, Y=Plus. % not inferred by CLP(FD): Z #= Y+X, X=0. does not infer Y==Z
5507 int_plus3(X,Y,Plus) :- % integer_dif(Y,Plus), % this generates overflows for test 1353, 1014
5508 ? int_plus4(X,Y,Plus).
5509
5510 % int_plus4/3: the first argument must be ground when called
5511 :- block int_plus4(?,-,-).
5512 int_plus4(X,Y,Plus) :-
5513 ( var(Plus) -> Plus is X+Y
5514 ; Y is Plus-X).
5515
5516 :- assert_must_succeed(exhaustive_kernel_check(int_minus(int(2),int(3),int(-1)))).
5517 :- assert_must_succeed(exhaustive_kernel_fail_check(int_minus(int(2),int(3),int(1)))).
5518 :- assert_must_succeed(int_minus(int(3),int(1),int(2))).
5519 :- assert_must_succeed(( int_minus2(A,B,C),A=3,B=2,C==1 )).
5520 :- assert_must_succeed(( int_minus2(A,B,C),A=3,C=1,B==2 )).
5521 :- assert_must_succeed(( int_minus2(A,B,C),B=2,A=3,C==1 )).
5522 :- assert_must_succeed(( int_minus2(A,B,C),B=2,C=1,A==3 )).
5523 :- assert_must_succeed(( int_minus2(A,B,C),C=1,A=3,B==2 )).
5524 :- assert_must_succeed(( int_minus2(A,B,C),C=1,B=2,A==3 )).
5525 :- assert_must_succeed(( int_minus2(A,B,C),B=0,A==C )).
5526 :- assert_must_succeed(( int_minus2(A,B,C),B=0,C=5,A==5 )).
5527 :- assert_must_succeed(( int_minus2(A,B,5),B=0,A==5 )).
5528
5529 int_minus(int(X),int(Y),int(Minus)) :-
5530 ? int_minus2(X,Y,Minus),
5531 ? (two_vars_or_more(X,Y,Minus) -> clpfd_eq(Minus,X-Y) % can have performance problems.
5532 % we could also set Minus to 0 if X==Y; this is done in CHR (chr_integer_inequality)
5533 ; true). % we can compute the value directly anyway
5534 :- block int_minus2(-,-,-).
5535 int_minus2(X,Y,Minus) :-
5536 ( ground(Y) ->
5537 ( Y=0 -> X=Minus
5538 ? ; Y2 is -Y, int_plus3(Y2,X,Minus))
5539 ; ground(X) ->
5540 ? int_minus3(X,Y,Minus)
5541 ; int_plus3(Minus,Y,X) % will infer that Y=X if Minus=0
5542 ).
5543
5544 % int_minus3/3: the first argument must be ground when called
5545 :- block int_minus3(?,-,-).
5546 int_minus3(X,Y,Minus) :-
5547 ( var(Minus) -> Minus is X-Y
5548 ; Y is X-Minus).
5549
5550 :- assert_must_succeed(exhaustive_kernel_check(division(int(2),int(3),int(0),unknown,_WF))).
5551 :- assert_must_succeed(exhaustive_kernel_check(division(int(7),int(2),int(3),unknown,_WF))).
5552 :- assert_must_succeed(exhaustive_kernel_check(division(int(8),int(2),int(4),unknown,_WF))).
5553 :- assert_must_succeed(exhaustive_kernel_check(division(int(9),int(2),int(4),unknown,_WF))).
5554 :- assert_must_succeed(exhaustive_kernel_check(division(int(2),int(-1),int(-2),unknown,_WF))).
5555 :- assert_must_succeed(exhaustive_kernel_check(division(int(9),int(-2),int(-4),unknown,_WF))).
5556 :- assert_must_succeed(exhaustive_kernel_check(division(int(-9),int(-3),int(3),unknown,_WF))).
5557 :- assert_must_succeed(exhaustive_kernel_check(division(int(-1),int(4),int(0),unknown,_WF))).
5558 :- assert_must_succeed((platform_is_64_bit
5559 -> exhaustive_kernel_check(division(int(4294967296),int(2),int(2147483648),unknown,_WF))
5560 ; exhaustive_kernel_check(division(int(134217728),int(2),int(67108864),unknown,_WF)))).
5561 :- assert_must_succeed((platform_is_64_bit
5562 -> exhaustive_kernel_check(division(int(4294967296),int(2147483648),int(2),unknown,_WF))
5563 ; exhaustive_kernel_check(division(int(134217728),int(67108864),int(2),unknown,_WF)))).
5564 :- assert_must_succeed(exhaustive_kernel_fail_check(division(int(2),int(3),int(1),unknown,_WF))).
5565 :- assert_must_succeed(( division3(A,B,C,unknown,_),A=15,B=4,C==3 )).
5566 :- assert_must_succeed(( division3(A,B,C,unknown,_),B=4,A=15,C==3 )).
5567
5568 division(int(X),int(Y),int(XDY),Span,WF) :- var(Y), (var(X) ; var(XDY)),
5569 preferences:preference(use_clpfd_solver,true),!,
5570 (preferences:preference(disprover_mode,true)
5571 -> clpfd_eq_div(XDY,X,Y) /* we can assume well-definedness */
5572 ; clpfd_eq_guarded_div(XDY,X,Y),
5573 % TO DO: we could set up a choice point just before enumeration of infinite types for Y=0 & Y/=0;
5574 % same for modulo
5575 check_nonzero(X,Y,XDY,Span,WF)
5576 ).
5577 division(int(X),int(Y),int(XDY),Span,WF) :-
5578 %% clpfd_eq_expr(XDY,X/Y), % can have performance problems; could hide division by 0 !
5579 division3(X,Y,XDY,Span,WF).
5580
5581 :- block check_nonzero(?,-,?,?,?).
5582 check_nonzero(X,Y,XDY,Span,WF) :-
5583 (Y=0 -> add_wd_error_set_result('division by zero','/'(X,Y),XDY,0,Span,WF)
5584 ; true).
5585
5586 :- block division3(?,-,?,?,?).
5587 division3(X,Y,XDY,Span,WF) :-
5588 ( Y==0 -> add_wd_error_set_result('division by zero','/'(X,Y),XDY,0,Span,WF)
5589 ; nonvar(X) -> XDY is X // Y
5590 ; Y == 1 -> X=XDY
5591 ; Y == -1,nonvar(XDY) -> X is -XDY
5592 ; clpfd_eq_div(XDY,X,Y)). % we could setup constraint before Y is known; could hide division by 0 ?
5593
5594
5595
5596 :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(2),int(3),int(0),unknown,_WF))).
5597 :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(7),int(2),int(3),unknown,_WF))).
5598 :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(-1),int(4),int(-1),unknown,_WF))).
5599 :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(-9),int(-3),int(3),unknown,_WF))).
5600 floored_division(int(X),int(Y),int(XDY),Span,WF) :- var(Y), (var(X) ; var(XDY)),
5601 preferences:preference(use_clpfd_solver,true),!,
5602 (preferences:preference(disprover_mode,true)
5603 -> clpfd_eq_fdiv(XDY,X,Y) /* we can assume well-definedness */
5604 ; clpfd_eq_guarded_fdiv(XDY,X,Y),
5605 check_nonzero(X,Y,XDY,Span,WF)
5606 ).
5607 floored_division(int(X),int(Y),int(XDY),Span,WF) :-
5608 %% clpfd_eq_expr(XDY,X/Y), % can have performance problems; could hide division by 0 !
5609 floored_division3(X,Y,XDY,Span,WF).
5610 :- block floored_division3(?,-,?,?,?).
5611 floored_division3(X,Y,XDY,Span,WF) :-
5612 ( Y==0 -> add_wd_error_set_result('division by zero','/'(X,Y),XDY,0,Span,WF)
5613 ; nonvar(X) -> XDY is X div Y
5614 ; Y == 1 -> X=XDY
5615 ; (Y == -1,nonvar(XDY)) -> X is -XDY
5616 ; clpfd_eq_guarded_fdiv(XDY,X,Y)). % we could setup constraint before Y is known; could hide division by 0 ?
5617
5618 :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(2),int(3),int(2),unknown,WF),WF)).
5619 :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(7),int(2),int(1),unknown,WF),WF)).
5620 :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(8),int(2),int(0),unknown,WF),WF)).
5621 :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(9),int(2),int(1),unknown,WF),WF)).
5622 :- assert_must_succeed((platform_is_64_bit
5623 -> exhaustive_kernel_check_wfdet(modulo(int(4294967296),int(2147483648),int(0),unknown,WF),WF)
5624 ; exhaustive_kernel_check_wfdet(modulo(int(134217728),int(67108864),int(0),unknown,WF),WF))).
5625 :- assert_must_succeed((platform_is_64_bit
5626 -> exhaustive_kernel_check_wfdet(modulo(int(4294967299),int(2147483648),int(3),unknown,WF),WF)
5627 ; exhaustive_kernel_check_wfdet(modulo(int(134217731),int(67108864),int(3),unknown,WF),WF))).
5628 :- assert_must_succeed(( modulo2(A,B,C,unknown,_),A=7,B=5,C==2 )).
5629 :- assert_must_fail(( modulo2(A,B,C,unknown,_),A=7,B=5,C==3 )).
5630
5631 modulo(int(X),int(Y),int(Modulo),Span,WF) :-
5632 %% clpfd_eq(Modulo,X mod Y), % can have performance problems; could hide division by 0 !
5633 modulo2(X,Y,Modulo,Span,WF),
5634 % assert that Modulo<Y, Modulo>=0
5635 (nonvar(X),nonvar(Y) -> true % we already have computed Modulo using modulo2
5636 ; nonvar(Modulo), Modulo < 0 -> true % we will generate well-definedness error; see comment next line
5637 ; number(Y),Y =< 0 -> true % in this case we will generate a well-definedness error; it would be more efficient from a constraint solving perspective to assume that there are no well-definedness errors and remove this case !!
5638 ; clpfd_modulo_prop(X,Y,Modulo,WF)
5639 ).
5640 :- use_module(specfile,[z_or_tla_minor_mode/0]).
5641 :- block modulo2(-,?,?,?,?), modulo2(?,-,?,?,?).
5642 modulo2(X,Y,Modulo,Span,WF) :-
5643 ( Y>0 -> (X<0 -> (z_or_tla_minor_mode -> Modulo is X mod Y
5644 ; add_wd_error_set_result('mod not defined for negative numbers in B:',mod(X,Y),Modulo,0,Span,WF))
5645 ; Modulo is X mod Y)
5646 ; Y==0 -> add_wd_error_set_result('mod by zero:',mod(X,Y),Modulo,0,Span,WF)
5647 ; Y<0 -> add_wd_error_set_result('mod not defined for negative numbers:',mod(X,Y),Modulo,0,Span,WF)). % there seems to be a definition in Z ? at least for Z Live ?
5648
5649 % propagate information about Modulo result if part of the information known
5650 clpfd_modulo_prop(X,Y,Modulo,WF) :- %preferences:preference(use_clpfd_solver,true),!,
5651 % in CLP(FD) this is sufficient; for non-CLPFD mode it is better to call in_nat_range to restrict enumeration
5652 less_than_direct(Modulo,Y),
5653 less_than_equal_direct(0,Modulo), % 0 <= Modulo < Y -> by transitivity this forces Y>0 and we no longer detect wd-errors
5654 %less_than_equal_direct(Modulo,X). % by transitivity this imposes X >= 0 and we will never find WD problems with negative X
5655 (preference(use_clpfd_solver,true)
5656 -> get_wait_flag0(WF,WF0),
5657 % avoid propagating complex too early, e.g., for x>2 & x:3..10 & x mod 3 = 1 & x mod 3 = 2 in test 2126
5658 % also see test 1959 which was initially failing due to adding WF0 delay
5659 clpfd_modulo_prop2(X,Y,Modulo,WF0)
5660 ; true).
5661
5662 :- block clpfd_modulo_prop2(?,?,?,-).
5663 clpfd_modulo_prop2(X,Y,Modulo,_WF0) :-
5664 number(Modulo), % this test is required for test 1009, 417 : TO DO : investigate cause
5665 var(X), % or should this be var(X) ; var(Y) ??
5666 fd_min(Y,MinY), number(MinY), MinY>0,
5667 fd_min(X,MinX), number(MinX), MinX>=0, % modulo is well-defined
5668 !,
5669 clpfd_interface:clpfd_leq_expr(Modulo,X),
5670 clpfd_interface:try_post_constraint(Modulo #= X mod Y).
5671 %clpfd_modulo_prop2(X,Y,Modulo,_WF0) :- number(Y),!,
5672 % % also makes tests 1009, 417 fail, but would enable solving x mod 256 = 0 & x>0
5673 % clpfd_interface:try_post_constraint(X#>=0 #=> Modulo #= X mod Y). % will also assert X#>Modulo
5674 clpfd_modulo_prop2(X,_Y,_Modulo,_WF0) :- X==0,!. % no need to propagate, we already assert 0 <= Modulo above
5675 clpfd_modulo_prop2(X,_Y,Modulo,_WF0) :-
5676 clpfd_interface:try_post_constraint(X#>=0 #=> X#>=Modulo). % this would be faster (e.g., {y|y:100000..200000 & y mod 2 = 0}), but would not catch some WD errors: clpfd_interface:try_post_constraint(X#>=Modulo).
5677 % we could reify: Y>0 => Modulo <Y ? Is it worth it ?
5678 % we could also use the CLP(FD) modulo operator X in 3..100, 1 #= X mod 20 infers X in 21..81
5679 % try_post_constraint((X#>=0 #/\ Y#>0) #=> Modulo #= X mod Y)
5680 % what is still missing is that if Y < Modulo => X=Y (CLP(FD) does this X in 0..100 , Y in 2..20 , X #= Y mod 30.)
5681 /* clpfd_modulo_prop(X,Y,Modulo,WF) :- clpfd_modulo_noclp(X,Y,Modulo,WF).
5682 :- block clpfd_modulo_noclp(-,-,-,?).
5683 clpfd_modulo_noclp(X,Y,Modulo,WF) :- print(mod(X,Y,Modulo,WF)),nl,
5684 var(X),var(Modulo),number(Y),!,
5685 Y1 is Y-1,
5686 in_nat_range_wf(int(Modulo),int(0),int(Y1),WF). % problem: could enumerate lambda return variables !!
5687 clpfd_modulo_noclp(_X,_Y,_Modulo,_WF).
5688 */
5689
5690
5691 :- assert_must_succeed(exhaustive_kernel_check(unary_minus_wf(int(2),int(-2),_WF))).
5692 :- assert_must_succeed(exhaustive_kernel_fail_check(unary_minus_wf(int(2),int(2),_WF))).
5693 :- assert_must_succeed(( unary_minus2(A,B),A=7,B== -7 )).
5694 :- assert_must_succeed(( unary_minus2(A,B),A= -7,B==7 )).
5695 :- assert_must_succeed(( unary_minus2(B,A),A=7,B== -7 )).
5696 :- assert_must_succeed(( unary_minus2(B,A),A= -7,B==7 )).
5697 :- assert_must_fail(( unary_minus2(B,A),A= -7,B=6 )).
5698 :- assert_must_fail(( unary_minus2(A,B),A= -7,B=6 )).
5699
5700 unary_minus_wf(int(X),int(MX),_WF) :-
5701 unary_minus2(X,MX),
5702 (var(X),var(MX) -> clpfd_eq(MX,0 - X) % can have performance problems
5703 ; true % we can compute the value without CLPFD
5704 ).
5705 :- block unary_minus2(-,-).
5706 unary_minus2(X,MX) :-
5707 ( ground(X) -> MX is -X
5708 ; X is -MX).
5709
5710 :- assert_must_succeed(first_of_pair((int(1),int(2)),int(1))).
5711 :- assert_must_succeed(second_of_pair((int(1),int(2)),int(2))).
5712
5713 first_of_pair((A,_B),R) :- equal_object(R,A,first_of_pair).
5714 second_of_pair((_A,B),R) :- equal_object(R,B,second_of_pair).
5715
5716
5717 :- assert_must_succeed(exhaustive_kernel_check(cartesian_product([int(2),int(4)],[int(3),int(1)],
5718 [(int(2),int(1)),(int(2),int(3)),(int(4),int(3)),(int(4),int(1))]))).
5719 :- assert_must_succeed(exhaustive_kernel_check(cartesian_product([],[int(3),int(1)],[]))).
5720 :- assert_must_succeed(exhaustive_kernel_check(cartesian_product([int(3)],[],[]))).
5721 :- assert_must_succeed(exhaustive_kernel_fail_check(cartesian_product([int(3)],[int(2)],[]))).
5722 :- assert_must_succeed((cartesian_product(global_set('NAT'),[int(2)],_Res))).
5723 :- assert_must_succeed((cartesian_product([int(1)],[int(2)],Res),
5724 equal_object(Res,[(int(1),int(2))]))).
5725 :- assert_must_succeed((cartesian_product([int(1)],[int(2)],[(int(1),int(2))]))).
5726 :- assert_must_succeed((cartesian_product([],[int(1),int(2)],Res),
5727 equal_object(Res,[]))).
5728 :- assert_must_succeed((cartesian_product([int(1),int(2)],[],Res),
5729 equal_object(Res,[]))).
5730 :- assert_must_succeed((cartesian_product([int(1),int(2)],[int(2),int(3)],Res),
5731 equal_object(Res,[(int(1),int(2)),(int(1),int(3)),(int(2),int(2)),(int(2),int(3))]))).
5732 :- assert_must_succeed((cartesian_product([int(1)|T],[int(2)|T2],Res),
5733 T = [int(2)], T2 = [int(3)],
5734 equal_object(Res,[(int(1),int(2)),(int(1),int(3)),(int(2),int(2)),(int(2),int(3))]))).
5735 :- assert_must_fail((cartesian_product([int(1)],[int(2),int(3)],Res),(Res=[_];
5736 equal_object(Res,[_,_,_|_])))).
5737
5738
5739 cartesian_product(Set1,Set2,Res) :- cartesian_product_wf(Set1,Set2,Res,no_wf_available).
5740
5741 :- block cartesian_product_wf(-,?,?,?), cartesian_product_wf(?,-,?,?).
5742 cartesian_product_wf(Set1,Set2,Res,WF) :-
5743 expand_custom_set_to_list_wf(Set1,ESet1,_,cartesian_product1,WF),
5744 (ESet1==[] -> empty_set_wf(Res,WF)
5745 ; expand_custom_set_to_list_wf(Set2,ESet2,_,cartesian_product2,WF),
5746 (var(Res)
5747 -> cartesian_product2(ESet1,ESet2,CRes,WF),
5748 equal_object_optimized_wf(CRes,Res,cart_product,WF)
5749 ; cartesian_product2(ESet1,ESet2,Res,WF))
5750 ).
5751
5752 :- block cartesian_product2(-,?,?,?).
5753 cartesian_product2([],_,Res,WF) :- empty_set_wf(Res,WF).
5754 cartesian_product2([H|T],Set2,Res,WF) :-
5755 cartesian_el_product(Set2,H,Res,InnerRes,WF),
5756 cartesian_product2(T,Set2,InnerRes,WF).
5757
5758 :- block cartesian_el_product(-,?,?,?,?).
5759 cartesian_el_product([],_El,Res,InnerRes,WF) :- equal_object_optimized_wf(Res,InnerRes,cartesian_el_product_1,WF).
5760 cartesian_el_product([H|T],El,ResSoFar,InnerRes,WF) :-
5761 equal_object_wf(ResSoFar,[(El,H)|NewResSoFar],cartesian_el_product_2,WF),
5762 cartesian_el_product(T,El,NewResSoFar,InnerRes,WF).
5763
5764
5765
5766 :- assert_must_succeed(exhaustive_kernel_check(in_nat_range(int(2),int(2),int(3)))).
5767 :- assert_must_succeed(exhaustive_kernel_check(in_nat_range_wf(int(2),int(2),int(3),_WF))).
5768 :- assert_must_succeed(exhaustive_kernel_fail_check(in_nat_range_wf(int(2),int(3),int(2),_WF))).
5769 :- assert_must_succeed((in_nat_range_wf(X,int(11),int(12),WF),
5770 kernel_waitflags:ground_wait_flags(WF), X==int(12) )).
5771 :- assert_must_fail((in_nat_range_wf(X,int(11),int(12),_WF), X=int(10) )).
5772 :- assert_must_fail((in_nat_range_wf(X,int(11),int(12),_WF), X=int(13) )).
5773 :- assert_must_succeed((in_nat_range_wf(X,int(11),int(12),_WF), X=int(11) )).
5774 :- assert_must_fail((in_nat_range_wf(X,int(11),int(10),_WF), X=int(11) )).
5775 :- assert_must_fail((in_nat_range_wf(X,int(11),int(10),_WF), X=int(10) )).
5776 :- assert_must_fail((in_nat_range_wf(X,int(11),int(10),_WF), X=int(12) )).
5777
5778 in_nat_range(int(X),int(Y),int(Z)) :- % does not enumerate, in contrast to in_nat_range_wf
5779 clpfd_inrange(X,Y,Z,Posted), % better to call inrange rather than leq twice, avoids unecessary propagation
5780 (Posted==true -> true
5781 ; safe_less_than_equal(in_nat_range,Y,X),
5782 safe_less_than_equal(in_nat_range,X,Z)
5783 ).
5784 in_nat_range_wf(int(X),int(Y),int(Z),WF) :-
5785 clpfd_inrange(X,Y,Z,Posted), % better to call inrange rather than leq twice, avoids unecessary propagation
5786 (Posted==true ->
5787 % if the constraint was posted: we do not need to add safe_less_than_equal,...:
5788 % if overflow happes whole computation will fail anyway
5789 block_add_fd_variable_for_labeling(X,Y,Z,WF) % do we really need to do this ? maybe add just before enum finished ?, see also test 328
5790 ; safe_less_than_equal(in_nat_range_wf,Y,X),
5791 safe_less_than_equal(in_nat_range_wf,X,Z),
5792 (ground(X) -> true
5793 ; get_int_domain(X,Y,Z,RL,RU),get_nat_range_prio(X,RL,RU,WF,LWF),
5794 ? call_enumerate_int(X,RL,RU,LWF))
5795 ).
5796
5797 :- block block_add_fd_variable_for_labeling(-,-,?,?), block_add_fd_variable_for_labeling(?,-,-,?).
5798 block_add_fd_variable_for_labeling(X,_Y,_Z,_WF) :- nonvar(X),!. % no need to label it
5799 block_add_fd_variable_for_labeling(X,_Y,_Z,WF) :- add_fd_variable_for_labeling(X,WF).
5800
5801 :- block get_nat_range_prio(?,-,?,?,?), get_nat_range_prio(?,?,-,?,?).
5802 get_nat_range_prio(_Variable,Y,Z,WF,LWF) :- Size is Z+1-Y,
5803 (Size>1 ->
5804 % we do not use add_fd_variable_for_labeling(Variable,Size,WF,LWF) % will use CLP(FD) labeling
5805 % either clpfd is off or we had a time-out or overflow; so labeling may generate instantiation error
5806 get_wait_flag(Size,get_nat_range_prio(Y,Z),WF,LWF)
5807 ; LWF=Size /* Size=0 or 1 -> we can either fail or determine variable */).
5808
5809 :- assert_must_succeed((kernel_objects:call_enumerate_int(X,1,2,g), X==2)).
5810 :- block call_enumerate_int(-,?,?,-).
5811 call_enumerate_int(X,RL,RU,_LWF) :-
5812 (ground(X) -> true
5813 ; % get_int_domain(X,RL,RU,RLL,RUU) : if clp(fd) active then CLP(FD) labeling is used anyway
5814 ? enumerate_int(X,RL,RU)).
5815
5816
5817
5818
5819 :- assert_must_succeed(exhaustive_kernel_check(not_in_nat_range(int(2),int(3),int(2)))).
5820 :- assert_must_succeed(exhaustive_kernel_fail_check(not_in_nat_range(int(2),int(2),int(3)))).
5821 :- assert_must_succeed((not_in_nat_range(X,int(11),int(12)), X=int(10) )).
5822 :- assert_must_succeed((not_in_nat_range(X,int(11),int(12)), X=int(13) )).
5823 :- assert_must_fail((not_in_nat_range(X,int(11),int(12)), X=int(11) )).
5824 :- assert_must_succeed((not_in_nat_range(X,int(11),int(10)), X=int(11) )).
5825 :- assert_must_succeed((not_in_nat_range(X,int(11),int(10)), X=int(10) )).
5826 :- assert_must_succeed((not_in_nat_range(X,int(11),int(10)), X=int(12) )).
5827
5828 ?not_in_nat_range_wf(X,Y,Z,_WF) :- not_in_nat_range(X,Y,Z).
5829 not_in_nat_range(int(X),int(Y),int(Z)) :-
5830 (number(Y),number(Z)
5831 ? -> (Z>=Y -> clpfd_not_in_non_empty_range(X,Y,Z) ; true /* interval empty */)
5832 ; clpfd_not_inrange(X,Y,Z)
5833 ).
5834
5835
5836 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(1),int(0),int(10),pred_true,WF),WF)).
5837 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(10),int(10),int(10),pred_true,WF),WF)).
5838 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(1),int(1),int(10),pred_true,WF),WF)).
5839 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(10),int(0),int(10),pred_true,WF),WF)).
5840 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(11),int(10),int(9),pred_false,WF),WF)).
5841 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(11),int(13),int(12),pred_false,WF),WF)).
5842 :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(11),int(13),int(15),pred_false,WF),WF)).
5843
5844 % reified version
5845 :- block test_in_nat_range_wf(-,-,?,-,?), test_in_nat_range_wf(-,?,-,-,?), test_in_nat_range_wf(?,-,-,-,?).
5846 test_in_nat_range_wf(X,Y,Z,PredRes,WF) :- PredRes==pred_true,!,
5847 in_nat_range_wf(X,Y,Z,WF).
5848 test_in_nat_range_wf(X,Y,Z,PredRes,WF) :- PredRes==pred_false,!,
5849 ? not_in_nat_range_wf(X,Y,Z,WF).
5850 test_in_nat_range_wf(int(X),int(Low),int(Up),PredRes,WF) :-
5851 clpfd_interface:post_constraint2(C1 #<=> (X #>= Low #/\ X #=< Up #/\ Low #=< Up),Posted1),
5852 (Posted1 == true -> prop_01(C1,PredRes) ; test_in_nat_range_no_clpfd(X,Low,Up,PredRes,WF)).
5853
5854 % Note: A #<=> (X #>= Low #/\ X#=< Up #/\ Low #=< Up), Low in 11..15, Up in 7..8. -> CLPFD infers A=0
5855 % without the redundant Low #=< Up it does not infer it !
5856 :- block prop_01(-,-).
5857 prop_01(0,pred_false).
5858 prop_01(1,pred_true).
5859
5860 :- block test_in_nat_range_no_clpfd(-,?,?,-,?), test_in_nat_range_no_clpfd(?,-,?,-,?),
5861 test_in_nat_range_no_clpfd(?,?,-,-,?).
5862 test_in_nat_range_no_clpfd(X,Y,Z,PredRes,WF) :- PredRes==pred_true,!,
5863 in_nat_range_wf(int(X),int(Y),int(Z),WF).
5864 test_in_nat_range_no_clpfd(X,Y,Z,PredRes,WF) :- PredRes==pred_false,!,
5865 not_in_nat_range_wf(int(X),int(Y),int(Z),WF).
5866 test_in_nat_range_no_clpfd(X,Y,Z,PredRes,_WF) :- % X,Y,Z must be ground integers
5867 (X >= Y, X =< Z, Y =< Z -> PredRes=pred_true ; PredRes=pred_false).
5868
5869 :- assert_must_succeed(exhaustive_kernel_check_wf(square(int(3),int(9),WF),WF)).
5870 % is now only called when CLPFD is FALSE
5871 square(int(X),int(Sqr),WF) :-
5872 int_square(X,Sqr,WF),
5873 (var(X) -> clpfd_eq(Sqr,X * X)
5874 ; true). % we can compute the value directly
5875
5876 :- block int_square(-,-,?).
5877 int_square(X,Sqr,_) :- ground(X),!, Sqr is X*X.
5878 int_square(X,Sqr,WF) :- get_binary_choice_wait_flag(int_square,WF,WF2), int_square2(X,Sqr,WF2).
5879 :- block int_square2(-,?,-).
5880 int_square2(X,Sqr,_) :- ground(X),!, Sqr is X*X.
5881 int_square2(X,Sqr,_WF2) :-
5882 integer_square_root(Sqr,X).
5883
5884 :- assert_must_succeed(( kernel_objects:integer_square_root(0,X),X==0 )).
5885 :- assert_must_succeed(( kernel_objects:integer_square_root(1,X),X==1 )).
5886 :- assert_must_succeed(( kernel_objects:integer_square_root(4,X),X==2 )).
5887 :- assert_must_succeed(( kernel_objects:integer_square_root(49,X),X==7 )).
5888 :- assert_must_succeed(( kernel_objects:integer_square_root(49,X),X==(-7) )).
5889 :- assert_must_fail(( kernel_objects:integer_square_root(5,_) )).
5890 :- assert_must_succeed(( X= 123456789, Y is X*X, kernel_objects:integer_square_root(Y,Z),Z==X)).
5891 :- assert_must_fail(( X= 123456789, Y is 1+X*X, kernel_objects:integer_square_root(Y,_Z))).
5892 :- assert_must_succeed(( X= 12345678900, Y is X*X, kernel_objects:integer_square_root(Y,Z),Z==X)).
5893
5894 integer_square_root(0,Root) :- !, Root = 0.
5895 :- if(current_prolog_flag(dialect, swi)).
5896 % SWI's behavior when converting bigint to float is suboptimal -
5897 % the value is always truncated toward zero instead of rounded to the nearest value,
5898 % which introduces slight inaccuracies that don't happen on SICStus.
5899 % See: https://github.com/SWI-Prolog/swipl-devel/issues/545
5900 % As a workaround, use CLP(FD) to calculate integer square roots.
5901 % On SWI, CLP(FD) works with unlimited size integers and can calculate exact integer n-th roots.
5902 :- use_module(library(clpfd), [(#=)/2, (#>)/2, (#=<)/2]).
5903 integer_square_root(Sqr,Root) :-
5904 Root*Root #= Sqr,
5905 (Root #> 0 ; Root #=< 0).
5906 :- else.
5907 integer_square_root(Sqr,PMRoot) :-
5908 Sqr>0, Root is truncate(sqrt(Sqr)), Sqr is Root*Root,
5909 (PMRoot = Root ; PMRoot is -(Root)).
5910 :- endif.
5911
5912 % integer multiplication
5913 times(int(X),int(Y),int(Times)) :-
5914 int_times2(X,Y,Times),
5915 ? (two_vars_or_more(X,Y,Times) -> clpfd_eq(Times,X * Y) % can have performance problems.
5916 ; true). % we can compute the value directly
5917
5918 :- assert_must_succeed(exhaustive_kernel_check([commutative],times(int(2),int(3),int(6)))).
5919 :- assert_must_succeed(exhaustive_kernel_check([commutative],times(int(2),int(1),int(2)))).
5920 :- assert_must_succeed(exhaustive_kernel_check([commutative],times(int(2),int(0),int(0)))).
5921 :- assert_must_succeed(exhaustive_kernel_check(times(int(0),int(1),int(0)))).
5922 :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],times(int(2),int(3),int(5)))).
5923 :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],times(int(1),int(3),int(2)))).
5924 :- assert_must_succeed(( int_times2(A,B,C),A=3,B=2,C==6 )).
5925 :- assert_must_succeed(( int_times2(A,B,C),A=3,C=6,B==2 )).
5926 :- assert_must_succeed(( int_times2(A,B,C),B=2,A=3,C==6 )).
5927 :- assert_must_succeed(( int_times2(A,B,C),B=2,C=6,A==3 )).
5928 :- assert_must_succeed(( int_times2(A,B,C),C=6,A=3,B==2 )).
5929 :- assert_must_succeed(( int_times2(A,B,C),C=6,B=2,A==3 )).
5930 :- assert_must_succeed(( int_times2(A,_,C),A=0,C==0 )).
5931 :- assert_must_succeed(( int_times2(_,B,C),B=0,C==0 )).
5932 :- assert_must_succeed(( int_times2(A,B,C),A=1,B==C )).
5933 :- assert_must_succeed(( int_times2(A,B,C),B=1,A==C )).
5934 :- assert_must_succeed(( int_times2(A,1,C),A=2,C==2 )).
5935 :- assert_must_succeed(( int_times2(_A,0,C),C==0 )).
5936 :- assert_must_succeed(( int_times2(A,_,C),C=0,A=0 )).
5937 :- assert_must_succeed(( int_times2(_,B,C),C=0,B=0 )).
5938 :- assert_must_succeed(( int_times2(A,B,0),A=0,B=2 )).
5939 :- assert_must_succeed(( int_times2(A,B,0),B=2,A=0 )).
5940 :- assert_must_succeed(( int_times2(B,A,0),A=0,B=2 )).
5941 :- assert_must_succeed(( int_times2(B,A,0),B=2,A=0 )).
5942 :- assert_must_fail(( int_times2(A,_,C),A=3,C=7 )).
5943 :- assert_must_fail(( int_times2(A,_,C),C=7,A=3 )).
5944 :- assert_must_fail(( int_times2(_,B,C),B=2,C=7 )).
5945 :- assert_must_fail(( int_times2(_,B,C),C=7,B=2 )).
5946 :- assert_must_fail(( int_times2(A,_,C),C=7,A=0 )).
5947 :- assert_must_fail(( int_times2(_,B,C),C=7,B=0 )).
5948 :- assert_must_fail(( int_times2(B,A,0),B=2,A=1 )).
5949
5950 :- block int_times2(-,-,-).
5951 int_times2(X,Y,Times) :-
5952 ( ground(X) ->
5953 ( X==1 -> Y=Times
5954 ; X==0 -> Times=0
5955 ; int_times3(X,Y,Times))
5956 ; ground(Y) ->
5957 ( Y==1 -> X=Times
5958 ; Y==0 -> Times=0
5959 ; int_times3(Y,X,Times))
5960 ; int_times4(X,Y,Times)).
5961 % int_times3/3: First argument must be ground when called and non-zero
5962 :- block int_times3(?,-,-).
5963 int_times3(X,Y,Times) :-
5964 ( ground(Y) -> Times is X*Y
5965 ; Y is Times // X, Times is X*Y).
5966 % int_times4/3: Third argument must be ground when called
5967 :- block int_times4(-,-,?).
5968 int_times4(X,Y,Times) :-
5969 ( Times==0 ->
5970 ( ground(X) -> (X==0 -> true; Y=0 )
5971 ; /* ground(Y) -> */ (Y==0 -> true; X=0 ))
5972 ; /* Times /== 0 */
5973 ( ground(X) -> X\==0, Y is Times // X, Times is X*Y
5974 ; /* ground(Y) -> */ Y\==0, X is Times // Y, Times is X*Y)).
5975
5976
5977 :- assert_must_succeed(exhaustive_kernel_check(int_power(int(2),int(3),int(8),unknown,_))).
5978 :- assert_must_succeed(exhaustive_kernel_check(int_power(int(2),int(1),int(2),unknown,_))).
5979 :- assert_must_succeed(exhaustive_kernel_check(int_power(int(3),int(0),int(1),unknown,_))).
5980 :- assert_must_succeed(exhaustive_kernel_check(int_power(int(1),int(3),int(1),unknown,_))).
5981 :- assert_must_succeed(exhaustive_kernel_check(int_power(int(0),int(3),int(0),unknown,_))).
5982 :- assert_must_succeed(exhaustive_kernel_check(int_power(int(0),int(0),int(1),unknown,_))).
5983 :- assert_must_succeed(exhaustive_kernel_fail_check(int_power(int(2),int(3),int(6),unknown,_))).
5984 :- assert_must_succeed(exhaustive_kernel_fail_check(int_power(int(0),int(0),int(0),unknown,_))).
5985 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=2,B=5,C==32 )).
5986 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A= -2,B=5,C== -32 )).
5987 %:- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=1,B= -5,C==1 )). % now aborts !
5988 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=1,C=1, B= -5 )).
5989 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=1,C= 1,B = -5 )).
5990 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=2,C=32,B==5 )).
5991 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=10,C=1000,B==3 )).
5992 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A= -2,C= -32,B==5 )).
5993 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A= -2,C= 16,B==4 )).
5994 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=2,C=1,B==0 )).
5995 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,B=2,C==0 )).
5996 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,C=0,B=2 )).
5997 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,B=0,C==1 )).
5998 :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,C=1,B==0 )).
5999 :- assert_must_succeed(( int_power2(17,13,C,unknown,_),C==9904578032905937 )).
6000 :- assert_must_succeed((platform_is_64_bit
6001 -> int_power2(A,13,C,unknown,_),C=9904578032905937,A=17
6002 ; int_power2(A,9,C,unknown,_),C=134217728,A=8 )).
6003 :- assert_must_fail((platform_is_64_bit
6004 -> int_power2(A,13,C,unknown,_),C=9904578032905936,A=17
6005 ; int_power2(A,9,C,unknown,_),C=134217727,A=8 )).
6006 :- assert_must_succeed((platform_is_64_bit
6007 -> int_power2(A,10,C,unknown,_),C=576650390625,A=15
6008 ; true)).
6009 :- assert_must_fail((platform_is_64_bit
6010 -> int_power2(A,10,C,unknown,_),C=576650390626,A=15
6011 ; false)).
6012 :- assert_must_succeed(( int_power2(A,100,C,unknown,_),A=2,C==1267650600228229401496703205376 )).
6013 :- assert_must_fail(( int_power2(A,100,C,unknown,_),C=1267650600228229401496703205375,A=2 )).
6014 :- assert_must_fail(( int_power2(A,100,C,unknown,_),C=1267650600228229401496703205377,A=2 )).
6015
6016 :- assert_must_fail(( int_power2(A,B,C,unknown,_),A=2,B=5,C=33 )).
6017 :- assert_must_abort_wf(( int_power2(A,B,_,unknown,WF),A=2,B= -5 ),WF).
6018 :- assert_must_fail(( int_power2(A,_,C,unknown,_),A= -2,C=32 )).
6019 :- assert_must_fail(( int_power2(A,_,C,unknown,_),A= -2,C= -16 )).
6020 % Note: 0**0=1 (see SIMP_SPECIAL_EXPN_0 in https://wiki.event-b.org/index.php/All_Rewrite_Rules)
6021 % TODO: in TLA+ it is undefined (TLC says 0^0 is undefined.)
6022
6023 :- use_module(specfile,[eventb_mode/0]).
6024 % TODO: calculate X from Y und Pow (i.e., Yth root of Pow); in CLPFD mode this is more or less done
6025 int_power(int(X),int(Y),int(Pow),Span,WF) :- % power_of AST node
6026 ( preferences:preference(use_clpfd_solver,true)
6027 -> int_power2(X,Y,Pow,Span,WF), int_power_clpfd_propagation(X,Y,Pow)
6028 ; int_power1(X,Y,Pow,Span,WF)).
6029 % TO DO ?: if all are variables we can still infer some knowledge
6030 % e.g. if X is positive then Pow must be positive; but it is probably quite rare that we have models with unknown exponent ?
6031 :- block int_power1(-,?,?,?,?). % ensure that Base X is known if CLPFD off
6032 int_power1(X,Y,Pow,Span,WF) :-
6033 int_power2(X,Y,Pow,Span,WF).
6034 :- block int_power2(-,-,?,?,?), int_power2(?,-,-,?,?). % we know Y or both X&Pow
6035 int_power2(X,Y,Pow,Span,WF) :-
6036 ( ground(Y) ->
6037 ( Y>=0 -> (integer(X) -> safe_int_power0(X,Y,PowXY,Span,WF),
6038 clpfd_nr_eq(PowXY,Pow) % try and prevent overflow if PowXY is large
6039 ; safe_int_power0(X,Y,Pow,Span,WF))
6040 ; add_wd_error_set_result('power with negative exponent','**'(X,Y),Pow,1,Span,WF))
6041 ; /* X & POW are ground */
6042 ( X==1 -> Pow==1 /* 1**Y = 1 */
6043 ; X==0, Pow==1 -> Y=0
6044 ; X==0 -> (Pow==1 -> Y=1 /* 0**0=1 */ ; Pow==0 -> integer_dif(Y,0))
6045 ; X>0, Pow>0 ->
6046 checked_precise_log(X,Y,Pow,Span,WF)
6047 % TO DO: X<0 should raise WD error for Event-B ?
6048 ; X<0, eventb_mode -> add_wd_error_set_result('power with negative base','^'(X,Y),Pow,1,Span,WF)
6049 ; X<0, Pow<0 ->
6050 PosPow is -(Pow),
6051 NegX is -(X),
6052 checked_precise_log(NegX,Y,PosPow,Span,WF),
6053 odd(Y)
6054 ; X<0, Pow>0 ->
6055 NegX is -(X),
6056 checked_precise_log(NegX,Y,Pow,Span,WF),
6057 even(Y))).
6058
6059 :- assert_must_succeed(( integer_log(3,59049,Log),Log==10 )).
6060 :- assert_must_succeed(( integer_log(2,1024,Log),Log==10 )).
6061 :- assert_must_succeed(( integer_log(4,1024,Log),Log==5 )).
6062 :- assert_must_succeed(( integer_log(10,1,Log),Log==0 )).
6063 :- assert_must_succeed(( integer_log(10,2,Log),Log==0 )).
6064 :- assert_must_succeed(( integer_log(10,10,Log),Log==1 )).
6065 :- assert_must_succeed(( integer_log(10,11,Log),Log==1 )).
6066 :- assert_must_succeed(( integer_log(10,1000,Log),Log==3 )).
6067 :- use_module(tools_portability, [check_arithmetic_function/1]).
6068 integer_log(Base,Power,_Exp) :- (Base =< 0 ; Power =< 0), !,
6069 add_error_and_fail(integer_log,'Logarithm only defined for positive values: ',log(Base,Power)).
6070 :- if(check_arithmetic_function(log(2, 4))).
6071 % Native log(Base, Power) function is available - use it. is available in SICStus
6072 integer_log(Base, Power, Exp) :- ApproximateExp is truncate(log(Base, Power)),
6073 % it is precise for power of 2 it seems, but not for 3
6074 % | ?- X is log(3,59049). X = 9.999999999999998 ? -> truncate gives 9, correct value is 10
6075 correct_integer_log_approximation(Base,Power,ApproximateExp,_,Exp).
6076 :- else.
6077 % No native log(Base, Power) support, so construct it using natural logarithms.
6078 integer_log(Base, Power, Exp) :- ApproximateExp is truncate(log(Power) / log(Base)),
6079 correct_integer_log_approximation(Base,Power,ApproximateExp,_,Exp).
6080 :- endif.
6081
6082 correct_integer_log_approximation(Base,Power,Exp,Correction,Res) :-
6083 BE is Base ^ Exp,
6084 (Correction=decreasing, BE > Power % not sure this case will ever trigger
6085 -> Exp1 is Exp-1, %write(dec(Base,Bower,Exp1)),nl,
6086 correct_integer_log_approximation(Base,Power,Exp1,Correction,Res)
6087 ; Correction=increasing, BE*Base =< Power
6088 -> Exp1 is Exp+1, %write(inc(Base,Bower,Exp1)),nl,
6089 correct_integer_log_approximation(Base,Power,Exp1,Correction,Res)
6090 ; Res=Exp).
6091
6092 % TO DO for checked_precise_log: we should take pre-cautions with try_find_abort
6093 % 2**x + y = 1024 & y:0..100 -> will give x=10, y=0 but not give rise to possible WD error
6094 checked_precise_log(1,Exp,Pow,_,_) :- !, % the SICStus Prolog log function does not work for Base=1
6095 Pow=1, less_than_equal_direct(0,Exp).
6096 checked_precise_log(Base,Exp,Pow,Span,WF) :-
6097 integer_log(Base,Pow,Exp),
6098 safe_int_power(Base,Exp,Pow,Span,WF). % we have the perfect solution
6099 % ; Exp is Try+1, write(inc(Base,Pow,Try)),nl, safe_int_power(Base,Exp,Pow,Span,WF) ,write(pow(Base,Exp,Pow)),nl).
6100
6101 :- block even(-).
6102 even(X) :- 0 is X mod 2.
6103 :- block odd(-).
6104 odd(X) :- 1 is X mod 2.
6105
6106 % propagation rules if only one of the args known
6107 :- block int_power_clpfd_propagation(-,-,-).
6108 int_power_clpfd_propagation(Base,Exp,Pow) :- Exp==0, var(Base),var(Pow),!, % B**0 = 1
6109 Pow = 1.
6110 int_power_clpfd_propagation(Base,Exp,Pow) :- Exp==1, var(Base),var(Pow),!, % B**1 = B
6111 Pow = Base.
6112 int_power_clpfd_propagation(Base,Exp,Pow) :- Base==1, var(Exp),var(Pow),!, % 1**E = 1
6113 Pow = Base.
6114 int_power_clpfd_propagation(Base,Exp,Pow) :- Base==0, var(Exp),var(Pow),!, % 0**E = 0 if E>0
6115 (fd_min(Exp,MinExp), number(MinExp), MinExp>0 -> Pow=0
6116 ; true). % case Exp=0 is treated in int_power itself
6117 %int_power_clpfd_propagation(Base,Exp,Pow) :- number(Base), Base>0,var(Exp),var(Pow),!,
6118 % clpfd_leq(1,Pow,_). % causes problem with test 305
6119 int_power_clpfd_propagation(X,Y,Pow) :-
6120 fd_min(X,MinX), number(MinX), MinX>0,
6121 fd_min(Y,MinY), number(MinY), MinY>0, % ensures no WD problem possible
6122 MinPow is MinX^MinY,
6123 \+ integer_too_large_for_clpfd(MinPow),
6124 fd_max(X,MaxX), number(MaxX),
6125 fd_max(Y,MaxY), number(MaxY),
6126 MaxPow is MaxX^MaxY,
6127 \+ integer_too_large_for_clpfd(MaxPow),
6128 % only do propagation if we are sure not to produce a CLPFD overflow
6129 !,
6130 clpfd_inrange(Pow,MinPow,MaxPow),
6131 (number(X), fd_max(Pow,MaxPow2), number(MaxPow2), get_new_upper_bound(X,MaxPow2,NewMaxExp,NewMaxPow)
6132 -> clpfd_leq(Pow,NewMaxPow,_),
6133 clpfd_leq(Y,NewMaxExp,_)
6134 ; true),
6135 (number(X), fd_min(Pow,MinPow2), number(MinPow2), get_new_lower_bound(X,MinPow2,NewMinExp,NewMinPow)
6136 -> clpfd_leq(NewMinPow,Pow,_),
6137 clpfd_leq(NewMinExp,Y,_)
6138 ; true),
6139 true.
6140 %result of this propagation: x = 3**y & y:3..5 & x /= 27 & x /= 243 -> deterministically forces x=81, y=4
6141 int_power_clpfd_propagation(Base,Exp,Pow) :- number(Base), Base>1, var(Exp), var(Pow),
6142 fd_max(Pow,MaxPow), number(MaxPow),!,
6143 (MaxPow =< 0 -> fail % Base^Exp will always be strictly positive
6144 ; integer_log(Base,MaxPow,Log)
6145 -> clpfd_leq(Exp,Log,_)
6146 ; add_internal_error('Failed:',integer_log(Base,MaxPow,_)),
6147 clpfd_lt(Exp,MaxPow,_Posted)).
6148 int_power_clpfd_propagation(_,_,_).
6149 % TO DO: maybe implement custom CLPFD propagators; above does not trigger for x>0 & y:0..500 & 2**x + y = 1500 or x>0 & x<20 & y:0..500 & 2**x + y = 1500
6150
6151 :- assert_must_succeed((kernel_objects:get_new_lower_bound(2,3,E,P),E==2,P==4)).
6152 :- assert_must_succeed((kernel_objects:get_new_lower_bound(2,11,E,P),E==4,P==16)).
6153 :- assert_must_fail((kernel_objects:get_new_lower_bound(2,16,_,_))).
6154 % given Base and Power, determine if Power is a proper power of Exp, if not determine the next possible power of Base
6155 get_new_lower_bound(Base,Power,MinExp,MinPower) :- Base > 1, Power> 0,
6156 integer_log(Base,Power,Exp),
6157 BE is Base^Exp,
6158 BE < Power,
6159 MinPower is Base*BE,
6160 MinPower>Power,
6161 MinPower < 1125899906842624, % 2^50 \+ integer_too_large_for_clpfd(MinPower),
6162 MinExp is Exp+1.
6163 :- assert_must_succeed((kernel_objects:get_new_upper_bound(2,3,E,P),E==1,P==2)).
6164 :- assert_must_succeed((kernel_objects:get_new_upper_bound(2,11,E,P),E==3,P==8)).
6165 :- assert_must_fail((kernel_objects:get_new_upper_bound(2,16,_,_))).
6166 get_new_upper_bound(Base,Power,MaxExp,MaxPower) :- Base > 1, Power> 0,
6167 integer_log(Base,Power,MaxExp),
6168 MaxPower is Base^MaxExp,
6169 MaxPower < Power,
6170 \+ integer_too_large_for_clpfd(MaxPower),
6171 MaxPower*Base > Power.
6172
6173 % safe exponentiation using the squaring algorithm (CLPFD supports exponentiation only for SICStus 4.9 or later)
6174 % Note: in TLA mode 0^0 is undefined according to TLC; for B/Rodin it is 1
6175 safe_int_power0(Base,Exp,Result,Span,WF) :- var(Base),
6176 Exp>30,!, % Exp>59 % 2**59 no overflow; but everything above that is guaranteed to generate an overflow unless Base is 0 or 1 or -1
6177 % 3**38 generates overflow; 4**30 generates overflow on 64-bit systems
6178 % To do: examine whether we should already delay with a smaller or larger exponent
6179 when(nonvar(Base),safe_int_power(Base,Exp,Result,Span,WF)). % wait until Base is known to avoid CLPFD overflow
6180 safe_int_power0(Base,Exp,Result,Span,WF) :- safe_int_power(Base,Exp,Result,Span,WF).
6181
6182 :- assert_must_succeed(( safe_int_power(0,0,P,unknown,_),P==1 )).
6183 safe_int_power(Base,Exp,Result,Span,WF) :- number(Base), Base<0, eventb_mode,!,
6184 add_wd_error_set_result('power with negative base','^'(Base,Exp),Result,1,Span,WF).
6185 safe_int_power(_Base,0,Result,_,_WF) :- !, Result = 1.
6186 safe_int_power(Base,Exp,Result,_,_) :- number(Base),!,
6187 Result is Base^Exp. % new integer exponentiation operator in SICStus 4.3, Note: X is 0^0. -> X=1
6188 safe_int_power(Base,Exp,Result,_,_) :-
6189 Msb is msb(Exp), % most significant bit
6190 ExpMask is 1<<Msb,
6191 safe_int_power_clpfd2(ExpMask,Exp,Base,1,Result).
6192
6193 :- use_module(clpfd_interface,[clpfd_eq_expr/2]).
6194 safe_int_power_clpfd2(0,_,_,Prev,Result) :- !, Prev=Result.
6195 safe_int_power_clpfd2(Mask,Exp,Base,Prev,Result) :-
6196 P is Exp /\ Mask, % P is Exp's highest bit
6197 Mask2 is Mask>>1,
6198 clpfd_eq_expr(Quad,Prev*Prev),
6199 ( P==0 -> Next = Quad
6200 ; clpfd_eq_expr(Next,Quad*Base) ),
6201 safe_int_power_clpfd2(Mask2,Exp,Base,Next,Result).
6202 %% -------------------------------------------------------
6203
6204 :- assert_must_succeed(( singleton_set_element([int(1)],E,unknown,_WF), E==int(1) )).
6205 :- assert_must_succeed(( singleton_set_element([int(X)],int(1),unknown,_WF), X==1 )).
6206 :- assert_must_fail(singleton_set_element([int(1)],int(2),unknown,_WF) ).
6207 :- assert_must_abort_wf(kernel_objects:singleton_set_element([int(1),int(2)],_E,unknown,WF),WF).
6208 % This predicate computes the effect of the MU operator.
6209 % Set should be a singleton set and Elem its only element.
6210 % In case Set is empty or has more than one element, an error
6211 % message is generated.
6212 :- block singleton_set_element(-,?,?,?).
6213 singleton_set_element([],_,Span,WF) :- !,
6214 add_wd_error_span('argument of MU expression must have cardinality 1, but is empty ', '', Span,WF).
6215 singleton_set_element([H|T],Elem,Span,WF) :- !,
6216 empty_set_test_wf(T,Empty,WF),
6217 when(nonvar(Empty),
6218 (Empty=pred_true -> equal_object_wf(Elem,H,singleton_set_element,WF)
6219 ; add_wd_error_span('argument of MU expression has more than one element ',
6220 b(value([H|T]),set(any),[]), Span,WF))).
6221 singleton_set_element(avl_set(A),Elem,Span,WF) :- !,
6222 (is_one_element_avl(A,AEl) -> equal_object_wf(Elem,AEl,singleton_set_element,WF)
6223 ; add_wd_error_span('argument of MU expression has more than one element ',
6224 b(value(avl_set(A)),set(any),[]), Span,WF)).
6225 singleton_set_element(Set,Elem,Span,WF) :-
6226 cardinality_as_int_wf(Set,Card,WF), % we have a comprehension set; could return inf !
6227 singleton_set_element1(Card,Set,Elem,Span,WF).
6228 :- block singleton_set_element1(-,?,?,?,?).
6229 singleton_set_element1(int(Card),Set,Elem,Span,WF) :- !,
6230 % we could check if fd_dom of Card is set up and call equality_objects_lwf(Card,int(1),IsSingleton,LWF,WF) if it is
6231 singleton_set_element2(Card,Set,Elem,Span,WF).
6232 singleton_set_element1(XX,_Set,_Elem,Span,WF) :-
6233 add_wd_error_span('argument of MU expression must have cardinality 1, but has ', XX, Span,WF).
6234
6235 :- block singleton_set_element2(-,?,?,?,?).
6236 singleton_set_element2(1,Set,Elem,_Span,_WF) :- !,
6237 exact_element_of(Elem,Set).
6238 singleton_set_element2(Card,_Set,_Elem,Span,WF) :-
6239 add_wd_error_span('argument of MU expression must have cardinality 1, but has ', Card, Span,WF).
6240
6241 :- assert_must_succeed(( singleton_set_element_wd([int(1)],E,unknown,_WF), E==int(1) )).
6242 :- assert_must_succeed(( singleton_set_element_wd([int(X)],int(1),unknown,_WF), X==1 )).
6243 %:- assert_must_succeed(( singleton_set_element_wd([int(X)|T],int(1),unknown,_WF), X==1, T==[] )).
6244 :- assert_must_fail(singleton_set_element_wd([int(1)],int(2),unknown,_WF) ).
6245 % MU_WD: a version of singleton_set_element which propagates more strongly from result to input
6246 % and thus may not raise WD errors in this case
6247 :- block singleton_set_element_wd(-,-,?,?).
6248 singleton_set_element_wd(Set,Elem,Span,WF) :- nonvar(Set),!, % TODO: first check if Elem is ground
6249 singleton_set_element(Set,Elem,Span,WF).
6250 singleton_set_element_wd(Set,Elem,_,WF) :- % TODO: only propagate if fully known?
6251 %(debug_mode(on) -> add_message_wf('MU_WD','MU_WD result instantiated: ',Elem,Span,WF) ; true),
6252 equal_object_wf(Set,[Elem],singleton_set_element_wd,WF).
6253
6254
6255 %:- print(finished_loading_kernel_objects),nl.