| 1 | | % (c) 2009-2024 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, |
| 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_printing). |
| 144 | | :- use_module(tools). |
| 145 | | |
| 146 | | :- use_module(module_information,[module_info/2]). |
| 147 | | :- module_info(group,kernel). |
| 148 | | :- module_info(description,'This module provides operations for the basic datatypes of ProB (equal, not_equal, enumeration).'). |
| 149 | | |
| 150 | | :- use_module(typechecker). |
| 151 | | :- use_module(error_manager). |
| 152 | | :- use_module(b_global_sets). %,[global_type/2, b_global_set_cardinality/2, b_empty_global_set/1]). |
| 153 | | :- use_module(kernel_waitflags). |
| 154 | | :- use_module(library(lists)). |
| 155 | | :- use_module(library(avl),[avl_min/2, avl_max/2]). |
| 156 | | :- use_module(library(clpfd)). |
| 157 | | :- use_module(fd_utils_clpfd). |
| 158 | | :- use_module(kernel_freetypes). |
| 159 | | :- use_module(kernel_card_arithmetic). |
| 160 | | :- use_module(custom_explicit_sets). |
| 161 | | :- use_module(typechecker). |
| 162 | | %:- use_module(clpfd_off_interface). % |
| 163 | | % on a 32 bit system: use clpfd_off_interface; on 64 bit system clpfd_interface should be ok (integer overflows) |
| 164 | | :- use_module(clpfd_interface). % |
| 165 | | :- use_module(bsyntaxtree, [get_texpr_id/2, get_texpr_pos/2]). |
| 166 | | |
| 167 | | :- type atomic_type +--> (term(integer,[]) ; term(string,[]) ; constant(list(atomic)) ; abort ; boolean ; global(atomic)). |
| 168 | | :- type atomic_any_type +--> (type(atomic_type) ; term(any,[]) ). |
| 169 | | :- type basic_type_descriptor +--> (type(atomic_any_type) ; set(basic_type_descriptor) ; |
| 170 | | seq(basic_type_descriptor) ; |
| 171 | | couple(basic_type_descriptor,basic_type_descriptor) ; |
| 172 | | record(list(type(field_type))) ; |
| 173 | | freetype(atomic)). |
| 174 | | |
| 175 | | :- type inferred_basic_type_descriptor +--> (var ; type(atomic_type) ; set(inferred_basic_type_descriptor) ; |
| 176 | | seq(inferred_basic_type_descriptor) ; |
| 177 | | couple(inferred_basic_type_descriptor,inferred_basic_type_descriptor)). |
| 178 | | |
| 179 | | :- type fd_index +--> (integer ; var). |
| 180 | | :- type fd_set +--> (atomic ; var). |
| 181 | | :- type fd_term +--> fd(fd_index,fd_set). |
| 182 | | :- type bsets_integer +--> int((integer ; var)). |
| 183 | | :- type bsets_string +--> string((atomic ; var)). |
| 184 | | :- type bsets_bool +--> (pred_false /* bool_false */ ; pred_true /* bool_true */). |
| 185 | | :- type field_type +--> field(atomic,basic_type_descriptor). |
| 186 | | |
| 187 | | %:- type bsets_sequence +--> (nil_seq ; cons(type(bsets_object),type(bsets_sequence))). |
| 188 | | %:- type bsets_set +--> vlist(type(bsets_object)). |
| 189 | | :- functor([_|_],ListFunctor,_), |
| 190 | | (type bsets_set +--> (term([],[]) ; var ; term(ListFunctor,[type(bsets_object),type(bsets_set)]) ; |
| 191 | | avl_set( ground ) ; |
| 192 | | closure(list(type(variable_id)), |
| 193 | | list(type(basic_type_descriptor)),type(boolean_expression)) |
| 194 | | ; closure_x(list(type(variable_id)), |
| 195 | | list(type(basic_type_descriptor)),type(boolean_expression),any))). |
| 196 | | :- type bsets_couple +--> term(',',[type(bsets_object),type(bsets_object)]). |
| 197 | | :- type bsets_global +--> global_set((atomic ; var)). |
| 198 | | :- type bsets_field +--> field(atomic,type(bsets_object)). |
| 199 | | :- type bsets_record +--> rec((var ; list(bsets_field))). |
| 200 | | :- type bsets_freetype +--> freeval(atomic,(atomic ; var),type(bsets_object)). |
| 201 | | |
| 202 | | :- type bsets_object +--> (fd_term ; bsets_integer ; bsets_bool ; term(term,[any]) ; bsets_set ; |
| 203 | | % abort(any) ; % deprecated |
| 204 | | bsets_couple ; bsets_string ; bsets_global ; var; |
| 205 | | bsets_record ; bsets_freetype). |
| 206 | | |
| 207 | | |
| 208 | | :- assert_must_succeed(kernel_waitflags:set_silent(true)). % disable waitflag store not init msgs |
| 209 | | |
| 210 | | |
| 211 | | |
| 212 | | |
| 213 | | % a predicate to exhaustively check a kernel predicate with all possible modes |
| 214 | | |
| 215 | | :- use_module(tools_timeout,[time_out_call/1]). |
| 216 | | exhaustive_kernel_check_opt(C,Cond) :- (Cond -> exhaustive_kernel_check(C) ; true). |
| 217 | | exhaustive_kernel_check(C) :- exhaustive_kernel_check4([],C,true,true). |
| 218 | | exhaustive_kernel_check(Opts,C) :- exhaustive_kernel_check4(Opts,C,true,true). |
| 219 | | exhaustive_kernel_check_wf(C,WF) :- exhaustive_kernel_check_wf([],C,WF). |
| 220 | | exhaustive_kernel_check_wf(Opts,C,WF) :- |
| 221 | | exhaustive_kernel_check4(Opts,C,kernel_waitflags:init_wait_flags(WF), |
| 222 | | kernel_waitflags:ground_wait_flags(WF)). |
| 223 | | exhaustive_kernel_check_wfdet(C,WF) :- |
| 224 | | exhaustive_kernel_check4([],C,kernel_waitflags:init_wait_flags(WF), |
| 225 | | kernel_waitflags:ground_det_wait_flag(WF)). |
| 226 | | exhaustive_kernel_check_wf_upto(C,WF,Limit) :- |
| 227 | | exhaustive_kernel_check4([],C,kernel_waitflags:init_wait_flags(WF), |
| 228 | | (kernel_waitflags:ground_wait_flag_to(WF,Limit), |
| 229 | | kernel_waitflags:portray_waitflags(WF))). |
| 230 | | |
| 231 | | exhaustive_kernel_check4(Opts,Call,Pre,Post) :- enumerate_kernel_call(Call,Opts,ECall,Code), |
| 232 | | debug_println(9,exhaustive_kernel_check(ECall,Code)), |
| 233 | | flatten_call((Pre,ECall,Code,Post),FullCall), |
| 234 | | must_succeed_without_residue_and_time_out(FullCall), debug_println(9,ok), |
| 235 | | fail. |
| 236 | | exhaustive_kernel_check4(_,_,_,_). |
| 237 | | |
| 238 | | flatten_call((A,B),Res) :- !,flatten_call(A,FA), flatten_call(B,FB), conjoin_call(FA,FB,Res). |
| 239 | | flatten_call(Module:Call,Res) :- !, flatten_call(Call,F), Res=Module:F. |
| 240 | | flatten_call(X,X). |
| 241 | | |
| 242 | | conjoin_call(true,X,R) :- !,R=X. |
| 243 | | conjoin_call(X,true,R) :- !, R=X. |
| 244 | | conjoin_call(X,Y,(X,Y)). |
| 245 | | |
| 246 | | exhaustive_kernel_succeed_check(C) :- exhaustive_kernel_succeed_check([],C). |
| 247 | | exhaustive_kernel_succeed_check(Opts,Call) :- enumerate_kernel_call(Call,Opts,ECall,Code), |
| 248 | | debug_println(9,exhaustive_kernel_succeed_check(ECall,Code)), |
| 249 | | flatten_call((ECall,Code),FullCall), |
| 250 | | time_out_call(must_succeed(FullCall)),debug_println(9,ok), |
| 251 | | fail. |
| 252 | | exhaustive_kernel_succeed_check(_,_). |
| 253 | | |
| 254 | | exhaustive_kernel_fail_check_opt(C,Cond) :- (Cond -> exhaustive_kernel_fail_check(C) ; true). |
| 255 | | exhaustive_kernel_fail_check(C) :- exhaustive_kernel_fail_check4([],C,true,true). |
| 256 | | exhaustive_kernel_fail_check(Opts,C) :- exhaustive_kernel_fail_check4(Opts,C,true,true). |
| 257 | | exhaustive_kernel_fail_check_wf(C,WF) :- |
| 258 | | exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF), |
| 259 | | kernel_waitflags:ground_wait_flags(WF)). |
| 260 | | exhaustive_kernel_fail_check_wfdet(C,WF) :- |
| 261 | | exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF), |
| 262 | | kernel_waitflags:ground_det_wait_flag(WF)). |
| 263 | | exhaustive_kernel_fail_check_wf_upto(C,WF,Limit) :- |
| 264 | | exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF), |
| 265 | | kernel_waitflags:ground_wait_flag_to(WF,Limit)). |
| 266 | | exhaustive_kernel_fail_check_wfinit(C,WF) :- |
| 267 | | exhaustive_kernel_fail_check4([],C,kernel_waitflags:init_wait_flags(WF), true). |
| 268 | | |
| 269 | | exhaustive_kernel_fail_check4(Opts,Call,Pre,Post) :- enumerate_kernel_call(Call,Opts,ECall,Code), |
| 270 | | debug_println(9,exhaustive_kernel_fail_check(ECall,Code)), |
| 271 | | flatten_call((Pre,ECall,Code,Post),FullCall), |
| 272 | | time_out_call(must_fail(FullCall)),debug_println(9,ok), |
| 273 | | fail. |
| 274 | | exhaustive_kernel_fail_check4(_,_,_,_). |
| 275 | | |
| 276 | | % enumerate_kernel_call(Call, OptionList, NewCall, CodeAfter) |
| 277 | | enumerate_kernel_call((A,B),Opts,(EA,EB),(CA,CB)) :- !, |
| 278 | | enumerate_kernel_call(A,Opts,EA,CA), enumerate_kernel_call(B,Opts,EB,CB). |
| 279 | | enumerate_kernel_call(Module:Call,Opts,Module:ECall,Code) :- !, enumerate_kernel_call(Call,Opts,ECall,Code). |
| 280 | | enumerate_kernel_call(Call,Opts,ECall,Code) :- Call=..[KernelPred|CArgs], |
| 281 | | (member(commutative,Opts) |
| 282 | | -> (Args=CArgs ; CArgs=[A1,A2|T], Args=[A2,A1|T]) |
| 283 | | ; Args=CArgs |
| 284 | | ), |
| 285 | | l_enumerate_kernel_args(Args,EArgs,Code,KernelPred,1), ECall=..[KernelPred|EArgs]. |
| 286 | | l_enumerate_kernel_args([],[],true,_,_). |
| 287 | | l_enumerate_kernel_args([H|T],[EH|ET],Code,KernelPred,Nr) :- |
| 288 | | enumerate_kernel_args(H,EH,C1,KernelPred/Nr), |
| 289 | | N1 is Nr+1, |
| 290 | | l_enumerate_kernel_args(T,ET,C2,KernelPred,N1), |
| 291 | | permute_code((C1,C2),Code). |
| 292 | | |
| 293 | | permute_code((true,C),R) :- !,R=C. |
| 294 | | permute_code((C,true),R) :- !, R=C. |
| 295 | | permute_code((C1,C2),(C1,C2)). |
| 296 | | permute_code((C1,C2),(C2,C1)). |
| 297 | | |
| 298 | | enumerate_kernel_args(Var,Res,Code,_) :- var(Var),!, Res=Var, Code=true. |
| 299 | | enumerate_kernel_args(X,Res,Code,KP_Nr) :- do_not_delay(X,KP_Nr),!, Res=X, Code=true. |
| 300 | | enumerate_kernel_args(Arg,Arg,true,_). % just keep the argument |
| 301 | | enumerate_kernel_args(Args,NewArg,Code,KP_Nr) :- arg_is_list(KP_Nr),!, |
| 302 | | % we have a list of B expressions (e.g., in partition_wf) |
| 303 | | (Code = '='(NewArg,Args) ; l_enumerate_kernel_args(Args,NewArg,Code,arg_is_list,1)). |
| 304 | | enumerate_kernel_args(Arg,NewArg,Code,_) :- % delay the argument fully |
| 305 | | (term_is_of_type(Arg,bsets_object,no) |
| 306 | | -> Code = equal_object(NewArg,Arg,enumerate_kernel_args) |
| 307 | | ; Code = '='(NewArg,Arg)). |
| 308 | | enumerate_kernel_args(int(X),int(XX),Code,_) :- nonvar(X), Code = '='(X,XX). % delay setting number content |
| 309 | | enumerate_kernel_args(string(X),string(XX),Code,_) :- nonvar(X), Code = '='(X,XX). % delay setting string content |
| 310 | | enumerate_kernel_args(term(floating(X)),term(floating(XX)),Code,_) :- nonvar(X), Code = '='(X,XX). % delay setting real number content |
| 311 | | enumerate_kernel_args((A,B),(AA,BB),(CodeA,CodeB),KP_Nr) :- |
| 312 | | enumerate_kernel_args(A,AA,CodeA,KP_Nr),enumerate_kernel_args(B,BB,CodeB,KP_Nr), |
| 313 | | (AA,BB) \== (A,B). % avoid re-generating case 3 above (just keep argument) |
| 314 | | enumerate_kernel_args(freeval(ID,Case,A),freeval(ID,Case,AA),CodeA,KP_Nr) :- |
| 315 | | enumerate_kernel_args(A,AA,CodeA,KP_Nr), |
| 316 | | AA \== A. % avoid re-generating case 3 above (just keep argument) |
| 317 | | enumerate_kernel_args([H|T],[H|NewT],Code,_) :- Code = equal_object(NewT,T). % delay tail |
| 318 | | enumerate_kernel_args([H|T],[(int(NewI),H2)|T],Code,_) :- nonvar(H), % make index (e.g. of sequence) nonvar first |
| 319 | | H = (II,H2), ground(II), II=int(I), \+ member((int(I),_),T), % the element is unique in domain |
| 320 | | Code = '='(NewI,I). |
| 321 | | enumerate_kernel_args([H|T],[(H1,NewH2)|T],Code,_) :- nonvar(H), |
| 322 | | H = (H1,H2), ground(H2), \+ member((_,H2),T), % the element is unique in ragne |
| 323 | | Code = equal_object(NewH2,H2). |
| 324 | | enumerate_kernel_args([H|T],Res,Code,KP_Nr) :- |
| 325 | | try_expand_and_convert_to_avl([H|T],AVL), |
| 326 | | AVL \= [H|T], enumerate_kernel_args(AVL,Res,Code,KP_Nr). |
| 327 | | enumerate_kernel_args([H|T],Res,Code,KP_Nr) :- ground([H|T]),generate_member_closure([H|T],Closure), |
| 328 | | enumerate_kernel_args(Closure,Res,Code,KP_Nr). |
| 329 | | |
| 330 | | % check if an argument is a list not a set. |
| 331 | | arg_is_list(KernelPred/Nr) :- argument_is_list_not_set(KernelPred,Nr). |
| 332 | | %arg_is_not_list(KernelPred/Nr) :- \+ argument_is_list_not_set(KernelPred,Nr). |
| 333 | | argument_is_list_not_set(partition_wf,2). |
| 334 | | argument_is_list_not_set(not_partition_wf,2). |
| 335 | | argument_is_list_not_set(test_partition_wf,2). |
| 336 | | argument_is_list_not_set(disjoint_union_generalized_wf,1). |
| 337 | | |
| 338 | | do_not_delay(b(_,_,_),_). % do not delay instantiation B predicates and expressions |
| 339 | | do_not_delay(global_set(G),KP/ArgNr) :- custom_explicit_sets:is_infinite_global_set(G,_), |
| 340 | | do_not_delay_arg(KP,ArgNr). |
| 341 | | % these arguments cause difficulty if infinite sets are delayed (i.e., instantiated later) |
| 342 | | do_not_delay_arg(partial_function_wf,2). |
| 343 | | do_not_delay_arg(partial_function_wf,3). |
| 344 | | do_not_delay_arg(subset_test,2). |
| 345 | | do_not_delay_arg(subset_strict_test,2). |
| 346 | | |
| 347 | | generate_member_closure(ExplicitSet,closure(['_zzzz_unit_tests'],[Type],Pred)) :- |
| 348 | | infer_type(ExplicitSet,set(Type)), |
| 349 | | Pred = |
| 350 | | b(member(b(identifier('_zzzz_unit_tests'),Type,[generated]), |
| 351 | | b(value(ExplicitSet),set(Type),[])),pred,[]). |
| 352 | | |
| 353 | | infer_type(Value,Type) :- (infer_value_type(Value,Type) |
| 354 | | -> true %,print(inferred(Type,Value)),nl |
| 355 | | ; print('### Could not infer type: '), print(Value),nl,fail). |
| 356 | | |
| 357 | | :- use_module(btypechecker,[couplise_list/2]). |
| 358 | | infer_value_type(Var,Type) :- var(Var),!,Type=any. |
| 359 | | infer_value_type([],set(any)). |
| 360 | | infer_value_type([H|T],set(ResType)) :- infer_value_type(H,Type), |
| 361 | | ((contains_any(Type),T=[H2|_], % try H2; maybe we can infer a better type here |
| 362 | | infer_value_type(H2,Type2), \+ contains_any(Type2)) |
| 363 | | -> ResType = Type2 |
| 364 | | ; ResType = Type). |
| 365 | | infer_value_type(avl_set(node(H,_True,_,_,_)),set(Type)) :- infer_value_type(H,Type). |
| 366 | | infer_value_type(int(_),integer). |
| 367 | | infer_value_type(string(_),string). |
| 368 | | infer_value_type((A,B),couple(TA,TB)) :- infer_value_type(A,TA), infer_value_type(B,TB). |
| 369 | | infer_value_type(fd(_,T),global(T)). |
| 370 | | infer_value_type(pred_true /* bool_true */,boolean). |
| 371 | | infer_value_type(pred_false /* bool_false */,boolean). |
| 372 | | infer_value_type(rec(Fields),record(FieldTypes)) :- infer_field_types(Fields,FieldTypes). |
| 373 | | infer_value_type(freeval(Id,_Case,_Val),freetype(Id)). |
| 374 | | infer_value_type(closure(_,Types,_),set(Res)) :- couplise_list(Types,Res). |
| 375 | | infer_value_type(global_set('STRING'),R) :- !, R=set(string). % what if Event-B/TLA have a deferred set of that name |
| 376 | | infer_value_type(global_set('FLOAT'),R) :- !, R=set(real). |
| 377 | | infer_value_type(global_set('REAL'),R) :- !, R=set(real). |
| 378 | | infer_value_type(global_set(X),R) :- b_integer_set(X),!,R=set(integer). |
| 379 | | infer_value_type(global_set(Name),set(global(Name))) :- b_global_set(Name). |
| 380 | | infer_value_type(term(floating(_)),real). % see kernel_reals:is_real(.) |
| 381 | | |
| 382 | | infer_field_types([],[]). |
| 383 | | infer_field_types([field(Name1,Val)|T],[field(Name1,VT)|TT]) :- |
| 384 | | infer_value_type(Val,VT), |
| 385 | | infer_field_types(T,TT). |
| 386 | | |
| 387 | | contains_any(any). |
| 388 | | contains_any(couple(A,B)) :- (contains_any(A) -> true ; contains_any(B)). |
| 389 | | contains_any(set(A)) :- contains_any(A). |
| 390 | | % to do: fields |
| 391 | | |
| 392 | | :- assert_pre(kernel_objects:basic_type(Obj,Type), (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))). |
| 393 | | :- assert_post(kernel_objects:basic_type(Obj,_), type_check(Obj,bsets_object)). |
| 394 | | |
| 395 | | %:- block basic_type(-,-). |
| 396 | | |
| 397 | | basic_type(FD,global(T)) :- !, global_type(FD,T). % will set up CLP(FD) domain for X |
| 398 | | % TO DO: Also: what about global(T) inside other structures (pairs) ? |
| 399 | | basic_type(Rec,record(FieldTypes)) :- !, Rec=rec(Fields), |
| 400 | ? | basic_field_types(Fields,FieldTypes). |
| 401 | | %basic_type(Set,set(Type)) :- !, basic_type_set(Type,Set,inf). |
| 402 | | basic_type(_X,_TY). %basic_type2(TY,X) %basic_symbreak(TY,X) |
| 403 | | %print(ignore_basic_type(X,Y)),nl %, basic_type2(TY,X) %%STILL REQUIRED ????? |
| 404 | | |
| 405 | | basic_field_types([],[]). |
| 406 | | basic_field_types([field(Name1,Val)|T],[field(Name2,VT)|TT]) :- |
| 407 | | check_field_name_compatibility(Name1,Name2,basic_field_types2), |
| 408 | ? | basic_type(Val,VT),basic_field_types(T,TT). |
| 409 | | |
| 410 | | |
| 411 | | |
| 412 | | /* ------------------------- */ |
| 413 | | /* enumerate_basic_type/2 */ |
| 414 | | /* ------------------------- */ |
| 415 | | /* a version of basic_type that enumerates */ |
| 416 | | |
| 417 | | :- assert_must_succeed(enumerate_basic_type([],set(couple(integer,integer)) )). |
| 418 | | :- assert_must_succeed(enumerate_basic_type([([],int(2)), ([int(3)],int(4))], |
| 419 | | set(couple(set(integer),integer)) )). |
| 420 | | :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))], |
| 421 | | set(couple(integer,integer)) )). |
| 422 | | :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))], |
| 423 | | seq(integer) )). |
| 424 | | :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))], |
| 425 | | seq(integer) )). |
| 426 | | :- assert_must_succeed((enumerate_basic_type(X,global('Name')), |
| 427 | | equal_object(X,fd(1,'Name')) )). |
| 428 | | :- assert_must_succeed((enumerate_basic_type(X,global('Name')), |
| 429 | | equal_object(X,fd(2,'Name')) )). |
| 430 | | :- assert_must_succeed((enumerate_basic_type(X,global('Name')), |
| 431 | | X==fd(2,'Name')) ). |
| 432 | | :- assert_must_succeed((enumerate_basic_type(X,record([field(a,global('Name'))])), |
| 433 | | equal_object(X,rec([field(a,fd(1,'Name'))])) )). |
| 434 | | :- assert_must_succeed((enumerate_basic_type(X,record([field(a,integer),field(b,global('Name'))])), |
| 435 | | equal_object(X,rec([field(a,int(1)),field(b,fd(1,'Name'))])) )). |
| 436 | | :- assert_must_succeed((kernel_freetypes:add_freetype(selfc1,[case(a,constant([a])),case(b,integer)]), |
| 437 | | kernel_freetypes:set_freetype_depth(2), |
| 438 | | enumerate_basic_type(X,freetype(selfc1)),equal_object(X,freeval(selfc1,a,term(a))), |
| 439 | | kernel_freetypes:reset_freetypes)). |
| 440 | | :- assert_must_succeed((kernel_freetypes:add_freetype(selfc5,[case(a,constant([a])),case(b,integer)]), |
| 441 | | kernel_freetypes:set_freetype_depth(2), |
| 442 | | enumerate_basic_type(X,freetype(selfc5)),equal_object(X,freeval(selfc5,b,int(1))), |
| 443 | | kernel_freetypes:reset_freetypes)). |
| 444 | | :- assert_must_succeed((kernel_freetypes:add_freetype(selfc7,[case(nil,constant([nil])),case(node,couple(freetype(selfc7),freetype(selfc7)))]), |
| 445 | | kernel_freetypes:set_freetype_depth(3), |
| 446 | | findall(X,enumerate_basic_type(X,freetype(selfc7)),Solutions), |
| 447 | | length(Solutions,5), |
| 448 | | kernel_freetypes:reset_freetypes)). |
| 449 | | :- assert_must_succeed((kernel_freetypes:add_freetype(selfc2,[case(a,constant([a])),case(b,freetype(selfc3))]), |
| 450 | | kernel_freetypes:add_freetype(selfc3,[case(c,constant([c])),case(d,freetype(selfc2))]), |
| 451 | | kernel_freetypes:set_freetype_depth(4), |
| 452 | | enumerate_basic_type(X,freetype(selfc2)), |
| 453 | | equal_object(X,freeval(selfc2,b,freeval(selfc3,d,freeval(selfc2,b,freeval(selfc3,c,term(c)))))), |
| 454 | | kernel_freetypes:reset_freetypes)). |
| 455 | | :- assert_must_succeed((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ), |
| 456 | | equal_object(X,[(fd(1,'Name'),fd(1,'Code'))])) ). |
| 457 | | :- assert_must_succeed((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ), |
| 458 | | equal_object(X,[(fd(2,'Name'),fd(1,'Code')), (fd(1,'Name'),fd(2,'Code'))])) ). |
| 459 | | :- assert_must_succeed((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ), |
| 460 | | equal_object(X,[(fd(1,'Name'),fd(2,'Code')), (fd(2,'Name'),fd(1,'Code'))])) ). |
| 461 | | :- assert_must_succeed_any((enumerate_basic_type(X,set(couple(global('Name'),global('Code'))) ), |
| 462 | | equal_object(X,[(fd(1,'Name'),fd(2,'Code')), (fd(2,'Name'),fd(1,'Code'))])) ). |
| 463 | | :- assert_must_succeed(enumerate_basic_type([(int(2),(int(1),int(2))), |
| 464 | | (int(1),(int(3),int(4)))], |
| 465 | | set(couple(integer,couple(integer,integer))) )). |
| 466 | | :- assert_must_succeed(enumerate_basic_type([(int(2),(int(1),int(2))), |
| 467 | | (int(55),(int(3),int(4)))], |
| 468 | | set(couple(integer,couple(integer,integer))) )). |
| 469 | | :- assert_must_succeed(enumerate_basic_type([term('err')],set(constant([err])))). |
| 470 | | :- assert_must_succeed(enumerate_basic_type([(int(1),int(2)),(int(3),int(4))], |
| 471 | | set(couple(integer,integer)))). |
| 472 | | |
| 473 | | :- assert_must_succeed_multiple(enumerate_basic_type([(int(2),fd(_A,'Name')),(int(3),fd(_B,'Name')), |
| 474 | | (int(4),fd(_C,'Name')),(int(5),fd(_D,'Name')),(int(6),fd(_E,'Name')),(int(7),fd(_F,'Name')), |
| 475 | | (int(8),fd(_G,'Name')),(int(9),fd(_H,'Name')),(int(10),fd(_I,'Name')), |
| 476 | | (int(11),fd(_,'Name')),(int(12),fd(_,'Name')),(int(13),fd(_,'Name')), |
| 477 | | (int(14),fd(_,'Name'))],set(couple(integer,global('Name'))))). |
| 478 | | |
| 479 | | :- 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) )). |
| 480 | | |
| 481 | | :- assert_must_succeed(( enumerate_basic_type(global_set('Code'), |
| 482 | | set(global('Code'))) )). |
| 483 | | |
| 484 | | :- 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')))))). |
| 485 | | :- 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))))). |
| 486 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(enumerate_basic_type([pred_true,pred_false],set(boolean)))). |
| 487 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(enumerate_basic_type([[],[pred_true,pred_false]],set(set(boolean))))). |
| 488 | | |
| 489 | | :- assert_pre(kernel_objects:enumerate_basic_type(Obj,Type), |
| 490 | | (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))). |
| 491 | | :- assert_post(kernel_objects:enumerate_basic_type(Obj,_), (type_check(Obj,bsets_object),ground_check(Obj))). |
| 492 | | |
| 493 | | enumerate_basic_type_wf(Obj,Type,WF) :- |
| 494 | | enumerate_basic_type_wf(Obj,Type,enumerate_basic_type,WF). |
| 495 | | :- block enumerate_basic_type_wf(?,-,?,?). |
| 496 | | enumerate_basic_type_wf(Obj,Type,EnumWarning,WF) :- |
| 497 | | enumerate_basic_type4(Type,Obj,basic,trigger_true(EnumWarning),WF). % add WF context info |
| 498 | | |
| 499 | | :- block enumerate_basic_type(?,-). |
| 500 | | enumerate_basic_type(Obj,Type) :- |
| 501 | | %enumerate_basic_type2(Obj,Type). |
| 502 | | enumerate_basic_type4(Type,Obj,basic,trigger_true(enumerate_basic_type),no_wf_available). |
| 503 | | %(ground(Obj) -> true ; enumerate_basic_type3(Type,Obj,basic)). |
| 504 | | |
| 505 | | :- block enumerate_basic_type(?,-,-). |
| 506 | | enumerate_basic_type(Obj,Type,EnumWarning) :- |
| 507 | | enumerate_basic_type4(Type,Obj,basic,EnumWarning,no_wf_available). |
| 508 | | |
| 509 | | |
| 510 | | :- block enumerate_type(?,-,?). % last argument: basic or tight |
| 511 | | enumerate_type(Obj,Type,Tight) :- |
| 512 | | %enumerate_basic_type2(Obj,Type). |
| 513 | | enumerate_basic_type4(Type,Obj,Tight,trigger_true(enumerate_type_3),no_wf_available). |
| 514 | | |
| 515 | | :- block enumerate_type(?,-,?,?), enumerate_type(?,?,?,-). |
| 516 | | enumerate_type(Obj,Type,Tight,EnumWarning) :- |
| 517 | | enumerate_basic_type4(Type,Obj,Tight,EnumWarning,no_wf_available). |
| 518 | | |
| 519 | | enumerate_type_wf(Obj,Type,Tight,WF) :- |
| 520 | ? | enumerate_type_wf(Obj,Type,Tight,trigger_true(enumerate_type_wf),WF). |
| 521 | | |
| 522 | | :- block enumerate_type_wf(?,-,?,?,?), enumerate_type_wf(?,?,?,-,?). |
| 523 | | enumerate_type_wf(Obj,Type,Tight,EnumWarning,WF) :- |
| 524 | ? | enumerate_basic_type4(Type,Obj,Tight,EnumWarning,WF). |
| 525 | | |
| 526 | | %enumerate_basic_type2(X,Type) :- |
| 527 | | % (ground(X) -> (basic_type(X,Type) -> true |
| 528 | | % ; add_internal_error('Type error: ',enumerate_basic_type2(X,Type))) |
| 529 | | % ; enumerate_basic_type3(Type,X)). |
| 530 | | |
| 531 | | enumerate_basic_type4(global(T),R,_Tight,EnumWarning,WF) :- |
| 532 | ? | enumerate_global_type_with_enum_warning(R,T,EnumWarning,WF). |
| 533 | | enumerate_basic_type4(set(X),Set,Tight,EnumWarning,WF) :- |
| 534 | ? | enumerate_basic_type_set(Set,X,Tight,EnumWarning,WF). |
| 535 | | enumerate_basic_type4(seq(SeqRanType),Seq,Tight,EnumWarning,WF) :- |
| 536 | | (Tight = tight -> enumerate_seq_type_wf(Seq,SeqRanType,EnumWarning,WF) % might trigger warning. push flag. |
| 537 | | ; enumerate_basic_type4(set(couple(integer,SeqRanType)),Seq,basic,EnumWarning,WF)). |
| 538 | | enumerate_basic_type4(couple(XT,YT),(X,Y),Tight,EnumWarning,WF) :- |
| 539 | ? | enumerate_type_wf(X,XT,Tight,EnumWarning,WF), |
| 540 | ? | enumerate_type_wf(Y,YT,Tight,EnumWarning,WF). |
| 541 | ? | enumerate_basic_type4(boolean,B,_Tight,_EnumWarning,_WF) :- enumerate_bool(B). |
| 542 | | enumerate_basic_type4(real,R,_Tight,EnumWarning,WF) :- enumerate_real_wf(R,EnumWarning,WF). |
| 543 | | enumerate_basic_type4(string,string(S),_Tight,EnumWarning,WF) :- enumerate_string_wf(S,EnumWarning,WF). |
| 544 | | enumerate_basic_type4(constant([V]),term(V),_Tight,_EnumWarning,_WF). |
| 545 | | enumerate_basic_type4(record(FT),rec(F),Tight,EnumWarning,WF) :- |
| 546 | ? | enumerate_basic_field_types(F,FT,Tight,EnumWarning,WF). |
| 547 | | enumerate_basic_type4(freetype(Id),freeval(Id2,C,Value),Tight,EnumWarning,WF) :- |
| 548 | | (Id=Id2 -> true |
| 549 | | ; add_internal_error('Freetypes do not match:',enumerate_basic_type4(freetype(Id),freeval(Id2,C,Value),Tight,_,_))), |
| 550 | | (ground_value(freeval(Id2,C,Value)) -> true |
| 551 | | ; (is_recursive_freetype(Id), |
| 552 | | max_freetype_enum_depth(Depth) |
| 553 | | -> gen_enum_warning_wf(Id,0:inf,0:Depth,EnumWarning,unknown,WF) |
| 554 | | ; true), |
| 555 | ? | enumerate_freetype_wf(Tight,freeval(Id,C,Value),freetype(Id),WF) |
| 556 | | ). |
| 557 | | enumerate_basic_type4(freetype_lim_depth(Id,Depth),freeval(Id2,C,Value),Tight,_EnumWarning,WF) :- |
| 558 | | (Id=Id2 -> true |
| 559 | | ; add_internal_error('Freetypes do not match:',enumerate_basic_type4(freetype_lim_depth(Id,Depth),freeval(Id2,C,Value),Tight,_,_))), |
| 560 | | % freetype_lim_depth is created artificially by enumerate_freetype |
| 561 | ? | enumerate_freetype_wf(Tight,freeval(Id,C,Value),freetype_lim_depth(Id,Depth),WF). |
| 562 | | enumerate_basic_type4(integer,int(N),Tight,EnumWarning,WF) :- |
| 563 | | (nonvar(N) |
| 564 | | -> (integer(N) -> true |
| 565 | | ; add_internal_error('Illegal value:',enumerate_basic_type4(integer,int(N),Tight,EnumWarning,WF)) |
| 566 | | ) |
| 567 | ? | ; enumerate_int_with_span(N,EnumWarning,unknown,WF)). |
| 568 | | enumerate_basic_type4(abort,V,Tight,EnumWarning,WF) :- |
| 569 | | add_internal_error(deprecated_abort_type,enumerate_basic_type4(abort,V,Tight,EnumWarning,WF)). |
| 570 | | enumerate_basic_type4(constant,V,Tight,EnumWarning,WF) :- |
| 571 | | add_internal_error(deprecated_abort_type,enumerate_basic_type4(constant,V,Tight,EnumWarning,WF)). |
| 572 | | enumerate_basic_type4(any,Obj,_Tight,EnumWarning,WF) :- enumerate_any_wf(Obj,EnumWarning,WF). |
| 573 | | |
| 574 | | :- use_module(library(random),[random/3]). |
| 575 | | enumerate_bool(X) :- preferences:preference(randomise_enumeration_order,true), |
| 576 | | random(1,3,1),!, |
| 577 | | (X=pred_false ; X=pred_true). |
| 578 | | enumerate_bool(pred_true). /* was bool_true */ |
| 579 | | enumerate_bool(pred_false). |
| 580 | | |
| 581 | | max_cardinality_string(inf). % was 2 |
| 582 | | all_strings_wf(AS,WF) :- findall(string(S),enumerate_string_wf(S,trigger_throw(all_strings),WF),AS). |
| 583 | | :- use_module(btypechecker,[machine_string/1]). |
| 584 | | enumerate_string_wf(S,_EnumWarning,_WF) :- atomic(S),!. |
| 585 | | enumerate_string_wf(S,EnumWarning,WF) :- %print('### WARNING, Enumerating STRING'),nl, |
| 586 | | % frozen(S,Goal), print(enum(S,Goal)),nl, |
| 587 | | % MAYBE TO DO: we could check if prolog:dif(S,'"STR1"') are in frozen Goal and then enumerate more? |
| 588 | | % if we do this we need to adapt dont_expand(global('STRING')) :- ... further below |
| 589 | | gen_enum_warning_wf('STRING',inf,'"STRING1","STRING2",...',EnumWarning,unknown,WF), |
| 590 | | (S = 'STRING1', \+ machine_string(S) % used to be '"STR1"' |
| 591 | | ; S = 'STRING2', \+ machine_string(S) % used to be '"STR2"' |
| 592 | | ; machine_string(S)). |
| 593 | | |
| 594 | | is_string(string(_),_WF). |
| 595 | | is_not_string(X) :- top_level_dif(X,string). |
| 596 | | |
| 597 | | |
| 598 | | :- use_module(library(random),[random/3]). |
| 599 | | :- use_module(kernel_reals,[is_ground_real/1, construct_real/2, is_real/2]). |
| 600 | | enumerate_real_wf(S,_EnumWarning,_) :- is_ground_real(S),!. |
| 601 | | enumerate_real_wf(S,EnumWarning,WF) :- |
| 602 | | gen_enum_warning_wf('REAL',inf,'"0.0","1.0",...',EnumWarning,unknown,WF), |
| 603 | | ( construct_real('0.0',S) |
| 604 | | ; construct_real('1.0',S) |
| 605 | | ; construct_real('-1.0',S) |
| 606 | | ; random(0.0,1.0,R), is_real(S,R) |
| 607 | | ; random(-1.0,0.0,R), is_real(S,R) |
| 608 | | ; preferences:preference(maxint,MaxInt), random(1.0,MaxInt,R), is_real(S,R) |
| 609 | | ; preferences:preference(minint,MinInt), random(MinInt,-1.0,R), is_real(S,R) |
| 610 | | ). |
| 611 | | |
| 612 | | |
| 613 | | :- block enumerate_any_wf(-,?,?). |
| 614 | | enumerate_any_wf(fd(X,T),EnumWarning,WF) :- !, |
| 615 | | when(nonvar(T),enumerate_global_type_with_enum_warning(fd(X,T),T,EnumWarning,WF)). |
| 616 | | enumerate_any_wf(int(N),EnumWarning,WF) :- !,enumerate_basic_type4(integer,int(N),basic,EnumWarning,WF). |
| 617 | | enumerate_any_wf(term(X),_EnumWarning,_WF) :- !, print_message(could_not_enumerate_term(X)). |
| 618 | | enumerate_any_wf(string(S),EnumWarning,WF) :- !, enumerate_string_wf(S,EnumWarning,WF). |
| 619 | | enumerate_any_wf(pred_true /* bool_true */,_EnumWarning,_WF) :- !. |
| 620 | | enumerate_any_wf(pred_false /* bool_false */,_EnumWarning,_WF) :- !. |
| 621 | | enumerate_any_wf([],_EnumWarning,_WF) :- !. |
| 622 | | enumerate_any_wf([H|T],EnumWarning,WF) :- !, enumerate_any_wf(H,EnumWarning,WF), enumerate_any_wf(T,EnumWarning,WF). |
| 623 | | enumerate_any_wf(avl_set(_),_EnumWarning,_WF) :- !. |
| 624 | | enumerate_any_wf(global_set(_),_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(rec(Fields),EnumWarning,WF) :- !, enumerate_any_wf(Fields,EnumWarning,WF). |
| 627 | | enumerate_any_wf(field(_,V),EnumWarning,WF) :- !, enumerate_any_wf(V,EnumWarning,WF). |
| 628 | | % we could support: closure values... |
| 629 | | enumerate_any_wf(T,_EnumWarning,_WF) :- add_message(enumerate_any_wf,'Could_not_enumerate value: ',T). |
| 630 | | |
| 631 | | |
| 632 | | :- use_module(preferences,[preference/2]). |
| 633 | | |
| 634 | | % enumerate an INTEGER variable |
| 635 | | enumerate_int_with_span(N,EnumWarning,Span,WF) :- |
| 636 | | clpfd_domain(N,FDLow,FDUp), % print(enum(N,FDLow,FDUp)),nl, |
| 637 | | (finite_domain(FDLow,FDUp) |
| 638 | ? | -> label(N,FDLow,FDUp) |
| 639 | ? | ; enum_unbounded(FDLow,FDUp,N,EnumWarning,Span,WF) |
| 640 | | ). |
| 641 | | label(N,FDLow,FDUp) :- |
| 642 | | gen_enum_warning_if_large(N,FDLow,FDUp), |
| 643 | ? | clpfd_interface:clpfd_randomised_labeling([],[N]). |
| 644 | | % Note: CLP(FD) labeling does not necessarily try all values in range (disjunctive domains) |
| 645 | | |
| 646 | | % when in CLP(FD) mode; try and do a case-split and see if that narrows down the possible ranges |
| 647 | | enum_unbounded(X,Y,N,EnumWarning,Span,WF) :- preferences:preference(use_clpfd_solver,true),!, |
| 648 | ? | enum_unbounded_clp(X,Y,N,EnumWarning,Span,WF). |
| 649 | | enum_unbounded(X,Y,N,EnumWarning,Span,WF) :- %frozen(N,G), print(frozen(N,G,X,Y,EnumWarning)),nl, |
| 650 | | clpfd_off_domain(N,X,Y,NX,NY), |
| 651 | | (finite_domain(NX,NY) -> enumerate_int1(N,NX,NY) |
| 652 | ? | ; enum_unbounded_clpfd_off(NX,NY,N,EnumWarning,Span,WF)). |
| 653 | | |
| 654 | | enum_unbounded_clpfd_off(_FDLow,_FDUp,N,_EnumWarning,_,_WF) :- is_wdguarded_result_variable(N),!. |
| 655 | | enum_unbounded_clpfd_off(FDLow,FDUp,N,EnumWarning,Span,WF) :- |
| 656 | | make_domain_finite(FDLow,FDUp,Min,Max), |
| 657 | | gen_enum_warning_wf('INTEGER',FDLow:FDUp,Min:Max,EnumWarning,Span,WF), |
| 658 | ? | enumerate_int1(N,Min,Max). % will also do a case split, but without posting constraints |
| 659 | | |
| 660 | | % try to determine integer variable bounds from pending co-routines for CLPFD off mode |
| 661 | | clpfd_off_domain(Var,Low,Up,NewLow,NewUp) :- |
| 662 | | frozen(Var,Goal), narrow_down_interval(Goal,Var,Low,Up,NewLow,NewUp). |
| 663 | | % ((Lowx,Up)==(NewLow,NewUp) -> true ; print(narrowed_down(Var,Low,Up,NewLow,NewUp)),nl). |
| 664 | | narrow_down_interval((A,B),Var,Low,Up,NewLow,NewUp) :- !, |
| 665 | | narrow_down_interval(A,Var,Low,Up,Low1,Up1), |
| 666 | | narrow_down_interval(B,Var,Low1,Up1,NewLow,NewUp). |
| 667 | | narrow_down_interval(kernel_objects:safe_less_than_equal(_,V1,V2),Var,Low,Up,NewLow,NewUp) :- !, |
| 668 | | (V1==Var,number(V2) -> NewLow=Low,fd_min(Up,V2,NewUp) |
| 669 | | ; V2==Var,number(V1) -> fd_max(Low,V1,NewLow),NewUp=Up |
| 670 | | ; NewLow=Low,NewUp=Up). |
| 671 | | narrow_down_interval(kernel_objects:safe_less_than(V1,V2),Var,Low,Up,NewLow,NewUp) :- !, |
| 672 | | (V1==Var,number(V2) -> NewLow=Low,V2m1 is V2-1, fd_min(Up,V2m1,NewUp) |
| 673 | | ; V2==Var,number(V1) -> V1p1 is V1+1, fd_max(Low,V1p1,NewLow),NewUp=Up |
| 674 | | ; NewLow=Low,NewUp=Up). |
| 675 | | narrow_down_interval(_,_,L,U,L,U). |
| 676 | | |
| 677 | | % check if this variable is marked as being assigned to by currently not-well-defined construct such as min,max,...: |
| 678 | | is_wdguarded_result_variable(N) :- % write('-WDG-'), |
| 679 | | frozen(N,FrozenGoal), % TO DO: use attribute rather than frozen |
| 680 | | is_wdguarded_result_variable_aux(FrozenGoal,N). |
| 681 | | is_wdguarded_result_variable_aux(kernel_waitflags:is_wd_guarded_result(V),N) :- !, N==V. |
| 682 | | is_wdguarded_result_variable_aux((A,B),N) :- |
| 683 | | is_wdguarded_result_variable_aux(A,N) ; is_wdguarded_result_variable_aux(B,N). |
| 684 | | |
| 685 | | % enumerate unbounded integer variable N in a CLP(FD) fashion: |
| 686 | | enum_unbounded_clp(0,Y,N,EnumWarning,Span,WF) :- (Y=sup ; Y>0), |
| 687 | | % we span 0 and positive numbers |
| 688 | | !, |
| 689 | | (N=0 |
| 690 | | % for division/modulo... 0 is often a special case |
| 691 | | ; try_post_constraint(N #>0), |
| 692 | | force_enumerate_int_wo_case_split(N,'INTEGER',EnumWarning,Span,WF) |
| 693 | | ). |
| 694 | | enum_unbounded_clp(X,Y,N,EnumWarning,Span,WF) :- |
| 695 | | (is_inf_or_overflow_card(X) -> true ; X<0), (Y=sup ; Y>0), |
| 696 | | % we span both negative and positive numbers |
| 697 | | !, |
| 698 | | % do a case split |
| 699 | | (N=0 |
| 700 | | % 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) |
| 701 | | ; 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 |
| 702 | ? | force_enumerate_int_wo_case_split(N,'INTEGER',EnumWarning,Span,WF) |
| 703 | | ; try_post_constraint(N #<0), |
| 704 | ? | force_enumerate_int_wo_case_split(N,'INTEGER',EnumWarning,Span,WF) |
| 705 | | ). |
| 706 | | enum_unbounded_clp(FDLow,FDUp,N,EnumWarning,Span,WF) :- |
| 707 | | % we cover only negative or only positive numbers |
| 708 | ? | force_enumerate_with_warning(N,FDLow,FDUp,'INTEGER',EnumWarning,Span,WF). |
| 709 | | |
| 710 | | % force enumeration without case split: |
| 711 | | force_enumerate_int_wo_case_split(N,Msg,EnumWarning,Span,WF) :- |
| 712 | | clpfd_domain(N,FDLow,FDUp), % print(enum(N,FDLow,FDUp)),nl, |
| 713 | | (finite_domain(FDLow,FDUp) |
| 714 | | -> label(N,FDLow,FDUp) |
| 715 | | ; %print(force_enumerate_int_wo_case_split(FDLow,FDUp)),nl, |
| 716 | ? | force_enumerate_with_warning(N,FDLow,FDUp,Msg,EnumWarning,Span,WF) |
| 717 | | ). |
| 718 | | |
| 719 | | force_enumerate_with_warning(N,_FDLow,_FDUp,_Msg,_EnumWarning,_Span,_WF) :- % check if we should enumerate at all |
| 720 | | is_wdguarded_result_variable(N),!. % affects tests 1825, 2017 |
| 721 | | force_enumerate_with_warning(N,FDLow,FDUp,Msg,EnumWarning,Span,WF) :- |
| 722 | | make_domain_finite(FDLow,FDUp,Min,Max), |
| 723 | | gen_enum_warning_wf(Msg,FDLow:FDUp,Min:Max,EnumWarning,Span,WF), |
| 724 | | %try_post_constraint(N in Min..Max), % I am not sure whether this is useful or not |
| 725 | ? | enumerate_int2(N,Min,Max). |
| 726 | | |
| 727 | | |
| 728 | | % generate enumeration warning: |
| 729 | | gen_enum_warning_wf(TYPE,RANGE,RESTRICTED_RANGE,Trigger,Span,WF) :- |
| 730 | | Warning = enumeration_warning(enumerating(Info),TYPE,RANGE,RESTRICTED_RANGE,critical), |
| 731 | | (get_trigger_info(Trigger,Info) |
| 732 | | -> (Span=unknown,Info=b(_,_,_),get_texpr_pos(Info,Span2) -> true ; Span2=Span) |
| 733 | | ; Info=unknown, Span2=Span |
| 734 | | ), |
| 735 | | (add_new_event_in_error_scope(Warning, |
| 736 | | print_enum_warning(Trigger,TYPE,RANGE,RESTRICTED_RANGE,Span2,WF)) |
| 737 | | % may also throw(Warning) |
| 738 | | -> |
| 739 | | (preference(allow_enumeration_of_infinite_types,false) |
| 740 | | -> formatsilent('### VIRTUAL TIME-OUT generated because ENUMERATE_INFINITE_TYPES=false~n',[]), |
| 741 | | % print_pending_abort_error(WF), |
| 742 | | (silent_mode(on) -> true ; print_span_nl(Span2)), |
| 743 | | throw(Warning) |
| 744 | | ; Trigger = trigger_throw(Source) |
| 745 | | -> (silent_mode(on) -> true |
| 746 | | ; Source=b(identifier(ID),_,_) -> |
| 747 | | format('### VIRTUAL TIME-OUT generated for ~w ',[ID]), |
| 748 | | print_span_nl(Span2) |
| 749 | | ; format('### VIRTUAL TIME-OUT generated for ~w ',[Source]), |
| 750 | | print_span_nl(Span2) |
| 751 | | ), |
| 752 | | throw(Warning) |
| 753 | | ; true) |
| 754 | | ; true). |
| 755 | | |
| 756 | | %get_trigger_info(trigger_false(I),Info) :- get_trigger_info2(I,Info). % was non_critical ; no longer used |
| 757 | | get_trigger_info(trigger_true(I),Info) :- get_trigger_info2(I,Info). |
| 758 | | get_trigger_info(trigger_throw(I),Info) :- get_trigger_info2(I,Info). |
| 759 | | %get_trigger_info2(enum_wf_context(_,Info),Res) :- !,Res=Info. % no longer used; WF now passed |
| 760 | | get_trigger_info2(Info,Info). |
| 761 | | |
| 762 | | |
| 763 | | % TO DO: pass WF explicitly rather than extracting it from enumeration warning terms |
| 764 | | :- use_module(translate,[translate_span/2, translate_error_term/3]). |
| 765 | | print_pending_abort_error(WF) :- |
| 766 | | pending_abort_error(WF,Msg,ErrTerm,Span), |
| 767 | | !, % just print one error |
| 768 | | translate_span(Span,TSpan), |
| 769 | | translate_error_term(ErrTerm,Span,TT), |
| 770 | | format_with_colour(user_output,[bold],' (could be due to WD-Error ~w: ~w ~w)~n',[TSpan,Msg,TT]). |
| 771 | | print_pending_abort_error(_). |
| 772 | | |
| 773 | | % try and get get_pending_abort_error_for_trigger |
| 774 | | get_pending_abort_error_for_info(WF,Span,FullMsg,ErrTerm) :- |
| 775 | | pending_abort_error(WF,Msg,ErrTerm,Span), |
| 776 | | ajoin(['Enumeration warning occured, probably caused by WD-Error: ',Msg],FullMsg). |
| 777 | | |
| 778 | | :- use_module(translate,[print_span/1, print_span_nl/1]). |
| 779 | | % THROWING,OuterSpan added by add_new_event_in_error_scope |
| 780 | | print_enum_warning(_,_,_,_,_,_WF,THROWING,_) :- |
| 781 | | THROWING \= throwing, % maybe we should also be silent if THROWING=throwing; see test 1522 |
| 782 | | silent_mode(on), % we could also check: performance_monitoring_on, |
| 783 | | !. % do not print |
| 784 | | print_enum_warning(Trigger,_,_,_,_LocalSpan,WF,THROWING,OuterThrowSpan) :- |
| 785 | | will_throw_enum_warning(THROWING), |
| 786 | | debug_mode(off), |
| 787 | | !, % do not print detailed enumeration warning with reduced scopes; we print another message instead |
| 788 | | print_throwing_wf(THROWING,Trigger,OuterThrowSpan,WF). |
| 789 | | print_enum_warning(_,_,_,_,_,_WF,THROWING,_) :- THROWING \= throwing, |
| 790 | | inc_counter(non_critical_enum_warnings,Nr), Nr>50,!, % do not print anymore |
| 791 | | (Nr=51 -> write('### No longer printing non-critical enumeration warnings; limit exceeded.'),nl |
| 792 | | ; true). |
| 793 | | print_enum_warning(Trigger,TYPE,RANGE,RESTRICTED_RANGE,LocalSpan,WF,THROWING,OuterThrowSpan) :- |
| 794 | | write('### Unbounded enumeration of '), % error_manager:trace_if_user_wants_it, |
| 795 | | print_trigger_var(Trigger), |
| 796 | | format('~w : ~w ---> ~w ',[TYPE,RANGE,RESTRICTED_RANGE]), |
| 797 | | print_wf_context(WF), |
| 798 | | print_span(LocalSpan),nl, |
| 799 | | print_throwing_wf(THROWING,Trigger,OuterThrowSpan,WF). |
| 800 | | |
| 801 | | % just count number of enum warnings |
| 802 | | :- use_module(extension('counter/counter'), |
| 803 | | [counter_init/0, new_counter/1, inc_counter/2, reset_counter/1]). |
| 804 | | kernel_objects_startup :- % call once at startup to ensure all counters exist |
| 805 | | counter_init, |
| 806 | | new_counter(non_critical_enum_warnings). |
| 807 | | kernel_objects_reset :- reset_counter(non_critical_enum_warnings). |
| 808 | | |
| 809 | | :- use_module(probsrc(eventhandling),[register_event_listener/3]). |
| 810 | | :- register_event_listener(startup_prob,kernel_objects_startup, |
| 811 | | 'Initialise kernel_objects counters.'). |
| 812 | | :- register_event_listener(clear_specification,kernel_objects_reset, |
| 813 | | 'Reset kernel_objects counters.'). |
| 814 | | |
| 815 | | % ----------- |
| 816 | | |
| 817 | | will_throw_enum_warning(THROWING) :- |
| 818 | | (THROWING=throwing -> true ; preference(strict_raise_enum_warnings,true)). |
| 819 | | |
| 820 | | :- use_module(tools_printing,[format_with_colour/4]). |
| 821 | | print_throwing(THROWING,Span) :- print_throwing_wf(THROWING,unknown_info,Span,no_wf_available). |
| 822 | | print_throwing_wf(THROWING,TriggerInfo,ThrowSpan,WF) :- |
| 823 | | peel_trigger(TriggerInfo,Info), |
| 824 | | (preference(strict_raise_enum_warnings,true) |
| 825 | | -> (get_pending_abort_error_for_info(WF,Span,Msg,ErrTerm) |
| 826 | | -> add_error(strict_raise_enum_warnings,Msg,ErrTerm,Span) |
| 827 | | ; add_error(strict_raise_enum_warnings,'Enumeration warning occured','',ThrowSpan) |
| 828 | | ) |
| 829 | | ; true |
| 830 | | ), |
| 831 | | (THROWING=throwing -> |
| 832 | | (get_trigger_info_variable(Info,VarID) |
| 833 | | -> format_with_colour(user_output,[bold],'Generating VIRTUAL TIME-OUT for unbounded enumeration of ~w!~n',[VarID]) |
| 834 | | ; format_with_colour(user_output,[bold],'Generating VIRTUAL TIME-OUT for unbounded enumeration warning!~n',[]) |
| 835 | | ), |
| 836 | | print_pending_abort_error(WF), |
| 837 | | (get_wait_flags_context_msg(WF,Msg) % % get call stack or other context message from WF |
| 838 | | -> format_with_colour(user_output,[bold],' ~w~n',[Msg]) |
| 839 | | ; true), |
| 840 | | (extract_span_description(ThrowSpan,PosMsg) -> format_with_colour(user_output,[bold],' ~w~n',[PosMsg]) ; true) |
| 841 | | ; true). |
| 842 | | |
| 843 | | peel_trigger(trigger_true(Info),Info) :- !. |
| 844 | | peel_trigger(trigger_throw(Info),Info) :- !. |
| 845 | | peel_trigger(Info,Info). |
| 846 | | |
| 847 | | print_trigger_var(trigger_true(Info)) :- !, print_trigger_var_info(Info), write(' : '). |
| 848 | | print_trigger_var(trigger_throw(Info)) :- !, print_trigger_var_info(Info), write(' : (all_solutions) : '). |
| 849 | | %print_trigger_var(trigger_false(Info)) :- !, print_trigger_var_info(Info), print(' (not critical [unless failure]) : '). % no longer used |
| 850 | | print_trigger_var(X) :- write(' UNKNOWN TRIGGER: '), print(X), write(' : '). |
| 851 | | |
| 852 | | print_wf_context(WF) :- |
| 853 | | (get_wait_flags_context_msg(WF,Msg) |
| 854 | | -> format('~n### ~w~n ',[Msg]) %format(' : (~w)',[Msg]) |
| 855 | | ; true). |
| 856 | | :- use_module(translate,[print_bexpr/1]). |
| 857 | | print_trigger_var_info(b(E,T,I)) :- !, print_bexpr(b(E,T,I)), write(' '), print_span(I). |
| 858 | | print_trigger_var_info(VarID) :- print(VarID). |
| 859 | | |
| 860 | | % get variable name from trigger info field |
| 861 | | get_trigger_info_variable(b(identifier(ID),_,_),VarID) :- !, VarID=ID. |
| 862 | | get_trigger_info_variable(ID,VarID) :- atom(ID), VarID=ID. |
| 863 | | |
| 864 | | |
| 865 | | % generate a warning if a large range is enumerated |
| 866 | | gen_enum_warning_if_large(Var,FDLow,FDUp) :- |
| 867 | | (FDUp>FDLow+8388608 /* 2**23 ; {x|x:1..2**23 & x mod 2 = x mod 1001} takes about 2 minutes */ |
| 868 | | % however the domain itself could be very small, we also check clpfd_size instead |
| 869 | | -> fd_size(Var,Size), % no need to call clpfd_size; we know we are in CLP(FD) mode |
| 870 | | (Size =< 8388608 -> true |
| 871 | | ; enum_warning_large(Var,'INTEGER',FDLow:FDUp) |
| 872 | | ) |
| 873 | | ; true). |
| 874 | | enum_warning_large(_Var,TYPE,RANGE) :- |
| 875 | | Warning = enumeration_warning(enumerating,TYPE,RANGE,RANGE,non_critical), |
| 876 | | (add_new_event_in_error_scope(Warning,print_enum_warning_large(TYPE,RANGE)) |
| 877 | | -> true |
| 878 | | ; true). |
| 879 | | |
| 880 | | print_enum_warning_large(TYPE,RANGE,THROWING,Span) :- |
| 881 | | print('### Warning: enumerating large range '), |
| 882 | | print(TYPE), print(' : '), |
| 883 | | print(RANGE),nl, |
| 884 | | print_throwing(THROWING,Span). |
| 885 | | |
| 886 | | :- block finite_warning(-,?,?,?,?). |
| 887 | | finite_warning(_,Par,Types,Body,Source) :- |
| 888 | | add_new_event_in_error_scope(enumeration_warning(checking_finite_closure,Par,Types,finite,critical), |
| 889 | | print_finite_warning(Par,Types,Body,Source) ), |
| 890 | | fail. % WITH NEW SEMANTICS OF ENUMERATION WARNING WE SHOULD PROBABLY ALWAYS FAIL HERE ! |
| 891 | | print_finite_warning(Par,Types,Body,Source,THROWING,Span) :- |
| 892 | | print('### Warning: could not determine set comprehension to be finite: '), |
| 893 | | translate:print_bvalue(closure(Par,Types,Body)),nl, |
| 894 | | print('### Source: '), print(Source),nl, |
| 895 | | print_throwing(THROWING,Span). |
| 896 | | |
| 897 | | :- block enumerate_natural(-,?,-,?,?). |
| 898 | ? | enumerate_natural(N,From,_,Span,WF) :- nonvar(N) -> true ; enumerate_natural(N,From,Span,WF). |
| 899 | | enumerate_natural(N,From,Span,WF) :- preference(use_clpfd_solver,false),!, |
| 900 | | clpfd_off_domain(N,From,sup,NewLow,NewUp), % try narrow down domain using co-routines |
| 901 | | (finite_domain(NewLow,NewUp) -> enumerate_int1(N,NewLow,NewUp) |
| 902 | | ; force_enumerate_with_warning(N,NewLow,NewUp,'NATURAL(1)',trigger_true('NATURAL(1)'),Span,WF)). |
| 903 | | enumerate_natural(N,From,Span,WF) :- clpfd_domain(N,FDLow,FDUp), |
| 904 | | fd_max(FDLow,From,Low), |
| 905 | | (finite_domain(Low,FDUp) |
| 906 | ? | -> label(N,Low,FDUp) |
| 907 | ? | ; enumerate_natural_unbounded(N,Low,FDUp,Span,WF) |
| 908 | | ). |
| 909 | | enumerate_natural_unbounded(N,FDLow1,FDUp,Span,WF) :- |
| 910 | | (FDLow1=0 |
| 911 | | -> (N=0 ; /* do a case split */ |
| 912 | | try_post_constraint(N #>0), % this can sometimes make the domain finite |
| 913 | | force_enumerate_int_wo_case_split(N,'NATURAL',trigger_true('NATURAL'),Span,WF) |
| 914 | | ) |
| 915 | | ; force_enumerate_with_warning(N,FDLow1,FDUp,'NATURAL(1)',trigger_true('NATURAL(1)'),Span,WF) |
| 916 | | ). |
| 917 | | |
| 918 | | |
| 919 | | % assumes one of FDLow and FDUp is not a number |
| 920 | | make_domain_finite(FDLow,_FDUp,Min,Max) :- number(FDLow),!,Min=FDLow, |
| 921 | | preferences:preference(maxint,MaxInt), |
| 922 | | (MaxInt>=FDLow -> Max=MaxInt ; Max=FDLow). % ensure that we try at least one number |
| 923 | | make_domain_finite(_FDLow,FDUp,Min,Max) :- number(FDUp),!,Max=FDUp, |
| 924 | | preferences:preference(minint,MinInt), |
| 925 | | (MinInt=<FDUp -> Min=MinInt ; Min=FDUp). |
| 926 | | make_domain_finite(_FDLow,_FDUp,Min,Max) :- |
| 927 | | ((preferences:preference(maxint,Max), |
| 928 | | preferences:get_preference(minint,Min))->true). % ensure that we try at least one number |
| 929 | | |
| 930 | | enumerate_int1(N,Min,Max) :- |
| 931 | | (Min<0 /* enumerate positive numbers first; many specs only use NAT/NATURAL */ |
| 932 | ? | -> (enumerate_int2(N,0,Max) ; enumerate_int2(N,Min,-1)) |
| 933 | | ; enumerate_int2(N,Min,Max) |
| 934 | | ). |
| 935 | | enumerate_int(X,Low,Up) :- get_int_domain(X,Low,Up,RL,RU), |
| 936 | | %% print(enumerate_int(X,Low,Up, RL,RU)),nl, %% |
| 937 | ? | enumerate_int2(X,RL,RU). |
| 938 | | |
| 939 | | get_int_domain(X,Low,Up,RL,RU) :- clpfd_domain(X,FDLow,FDUp), |
| 940 | | fd_max(FDLow,Low,RL),fd_min(FDUp,Up,RU). |
| 941 | | |
| 942 | | finite_domain(Low,Up) :- \+ infinite_domain(Low,Up). |
| 943 | | infinite_domain(inf,_) :- !. |
| 944 | | infinite_domain(_,sup). |
| 945 | | |
| 946 | | % second arg should always be a number |
| 947 | | fd_max(inf,L,R) :- !,R=L. |
| 948 | | fd_max(FDX,Y,R) :- (nonvar(FDX),nonvar(Y),FDX>Y -> R=FDX ; R=Y). |
| 949 | | fd_min(sup,L,R) :- !,R=L. |
| 950 | | fd_min(FDX,Y,R) :- (nonvar(FDX),nonvar(Y),FDX<Y -> R=FDX ; R=Y). |
| 951 | | |
| 952 | | :- use_module(extension('random_permutations/random_permutations'), |
| 953 | | [enum_fd_random/3]). |
| 954 | | |
| 955 | | enumerate_int2(N,X,Y) :- |
| 956 | | preferences:get_preference(randomise_enumeration_order,true) |
| 957 | ? | -> enum_fd_random(N,X,Y) ; enumerate_int2_linear(N,X,Y). |
| 958 | | |
| 959 | | enumerate_int2_linear(N,X,Y) :- X=<Y, |
| 960 | ? | (N=X ; X1 is X+1, enumerate_int2_linear(N,X1,Y)). |
| 961 | | |
| 962 | | |
| 963 | | enumerate_basic_type_set(X,Type,Tight,EnumWarning,WF) :- var(X),!, |
| 964 | | max_cardinality_with_check(Type,Card), |
| 965 | ? | enumerate_basic_type_set2(X,[],Card,Type,none,Tight,EnumWarning,WF). |
| 966 | | enumerate_basic_type_set([],_,_,_EnumWarning,_WF) :- !. |
| 967 | | enumerate_basic_type_set(avl_set(_),_,_,_EnumWarning,_WF) :- !. |
| 968 | | enumerate_basic_type_set(freetype(_),_,_,_EnumWarning,_WF) :- !. |
| 969 | | enumerate_basic_type_set(global_set(GS),Type,_Tight,_EnumWarning,_WF) :- !, |
| 970 | | (Type = global(GT) |
| 971 | | -> (GS = GT -> true |
| 972 | | ; nonvar(GS), add_error_and_fail(enumerate_basic_type_set,'Type error in global set: ',GS:GT)) |
| 973 | | ; Type = integer,integer_global_set(GS) |
| 974 | | ; Type = string, string_global_set(GS) |
| 975 | | ; Type = real, real_global_set(GS) |
| 976 | | ). |
| 977 | | enumerate_basic_type_set(closure(Parameters, PT, Body),_Type,_Tight,_EnumWarning,WF) :- !, |
| 978 | | (ground(Body) -> true |
| 979 | | ; add_message_wf(kernel_objects,'Enumerating non-ground closure body: ',closure(Parameters, PT, Body),Body,WF), |
| 980 | | % this did happen for symbolic total function closures set up for f : NATURAL1 --> ..., see test 2022 |
| 981 | | %term_variables(Body,Vars), print('### Variables: '), print(Vars),nl, |
| 982 | | enumerate_values_inside_expression(Body,WF) |
| 983 | | ). |
| 984 | | enumerate_basic_type_set([H|T],Type,Tight,EnumWarning,WF) :- !, |
| 985 | | % collect bound elements; avoid enumerating initial elements with elements that already appear later |
| 986 | | collect_bound_elements([H|T], SoFar,Unbound,Closed), |
| 987 | | (Closed=false -> max_cardinality_with_check(Type,Card) |
| 988 | | ; Card = Closed), |
| 989 | | % print(enum(Card,Unbound,SoFar,[H|T],Closed)),nl, |
| 990 | ? | enumerate_basic_type_set2(Unbound,SoFar,Card,Type,none,Tight,EnumWarning,WF). |
| 991 | | %enumerate_basic_type_set([H|T],Type,Tight,WF) :- !, |
| 992 | | % (is_list_skeleton([H|T],Card) -> true |
| 993 | | % ; max_cardinality_with_check(Type,Card) |
| 994 | | % ), |
| 995 | | % enumerate_basic_type_set2([H|T],[],Card,Type,none,Tight,WF). |
| 996 | | enumerate_basic_type_set(S,Type,Tight,EnumWarning,WF) :- |
| 997 | | add_internal_error('Illegal set: ',enumerate_basic_type_set(S,Type,Tight,EnumWarning,WF)). |
| 998 | | |
| 999 | | enumerate_basic_type_set2(HT,ElementsSoFar,_Card,_Type,_Last,_Tight,_EnumWarning,_WF) :- nonvar(HT), |
| 1000 | | is_custom_explicit_set(HT,enumerate_basic_type),!, |
| 1001 | | disjoint_sets(HT,ElementsSoFar). % I am not sure this is necessary; probably other constraints already ensure this holds |
| 1002 | | enumerate_basic_type_set2(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) :- var(HT), |
| 1003 | | preferences:preference(randomise_enumeration_order,true),!, |
| 1004 | | (random(1,3,1) |
| 1005 | ? | -> (enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) |
| 1006 | | ; HT = []) |
| 1007 | | ; (HT = [] ; |
| 1008 | ? | enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF)) |
| 1009 | | ). |
| 1010 | | enumerate_basic_type_set2([],_,_,_,_,_Tight,_EnumWarning,_WF). |
| 1011 | | enumerate_basic_type_set2(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) :- |
| 1012 | ? | enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF). |
| 1013 | | |
| 1014 | | enumerate_basic_type_set_cons(HT,ElementsSoFar,Card,Type,Last,Tight,EnumWarning,WF) :- positive_card(Card), |
| 1015 | | %debug:trace_point(enum(HT,ElementsSoFar,Card,Type,Last,Tight)), |
| 1016 | | (var(HT) -> HT=[H|T], NewLast=NormH /* the enumerator has completely determined H */ |
| 1017 | | % Note: HT=[H|T] may wake up co-routines and then attach infos to H; but these should hold indpendently for all elements |
| 1018 | | ; HT=[H|T], |
| 1019 | | (unbound_value(H) |
| 1020 | | -> NewLast=NormH /* the enumerator has completely determined H */ |
| 1021 | | ; NewLast=Last) /* H was not freely chosen by the enumerator */ |
| 1022 | | ), |
| 1023 | ? | not_element_of(H,ElementsSoFar), % this is only needed for elements generated by the enumerator itself |
| 1024 | | % if we pass WF to not_element_of then test 479 fails due to different enumeration order |
| 1025 | ? | enumerate_type_wf(H,Type,Tight,EnumWarning,WF), |
| 1026 | | % TO DO: extract normal form from add_new_element |
| 1027 | | % Note: if H is_wdguarded_result_variable then H may not be ground !! |
| 1028 | | (ground_value(H) |
| 1029 | | -> val_greater_than(H,NormH,Last), |
| 1030 | | add_new_element(NormH,ElementsSoFar,SoFar2) % TODO : use add_new_element_wf ? |
| 1031 | | ; add_new_element(H,ElementsSoFar,SoFar2), |
| 1032 | | NormH=none |
| 1033 | | ), |
| 1034 | | C1 is Card-1, |
| 1035 | ? | enumerate_basic_type_set2(T,SoFar2,C1,Type,NewLast,Tight,EnumWarning,WF). |
| 1036 | | |
| 1037 | | :- assert_must_succeed((collect_bound_elements([int(1),int(2),int(4),X,int(5)|T],_,U,C),U==[X|T],C==false)). |
| 1038 | | :- assert_must_succeed((collect_bound_elements([int(1),int(2),int(4),X,int(5)],_,U,C),U==[X],C==1)). |
| 1039 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(collect_bound_elements([int(1),int(2),int(4),int(5)],_,_,_))). |
| 1040 | | |
| 1041 | | % collect the bound and unbound elements in a list; also return if the list is closed (then return length) or return false |
| 1042 | | collect_bound_elements(T, SoFar,Unbound,Closed) :- var(T),!, SoFar=[],Unbound=T,Closed=false. |
| 1043 | | collect_bound_elements([],[],[],0). |
| 1044 | | collect_bound_elements(avl_set(A),avl_set(A),[],0). |
| 1045 | | collect_bound_elements(global_set(GS),SoFar,Unbound,Closed) :- expand_custom_set(global_set(GS),ES), |
| 1046 | | collect_bound_elements(ES,SoFar,Unbound,Closed). |
| 1047 | | collect_bound_elements(freetype(FS),SoFar,Unbound,Closed) :- expand_custom_set(freetype(FS),ES), |
| 1048 | | collect_bound_elements(ES,SoFar,Unbound,Closed). |
| 1049 | | collect_bound_elements(closure(P,T,B),SoFar,Unbound,Closed) :- expand_custom_set(closure(P,T,B),ES), |
| 1050 | | collect_bound_elements(ES,SoFar,Unbound,Closed). |
| 1051 | | collect_bound_elements([H|T],SoFar,Unbound,Closed) :- |
| 1052 | | collect_bound_elements(T,TSoFar,TUnbound,TClosed), |
| 1053 | | (ground(H) -> add_new_element(H,TSoFar,SoFar), Unbound=TUnbound, TClosed=Closed |
| 1054 | | ; SoFar = TSoFar, Unbound = [H|TUnbound], |
| 1055 | | (TClosed=false -> Closed=false ; Closed is TClosed+1) |
| 1056 | | ). |
| 1057 | | |
| 1058 | | |
| 1059 | | % perform order checking on terms, normalising them first |
| 1060 | | % val_greater_than(A,NormA,NormB) |
| 1061 | | val_greater_than(A,NormA,NormB) :- !, |
| 1062 | | (nonvar(A),custom_explicit_sets:convert_to_avl_inside_set(A,NormA) |
| 1063 | | -> (NormB==none -> true ; NormA @> NormB) |
| 1064 | | ; add_internal_error('Call failed: ',custom_explicit_sets:convert_to_avl_inside_set(A,NormA)), |
| 1065 | | NormA = A). |
| 1066 | | |
| 1067 | | positive_card(inf) :- !, print('$'). |
| 1068 | | positive_card(C) :- (integer(C) -> C>0 |
| 1069 | | ; add_internal_error('Not an integer: ',positive_card(C)),fail). |
| 1070 | | |
| 1071 | | |
| 1072 | | |
| 1073 | | :- block enumerate_basic_field_types(?,-,?,-,?). |
| 1074 | | enumerate_basic_field_types([],[],_Tight,_EnumWarning,_). |
| 1075 | | enumerate_basic_field_types(Fields,[field(Name,VT)|TT],Tight,EnumWarning,WF) :- |
| 1076 | ? | enumerate_basic_field_types2(Fields,Name,VT,TT,Tight,EnumWarning,WF). |
| 1077 | | |
| 1078 | | :- block enumerate_basic_field_types2(?,-,?,?,?,?,?). |
| 1079 | | enumerate_basic_field_types2([field(Name1,V)|T], Name2,VT,TT,Tight,EnumWarning,WF) :- |
| 1080 | | check_field_name_compatibility(Name1,Name2,enumerate_basic_field_types2), |
| 1081 | ? | enumerate_type_wf(V,VT,Tight,EnumWarning,WF), |
| 1082 | ? | enumerate_basic_field_types(T,TT,Tight,EnumWarning,WF). |
| 1083 | | |
| 1084 | | |
| 1085 | | :- block all_objects_of_type(-,?). |
| 1086 | | all_objects_of_type(Type,Res) :- |
| 1087 | | findall(O,enumerate_basic_type(O,Type),Res). |
| 1088 | | |
| 1089 | | :- use_module(library(avl),[avl_size/2]). |
| 1090 | | :- use_module(kernel_cardinality_attr,[clpfd_card_domain_for_var/3]). |
| 1091 | | % obtain info for enumerating sequence lists: length of list skeleton and maximum index inferred to be in the list |
| 1092 | | % (MaxIndex is not the maximum index that can appear in the full sequence !) |
| 1093 | | list_length_info(X,LenSoFar,Len,Type,MaxIndex) :- var(X),!,Len=0, |
| 1094 | | clpfd_card_domain_for_var(X,MinCard,MaxCard), |
| 1095 | | ( number(MinCard) |
| 1096 | | -> MaxIndex is MinCard+LenSoFar % we know a valid list must be at least LenSoFar+MinCard long |
| 1097 | | ; MaxIndex=0), |
| 1098 | | ( number(MaxCard) -> Max1 is MaxCard+Len, Type = open_bounded(Max1) ; Type = open). |
| 1099 | | list_length_info([],_,0,closed,0). |
| 1100 | | list_length_info([H|T],LenSoFar,C1,Type,MaxIndex1) :- Len1 is LenSoFar+1, |
| 1101 | | list_length_info(T,Len1,C,Type,MaxIndex), |
| 1102 | | C1 is C+1, |
| 1103 | | (nonvar(H),H=(I,_),nonvar(I),I=int(Idx),number(Idx),Idx>MaxIndex |
| 1104 | | -> MaxIndex1 = Idx ; MaxIndex1 = MaxIndex). |
| 1105 | | list_length_info(avl_set(A),LenSoFar,Size,closed,0) :- % case arises e.g. in private_examples/ClearSy/2019_Dec/well_def |
| 1106 | | (LenSoFar=0 -> Size=1000000 % then length not used anyway |
| 1107 | | ; avl_size(A,Size)). % we could check that this is a sequence tail! |
| 1108 | | list_length_info(closure(_,_,_),_,0,open,0). |
| 1109 | | |
| 1110 | | :- assert_must_succeed((max_cardinality(set(couple(global('Name'),global('Code'))),64))). |
| 1111 | | :- assert_must_succeed((max_cardinality(set(set(set(couple(global('Name'),global('Code'))))),_))). |
| 1112 | | :- assert_must_succeed((kernel_freetypes:add_freetype(selfc4,[case(a,boolean),case(b,couple(boolean,boolean))]), |
| 1113 | | max_cardinality(freetype(selfc4),6), |
| 1114 | | kernel_freetypes:reset_freetypes)). |
| 1115 | | :- assert_must_succeed((kernel_freetypes:add_freetype(selfc6,[case(a,boolean),case(b,freetype(selfc6)),case(c,constant([c]))]), |
| 1116 | | kernel_freetypes:set_freetype_depth(3), |
| 1117 | | findall(X,enumerate_tight_type(X,freetype(selfc6)),Solutions), |
| 1118 | | length(Solutions,NumberOfSolutions), |
| 1119 | | max_cardinality(freetype(selfc6),NumberOfSolutions), |
| 1120 | | kernel_freetypes:reset_freetypes)). |
| 1121 | | |
| 1122 | | :- use_module(tools_printing,[print_error/1]). |
| 1123 | | max_cardinality_with_check(Set,CCard) :- |
| 1124 | ? | (max_cardinality(Set,Card) -> |
| 1125 | | (is_inf_or_overflow_card(Card) |
| 1126 | | -> debug_println(9,very_large_cardinality(Set,Card)), |
| 1127 | | CCard = 20000000 |
| 1128 | | ; CCard=Card, |
| 1129 | | (Card>100 -> debug_println(9,large_cardinality(Set,Card)) ; true) |
| 1130 | | ) |
| 1131 | | ; print_error(failed(max_cardinality(Set,CCard))), CCard = 10 |
| 1132 | | ). |
| 1133 | | max_cardinality(global(T),Card) :- b_global_set_cardinality(T,Card). |
| 1134 | | max_cardinality(boolean,2). |
| 1135 | | max_cardinality(constant([_V]),1). |
| 1136 | | max_cardinality(any,inf). % :- print_message(dont_know_card_of_any). /* TODO: what should we do here ? */ |
| 1137 | | max_cardinality(string,MC) :- max_cardinality_string(MC). % is inf now |
| 1138 | | %max_cardinality(abort,1). |
| 1139 | | max_cardinality(integer,Card) :- Card=inf. %b_global_set_cardinality('INTEGER',Card). |
| 1140 | | max_cardinality(real,Card) :- Card=inf. |
| 1141 | | max_cardinality(seq(X),Card) :- % Card=inf, unless a freetype can be of cardinality 0 |
| 1142 | | max_cardinality(set(couple(integer,X)),Card). |
| 1143 | | max_cardinality(couple(X,Y),Card) :- |
| 1144 | ? | max_cardinality(X,CX), max_cardinality(Y,CY), safe_mul(CX,CY,Card). |
| 1145 | | max_cardinality(record([]),1). |
| 1146 | | max_cardinality(record([field(_,T1)|RF]),Card) :- |
| 1147 | ? | max_cardinality(record(RF),RC), |
| 1148 | | max_cardinality(T1,C1), |
| 1149 | | safe_mul(C1,RC,Card). |
| 1150 | ? | max_cardinality(set(X),Card) :- max_cardinality(X,CX), |
| 1151 | | safe_pow2(CX,Card). |
| 1152 | | max_cardinality(freetype(Id),Card) :- max_cardinality_freetype(freetype(Id),Card). |
| 1153 | | max_cardinality(freetype_lim_depth(Id,Depth),Card) :- max_cardinality_freetype(freetype_lim_depth(Id,Depth),Card). |
| 1154 | | |
| 1155 | | |
| 1156 | | |
| 1157 | | /* ---------------------------- */ |
| 1158 | | |
| 1159 | | |
| 1160 | | /* use a cleverer, better enumeration than enumerate_basic_type */ |
| 1161 | | /* can only be used in certain circumstances: operation preconditions, |
| 1162 | | properties,... but not for VARIABLES as there is no guarantee that |
| 1163 | | something declared as a sequence will actually turn out to be a sequence */ |
| 1164 | | |
| 1165 | | :- assert_pre(kernel_objects:enumerate_tight_type(Obj,Type), |
| 1166 | | (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))). |
| 1167 | | :- assert_post(kernel_objects:enumerate_tight_type(Obj,_), (type_check(Obj,bsets_object),ground_check(Obj))). |
| 1168 | | :- assert_pre(kernel_objects:enumerate_tight_type(Obj,Type,_), |
| 1169 | | (type_check(Obj,bsets_object),type_check(Type,basic_type_descriptor))). |
| 1170 | | :- assert_post(kernel_objects:enumerate_tight_type(Obj,_,_), (type_check(Obj,bsets_object),ground_check(Obj))). |
| 1171 | | |
| 1172 | | :- assert_must_succeed(enumerate_tight_type([(int(1),int(2)),(int(2),int(4))], |
| 1173 | | seq(integer) )). |
| 1174 | | :- assert_must_succeed(enumerate_tight_type([(int(1),int(2))],seq(integer) )). |
| 1175 | | :- assert_must_succeed(enumerate_tight_type([],seq(integer) )). |
| 1176 | | :- assert_must_succeed((enumerate_tight_type(X,record([field(a,integer),field(b,global('Name'))])), |
| 1177 | | equal_object(X,rec([field(a,int(1)),field(b,fd(1,'Name'))])) )). |
| 1178 | | :- assert_must_fail(enumerate_tight_type([(int(1),int(2)),(int(3),int(_))], |
| 1179 | | seq(integer) )). |
| 1180 | | :- assert_must_fail(enumerate_tight_type([(int(3),int(_))],seq(integer) )). |
| 1181 | | :- assert_must_succeed((bsets_clp:is_sequence(X,global_set('Name')), |
| 1182 | | enumerate_tight_type(X,seq(global('Name')) ), |
| 1183 | | X = [(int(1),fd(2,'Name'))] )). |
| 1184 | | :- assert_must_succeed(( enumerate_tight_type(XX, record([field(balance,integer),field(name,global('Name'))])) , |
| 1185 | | XX = rec([field(balance,int(1)),field(name,fd(3,'Name'))]) )). |
| 1186 | | :- assert_must_succeed(( enumerate_tight_type(XX, set(record([field(balance,global('Name')),field(name,global('Name'))]))) , /* STILL TAKES VERY LONG !! */ |
| 1187 | | XX = [rec([field(balance,fd(3,'Name')),field(name,fd(3,'Name'))])] )). |
| 1188 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(balance,global('Name')),field(name,global('Name'))]))) ,S), |
| 1189 | | length(S,Len), Len = 512 )). |
| 1190 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(name,global('Code'))]))) ,S), |
| 1191 | | length(S,Len), Len = 4 )). |
| 1192 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(fname,global('Code')),field(name,global('Code'))]))) ,S), |
| 1193 | | length(S,Len), Len = 16 )). |
| 1194 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(record([field(fname,global('Code')),field(name,global('Name'))]))) ,S), |
| 1195 | | length(S,Len), Len = 64 )). |
| 1196 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(global('Name'))) ,S), |
| 1197 | | length(S,Len), Len = 8 )). |
| 1198 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(boolean))) ,S), |
| 1199 | | length(S,Len), Len = 16 )). |
| 1200 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(global('Name')))) ,S), |
| 1201 | | length(S,Len), Len = 256 )). |
| 1202 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(global('Code')))) ,S), |
| 1203 | | length(S,Len), Len = 16 )). |
| 1204 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(set(boolean))) ,S), |
| 1205 | | length(S,Len), Len = 16 )). |
| 1206 | | :- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(couple(global('Code'),global('Name')))) ,S), |
| 1207 | | length(S,Len), Len = 64 )). |
| 1208 | | %:- assert_must_succeed(( findall(XX,enumerate_tight_type(XX, set(couple(global('Code'),integer))) ,S), |
| 1209 | | % length(S,Len), Len = 64 )). |
| 1210 | | :- assert_must_succeed(( enumerate_tight_type(XX, set(record([field(balance,integer)]))) , |
| 1211 | | XX = [rec([field(balance,int(1))])] )). |
| 1212 | | :- assert_must_succeed(( enumerate_tight_type(global_set('Code'),set(global('Code'))) )). |
| 1213 | | |
| 1214 | | enumerate_tight_type(Obj,Type) :- |
| 1215 | | enumerate_tight_type_wf(Obj,Type,no_wf_available). |
| 1216 | | |
| 1217 | | enumerate_tight_type_wf(Obj,Type,WF) :- |
| 1218 | | enumerate_tight_type_wf(Obj,Type,trigger_true(enumerate_tight_type),WF). |
| 1219 | | |
| 1220 | | enumerate_tight_type(Obj,Type,EnumWarning) :- %enumerate_tight_type2(Type,Obj). |
| 1221 | | enumerate_tight_type_wf(Obj,Type,EnumWarning,no_wf_available). |
| 1222 | | |
| 1223 | | :- block enumerate_tight_type_wf(?,-,?,?), enumerate_tight_type_wf(?,?,-,?). |
| 1224 | | enumerate_tight_type_wf(Obj,Type,EnumWarning,WF) :- %enumerate_tight_type2(Type,Obj). |
| 1225 | | (ground_value(Obj) -> true ; % print(enumerate_tight_type(Obj,Type)),nl, |
| 1226 | ? | enumerate_basic_type4(Type,Obj,tight,EnumWarning,WF) |
| 1227 | | ). |
| 1228 | | |
| 1229 | | /* TO DO: provide tight enumerators for nat, functions, ... ?? */ |
| 1230 | | |
| 1231 | | |
| 1232 | | |
| 1233 | | :- assert_must_succeed((X=[(int(I1),pred_true /* bool_true */),Y], dif(I1,1), |
| 1234 | | kernel_objects:enumerate_seq_type(X,boolean,true),I1==2,Y=(int(1),pred_false /* bool_false */))). |
| 1235 | | |
| 1236 | | enumerate_seq_type(X,Type,EnumWarning) :- enumerate_seq_type_wf(X,Type,EnumWarning,no_wf_available). |
| 1237 | | |
| 1238 | | enumerate_seq_type_wf(X,Type,EnumWarning,WF) :- |
| 1239 | | list_length_info(X,0,Len,ListType,MaxIndex), % ListType can be open or closed |
| 1240 | | % determine MaxIndexForEnum: |
| 1241 | | (ListType=closed |
| 1242 | | -> MaxIndexForEnum=Len, EW = no_enum_warning, |
| 1243 | | MaxIndex =< Len % otherwise this is obviously not a sequence (Index in set which is larger than size) |
| 1244 | | ; ListType=open_bounded(MaxSize) |
| 1245 | | -> MaxIndexForEnum=MaxSize, EW = no_enum_warning, |
| 1246 | | MaxIndex =< MaxSize % otherwise cannot be a sequence |
| 1247 | | % TO DO: use MinSize? |
| 1248 | | ; (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 |
| 1249 | | b_global_set_cardinality('NAT1',NatCard), |
| 1250 | | (NatCard<Card -> Max1=Card ; Max1=NatCard), |
| 1251 | | (Max1<1 -> MaxIndexForEnum = 1 ; MaxIndexForEnum=Max1), % ensure that we generate enumeration warning |
| 1252 | | EW = EnumWarning |
| 1253 | | ), |
| 1254 | | enumerate_seq(X,range(1,MaxIndexForEnum),MaxIndexForEnum,Type,EW,WF). |
| 1255 | | |
| 1256 | | enumerate_seq([],_,_,_,_,_WF). |
| 1257 | | enumerate_seq(V,_,_,_,_,_WF) :- nonvar(V),V=avl_set(_),!. |
| 1258 | | enumerate_seq(V,_,_,Type,EnumWarning,WF) :- nonvar(V),V=closure(_,_,_),!, |
| 1259 | | enumerate_basic_type_set(V,Type,not_tight,EnumWarning,WF). |
| 1260 | | enumerate_seq(Seq,_,_,_,_,_WF) :- nonvar(Seq), |
| 1261 | | is_custom_explicit_set(Seq,enumerate_seq),!. |
| 1262 | | enumerate_seq(Seq,Indexes,Card,Type,EnumWarning,WF) :- |
| 1263 | | (unbound_variable_for_cons(Seq) |
| 1264 | | -> positive_card(Card), |
| 1265 | | get_next_index(Indexes,Index,RemIndexes), % force next index |
| 1266 | | Seq = [(int(Index),Element)|TSeq], VarEl=true |
| 1267 | | ; Seq = [El|TSeq], |
| 1268 | | (unbound_variable(El) |
| 1269 | | -> VarEl=true, get_next_index(Indexes,Index,RemIndexes) % force next index |
| 1270 | | ; VarEl=false), |
| 1271 | | El = (int(Index),Element) |
| 1272 | | ), |
| 1273 | | (VarEl=true |
| 1274 | | -> true % index already forced above |
| 1275 | | ; 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 |
| 1276 | | ; remove_index(Indexes,Index,RemIndexes) |
| 1277 | | ), |
| 1278 | | (EnumWarning==no_enum_warning -> true |
| 1279 | | ; 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) |
| 1280 | | enumerate_tight_type_wf(Element,Type,WF), |
| 1281 | | C1 is Card-1, |
| 1282 | | enumerate_seq(TSeq,RemIndexes,C1,Type,no_enum_warning,WF). |
| 1283 | | |
| 1284 | | get_next_index([Index1|RestIndexes],Index1,RestIndexes). |
| 1285 | | get_next_index(range(I1,I2),I1,Res) :- |
| 1286 | | I11 is I1+1, |
| 1287 | | (I11>I2 -> Res=[] ; Res=range(I11,I2)). |
| 1288 | | |
| 1289 | | remove_index_ground(Indexes,X,Res) :- get_next_index(Indexes,H,T), |
| 1290 | | (X=H -> Res=T ; Res=[H|R2], remove_index_ground(T,X,R2)). |
| 1291 | | |
| 1292 | | remove_index(Indexes,X,Res) :- get_next_index(Indexes,H,T), |
| 1293 | | (X=H,Res=T ; X\==H, Res=[H|R2], remove_index(T,X,R2)). |
| 1294 | | |
| 1295 | | |
| 1296 | | |
| 1297 | | /* a few more unit tests: */ |
| 1298 | | |
| 1299 | | :- assert_must_succeed(( findall(X,enumerate_type(X,set(couple(boolean,boolean)),tight) ,L), length(L,16) )). |
| 1300 | | :- assert_must_succeed(( findall(X,enumerate_type(X,set(couple(boolean,boolean)),basic) ,L), length(L,16) )). |
| 1301 | | |
| 1302 | | :- assert_must_succeed(( enumerate_tight_type( |
| 1303 | | [rec([field(balance,int(0)),field(name,fd(2,'Name'))])],[ |
| 1304 | | rec([field(balance,int(1)),field(name,fd(3,'Name'))]), |
| 1305 | | rec([field(balance,int(1)),field(name,fd(2,'Name'))]), |
| 1306 | | rec([field(balance,int(0)),field(name,fd(1,'Name'))]), |
| 1307 | | rec([field(balance,int(-1)),field(name,fd(1,'Name'))])], |
| 1308 | | set(record([field(balance,integer),field(name,global('Name'))]))) )). |
| 1309 | | :- assert_must_succeed(( enumerate_tight_type([ |
| 1310 | | rec([field(balance,int(1)),field(name,fd(2,'Name'))]), |
| 1311 | | rec([field(balance,int(1)),field(name,fd(1,'Name'))]), |
| 1312 | | rec([field(balance,int(0)),field(name,fd(1,'Name'))]), |
| 1313 | | rec([field(balance,int(-1)),field(name,fd(1,'Name'))])|X], |
| 1314 | | set(record([field(balance,integer),field(name,global('Name'))]))) , |
| 1315 | | X = [rec([field(balance,int(1)),field(name,fd(3,'Name'))])] )). |
| 1316 | | |
| 1317 | | :- assert_must_succeed((not_element_of(X,[(pred_true /* bool_true */,pred_true /* bool_true */), |
| 1318 | | (pred_true /* bool_true */,pred_false /* bool_false */),(pred_false /* bool_false */,pred_false /* bool_false */)]), |
| 1319 | | enumerate_tight_type(X,couple(boolean,boolean)))). |
| 1320 | | |
| 1321 | | :- assert_must_succeed(( not_equal_object(X,(pred_true /* bool_true */,pred_false /* bool_false */)), |
| 1322 | | not_equal_object(X,(pred_false /* bool_false */,pred_false /* bool_false */)), |
| 1323 | | not_equal_object(X,(pred_true /* bool_true */,pred_true /* bool_true */)), |
| 1324 | | enumerate_tight_type(X,couple(boolean,boolean)))). |
| 1325 | | |
| 1326 | | :- assert_must_succeed(( X = [fd(3,'Name')|T],enumerate_tight_type(X,set(global('Name'))), |
| 1327 | | T == [fd(1,'Name'),fd(2,'Name')] )). |
| 1328 | | |
| 1329 | | |
| 1330 | | |
| 1331 | | unbound_value(V) :- |
| 1332 | | (var(V) -> unbound_variable(V) |
| 1333 | | ; V = (V1,W1),unbound_value(V1), unbound_value(W1)). |
| 1334 | | |
| 1335 | | :- use_module(bsyntaxtree,[syntaxtraversion/6]). |
| 1336 | | enumerate_values_inside_expression(TExpr,WF) :- |
| 1337 | | syntaxtraversion(TExpr,Expr,Type,_Infos,Subs,_), |
| 1338 | | nonvar(Expr),!, |
| 1339 | | enumerate_expr(Expr,Type,Subs,WF). |
| 1340 | | enumerate_values_inside_expression(X,WF) :- |
| 1341 | | add_internal_error('Unexpected B expression: ',enumerate_values_inside_expression(X,WF)). |
| 1342 | | |
| 1343 | | %:- block enumerate_expr(-,?,?,?). |
| 1344 | | enumerate_expr(value(X),Type,Subs,WF) :- !, |
| 1345 | | (ground(Type) -> enumerate_value(X,Type,WF) |
| 1346 | | ; add_internal_error('Value type not ground: ',enumerate_expr(value(X),Type,Subs,WF))). |
| 1347 | | enumerate_expr(_,_,Subs,WF) :- l_enumerate_values_inside_expression(Subs,WF). |
| 1348 | | |
| 1349 | | :- use_module(bsyntaxtree,[is_set_type/2]). |
| 1350 | | % catch a few type errors: |
| 1351 | | enumerate_value(X,Type,_) :- X==[], !, |
| 1352 | | (is_set_type(Type,_) -> true ; add_internal_error('Illegal type: ',enumerate_value(X,Type,_))). |
| 1353 | | enumerate_value(X,Type,WF) :- enumerate_basic_type_wf(X,Type,WF). |
| 1354 | | |
| 1355 | | :- block l_enumerate_values_inside_expression(-,?). |
| 1356 | | l_enumerate_values_inside_expression([],_WF). |
| 1357 | | l_enumerate_values_inside_expression([H|T],WF) :- |
| 1358 | | enumerate_values_inside_expression(H,WF), |
| 1359 | | l_enumerate_values_inside_expression(T,WF). |
| 1360 | | |
| 1361 | | |
| 1362 | | /* --------------- */ |
| 1363 | | /* top_level_dif/2 */ |
| 1364 | | /* --------------- */ |
| 1365 | | /* checks whether two terms have a different top-level functor */ |
| 1366 | | |
| 1367 | | :- assert_must_succeed(top_level_dif(a,b)). |
| 1368 | | :- assert_must_succeed(top_level_dif(f(_X),g(_Z))). |
| 1369 | | :- assert_must_fail(top_level_dif(f(a),f(_Z))). |
| 1370 | | :- assert_must_fail(top_level_dif(f(a),f(b))). |
| 1371 | | |
| 1372 | | :- block top_level_dif(-,?),top_level_dif(?,-). |
| 1373 | | top_level_dif(X,Y) :- |
| 1374 | | functor(X,FX,_),functor(Y,FY,_), FX\=FY. /* check arities ? */ |
| 1375 | | |
| 1376 | | |
| 1377 | | /* ------------------------------------------------------------------- */ |
| 1378 | | /* EQUAL OBJECT */ |
| 1379 | | /* ------------------------------------------------------------------- */ |
| 1380 | | |
| 1381 | | sample_closure(C) :- |
| 1382 | | construct_closure([xx],[integer],Body,C), |
| 1383 | | Body = b(conjunct(b(conjunct( |
| 1384 | | b(member(b(identifier(xx),integer,[]),b(integer_set('NAT'),set(identifier(xx)),[])),pred,[]), |
| 1385 | | b(greater(b(identifier(xx),integer,[]),b(integer(0),integer,[])),pred,[])),pred,[]), |
| 1386 | | b(less(b(identifier(xx),integer,[]),b(integer(3),integer,[])),pred,[])),pred,[]). |
| 1387 | | |
| 1388 | | :- assert_must_succeed(equal_object([int(3),int(1)], |
| 1389 | | closure([zz],[integer],b(member(b(identifier(zz),integer,[]),b(value([int(1),int(3)]),set(integer),[])),pred,[])))). |
| 1390 | | :- assert_must_succeed(( equal_object( (fd(1,'Name'),fd(1,'Name')) , (fd(1,'Name'),fd(1,'Name')) ) )). |
| 1391 | | :- assert_must_succeed(( equal_object( (X,Y) , (fd(2,'Name'),fd(2,'Name')) ) , X = fd(2,'Name'), Y=fd(2,'Name') )). |
| 1392 | | :- assert_must_fail(equal_object(term(a),term(b))). |
| 1393 | | :- assert_must_fail(equal_object(int(1),int(2))). |
| 1394 | | :- assert_must_fail(equal_object([term(a),term(b)],[term(a),term(c)])). |
| 1395 | | :- assert_must_fail((equal_object([(int(1),[Y])],[(int(X),[Z])]), |
| 1396 | | Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[int(2)])). |
| 1397 | | :- assert_must_fail(equal_object(rec([field(a,int(1))]),rec([field(a,int(2))]))). |
| 1398 | | :- assert_must_fail(equal_object(rec([field(a,int(2)),field(b,int(3))]), |
| 1399 | | rec([field(a,int(2)),field(b,int(4))]))). |
| 1400 | | :- assert_must_succeed(equal_object(rec([field(a,int(2))]),rec([field(a,int(2))]))). |
| 1401 | | :- assert_must_succeed(equal_object(rec([field(a,int(2)),field(b,[int(3),int(2)])]), |
| 1402 | | rec([field(a,int(2)),field(b,[int(2),int(3)])]) )). |
| 1403 | | :- assert_must_succeed(equal_object([(term(a),[])],[(term(a),[])])). |
| 1404 | | :- assert_must_succeed(equal_object(_X,[int(1),int(2)])). |
| 1405 | | :- assert_must_succeed(equal_object([int(1),int(2)],_X)). |
| 1406 | | :- assert_must_succeed((equal_object([(int(1),[Y])],[(int(X),[Z])]), |
| 1407 | | Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[])). |
| 1408 | | :- assert_must_succeed(equal_object([int(1),int(2)],[int(2),int(1)])). |
| 1409 | | :- assert_must_succeed(equal_object(global_set('Name'),[fd(2,'Name'),fd(3,'Name'),fd(1,'Name')])). |
| 1410 | | :- assert_must_succeed(equal_object(global_set('Name'),[fd(1,'Name'),fd(3,'Name'),fd(2,'Name')])). |
| 1411 | | :- assert_must_succeed((equal_object([fd(3,'Name'),fd(2,'Name'),fd(1,'Name')],global_set('Name')))). |
| 1412 | | %:- assert_must_succeed((equal_object([fd(3,'Name'),fd(2,'Name'),fd(1,'Name')],X),X=global_set('Name'))). |
| 1413 | | :- assert_must_succeed((equal_object(Y,X),X=global_set('Name'),equal_object(Y,[fd(3,'Name'),fd(2,'Name'),fd(1,'Name')]))). |
| 1414 | | :- assert_must_succeed((equal_object(X,X),X=global_set('Name'))). |
| 1415 | | :- assert_must_succeed((equal_object(_,X),X=global_set('Name'))). |
| 1416 | | :- assert_must_succeed((equal_object(X,global_set('Name')),X=global_set('Name'))). |
| 1417 | | :- assert_must_succeed((equal_object([_A,_B],[int(2),int(1)]))). |
| 1418 | | :- assert_must_fail((equal_object(X,global_set('Code')),X=global_set('Name'))). |
| 1419 | | :- assert_must_fail((equal_object(Y,global_set('Name')),Y=[fd(3,'Name'),fd(1,'Name')])). |
| 1420 | | :- assert_must_fail((equal_object(Y,global_set('Name')),Y=[_,_])). |
| 1421 | | :- assert_must_succeed((equal_object(X,closure([xx],[integer],b(truth,pred,[]))),X==closure([xx],[integer],b(truth,pred,[])))). |
| 1422 | | :- assert_must_succeed((sample_closure(C), equal_object([int(1),int(2)],C))). |
| 1423 | | :- assert_must_succeed((sample_closure(C), equal_object(C,[int(1),int(2)]))). |
| 1424 | | :- assert_must_fail((sample_closure(C), equal_object(C,[int(1),int(0)]))). |
| 1425 | | :- assert_must_fail((sample_closure(C), equal_object(C,global_set('NAT')))). |
| 1426 | | :- assert_must_succeed((equal_object(freeval(selfcx,a,int(5)),freeval(selfcx,a,int(5))))). |
| 1427 | | :- assert_must_fail((equal_object([int(1),int(2),int(3)],global_set('NATURAL1')))). |
| 1428 | | :- assert_must_fail((equal_object(X,global_set('NATURAL1')),equal_object(X,[int(1),int(2),int(3)]))). |
| 1429 | | :- assert_must_fail((equal_object(X,[int(1),int(2),int(3)]),equal_object(X,global_set('NATURAL1')))). |
| 1430 | | :- assert_must_fail((equal_object(X,global_set('NATURAL')),equal_object(X,global_set('NATURAL1')))). |
| 1431 | | :- assert_must_succeed((equal_object(X,global_set('NATURAL')),equal_object(X,global_set('NATURAL')))). |
| 1432 | | % :- assert_must_fail((equal_object(freeval(selfcx,a,int(5)),freeval(selfcy,a,int(5))))). % is a type error |
| 1433 | | :- assert_must_fail((equal_object(freeval(selfcx,b,int(5)),freeval(selfcx,a,int(5))))). |
| 1434 | | :- assert_must_fail((equal_object(freeval(selfcx,a,int(5)),freeval(selfcx,a,int(6))))). |
| 1435 | | :- assert_must_succeed((equal_object( |
| 1436 | | [[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')], |
| 1437 | | [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(3,'Name'),fd(2,'Name')]] |
| 1438 | | ,[[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')], |
| 1439 | | [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(2,'Name'),fd(3,'Name')]]) |
| 1440 | | )). |
| 1441 | | :- assert_must_succeed(exhaustive_kernel_check( (equal_object([int(3),int(2),int(1)],[int(2)|T]), |
| 1442 | | equal_object(T,[int(1),int(3)])))). |
| 1443 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],equal_object([int(3),int(1)],[int(1),int(3)]))). |
| 1444 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],equal_object([int(3),int(4),int(1)],[int(4),int(1),int(3)]))). |
| 1445 | | |
| 1446 | | %:- assert_must_succeed(exhaustive_kernel_fail_check([commutative],equal_object([int(1),int(2),int(3)],global_set('NATURAL1')))). |
| 1447 | | :- 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)]) )). |
| 1448 | | % NOTE: had multiple solutions; after solving Ticket #227 it no longer has :-) |
| 1449 | | :- 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]) )). |
| 1450 | | |
| 1451 | | :- assert_must_succeed((equal_object([_X,_Y],[int(1),int(2)]))). |
| 1452 | | :- 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)))))), |
| 1453 | | 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))). |
| 1454 | | |
| 1455 | | :- use_module(bool_pred). |
| 1456 | | |
| 1457 | ? | equal_object(V1,V2) :- equal_object_wf(V1,V2,no_wf_available). |
| 1458 | ? | equal_object(V1,V2,Origin) :- equal_object_wf(V1,V2,Origin,no_wf_available). |
| 1459 | ? | equal_object_optimized(V1,V2,Origin) :- equal_object_optimized_wf(V1,V2,Origin,no_wf_available). |
| 1460 | | equal_object_optimized(V1,V2) :- equal_object_optimized(V1,V2,unknown). |
| 1461 | | |
| 1462 | | :- load_files(library(system), [when(compile_time), imports([environ/2])]). |
| 1463 | | :- if(environ(prob_safe_mode,true)). |
| 1464 | | /* a version of equal_object which will convert lists to avl if possible */ |
| 1465 | | equal_object_optimized_wf(V1,V2,Origin,WF) :- |
| 1466 | | ( var(V1) -> (var(V2) -> V1=V2 ; equal_object_opt3(V2,V1,WF)) |
| 1467 | | ; equal_object_opt3(V1,V2,WF)), |
| 1468 | | check_value(V1,Origin), check_value(V2,Origin). |
| 1469 | | equal_object_wf(V1,V2,Origin,WF) :- ( (var(V1);var(V2)) -> V1=V2 |
| 1470 | | ; nonvar(V1) -> equal_object3(V1,V2,WF) |
| 1471 | | ; equal_object3(V2,V1,WF)), |
| 1472 | | check_value(V1,val1(Origin)), check_value(V2,val2(Origin)). |
| 1473 | | equal_object_wf(V1,V2,WF) :- ( (var(V1);var(V2)) -> V1=V2 |
| 1474 | | ; nonvar(V1) -> equal_object3(V1,V2,WF) |
| 1475 | | ; equal_object3(V2,V1,WF)), |
| 1476 | | check_value(V1,equal_object1), check_value(V2,equal_object2). |
| 1477 | | check_value(X,Origin) :- nonvar(X) -> check_value_aux(X,Origin) ; true. |
| 1478 | | check_value_aux((A,B),Origin) :- !, check_value(A,pair1(Origin)), check_value(B,pair2(Origin)). |
| 1479 | | check_value_aux([H|T],Origin) :- !, check_value(H,head(Origin)), check_value(T,tail(Origin)). |
| 1480 | | check_value_aux(avl_set(X),Origin) :- !, |
| 1481 | | (var(X) -> add_warning(Origin,'Variable avl_set') |
| 1482 | | ; X=empty -> add_warning(Origin,'Empty avl_set') ; true). |
| 1483 | | check_value_aux(closure(P,T,B),Origin) :- !, |
| 1484 | | (ground(P),ground(T),nonvar(B) -> true |
| 1485 | | ; add_warning(Origin,illegal_closure(P,T,B))). |
| 1486 | | check_value_aux(_,_Origin). |
| 1487 | | :- else. |
| 1488 | | /* a version of equal_object which will convert lists to avl if possible */ |
| 1489 | | equal_object_optimized_wf(V1,V2,_Origin,WF) :- |
| 1490 | | ( var(V1) -> (var(V2) -> V1=V2 ; equal_object_opt3(V2,V1,WF)) |
| 1491 | ? | ; equal_object_opt3(V1,V2,WF)). |
| 1492 | | |
| 1493 | | equal_object_wf(V1,V2,_Origin,WF) :- ( (var(V1);var(V2)) -> V1=V2 |
| 1494 | ? | ; nonvar(V1) -> equal_object3(V1,V2,WF) |
| 1495 | | ; equal_object3(V2,V1,WF)). |
| 1496 | | equal_object_wf(V1,V2,WF) :- ( (var(V1);var(V2)) -> V1=V2 |
| 1497 | ? | ; nonvar(V1) -> equal_object3(V1,V2,WF) |
| 1498 | | ; equal_object3(V2,V1,WF)). |
| 1499 | | :- endif. |
| 1500 | | |
| 1501 | | |
| 1502 | | equal_object_opt3(int(X),Y,_WF) :- !, Y=int(X). |
| 1503 | | equal_object_opt3(fd(X,T),Y,_WF) :- !, Y=fd(X,T). |
| 1504 | | equal_object_opt3(string(X),Y,_WF) :- !, Y=string(X). |
| 1505 | | equal_object_opt3(pred_false,Y,_WF) :- !, Y=pred_false. |
| 1506 | | equal_object_opt3(pred_true,Y,_WF) :- !, Y=pred_true. |
| 1507 | | equal_object_opt3(X,S2,WF) :- var(S2), %unbound_variable(S2), % is it ok to assing an AVL set in one go ?! |
| 1508 | | should_be_converted_to_avl_from_lists(X), !, % does a ground(X) check |
| 1509 | ? | construct_avl_from_lists_wf(X,S2,WF). |
| 1510 | | %equal_object_opt3([H|T],S2) :- var(S2),ground(H),ground(T), !, construct_avl_from_lists([H|T],S2). |
| 1511 | ? | equal_object_opt3(X,Y,WF) :- equal_object3(X,Y,WF). |
| 1512 | | |
| 1513 | | |
| 1514 | | %%equal_object3c(X,Y) :- if(equal_object3(X,Y),true, |
| 1515 | | %% (print_message(equal_object3_failed(X,Y)),equal_object3(X,Y),fail)). %% |
| 1516 | | :- if(environ(prob_safe_mode,true)). |
| 1517 | | equal_object3(X,Y,_WF) :- (nonvar(Y) -> type_error(X,Y) ; illegal_value(X)), |
| 1518 | | add_internal_error('Internal Typing Error (please report as bug !) : ',equal_object(X,Y)),fail. |
| 1519 | | :- endif. |
| 1520 | | equal_object3(closure(Par,ParTypes,Clo),Y,WF) :- var(Y),!, |
| 1521 | | ( closure_occurs_check(Y,Par,ParTypes,Clo) |
| 1522 | | -> print(occurs_check(Y,Par)),nl, |
| 1523 | | expand_custom_set_wf(closure(Par,ParTypes,Clo),Expansion,equal_object3,WF), |
| 1524 | | equal_object_optimized_wf(Y,Expansion,equal_object3,WF) |
| 1525 | | ; Y = closure(Par,ParTypes,Clo)). |
| 1526 | | equal_object3(closure(Parameters,PT,Cond),Y,WF) :- |
| 1527 | ? | equal_object_custom_explicit_set(closure(Parameters,PT,Cond),Y,WF). |
| 1528 | | %equal_object3(Obj,Y) :- is_custom_explicit_set(Obj,equal_object3_Obj), |
| 1529 | | % equal_object_custom_explicit_set(Obj,Y,WF). % inlined below for performance |
| 1530 | | equal_object3(global_set(X),Y,WF) :- equal_object_custom_explicit_set(global_set(X),Y,WF). |
| 1531 | | equal_object3(freetype(X),Y,WF) :- equal_object_custom_explicit_set(freetype(X),Y,WF). |
| 1532 | ? | equal_object3(avl_set(X),Y,WF) :- equal_object_custom_explicit_set(avl_set(X),Y,WF). |
| 1533 | | equal_object3(pred_true /* bool_true */,pred_true /* bool_true */,_WF). |
| 1534 | | equal_object3(pred_false /* bool_false */,pred_false /* bool_false */,_WF). |
| 1535 | | equal_object3(term(X),term(X),_WF). |
| 1536 | | equal_object3(string(X),string(X),_WF). |
| 1537 | ? | equal_object3(rec(F1),rec(F2),WF) :- equal_fields_wf(F1,F2,WF). |
| 1538 | | equal_object3(freeval(Id,C,F1),freeval(Id,C,F2),WF) :- |
| 1539 | | instantiate_freetype_case(Id,C,C), |
| 1540 | | equal_object_wf(F1,F2,WF). |
| 1541 | | equal_object3(int(X),int(X),_WF). |
| 1542 | ? | equal_object3(fd(X,Type),fd(Y,Type),_WF) :- eq_fd(X,Y). |
| 1543 | | equal_object3((X,Y),(X2,Y2),WF) :- |
| 1544 | ? | equal_object_wf(X,X2,WF), 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 |
| 1545 | | equal_object3([],X,WF) :- empty_set_wf(X,WF). |
| 1546 | | equal_object3([H|T],S2,WF) :- nonvar(S2), is_custom_explicit_set_nonvar(S2),!, |
| 1547 | ? | equal_custom_explicit_set_cons_wf(S2,H,T,WF). |
| 1548 | | %equal_object3([H|T],S2,WF) :- equal_cons_wf(S2,H,T,WF). % leads to time-out for test 1270 : TODO investigate |
| 1549 | ? | equal_object3([H|T],S2,_WF) :- equal_cons(S2,H,T). |
| 1550 | | |
| 1551 | | equal_object_custom_explicit_set(Obj,Y,WF) :- |
| 1552 | | (var(Y) -> Y = Obj |
| 1553 | ? | ; (is_custom_explicit_set_nonvar(Y) -> equal_explicit_sets_wf(Obj,Y,WF) |
| 1554 | | ; (Y=[] -> is_empty_explicit_set_wf(Obj,WF) |
| 1555 | ? | ; Y=[H|T] -> equal_custom_explicit_set_cons_wf(Obj,H,T,WF) |
| 1556 | | ; add_internal_error('Illegal set: ',equal_object_custom_explicit_set(Obj,Y,WF)),fail |
| 1557 | | ) |
| 1558 | | )). |
| 1559 | | |
| 1560 | | equal_custom_explicit_set_cons_wf(CS,H,T,_WF) :- CS \= avl_set(_), |
| 1561 | | var(H),var(T), % TO DO: should we move this treatment below ? to equal_cons_lwf |
| 1562 | | % YES, I THINK WE CAN DELETE THIS NOW for avl_sets; but not yet for global_set,... |
| 1563 | | % print_term_summary(equal_custom_explicit_set_cons(CS,H,T)),nl, (debug_mode(on) -> trace ; true), |
| 1564 | | unbound_variable(H), |
| 1565 | | unbound_variable_for_cons(T), |
| 1566 | | !, |
| 1567 | | remove_minimum_element_custom_set(CS,Min,NewCS), |
| 1568 | | (H,T) = (Min,NewCS). |
| 1569 | | equal_custom_explicit_set_cons_wf(avl_set(AVL),H,T,_WF) :- var(H), |
| 1570 | | is_unbound_ordered_list_skeleton(H,T),!, % TO DO: provide this also for global_set(_) |
| 1571 | | % below we check if H can be removed from AVL and remove it |
| 1572 | | remove_minimal_elements([H|T],avl_set(AVL),SkeletonToUnify), |
| 1573 | | [H|T] = SkeletonToUnify. |
| 1574 | | equal_custom_explicit_set_cons_wf(Obj,H,T,WF) :- |
| 1575 | ? | equal_cons_lwf(Obj,H,T,2,WF). |
| 1576 | | %equal_cons_wf(Obj,H,T,WF). % equal_cons_wf causes issues to tests 799, (but not anymore 1751, 1642, 1708) |
| 1577 | | |
| 1578 | | |
| 1579 | | :- block equal_fields_wf(-,-,?). |
| 1580 | | equal_fields_wf([],[],_). |
| 1581 | | equal_fields_wf([field(Name1,V1)|T1],[field(Name2,V2)|T2],WF) :- |
| 1582 | | check_field_name_compatibility(Name1,Name2,equal_fields_wf), |
| 1583 | ? | equal_object_wf(V1,V2,field,WF), |
| 1584 | | equal_fields_wf(T1,T2,WF). |
| 1585 | | |
| 1586 | | |
| 1587 | | % is just like equal_cons, but H and T are guaranteed by the caller to be free |
| 1588 | | % this just gives one next element of the set; can be used to iterate over sets. |
| 1589 | | get_next_element(R,H,T) :- var(R),!,R=[H|T]. |
| 1590 | | get_next_element([H1|T1],H,T) :- !,(H1,T1)=(H,T). |
| 1591 | | get_next_element(R,H,T) :- equal_cons(R,H,T). |
| 1592 | | |
| 1593 | | |
| 1594 | | equal_cons_wf(R,H,T,WF) :- WF == no_wf_available,!, equal_cons_lwf(R,H,T,2,WF). |
| 1595 | | equal_cons_wf(R,H,T,WF) :- |
| 1596 | | %get_cardinality_wait_flag(R,equal_cons_wf,WF,LWF), |
| 1597 | | %get_binary_choice_wait_flag(equal_cons_wf,WF,LWF), %old version |
| 1598 | | LWF = lwf_card(R,equal_cons_wf,WF), % will be instantiated by instantiate_lwf |
| 1599 | ? | equal_cons_lwf(R,H,T,LWF,WF). |
| 1600 | | |
| 1601 | | % a deterministic version; will never instantiate non-deterministically: |
| 1602 | | % probably better to use equal_cons_wf if possible |
| 1603 | | %equal_cons_det(R,H,T) :- equal_cons_lwf4(R,H,T,_). |
| 1604 | | |
| 1605 | | equal_cons(R,H,T) :- |
| 1606 | ? | equal_cons_lwf(R,H,T,2,no_wf_available). %lwf_first(2)). |
| 1607 | | |
| 1608 | | :- block blocking_equal_cons_lwf(-,?,?,?,?). |
| 1609 | ? | blocking_equal_cons_lwf(E,H,T,LWF,WF) :- equal_cons_lwf(E,H,T,LWF,WF). |
| 1610 | | |
| 1611 | | %equal_cons_lwf4(R,H,T,LWF) :- equal_cons_lwf(R,H,T,LWF,no_wf_available). |
| 1612 | | |
| 1613 | ? | equal_cons_lwf(R,H,T,_,_) :- var(R),!,add_new_el(T,H,R). |
| 1614 | | equal_cons_lwf([HR|TR],H,T,_,WF) :- ground_value(H), %print(delete_exact(H,[HR|TR])),nl, |
| 1615 | | try_quick_delete_exact_member([HR|TR],H,Rest), % try and see if we can find an exact member in the list |
| 1616 | | % adds quadratic complexity if TR is a list; TODO: maybe do a sort |
| 1617 | | !, |
| 1618 | | %equal_object(Rest,T,equal_cons_lwf_1). |
| 1619 | ? | equal_object_wf(Rest,T,equal_cons_lwf_1,WF). |
| 1620 | ? | equal_cons_lwf([HR|TR],H,T,LWF,WF) :- !, equal_cons_cons(HR,TR,H,T,LWF,WF). |
| 1621 | | equal_cons_lwf(avl_set(AVL),H,T,LWF,WF) :- !, |
| 1622 | | (is_one_element_custom_set(avl_set(AVL),El) |
| 1623 | | -> empty_set(T), % was T=[], but T could be an empty closure ! |
| 1624 | | equal_object_wf(El,H,equal_cons_lwf_2,WF) |
| 1625 | | ; T==[] -> fail % we have a one element set and AVL is not |
| 1626 | | ; element_can_be_added_or_removed_to_avl(H) -> |
| 1627 | | remove_element_from_explicit_set(avl_set(AVL),H,AR), |
| 1628 | | equal_object_wf(AR,T,equal_cons_lwf_3,WF) |
| 1629 | | ; nonvar(T),T=[H2|T2],element_can_be_added_or_removed_to_avl(H2) -> |
| 1630 | | remove_element_from_explicit_set(avl_set(AVL),H2,AR), |
| 1631 | | equal_object_wf(AR,[H|T2],equal_cons_lwf_4,WF) |
| 1632 | | % TO DO: move all such H2 to the front ?? |
| 1633 | | % Common pattern for function application patterns f(a) = 1 & f(b) = 2 & f = AVL |
| 1634 | | % We have f = [(a,1),(b,2)|_] to be unified with an avl_set |
| 1635 | | ; at_most_one_match_possible(H,AVL,Pairs) -> Pairs=[H2], % unification could fail if no match found |
| 1636 | | % this optimisation is redundant wrt definitely_not_in_list optimisation below; check test 1716 |
| 1637 | | % but it has better performance for large sets, e.g., when unifying with a large sequence skeleton |
| 1638 | | % TODO: it could be useful even if there are more than one matches?? |
| 1639 | | equal_object_wf(H,H2,WF), |
| 1640 | | % element_can_be_added_or_removed_to_avl not checked ! |
| 1641 | | % we may need to call another predicate to remove, which only checks index |
| 1642 | | % or at_most_one_match_possible should remove the element itself |
| 1643 | | remove_element_from_explicit_set(avl_set(AVL),H2,AR), % print(removed_from_avl_by_equal_cons(H)),nl, |
| 1644 | | equal_object_wf(AR,T,equal_cons_lwf_3,WF) %% |
| 1645 | | ; expand_custom_set_wf(avl_set(AVL),ES,equal_cons_lwf,WF), % length(ES,LenES),print(expanded(LenES,T)),nl, |
| 1646 | | % before attempting unification quickly look if lengths are compatible: |
| 1647 | | quick_check_length_compatible(ES,[H|T]), % not really sure this is worth it: we have propagate_card in equal_cons_cons below |
| 1648 | | %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 |
| 1649 | | equal_cons_perf_message(AVL,H,T,WF), |
| 1650 | ? | equal_cons_lwf(ES,H,T,LWF,WF) ). |
| 1651 | | equal_cons_lwf(C,H,T,LWF,WF) :- |
| 1652 | | is_interval_closure_or_integerset(C,Low,Up), |
| 1653 | | (T==[] -> true ; finite_bound(Low), finite_bound(Up)), |
| 1654 | | !, |
| 1655 | ? | equal_cons_interval(H,T,Low,Up,LWF,WF). |
| 1656 | | equal_cons_lwf(closure(P,Ty,B),H,T,LWF,WF) :- !, |
| 1657 | | equal_cons_closure(P,Ty,B,H,T,LWF,WF). |
| 1658 | | equal_cons_lwf(freetype(ID),H,T,LWF,WF) :- !, expand_custom_set_wf(freetype(ID),ES,equal_cons_lwf,WF), |
| 1659 | | blocking_equal_cons_lwf(ES,H,T,LWF,WF). |
| 1660 | | equal_cons_lwf(global_set(G),H,T,LWF,WF) :- equal_cons_global_set(G,H,T,LWF,WF). |
| 1661 | | |
| 1662 | | |
| 1663 | | :- use_module(probsrc(avl_tools),[avl_height_less_than/2]). |
| 1664 | | :- use_module(performance_messages,[perf_format_wf/3]). |
| 1665 | | equal_cons_perf_message(AVL,H,T,WF) :- preference(performance_monitoring_on,true), |
| 1666 | | \+ avl_height_less_than(AVL,5), |
| 1667 | | \+ is_unbound_ordered_list_skeleton(H,T), % otherwise H will be set to minimum of AVL deterministically |
| 1668 | | !, |
| 1669 | | translate:translate_bvalue(avl_set(AVL),AS), |
| 1670 | | translate:translate_bvalue([H|T],HTS), |
| 1671 | | perf_format_wf('Expanding avl_set for set-unification~n ~w~n =~n ~w~n',[AS,HTS],WF). |
| 1672 | | equal_cons_perf_message(_,_,_,_). |
| 1673 | | |
| 1674 | | equal_cons_closure(P,Ty,B,_H,T,_LWF,_WF) :- nonvar(T), |
| 1675 | | is_definitely_finite(T), % move earlier; is_infinite_closure can perform expansions, e.g., for nested closures |
| 1676 | | is_infinite_closure(P,Ty,B), |
| 1677 | | !, |
| 1678 | | fail. % an infinite set cannot be equal to a finite one. |
| 1679 | | equal_cons_closure(P,Ty,B,H,T,LWF,WF) :- |
| 1680 | | expand_custom_set_wf(closure(P,Ty,B),ES,equal_cons_closure,WF), |
| 1681 | | blocking_equal_cons_lwf(ES,H,T,LWF,WF). |
| 1682 | | |
| 1683 | | is_definitely_finite(Var) :- var(Var),!,fail. |
| 1684 | | is_definitely_finite([]). |
| 1685 | | is_definitely_finite([_|T]) :- is_definitely_finite(T). |
| 1686 | | is_definitely_finite(avl_set(_)). |
| 1687 | | |
| 1688 | | %get_wf_from_lwf(LWF,WF) :- % TO DO: a cleaner, less hacky version; passing WF around if possible |
| 1689 | | % (nonvar(LWF),LWF=lwf_card(_,_,WF1) -> WF=WF1 ; WF = no_wf_available). |
| 1690 | | |
| 1691 | | finite_bound(I) :- (var(I) -> true /* inf would be created straightaway */ ; number(I)). |
| 1692 | | |
| 1693 | | % 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 |
| 1694 | | equal_cons_interval(H,T,Low,Up,_LWF,_WF) :- T==[],!, % Low..Up = {H} -> Low=H & Up=H |
| 1695 | | % unification will fail if Low or Up are not numbers (inf) |
| 1696 | | (int(Low),int(Up)) = (H,H). |
| 1697 | | %equal_cons_interval(_H,_T,Low,Up,_LWF,WF) :- (nonvar(Low),\+ number(Low) ; nonvar(Up),\+ number(Up)),!, |
| 1698 | | % gen_enum_warning_wf('OPEN INTERVAL',Low:Up,'cannot expand',trigger_throw(equal_cons_interval),WF), |
| 1699 | | % % we could try and instantiate T to an infinite closure |
| 1700 | | % fail. |
| 1701 | | equal_cons_interval(H,T,Low,Up,LWF,WF) :- |
| 1702 | | (number(Low),number(Up) -> true % we can expand interval fully |
| 1703 | | ; propagate_in_interval([H|T],int(Low),int(Up),0)), |
| 1704 | | expand_interval_closure_to_avl(Low,Up,ES), |
| 1705 | ? | blocking_equal_cons_lwf(ES,H,T,LWF,WF). |
| 1706 | | |
| 1707 | | :- block propagate_in_interval(-,?,?,?). |
| 1708 | | propagate_in_interval([],Low,Up,Sze) :- |
| 1709 | | (Sze > 0 -> S1 is Sze-1, int_plus(Low,int(S1),Up) ; true). % Test should always be true |
| 1710 | | propagate_in_interval([H|T],Low,Up,Sze) :- |
| 1711 | | in_nat_range(H,Low,Up), % without enumeration |
| 1712 | | S1 is Sze+1, |
| 1713 | | propagate_in_interval(T,Low,Up,S1). |
| 1714 | | propagate_in_interval(avl_set(_A),_Low,_Up,_). % TO DO: propagate if Low/Up not instantiated |
| 1715 | | propagate_in_interval(closure(_,_,_),_,_,_). |
| 1716 | | propagate_in_interval(global_set(_),_,_,_). |
| 1717 | | |
| 1718 | | quick_check_length_compatible([],R) :- !, |
| 1719 | | (var(R) -> R=[] % can we force R=[] here ?? |
| 1720 | | ; R \= [_|_]). %(R \= [_|_] -> true ; print(incompatible(R)),fail). |
| 1721 | | quick_check_length_compatible([_|T],R) :- |
| 1722 | | (var(R) -> true |
| 1723 | | ; R = [] -> fail |
| 1724 | | ; R = [_|RT] -> quick_check_length_compatible(T,RT) |
| 1725 | | ; true). |
| 1726 | | |
| 1727 | | :- block equal_cons_global_set(-,?,?,?,?). |
| 1728 | | equal_cons_global_set(G,H,T,LWF,WF) :- is_infinite_global_set(G,_),!, |
| 1729 | | % for maximal sets we could complement_set([H],global(G),Res), |
| 1730 | | /* should normally fail, unless T is not a list but contains closure or global set */ |
| 1731 | | test_finite_set_wf(T,Finite,WF), dif(Finite,pred_true), |
| 1732 | | when((nonvar(Finite);nonvar(LWF)),equal_cons_global_set_warning(LWF,G,H,T,WF)). |
| 1733 | | % used to be : expand_custom_set(global_set(G),ES), equal_cons_lwf4(ES,H,T,LWF))). |
| 1734 | | equal_cons_global_set(G,H,T,LWF,WF) :- |
| 1735 | | %(is_infinite_global_set(G,_) -> test_finite_set_wf(T,Finite,WF), Finite \== pred_true ; true), |
| 1736 | | expand_custom_set_wf(global_set(G),ES,equal_cons_global_set,WF), |
| 1737 | | equal_cons_lwf(ES,H,T,LWF,WF). |
| 1738 | | |
| 1739 | | |
| 1740 | | :- block equal_cons_global_set_warning(-,?,?,?,?). |
| 1741 | | equal_cons_global_set_warning(_,G,H,T,WF) :- |
| 1742 | | add_new_event_in_error_scope(enumeration_warning(enumerating(G),G,'{}',finite,critical), |
| 1743 | | print_equal_cons_warning(G,H,T,WF)), |
| 1744 | | fail. % WITH NEW SEMANTICS OF ENUMERATION WARNING WE SHOULD PROBABLY ALWAYS FAIL HERE ! |
| 1745 | | |
| 1746 | | % THROWING, Span added by add_new_event_in_error_scope |
| 1747 | | print_equal_cons_warning(G,H,T,WF,THROWING,Span) :- |
| 1748 | | print('### Enumeration Warning: trying to deconstruct infinite set: '), |
| 1749 | | translate:print_bvalue(global_set(G)),nl, |
| 1750 | | print('### Source: '), print(equal_cons_global_set(G,H,T)),nl, |
| 1751 | | print_throwing_wf(THROWING,unknown_info,Span,WF). |
| 1752 | | |
| 1753 | | add_new_el(T,H,R) :- var(T),!,R=[H|T]. |
| 1754 | | add_new_el(T,H,R) :- nonvar(T), is_custom_explicit_set_nonvar(T), |
| 1755 | | add_element_to_explicit_set_wf(T,H,Res,no_wf_available), % will fail for closure/3 |
| 1756 | | !, |
| 1757 | | Res=R. |
| 1758 | | add_new_el([HT|TT],H,R) :- !,R=[H,HT|TT]. |
| 1759 | | add_new_el([],H,R) :- !, R=[H]. |
| 1760 | | add_new_el(Set,H,R) :- expand_custom_set_to_list(Set,ESet,_,add_new_el), |
| 1761 | | add_new_el(ESet,H,R). |
| 1762 | | |
| 1763 | | %delete_exact_member(V,_,_) :- var(V),!,fail. |
| 1764 | | %delete_exact_member([H|T],El,Res) :- |
| 1765 | | % (H==El -> Res=T |
| 1766 | | % ; Res=[H|TR], delete_exact_member(T,El,TR)). |
| 1767 | | |
| 1768 | | % a version of delete_exact_member with a cut off |
| 1769 | | % avoids spending useless time traversing large non-ground lists |
| 1770 | | % for a list consisting only of non-ground elements delete_exact_member will never succeed ! |
| 1771 | | % this occurs e.g., when a large list skeleton generated by e.g. size_of_sequence is unified with an avl_set |
| 1772 | | % (e.g., m = READ_PGM_IMAGE_FILE("pgm_files/yuv_1.pgm") & %i.(i:1..550| m(i) /|\ 725)) |
| 1773 | | try_quick_delete_exact_member(List,El,Result) :- |
| 1774 | | try_quick_delete_exact_member(List,1,El,Result). |
| 1775 | | try_quick_delete_exact_member(V,_,_,_) :- var(V),!,fail. |
| 1776 | | try_quick_delete_exact_member([H|T],Sz,El,Res) :- |
| 1777 | | (H==El -> Res=T |
| 1778 | | ; Res=[H|TR], |
| 1779 | | (Sz>50 |
| 1780 | | -> ground_value(H), % after a certain limit we only proceed if there are ground elements |
| 1781 | | % we could also check: preferences:preference(use_smt_mode,true) |
| 1782 | | Sz=30 % check again in 20 steps |
| 1783 | | ; Sz1 is Sz+1), |
| 1784 | | try_quick_delete_exact_member(T,Sz1,El,TR)). |
| 1785 | | |
| 1786 | | |
| 1787 | | %unbound_variable(V) :- !, unbound_variable_check(V). |
| 1788 | | unbound_variable(V) :- free_var(V), frozen(V,Residue), |
| 1789 | | %unbound_residue(Residue,V). |
| 1790 | | (unbound_residue(Residue,V) -> true ; %print(bound_var(V,Residue)),nl,trace,unbound_residue(Residue,V), |
| 1791 | | fail). |
| 1792 | | unbound_residue((A,B),V) :- !,unbound_residue(A,V), unbound_residue(B,V). |
| 1793 | | unbound_residue(true,_) :- !. |
| 1794 | | unbound_residue(Module:Call,Variable) :- unbound_residue_m(Module,Call,Variable). |
| 1795 | | |
| 1796 | | unbound_residue_m(external_functions,to_string_aux(GrV,_Val,Str),V) :- !, %GrV checks for groundness of _Val |
| 1797 | | V==GrV,unbound_variable(Str). |
| 1798 | | unbound_residue_m(external_functions,format_to_string_aux(GrV,_Format,_Val,Str),V) :- !, |
| 1799 | | %GrV checks for groundness of _Val |
| 1800 | | V==GrV,unbound_variable(Str). |
| 1801 | | % TO DO: we need to detect other functions (e.g., B function application,...) which result in values which are not used |
| 1802 | | %unbound_residue_m(_,ground_value_check(V1,V2),V) :- !, V1==V, unbound_variable(V2). % V1==V not necessary?! cycle check |
| 1803 | | unbound_residue_m(Module,Residue,Var) :- unbound_basic_residue(Module,Residue,Var). |
| 1804 | | |
| 1805 | | %unbound_basic_residue(_,true,_). |
| 1806 | | unbound_basic_residue(_,ground_value_check(V1,V2),Var) :- !, Var==V1, % == check to prevent loops |
| 1807 | | % in particularly in SWI, where residues also contain calls where Var==V2; e.g., test 639 |
| 1808 | | unbound_variable(V2). |
| 1809 | | unbound_basic_residue(_,ground_value_check_aux(V1,V2,V3),Var) :- !, (Var==V1 -> true ; Var==V2), unbound_variable(V3). |
| 1810 | | % we could also treat ground_value_opt_check |
| 1811 | | unbound_basic_residue(b_interpreter_components,observe_variable_block(_,_,_,_,_),_). % when in -p TRACE_INFO TRUE mode |
| 1812 | | unbound_basic_residue(b_interpreter_components,observe_variable1_block(_,_,_,_),_). % (provide_trace_information pref) |
| 1813 | | unbound_basic_residue(kernel_objects,mark_as_to_be_computed(_),_). |
| 1814 | | 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 |
| 1815 | | %unbound_basic_residue(kernel_objects,ordered_value(V,_),_). % <-- TO DO: treat this and then assign minimal value ! |
| 1816 | | %unbound_basic_residue(kernel_ordering,ordered_value2(V,_),_). |
| 1817 | | % b_tighter_enumerate_sorted_value_and_continue |
| 1818 | | %unbound_basic_residue(M,U,Var) :- print(bound_basic_residue(M,U,Var)),nl,fail. |
| 1819 | | |
| 1820 | | % check if we have an unbound list_skeleton with optionally just ordering constraints |
| 1821 | | % check if it is safe to assign H minimal value |
| 1822 | | % TO DO: also accept if all elements have the same co-routines constraints attached (e.g., because of +-> check) |
| 1823 | | is_unbound_ordered_list_skeleton(H,T) :- |
| 1824 | | is_unbound_ordered_list_skeleton3(H,T,[allow_ordered_values]). |
| 1825 | | is_unbound_list_skeleton(H,T) :- |
| 1826 | | is_unbound_ordered_list_skeleton3(H,T,[]). |
| 1827 | | |
| 1828 | | is_unbound_ordered_list_skeleton(H,T,Ordered) :- |
| 1829 | | is_unbound_ordered_list_skeleton3(H,T,List), |
| 1830 | | % if List gets instantiated it will become [allow_ordered_values|_] |
| 1831 | | (var(List) -> Ordered=unordered ; Ordered=ordered). |
| 1832 | | |
| 1833 | | is_unbound_ordered_list_skeleton3(H,T,Options) :- |
| 1834 | | free_var(H), |
| 1835 | | (var(T) -> unbound_variable(H), |
| 1836 | | unbound_ordered_tail(T,Options) % or ? unbound_variable_for_cons(T) |
| 1837 | | ; T = [H2|T2], |
| 1838 | | unbound_variable_or_ordered(H,'$$',H2,T,Options), |
| 1839 | | is_unbound_ordered_list_skeleton5(H,H2,T2,[H|T],Options)). |
| 1840 | | is_unbound_ordered_list_skeleton5(Prev,H,T,All,Options) :- |
| 1841 | | free_var(H), |
| 1842 | | (var(T) -> unbound_variable_or_ordered(H,Prev,'$$',All,Options), |
| 1843 | | unbound_ordered_tail(T,Options) |
| 1844 | | ; T==[] -> unbound_variable_or_ordered(H,Prev,'$$',All,Options) |
| 1845 | | ; T = [H2|T2], |
| 1846 | | unbound_variable_or_ordered(H,Prev,H2,All,Options), |
| 1847 | | is_unbound_ordered_list_skeleton5(H,H2,T2,All,Options)). |
| 1848 | | |
| 1849 | | % utility: if is_unbound_ordered_list_skeleton is true, extract for every element in the list one minimal element from CS |
| 1850 | | remove_minimal_elements(T,CS,Res) :- var(T),!,Res=CS. |
| 1851 | | remove_minimal_elements([],CS,Res) :- !, empty_set(CS),Res=[]. |
| 1852 | | remove_minimal_elements([_H|T],CS,[Min|Rest]) :- |
| 1853 | | remove_minimum_element_custom_set(CS,Min,NewCS), % _H will be unified in one go with Min later |
| 1854 | | remove_minimal_elements(T,NewCS,Rest). |
| 1855 | | |
| 1856 | | % it is unbound or can be assigned the minimal value of a set |
| 1857 | | unbound_variable_or_ordered(Var,Prev,Nxt,All,Options) :- |
| 1858 | | free_var(Var), frozen(Var,Residue), |
| 1859 | | unbound_ord_residue_aux(Residue,Prev,Var,Nxt,All,Options). |
| 1860 | | unbound_ord_residue_aux(true,_Prev,_,_Nxt,_All,_Options). |
| 1861 | | unbound_ord_residue_aux((A,B),Prev,V,Nxt,All,Options) :- !, |
| 1862 | | unbound_ord_residue_aux(A,Prev,V,Nxt,All,Options), |
| 1863 | | unbound_ord_residue_aux(B,Prev,V,Nxt,All,Options). |
| 1864 | | unbound_ord_residue_aux(Module:Call,Prev,V,Nxt,All,Options) :- |
| 1865 | | unbound_ord_residue_m(Module,Call,Prev,V,Nxt,All,Options). |
| 1866 | | unbound_ord_residue_m(Module,Residue,_,Var,_,_,_) :- unbound_basic_residue(Module,Residue,Var),!. |
| 1867 | | unbound_ord_residue_m(bsets_clp,check_index(V2,_),_,V,_,_,_) :- !, |
| 1868 | | V2==V. % assumes all index elements in the sequence are being checked; this is the case |
| 1869 | | unbound_ord_residue_m(kernel_objects,ordered_value(A,B),Prev,V,Nxt,_,Options) :- !, |
| 1870 | | % there is also a bsets_clp version |
| 1871 | | ((A,B)==(Prev,V) ; (A,B)==(V,Nxt)), |
| 1872 | | (member(allow_ordered_values,Options) -> true). |
| 1873 | | unbound_ord_residue_m(kernel_objects,not_equal_object_wf(A,B,_),_,V,_,All,_) :- !, |
| 1874 | | % check for all diff constraint; e.g., set up by not_element_of_wf(H,SoFar,WF) in cardinality_as_int2; |
| 1875 | | % anyway: all elements in a list must be different |
| 1876 | | (A==V -> exact_member_in_skel(B,All) ; B==V, exact_member_in_skel(A,All)). |
| 1877 | | unbound_ord_residue_m(kernel_objects,not_element_of_wf1(Set,Val,_),_,V,_,All,_) :- !, Val==V, |
| 1878 | | open_tail(All,Tail), Tail==Set. % ditto, again just stating that Values are distinct in the list |
| 1879 | | %unbound_ord_residue_m(A,Prev,V,Nxt,All) :- |
| 1880 | | % print(unbound_ord_residue_aux(A,Prev,V,Nxt,All)),nl,fail. |
| 1881 | | |
| 1882 | | % get tail of an open list: |
| 1883 | | open_tail(X,Res) :- var(X),!,Res=X. |
| 1884 | | open_tail([_|T],Res) :- open_tail(T,Res). |
| 1885 | | % exact member in a possibly open list: |
| 1886 | | exact_member_in_skel(X,List) :- nonvar(List), List=[Y|T], |
| 1887 | | (X==Y -> true ; exact_member_in_skel(X,T)). |
| 1888 | | |
| 1889 | | |
| 1890 | | unbound_ordered_tail(T,Options) :- free_var(T), frozen(T,Residue), |
| 1891 | | unbound_ordered_tail_aux(Residue,T,Options). |
| 1892 | | unbound_ordered_tail_aux(true,_,_). |
| 1893 | | unbound_ordered_tail_aux(kernel_objects:propagate_card(A,B,_Eq),V,_) :- |
| 1894 | | (V==A ; V==B). % just specifies A and B have same cardinality |
| 1895 | | unbound_ordered_tail_aux(prolog:dif(X,Y),V,_) :- (V==X,Y==[] ; V==Y,X==[]). |
| 1896 | | unbound_ordered_tail_aux(dif(X,Y),V,_) :- (V==X,Y==[] ; V==Y,X==[]). |
| 1897 | | unbound_ordered_tail_aux(kernel_objects:lazy_ordered_value(W,_),T,Options) :- |
| 1898 | | W==T, %% difference with just_cardinality_constraints |
| 1899 | | (member(allow_ordered_values,Options)->true). |
| 1900 | | unbound_ordered_tail_aux(bsets_clp:propagate_empty_set(_,_),_,_). |
| 1901 | | unbound_ordered_tail_aux(kernel_objects:prop_non_empty(_,W,_),T,_) :- W==T. |
| 1902 | | unbound_ordered_tail_aux(kernel_objects:cardinality_as_int2(W,_,_,_,_,_),T,_) :- W==T. |
| 1903 | | unbound_ordered_tail_aux(kernel_objects:cardinality3(W,_,_),Var,_) :- W==Var. |
| 1904 | | unbound_ordered_tail_aux((A,B),T,Options) :- |
| 1905 | | (unbound_ordered_tail_aux(A,T,Options) -> true ; unbound_ordered_tail_aux(B,T,Options)). |
| 1906 | | % TODO: call unbound_basic_residue |
| 1907 | | |
| 1908 | | % co-routine used to mark certain values as to be computed; avoid instantiating them |
| 1909 | | :- block mark_as_to_be_computed(-). |
| 1910 | | mark_as_to_be_computed(_). |
| 1911 | | |
| 1912 | | is_marked_to_be_computed(X) :- var(X),frozen(X,G), %nl,print(check_frozen(X,G)),nl, |
| 1913 | | marked_aux(G,X). |
| 1914 | | marked_aux((A,B),V) :- (marked_aux(A,V) -> true ; marked_aux(B,V)). |
| 1915 | | marked_aux(kernel_objects:mark_as_to_be_computed(M),V) :- V==M. |
| 1916 | | |
| 1917 | | :- public unbound_variable_check/1. |
| 1918 | | % currently not used; but can be useful for debugging |
| 1919 | | unbound_variable_check(V) :- free_var(V), % check no bool_pred attributes |
| 1920 | | (frozen(V,Goal), Goal\=true |
| 1921 | | -> nl,print('### WARNING: goal attached to unbound variable expression'),nl,print(V:Goal),nl, %trace, |
| 1922 | | fail |
| 1923 | | ; true). |
| 1924 | | |
| 1925 | | % 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 |
| 1926 | | unbound_variable_for_cons(Set) :- var(Set),frozen(Set,F), |
| 1927 | | \+ 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 |
| 1928 | | |
| 1929 | | % prolog:dif(X,Y) with Y == [] is ok |
| 1930 | | contains_problematic_coroutine_for_cons(custom_explicit_sets:element_of_avl_set_wf3(Var,_,_,_,_),V) :- V==Var. % occurs in test 1270 |
| 1931 | | contains_problematic_coroutine_for_cons(kernel_objects:non_free(_),_). % has been marked as non-free |
| 1932 | | contains_problematic_coroutine_for_cons(kernel_objects:mark_as_to_be_computed(_),_). % has been marked to be computed by closure expansion |
| 1933 | | % 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?) |
| 1934 | | % 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 |
| 1935 | | contains_problematic_coroutine_for_cons((A,B),Var) :- |
| 1936 | ? | (contains_problematic_coroutine_for_cons(A,Var) -> true |
| 1937 | | ; contains_problematic_coroutine_for_cons(B,Var)). |
| 1938 | | %contains_problematic_coroutine_for_cons(M:Call,Var) :- |
| 1939 | | % functor(Call,F,N), format('~w:~w/~w for ~w~n',[M,F,N,Var]),fail. |
| 1940 | | |
| 1941 | | unbound_variable_for_card(Set) :- % when do we allow card to instantiate a list skeleton |
| 1942 | | preference(data_validation_mode,true), |
| 1943 | | !, |
| 1944 | | unbound_variable(Set). |
| 1945 | | unbound_variable_for_card(Set) :- unbound_variable_for_cons(Set). |
| 1946 | | |
| 1947 | | |
| 1948 | | |
| 1949 | | % handling equal_object for [HR|TR] = [H|T] |
| 1950 | | |
| 1951 | | equal_cons_cons(HR,TR,H,T,_LWF,WF) :- TR==[],!, |
| 1952 | | empty_set_wf(T,WF), % was T=[], but T could be an empty closure |
| 1953 | ? | equal_object_wf(HR,H,equal_cons_cons_1,WF). |
| 1954 | | equal_cons_cons(HR,TR,H,T,_LWF,WF) :- T==[],!, |
| 1955 | | empty_set_wf(TR,WF), % was TR=[], but TR could be an empty closure |
| 1956 | ? | equal_object_wf(HR,H,equal_cons_cons_2,WF). |
| 1957 | | equal_cons_cons(HR,TR,H,T,_LWF,WF) :- |
| 1958 | | %(is_unbound_list_skeleton(H,T) -> true ; is_unbound_list_skeleton(HR,TR)), |
| 1959 | | (is_unbound_ordered_list_skeleton(H,T,Ordered) |
| 1960 | | -> (Ordered = unordered -> true |
| 1961 | | ; is_unbound_ordered_list_skeleton(HR,TR)) |
| 1962 | | ; is_unbound_list_skeleton(HR,TR)), |
| 1963 | | % if both are ordered: then the first elements must be equal, |
| 1964 | | % if one or both are not ordered: the unification HR=H is only ok if the other is unbound |
| 1965 | | % beware of tests 1078 and 1101 when allowing ordered lists |
| 1966 | | !, |
| 1967 | | % HR is variable: no constraints/co-routines attached to it; no other element in TR is constrained either |
| 1968 | | %(HR,TR)=(H,T). %fails, e.g., if TR=[] and T= empty closure ! |
| 1969 | | % at the moment : unbound_check does not allow ordered set skeletons |
| 1970 | | HR=H, equal_object_wf(TR,T,equal_cons_cons3,WF). |
| 1971 | | equal_cons_cons(HR,TR,H,T,LWF,WF) :- |
| 1972 | | % here we use LWF for the first time |
| 1973 | | %(number(LWF) -> LWF2=LWF ; true), |
| 1974 | | equality_objects_lwf(HR,H,EqRes,LWF2,WF), |
| 1975 | ? | equal_cons1(EqRes,HR,TR,H,T,LWF,LWF2,WF). |
| 1976 | | |
| 1977 | | equal_cons1(EqRes,_HR,TR,_H,T,_LWF,_LWF2,WF) :- EqRes == pred_true,!, |
| 1978 | | equal_object_wf(TR,T,equal_cons1,WF). |
| 1979 | | equal_cons1(EqRes,HR,TR,H,T,_LWF,_LWF2,WF) :- var(EqRes), |
| 1980 | | (definitely_not_in_list(TR,H) |
| 1981 | | ; definitely_not_in_list(T,HR) % this can induce a quadratic complexity for large list skeletons |
| 1982 | | ), |
| 1983 | | !, |
| 1984 | | EqRes=pred_true, % H cannot appear in TR; it must match HR |
| 1985 | | equal_object_wf(TR,T,equal_cons1,WF). |
| 1986 | | equal_cons1(EqRes,HR,TR,H,T,LWF,LWF2,WF) :- |
| 1987 | ? | instantiate_lwf(LWF,LWF2), % instantiate later to ensure var(EqRes) can hold if LWF already bound |
| 1988 | | %print(eq_cons_cons_lwf2(HR,H,EqRes,LWF2)),nl, |
| 1989 | ? | equal_cons2(EqRes,HR,TR,H,T,LWF2,WF), |
| 1990 | | propagate_card(TR,T,EqRes). % prevents tail recursion; move earlier/remove if EqRes nonvar? |
| 1991 | | %,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 |
| 1992 | | |
| 1993 | | |
| 1994 | | % this will instantiate LWF if it has not yet been computed |
| 1995 | | % (Idea: get_cardinality_wait_flag can be expensive; only do it if we really need the wait_flag) |
| 1996 | | instantiate_lwf(LWF,R) :- var(LWF),!,R=LWF. |
| 1997 | | instantiate_lwf(lwf_card(Set,Info,WF),LWF) :- !, % TO DO: in prob_data_validation_mode: increase or get_last_waitflag |
| 1998 | | get_cardinality_wait_flag(Set,Info,WF,LWF). |
| 1999 | | %% get_cardinality_powset_wait_flag(Set,Info,WF,_,LWF). |
| 2000 | | %instantiate_lwf(lwf_first(X),R) :- !, R=X. |
| 2001 | | instantiate_lwf(LWF,LWF). |
| 2002 | | |
| 2003 | | :- block equal_cons2(-,?,?,?,?,?,?). |
| 2004 | ? | equal_cons2(pred_true,_HR,TR,_H,T,_,WF) :- equal_object_wf(TR,T,equal_cons2,WF). |
| 2005 | | equal_cons2(pred_false,HR,TR, H,T,LWF,WF) :- |
| 2006 | ? | equal_cons_lwf(T,HR,TR2,LWF,WF), % look for HR inside T |
| 2007 | | T2=TR2, |
| 2008 | ? | equal_cons_lwf(TR,H,T2,LWF,WF). %, was instead of T2=TR2: equal_object(TR2,T2). |
| 2009 | | |
| 2010 | | :- use_module(kernel_tools,[cannot_match/2]). |
| 2011 | | % TO DO: investigate whether we should not use kernel_equality or at least a blocking version |
| 2012 | | definitely_not_in_list(V,_) :- var(V),!,fail. |
| 2013 | | definitely_not_in_list([],_). |
| 2014 | | definitely_not_in_list([H|T],X) :- cannot_match(H,X), definitely_not_in_list(T,X). |
| 2015 | | |
| 2016 | | |
| 2017 | | :- block propagate_card(-,-,-). |
| 2018 | | propagate_card(X,Y,EqRes) :- |
| 2019 | | (nonvar(EqRes) -> true % we no longer need to propagate; equal_cons will traverse |
| 2020 | | ; nonvar(X) -> propagate_card2(X,Y,EqRes) |
| 2021 | | ; propagate_card2(Y,X,EqRes)). |
| 2022 | | propagate_card2([],Y,_) :- !,empty_set(Y). |
| 2023 | | propagate_card2([_|TX],Y,EqRes) :- !, |
| 2024 | | (var(Y) -> Y= [_|TY], propagate_card(TX,TY,EqRes) |
| 2025 | | ; Y=[] -> fail |
| 2026 | | ; Y=[_|TY] -> propagate_card(TX,TY,EqRes) |
| 2027 | | ; true |
| 2028 | | ). % TO DO: add more propagation |
| 2029 | | propagate_card2(_,_,_). |
| 2030 | | |
| 2031 | | %same_card_and_expand(A,B,ExpA,ExpB) :- .... + reorder ?? |
| 2032 | | |
| 2033 | | |
| 2034 | | % CODE FOR CHECKING FOR TYPE ERRORS AT RUNTIME |
| 2035 | | |
| 2036 | | % explicitly check for type errors between two terms |
| 2037 | | % can be useful for some external functions were users provide predicates/values at runtime |
| 2038 | | % should be called before attempting e.g., equal_object |
| 2039 | | check_values_have_same_type(TermA,TermB,_Pos) :- (var(TermA) ; var(TermB)),!. |
| 2040 | | check_values_have_same_type((A1,A2),(B1,B2),Pos) :- !, |
| 2041 | | check_values_have_same_type(A1,B1,Pos), |
| 2042 | | check_values_have_same_type(A2,B2,Pos). |
| 2043 | | % TODO: better checking for fields |
| 2044 | | check_values_have_same_type(TermA,TermB,Pos) :- type_error(TermA,TermB),!, |
| 2045 | | add_error(kernel_objects,'Type error, values are incompatible:',(TermA,TermB),Pos). |
| 2046 | | check_values_have_same_type(_,_,_). |
| 2047 | | |
| 2048 | | % the following is used by some kernel predicates if(environ(prob_safe_mode,true)). |
| 2049 | | :- assert_must_succeed(type_error([],int(1))). |
| 2050 | | :- assert_must_succeed(type_error((int(1),int(2)),[pred_true])). |
| 2051 | | :- assert_must_succeed(type_error(string('Name'),global_set('Name'))). |
| 2052 | | :- assert_must_fail((type_error([],[_]))). |
| 2053 | | type_error(pred_true,Y) :- \+ bool_val(Y). |
| 2054 | | type_error(pred_false,Y) :- \+ bool_val(Y). |
| 2055 | | type_error([],Y) :- no_set_type_error(Y). |
| 2056 | | type_error([_|_],Y) :- no_set_type_error(Y). |
| 2057 | | %type_error(X,Y) :- is_custom_explicit_set(X,type_error1), no_set_type_error(Y). |
| 2058 | | type_error(avl_set(A),Y) :- illegal_avl_set(A) -> true ; no_set_type_error(Y). |
| 2059 | | type_error(global_set(_),Y) :- no_set_type_error(Y). |
| 2060 | | type_error(freetype(_),Y) :- no_set_type_error(Y). |
| 2061 | | type_error(closure(P,_,B),Y) :- |
| 2062 | | (var(P) -> true ; var(B) -> true ; P=[] -> true ; P=[P1|_], var(P1) -> true ; no_set_type_error(Y)). |
| 2063 | | type_error((_,_),Y) :- Y \= (_,_). |
| 2064 | | type_error(fd(_,T1),Y) :- (Y= fd(_,T2) -> nonvar(T1),nonvar(T2),T1 \=T2 ; true). |
| 2065 | | type_error(int(_),Y) :- Y\= int(_). |
| 2066 | | type_error(term(_),Y) :- Y\= term(_). |
| 2067 | | type_error(rec(FX),Y) :- (Y = rec(FY) -> type_error_fields(FX,FY,'$') ; true). |
| 2068 | | type_error(freeval(ID,_,_),Y) :- Y \= freeval(ID,_,_). |
| 2069 | | type_error(string(_),Y) :- Y \= string(_). |
| 2070 | | % Should raise type error: kernel_objects:union([int(1)],[[]],R). |
| 2071 | | |
| 2072 | | bool_val(pred_true). |
| 2073 | | bool_val(pred_false). |
| 2074 | | |
| 2075 | | type_error_fields(X,Y,_) :- (var(X);var(Y)),!,fail. |
| 2076 | | type_error_fields([],[_|_],_). |
| 2077 | | type_error_fields([_|_],[],_). |
| 2078 | | type_error_fields([F1|T1],[F2|T2],PrevField) :- |
| 2079 | | nonvar(F1),nonvar(F2),F1=field(Name1,_),F2=field(Name2,_), |
| 2080 | | nonvar(Name1), |
| 2081 | | (Name1 @=< PrevField -> true % not sorted |
| 2082 | | ; Name1 \= Name2 -> true % other record has different field |
| 2083 | | ; type_error_fields(T1,T2,Name1)). |
| 2084 | | |
| 2085 | | illegal_value(X) :- var(X),!,fail. |
| 2086 | | illegal_value(avl_set(A)) :- illegal_avl_set(A). |
| 2087 | | illegal_value([H|T]) :- illegal_value(H) -> true ; illegal_value(T). |
| 2088 | | illegal_value(global_set(G)) :- \+ ground(G). |
| 2089 | | illegal_value(N) :- number(N). |
| 2090 | | illegal_value((A,B)) :- illegal_value(A) -> true ; illegal_value(B). |
| 2091 | | % TO DO: complete this |
| 2092 | | |
| 2093 | | illegal_avl_set(X) :- var(X),!. |
| 2094 | | illegal_avl_set(empty). |
| 2095 | | illegal_avl_set(X) :- (X=node(_,_,_,_,_) -> \+ ground(X) ; true). |
| 2096 | | |
| 2097 | | no_set_type_error(int(_)). |
| 2098 | | no_set_type_error(fd(_,_)). |
| 2099 | | no_set_type_error((_,_)). |
| 2100 | | no_set_type_error(rec(_)). |
| 2101 | | no_set_type_error(pred_true /* bool_true */). |
| 2102 | | no_set_type_error(pred_false /* bool_false */). |
| 2103 | | no_set_type_error(term(_)). |
| 2104 | | no_set_type_error(string(_)). |
| 2105 | | no_set_type_error(freeval(_,_,_)). |
| 2106 | | no_set_type_error(avl_set(A)) :- illegal_avl_set(A). |
| 2107 | | %% END OF TYPE CHECKING CODE |
| 2108 | | |
| 2109 | | |
| 2110 | | :- assert_must_succeed(not_equal_object(term(a),term(b))). |
| 2111 | | :- assert_must_succeed(not_equal_object(string('a'),string('b'))). |
| 2112 | | :- assert_must_succeed(not_equal_object(int(1),int(2))). |
| 2113 | | :- assert_must_succeed(not_equal_object(rec([field(a,int(1))]),rec([field(a,int(2))]))). |
| 2114 | | :- assert_must_succeed(not_equal_object(rec([field(a,int(1)),field(b,int(2))]), |
| 2115 | | rec([field(a,int(1)),field(b,int(3))]))). |
| 2116 | | :- assert_must_fail(not_equal_object(rec([field(a,int(1))]),rec([field(a,int(1))]))). |
| 2117 | | :- assert_must_fail(not_equal_object(rec([field(a,int(1)),field(b,int(2))]), |
| 2118 | | rec([field(a,int(1)),field(b,int(2))]))). |
| 2119 | | :- assert_must_fail(not_equal_object(term(msg),int(2))). |
| 2120 | | :- assert_must_fail(not_equal_object(fd(1,a),term(msg))). |
| 2121 | | :- assert_must_succeed(not_equal_object(global_set(a),global_set(b))). |
| 2122 | | :- assert_must_succeed(not_equal_object([term(a),term(b)],[term(a),term(c)])). |
| 2123 | | :- assert_must_succeed((not_equal_object([(int(1),[Y])],[(int(X),[Z])]), |
| 2124 | | Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[int(2)])). |
| 2125 | | :- assert_must_succeed(not_equal_object((int(1),int(2)),(int(3),int(4)))). |
| 2126 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_equal_object((int(1),int(2)),(int(1),int(4))))). |
| 2127 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_equal_object((int(1),int(4)),(int(3),int(4))))). |
| 2128 | | :- assert_must_fail(not_equal_object((int(1),int(4)),(int(1),int(4)))). |
| 2129 | | :- assert_must_succeed(not_equal_object((int(1),string('a')),(int(1),string('b')))). |
| 2130 | | :- assert_must_fail(not_equal_object((int(1),string('b')),(int(1),string('b')))). |
| 2131 | | :- assert_must_fail(not_equal_object([(term(a),[])],[(term(a),[])])). |
| 2132 | | :- assert_must_fail((not_equal_object([(int(1),[Y])],[(int(X),[Z])]), |
| 2133 | | Y=(term(a),Y2), X=1, Z=(term(a),[]), Y2=[])). |
| 2134 | | :- assert_must_fail(not_equal_object([int(1),int(2)],[int(2),int(1)])). |
| 2135 | | :- assert_must_succeed(not_equal_object(term(msg),term(another_msg))). |
| 2136 | | :- assert_must_succeed(not_equal_object([int(1),int(2)],[int(0),int(4)])). |
| 2137 | | :- assert_must_fail((sample_closure(C), |
| 2138 | | not_equal_object(C,[int(1),int(2)]))). |
| 2139 | | :- assert_must_succeed((sample_closure(C), |
| 2140 | | not_equal_object(C,[int(1),int(0)]))). |
| 2141 | | :- assert_must_succeed((sample_closure(C), |
| 2142 | | not_equal_object(C,global_set('NAT')))). |
| 2143 | | :- assert_must_fail((not_equal_object( |
| 2144 | | [[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')], |
| 2145 | | [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(3,'Name'),fd(2,'Name')]] |
| 2146 | | ,[[],[fd(1,'Name')],[fd(1,'Name'),fd(2,'Name')], |
| 2147 | | [fd(1,'Name'),fd(2,'Name'),fd(3,'Name')],[fd(2,'Name')],[fd(2,'Name'),fd(3,'Name')]]) |
| 2148 | | )). |
| 2149 | | :- assert_must_fail((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,a,int(2))))). |
| 2150 | | :- assert_must_succeed((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,a,int(3))))). |
| 2151 | | :- assert_must_succeed((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,b,int(2))))). |
| 2152 | | :- assert_must_succeed((not_equal_object(freeval(selfcx,a,int(2)),freeval(selfcx,a,int(3))))). |
| 2153 | | |
| 2154 | | :- assert_must_succeed((not_equal_object(pred_true /* bool_true */,X), X==pred_false /* bool_false */)). |
| 2155 | | :- assert_must_succeed((not_equal_object([],X),X=[_|_])). |
| 2156 | | %:- assert_must_succeed((not_equal_object([],X), nonvar(X),X=[_|_])). |
| 2157 | | :- assert_must_succeed((not_equal_object(X,[]), X=[_|_])). |
| 2158 | | :- assert_must_succeed((not_equal_object(X,pred_false /* bool_false */), X==pred_true /* bool_true */)). |
| 2159 | | |
| 2160 | | :- assert_must_succeed(not_equal_object([_X],[int(1),int(3)])). % Inefficiency example of setlog |
| 2161 | | :- assert_must_succeed_any(not_equal_object([_X],[int(1)])). % Inefficiency example of setlog |
| 2162 | | :- assert_must_succeed((not_equal_object([X],[pred_true /* bool_true */]),X==pred_false /* bool_false */)). |
| 2163 | | :- assert_must_succeed((not_equal_object([pred_true /* bool_true */],[X]),X==pred_false /* bool_false */)). |
| 2164 | | :- assert_must_succeed((not_equal_object([[X]],[[pred_true /* bool_true */]]),X==pred_false /* bool_false */)). |
| 2165 | | :- assert_must_succeed((not_equal_object([[pred_true /* bool_true */]],[[X]]),X==pred_false /* bool_false */)). |
| 2166 | | :- 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 */)). |
| 2167 | | :- 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 */)). |
| 2168 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([],[int(3333)]))). |
| 2169 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([],[int(2),int(1),int(3)]))). |
| 2170 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([int(3)],[int(2),int(1),int(3)]))). |
| 2171 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([int(3),int(1),int(4)],[int(2),int(1),int(3)]))). |
| 2172 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],not_equal_object([int(2),int(1),int(3),int(5)],[int(2),int(1),int(3)]))). |
| 2173 | | % X in 3..4, kernel_objects:not_equal_object([int(2),int(3)],[int(2),int(X)]), X==4. in clpfd Mode |
| 2174 | | |
| 2175 | | |
| 2176 | | not_equal_object_wf(X,Y,WF) :- |
| 2177 | | (var(X) |
| 2178 | | -> (var(Y) |
| 2179 | | -> X \== Y, |
| 2180 | | when((nonvar(X);nonvar(Y);?=(X,Y)), not_equal_object_wf0(X,Y,WF)) |
| 2181 | ? | ; not_equal_object_wf1(Y,X,WF) % invert arguments |
| 2182 | | ) |
| 2183 | ? | ; not_equal_object_wf1(X,Y,WF)). |
| 2184 | | |
| 2185 | | %:- block not_equal_object_wf0(-,-,?). |
| 2186 | | /* TO DO: implement a better _wf version ; use bool_dif if possible */ |
| 2187 | | % block is relevant for tests 1374, 1737 |
| 2188 | | not_equal_object_wf0(X,Y,WF) :- |
| 2189 | | %(X==Y -> print(not_eq_pruned(X,Y)),nl,fail ; true), |
| 2190 | | %X\==Y, % could be expensive if X,Y assigned to large term simultaneously (just woken up by when) |
| 2191 | ? | (var(X) -> X\==Y, not_equal_object_wf1(Y,X,WF) |
| 2192 | ? | ; not_equal_object_wf1(X,Y,WF)). |
| 2193 | | |
| 2194 | | not_equal_object_wf1([],R,WF) :- !, not_empty_set_wf(R,WF). |
| 2195 | | not_equal_object_wf1(R,E,WF) :- E==[],!, not_empty_set_wf(R,WF). |
| 2196 | ? | not_equal_object_wf1(X,Y,WF) :- not_equal_object2_wf(X,Y,WF). |
| 2197 | | |
| 2198 | | not_equal_object(X,Y) :- |
| 2199 | | ( nonvar(X) -> not_equal_object2_wf(X,Y,no_wf_available) |
| 2200 | | ; nonvar(Y) -> not_equal_object2_wf(Y,X,no_wf_available) |
| 2201 | | ; X\==Y, when((?=(X,Y);nonvar(X);nonvar(Y)), not_equal_object0(X,Y))). |
| 2202 | | |
| 2203 | | not_equal_object0(X,Y) :- X\==Y,(var(X) -> not_equal_object2_wf(Y,X,no_wf_available) |
| 2204 | | ; not_equal_object2_wf(X,Y,no_wf_available)). |
| 2205 | | |
| 2206 | | %not_equal_object2_wf(X,Y,_) :- print(not_equal_object2_wf(X,Y)),nl,fail. |
| 2207 | | not_equal_object2_wf(pred_true /* bool_true */,R,_) :- !, R=pred_false /* bool_false */. |
| 2208 | | not_equal_object2_wf(pred_false /* bool_false */,R,_) :- !, R=pred_true /* bool_true */. |
| 2209 | | 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 |
| 2210 | ? | neq_fd(X,Y,Type). |
| 2211 | | not_equal_object2_wf(int(X),R,_WF) :- !, R=int(Y), integer_dif(X,Y). |
| 2212 | | not_equal_object2_wf(string(X),R,_) :- !, R=string(Y), dif(X,Y). |
| 2213 | | not_equal_object2_wf(term(X),R,WF) :- !, R=term(Y), not_equal_term_wf(X,Y,WF). |
| 2214 | | not_equal_object2_wf(rec(F1),R,WF) :- !, R=rec(F2), |
| 2215 | ? | not_equal_fields_wf(F1,F2,WF). |
| 2216 | | not_equal_object2_wf([],X,WF) :- !, not_empty_set_wf(X,WF). |
| 2217 | | not_equal_object2_wf((X1,X2),R,WF) :- !, R=(Y1,Y2), |
| 2218 | ? | not_equal_couple_wf(X1,Y1,X2,Y2,WF). |
| 2219 | | not_equal_object2_wf(X,Y,WF) :- is_custom_explicit_set(X,not_equal_object2),!, |
| 2220 | ? | not_equal_explicit_set_wf(X,Y,WF). |
| 2221 | ? | not_equal_object2_wf(X,Y,WF) :- not_equal_object3(X,Y,WF). |
| 2222 | | |
| 2223 | | :- block not_equal_term_wf(-,-,?). |
| 2224 | | not_equal_term_wf(X,Y,_WF) :- % triggered e.g. in test 1225 or 1227 for nil (freetypes) |
| 2225 | | dif(X,Y). |
| 2226 | | % TO DO: should we treat floating/1 in a special way? |
| 2227 | | |
| 2228 | | :- block not_equal_explicit_set_wf(?,-,?). |
| 2229 | | not_equal_explicit_set_wf(X,Y,WF) :- |
| 2230 | | is_custom_explicit_set_nonvar(Y),!, |
| 2231 | | not_equal_explicit_sets_wf(X,Y,WF). |
| 2232 | | not_equal_explicit_set_wf(X,[],WF) :- !, |
| 2233 | | is_non_empty_explicit_set_wf(X,WF). |
| 2234 | | not_equal_explicit_set_wf(CS,[H|T],WF) :- |
| 2235 | | is_simple_infinite_set(CS), % global_set(.) or open interval |
| 2236 | | !, % TODO: maybe also detect other infinite sets |
| 2237 | | test_finite_set_wf(T,Finite,WF), |
| 2238 | | when(nonvar(Finite),(Finite=pred_true -> true % infinite set cannot be equal finite one |
| 2239 | | ; not_equal_explicit_set_expand(CS,[H|T],WF))). |
| 2240 | | not_equal_explicit_set_wf(X,Y,WF) :- |
| 2241 | ? | not_equal_explicit_set_expand(X,Y,WF). |
| 2242 | | |
| 2243 | | not_equal_explicit_set_expand(X,Y,WF) :- |
| 2244 | | expand_custom_set_wf(X,EX,not_equal_explicit_set_wf,WF), |
| 2245 | ? | not_equal_object3_block(EX,Y,WF). |
| 2246 | | |
| 2247 | | :- block not_equal_object3_block(-,?,?). |
| 2248 | ? | not_equal_object3_block(EX,Y,WF) :- not_equal_object3(EX,Y,WF). |
| 2249 | | |
| 2250 | | :- load_files(library(system), [when(compile_time), imports([environ/2])]). |
| 2251 | | :- block not_equal_object3(?,-,?). |
| 2252 | | :- if(environ(prob_safe_mode,true)). |
| 2253 | | not_equal_object3(X,Y,_) :- nonvar(X),type_error(X,Y), |
| 2254 | | add_internal_error('Internal Typing Error (please report as bug !) : ',not_equal_object(X,Y)), |
| 2255 | | fail. |
| 2256 | | :- endif. |
| 2257 | | not_equal_object3(X,Y,WF) :- is_custom_explicit_set(Y,not_equal_object2),!, |
| 2258 | ? | not_equal_explicit_set_wf(Y,X,WF). % TODO: will uselessly check for X being custom_set or [] |
| 2259 | | not_equal_object3(freeval(ID,Case1,Value1),freeval(ID,Case2,Value2),WF) :- |
| 2260 | | instantiate_freetype_case(ID,Case1,Case2), |
| 2261 | | when(?=(Case1,Case2), % we first have to be able to decide the case; if cases are different types of values may be different |
| 2262 | | not_equal_freeval_wf(Case1,Value1,Case2,Value2,WF)). |
| 2263 | | not_equal_object3([],X,WF) :- not_empty_set_wf(X,WF). |
| 2264 | | not_equal_object3([H|T],Set2,WF) :- |
| 2265 | | (Set2==[] -> true % note second argument is nonvar |
| 2266 | | ; cardinality_peano_wf([H|T],N1,no_wf_available), |
| 2267 | | cardinality_peano_wf(Set2,N2,no_wf_available), % TODO(?): pending co-routines if Set2 infinite |
| 2268 | ? | when(?=(N1,N2), % when we trigger code below, = can be decided: |
| 2269 | | (N1=N2 -> neq_cons_wf(Set2,H,T,WF) ; true))). |
| 2270 | | % (dif(N1,N2) ; (N1=N2, neq_cons_wf(Set2,H,T,WF)))). %not_equal_object_sets(Set1,Set2) )) ). |
| 2271 | | |
| 2272 | | not_equal_freeval_wf(Case1,Value1,Case2,Value2,WF) :- |
| 2273 | | (Case1=Case2 -> not_equal_object_wf(Value1,Value2,WF) ; true). |
| 2274 | | |
| 2275 | | :- block not_equal_object_sets_wf(-,?,?), not_equal_object_sets_wf(?,-,?). |
| 2276 | | not_equal_object_sets_wf([H|T],Set2,WF) :- !, |
| 2277 | | ( Set2=[H2|_T2] |
| 2278 | ? | -> not_equal_object_sets2(H,T,H2,Set2,WF) |
| 2279 | | ; Set2=[] -> true |
| 2280 | | ; not_equal_object2_wf(Set2,[H|T],WF) % avl_set probably |
| 2281 | | ). |
| 2282 | | not_equal_object_sets_wf(Set1,Set2,WF) :- % Note : if Set1 =[] then we can fail, as both sets have same length |
| 2283 | | % we could have empty set or avl_set can sometimes creep into end of lists |
| 2284 | | not_equal_object2_wf(Set1,Set2,WF). |
| 2285 | | |
| 2286 | | :- block not_equal_object_sets2(-,?,?,?,?), not_equal_object_sets2(?,?,-,?,?). |
| 2287 | | not_equal_object_sets2(H,_T,_H2,Set2,WF) :- |
| 2288 | | % TO DO: should we not use kernel_equality:membership_test_wf here ?? |
| 2289 | | not_element_of_wf(H,Set2,WF). |
| 2290 | | not_equal_object_sets2(H,T,_H2,Set2,WF) :- |
| 2291 | ? | remove_element_wf(H,Set2,Del2,WF), % used to be remove_element(X,Set,Res) :- equal_cons(Set,X,Res). |
| 2292 | ? | not_equal_object_wf(T,Del2,WF). |
| 2293 | | |
| 2294 | | |
| 2295 | | :- block neq_cons_wf(-,?,?,?). |
| 2296 | | neq_cons_wf([],_,_,_) :- !. |
| 2297 | | neq_cons_wf([H2|T2],H1,T1,WF) :- !, |
| 2298 | | (T2==[],T1==[] |
| 2299 | | -> not_equal_object_wf(H1,H2,WF) |
| 2300 | | ; check_and_remove([H2|T2],H1,NewSet2,RemoveSuccesful), |
| 2301 | ? | neq_cons2(RemoveSuccesful,T1,NewSet2,WF) |
| 2302 | | ). |
| 2303 | | neq_cons_wf(avl_set(A),H1,T1,WF) :- element_can_be_added_or_removed_to_avl(H1),!, |
| 2304 | | (remove_element_from_explicit_set(avl_set(A),H1,RA) |
| 2305 | | -> not_equal_object_wf(T1,RA,WF) |
| 2306 | | ; true ). |
| 2307 | | neq_cons_wf(ES,H1,T1,WF) :- is_custom_explicit_set(ES,neq_cons), |
| 2308 | | expand_custom_set_wf(ES,ExpSet,neq_cons_wf,WF), |
| 2309 | | neq_cons_wf(ExpSet,H1,T1,WF). |
| 2310 | | |
| 2311 | | :- block neq_cons2(-,?,?,?). |
| 2312 | | neq_cons2(not_successful,_T1,_NewSet2,_WF). % one element could not be removed: the sets are different |
| 2313 | ? | neq_cons2(successful,T1,NewSet2,WF) :- not_equal_object_sets_wf(T1,NewSet2,WF). |
| 2314 | | |
| 2315 | | % kernel_objects:not_equal_couple(int(1),int(Y),B,pred_true). |
| 2316 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(1),int(Y),B,pred_true,no_wf_available),Y=1, B==pred_false)). |
| 2317 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),B,pred_true,no_wf_available),Y=1, B==pred_false)). |
| 2318 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),B,pred_false,no_wf_available),Y=1, B==pred_true)). |
| 2319 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),pred_false,B,no_wf_available),Y=1, B==pred_true)). |
| 2320 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(Y),int(1),B,pred_true,no_wf_available),Y=2, var(B))). |
| 2321 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(B,pred_true,int(Y),int(1),no_wf_available),Y=1, B==pred_false)). |
| 2322 | | :- 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 )). |
| 2323 | | :- 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)). |
| 2324 | | |
| 2325 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(int(2500),int(50),_,_,no_wf_available))). |
| 2326 | | :- assert_must_succeed(( kernel_objects:not_equal_couple_wf(_,_,int(2500),int(50),no_wf_available))). |
| 2327 | | |
| 2328 | | |
| 2329 | | %was too lax (but works): :- block not_equal_couple_wf(-,?,-,?,?),not_equal_couple_wf(?,-,?,-,?). |
| 2330 | | % but not sure if this new declaration below is worth it, also since X1==Y1 or X2==Y2 is possible |
| 2331 | | :- block not_equal_couple_wf(-,?,-,?,?), % X1 or X2 must be known |
| 2332 | | not_equal_couple_wf(?,-,?,-,?), % Y1 or Y2 must be known |
| 2333 | | not_equal_couple_wf(?,-,-,?,?), % X2 or Y1 must be known |
| 2334 | | not_equal_couple_wf(-,?,?,-,?). % X1 or Y2 must be known |
| 2335 | | % (X1,X2) /= (Y1,Y2) |
| 2336 | | |
| 2337 | | % using CLPFD results in less propagation it seems |
| 2338 | | % e.g. post_constraint((A1 #\= A2 #\/ B1 #\= B2), dif((A1,B1),(A2,B2))) will not propagate if A1=A2 or B1=B2 |
| 2339 | | % we could do something like |
| 2340 | | % post_constraint((N*A1 + B1 #\= N*A2 + B2), dif((A1,B1),(A2,B2))). ; but we need to know good value for N |
| 2341 | | % TO DO: pass typing information when available ?? or not needed because type info extracted ? |
| 2342 | | |
| 2343 | | not_equal_couple_wf(X1,Y1,X2,Y2,WF) :- var(X1), var(Y1),!, |
| 2344 | | (X1==Y1 -> not_equal_object_wf(X2,Y2,WF) |
| 2345 | | ; not_equal_couple_wf_aux(X2,Y2,X1,Y1,WF)). % change order to test |
| 2346 | | not_equal_couple_wf(X1,Y1,X2,Y2,WF) :- |
| 2347 | ? | not_equal_couple_wf_aux(X1,Y1,X2,Y2,WF). |
| 2348 | | |
| 2349 | | not_equal_couple_wf_aux(X1,Y1,X2,Y2,WF) :- |
| 2350 | ? | equality_objects_wf(X1,Y1,EqRes1,WF), |
| 2351 | | (var(EqRes1) |
| 2352 | | -> equality_objects_wf(X2,Y2,EqRes2,WF), |
| 2353 | ? | not_equal_couple4(EqRes1,X1,Y1,EqRes2,X2,Y2) |
| 2354 | ? | ; EqRes1=pred_true -> not_equal_object_wf(X2,Y2,WF) |
| 2355 | | ; true). |
| 2356 | | |
| 2357 | | :- block not_equal_couple4(-,?,?,-,?,?). |
| 2358 | | not_equal_couple4(EqRes1,X1,Y1,EqRes2,X2,Y2) :- |
| 2359 | | (var(EqRes1) |
| 2360 | ? | -> not_equal_couple5(EqRes2,X1,Y1,EqRes1) |
| 2361 | ? | ; not_equal_couple5(EqRes1,X2,Y2,EqRes2)). |
| 2362 | | |
| 2363 | | not_equal_couple5(pred_true,_X2,_Y2,EqResOther) :- EqResOther=pred_false. |
| 2364 | | not_equal_couple5(pred_false,_,_,_). |
| 2365 | | |
| 2366 | | |
| 2367 | | /* To do: provide special support for things like |
| 2368 | | couple of fd's [done], list of fd's, set of fd's */ |
| 2369 | | |
| 2370 | | :- use_module(kernel_records,[check_field_name_compatibility/3]). |
| 2371 | | :- block not_equal_fields_wf(-,-,?). |
| 2372 | | not_equal_fields_wf([field(ID1,V1)|T1],[field(ID2,V2)|T2],WF) :- |
| 2373 | | % should we wait for ID1 or ID2 to become nonvar? |
| 2374 | | check_field_name_compatibility(ID1,ID2,not_equal_fields_wf), |
| 2375 | | (T1==[] |
| 2376 | | -> T2=[], not_equal_object_wf(V1,V2,WF) |
| 2377 | ? | ; 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 |
| 2378 | | ). |
| 2379 | | |
| 2380 | | |
| 2381 | | /* ------------------------------------------- */ |
| 2382 | | /* equality_objects/3 function */ |
| 2383 | | /* ------------------------------------------- */ |
| 2384 | | |
| 2385 | | %% :- ensure_loaded(kernel_equality). |
| 2386 | | |
| 2387 | | % ---------------------------------------------------------- |
| 2388 | | % ---------------------------------------------------------- |
| 2389 | | |
| 2390 | | |
| 2391 | | |
| 2392 | | :- use_module(kernel_equality). |
| 2393 | | |
| 2394 | | % ---------------------------------------------------------- |
| 2395 | | % ---------------------------------------------------------- |
| 2396 | | |
| 2397 | | /* ---------------> */ |
| 2398 | | /* This should probably be more systematically applied before every kernel call |
| 2399 | | + expanded for other symbolic representations !! */ |
| 2400 | | |
| 2401 | | |
| 2402 | | |
| 2403 | | /* underlying assumption: if G is a global set: we get back the |
| 2404 | | global_set tag immediately: no need to use when to wait; |
| 2405 | | better: ensure that b_compute_expression always returns a nonvar term */ |
| 2406 | | |
| 2407 | | integer_global_set('NAT'). |
| 2408 | | integer_global_set('NATURAL'). |
| 2409 | | integer_global_set('NAT1'). |
| 2410 | | integer_global_set('NATURAL1'). |
| 2411 | | integer_global_set('INT'). |
| 2412 | | integer_global_set('INTEGER'). |
| 2413 | | |
| 2414 | | string_global_set('STRING'). % TODO : check what happens when we have STRING in Event-B as a set |
| 2415 | | real_global_set('REAL'). % TODO: ditto |
| 2416 | | real_global_set('FLOAT'). % TODO: ditto |
| 2417 | | |
| 2418 | | |
| 2419 | | :- assert_must_succeed(( kernel_objects:element_of_global_set(int(0),'NATURAL'))). |
| 2420 | | :- assert_must_fail(( kernel_objects:element_of_global_set(int(0),'NATURAL1'))). |
| 2421 | | :- assert_must_fail(( kernel_objects:element_of_global_set(int(-1),'NATURAL'))). |
| 2422 | | :- assert_must_succeed(( kernel_objects:element_of_global_set(int(-1),'INTEGER'))). |
| 2423 | | :- assert_must_succeed(( kernel_objects:element_of_global_set(int(0),'NAT'))). |
| 2424 | | :- assert_must_fail(( kernel_objects:element_of_global_set(int(0),'NAT1'))). |
| 2425 | | :- assert_must_succeed(( kernel_objects:element_of_global_set(X,'NAT'),X=int(1))). |
| 2426 | | :- assert_must_succeed(( kernel_objects:element_of_global_set(X,'NATURAL'),X=int(1))). |
| 2427 | | |
| 2428 | | element_of_global_set(X,GS) :- |
| 2429 | | init_wait_flags(WF),element_of_global_set_wf(X,GS,WF),ground_wait_flags(WF). |
| 2430 | | |
| 2431 | | element_of_global_set_wf(El,Set,WF) :- element_of_global_set_wf(El,Set,WF,unknown). |
| 2432 | | |
| 2433 | | :- use_module(kernel_reals,[is_real/1, is_float_wf/2, is_not_float/1]). |
| 2434 | | :- block element_of_global_set_wf(?,-,?,?). |
| 2435 | ? | element_of_global_set_wf(El,Set,WF,_) :- b_global_set(Set),!, |
| 2436 | | global_type_wf(El,Set,WF). |
| 2437 | | element_of_global_set_wf(X,'STRING',_WF,_) :- !, X=string(_). |
| 2438 | | element_of_global_set_wf(X,'REAL',_WF,_) :- !, is_real(X). |
| 2439 | | element_of_global_set_wf(X,'FLOAT',WF,_) :- !, is_float_wf(X,WF). |
| 2440 | | element_of_global_set_wf(int(X),GS,WF,Span) :- |
| 2441 | | element_of_global_integer_set_wf(GS,X,WF,Span). |
| 2442 | | |
| 2443 | | /* what about BOOL ?? */ |
| 2444 | | element_of_global_integer_set_wf('NAT',X,WF,_) :- |
| 2445 | | preferences:get_preference(maxint,MAXINT), |
| 2446 | | in_nat_range_wf(int(X),int(0),int(MAXINT),WF). |
| 2447 | | element_of_global_integer_set_wf('NATURAL',X,WF,Span) :- |
| 2448 | | (ground(X) -> X>=0 |
| 2449 | | ; is_natural(int(X),WF), |
| 2450 | | %get_last_wait_flag(element_of_global_set(int(X),'NATURAL'),WF,LWF), |
| 2451 | | get_integer_enumeration_wait_flag(X,'NATURAL',WF,LWF), |
| 2452 | | enumerate_natural(X,0,LWF,Span,WF) |
| 2453 | | ). |
| 2454 | | element_of_global_integer_set_wf('NAT1',X,WF,_) :- |
| 2455 | | preferences:get_preference(maxint,MAXINT), |
| 2456 | | in_nat_range_wf(int(X),int(1),int(MAXINT),WF). |
| 2457 | | element_of_global_integer_set_wf('NATURAL1',X,WF,Span) :- |
| 2458 | | (ground(X) -> X>=1 |
| 2459 | | ; is_natural1(int(X),WF), |
| 2460 | | %get_last_wait_flag(element_of_global_set_wf(int(X),'NATURAL1'),WF,LWF), |
| 2461 | | get_integer_enumeration_wait_flag(X,'NATURAL1',WF,LWF), |
| 2462 | | enumerate_natural(X,1,LWF,Span,WF) |
| 2463 | | ). |
| 2464 | | element_of_global_integer_set_wf('INT',X,WF,_) :- |
| 2465 | | preferences:get_preference(minint,MININT), |
| 2466 | | preferences:get_preference(maxint,MAXINT), |
| 2467 | | in_nat_range_wf(int(X),int(MININT),int(MAXINT),WF). |
| 2468 | | element_of_global_integer_set_wf('INTEGER',X,WF,Span) :- |
| 2469 | | (ground(X) -> true |
| 2470 | | ; get_integer_enumeration_wait_flag(X,'INTEGER',WF,LWF), |
| 2471 | | enumerate_int_wf(X,LWF,'INTEGER',WF,Span) |
| 2472 | | ). |
| 2473 | | |
| 2474 | | |
| 2475 | | get_integer_enumeration_wait_flag(X,SET,WF,LWF) :- |
| 2476 | | clpfd_domain(X,FDLow,FDUp), finite_domain(FDLow,FDUp),!, |
| 2477 | | Size is 1+FDUp-FDLow, |
| 2478 | | get_wait_flag(Size,element_of_global_set_wf(int(X),SET),WF,LWF). |
| 2479 | | get_integer_enumeration_wait_flag(X,SET,WF,LWF) :- |
| 2480 | | get_integer_enumeration_wait_flag(element_of_global_set_wf(int(X),SET),WF,LWF). |
| 2481 | | % important for e.g., solving r = /*@symbolic*/ {u|#x.(x : NATURAL & u : {x |-> x * x,x |-> x + x})} & 10|->20 : r |
| 2482 | | % 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 |
| 2483 | | |
| 2484 | | :- assert_must_succeed((kernel_objects:enumerate_int_wf(X,4,self_check,no_wf_available,unknown),X==2)). |
| 2485 | | :- block enumerate_int_wf(-,-,?,?,?). |
| 2486 | | enumerate_int_wf(X,_LWF,Source,WF,Span) :- |
| 2487 | | (ground(X) -> true |
| 2488 | | ; add_call_stack_to_span(Span,WF,Span2), % TODO: necessary? |
| 2489 | | enumerate_int_with_span(X,trigger_true(Source),Span2,WF)). |
| 2490 | | |
| 2491 | | :- assert_must_succeed(not_element_of_global_set(int(-1),'NAT')). |
| 2492 | | :- assert_must_succeed(not_element_of_global_set(int(-1),'NATURAL')). |
| 2493 | | :- assert_must_succeed(not_element_of_global_set(int(0),'NAT1')). |
| 2494 | | :- assert_must_succeed(not_element_of_global_set(int(0),'NATURAL1')). |
| 2495 | | not_element_of_global_set(_,GS) :- is_maximal_global_set(GS),!, fail. % covers REAL, STRING, INTEGER |
| 2496 | | not_element_of_global_set(X,'FLOAT') :- !, is_not_float(X). |
| 2497 | | not_element_of_global_set(int(X),GS) :- |
| 2498 | | (var(GS) -> add_error(kernel_objects,var_not_element_of_global_set,(int(X),GS)) ; true), |
| 2499 | | not_element_of_global_set2(GS,X). |
| 2500 | | not_element_of_global_set2('NAT',X) :- |
| 2501 | | preferences:get_preference(maxint,MAXINT), |
| 2502 | | clpfd_not_in_non_empty_range(X,0,MAXINT). %when(nonvar(X), (X<0 ; X>MAXINT)). |
| 2503 | | not_element_of_global_set2('NATURAL',X) :- is_not_natural(int(X)). |
| 2504 | | not_element_of_global_set2('NAT1',X) :- |
| 2505 | | preferences:get_preference(maxint,MAXINT), |
| 2506 | | clpfd_not_in_non_empty_range(X,1,MAXINT). %when(nonvar(X),(X<1 ; X>MAXINT)). |
| 2507 | | not_element_of_global_set2('NATURAL1',X) :- is_not_natural1(int(X)). |
| 2508 | | not_element_of_global_set2('INT',X) :- |
| 2509 | | preferences:get_preference(minint,MININT), |
| 2510 | | preferences:get_preference(maxint,MAXINT), |
| 2511 | | clpfd_not_in_non_empty_range(X,MININT,MAXINT). %when(nonvar(X), (X < MININT ; X > MAXINT)). |
| 2512 | | %not_element_of_global_set(string(_X),'STRING') :- fail. |
| 2513 | | %not_element_of_global_set(int(_X),'INTEGER') :- fail. |
| 2514 | | %not_element_of_global_set(_El,Set) :- b_global_set(Set), fail. |
| 2515 | | |
| 2516 | | |
| 2517 | | |
| 2518 | | /* ---- */ |
| 2519 | | /* SETS */ |
| 2520 | | /* ---- */ |
| 2521 | | |
| 2522 | | %:- block is_a_set(-). |
| 2523 | | %is_a_set(X) :- is_a_set2(X). |
| 2524 | | %is_a_set2([]) :- !. |
| 2525 | | %is_a_set2([_|_]) :- !. |
| 2526 | | %is_a_set2(X) :- is_custom_explicit_set(X,is_a_set2). |
| 2527 | | |
| 2528 | | |
| 2529 | | |
| 2530 | | |
| 2531 | | :- assert_must_succeed(exhaustive_kernel_fail_check(empty_set([int(4),int(3)]))). |
| 2532 | | :- assert_must_fail((empty_set([int(2),int(1)]))). |
| 2533 | | :- assert_must_fail((empty_set([int(1)]))). |
| 2534 | | :- assert_must_fail((empty_set([[]]))). |
| 2535 | | :- assert_must_fail((empty_set(global_set('Name')))). |
| 2536 | | :- assert_must_fail((empty_set(X),X=[int(1)])). |
| 2537 | | :- assert_must_succeed((empty_set([]))). |
| 2538 | | empty_set(X) :- (var(X) -> X=[] |
| 2539 | | ; X=[] -> true |
| 2540 | | % ; X=[_|_] -> fail |
| 2541 | | ; is_custom_explicit_set_nonvar(X),is_empty_explicit_set(X)). |
| 2542 | | empty_set_wf(X,WF) :- (var(X) -> X=[] |
| 2543 | | ; X=[] -> true |
| 2544 | | % ; X=[_|_] -> fail |
| 2545 | | ; is_custom_explicit_set_nonvar(X),is_empty_explicit_set_wf(X,WF)). |
| 2546 | | |
| 2547 | | |
| 2548 | | :- assert_must_succeed(exhaustive_kernel_check(not_empty_set([int(4),int(3)]))). |
| 2549 | | :- assert_must_succeed((kernel_objects:not_empty_set([int(2),int(1)]))). |
| 2550 | | :- assert_must_succeed((kernel_objects:not_empty_set([int(1)]))). |
| 2551 | | :- assert_must_succeed((kernel_objects:not_empty_set([[]]))). |
| 2552 | | :- assert_must_succeed((kernel_objects:not_empty_set(global_set('Name')))). |
| 2553 | | :- assert_must_succeed((kernel_objects:not_empty_set_lwf(X,1),nonvar(X),X=[_|_])). |
| 2554 | | :- assert_must_succeed((kernel_objects:not_empty_set_lwf([int(1)],_))). |
| 2555 | | :- assert_must_fail((kernel_objects:not_empty_set([]))). |
| 2556 | | |
| 2557 | | :- use_module(kernel_non_empty_attr,[mark_var_set_as_non_empty/1]). |
| 2558 | | |
| 2559 | | not_empty_set_wf(S,WF) :- WF==no_wf_available,!, not_empty_set2(S,WF). |
| 2560 | | not_empty_set_wf(S,WF) :- var(S), !, |
| 2561 | | (preferences:preference(use_smt_mode,true) -> S=[_|_] |
| 2562 | | % ; WF=no_wf_available -> not_empty_set(S) |
| 2563 | | ; get_large_finite_wait_flag(not_empty_set_wf,WF,LWF), |
| 2564 | | % print(not_empty(S)),nl, % TO DO: set kernel_cardinality attribute if variable |
| 2565 | | mark_var_set_as_non_empty(S), |
| 2566 | | not_empty_set_lwf(S,LWF)). |
| 2567 | | not_empty_set_wf(closure(P,T,B),WF) :- !, is_non_empty_explicit_set_wf(closure(P,T,B),WF). |
| 2568 | | not_empty_set_wf(S,WF) :- not_empty_set2(S,WF). |
| 2569 | | |
| 2570 | | :- block not_empty_set_lwf(-,-). |
| 2571 | | % the instantiation with a list skeleton can easily cause multiple solutions for the same |
| 2572 | | % set to be found: hence we guard it by a wait flag |
| 2573 | | not_empty_set_lwf(S,_LWF) :- var(S),!, |
| 2574 | | S=[_|_]. |
| 2575 | | not_empty_set_lwf(S,_) :- not_empty_set(S). |
| 2576 | | |
| 2577 | | not_empty_set(Set) :- not_empty_set2(Set,no_wf_available). |
| 2578 | | |
| 2579 | | :- use_module(error_manager,[add_warning/2]). |
| 2580 | | :- block not_empty_set2(-,?). |
| 2581 | | %not_empty_set(S) :- var(S),!,S=[_|_]. |
| 2582 | | % not_empty_set(X) :- not_equal_object([],X). |
| 2583 | | not_empty_set2([_|_],_). |
| 2584 | | not_empty_set2(avl_set(A),_) :- (A==empty -> add_warning(not_empty_set,'Empty avl_set'),fail ; true). |
| 2585 | | not_empty_set2(closure(P,T,B),WF) :- is_non_empty_explicit_set_wf(closure(P,T,B),WF). % TO DO: also use WF |
| 2586 | | not_empty_set2(global_set(Type),_) :- b_non_empty_global_set(Type). |
| 2587 | | not_empty_set2(freetype(ID),_) :- kernel_freetypes:is_non_empty_freetype(ID). |
| 2588 | | |
| 2589 | | % there also exists: eq_empty_set , a reified version, i.e., test_empty_set |
| 2590 | | |
| 2591 | | |
| 2592 | | :- assert_must_succeed((exact_element_of(int(1),[int(2),int(1)]))). |
| 2593 | | :- assert_must_succeed((exact_element_of(int(1),[int(2),int(3),int(4),int(1)]))). |
| 2594 | | :- assert_must_succeed((exact_element_of(int(4),[int(2),int(3),int(4),int(1)]))). |
| 2595 | | :- assert_must_succeed((exact_element_of(int(1),[int(2),int(3)|T]), T=[int(4),int(1)])). |
| 2596 | | :- assert_must_fail((exact_element_of(int(5),[int(2),int(3)|T]), T=[int(4),int(1)])). |
| 2597 | | :- assert_must_succeed((exact_element_of(fd(1,'Name'),global_set('Name')))). |
| 2598 | | :- assert_must_succeed((exact_element_of([int(2),int(1)],[[],[int(2),int(1)]]))). |
| 2599 | | :- assert_must_fail((exact_element_of([int(1),int(2)],[[],[int(2),int(1)]]))). |
| 2600 | | %:- assert_must_succeed((exact_element_of([(int(1),fd(2,'Name'))], |
| 2601 | | % closure([zzzz],[set(couple(integer,global('Name')))], 'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2602 | | % 'Seq'(value([fd(1,'Name'),fd(2,'Name')]))))) )). |
| 2603 | | %:- assert_must_succeed((exact_element_of(XX, |
| 2604 | | % closure([zzzz],[set(couple(integer,global('Name')))], 'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2605 | | % 'Seq'(value([fd(1,'Name'),fd(2,'Name')]))))), |
| 2606 | | % equal_object(XX,[(int(1),fd(1,'Name'))]) )). |
| 2607 | | %:- assert_must_succeed(( |
| 2608 | | %exact_element_of(XX,closure([zzzz],[set(couple(integer,global('Name')))], |
| 2609 | | % 'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2610 | | % 'Perm'(value([fd(1,'Name'),fd(2,'Name')]))))), |
| 2611 | | % equal_object(XX,[(int(1),fd(2,'Name')),(int(2),fd(1,'Name'))]) )). |
| 2612 | | |
| 2613 | | %:- assert_must_succeed(( exact_element_of(X, |
| 2614 | | % closure([zzzz],[set(record([field(balance,integer),field(name,global('Code'))]))], |
| 2615 | | % 'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2616 | | % 'PowerSet'(value(closure([zzzz], |
| 2617 | | % [record([field(balance,integer),field(name,global('Code'))])],'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2618 | | % 'SetOfRecords'(value(cons_expr(field(balance,global_set('NAT')), |
| 2619 | | % cons_expr(field(name,global_set('Code')),nil_expr))))))))))), |
| 2620 | | % X=[rec([field(balance,int(0)),field(name,fd(2,'Code'))])] )). |
| 2621 | | %:- assert_must_fail(( exact_element_of(X, |
| 2622 | | % closure([zzzz],[set(record([field(balance,integer),field(name,global('Code'))]))], |
| 2623 | | % 'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2624 | | % 'PowerSet'(value(closure([zzzz], |
| 2625 | | % [record([field(balance,integer),field(name,global('Code'))])],'In'('ListExpression'(['Identifier'(zzzz)]), |
| 2626 | | % 'SetOfRecords'(value(cons_expr(field(balance,global_set('NAT')), |
| 2627 | | % cons_expr(field(name,global_set('Code')),nil_expr))))))))))), |
| 2628 | | % X=[rec([field(balance,int(-1)),field(name,fd(2,'Code'))])] )). |
| 2629 | | |
| 2630 | | |
| 2631 | | /* use this to compute elements */ |
| 2632 | | exact_element_of(X,Set) :- |
| 2633 | | dif(Set,[]), |
| 2634 | | exact_element_of2(Set,X). |
| 2635 | | :- block exact_element_of2(-,?). |
| 2636 | | exact_element_of2([H|_],H). |
| 2637 | | exact_element_of2([_|T],E) :- exact_element_of3(T,E). |
| 2638 | | exact_element_of2(X,E) :- is_custom_explicit_set_nonvar(X), check_element_of(E,X). |
| 2639 | | :- block exact_element_of3(-,?). |
| 2640 | | exact_element_of3([H|_],H). |
| 2641 | | exact_element_of3([_|T],E) :- exact_element_of3(T,E). |
| 2642 | | |
| 2643 | | |
| 2644 | | :- assert_must_succeed(exhaustive_kernel_check(check_element_of(int(1),[int(2),int(1)]))). |
| 2645 | | :- assert_must_succeed(exhaustive_kernel_fail_check(check_element_of(int(3),[int(2),int(1)]))). |
| 2646 | | :- assert_must_succeed(exhaustive_kernel_fail_check(check_element_of(int(1),[]))). |
| 2647 | | |
| 2648 | | /* uses equal_object instead of unification */ |
| 2649 | | :- assert_must_succeed((check_element_of(X, |
| 2650 | | [(int(1),(int(1),(int(1),int(1)))),(int(2),(int(1),(int(1),int(1)))), |
| 2651 | | (int(1),(int(1),(int(1),int(2)))),(int(2),(int(1),(int(1),int(2))))]), |
| 2652 | | equal_object(X, (int(2),(int(1),(int(1),int(2))))) )). |
| 2653 | | :- assert_must_succeed((check_element_of(X, |
| 2654 | | [ (((int(1),int(1)),int(1)),int(1)), (((int(1),int(1)),int(1)),int(2)), |
| 2655 | | (((int(1),int(1)),int(1)),int(3)), (((int(1),int(1)),int(1)),int(4)), |
| 2656 | | (((int(1),int(1)),int(2)),int(1)), (((int(1),int(1)),int(2)),int(2)) |
| 2657 | | ]), equal_object(X, (((int(1),int(1)),int(2)),int(1))) |
| 2658 | | )). |
| 2659 | | :- assert_must_succeed((check_element_of(fd(1,'Name'),global_set('Name')))). |
| 2660 | | %:- assert_must_succeed_multiple(check_element_of(X,[[fd(1,'Name')],[]])). |
| 2661 | | :- assert_must_succeed((check_element_of((int(1),int(2)),[(int(1),int(2))]))). |
| 2662 | | :- assert_must_succeed((check_element_of((_X,_Y),[(fd(2,'Code'),fd(2,'Code'))]))). |
| 2663 | | :- assert_must_succeed((init_wait_flags(WF), |
| 2664 | | check_element_of_wf((X,Y),[(fd(2,'Code'),fd(2,'Code'))],WF), |
| 2665 | | ground_det_wait_flag(WF), X= fd(2,'Code'), Y= fd(2,'Code'), |
| 2666 | | kernel_waitflags:ground_wait_flags(WF) )). |
| 2667 | | :- assert_must_succeed((init_wait_flags(WF), |
| 2668 | | check_element_of_wf((Y,X),[(fd(2,'Code'),fd(2,'Code'))],WF), |
| 2669 | | ground_det_wait_flag(WF), X= fd(2,'Code'), Y= fd(2,'Code'), |
| 2670 | | kernel_waitflags:ground_wait_flags(WF) )). |
| 2671 | | :- assert_must_succeed((check_element_of([int(1),int(2)],[[int(2),int(1)]]))). |
| 2672 | | |
| 2673 | | :- assert_must_succeed((check_element_of([int(1),int(2)],[[],[int(2),int(1)]]))). |
| 2674 | | :- assert_must_succeed((check_element_of(X,[[],[int(2),int(1)]]), X==[] )). |
| 2675 | | :- assert_must_succeed((check_element_of_wf(X,[[],[int(2),int(1)]],_WF), |
| 2676 | | equal_object(X,[int(1),int(2)]) )). |
| 2677 | | :- assert_must_succeed((check_element_of_wf(XX,global_set('Name'),WF),kernel_waitflags:ground_wait_flags(WF), XX==fd(3,'Name') )). |
| 2678 | | :- assert_must_fail(check_element_of([fd(2,'Name')],[[fd(1,'Name')],[]])). |
| 2679 | | :- assert_must_fail((check_element_of([int(2)],[[],[int(2),int(1)]]))). |
| 2680 | | :- assert_must_succeed((check_element_of(int(1),_X))). |
| 2681 | | :- assert_must_succeed((check_element_of((int(2),_X),[(int(1),[(int(1),int(22))]),(int(2),[(int(1),int(55))])]))). |
| 2682 | | |
| 2683 | | check_element_of(X,Set) :- init_wait_flags(WF,[check_element_of]), |
| 2684 | | check_element_of_wf(X,Set,WF), |
| 2685 | | ground_wait_flags(WF). |
| 2686 | | |
| 2687 | | % new test: check_element_of(int(1),X). |
| 2688 | | % new test: check_element_of(int(1),[int(2)|X]). |
| 2689 | | |
| 2690 | | check_element_of_wf(X,Set,WF) :- %print(el_of(X,Set)),nl, |
| 2691 | | dif(Set,[]), |
| 2692 | | % TO do: mark Set as non-empty not_empty_set_wf from kernel_cardinality_attr |
| 2693 | ? | check_element_of1(X,Set,WF). |
| 2694 | | |
| 2695 | | %check_element_of1(X,Set,WF) :- var(X),var(Set),unbound_variable_check(Set),!, |
| 2696 | | % Set=[_|_], check_element_of2(Set,X,WF). |
| 2697 | | %:- block check_element_of1(-,-,?). %% |
| 2698 | | |
| 2699 | | |
| 2700 | | %:- 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 |
| 2701 | | check_element_of1(X,Set,WF) :- |
| 2702 | | (unbound_variable_for_element_of(Set), |
| 2703 | | preference(data_validation_mode,false) % TODO: this leads to failure of test 1976 with CLPFD FALSE |
| 2704 | | % but avoids instantiating Sets to lists early on: can disturb enumeration and efficient computation/unification of large sets |
| 2705 | ? | -> check_element_of_unbound_set(X,Set,WF) |
| 2706 | ? | ; check_element_of2(Set,X,WF) |
| 2707 | | ). |
| 2708 | | |
| 2709 | | check_element_of_unbound_set(X,Set,_WF) :- |
| 2710 | | mark_as_non_free(X,check_element_of_unbound_set), |
| 2711 | | Set=[X|_]. % Note: X needs to be nonvar so that other code knows X is not free anymore |
| 2712 | | % TO DO: normalise X ? |
| 2713 | | % TO DO: do this using CHR/attributes rather than by instantiation |
| 2714 | | |
| 2715 | | |
| 2716 | | unbound_variable_for_element_of(Set) :- unbound_variable_for_cons(Set). |
| 2717 | | |
| 2718 | | % attach co-routine to mark a given term as not a real variable |
| 2719 | | mark_as_non_free(X,_Info) :- var(X) -> non_free(X) ; true. |
| 2720 | | mark_as_non_free(X) :- var(X) -> non_free(X) ; true. |
| 2721 | | :- block non_free(-). |
| 2722 | | non_free([H|T]) :- !, mark_as_non_free(H), mark_as_non_free(T). |
| 2723 | | non_free((A,B)) :- !, mark_as_non_free(A), mark_as_non_free(B). |
| 2724 | | non_free(rec(Fields)) :- !, mark_as_non_free_fields(Fields). |
| 2725 | | non_free(_). |
| 2726 | | :- block mark_as_non_free_fields(-). |
| 2727 | | mark_as_non_free_fields([]). |
| 2728 | | mark_as_non_free_fields([field(_,Val)|T]) :- mark_as_non_free(Val),mark_as_non_free_fields(T). |
| 2729 | | |
| 2730 | | :- use_module(clpfd_lists,[lazy_fd_value_check/4]). |
| 2731 | | |
| 2732 | | :- block check_element_of2(-,?,?). |
| 2733 | | check_element_of2(CS,El,WF) :- |
| 2734 | ? | is_custom_explicit_set_nonvar(CS),!, element_of_custom_set_wf(El,CS,WF). |
| 2735 | | check_element_of2([],_,_) :- !,fail. |
| 2736 | | %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, |
| 2737 | | % element_of_custom_set_wf(El,AVL,WF). |
| 2738 | | check_element_of2([H|T],E,WF) :- !, % print(check_element_of4w(E,H,T,WF)),nl, |
| 2739 | | % try and transform E : Set into clpfd:element(_,FDVals,EFD) check: |
| 2740 | ? | lazy_fd_value_check([H|T],E,WF,FullyChecked), |
| 2741 | | %get_partial_set_priority([H|T],WF,LWF), %% |
| 2742 | | %get_wait_flag(2,check_element_of2([H|T],E),WF,LWF), %% |
| 2743 | | (FullyChecked==true,ground(E) -> true % no need to check |
| 2744 | | ; get_cardinality_wait_flag([H|T],check_element_of2,WF,LWF), |
| 2745 | ? | 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) |
| 2746 | | ). |
| 2747 | | check_element_of2(freetype(Id),E,WF) :- !, is_a_freetype_wf(E,Id,WF). |
| 2748 | | check_element_of2(term(Z),_E,_WF) :- Z==undefined,!, |
| 2749 | | add_error_fail(check_element_of2,'Encountered uninitialised set variable', ''). |
| 2750 | | check_element_of2(Set,E,WF) :- |
| 2751 | | add_internal_error('Illegal argument: ',check_element_of2(Set,E,WF)),fail. |
| 2752 | | |
| 2753 | | |
| 2754 | | % call if you already have an explicit waitflag (LWF) setup for the cardinality of the set |
| 2755 | | :- block check_element_of_wf_lwf(?,-,?,?). |
| 2756 | | check_element_of_wf_lwf(El,CS,WF,_LWF) :- |
| 2757 | ? | is_custom_explicit_set_nonvar(CS),!, element_of_custom_set_wf(El,CS,WF). |
| 2758 | | check_element_of_wf_lwf(E,[H|T],WF,LWF) :- check_element_of4w(E,H,T,WF,LWF). |
| 2759 | | check_element_of_wf_lwf(E,freetype(Id),WF,_) :- !, is_a_freetype_wf(E,Id,WF). |
| 2760 | | |
| 2761 | | :- block check_element_of4w(-,?,-,?,-). |
| 2762 | | % check_element_of4w(E,H,T,_WF,_LWF) :- print(check_element_of4w(E,H,T,_WF,_LWF)),nl,fail. |
| 2763 | | check_element_of4w(E,H,T,_WF,_LWF) :- T==[],!,equal_object(E,H,check_element_of4w). |
| 2764 | | check_element_of4w(E,H,_T,_WF,_LWF) :- E==H ,!. %,print(eq(E,H)),nl. % added by mal, 17.10 2007 |
| 2765 | | check_element_of4w(E,H,T,WF,LWF) :- T\==[], |
| 2766 | ? | equality_objects_lwf(E,H,Res,LWF,WF), |
| 2767 | ? | check_element_of4(Res,E,T,WF,LWF). |
| 2768 | | |
| 2769 | | :- block check_element_of4(-,?,?,?,-). |
| 2770 | | check_element_of4(pred_true,_E,_,_WF,_LWF). |
| 2771 | | check_element_of4(pred_false,E,T,WF,LWF) :- |
| 2772 | ? | (var(T) -> T = [E|_] ; check_element_of5(E,T,WF,LWF)). |
| 2773 | | |
| 2774 | | :- block check_element_of5(?,-,?,?). |
| 2775 | | check_element_of5(E,R,WF,LWF) :- |
| 2776 | | get_next_element(R,H,T), |
| 2777 | ? | check_element_of4w(E,H,T,WF,LWF). |
| 2778 | | |
| 2779 | | |
| 2780 | | |
| 2781 | | :- assert_must_succeed(exhaustive_kernel_check(not_element_of(int(3),[int(2),int(1)]))). |
| 2782 | | :- assert_must_succeed(exhaustive_kernel_check(not_element_of(int(3),[int(2),int(1),int(4)]))). |
| 2783 | | :- assert_must_succeed(exhaustive_kernel_fail_check(not_element_of(int(1),[int(2),int(1)]))). |
| 2784 | | :- assert_must_succeed((kernel_objects:not_element_of(int(3),[int(2),int(1)]))). |
| 2785 | | :- assert_must_succeed((kernel_objects:not_element_of(fd(1,'Name'),[]))). |
| 2786 | | :- assert_must_fail((kernel_objects:not_element_of(fd(1,'Name'),global_set('Name')))). |
| 2787 | | :- assert_must_succeed((kernel_objects:not_element_of(X,[fd(1,'Name')]),X = fd(2,'Name'))). |
| 2788 | | :- assert_must_fail((kernel_objects:not_element_of(X,[fd(1,'Name')]),X = fd(1,'Name'))). |
| 2789 | | :- assert_must_succeed(kernel_objects:not_element_of(term(a),[])). |
| 2790 | | :- assert_must_fail((kernel_objects:not_element_of(int(1),[int(2),int(1)]))). |
| 2791 | | :- assert_must_succeed((kernel_objects:not_element_of([int(1),int(2)], |
| 2792 | | [[int(1)],[int(0),int(4)],[int(0),int(3)],[int(0),int(1)],[int(0)],[]]))). |
| 2793 | | :- assert_must_fail((kernel_objects:not_element_of(term(3),[int(2),int(1)]))). |
| 2794 | | |
| 2795 | | |
| 2796 | | not_element_of(X,Set) :- init_wait_flags(WF,[not_element_of]), |
| 2797 | ? | not_element_of_wf(X,Set,WF), |
| 2798 | ? | ground_wait_flags(WF). |
| 2799 | | |
| 2800 | | :- use_module(b_global_sets,[b_get_fd_type_bounds/3]). |
| 2801 | | :- block not_element_of_wf(-,-,?). |
| 2802 | | not_element_of_wf(_,Set,_) :- Set==[],!. |
| 2803 | | not_element_of_wf(El,Set,WF) :- nonvar(El),El=fd(X,GS),b_get_fd_type_bounds(GS,N,N),!, |
| 2804 | | % we have a global set with a single element; Set must be empty |
| 2805 | | X=N,empty_set_wf(Set,WF). |
| 2806 | ? | not_element_of_wf(El,Set,WF) :- not_element_of_wf1(Set,El,WF). |
| 2807 | | |
| 2808 | | :- block not_element_of_wf1(-,?,?). |
| 2809 | | not_element_of_wf1(X,E,WF) :- is_custom_explicit_set_nonvar(X),!, |
| 2810 | ? | not_element_of_custom_set_wf(E,X,WF). |
| 2811 | | not_element_of_wf1([],_E,_WF). |
| 2812 | | not_element_of_wf1([H|T],E,WF) :- |
| 2813 | ? | not_equal_object_wf(E,H,WF), |
| 2814 | ? | not_element_of_wf1(T,E,WF). |
| 2815 | | |
| 2816 | | |
| 2817 | | :- assert_must_succeed(exhaustive_kernel_check(add_element(int(3),[int(2),int(1)],[int(1),int(3),int(2)]))). |
| 2818 | | :- assert_must_succeed(exhaustive_kernel_fail_check(add_element(int(2),[int(2),int(1)],[int(1),int(3),int(2)]))). |
| 2819 | | :- assert_must_succeed(exhaustive_kernel_fail_check(add_element(int(4),[int(2),int(1)],[int(1),int(3),int(2)]))). |
| 2820 | | :- assert_must_succeed((kernel_objects:add_element(int(3),[int(2),int(1)],R), |
| 2821 | | kernel_objects:equal_object(R,[int(1),int(2),int(3)]))). |
| 2822 | | :- assert_must_succeed((kernel_objects:add_element([int(2)],[[int(2),int(1)],[]],R), |
| 2823 | | kernel_objects:equal_object(R,[[],[int(1),int(2)],[int(2)]]))). |
| 2824 | | :- assert_must_succeed((kernel_objects:add_element([int(1),int(2)],[[int(2),int(1)],[]],R), |
| 2825 | | kernel_objects:equal_object(R,[[],[int(1),int(2)]]))). |
| 2826 | | :- assert_must_succeed((kernel_objects:add_element(X,[int(2),int(1)],R), |
| 2827 | | kernel_objects:equal_object(R,[int(1),int(2)]), X = int(1))). |
| 2828 | | :- assert_must_succeed((kernel_objects:add_element([int(1),int(2)], |
| 2829 | | [[int(1)],[int(0),int(4)],[int(0),int(3)],[int(0),int(1)],[int(0)],[]], _R))). |
| 2830 | | |
| 2831 | | :- assert_must_succeed((kernel_objects:add_element(int(3),[int(X),int(1)],R,D), |
| 2832 | | var(D), X=3, R==[int(3),int(1)], D==done)). |
| 2833 | | |
| 2834 | | :- assert_must_fail((kernel_objects:add_element(term(msg),[int(2),int(1)],_R))). |
| 2835 | | :- assert_must_succeed((kernel_objects:add_element(int(3),[int(2),int(X)],R), |
| 2836 | | nonvar(R), R =[H|T], H==int(2), nonvar(T),T=[_HH|TT],var(TT), |
| 2837 | | X=4, T==[int(4),int(3)])). |
| 2838 | | :- assert_must_succeed((kernel_objects:add_element(int(3),[int(2),int(X)],R), |
| 2839 | | nonvar(R), R =[H|T], H==int(2), nonvar(T),T=[_HH|TT],var(TT), |
| 2840 | | X=3, T==[int(3)])). |
| 2841 | | :- assert_must_succeed((kernel_objects:add_element(int(3),X,[int(2),int(3)]), |
| 2842 | | kernel_objects:equal_object(X,[int(2)]) )). |
| 2843 | | :- assert_must_succeed((kernel_objects:add_element(int(3),X,[int(3)]), |
| 2844 | | kernel_objects:equal_object(X,[]) )). |
| 2845 | | :- assert_must_succeed((add_element(X,[int(1)],[int(1)]),X==int(1))). |
| 2846 | | :- assert_must_succeed((add_element(X,[],[int(1)]),X==int(1))). |
| 2847 | | % kernel_objects:add_element(E,[H],R,Done), H = int(X), E=int(Y), X in 1..10, Y in 11..20. |
| 2848 | | |
| 2849 | | |
| 2850 | | add_element(E,Set,NewSet) :- add_element(E,Set,NewSet,_). |
| 2851 | | add_element(Element,Set,NewSet,Done) :- add_element_wf(Element,Set,NewSet,Done,no_wf_available). |
| 2852 | | add_element_wf(E,Set,NewSet,WF) :- add_element_wf(E,Set,NewSet,_,WF). |
| 2853 | | |
| 2854 | | :- block add_element_wf(?,-,?,?,?). |
| 2855 | | add_element_wf(Element,Set,NewSet,Done,_WF) :- Set==[],!, |
| 2856 | | % try and convert to AVL if possible: |
| 2857 | | equal_object_optimized(NewSet,[Element]), % we could call equal_object_opt3 directly |
| 2858 | | Done=done. |
| 2859 | | add_element_wf(E,Set,NewSet,Done,WF) :- add_element1_wf(E,Set,NewSet,Done,WF). |
| 2860 | | |
| 2861 | | :- block %add_element1(-,?,-,?), |
| 2862 | | add_element1_wf(?,-,?,?,?). |
| 2863 | | add_element1_wf(E,Set,NewSet,Done,WF) :- var(E),!, add_element_var(Set,NewSet,E,Done,WF). |
| 2864 | | add_element1_wf(E,[H|T],NewSet,Done,WF) :- E==H,!, % avoid running [H|T] through expand_custom_set_to_list, in case T is a variable this will create a pending co-routine |
| 2865 | | equal_object_wf(NewSet,[H|T],add_element1_1,WF),Done=done. |
| 2866 | | add_element1_wf(E,Set,NewSet,Done,WF) :- |
| 2867 | | nonvar(Set), is_custom_explicit_set_nonvar(Set), |
| 2868 | | add_element_to_explicit_set_wf(Set,E,R,WF),!, |
| 2869 | | equal_object_wf(R,NewSet,add_element1_2,WF),Done=done. |
| 2870 | | add_element1_wf(E,Set,NewSet,Done,WF) :- |
| 2871 | | expand_custom_set_to_list_wf(Set,ESet,_,add_element1,WF), % we could avoid this expansion by treating avl_set,... below in add_element3 |
| 2872 | | add_element2_wf(ESet,E,NewSet,Done,WF). |
| 2873 | | |
| 2874 | | |
| 2875 | | add_element_var([],Res,Element,Done,WF) :- !, |
| 2876 | | equal_cons_wf(Res,Element,[],WF),Done=done. |
| 2877 | | add_element_var(Set,Res,Element,Done,WF) :- Set \= [], Set \= closure(_,_,_), |
| 2878 | | is_one_element_set(Res,ResEl), !, |
| 2879 | | % the result is a one element set; hence Element *must* be the element in that set |
| 2880 | | equal_object_wf(Element,ResEl,add_element_var_1,WF), |
| 2881 | | equal_object_wf(Set,Res,add_element_var_2,WF), Done=done. |
| 2882 | | add_element_var(Set,Res,Element,Done,WF) :- %when(nonvar(Element), add_element(Element,Set,Res,Done)). |
| 2883 | | expand_custom_set_to_list_wf(Set,ESet,_,add_element_var,WF), |
| 2884 | | add_element2_wf(ESet,Element,Res,Done,WF). |
| 2885 | | |
| 2886 | | is_one_element_set(S,_) :- var(S),!,fail. |
| 2887 | | is_one_element_set([H|T],H) :- T==[]. |
| 2888 | | is_one_element_set(avl_set(S),El) :- is_one_element_custom_set(avl_set(S),El). |
| 2889 | | |
| 2890 | | :- block add_element2_wf(-,?,?,?,?). |
| 2891 | | add_element2_wf([],E,Res,Done,WF) :- var(Res),should_be_converted_to_avl(E), |
| 2892 | | construct_avl_from_lists_wf([E],R,WF),!, |
| 2893 | | (R,Done)=(Res,done). |
| 2894 | | add_element2_wf(S,E,Res,Done,WF) :- copy_list_skeleton(S,Res,WF), |
| 2895 | ? | add_element3_wf(S,E,Res,Done,WF). |
| 2896 | | |
| 2897 | | % TO DO: use something else, like subset to propagate info that Set1 <: Set1 \/ {New} |
| 2898 | | :- block copy_list_skeleton(-,?,?). |
| 2899 | | copy_list_skeleton([],_,_WF) :- !. |
| 2900 | | 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 |
| 2901 | | ((ground_value(H) ; unbound_variable_for_cons(R) ; |
| 2902 | | custom_explicit_sets:singleton_set(R,_) % if R is a singleton set {EL} then H must be EL and T=[] |
| 2903 | | ) |
| 2904 | | -> equal_cons_wf(R,H,RR,WF), |
| 2905 | | copy_list_skeleton(T,RR,WF) |
| 2906 | | ; %nl,print(not_copying([H|T],R)),nl, |
| 2907 | | 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 |
| 2908 | | ). |
| 2909 | | copy_list_skeleton(Set,R,WF) :- !,is_custom_explicit_set(Set,copy_list_skeleton), |
| 2910 | | expand_custom_set_to_list_wf(Set,ESet,_,copy_list_skeleton,WF), copy_list_skeleton(ESet,R,WF). |
| 2911 | | copy_list_skeleton(Skel,R,WF) :- add_internal_error('Argument not a set: ',copy_list_skeleton(Skel,R,WF)). |
| 2912 | | |
| 2913 | | :- block add_element3_wf(-,?,?,?,?). |
| 2914 | | add_element3_wf([],E,Res,Done,WF) :- % Res must be {E} |
| 2915 | ? | equal_cons_wf(Res,E,[],WF), |
| 2916 | | Done=done. |
| 2917 | | add_element3_wf([H|T],E,Res,Done,WF) :- |
| 2918 | | equality_objects_wf(H,E,EqRes,WF), |
| 2919 | | equal_cons_wf(Res,H,TailRes,WF), % was: equal_object([H|TailRes],Res), % use WF? |
| 2920 | | (var(EqRes) |
| 2921 | ? | -> has_not_to_be_added([H|T],Res,EqRes,0) |
| 2922 | | ; true), |
| 2923 | | %(when(nonvar(EqRes),(print(nv(EqRes,H,T,WF)),nl))), |
| 2924 | ? | add_element4_wf(EqRes,T,E,TailRes,Done,WF). |
| 2925 | | |
| 2926 | | |
| 2927 | | % check if an element has not to be added to arg1 to obtain arg2 |
| 2928 | | :- block has_not_to_be_added(?,-,?,?),has_not_to_be_added(-,?,?,?). |
| 2929 | | %has_not_to_be_added(A,B,R,Sz) :- print(has_not_to_be_added(A,B,R,Sz)),nl,fail. |
| 2930 | | has_not_to_be_added([],[],R,Sz) :- !,(Sz=1 -> R=pred_true % we have 1 element: force equality with first element |
| 2931 | | ; true). |
| 2932 | | has_not_to_be_added([],[_H|T],R,_Sz) :- !, %(var(R) -> print(add_f([],[_H|T],R,_Sz)),nl ; true), |
| 2933 | | empty_set(T),R=pred_false. % R=pred_false means with add an element |
| 2934 | | has_not_to_be_added([_|_],[],_,_) :- !,fail. % we can either add or not; in both cases we do not obtain [] |
| 2935 | ? | has_not_to_be_added([_|T1],[_|T2],R,Sz) :- !, S1 is Sz+1, has_not_to_be_added(T1,T2,R,S1). |
| 2936 | | has_not_to_be_added(_,_,_,_). % to do: support custom explicit sets |
| 2937 | | |
| 2938 | | :- block add_element4_wf(-,?,?,?,?,?). |
| 2939 | ? | add_element4_wf(pred_true, T,_E,TRes,Done,WF) :- equal_object_wf(T,TRes,add_element4_wf,WF), Done=done. |
| 2940 | ? | add_element4_wf(pred_false,T, E,TRes,Done,WF) :- add_element3_wf(T,E,TRes,Done,WF). |
| 2941 | | |
| 2942 | | |
| 2943 | | :- assert_must_succeed((kernel_objects:add_new_element(int(3),[int(2),int(1)],R), |
| 2944 | | kernel_objects:equal_object(R,[int(1),int(2),int(3)]))). |
| 2945 | | :- assert_must_succeed((kernel_objects:add_new_element([int(2)],[[int(2),int(1)],[]],R), |
| 2946 | | kernel_objects:equal_object(R,[[],[int(1),int(2)],[int(2)]]))). |
| 2947 | | |
| 2948 | | % TO DO : get rid of need for non-WF version in enumeration basic type: |
| 2949 | | add_new_element(E,Set,NewSet) :- init_wait_flags(WF), |
| 2950 | | add_new_element_wf(E,Set,NewSet,WF), ground_wait_flags(WF). |
| 2951 | | |
| 2952 | | % use when you are sure the element to add is not in the set |
| 2953 | | % to be used for adding elements to an accumulator |
| 2954 | | :- block add_new_element_wf(?,-,?,?). |
| 2955 | | %%add_new_element(E,Set,NewSet) :- add_element(E,Set,NewSet). % TO DO : Improve |
| 2956 | | add_new_element_wf(E,Set,NewSet,WF) :- |
| 2957 | | is_custom_explicit_set(Set,add_element), |
| 2958 | | add_element_to_explicit_set_wf(Set,E,R,WF),!, |
| 2959 | | equal_object_wf(R,NewSet,add_new_element_wf,WF). |
| 2960 | | add_new_element_wf(E,Set,NewSet,WF) :- |
| 2961 | | expand_custom_set_to_list_wf(Set,ESet,_,add_new_element_wf,WF), |
| 2962 | | add_new_element2(ESet,E,NewSet,WF). |
| 2963 | | |
| 2964 | | :- block add_new_element2(-,?,?,?). |
| 2965 | | add_new_element2([],E,Res,WF) :- var(Res),should_be_converted_to_avl(E), |
| 2966 | | construct_avl_from_lists_wf([E],R,WF),!,equal_object_wf(R,Res,add_new_element2,WF). |
| 2967 | | add_new_element2(S,E,Res,WF) :- equal_cons_wf(Res,E,S,WF). |
| 2968 | | |
| 2969 | | |
| 2970 | | |
| 2971 | | |
| 2972 | | :- assert_must_succeed(exhaustive_kernel_check(remove_element_wf(int(3),[int(3),int(1)], |
| 2973 | | [int(1)],_WF))). |
| 2974 | | :- assert_must_succeed(exhaustive_kernel_check(remove_element_wf(int(1),[int(3),int(1)], |
| 2975 | | [int(3)],_WF))). |
| 2976 | | :- assert_must_succeed(exhaustive_kernel_fail_check(remove_element_wf(int(1),[int(3),int(1)], |
| 2977 | | [int(1)],_WF))). |
| 2978 | | :- assert_must_succeed(exhaustive_kernel_fail_check(remove_element_wf(int(11),[int(1)], |
| 2979 | | [int(1)],_WF))). |
| 2980 | | :- assert_must_succeed(exhaustive_kernel_fail_check(remove_element_wf(int(1),[int(3),int(1)], |
| 2981 | | [],_WF))). |
| 2982 | | :- assert_must_succeed((kernel_objects:remove_element_wf(fd(1,'Name'),X,[fd(2,'Name'),fd(3,'Name')],_WF), |
| 2983 | | kernel_objects:equal_object(X,global_set('Name')))). |
| 2984 | | :- assert_must_succeed((kernel_objects:remove_element_wf(int(1),X,[int(2)],_WF), |
| 2985 | | kernel_objects:equal_object(X,[int(2),int(1)]))). |
| 2986 | | :- 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)] )). |
| 2987 | | :- 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)] )). |
| 2988 | | :- 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 */] )). |
| 2989 | | |
| 2990 | ? | remove_element_wf(X,Set,Res,WF) :- remove_element_wf(X,Set,Res,WF,_DONE). |
| 2991 | | |
| 2992 | | :- block remove_element_wf(?,-, -,?,?). |
| 2993 | | remove_element_wf(X,Set,Res,WF,_DONE) :- Res==[],!, % we know that X must be the only element in Set |
| 2994 | | equal_object_wf(Set,[X],remove_element_wf,WF). |
| 2995 | | remove_element_wf(X,Set,Res,WF,DONE) :- |
| 2996 | ? | remove_element_wf1(X,Set,Res,WF,DONE). |
| 2997 | | |
| 2998 | | :- block remove_element_wf1(?,-, ?,?,?). |
| 2999 | | remove_element_wf1(X,avl_set(A),Res,WF,DONE) :- element_can_be_added_or_removed_to_avl(X),!, |
| 3000 | | /* TO DO: try and move the check about whether X can be added to later; when either X is known |
| 3001 | | or LWF is instantiated */ |
| 3002 | | remove_element_from_explicit_set(avl_set(A),X,AR), |
| 3003 | | equal_object_wf(AR,Res,remove_element_wf1,WF), DONE=done. |
| 3004 | | remove_element_wf1(X,Set,Res,WF,DONE) :- /* DONE is ground when element actually removed */ |
| 3005 | | expand_custom_set_to_list_wf(Set,ESet,_,remove_element_wf1,WF), |
| 3006 | | %% nl,print(remove_element_wf1(X,Set,ESet,Res,WF,DONE)),nl,nl, %% |
| 3007 | ? | remove_element_wf2(X,ESet,Res,LWF,DONE), |
| 3008 | | %when(nonvar(DONE), print_bt_message(removed(X,ESet,Res,LWF))), |
| 3009 | | (DONE==done -> true |
| 3010 | | ; same_card_prop(ESet,[X|Res]), % in case result is instantiated: check compatible with inputs |
| 3011 | | get_cardinality_wait_flag(ESet,remove_element_wf1(X,ESet,Res),WF,LWF), |
| 3012 | ? | quick_propagation_element_information(Set,X,WF,_) % use Set rather than ESet; better if still closure or AVL |
| 3013 | | ). |
| 3014 | | |
| 3015 | | :- block same_card_prop(-,?), same_card_prop(?,-). |
| 3016 | | same_card_prop([],[_|_]) :- !, fail. |
| 3017 | | same_card_prop([_|T],R) :- !, |
| 3018 | | (R=[] -> fail |
| 3019 | | ; R=[_|RT] -> same_card_prop(T,RT) |
| 3020 | | ; true). % just ignore |
| 3021 | | same_card_prop(_,_). |
| 3022 | | |
| 3023 | | :- block remove_element_wf2(?,-,?,?,?). |
| 3024 | | remove_element_wf2(H1,[H2|T],Res,LWF,DONE) :- Res==[],!, |
| 3025 | | equal_object(H1,H2,remove_element_wf2), |
| 3026 | | remove_element_wf3(pred_true,H1,H2,T,Res,LWF,DONE). |
| 3027 | | remove_element_wf2(H1,[H2|T],Res,LWF,DONE) :- |
| 3028 | | prop_empty_set(T,EqRes), |
| 3029 | ? | equality_objects_lwf(H1,H2,EqRes,LWF,no_wf_available), % TODO: pass WF |
| 3030 | ? | remove_element_wf3(EqRes,H1,H2,T,Res,LWF,DONE). |
| 3031 | | /* important for total_bijection that this has higher priority than other expansions */ |
| 3032 | | |
| 3033 | | :- block prop_empty_set(-,?). |
| 3034 | | % force second argument to pred_true if first arg is empty set |
| 3035 | | prop_empty_set([],R) :- !, R=pred_true. |
| 3036 | | prop_empty_set(_,_). |
| 3037 | | |
| 3038 | | :- block remove_element_wf3(-,?,?,?,?,-,?). |
| 3039 | | % remove_element_wf3(EqRes,H1,H2,T,Res,LWF,DONE) :- print(remove_element_wf3(EqRes,H1,H2,T,Res,LWF,DONE)),nl,fail. |
| 3040 | | remove_element_wf3(pred_true,_H1,_H2,T,Res,_LWF,DONE) :- |
| 3041 | ? | equal_object(T,Res,remove_element_wf3_1),DONE=done. |
| 3042 | | remove_element_wf3(pred_false,E,H,T,Res,LWF,DONE) :- |
| 3043 | ? | equal_object([H|RT],Res,remove_element_wf3_2), |
| 3044 | ? | remove_element_wf2(E,T,RT,LWF,DONE). |
| 3045 | | |
| 3046 | | /* the same as above: but do not remove if infinite or closure */ |
| 3047 | | |
| 3048 | | :- block remove_element_wf_if_not_infinite_or_closure(?,-,?,?,?,?). |
| 3049 | | remove_element_wf_if_not_infinite_or_closure(X,Set, Res,WF,LWF,Done) :- |
| 3050 | | (dont_expand(Set) |
| 3051 | | -> check_element_of_wf(X,Set,WF), |
| 3052 | | equal_object_wf(Res,Set,remove_element_wf_if_not_infinite_or_closure,WF), |
| 3053 | | Done=true % or should we wait until X known ? |
| 3054 | | %(var(Res)->Res=Set ; equal_object(Res,Set)) |
| 3055 | | ; expand_custom_set_to_list_wf(Set,ESet,_,remove_element_wf_if_not_infinite_or_closure,WF), |
| 3056 | ? | remove_element_wf2(X,ESet,Res,LWF,Done) |
| 3057 | | ). |
| 3058 | | |
| 3059 | | %:- use_module(bmachine_construction,[external_procedure_used/1]). |
| 3060 | | %dont_expand(global_set('STRING')) :- !. % s: STRING +-> ... will generate new strings ! |
| 3061 | | %(external_procedure_used(_) -> true). % we could check if there is a STRING generating procedure involved |
| 3062 | | % unless we use external functions, there is *no* way that new strings can be generated from a B machine ! |
| 3063 | | % Hence: we can expand STRING safely and thus avoid infinite enumeration of partial functions, ... |
| 3064 | | % example: procs : STRING +-> {"waiting"} & card( dom(procs) ) = 6 thus fails quickly |
| 3065 | | dont_expand(avl_set(_)) :- !,fail. |
| 3066 | | dont_expand(closure(_,_,_)) :- !. % relevant for tests 283, 1609, 1858 |
| 3067 | | dont_expand(Set) :- is_infinite_or_very_large_explicit_set(Set). % should we use a smaller bound than 20000 ? see test 1609 |
| 3068 | | |
| 3069 | | |
| 3070 | | :- assert_must_succeed((kernel_objects:check_no_duplicates_in_list([int(1),int(2)],[],no_wf_available))). |
| 3071 | | :- assert_must_fail((kernel_objects:check_no_duplicates_in_list([int(1),int(2),int(1)],[],no_wf_available))). |
| 3072 | | |
| 3073 | | :- block check_no_duplicates_in_list(-,?,?). |
| 3074 | | check_no_duplicates_in_list([],_,_) :- !. |
| 3075 | | check_no_duplicates_in_list([H|T],ElementsSoFar,WF) :- !, |
| 3076 | | not_element_of_wf(H,ElementsSoFar,WF), |
| 3077 | | add_new_element_wf(H,ElementsSoFar,ElementsSoFar2,WF), |
| 3078 | | check_no_duplicates_in_list(T,ElementsSoFar2,WF). |
| 3079 | | check_no_duplicates_in_list(CS,ElementsSoFar,WF) :- |
| 3080 | | disjoint_sets(CS,ElementsSoFar,WF). |
| 3081 | | |
| 3082 | | :- public warn_if_duplicates_in_list/3. |
| 3083 | | % code for debugging / safe mode execution to check for duplicates |
| 3084 | | warn_if_duplicates_in_list(List,Src,WF) :- |
| 3085 | | %get_last_wait_flag(warn_if_duplicates_in_list,WF,WFX), % we may wish to use another WF here !? |
| 3086 | | get_enumeration_finished_wait_flag(WF,WFX), |
| 3087 | | when(nonvar(WFX),warn_if_duplicates_in_list(List,[],Src,WF)). |
| 3088 | | |
| 3089 | | :- block warn_if_duplicates_in_list(-,?,?,?). |
| 3090 | | warn_if_duplicates_in_list([],_,_,_) :- !. |
| 3091 | | warn_if_duplicates_in_list([H|T],ElementsSoFar,Src,WF) :- !, |
| 3092 | | membership_test_wf(ElementsSoFar,H,MemRes,WF), |
| 3093 | | warn_aux(MemRes,H,T,ElementsSoFar,Src,WF). |
| 3094 | | warn_if_duplicates_in_list(CS,ElementsSoFar,Src,WF) :- |
| 3095 | | when(ground(CS), |
| 3096 | | (disjoint_sets(CS,ElementsSoFar,WF) |
| 3097 | | -> true |
| 3098 | | ; add_error(Src,'Duplicates in list: ',CS:ElementsSoFar:Src))). |
| 3099 | | |
| 3100 | | :- block warn_aux(-,?,?,?,?,?). |
| 3101 | | warn_aux(pred_true,H,_,ElementsSoFar,Src,_WF) :- |
| 3102 | | add_error(Src,'Duplicate in list: ',H:ElementsSoFar:Src). |
| 3103 | | warn_aux(pred_false,H,T,ElementsSoFar,Src,WF) :- |
| 3104 | | add_new_element_wf(H,ElementsSoFar,ElementsSoFar2,WF), |
| 3105 | | warn_if_duplicates_in_list(T,ElementsSoFar2,Src,WF). |
| 3106 | | |
| 3107 | | |
| 3108 | | :- assert_must_succeed((kernel_objects:remove_exact_first_element([int(1),int(2)],X,[[]]), |
| 3109 | | X = [[int(1),int(2)],[]])). |
| 3110 | | :- assert_must_succeed((kernel_objects:remove_exact_first_element(X,global_set('Name'),T), |
| 3111 | | X==fd(1,'Name'),T==[fd(2,'Name'),fd(3,'Name')])). |
| 3112 | | :- assert_must_fail((kernel_objects:remove_exact_first_element([[]],X,_), |
| 3113 | | X = [[int(1),int(2)],[]])). |
| 3114 | | |
| 3115 | | :- assert_must_succeed((kernel_objects:remove_exact_first_element(X,C,R), |
| 3116 | | kernel_objects:gen_test_interval_closure(1,2,C), |
| 3117 | | X == int(1), R == [int(2)] )). |
| 3118 | | |
| 3119 | | gen_test_interval_closure(From,To,CL) :- |
| 3120 | | CL=closure(['_zzzz_unary'],[integer],b(member( b(identifier('_zzzz_unary'),integer,[]), |
| 3121 | | b(interval(b(value(int(From)),integer,[]), |
| 3122 | | b(value(int(To)),integer,[])),set(integer),[])),pred,[])). |
| 3123 | | |
| 3124 | | :- block remove_exact_first_element(?,-,?). |
| 3125 | | remove_exact_first_element(X,Set,Res) :- remove_exact_first_element1(Set,X,Res). |
| 3126 | | |
| 3127 | | remove_exact_first_element1([],_,_) :- fail. |
| 3128 | | remove_exact_first_element1([H|T],H,T). |
| 3129 | | remove_exact_first_element1(avl_set(A),H,T) :- remove_minimum_element_custom_set(avl_set(A),H,T). |
| 3130 | | remove_exact_first_element1(global_set(GS),H,T) :- |
| 3131 | | remove_minimum_element_custom_set(global_set(GS),H,T). |
| 3132 | | remove_exact_first_element1(freetype(GS),H,T) :- |
| 3133 | | remove_minimum_element_custom_set(freetype(GS),H,T). |
| 3134 | | remove_exact_first_element1(closure(P,Types,B),H,T) :- |
| 3135 | | remove_minimum_element_custom_set(closure(P,Types,B),H,T). |
| 3136 | | |
| 3137 | | |
| 3138 | | :- assert_must_succeed((kernel_objects:delete_element_wf(fd(1,'Name'),X,[fd(2,'Name'),fd(3,'Name')],_WF), |
| 3139 | | X = global_set('Name'))). |
| 3140 | | :- assert_must_succeed((kernel_objects:delete_element_wf(int(1),X,[int(2)],_WF), |
| 3141 | | X = [int(2),int(1)])). |
| 3142 | | :- assert_must_succeed((kernel_objects:delete_element_wf([int(1),int(2)],X,[],_WF), |
| 3143 | | X = [[int(2),int(1)]])). |
| 3144 | | :- assert_must_succeed((kernel_objects:delete_element_wf(int(3),X,[int(2),int(1)],_WF), |
| 3145 | | X = [int(2),int(1)])). |
| 3146 | | :- assert_must_succeed((kernel_objects:delete_element_wf(int(1),X,X,_WF), |
| 3147 | | X = [])). |
| 3148 | | :- assert_must_fail((kernel_objects:delete_element_wf(int(X),[int(1)],[int(1)],_WF), |
| 3149 | | X = 1)). |
| 3150 | | |
| 3151 | | /* WARNING: only use when R is not instantiated by something else; |
| 3152 | | (except for R=[]) */ |
| 3153 | | |
| 3154 | | |
| 3155 | | :- block delete_element_wf(?,-,?,?). |
| 3156 | | delete_element_wf(X,Set,Res,WF) :- |
| 3157 | | ground(X), |
| 3158 | | try_expand_and_convert_to_avl_with_check(Set,ESet,delete_element_wf),!, |
| 3159 | | delete_element0(X,ESet,Res,WF). |
| 3160 | | delete_element_wf(X,Set,Res,WF) :- delete_element1(X,Set,Res,WF). |
| 3161 | | |
| 3162 | | :- block delete_element0(?,-,?,?). |
| 3163 | | delete_element0(X,ESet,Res,WF) :- |
| 3164 | | ( is_custom_explicit_set(ESet,delete_element), |
| 3165 | | delete_element_from_explicit_set(ESet,X,DS) |
| 3166 | | -> equal_object_wf(DS,Res,delete_element0,WF) |
| 3167 | | ; delete_element1(X,ESet,Res,WF) |
| 3168 | | ). |
| 3169 | | |
| 3170 | | delete_element1(X,Set,Res,WF) :- expand_custom_set_to_list_wf(Set,ESet,_,delete_element1,WF), |
| 3171 | | %check_is_expanded_set(ESet,delete_element2), |
| 3172 | | delete_element2(ESet,X,Res,WF). |
| 3173 | | |
| 3174 | | :- block delete_element2(-,?,?,?). |
| 3175 | | delete_element2([],_,[],_). /* same as above, but allow element to be absent */ |
| 3176 | | delete_element2([H2|T],E,R,WF) :- |
| 3177 | | equality_objects_wf(H2,E,EqRes,WF), |
| 3178 | | delete_element3(EqRes,H2,T,E,R,WF). |
| 3179 | | %when_sufficiently_instantiated(E,H2,delete_element3(H1,[H2|T],R)). /* added by Michael Leuschel, 16/3/06 */ |
| 3180 | | |
| 3181 | | :- block delete_element3(-,?,?,?,?,?). |
| 3182 | | delete_element3(pred_true,_H2,T,_,R,WF) :- equal_object_wf(R,T,delete_element3,WF). |
| 3183 | | delete_element3(pred_false,H2,T,E,Res,WF) :- equal_cons_wf(Res,H2,RT,WF),delete_element2(T,E,RT,WF). |
| 3184 | | |
| 3185 | | |
| 3186 | | |
| 3187 | | |
| 3188 | | :- assert_must_succeed(kernel_objects:check_is_expanded_set([int(1)],test)). |
| 3189 | | |
| 3190 | | :- public check_is_expanded_set/2. |
| 3191 | | check_is_expanded_set(X,Source) :- |
| 3192 | | (nonvar(X),(X=[] ; X= [_|_]) -> true |
| 3193 | | ; add_internal_error('Is not expanded set: ',check_is_expanded_set(X,Source)) |
| 3194 | | ). |
| 3195 | | |
| 3196 | | |
| 3197 | | /* union/3 */ |
| 3198 | | |
| 3199 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(3)],[int(2),int(1),int(3)],[int(1),int(3),int(2)]))). |
| 3200 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(1)],[int(1),int(2)],[int(1),int(2)]))). |
| 3201 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(3)],[int(2),int(1)],[int(1),int(3),int(2)]))). |
| 3202 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],union([int(3),int(2)],[int(2),int(1)],[int(1),int(3),int(2)]))). |
| 3203 | | :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],union([int(3),int(4)],[int(2),int(1)],[int(1),int(3),int(2)]))). |
| 3204 | | :- assert_must_succeed((kernel_objects:union([int(1)],[int(2)],Res),kernel_objects:equal_object(Res,[_,_]))). |
| 3205 | | :- assert_must_succeed((kernel_objects:union([],[int(2)],Res), |
| 3206 | | kernel_objects:equal_object(Res,[int(2)]))). |
| 3207 | | :- assert_must_succeed((kernel_objects:union([int(2)],[],Res), |
| 3208 | | kernel_objects:equal_object(Res,[int(2)]))). |
| 3209 | | :- assert_must_succeed((kernel_objects:union([int(2)],[int(2)],Res), |
| 3210 | | kernel_objects:equal_object(Res,[int(2)]))). |
| 3211 | | :- assert_must_succeed((kernel_objects:union([int(1)],Res,[int(1),int(2)]), |
| 3212 | | kernel_objects:equal_object(Res,[int(2)]))). |
| 3213 | | :- assert_must_succeed((kernel_objects:union([fd(1,'Name')],X,Res),X=global_set('Name'), |
| 3214 | | kernel_objects:equal_object(Res,X))). |
| 3215 | | :- assert_must_succeed((kernel_objects:union(X,global_set('Name'),Res),X=[fd(2,'Name'),fd(1,'Name')], |
| 3216 | | kernel_objects:equal_object(Res,global_set('Name')))). |
| 3217 | | :- assert_must_succeed((kernel_objects:union([fd(1,'Name')],[fd(3,'Name'),fd(2,'Name')],Res), |
| 3218 | | kernel_objects:equal_object(Res,global_set('Name')))). |
| 3219 | | %:- assert_must_succeed((kernel_objects:union([fd(1,'Name')],[fd(3,'Name'),fd(2,'Name')],Res), |
| 3220 | | % kernel_objects:equal_object(Res,X),X=global_set('Name'))). |
| 3221 | | :- assert_must_fail((kernel_objects:union([int(1)],[int(2)],Res), |
| 3222 | | (kernel_objects:equal_object(Res,[_]);kernel_objects:equal_object(Res,[_,_,_|_])))). |
| 3223 | | :- assert_must_fail((kernel_objects:union([int(1)],[int(1)],Res),(Res=[];kernel_objects:equal_object(Res,[_,_|_])))). |
| 3224 | | :- assert_must_fail((kernel_objects:union([fd(1,'Name')],[fd(2,'Name')],Res), |
| 3225 | | kernel_objects:equal_object(Res,global_set('Name')))). |
| 3226 | | % kernel_objects:union([int(1),int(2)],X,[int(1),int(2),int(3)]) |
| 3227 | | |
| 3228 | | union(S1,S2,Res) :- init_wait_flags(WF,[union]), union_wf(S1,S2,Res,WF), ground_wait_flags(WF). |
| 3229 | | |
| 3230 | | :- block union_wf(-,-,-,?). |
| 3231 | | %union_wf(Set1,Set2,Res,_WF) :- print(union_wf(Set1,Set2,Res)),nl,fail. |
| 3232 | | union_wf(Set1,Set2,Res,WF) :- Set1==[],!,equal_object_wf(Set2,Res,union_wf_1,WF). |
| 3233 | | union_wf(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,union_wf_2,WF). |
| 3234 | | union_wf(Set1,Set2,Res,WF) :- Res==[],!,empty_set_wf(Set1,WF), empty_set_wf(Set2,WF). |
| 3235 | | union_wf(Set1,Set2,Res,WF) :- union0(Set1,Set2,Res,WF). |
| 3236 | | |
| 3237 | | :- block union0(-,-,?,?), union0(-,?,-,?), union0(?,-,-,?). % require two arguments to be known |
| 3238 | | union0(Set1,Set2,Res,WF) :- Set1==[],!,equal_object_wf(Set2,Res,union0_1,WF). |
| 3239 | | union0(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,union0_2,WF). |
| 3240 | | union0(Set1,Set2,Res,WF) :- Res==[],!,empty_set_wf(Set1,WF), empty_set_wf(Set2,WF). |
| 3241 | | union0(Set1,Set2,Res,WF) :- nonvar(Res), singleton_set(Res,X),!, |
| 3242 | | (var(Set1) -> union0_to_singleton_set(Set2,Set1,X,WF) ; union0_to_singleton_set(Set1,Set2,X,WF)). |
| 3243 | ? | union0(Set1,Set2,Res,WF) :- (var(Set1) -> union1(Set2,Set1,Res,WF) ; union1(Set1,Set2,Res,WF)). |
| 3244 | | |
| 3245 | | % optimized version for Set1 \/ Set2 = {X} |
| 3246 | | % TO DO: is not triggered when Set1 and Set2 are instantiated first (before result) |
| 3247 | | % >>> z:11..12 & {x,y} \/ {v} = {z} does not work |
| 3248 | | union0_to_singleton_set([],Set2,X,WF) :- !, equal_object_wf(Set2,[X],union0_3,WF). % cannot be reached, due to checks above |
| 3249 | | union0_to_singleton_set([H|T],Set2,X,WF) :- !, empty_set_wf(T,WF), equal_object_wf(H,X,WF), |
| 3250 | | check_subset_of_wf(Set2,[X],WF). |
| 3251 | | union0_to_singleton_set(avl_set(A),Set2,X,WF) :- !, singleton_set(avl_set(A),AEl), |
| 3252 | | equal_object_wf(AEl,X,WF), |
| 3253 | | check_subset_of_wf(Set2,[X],WF). |
| 3254 | | union0_to_singleton_set(Set1,Set2,X,WF) :- % closure or global_set; revert to normal treatment |
| 3255 | | union1(Set1,Set2,[X],WF). |
| 3256 | | |
| 3257 | | union1(Set1,Set2,Res,WF) :- |
| 3258 | | try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set1,ESet1,WF), |
| 3259 | | try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set2,ESet2,WF), |
| 3260 | ? | union1e(ESet1,ESet2,Res,WF). |
| 3261 | | |
| 3262 | | try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set,ESet,_) :- (var(Set);Set=closure(_,_,_)),!,ESet=Set. |
| 3263 | | try_expand_and_convert_to_avl_unless_large_or_closure_wf(Set,ESet,WF) :- |
| 3264 | | try_expand_and_convert_to_avl_unless_large_wf(Set,ESet,WF). |
| 3265 | | |
| 3266 | | union1e(Set1,Set2,Res,WF) :- |
| 3267 | | is_custom_explicit_set(Set1,union1e), |
| 3268 | | union_of_explicit_set(Set1,Set2,Union), !, |
| 3269 | | equal_object_wf(Union,Res,union1e,WF). |
| 3270 | | union1e(Set2,Set1,Res,WF) :- % Set2=avl_set(_), nonvar(Set1), Set1 \= avl_set(_), |
| 3271 | | nonvar(Set1), Set1=avl_set(_), Set2 \= avl_set(_), \+ ground(Set2), |
| 3272 | | !, % avoid expanding Set2 |
| 3273 | | expand_custom_set_to_list_wf(Set1,ESet1,_,union1e_1,WF), |
| 3274 | ? | union2(ESet1,Set2,Res,WF), lazy_check_subset_of(Set2,Res,WF). |
| 3275 | | union1e(Set1,Set2,Res,WF) :- |
| 3276 | | expand_custom_set_to_list_wf(Set1,ESet1,_,union1e_2,WF), % we could avoid this expansion by treating avl_set,... below in union2 |
| 3277 | | union2(ESet1,Set2,Res,WF), |
| 3278 | | lazy_check_subset_of(Set1,Res,WF), % ADDED to solve {x,y| { x \/ y } <: {{1} \/ {2}}} |
| 3279 | | lazy_check_subset_of(Set2,Res,WF) % could perform additional constraint checking |
| 3280 | | % ,try_prop_card_leq(ESet1,Res), try_prop_card_leq(Set2,Res). %%% seems to slow down ProB: investigate |
| 3281 | | . |
| 3282 | | |
| 3283 | | /* not yet used: |
| 3284 | | % lazy_check_in_union(R,Set1,Set2,WF): check if all elements of R appear in at least one of the sets Sets1/2: |
| 3285 | | :- block lazy_check_in_union(-,?,?,?). |
| 3286 | | lazy_check_in_union([],_,_,_) :- !. |
| 3287 | | lazy_check_in_union([H|T],Set1,Set2,WF) :- !, |
| 3288 | | in_one_of_sets(H,Set1,Set2,WF), |
| 3289 | | lazy_check_in_union(T,Set1,Set2,WF). |
| 3290 | | lazy_check_in_union(_,_,_,_). |
| 3291 | | |
| 3292 | | % check if an element appear in at least one of the two sets: |
| 3293 | | in_one_of_sets(H,Set1,Set2,WF) :- |
| 3294 | | membership_test_wf(Set1,H,MemRes1,WF), |
| 3295 | | (MemRes1==pred_true -> true |
| 3296 | | ; one_true(MemRes1,MemRes2), |
| 3297 | | membership_test_wf(Set2,H,MemRes2,WF) |
| 3298 | | ). |
| 3299 | | |
| 3300 | | :- block one_true(-,-). |
| 3301 | | one_true(MemRes1,MemRes2) :- var(MemRes1),!, |
| 3302 | | (MemRes2=pred_false -> MemRes1=pred_true ; true). |
| 3303 | | one_true(pred_true,_). |
| 3304 | | one_true(pred_false,pred_true). |
| 3305 | | */ |
| 3306 | | |
| 3307 | | |
| 3308 | | :- block lazy_try_check_element_of(?,-,?). |
| 3309 | | lazy_try_check_element_of(H,Set,WF) :- lazy_check_element_of_aux(Set,H,WF). |
| 3310 | | |
| 3311 | | lazy_check_element_of_aux(closure(P,T,B),H,WF) :- !, check_element_of_wf(H,closure(P,T,B),WF). |
| 3312 | | lazy_check_element_of_aux(avl_set(A),H,WF) :- !, check_element_of_wf(H,avl_set(A),WF). |
| 3313 | | lazy_check_element_of_aux([X|T],H,WF) :- !, lazy_check_element_of_list(T,X,H,WF). |
| 3314 | | lazy_check_element_of_aux(_,_,_). |
| 3315 | | |
| 3316 | | :- block lazy_check_element_of_list(-,?,?,?). |
| 3317 | | lazy_check_element_of_list([],X,H,WF) :- !, equal_object_wf(X,H,WF). |
| 3318 | | lazy_check_element_of_list([Y|T],X,H,WF) :- !, |
| 3319 | | quick_propagation_element_information([X,Y|T],H,WF,_). % TO DO: check that we loose no performance due to this |
| 3320 | | lazy_check_element_of_list(_,_,_,_). |
| 3321 | | |
| 3322 | | % an incomplete subset check without enumeration |
| 3323 | | :- block lazy_check_subset_of(-,?,?), lazy_check_subset_of(?,-,?). |
| 3324 | | lazy_check_subset_of(Set1,Set2,WF) :- nonvar(Set2), |
| 3325 | | (Set2=closure(_,_,_) ; Set2=avl_set(_)),!, lazy_check_subset_of2(Set1,Set2,WF). |
| 3326 | | lazy_check_subset_of(_,_,_). % ignore other set representations |
| 3327 | | :- block lazy_check_subset_of2(-,?,?). |
| 3328 | | lazy_check_subset_of2([],_,_WF) :- !. |
| 3329 | | lazy_check_subset_of2([H|T],Set,WF) :- !, check_element_of_wf(H,Set,WF), lazy_check_subset_of2(T,Set,WF). |
| 3330 | | lazy_check_subset_of2(_,_,_). % ignore other set representations |
| 3331 | | |
| 3332 | | :- block union2(-,?,?,?). |
| 3333 | | union2([],S,Res,WF) :- equal_object_optimized_wf(S,Res,union2,WF). |
| 3334 | | union2([H|T],Set2,Res,WF) :- |
| 3335 | | (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 |
| 3336 | | % the constraint is not yet detected straight away: x:S & S<:1..12 & S \/ {x} /= S |
| 3337 | | -> union3(H2,T2,[H|T],Res,WF) |
| 3338 | ? | ; union3(H,T,Set2,Res,WF) |
| 3339 | | ). |
| 3340 | | union3(H,T,Set2,Res,WF) :- |
| 3341 | | add_element_wf(H,Set2,R,Done,WF), |
| 3342 | | lazy_try_check_element_of(H,Res,WF), % TO DO: propagate constraint that H is in Res |
| 3343 | | (T==[] |
| 3344 | ? | -> equal_object_optimized_wf(R,Res,union3,WF) %union2(T,R,Res,WF) |
| 3345 | | ; union4(Done,T,R,Res,WF)). |
| 3346 | | :- block union4(-,?,?,?,?). |
| 3347 | ? | 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 |
| 3348 | | |
| 3349 | | |
| 3350 | | :- assert_must_succeed(exhaustive_kernel_check(union_generalized([[int(3)],[int(2),int(1),int(3)]],[int(1),int(3),int(2)]))). |
| 3351 | | :- assert_must_succeed(exhaustive_kernel_check(union_generalized([[int(3),int(2)],[],[int(2),int(1),int(3)]],[int(1),int(3),int(2)]))). |
| 3352 | | :- 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)]))). |
| 3353 | | :- assert_must_succeed((kernel_objects:union_generalized([[]],Res),Res=[])). |
| 3354 | | :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2)]],Res), |
| 3355 | | kernel_objects:equal_object(Res,[_,_]))). |
| 3356 | | :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2),int(1)]],Res), |
| 3357 | | kernel_objects:equal_object(Res,[_,_]))). |
| 3358 | | :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2),int(1)],[],[int(2)]],Res), |
| 3359 | | kernel_objects:equal_object(Res,[_,_]))). |
| 3360 | | :- assert_must_succeed((kernel_objects:union_generalized([[int(1)],[int(2)],X],Res), |
| 3361 | | kernel_objects:equal_object(X,Res), X = [int(2),int(1),int(3)])). |
| 3362 | | :- assert_must_succeed((kernel_objects:union_generalized([global_set('Name'),X,X,X],Res), |
| 3363 | | kernel_objects:equal_object(global_set('Name'),Res), X = [fd(2,'Name'),fd(1,'Name')])). |
| 3364 | | :- assert_must_succeed((kernel_objects:union_generalized([X,global_set('Name')],Res), |
| 3365 | | kernel_objects:equal_object(global_set('Name'),Res), X = [fd(2,'Name'),fd(1,'Name')])). |
| 3366 | | :- assert_must_fail((kernel_objects:union_generalized([[int(1)],[int(2)]],Res),(Res=[_]; |
| 3367 | | kernel_objects:equal_object(Res,[_,_,_|_])))). |
| 3368 | | :- assert_must_fail((kernel_objects:union_generalized([[int(1)],[int(1)]],Res),(Res=[]; |
| 3369 | | kernel_objects:equal_object(Res,[_,_|_])))). |
| 3370 | | |
| 3371 | | % treates the general_union AST node (union(.) in B syntax) |
| 3372 | | union_generalized(S,Res) :- init_wait_flags(WF), union_generalized_wf(S,Res,WF), ground_wait_flags(WF). |
| 3373 | | |
| 3374 | | :- block union_generalized_wf(-,-,?). |
| 3375 | | union_generalized_wf(SetsOfSets,Res,WF) :- var(SetsOfSets), Res==[],!, |
| 3376 | | expand_custom_set_to_list_wf(SetsOfSets,ESetsOfSets,_,union_generalized_wf,WF), |
| 3377 | | all_empty_sets_wf(ESetsOfSets,WF). |
| 3378 | | union_generalized_wf(SetsOfSets,Res,WF) :- |
| 3379 | | union_generalized_wf2(SetsOfSets,Res,WF). |
| 3380 | | |
| 3381 | | :- block union_generalized_wf2(-,?,?). |
| 3382 | | union_generalized_wf2(SetsOfSets,Res,WF) :- |
| 3383 | | custom_explicit_sets:union_generalized_explicit_set(SetsOfSets,ARes,WF),!, |
| 3384 | ? | equal_object_optimized_wf(ARes,Res,union_generalized_avl_set,WF). |
| 3385 | | union_generalized_wf2(SetsOfSets,Res,WF) :- |
| 3386 | | expand_custom_set_to_list_wf(SetsOfSets,ESetsOfSets,_,union_generalized_wf2,WF), |
| 3387 | | union_generalized2(ESetsOfSets,[],Res,WF). |
| 3388 | | |
| 3389 | | :- block union_generalized2(-,?,?,?). |
| 3390 | | union_generalized2([],S,Res,WF) :- equal_object_optimized_wf(S,Res,union_generalized2,WF). |
| 3391 | | union_generalized2([H|T],UnionSoFar,Res,WF) :- |
| 3392 | | Res==[], |
| 3393 | | !, |
| 3394 | | empty_set_wf(H,WF), |
| 3395 | | empty_set_wf(UnionSoFar,WF), |
| 3396 | | all_empty_sets_wf(T,WF). |
| 3397 | | union_generalized2([H|T],UnionSoFar,Res,WF) :- union_wf(H,UnionSoFar,UnionSoFar2,WF), |
| 3398 | | ((var(T);var(UnionSoFar2)), |
| 3399 | | 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) |
| 3400 | | -> check_subset_of_wf(H,Res,WF) |
| 3401 | | % 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 |
| 3402 | | ; true), |
| 3403 | | union_generalized2(T,UnionSoFar2,Res,WF). |
| 3404 | | |
| 3405 | | :- block all_empty_sets_wf(-,?). |
| 3406 | | all_empty_sets_wf([],_). |
| 3407 | | all_empty_sets_wf([H|T],WF) :- empty_set_wf(H,WF), all_empty_sets_wf(T,WF). |
| 3408 | | |
| 3409 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],intersection([int(3)],[int(2),int(1),int(3)],[int(3)]))). |
| 3410 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],intersection([int(4),int(3),int(2)],[int(2),int(1),int(3)],[int(2),int(3)]))). |
| 3411 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],intersection([int(4),int(3),int(2)],[],[]))). |
| 3412 | | :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],intersection([int(1),int(3)],[int(4),int(3),int(2)],[]))). |
| 3413 | | :- assert_must_succeed((kernel_objects:intersection(Y,X,Res),X=global_set('Name'), |
| 3414 | | kernel_objects:equal_object(Res,Y), Y =[fd(1,'Name')])). |
| 3415 | | :- assert_must_succeed((kernel_objects:intersection([int(1)],[int(2)],Res),Res=[])). |
| 3416 | | :- assert_must_succeed((kernel_objects:intersection([int(1)],[int(2)],[]))). |
| 3417 | | :- assert_must_fail((kernel_objects:intersection([int(1),int(4),int(3)],[int(2),int(3)],[]))). |
| 3418 | | :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(1)],_))). |
| 3419 | | :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(1)],[int(2),int(1)]))). |
| 3420 | | :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(1)],[int(1),int(2)]))). |
| 3421 | | :- assert_must_succeed((kernel_objects:intersection([int(1),int(2)],[int(2),int(3)],Res), |
| 3422 | | kernel_objects:equal_object(Res,[int(2)]))). |
| 3423 | | :- assert_must_succeed((kernel_objects:intersection([int(2)],[int(2)],Res), |
| 3424 | | kernel_objects:equal_object(Res,[int(2)]))). |
| 3425 | | :- assert_must_succeed((kernel_objects:intersection([int(2),int(3)],[int(3),int(4),int(2)],Res), |
| 3426 | | kernel_objects:equal_object(Res,[int(2),int(3)]))). |
| 3427 | | :- assert_must_fail((kernel_objects:intersection([int(1)],[int(2)],Res),( |
| 3428 | | kernel_objects:equal_object(Res,[_|_])))). |
| 3429 | | :- assert_must_fail((kernel_objects:intersection([int(1)],[int(1)],Res),(Res=[]; |
| 3430 | | kernel_objects:equal_object(Res,[_,_|_])))). |
| 3431 | | :- assert_must_fail((kernel_objects:intersection([fd(1,'Name')],X,Res),X=global_set('Name'), |
| 3432 | | kernel_objects:equal_object(Res,X))). |
| 3433 | | |
| 3434 | | |
| 3435 | | intersection(S1,S2,Res) :- init_wait_flags(WF,[intersection]), intersection(S1,S2,Res,WF), ground_wait_flags(WF). |
| 3436 | | |
| 3437 | | :- block intersection(-,-,-,?). |
| 3438 | | intersection(Set1,Set2,Res,WF) :- (Set1==[] ; Set2==[]),!, empty_set_wf(Res,WF). |
| 3439 | | intersection(Set1,Set2,Res,WF) :- quick_same_value(Set1,Set2),!, |
| 3440 | | equal_object_wf(Res,Set1,inter0_equal,WF). |
| 3441 | | intersection(Set1,Set2,Res,WF) :- Res==[],!, |
| 3442 | | disjoint_sets(Set1,Set2,WF). |
| 3443 | | 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 |
| 3444 | | intersection0(Set1,Set2,Res,WF), |
| 3445 | | propagate_intersection(Set1,Set2,Res,WF). |
| 3446 | | |
| 3447 | | :- block propagate_intersection(?,?,-,?). % propagate constraint that result elements must be in both sets |
| 3448 | | propagate_intersection(Set1,Set2,[H|T],WF) :- |
| 3449 | | preference(data_validation_mode,false), |
| 3450 | | !, |
| 3451 | ? | propagate_intersection_aux(Set1,Set2,H,T,WF). |
| 3452 | | propagate_intersection(Set1,Set2,avl_set(A),WF) :- !, |
| 3453 | | ((unknown_set(Set1) ; unknown_set(Set2)) % otherwise intersection0 has already triggered below |
| 3454 | | -> custom_explicit_sets:avl_approximate_size(A,Size), |
| 3455 | | (Size<20 |
| 3456 | | -> expand_custom_set_to_list_wf(avl_set(A),ESet,_,propagate_intersection,WF) |
| 3457 | | ; avl_min(A,Min), avl_max(A,Max), ESet=[Min,Max] |
| 3458 | | ), |
| 3459 | | propagate_intersection(Set1,Set2,ESet,WF) |
| 3460 | | ; true). |
| 3461 | | % other cases: Set1,2,3 could be interval closure with unknown bounds,... |
| 3462 | | propagate_intersection(_,_,_,_). |
| 3463 | | |
| 3464 | | :- block propagate_intersection_aux(-,-,-,?,?). |
| 3465 | | propagate_intersection_aux(Set1,Set2,H,T,WF) :- |
| 3466 | | ((unknown_set(Set1) ; unknown_set(Set2)) % otherwise intersection0 has already triggered below |
| 3467 | | -> check_element_of_wf(H,Set1,WF), % should we do this lazily ? |
| 3468 | ? | check_element_of_wf(H,Set2,WF), |
| 3469 | | propagate_intersection(Set1,Set2,T,WF) |
| 3470 | | ; true). |
| 3471 | | |
| 3472 | | unknown_set(Set) :- var(Set),!. |
| 3473 | | unknown_set([H|T]) :- (unknown_val(H) -> true ; unknown_set(T)). |
| 3474 | | unknown_val(Val) :- var(Val),!. |
| 3475 | | unknown_val(int(X)) :- var(X). |
| 3476 | | unknown_val(string(X)) :- var(X). |
| 3477 | | unknown_val(fd(X,_)) :- var(X). |
| 3478 | | unknown_val((A,B)) :- (unknown_val(A) -> true ; unknown_val(B)). |
| 3479 | | unknown_val([H|T]) :- (unknown_val(H) -> true ; unknown_set(T)). |
| 3480 | | |
| 3481 | | :- block intersection0(-,?,?,?), intersection0(?,-,?,?). |
| 3482 | | intersection0(Set1,Set2,Res,WF) :- |
| 3483 | | (Set1==[] ; Set2==[]),!, empty_set_wf(Res,WF). |
| 3484 | | intersection0(Set1,Set2,Res,WF) :- quick_same_value(Set1,Set2),!, |
| 3485 | | equal_object_wf(Res,Set1,inter0_equal,WF). |
| 3486 | | intersection0(Set1,Set2,Res,WF) :- Res==[],!, |
| 3487 | | disjoint_sets(Set1,Set2,WF). |
| 3488 | | intersection0([El1|T1],[El2|T2],Res,WF) :- T1==[],T2==[], |
| 3489 | | !, % avoid doing intersection_with_interval_closure, especially for nonvar El1,El2 ; see test 2021 |
| 3490 | | equality_objects_wf(El1,El2,EqRes,WF), |
| 3491 | | kernel_equality:empty_set_test_wf(Res,Empty,WF), |
| 3492 | | bool_pred:negate(Empty,EqRes), |
| 3493 | | intersection_pair(EqRes,El1,El2,Res,WF). |
| 3494 | | intersection0(Set1,Set2,Res,WF) :- |
| 3495 | ? | intersection_with_interval_closure(Set1,Set2,Inter),!, % avoid expanding intervals at all |
| 3496 | | equal_object_wf(Inter,Res,intersection0,WF). |
| 3497 | | intersection0(Set1,Set2,Res,WF) :- |
| 3498 | | try_expand_and_convert_to_avl_unless_large_wf(Set1,ESet1,WF), |
| 3499 | | try_expand_and_convert_to_avl_unless_large_wf(Set2,ESet2,WF), |
| 3500 | | intersection1(ESet1,ESet2,Res,WF). |
| 3501 | | |
| 3502 | | % treat {El1} /\ {El2} = Res |
| 3503 | | :- block intersection_pair(-,?,?,?,?). |
| 3504 | | intersection_pair(pred_false,_,_,_,_). % empty_set_test_wf above will set Res to empty_set |
| 3505 | ? | intersection_pair(pred_true,El1,_El2,Res,WF) :- equal_object_wf(Res,[El1],intersection_pair,WF). |
| 3506 | | |
| 3507 | | intersection1(Set1,Set2,Res,WF) :- nonvar(Set1),is_custom_explicit_set(Set1,intersection), |
| 3508 | | intersection_of_explicit_set_wf(Set1,Set2,Inter,WF), !, |
| 3509 | | equal_object_wf(Inter,Res,intersection1,WF). |
| 3510 | | intersection1(Set1,Set2,Res,WF) :- |
| 3511 | | (Res==[] -> |
| 3512 | | disjoint_sets(Set1,Set2,WF) |
| 3513 | | ; |
| 3514 | | (swap_set(Set1,Set2) -> intersection2(Set2,Set1,Res,WF) |
| 3515 | | ; intersection2(Set1,Set2,Res,WF)) |
| 3516 | | ). |
| 3517 | | |
| 3518 | | swap_set(Set1,_Set2) :- var(Set1),!. |
| 3519 | | swap_set(_Set1,Set2) :- var(Set2),!,fail. |
| 3520 | | %swap_set(_Set1,Set2) :- is_infinite_explicit_set(Set2),!,fail. |
| 3521 | | swap_set(avl_set(_),Set2) :- \+ functor(Set2,avl_set,2), %Set2 \= avl_set(_), |
| 3522 | | Set2 \= [], |
| 3523 | | \+ functor(Set2,closure,3), %Set2 \= closure(_,_,_), |
| 3524 | | \+ functor(Set2,global_set,1). %Set2 \= global_set(_). % if it was a small closure, intersection_of_explicit_set should have triggered |
| 3525 | | 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 |
| 3526 | | swap_set(global_set(_GS),Set2) :- ok_to_swap(Set2). |
| 3527 | | |
| 3528 | | ok_to_swap(global_set(GS)) :- !, \+ is_infinite_or_very_large_explicit_set(global_set(GS),1000000). |
| 3529 | | ok_to_swap(closure(P,T,B)) :- !,\+ is_infinite_or_very_large_explicit_set(closure(P,T,B),1000000). |
| 3530 | | ok_to_swap(_). |
| 3531 | | % maybe also use is_efficient_custom_set as below ?? |
| 3532 | | % what about freetype ? |
| 3533 | | |
| 3534 | | |
| 3535 | | intersection2(Set1,Set2,Res,WF) :- |
| 3536 | | expand_custom_set_to_list_wf(Set1,ESet1,_,intersection2,WF), |
| 3537 | | intersection3(ESet1,Set2,Res,WF). |
| 3538 | | :- block intersection3(-,?,?,?). |
| 3539 | ? | intersection3([],_,Res,WF) :- empty_set_wf(Res,WF). |
| 3540 | | intersection3([H|T],Set,Res,WF) :- |
| 3541 | | (Res==[] |
| 3542 | | -> not_element_of_wf(H,Set,WF),intersection3(T,Set,Res,WF) |
| 3543 | | ; membership_test_wf(Set,H,MemRes,WF), |
| 3544 | ? | intersection4(MemRes,H,T,Set,Res,WF) |
| 3545 | | ). |
| 3546 | | |
| 3547 | | :- block intersection4(-,?,?, ?,?,?). |
| 3548 | | intersection4(pred_true,H,T,Set,Result,WF) :- |
| 3549 | ? | equal_object_wf([H|Res],Result,intersection4,WF), |
| 3550 | ? | intersection3(T,Set,Res,WF). |
| 3551 | | intersection4(pred_false,_H,T,Set,Res,WF) :- |
| 3552 | ? | intersection3(T,Set,Res,WF). |
| 3553 | | |
| 3554 | | |
| 3555 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(disjoint_sets([int(5)],[int(2),int(1),int(3)],WF),WF)). |
| 3556 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(disjoint_sets([int(5)],[],WF),WF)). |
| 3557 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(disjoint_sets([int(5),int(2)],[int(6),int(1),int(3)],WF),WF)). |
| 3558 | | |
| 3559 | | disjoint_sets(S1,S2) :- init_wait_flags(WF,[disjoint_sets]), |
| 3560 | | disjoint_sets(S1,S2,WF), |
| 3561 | | ground_wait_flags(WF). |
| 3562 | | |
| 3563 | | :- block disjoint_sets(-,?,?), disjoint_sets(?,-,?). |
| 3564 | | disjoint_sets(S1,S2,WF) :- |
| 3565 | | % TO DO: we could provide faster code for two avl sets / intervals; but probably caught in intersection code above? |
| 3566 | | ((S1==[];S2==[]) -> true |
| 3567 | | ; is_interval_closure_or_integerset(S1,Low1,Up1), |
| 3568 | | nonvar(Low1), nonvar(Up1), % avoid applying it to e.g., {x} /\ 0..2000 = {} from test 1165 |
| 3569 | | is_interval_closure_or_integerset(S2,Low2,Up2), nonvar(Low2), nonvar(Up2) -> |
| 3570 | | custom_explicit_sets:disjoint_intervals_with_inf(Low1,Up1,Low2,Up2) |
| 3571 | | ; is_efficient_custom_set(S2) -> expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_1,WF), |
| 3572 | | % TODO: treat is_infinite_or_symbolic_closure S1 |
| 3573 | | disjoint_sets2(ESet1,S2,WF) |
| 3574 | | ; is_efficient_custom_set(S1) -> expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_2,WF), |
| 3575 | | disjoint_sets2(ESet2,S1,WF) |
| 3576 | | ; expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_3,WF), |
| 3577 | | %expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_4,WF), |
| 3578 | | disjoint_sets2(ESet1,S2,WF) |
| 3579 | | ). |
| 3580 | | |
| 3581 | | % TO DO: we could infer some constraints on the possible max sizes of the sets |
| 3582 | | % for finite types (sum of size must be <= size of type) |
| 3583 | | :- block disjoint_sets2(-,?,?). |
| 3584 | | disjoint_sets2([],_,_WF). |
| 3585 | | disjoint_sets2([H|T],S2,WF) :- not_element_of_wf(H,S2,WF), disjoint_sets2(T,S2,WF). |
| 3586 | | |
| 3587 | | % NOT YET USED: not_disjoint_sets could be used for S /\ R /= {} |
| 3588 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(not_disjoint_sets([int(3)],[int(2),int(1),int(3)],WF),WF)). |
| 3589 | | :- block not_disjoint_sets(-,?,?), not_disjoint_sets(?,-,?). |
| 3590 | | not_disjoint_sets(S1,S2,WF) :- |
| 3591 | | ((S1==[];S2==[]) -> fail |
| 3592 | | ; is_efficient_custom_set(S2) -> expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_1,WF), |
| 3593 | | not_disjoint_sets2(ESet1,S2,WF) |
| 3594 | | ; is_efficient_custom_set(S1) -> expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_2,WF), |
| 3595 | | not_disjoint_sets2(ESet2,S1,WF) |
| 3596 | | ; expand_custom_set_to_list_wf(S1,ESet1,_,disjoint_sets_3,WF), |
| 3597 | | %expand_custom_set_to_list_wf(S2,ESet2,_,disjoint_sets_4,WF), |
| 3598 | | not_disjoint_sets2(ESet1,S2,WF) |
| 3599 | | ). |
| 3600 | | |
| 3601 | | :- block not_disjoint_sets2(-,?,?). |
| 3602 | | not_disjoint_sets2([],_,_WF). |
| 3603 | | not_disjoint_sets2([H|T],S2,WF) :- membership_test_wf(S2,H,MemRes,WF), not_disjoint3(MemRes,T,S2,WF). |
| 3604 | | |
| 3605 | | :- block not_disjoint3(-,?,?,?). |
| 3606 | | not_disjoint3(pred_true,_,_,_). |
| 3607 | | not_disjoint3(pred_false,T,S2,WF) :- not_disjoint_sets2(T,S2,WF). |
| 3608 | | |
| 3609 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(intersection_generalized_wf([[int(3)],[int(2),int(1),int(3)]],[int(3)],unknown,WF),WF)). |
| 3610 | | :- 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)). |
| 3611 | | :- 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))), |
| 3612 | | 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))), |
| 3613 | | avl_set(node(fd(2,'Name'),true,0,empty,empty)),unknown,_WF))). |
| 3614 | | :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(1)],[int(2)]],Res,unknown,_WF),Res=[])). |
| 3615 | | :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(1)],[int(2),int(1)]],Res,unknown,_WF), |
| 3616 | | kernel_objects:equal_object(Res,[int(1)]))). |
| 3617 | | :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(1)],X,[int(2),int(3),int(1)]],Res,unknown,_WF), |
| 3618 | | X = [int(2),int(1)], |
| 3619 | | kernel_objects:equal_object(Res,[int(1)]))). |
| 3620 | | :- assert_must_succeed((kernel_objects:intersection_generalized_wf([X,X,[int(2),int(3),int(1)]],Res,unknown,_WF), |
| 3621 | | X = [int(2),int(1)], kernel_objects:equal_object(Res,[int(1),int(2)]))). |
| 3622 | | :- assert_must_succeed((kernel_objects:intersection_generalized_wf([[int(2),int(1),int(3)],X,[int(1),int(2)],X],Res,unknown,_WF), |
| 3623 | | kernel_objects:equal_object(X,Res), X = [int(2),int(1)])). |
| 3624 | | :- assert_must_succeed((kernel_objects:intersection_generalized_wf([global_set('Name'),X],Res,unknown,_WF), |
| 3625 | | kernel_objects:equal_object(X,Res), X = [fd(2,'Name'),fd(1,'Name')])). |
| 3626 | | :- assert_must_fail((kernel_objects:intersection_generalized_wf([[int(1)],[int(2)]],Res,unknown,_WF),( |
| 3627 | | kernel_objects:equal_object(Res,[_|_])))). |
| 3628 | | :- assert_must_fail((kernel_objects:intersection_generalized_wf([[int(1)],[int(1)]],Res,unknown,_WF),(Res=[]; |
| 3629 | | kernel_objects:equal_object(Res,[_,_|_])))). |
| 3630 | | :- assert_must_abort_wf(kernel_objects:intersection_generalized_wf([],_R,unknown,WF),WF). |
| 3631 | | |
| 3632 | | % code for general_intersection |
| 3633 | | :- block intersection_generalized_wf(-,?,?,?). |
| 3634 | | intersection_generalized_wf(SetsOfSets,Res,Span,WF) :- |
| 3635 | | expand_custom_set_to_list_wf(SetsOfSets,ESetsOfSets,_,intersection_generalized_wf,WF), |
| 3636 | | intersection_generalized2(ESetsOfSets,Res,Span,WF). |
| 3637 | | |
| 3638 | | intersection_generalized2([],Res,Span,WF) :- /* Atelier-B manual requires argument to inter to be non-empty */ |
| 3639 | | add_wd_error_set_result('inter applied to empty set','',Res,[],Span,WF). |
| 3640 | | intersection_generalized2([H|T],Res,_Span,WF) :- intersection_generalized3(T,H,Res,WF). |
| 3641 | | :- block intersection_generalized3(-,?,?,?). |
| 3642 | | intersection_generalized3([],SoFar,Res,WF) :- equal_object_optimized_wf(SoFar,Res,intersection_generalized3,WF). |
| 3643 | | intersection_generalized3([H|T],InterSoFar,Res,WF) :- |
| 3644 | | intersection(H,InterSoFar,InterSoFar2,WF), |
| 3645 | | intersection_generalized3(T,InterSoFar2,Res,WF). |
| 3646 | | |
| 3647 | | :- assert_must_succeed(exhaustive_kernel_check(difference_set([int(3),int(2)],[int(2),int(1),int(3)],[]))). |
| 3648 | | :- assert_must_succeed(exhaustive_kernel_check(difference_set([int(3),int(2)],[int(2),int(1),int(4)],[int(3)]))). |
| 3649 | | :- assert_must_succeed((kernel_objects:difference_set(SSS,[[int(1),int(2)]],[]), |
| 3650 | | kernel_objects:equal_object(SSS,[[int(2),int(1)]]))). |
| 3651 | | :- assert_must_succeed((kernel_objects:difference_set(SSS,[[int(1),int(2)]],R), kernel_objects:equal_object(R,[]), |
| 3652 | | kernel_objects:equal_object(SSS,[[int(2),int(1)]]))). |
| 3653 | | :- assert_must_succeed((kernel_objects:difference_set(SSS,[[fd(1,'Name'),fd(2,'Name')]],R), |
| 3654 | | kernel_objects:equal_object(R,[]), |
| 3655 | | kernel_objects:equal_object(SSS,[[fd(2,'Name'),fd(1,'Name')]]))). |
| 3656 | | :- assert_must_succeed((kernel_objects:difference_set(SSS,[[int(1),int(2)]],[]), |
| 3657 | | kernel_objects:equal_object(SSS,[[int(1),int(2)]]))). |
| 3658 | | :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[int(1)],_))). |
| 3659 | | :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[int(2)],_))). |
| 3660 | | :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[int(2)],[int(1)]))). |
| 3661 | | :- assert_must_succeed((kernel_objects:difference_set([int(1),int(2)],[],[int(2),int(1)]))). |
| 3662 | | :- assert_must_succeed((kernel_objects:difference_set([],[int(1),int(2)],[]))). |
| 3663 | | :- assert_must_succeed((kernel_objects:difference_set(Y,X,Res),X=global_set('Name'), |
| 3664 | | kernel_objects:equal_object(Res,[]), Y =[fd(1,'Name')])). |
| 3665 | | :- assert_must_succeed((kernel_objects:difference_set(X,Y,Res),X=global_set('Name'), |
| 3666 | | kernel_objects:equal_object(Res,[fd(3,'Name'),fd(1,'Name')]), Y =[fd(2,'Name')])). |
| 3667 | | :- assert_must_fail((kernel_objects:difference_set(X,Y,Res),X=global_set('Name'), |
| 3668 | | kernel_objects:equal_object(Res,[]), Y =[fd(1,'Name'),fd(2,'Name')])). |
| 3669 | | :- assert_must_fail((kernel_objects:difference_set(Y,X,Res),X=global_set('Name'), |
| 3670 | | kernel_objects:equal_object(Res,Y), Y =[fd(1,'Name')])). |
| 3671 | | |
| 3672 | | % deals with set_subtraction AST node |
| 3673 | | difference_set(Set1,Set2,Res) :- init_wait_flags(WF), |
| 3674 | | difference_set_wf(Set1,Set2,Res,WF), |
| 3675 | | ground_wait_flags(WF). |
| 3676 | | |
| 3677 | | :- block difference_set_wf(-,-,?,?). |
| 3678 | | difference_set_wf(Set1,_,Res,WF) :- Set1==[],!,empty_set_wf(Res,WF). |
| 3679 | | difference_set_wf(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,difference_set_wf,WF). |
| 3680 | | difference_set_wf(Set1,Set2,Res,WF) :- difference_set1(Set1,Set2,Res,WF). |
| 3681 | | |
| 3682 | | |
| 3683 | | :- block difference_set1(?,-,-,?), difference_set1(-,?,-,?). |
| 3684 | | difference_set1(Set1,Set2,Res,WF) :- |
| 3685 | | nonvar(Set1),is_custom_explicit_set(Set1,difference_set), |
| 3686 | | difference_of_explicit_set_wf(Set1,Set2,Diff,WF), !, |
| 3687 | | equal_object_wf(Diff,Res,difference_set1_1,WF). |
| 3688 | | difference_set1(Set1,Set2,Res,WF) :- Set2==[],!,equal_object_wf(Set1,Res,difference_set1_2,WF). |
| 3689 | | difference_set1(Set1,Set2,Res,WF) :- Res==[],!, check_subset_of_wf(Set1,Set2,WF). |
| 3690 | | difference_set1(Set1,Set2,Res,WF) :- |
| 3691 | | expand_custom_set_to_list_wf(Set1,ESet1,_,difference_set1,WF), |
| 3692 | | compute_diff(ESet1,Set2,Res,WF), |
| 3693 | | propagate_into2(Res,ESet1,Set2,WF). |
| 3694 | | |
| 3695 | | :- block compute_diff(-,?,?,?). |
| 3696 | ? | compute_diff([],_Set2,Res,WF) :- empty_set_wf(Res,WF). |
| 3697 | | compute_diff([H|T],Set2,Res,WF) :- |
| 3698 | ? | membership_test_wf(Set2,H,MemRes,WF),compute_diff2(MemRes,H,T,Set2,Res,WF). |
| 3699 | | |
| 3700 | | :- block compute_diff2(-,?,?,?,?,?). |
| 3701 | ? | compute_diff2(pred_true,_H,T,Set2,Res,WF) :- compute_diff(T,Set2,Res,WF). |
| 3702 | ? | compute_diff2(pred_false,H,T,Set2,Res,WF) :- equal_object_wf([H|R2],Res,compute_diff2,WF), |
| 3703 | ? | compute_diff(T,Set2,R2,WF). |
| 3704 | | |
| 3705 | | % propagate all elements from one set into another one; do not use for computation; may skip elements ... |
| 3706 | | /* this version not used at the moment: |
| 3707 | | :- block propagate_into(-,?,?). |
| 3708 | | propagate_into(_,Set2,_WF) :- nonvar(Set2), |
| 3709 | | is_custom_explicit_set(Set2,propagate_into),!. % second set already fully known |
| 3710 | | propagate_into([],_,_WF) :- !. |
| 3711 | | propagate_into([H|T],Set,WF) :- !,check_element_of_wf(H,Set,WF), propagate_into(T,Set,WF). |
| 3712 | | propagate_into(Set1,Set2,WF) :- is_custom_explicit_set(Set1,propagate_into),!, |
| 3713 | | (is_infinite_explicit_set(Set1) -> true ; |
| 3714 | | expand_custom_set_to_list(Set1,ESet1), propagate_into(ESet1,Set2,WF)). */ |
| 3715 | | |
| 3716 | | :- block propagate_into2(-,?,?,?). |
| 3717 | | propagate_into2(_,Set2,_NegSet,_WF) :- nonvar(Set2), |
| 3718 | | is_custom_explicit_set(Set2,propagate_into),!. % second set already fully known |
| 3719 | | propagate_into2([],_,_,_WF) :- !. |
| 3720 | | propagate_into2([H|T],PosSet,NegSet,WF) :- !, |
| 3721 | | check_element_of_wf(H,PosSet,WF), |
| 3722 | ? | not_element_of_wf(H,NegSet,WF),propagate_into2(T,PosSet,NegSet,WF). |
| 3723 | | propagate_into2(Set1,PosSet,NegSet,WF) :- is_custom_explicit_set(Set1,propagate_into),!, |
| 3724 | | (is_infinite_explicit_set(Set1) -> true ; |
| 3725 | | expand_custom_set_to_list_wf(Set1,ESet1,_,propagate_into2,WF), propagate_into2(ESet1,PosSet,NegSet,WF)). |
| 3726 | | |
| 3727 | | :- 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)). |
| 3728 | | :- block in_difference_set_wf(-,-,-,?). |
| 3729 | | in_difference_set_wf(A,X,Y,WF) :- |
| 3730 | | (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)), |
| 3731 | | % symbolic treatment would also make sense when A is nonvar and X var to force A to be in X ?! |
| 3732 | | !, |
| 3733 | ? | check_element_of_wf(A,X,WF), not_element_of_wf(A,Y,WF). |
| 3734 | | in_difference_set_wf(A,X,Y,WF) :- |
| 3735 | | difference_set_wf(X,Y,Diff,WF), |
| 3736 | | check_element_of_wf(A,Diff,WF). |
| 3737 | | |
| 3738 | | treat_arg_symbolically(X) :- var(X),!. |
| 3739 | | treat_arg_symbolically(global_set(_)). |
| 3740 | | treat_arg_symbolically(freetype(_)). |
| 3741 | | treat_arg_symbolically(closure(P,T,B)) :- \+ small_interval(P,T,B). |
| 3742 | | |
| 3743 | | small_interval(P,T,B) :- is_interval_closure(P,T,B,Low,Up), |
| 3744 | | integer(Low), integer(Up), |
| 3745 | | Up-Low < 500. % Magic Constant; TO DO: determine good value |
| 3746 | | |
| 3747 | | |
| 3748 | | :- 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)). |
| 3749 | | :- 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)). |
| 3750 | | :- 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)). |
| 3751 | | |
| 3752 | | :- block not_in_difference_set_wf(-,-,-,?). |
| 3753 | | not_in_difference_set_wf(A,X,Y,WF) :- |
| 3754 | | (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)), |
| 3755 | | !, |
| 3756 | | % A : (X-Y) <=> A:X & not(A:Y) |
| 3757 | | % A /: (X-Y) <=> A/: X or A:Y |
| 3758 | | membership_test_wf(X,A,AX_Res,WF), |
| 3759 | | (AX_Res==pred_false -> true |
| 3760 | | ; bool_pred:negate(AX_Res,NotAX_Res), |
| 3761 | | 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 ? |
| 3762 | ? | membership_test_wf(Y,A,AY_Res,WF) |
| 3763 | | ). |
| 3764 | | not_in_difference_set_wf(A,X,Y,WF) :- |
| 3765 | | difference_set_wf(X,Y,Diff,WF), |
| 3766 | | not_element_of_wf(A,Diff,WF). |
| 3767 | | |
| 3768 | | |
| 3769 | | :- 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)). |
| 3770 | | |
| 3771 | | :- block in_intersection_set_wf(-,-,-,?). |
| 3772 | | in_intersection_set_wf(A,X,Y,WF) :- |
| 3773 | | (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) |
| 3774 | | ; preference(convert_comprehension_sets_into_closures,true)), |
| 3775 | | (preference(data_validation_mode,true) -> nonvar(X) ; true), |
| 3776 | | % otherwise we may change enumeration order and enumerate with Y first; |
| 3777 | | % see private_examples/ClearSy/2019_May/perf_3264/rule_186.mch (but also test 1976); |
| 3778 | | % we could check if A is ground |
| 3779 | | !, |
| 3780 | | Y \== [], % avoid setting up check_element_of for X then |
| 3781 | | check_element_of_wf(A,X,WF), check_element_of_wf(A,Y,WF). |
| 3782 | | in_intersection_set_wf(A,X,Y,WF) :- |
| 3783 | | intersection(X,Y,Inter,WF), |
| 3784 | | check_element_of_wf(A,Inter,WF). |
| 3785 | | |
| 3786 | | :- 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)). |
| 3787 | | :- block not_in_intersection_set_wf(-,-,-,?). |
| 3788 | | not_in_intersection_set_wf(_A,_X,Y,_WF) :- Y == [], !. % intersection will be empty; avoid analysing X |
| 3789 | | not_in_intersection_set_wf(A,X,Y,WF) :- |
| 3790 | | (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)), |
| 3791 | | !, |
| 3792 | | % A : (X /\ Y) <=> A:X & A:Y |
| 3793 | | % A /: (X /\ Y) <=> A/:X or A/:Y |
| 3794 | | membership_test_wf(X,A,AX_Res,WF), |
| 3795 | | (AX_Res==pred_false -> true |
| 3796 | | ; bool_pred:negate(AX_Res,NotAX_Res), bool_pred:negate(AY_Res,NotAY_Res), |
| 3797 | | 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 ? |
| 3798 | | membership_test_wf(Y,A,AY_Res,WF) |
| 3799 | | ). |
| 3800 | | not_in_intersection_set_wf(A,X,Y,WF) :- |
| 3801 | | intersection(X,Y,Inter,WF), |
| 3802 | | not_element_of_wf(A,Inter,WF). |
| 3803 | | |
| 3804 | | :- 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)). |
| 3805 | | :- 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)). |
| 3806 | | |
| 3807 | | :- block in_union_set_wf(-,-,-,?). |
| 3808 | | in_union_set_wf(A,X,Y,WF) :- |
| 3809 | | (treat_arg_symbolically(X) ; treat_arg_symbolically(Y) ; preference(convert_comprehension_sets_into_closures,true)), |
| 3810 | | % symbolic treatment would also make sense when A is nonvar and X var to force A to be in X ?! |
| 3811 | | !, |
| 3812 | | membership_test_wf(X,A,AX_Res,WF), |
| 3813 | | (AX_Res==pred_true -> true |
| 3814 | | ; 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 ? |
| 3815 | | membership_test_wf(Y,A,AY_Res,WF) |
| 3816 | | ). |
| 3817 | | in_union_set_wf(A,X,Y,WF) :- |
| 3818 | | union_wf(X,Y,Union,WF), |
| 3819 | | check_element_of_wf(A,Union,WF). |
| 3820 | | |
| 3821 | | :- 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)). |
| 3822 | | |
| 3823 | | :- block not_in_union_set_wf(-,-,-,?). |
| 3824 | | not_in_union_set_wf(A,X,Y,WF) :- |
| 3825 | | not_element_of_wf(A,X,WF), |
| 3826 | | not_element_of_wf(A,Y,WF). |
| 3827 | | |
| 3828 | | % --------------------- |
| 3829 | | |
| 3830 | | |
| 3831 | | strict_subset_of(X,Y) :- |
| 3832 | | init_wait_flags(WF,[strict_subset_of]), |
| 3833 | | strict_subset_of_wf(X,Y,WF), |
| 3834 | | ground_wait_flags(WF). |
| 3835 | | |
| 3836 | | :- assert_must_succeed(exhaustive_kernel_check(strict_subset_of_wf([int(3),int(2)],[int(2),int(1),int(3)],_))). |
| 3837 | | :- assert_must_succeed(exhaustive_kernel_check(strict_subset_of_wf([],[int(2),int(1),int(3)],_))). |
| 3838 | | :- assert_must_succeed(exhaustive_kernel_check(strict_subset_of_wf([],[ [] ],_))). |
| 3839 | | :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([int(3),int(2),int(1)],[int(2),int(1),int(3)],_))). |
| 3840 | | :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([int(1),int(4)],[int(2),int(1),int(3)],_))). |
| 3841 | | :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([[]],[],_))). |
| 3842 | | :- assert_must_succeed(exhaustive_kernel_fail_check(strict_subset_of_wf([],[],_))). |
| 3843 | | :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [int(1)], X=[int(2),int(1)])). |
| 3844 | | :- assert_must_succeed((kernel_objects:strict_subset_of(Y,X), Y = [int(1)], X=[int(2),int(1)])). |
| 3845 | | :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [], X=[int(2),int(1)])). |
| 3846 | | :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [[int(1),int(2)]], X=[[int(2)],[int(2),int(1)]])). |
| 3847 | | :- assert_must_succeed((kernel_objects:strict_subset_of_wf(Y,X,_WF), Y = [fd(1,'Name')], kernel_objects:equal_object(X,global_set('Name')))). |
| 3848 | | :- 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')))). |
| 3849 | | :- 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'))). |
| 3850 | | :- 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')))). |
| 3851 | | :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(1)], X=[int(2),int(1)])). |
| 3852 | | :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(1),int(2)], X=[int(2),int(1)])). |
| 3853 | | :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(2)], X=[int(2)])). |
| 3854 | | :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [int(2)], X=[int(1)])). |
| 3855 | | :- assert_must_fail((kernel_objects:strict_subset_of_wf(X,Y,_WF), Y = [], X=[int(1)])). |
| 3856 | | |
| 3857 | | |
| 3858 | | :- use_module(chrsrc(chr_set_membership),[chr_subset_strict/2, chr_not_subset_strict/2]). |
| 3859 | | :- use_module(chrsrc(chr_integer_inequality),[chr_in_interval/4]). |
| 3860 | | |
| 3861 | | strict_subset_of_wf(Set1,Set2,WF) :- |
| 3862 | | (preference(use_chr_solver,true) -> chr_subset_strict(Set1,Set2) |
| 3863 | | ; Set1 \== Set2), % relevant for test 1326 |
| 3864 | ? | strict_subset_of_wf_aux(Set1,Set2,WF). |
| 3865 | | |
| 3866 | | %:- block strict_subset_of_wf(-,-,?). |
| 3867 | | strict_subset_of_wf_aux(Set1,Set2,WF) :- Set1==[],!,not_empty_set_wf(Set2,WF). |
| 3868 | | %strict_subset_of_wf_aux(Set1,Set2,WF) :- var(Set2),nonvar(Set1), print(subs(Set1,Set2)),nl,fail. |
| 3869 | | strict_subset_of_wf_aux(Set1,Set2,WF) :- nonvar(Set2), singleton_set(Set2,_),!, empty_set_wf(Set1,WF). |
| 3870 | | strict_subset_of_wf_aux(Set1,Set2,WF) :- |
| 3871 | | not_empty_set_wf(Set2,WF), |
| 3872 | | get_cardinality_powset_wait_flag(Set2,strict_subset_of_wf,WF,_,LWF), |
| 3873 | | % we could subtract 1 from priority !? (get_cardinality_pow1set_wait_flag) |
| 3874 | ? | when(((nonvar(LWF),(nonvar(Set1);ground(Set2))) ; (nonvar(Set1),nonvar(Set2)) ), |
| 3875 | | strict_subset_of_aux_block(Set1,Set2,WF,LWF)). |
| 3876 | | |
| 3877 | | strict_subset_of_aux_block(Set1,_Set2,_WF,_LWF) :- |
| 3878 | | Set1==[], |
| 3879 | | !. % we have already checked that Set2 is not empty |
| 3880 | | strict_subset_of_aux_block(Set1,Set2,WF,_LWF) :- |
| 3881 | | nonvar(Set2), is_definitely_maximal_set(Set2), |
| 3882 | | !, |
| 3883 | | not_equal_object_wf(Set1,Set2,WF). |
| 3884 | | strict_subset_of_aux_block(Set1,Set2,WF,_LWF) :- nonvar(Set2), singleton_set(Set2,_),!, empty_set_wf(Set1,WF). |
| 3885 | | strict_subset_of_aux_block(Set1,Set2,_WF,_LWF) :- |
| 3886 | | both_global_sets(Set1,Set2,G1,G2), |
| 3887 | | !, %(print(check_strict_subset_of_global_sets(G1,G2)),nl, |
| 3888 | ? | check_strict_subset_of_global_sets(G1,G2). |
| 3889 | | strict_subset_of_aux_block(Set1,Set2,WF,LWF) :- |
| 3890 | | var(Set1), nonvar(Set2), Set2=avl_set(_), |
| 3891 | | check_card_waitflag_less(LWF,4097), % if the number is too big strict_subset_of0 has better chance of working ?! |
| 3892 | | % without avl_set check test 1003 leads to time out for plavis-TransData_SP_13.prob, with |
| 3893 | | % memp : seq(STRING) & dom(memp) <<: ( mdp + 1 .. ( mdp + 43 ) ) |
| 3894 | | !, |
| 3895 | | %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 |
| 3896 | | expand_custom_set_to_list_wf(Set2,ESet2,_,strict_subset_of_wf,WF), |
| 3897 | | gen_strict_subsets(Set1,ESet2,WF). |
| 3898 | | strict_subset_of_aux_block(Set1,Set2,WF,LWF) :- |
| 3899 | ? | strict_subset_of0(Set1,Set2,WF,LWF). |
| 3900 | | % TO DO (26.10.2014): test 1270 now passes thanks to maximal set check above |
| 3901 | | % but we should need a better way of ensuring that something like {ssu|ssu<<:POW(elements)} is efficiently computed |
| 3902 | | % (which it no longer is once the unbound_variable check had been fixed) |
| 3903 | | % we could also just generally use Set1 <: Set2 & Set1 /= Set2 |
| 3904 | | |
| 3905 | | check_card_waitflag_less(float(Nr),Limit) :- number(Nr), Nr<Limit. |
| 3906 | | |
| 3907 | | % avoid generating different ordering of the same subset ([1,2] and [2,1] for example), useful for test 642 |
| 3908 | | % Note: remove_element_wf in strict_subset_of2 will create different orders |
| 3909 | | % for sequence domains gen_strict_subsets uses just the wrong order (deciding to remove 1 first); |
| 3910 | | % cf test 1003 where not including 1 in domain is bad: memp : seq(STRING) & dom(memp) <<: ( mdp + 1 .. ( mdp + 43 ) ) |
| 3911 | | gen_strict_subsets(T,[H2|T2],WF) :- |
| 3912 | | not_element_of_wf(H2,T,WF), |
| 3913 | | gen_subsets(T,T2,WF). |
| 3914 | | gen_strict_subsets(SubSet,[H2|T2],WF) :- |
| 3915 | | equal_object_wf([H2|T],SubSet,gen_strict_subsets,WF), |
| 3916 | | gen_strict_subsets(T,T2,WF). |
| 3917 | | |
| 3918 | | |
| 3919 | | %:- block strict_subset_of0(-,?,?,?). % required to wait: we know Set2 must be non-empty, but Set1 could be an avl-tree or closure |
| 3920 | | % TO DO: deal with infinite Set1 |
| 3921 | | strict_subset_of0(Set1,Set2,WF,LWF) :- |
| 3922 | | expand_custom_set_to_list_wf(Set1,ESet1,_,strict_subset_of0,WF), |
| 3923 | | (ESet1==[] -> true %not_empty_set(Set2) already checked above |
| 3924 | ? | ; is_infinite_explicit_set(Set2) -> |
| 3925 | | % Set1 is expanded to a list ESet1 and thus finite: it is sufficient to check subset relation |
| 3926 | | check_subset_of_wf(ESet1,Set2,WF) |
| 3927 | | ; try_expand_custom_set_wf(Set2,ESet2,strict_subset_of0,WF), |
| 3928 | | %%try_prop_card_lt(ESet1,ESet2), try_prop_card_gt(ESet2,ESet1), |
| 3929 | ? | strict_subset_of2(ESet1,[],ESet2,WF,LWF) |
| 3930 | | ). |
| 3931 | | |
| 3932 | | :- block strict_subset_of2(-,?,?,?,-). |
| 3933 | | %strict_subset_of2(S,SoFar,Set2,WF) :- print(strict_subset_of2(S,SoFar,Set2,WF)),nl,fail. |
| 3934 | ? | strict_subset_of2([],_,RemS,WF,_LWF) :- not_empty_set_wf(RemS,WF). /* we know it must be explicit set */ |
| 3935 | | strict_subset_of2([H|T],SoFar,Set2,WF,LWF) :- var(Set2),!, |
| 3936 | | Set2 = [H|Set2R], |
| 3937 | | add_new_element_wf(H,SoFar,SoFar2,WF), %was SoFar2 = [H|SoFar], |
| 3938 | ? | strict_subset_of2(T,SoFar2,Set2R,WF,LWF). |
| 3939 | | strict_subset_of2([H|T],SoFar,Set2,WF,LWF) :- |
| 3940 | | % when_sufficiently_for_member(H,Set2,WF, |
| 3941 | ? | remove_element_wf(H,Set2,RS2,WF), |
| 3942 | ? | not_empty_set_wf(RS2,WF), |
| 3943 | | not_element_of_wf(H,SoFar,WF), /* consistent((H,SoFar)), necessary? */ |
| 3944 | | when((nonvar(T) ; (ground(LWF),ground(RS2))), |
| 3945 | | (add_new_element_wf(H,SoFar,SoFar2,WF), %SoFar2 = [H|SoFar], |
| 3946 | | strict_subset_of2(T,SoFar2,RS2,WF,LWF) )). |
| 3947 | | |
| 3948 | | |
| 3949 | | |
| 3950 | | |
| 3951 | | :- assert_must_succeed(exhaustive_kernel_check(partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ],_))). |
| 3952 | | :- assert_must_succeed(exhaustive_kernel_check(partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)] ],_))). |
| 3953 | | :- assert_must_succeed(exhaustive_kernel_check(partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5)],[int(1)] ],_))). |
| 3954 | | :- assert_must_succeed(exhaustive_kernel_fail_check(partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)], [int(3)] ],_))). |
| 3955 | | :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ], _))). |
| 3956 | | :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2)],[ [int(2)], [int(1)], [] ], _))). |
| 3957 | | :- assert_must_fail((kernel_objects:partition_wf([int(1),int(2)],[ [int(2)], [int(1),int(2)] ], _))). |
| 3958 | | :- assert_must_fail((kernel_objects:partition_wf([int(1),int(3)],[ [int(1)], [int(2)] ], _))). |
| 3959 | | :- assert_must_fail((kernel_objects:partition_wf([int(1),int(2),int(3)],[ [int(1)], [int(2)] ], _))). |
| 3960 | | :- assert_must_succeed((kernel_objects:partition_wf([int(1)],[S1,S2],_WF), S1=[H|T], S2==[],T==[],H==int(1))). |
| 3961 | | :- 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)))). |
| 3962 | | :- 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))). |
| 3963 | | :- assert_must_succeed((kernel_objects:partition_wf([int(1),int(2),int(3)],[[int(1)],X,[int(2)]],_WF), |
| 3964 | | X==[int(3)])). |
| 3965 | | |
| 3966 | | :- use_module(bsets_clp,[disjoint_union_generalized_wf/3]). |
| 3967 | | :- use_module(kernel_tools,[ground_value/1]). |
| 3968 | | :- block partition_wf(?,-,?). |
| 3969 | | partition_wf(Set,ListOfSets,WF) :- |
| 3970 | | partition_disj_union_wf(Set,ListOfSets,WF), |
| 3971 | | all_disjoint(ListOfSets,WF). |
| 3972 | | |
| 3973 | | % just check that the disjoint union of all sets is equal to Set |
| 3974 | | partition_disj_union_wf(Set,ListOfSets,WF) :- |
| 3975 | | ground_value(Set),find_non_ground_set(ListOfSets,NGS,Rest),!, |
| 3976 | | disjoint_union_generalized_wf(Rest,RestSet,WF), |
| 3977 | | check_subset_of_wf(RestSet,Set,WF), % otherwise this is not a partition of Set |
| 3978 | | difference_set(Set,RestSet,NGS). |
| 3979 | | partition_disj_union_wf(Set,ListOfSets,WF) :- |
| 3980 | | disjoint_union_generalized_wf(ListOfSets,Set,WF). |
| 3981 | | |
| 3982 | | :- 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)])). |
| 3983 | | find_non_ground_set([H|T],NG,Rest) :- |
| 3984 | | (ground_value(H) -> Rest=[H|TR], find_non_ground_set(T,NG,TR) |
| 3985 | | ; ground_value(T),NG=H, Rest=T). |
| 3986 | | |
| 3987 | | :- block all_disjoint(-,?). |
| 3988 | | % check if a list of sets is all disjoint (Note: this is not a set of sets) |
| 3989 | | all_disjoint([],_WF) :- !. |
| 3990 | | all_disjoint([H|T],WF) :- !, |
| 3991 | | all_disjoint_with(T,H,WF), |
| 3992 | | all_disjoint(T,WF). |
| 3993 | | all_disjoint(S,WF) :- add_internal_error('Not a list for partition:',all_disjoint(S,WF)),fail. |
| 3994 | | |
| 3995 | | :- block all_disjoint_with(-,?,?). |
| 3996 | | all_disjoint_with([],_,_WF). |
| 3997 | | all_disjoint_with([H|T],Set1,WF) :- disjoint_sets(Set1,H,WF), all_disjoint_with(T,Set1,WF). |
| 3998 | | |
| 3999 | | |
| 4000 | | % a utility to check for duplicates in set lists and enter debugger |
| 4001 | | %:- block check_set_for_repetitions(-,?). |
| 4002 | | %check_set_for_repetitions([],_) :- !. |
| 4003 | | %check_set_for_repetitions([H|T],Acc) :- !, |
| 4004 | | % when(ground(H),(member(H,Acc) -> tools:print_bt_message(duplicate(H,Acc)),trace |
| 4005 | | % ; check_set_for_repetitions(T,[H|Acc]))). |
| 4006 | | %check_set_for_repetitions(_,_). |
| 4007 | | |
| 4008 | | :- assert_must_succeed(exhaustive_kernel_fail_check(not_partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ],_))). |
| 4009 | | :- assert_must_succeed(exhaustive_kernel_fail_check(not_partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)] ],_))). |
| 4010 | | :- assert_must_succeed(exhaustive_kernel_fail_check(not_partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5)],[int(1)] ],_))). |
| 4011 | | :- assert_must_succeed(exhaustive_kernel_check(not_partition_wf([int(1),int(2),int(5)],[ [int(2)], [int(5),int(1)], [int(3)] ],_))). |
| 4012 | | :- assert_must_fail((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(2)], [int(1)] ], _))). |
| 4013 | | :- assert_must_fail((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(2)], [int(1)], [] ], _))). |
| 4014 | | :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(2)], [int(1),int(2)] ], _))). |
| 4015 | | :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(3)],[ [int(1)], [int(2)] ], _))). |
| 4016 | | :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(2),int(3)],[ [int(1)], [int(2)] ], _))). |
| 4017 | | :- assert_must_succeed((kernel_objects:not_partition_wf([int(1),int(2)],[ [int(1),int(2)], [int(1),int(2)] ], _))). |
| 4018 | | |
| 4019 | | not_partition_wf(FullSet,ListOfSets,WF) :- |
| 4020 | | test_partition_wf(FullSet,ListOfSets,pred_false,WF). |
| 4021 | | |
| 4022 | | |
| 4023 | | :- use_module(b_interpreter_check,[imply_true/2]). % TODO: move to another module |
| 4024 | | :- block test_partition_wf(?,-,?,?). |
| 4025 | | test_partition_wf(FullSet,ListOfSets,PredRes,WF) :- |
| 4026 | | bool_pred:negate(PredRes,NotPredRes), |
| 4027 | | propagate_partition_true(FullSet,ListOfSets,PredRes,WF), |
| 4028 | ? | test_partition_wf2(ListOfSets,[],FullSet,PredRes,NotPredRes,WF). |
| 4029 | | |
| 4030 | | :- block propagate_partition_true(?,?,-,?). |
| 4031 | | propagate_partition_true(FullSet,ListOfSets,pred_true,WF) :- |
| 4032 | | % ensure we propagate more info; required for tests 1059, 1060 |
| 4033 | | partition_disj_union_wf(FullSet,ListOfSets,WF). |
| 4034 | | propagate_partition_true(_,_,pred_false,_). |
| 4035 | | |
| 4036 | | :- block test_partition_wf2(-,?,?, ?,?,?). |
| 4037 | | %test_partition_wf2(Sets,SoFar,_,Pred,_,_) :- print_term_summary(test_partition_wf2(Sets,SoFar,Pred)),nl,fail. |
| 4038 | ? | test_partition_wf2([],ElementsSoFar,FullSet,PredRes,_,WF) :- !, equality_objects_wf(ElementsSoFar,FullSet,PredRes,WF). |
| 4039 | | test_partition_wf2([Set1|Rest],ElementsSoFar,FullSet,PredRes,NotPredRes,WF) :- !, |
| 4040 | | expand_custom_set_to_list_wf(Set1,ESet1,_,test_partition_wf2,WF), % TODO: requires finite set; choose instantiated sets first |
| 4041 | ? | test_partition_wf3(ESet1,ElementsSoFar,ElementsSoFar,Rest,FullSet,PredRes,NotPredRes,WF). |
| 4042 | | test_partition_wf2(A,E,FS,PR,NPR,WF) :- |
| 4043 | | add_internal_error('Not a list for partition:',test_partition_wf2(A,E,FS,PR,NPR,WF)),fail. |
| 4044 | | |
| 4045 | | :- block test_partition_wf3(-,?,?,?, ?,?,?,?). |
| 4046 | | test_partition_wf3([],_,NewElementsSoFar,OtherSets,FullSet,PredRes,NPR,WF) :- |
| 4047 | ? | test_partition_wf2(OtherSets,NewElementsSoFar,FullSet,PredRes,NPR,WF). % finished treating this set |
| 4048 | | test_partition_wf3([H|T],ElementsSoFar,NewElementsSoFar,OtherSets,FullSet,PredRes,NotPredRes,WF) :- |
| 4049 | | imply_true(MemRes,NotPredRes), % if not disjoint (MemRes=pred_true) then we do not have a partition |
| 4050 | | membership_test_wf(ElementsSoFar,H,MemRes,WF), |
| 4051 | ? | test_partition_wf4(MemRes,H,T,ElementsSoFar,NewElementsSoFar,OtherSets,FullSet,PredRes,NotPredRes,WF). |
| 4052 | | |
| 4053 | | :- block test_partition_wf4(-,?,?,?,?, ?,?,?,?,?). |
| 4054 | | test_partition_wf4(pred_true,_,_,_,_,_,_,pred_false,_,_). % Not disjoint |
| 4055 | | test_partition_wf4(pred_false,H,T,ElementsSoFar,NewElementsSoFar,OtherSets,FullSet,PredRes,NotPredRes,WF) :- |
| 4056 | | add_element_wf(H,NewElementsSoFar,NewElementsSoFar2,WF), % we could also already check whether H in FullSet or not |
| 4057 | | %(PredRes==pred_true -> check_element_of_wf(H,FullSet,WF) ; true), |
| 4058 | ? | test_partition_wf3(T,ElementsSoFar,NewElementsSoFar2,OtherSets,FullSet,PredRes,NotPredRes,WF). |
| 4059 | | |
| 4060 | | |
| 4061 | | |
| 4062 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(check_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1),int(3)]))). |
| 4063 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(check_subset_of([int(1),int(2),int(5)],[int(2),int(5),int(1)]))). |
| 4064 | | :- assert_must_succeed(exhaustive_kernel_fail_check(check_subset_of([int(1),int(3),int(5)],[int(2),int(5),int(1)]))). |
| 4065 | | :- assert_must_succeed((kernel_objects:power_set(global_set('Name'),PS),kernel_objects:check_subset_of(X,PS), |
| 4066 | | kernel_objects:equal_object(X,[[fd(2,'Name'),fd(1,'Name')]]))). |
| 4067 | | :- assert_must_succeed(findall(X,kernel_objects:check_subset_of(X,[[int(1),int(2)],[]]),[_1,_2,_3,_4])). |
| 4068 | | :- assert_must_succeed((kernel_objects:check_subset_of(X,[[int(1),int(2)],[]]), |
| 4069 | | nonvar(X), |
| 4070 | | kernel_objects:equal_object(X,[[int(2),int(1)]]))). |
| 4071 | | :- assert_must_succeed((kernel_objects:check_subset_of_wf(Y,X,_WF), Y = [fd(1,'Name')], |
| 4072 | | nonvar(X),X=[H|T], var(T), H==fd(1,'Name'), X=Y)). |
| 4073 | | :- assert_must_succeed((kernel_objects:check_subset_of(Y,X), Y = [fd(1,'Name')], kernel_objects:equal_object(X,global_set('Name')))). |
| 4074 | | :- 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')))). |
| 4075 | | :- 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')))). |
| 4076 | | :- assert_must_succeed((kernel_objects:sample_closure(C),kernel_objects:check_subset_of(C,global_set('NAT')))). |
| 4077 | | :- assert_must_succeed((kernel_objects:check_subset_of(global_set('NAT'),global_set('NAT')))). |
| 4078 | | :- assert_must_succeed((kernel_objects:check_subset_of(global_set('NAT'),global_set('NATURAL')))). |
| 4079 | | :- assert_must_fail((kernel_objects:check_subset_of(global_set('NAT'),global_set('NATURAL1')))). |
| 4080 | | :- assert_must_fail((kernel_objects:check_subset_of(global_set('NAT'),global_set('NAT1')))). |
| 4081 | | :- assert_must_fail((kernel_objects:check_subset_of(X,Y), Y = [fd(1,'Name')], kernel_objects:equal_object(X,global_set('Name')))). |
| 4082 | | /* TO DO: add special treatment for closures and type checks !! */ |
| 4083 | | |
| 4084 | | check_subset_of(Set1,Set2) :- init_wait_flags(WF), |
| 4085 | | check_subset_of_wf(Set1,Set2,WF), |
| 4086 | | ground_wait_flags(WF). |
| 4087 | | |
| 4088 | | check_finite_subset_of_wf(Set1,Set2,WF) :- |
| 4089 | | check_subset_of_wf(Set1,Set2,WF), |
| 4090 | | is_finite_set_wf(Set1,WF). |
| 4091 | | |
| 4092 | | :- block check_subset_of_wf(-,-,?). |
| 4093 | | check_subset_of_wf(Set1,Set2,WF) :- |
| 4094 | | (both_global_sets(Set1,Set2,G1,G2) |
| 4095 | ? | -> check_subset_of_global_sets(G1,G2) |
| 4096 | ? | ; check_subset_of0(Set1,Set2,WF) |
| 4097 | | ). |
| 4098 | | |
| 4099 | | both_global_sets(S1,S2,G1,G2) :- nonvar(S1),nonvar(S2), |
| 4100 | | is_global_set(S1,G1), is_global_set(S2,G2). |
| 4101 | | |
| 4102 | | % check if we have a global set or interval |
| 4103 | | % is_global_set([],R) :- !, R=interval(0,-1). % useful ??? |
| 4104 | | is_global_set(global_set(G1),R) :- !, |
| 4105 | | (custom_explicit_sets:get_integer_set_interval(G1,Low,Up) -> R=interval(Low,Up) ; R=G1). |
| 4106 | | is_global_set(Closure,R) :- |
| 4107 | | custom_explicit_sets:is_interval_closure_or_integerset(Closure,Low,Up),!, |
| 4108 | | R=interval(Low,Up). |
| 4109 | | |
| 4110 | | |
| 4111 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(0,0),interval(minus_inf,inf))). |
| 4112 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(-200,1000),interval(minus_inf,inf))). |
| 4113 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(10,1000),interval(0,inf))). |
| 4114 | | :- assert_must_fail(kernel_objects:check_subset_of_global_sets(interval(-10,1000),interval(0,inf))). |
| 4115 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(0,inf),interval(0,inf))). |
| 4116 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(0,inf),interval(minus_inf,inf))). |
| 4117 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(1,inf),interval(0,inf))). |
| 4118 | | :- assert_must_succeed(kernel_objects:check_subset_of_global_sets(interval(1,inf),interval(minus_inf,inf))). |
| 4119 | | |
| 4120 | | % to do: also extend to allow intervals with inf/minus_inf |
| 4121 | | check_subset_of_global_sets(X,Y) :- (var(X) ; var(Y)), |
| 4122 | | add_internal_error('Illegal call: ',check_subset_of_global_sets(X,Y)),fail. |
| 4123 | | check_subset_of_global_sets(interval(Low1,Up1),interval(Low2,Up2)) :- !, |
| 4124 | ? | interval_subset(Low1,Up1,Low2,Up2). |
| 4125 | | check_subset_of_global_sets(X,X) :- !. % both args must be atomic and ground (global set names) |
| 4126 | | % BUT WE COULD HAVE {x|x>0} <: NATURAL1 ? interval(0,inf) <: NATURAL1 |
| 4127 | | check_subset_of_global_sets(X,Y) :- check_strict_subset_of_global_sets(X,Y). |
| 4128 | | |
| 4129 | | % To do: perform some treatment of inf, minus_inf values here <---- |
| 4130 | | interval_subset(Low1,Up1,Low2,Up2) :- |
| 4131 | | (var(Low1) ; var(Up1)), % otherwise we can use code below |
| 4132 | | finite_interval(Low1,Up1), finite_interval(Low2,Up2), % inf can appear as term; but only directly not later |
| 4133 | | !, |
| 4134 | | % Maybe to do: try to avoid CLPFD overflows if possible; pass WF to force case distinction between empty/non-empty intervals |
| 4135 | | clpfd_in_interval(Low1,Up1,Low2,Up2). |
| 4136 | | interval_subset(Low1,Up1,Low2,Up2) :- |
| 4137 | ? | interval_subset_aux(Low1,Up1,Low2,Up2). |
| 4138 | | |
| 4139 | | % check if we have a finite interval (fails for inf/minus_inf terms) |
| 4140 | | finite_interval(Low1,Up1) :- (var(Low1) -> true ; integer(Low1)), (var(Up1) -> true ; integer(Up1)). |
| 4141 | | finite_val(LowUp) :- (var(LowUp) -> true ; integer(LowUp)). |
| 4142 | | |
| 4143 | | |
| 4144 | | |
| 4145 | | % assert Low1..Up1 <: Low2..Up2 |
| 4146 | | clpfd_in_interval(Low1,Up1,Low2,Up2) :- |
| 4147 | | (preferences:preference(use_chr_solver,true) |
| 4148 | | -> chr_in_interval(Low1,Up1,Low2,Up2) ; true), |
| 4149 | | % TO DO: improve detection of Low1 #=< Up1; maybe outside of CHR ?; we could also add a choice point here |
| 4150 | | % example: p..q <: 0..25 & p<q -> should constrain p,q to p:0..24 & q:1..25 |
| 4151 | | clpfd_interface:post_constraint2((Low1 #=< Up1) #=> ((Low2 #=< Low1) #/\ (Up1 #=< Up2)),Posted), |
| 4152 | | (Posted==true -> true ; interval_subset_aux(Low1,Up1,Low2,Up2)). |
| 4153 | | |
| 4154 | | :- block interval_subset_aux(-,?,?,?), interval_subset_aux(?,-,?,?). |
| 4155 | | interval_subset_aux(Low1,Up1,_,_) :- safe_less_than_with_inf(Up1,Low1). %Set 1 is empty. |
| 4156 | | interval_subset_aux(Low1,Up1,Low2,Up2) :- |
| 4157 | | safe_less_than_equal_with_inf(Low1,Up1), % Set 1 is not empty |
| 4158 | | safe_less_than_equal_with_inf_clpfd(Low2,Low1), safe_less_than_equal_with_inf_clpfd(Up1,Up2). % may call CLPFD |
| 4159 | | |
| 4160 | | % a version of safe_less_than which allows minus_inf and inf, but only if those terms appear straightaway at the first call |
| 4161 | | % assumes any variable will only be bound to a number |
| 4162 | | safe_less_than_with_inf(X,Y) :- (X==Y ; X==inf ; Y==minus_inf), !,fail. |
| 4163 | | safe_less_than_with_inf(X,Y) :- (X==minus_inf ; Y==inf), !. |
| 4164 | | safe_less_than_with_inf(X,Y) :- safe_less_than(X,Y). |
| 4165 | | |
| 4166 | | safe_less_than_with_inf_clpfd(X,Y) :- (X==Y ; X==inf ; Y==minus_inf), !,fail. |
| 4167 | | safe_less_than_with_inf_clpfd(X,Y) :- (X==minus_inf ; Y==inf), !. |
| 4168 | | safe_less_than_with_inf_clpfd(X,Y) :- less_than_direct(X,Y). % this can also call CLPFD |
| 4169 | | |
| 4170 | | % a version of safe_less_than_equal which allows minus_inf and inf, but only if those terms appear straightaway at the first call |
| 4171 | | safe_less_than_equal_with_inf(X,Y) :- X==Y,!. |
| 4172 | | safe_less_than_equal_with_inf(X,Y) :- (X==inf ; Y==minus_inf), !,fail. |
| 4173 | | safe_less_than_equal_with_inf(X,Y) :- (X==minus_inf ; Y==inf), !. |
| 4174 | | safe_less_than_equal_with_inf(X,Y) :- safe_less_than_equal(X,Y). |
| 4175 | | |
| 4176 | | safe_less_than_equal_with_inf_clpfd(X,Y) :- X==Y,!. |
| 4177 | | safe_less_than_equal_with_inf_clpfd(X,Y) :- (X==inf ; Y==minus_inf), !,fail. |
| 4178 | | safe_less_than_equal_with_inf_clpfd(X,Y) :- (X==minus_inf ; Y==inf), !. |
| 4179 | | safe_less_than_equal_with_inf_clpfd(X,Y) :- less_than_equal_direct(X,Y). % this can also call CLPFD |
| 4180 | | |
| 4181 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,2),interval(1,3))). |
| 4182 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,1),interval(1,2))). |
| 4183 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,1),interval(0,1))). |
| 4184 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(2,1),interval(33,34))). |
| 4185 | | :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(3,1),interval(4,2))). |
| 4186 | | :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(3,1),interval(2,1))). |
| 4187 | | :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(1,2),interval(1,2))). |
| 4188 | | :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(1,2),interval(2,3))). |
| 4189 | | :- assert_must_fail(kernel_objects:check_strict_subset_of_global_sets(interval(2,3),interval(1,2))). |
| 4190 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(0,1000),interval(0,inf))). |
| 4191 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(1,1000),interval(1,inf))). |
| 4192 | | :- assert_must_succeed(kernel_objects:check_strict_subset_of_global_sets(interval(-200,1000),interval(minus_inf,inf))). |
| 4193 | | % for any other term we have global enumerated or deferred sets: they cannot be a strict subset of each other |
| 4194 | | check_strict_subset_of_global_sets('FLOAT','REAL'). |
| 4195 | | check_strict_subset_of_global_sets(interval(Low1,Up1),interval(Low2,Up2)) :- |
| 4196 | ? | check_strict_subset_intervals(Low1,Up1,Low2,Up2). |
| 4197 | | |
| 4198 | | check_strict_subset_intervals(Low1,Up1,Low2,Up2) :- |
| 4199 | | safe_less_than_equal_with_inf_clpfd(Low2,Up2), % Low2..Up2 not empty |
| 4200 | ? | check_strict_subset_intervals1(Low1,Up1,Low2,Up2). |
| 4201 | | |
| 4202 | | check_strict_subset_intervals1(Low1,Up1,Low2,Up2) :- % we cannot have inf as term (yet) here |
| 4203 | | %preferences:preference(use_clpfd_solver,true), |
| 4204 | | (var(Low1) ; var(Up1)), |
| 4205 | | finite_interval(Low1,Up1), finite_interval(Low2,Up2), |
| 4206 | | !, |
| 4207 | | clpfd_interface:post_constraint2((Low1 #=< Up1) #=> ((Low2 #=< Low1) #/\ (Up1 #=< Up2) #/\ (Low1 #\= Low2 #\/ Up1 #\= Up2)),Posted), |
| 4208 | | (Posted==true -> true ; check_strict_subset_intervals2(Low1,Up1,Low2,Up2)). |
| 4209 | ? | check_strict_subset_intervals1(Low1,Up1,Low2,Up2) :- check_strict_subset_intervals2(Low1,Up1,Low2,Up2). |
| 4210 | | |
| 4211 | | :- block check_strict_subset_intervals2(-,?,?,?),check_strict_subset_intervals2(?,-,?,?), |
| 4212 | | check_strict_subset_intervals2(?,?,-,?). |
| 4213 | | check_strict_subset_intervals2(Low1,Up1,_,_) :- safe_less_than_with_inf(Up1,Low1). % interval 1 empty |
| 4214 | | check_strict_subset_intervals2(Low1,Up1,Low2,Up2) :- |
| 4215 | | safe_less_than_equal_with_inf(Low1,Up1), % interval 1 not empty |
| 4216 | | ( safe_less_than_with_inf(Low2,Low1), safe_less_than_equal_with_inf_clpfd(Up1,Up2) |
| 4217 | | ; |
| 4218 | | Low1=Low2,safe_less_than_with_inf_clpfd(Up1,Up2) |
| 4219 | | ). |
| 4220 | | |
| 4221 | | :- use_module(custom_explicit_sets,[is_definitely_maximal_set/1,singleton_set/2]). |
| 4222 | | :- use_module(kernel_tools,[ground_value_check/2, quick_same_value/2]). |
| 4223 | | |
| 4224 | | check_subset_of0(Set1,_Set2,_WF) :- Set1==[],!. |
| 4225 | | check_subset_of0(Set1,Set2,WF) :- Set2==[], |
| 4226 | | %nonvar(Set2),Set2=[], %var(Set1), |
| 4227 | | !, |
| 4228 | | empty_set_wf(Set1,WF). |
| 4229 | | check_subset_of0(_Set1,Set2,_WF) :- |
| 4230 | | nonvar(Set2),is_definitely_maximal_set(Set2),!. |
| 4231 | | %singleton |
| 4232 | | check_subset_of0(Set1,Set2,_) :- |
| 4233 | | quick_same_value(Set1,Set2), % important for e.g. test 1948 for closures with different info fields |
| 4234 | | !. |
| 4235 | | check_subset_of0(Set1,Set2,WF) :- custom_explicit_sets:singleton_set(Set1,El),!, |
| 4236 | ? | check_element_of_wf(El,Set2,WF). |
| 4237 | | check_subset_of0(Set1,Set2,WF) :- % Note: two intervals are treated in check_subset_of_global_sets |
| 4238 | | subset_of_explicit_set(Set1,Set2,Code,WF),!, |
| 4239 | | call(Code). |
| 4240 | | check_subset_of0(Set1,Set2,WF) :- nonvar(Set1),!, |
| 4241 | | get_cardinality_powset_wait_flag(Set2,check_subset_of0,WF,_,LWF), |
| 4242 | | expand_custom_set_to_list_wf(Set1,ESet1,_,check_subset_of1,WF), |
| 4243 | | try_expand_and_convert_to_avl_unless_large_wf(Set2,ESet2,WF), |
| 4244 | | % b_interpreter_components:observe_instantiation(ESet1,'ESet1',ESet1), |
| 4245 | ? | check_subset_of2(ESet1,[],ESet2,WF,LWF,none). |
| 4246 | | check_subset_of0(Set1,Set2,WF) :- |
| 4247 | | is_wait_flag_info(WF,wfx_no_enumeration),!, |
| 4248 | | check_subset_of0_lwf(Set1,Set2,WF,_LWF,_). |
| 4249 | | check_subset_of0(Set1,Set2,WF) :- |
| 4250 | | % DO we need LWF if Set1=avl_set(_) ?? |
| 4251 | | get_cardinality_powset_wait_flag(Set2,check_subset_of0,WF,_Card,LWF), |
| 4252 | | ground_value_check(Set2,GS2), |
| 4253 | | check_subset_of0_lwf(Set1,Set2,WF,LWF,GS2). |
| 4254 | | |
| 4255 | | :- use_module(custom_explicit_sets,[is_infinite_or_very_large_explicit_set/2]). |
| 4256 | | |
| 4257 | | :- block check_subset_of0_lwf(-,?,?,-,?),check_subset_of0_lwf(-,?,?,?,-). |
| 4258 | | check_subset_of0_lwf(Set1,_Set2,_WF,_LWF,_GS2) :- Set1==[],!. |
| 4259 | | %check_subset_of0_lwf(Set1,Set2,WF,_LWF) :- Set2==[],!, % can never trigger as Set2 was already nonvar |
| 4260 | | % empty_set_wf(Set1,WF). |
| 4261 | | check_subset_of0_lwf(Set1,Set2,WF,_LWF,_GS2) :- custom_explicit_sets:singleton_set(Set1,El),!, |
| 4262 | | check_element_of_wf(El,Set2,WF). |
| 4263 | | check_subset_of0_lwf(Set1,Set2,_WF,_,_) :- |
| 4264 | | both_global_sets(Set1,Set2,G1,G2),!, % may now succeed compared to same check above, as Set1/Set2 now instantiated |
| 4265 | | check_subset_of_global_sets(G1,G2). |
| 4266 | | check_subset_of0_lwf(Set1,Set2,WF,_LWF,_GS2) :- % Note: two intervals are treated in check_subset_of_global_sets |
| 4267 | | nonvar(Set1), % otherwise we have already checked this code above |
| 4268 | | subset_of_explicit_set(Set1,Set2,Code,WF),!, |
| 4269 | | call(Code). |
| 4270 | | check_subset_of0_lwf(Set1,Set2,WF,LWF,_GS2) :- |
| 4271 | | (nonvar(Set1) ; nonvar(Set2),dont_expand_this_explicit_set(Set2)), |
| 4272 | | !, |
| 4273 | | expand_custom_set_to_list_wf(Set1,ESet1,_,check_subset_of1,WF), |
| 4274 | | try_expand_and_convert_to_avl_unless_large_wf(Set2,ESet2,WF), |
| 4275 | | % b_interpreter_components:observe_instantiation(ESet1,'ESet1',ESet1), |
| 4276 | ? | check_subset_of2(ESet1,[],ESet2,WF,LWF,none). |
| 4277 | | check_subset_of0_lwf(Set1,Set2,WF,_LWF,_GS2) :- |
| 4278 | | expand_custom_set_to_list_wf(Set2,ESet2,_,check_subset_of0_lwf,WF), % Set2 is ground |
| 4279 | | % THIS WILL ENUMERATE, for something like dom(f) <: SET this is problematic, as information cannot be used |
| 4280 | | % hence we use wfx_no_enumeration above |
| 4281 | | %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 ? |
| 4282 | ? | gen_subsets(Set1,ESet2,WF). |
| 4283 | | |
| 4284 | | :- block check_subset_of2(-,?,?,?,-, ?). |
| 4285 | | check_subset_of2([],_SoFar,_Set2,_WF,_LWF,_Last). |
| 4286 | | check_subset_of2(HT,SoFar,Set2,WF,LWF,Last) :- |
| 4287 | | (var(HT),Set2 = avl_set(AVL) |
| 4288 | | -> % the value is chosen by the enumerator |
| 4289 | ? | custom_explicit_sets:safe_avl_member(H,AVL), |
| 4290 | | % this forces H to be ground; if Last /= none then it will be ground |
| 4291 | | (Last==none -> true ; Last @< H), |
| 4292 | | % TO DO: we could write a safe_avl_member_greater_than(H,Last,AVL) |
| 4293 | | not_element_of_wf(H,SoFar,WF), |
| 4294 | | NewLast=H, |
| 4295 | | HT = [H|T] |
| 4296 | | ; % the value may have been chosen by somebody else or will not be enumerated in order below |
| 4297 | | HT = [H|T], |
| 4298 | | not_element_of_wf(H,SoFar,WF), |
| 4299 | ? | check_element_of_wf_lwf(H,Set2,WF,LWF), |
| 4300 | | %check_element_of_wf(H,Set2,WF), |
| 4301 | | |
| 4302 | | NewLast = Last |
| 4303 | | ), |
| 4304 | ? | check_subset_of3(H,T,SoFar,Set2,WF,LWF,NewLast). |
| 4305 | | |
| 4306 | | % TO DO: write specific subsets code for avl_set(Set2) + try expand when becomes ground; merge with enumerate_tight_set ,... |
| 4307 | | % TO DO: ensure that it also works with global_set(T) instead of avl_set(_) or with interval closures |
| 4308 | | |
| 4309 | | |
| 4310 | | :- block check_subset_of3(?,-,-,?,?,-,?), check_subset_of3(?,-,?,-,?,-,?), check_subset_of3(?,-,-,-,?,?,?). |
| 4311 | | check_subset_of3(_,T,_,_Set2,_WF,_LWF,_) :- T==[],!. |
| 4312 | | check_subset_of3(H,T,SoFar,Set2,WF,LWF,Last) :- var(T),!, |
| 4313 | | % Sofar, Set2 and LWF must be set |
| 4314 | ? | when((nonvar(T);(ground(Set2),ground(H),ground(SoFar))), |
| 4315 | | (T==[] -> true |
| 4316 | | ; add_new_element_wf(H,SoFar,SoFar2,WF), %SoFar2 = [H|SoFar], |
| 4317 | | check_subset_of2(T,SoFar2,Set2,WF,LWF,Last))). |
| 4318 | | check_subset_of3(H,T,SoFar,Set2,WF,LWF,Last) :- |
| 4319 | | % T must be set and not equal to [] |
| 4320 | | T = [H2|T2], |
| 4321 | | add_new_element_wf(H,SoFar,SoFar2,WF), %SoFar2 = [H|SoFar], |
| 4322 | | %check_subset_of2(T,SoFar2,Set2,WF,LWF))), |
| 4323 | ? | check_element_of_wf(H2,Set2,WF), |
| 4324 | | not_element_of_wf(H2,SoFar2,WF), |
| 4325 | | check_subset_of3(H2,T2,SoFar2,Set2,WF,LWF,Last). |
| 4326 | | |
| 4327 | | |
| 4328 | | :- block gen_subsets(?,-,?). |
| 4329 | | gen_subsets([],_,_). |
| 4330 | | gen_subsets(SubSet,Set,WF) :- |
| 4331 | ? | ordered_delete(DH,Set,NewSet), |
| 4332 | ? | equal_object_wf([DH|T],SubSet,gen_subsets,WF), |
| 4333 | ? | gen_subsets(T,NewSet,WF). |
| 4334 | | |
| 4335 | | % note: this is not select/3 |
| 4336 | | ordered_delete(H,[H|T],T). |
| 4337 | ? | ordered_delete(H,[_|T],R) :- ordered_delete(H,T,R). |
| 4338 | | |
| 4339 | | |
| 4340 | | :- 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)). |
| 4341 | | :- assert_must_succeed(exhaustive_kernel_check_wf(check_finite_non_empty_subset_of_wf([int(1),int(5)], [int(5),int(1)],WF),WF)). |
| 4342 | | check_finite_non_empty_subset_of_wf(Set1,Set2,WF) :- |
| 4343 | | check_non_empty_subset_of_wf(Set1,Set2,WF), |
| 4344 | | is_finite_set_wf(Set1,WF). |
| 4345 | | |
| 4346 | | :- 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)). |
| 4347 | | :- assert_must_succeed(exhaustive_kernel_fail_check_wfdet(check_non_empty_subset_of_wf([int(2)], [int(5),int(1)],WF),WF)). |
| 4348 | | :- assert_must_succeed(exhaustive_kernel_fail_check_wfdet(check_non_empty_subset_of_wf([], [int(1)],WF),WF)). |
| 4349 | | |
| 4350 | | check_non_empty_subset_of_wf(S1,S2,WF) :- not_empty_set_wf(S1,WF), |
| 4351 | | check_subset_of_wf(S1,S2,WF). |
| 4352 | | |
| 4353 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_subset_of([int(1),int(2),int(5)], [int(2),int(4),int(1),int(3)]))). |
| 4354 | | :- assert_must_succeed(exhaustive_kernel_fail_check(not_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1),int(3)]))). |
| 4355 | | :- assert_must_succeed((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name')], X=global_set('Name'))). |
| 4356 | | :- assert_must_succeed((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name')], X=[fd(2,'Name')])). |
| 4357 | | :- assert_must_succeed((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name')], X=[fd(1,'Name'),fd(2,'Name')])). |
| 4358 | | :- assert_must_fail((kernel_objects:not_subset_of(Y,X), Y = [fd(1,'Name'),fd(3,'Name')], X=global_set('Name'))). |
| 4359 | | :- assert_must_fail((kernel_objects:not_subset_of(Y,X), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))). |
| 4360 | | :- assert_must_fail((kernel_objects:not_subset_of(X,Y), Y = [fd(1,'Name'),fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))). |
| 4361 | | :- assert_must_fail((kernel_objects:not_subset_of(global_set('NAT'),global_set('NAT')))). |
| 4362 | | :- assert_must_succeed((kernel_objects:not_subset_of(global_set('NAT'),global_set('NAT1')))). |
| 4363 | | |
| 4364 | | |
| 4365 | | not_subset_of(Set1,Set2) :- init_wait_flags(WF), |
| 4366 | | not_subset_of_wf(Set1,Set2,WF), |
| 4367 | | ground_wait_flags(WF). |
| 4368 | | |
| 4369 | | :- 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))). |
| 4370 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf(global_set('NATURAL'), global_set('INTEGER'),_WF))). |
| 4371 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf(global_set('INTEGER'), global_set('INTEGER'),_WF))). |
| 4372 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_finite_subset_of_wf([int(1)], [],_WF))). |
| 4373 | | |
| 4374 | | :- block not_finite_subset_of_wf(-,?,?). |
| 4375 | | not_finite_subset_of_wf(Set1,Set2,WF) :- test_finite_set_wf(Set1,Finite,WF), |
| 4376 | | not_finite_subset_of_wf_aux(Finite,Set1,Set2,WF). |
| 4377 | | :- block not_finite_subset_of_wf_aux(-,?,?,?). |
| 4378 | | not_finite_subset_of_wf_aux(pred_false,_Set1,_Set2,_WF). |
| 4379 | | not_finite_subset_of_wf_aux(pred_true,Set1,Set2,WF) :- not_subset_of_wf(Set1,Set2,WF). |
| 4380 | | |
| 4381 | | :- block not_subset_of_wf(-,?,?). |
| 4382 | | not_subset_of_wf([],_,_WF) :- !, fail. |
| 4383 | | not_subset_of_wf(Set1,Set2,WF) :- Set2==[],!, not_empty_set_wf(Set1,WF). |
| 4384 | | not_subset_of_wf(Set1,Set2,WF) :- |
| 4385 | | (both_global_sets(Set1,Set2,G1,G2) % also catches intervals |
| 4386 | | -> check_not_subset_of_global_sets(G1,G2) |
| 4387 | | ; not_subset_of_wf1(Set1,Set2,WF) |
| 4388 | | ). |
| 4389 | | not_subset_of_wf1(_Set1,Set2,_WF) :- |
| 4390 | | nonvar(Set2), is_definitely_maximal_set(Set2),!,fail. |
| 4391 | | not_subset_of_wf1(Set1,Set2,_WF) :- quick_same_value(Set1,Set2), |
| 4392 | | !, fail. |
| 4393 | | not_subset_of_wf1(Set1,Set2,WF) :- custom_explicit_sets:singleton_set(Set1,El),!, |
| 4394 | | not_element_of_wf(El,Set2,WF). |
| 4395 | ? | not_subset_of_wf1(Set1,Set2,WF) :- not_subset_of_explicit_set(Set1,Set2,Code,WF),!, |
| 4396 | | call(Code). |
| 4397 | | not_subset_of_wf1(Set1,Set2,WF) :- |
| 4398 | | expand_custom_set_to_list_wf(Set1,ESet1,_,not_subset_of_wf1,WF), |
| 4399 | | not_subset_of2(ESet1,Set2,WF). |
| 4400 | | |
| 4401 | | |
| 4402 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(0,2),interval(1,3))). |
| 4403 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(1,2),interval(0,-1))). |
| 4404 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(1,2),interval(4,3))). |
| 4405 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(1,3))). |
| 4406 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(1,9000),interval(2,9999))). |
| 4407 | | :- assert_must_succeed((kernel_objects:check_not_subset_of_global_sets(interval(X2,X4),interval(1,3)), |
| 4408 | | X2=2, X4=4)). |
| 4409 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(1,4))). |
| 4410 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(2,4))). |
| 4411 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(2,4),interval(0,10))). |
| 4412 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(0,2),interval(1,inf))). |
| 4413 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(-1,2),interval(0,inf))). |
| 4414 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,2),interval(1,inf))). |
| 4415 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(0,2),interval(0,inf))). |
| 4416 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(-1,2),interval(minus_inf,inf))). |
| 4417 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(0,inf),interval(1,inf))). |
| 4418 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(minus_inf,inf),interval(1,inf))). |
| 4419 | | :- assert_must_succeed(kernel_objects:check_not_subset_of_global_sets(interval(minus_inf,inf),interval(0,inf))). |
| 4420 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,inf),interval(minus_inf,inf))). |
| 4421 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,inf),interval(1,inf))). |
| 4422 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(1,inf),interval(0,inf))). |
| 4423 | | :- assert_must_fail(kernel_objects:check_not_subset_of_global_sets(interval(0,inf),interval(0,inf))). |
| 4424 | | |
| 4425 | | :- block check_not_subset_of_global_sets(-,?), check_not_subset_of_global_sets(?,-). |
| 4426 | | check_not_subset_of_global_sets(interval(Low1,Up1),G2) :- !, |
| 4427 | | safe_less_than_equal_with_inf_clpfd(Low1,Up1), % Set 1 is not empty; otherwise it will always be a subset |
| 4428 | | not_subset_interval_gs_aux(G2,Low1,Up1). |
| 4429 | | check_not_subset_of_global_sets(G1,G2) :- |
| 4430 | | \+ check_subset_of_global_sets(G1,G2). |
| 4431 | | |
| 4432 | | not_subset_interval_gs_aux(interval(Low2,Up2),Low1,Up1) :- |
| 4433 | | finite_interval(Low1,Up1), finite_interval(Low2,Up2), |
| 4434 | | !, |
| 4435 | | % post_constraint2((Low1 #<Low2 #\/ Up1 #> Up2 #\/ Up2 #< Low1),Posted), %% X #<100 #\/ X#<0. does not constraint X ! but X #<max(100,0) does |
| 4436 | | post_constraint2((Low1 #<Low2 #\/ Up2 #< max(Up1,Low1)),Posted), |
| 4437 | | (Posted==true -> true ; not_interval_subset(Low1,Up1,Low2,Up2)). |
| 4438 | | not_subset_interval_gs_aux(interval(Low2,Up2),Low1,Up1) :- !, not_interval_subset(Low1,Up1,Low2,Up2). |
| 4439 | | not_subset_interval_gs_aux(GS2,Low1,Up1) :- |
| 4440 | | when((nonvar(Low1),nonvar(Up1)), \+ check_subset_of_global_sets(interval(Low1,Up1),GS2)). |
| 4441 | | |
| 4442 | | not_interval_subset(Val1,Up1,Low2,Up2) :- var(Val1), Val1==Up1, |
| 4443 | | !, % better propagation for singleton set |
| 4444 | | (Up2==inf -> Low2\==minus_inf, less_than_direct(Val1,Low2) |
| 4445 | | ; Low2=minus_inf -> less_than_direct(Up2,Val1) |
| 4446 | | ; not_in_nat_range(int(Val1),int(Low2),int(Up2))). |
| 4447 | | not_interval_subset(Low1,_,Low2,Up2) :- Up2==inf, finite_val(Low2), finite_val(Low1), |
| 4448 | | % typical case x..y /<: NATURAL <==> x < 0 |
| 4449 | | !, |
| 4450 | | less_than_direct(Low1,Low2). |
| 4451 | | not_interval_subset(_,Up1,Low2,Up2) :- Low2==minus_inf, finite_val(Up2), finite_val(Up1), |
| 4452 | | % covers x..y /<: {x|x<=0} <==> y > 0 |
| 4453 | | !, |
| 4454 | | less_than_direct(Up2,Up1). |
| 4455 | | not_interval_subset(Low1,Up1,Low2,Up2) :- not_interval_subset_block(Low1,Up1,Low2,Up2). |
| 4456 | | :- block not_interval_subset_block(-,?,?,?), not_interval_subset_block(?,-,?,?), |
| 4457 | | not_interval_subset_block(?,?,-,?), not_interval_subset_block(?,?,?,-). |
| 4458 | | not_interval_subset_block(Low1,Up1,Low2,Up2) :- % this could be decided earlier, e.g. 1..n /<: 1..inf is false |
| 4459 | ? | \+ interval_subset(Low1,Up1,Low2,Up2). |
| 4460 | | |
| 4461 | | |
| 4462 | | :- block not_subset_of2(-,?,?). |
| 4463 | | not_subset_of2([H|T],Set2,WF) :- |
| 4464 | | (T==[] |
| 4465 | | -> not_element_of_wf(H,Set2,WF) |
| 4466 | | ; membership_test_wf(Set2,H,MemRes,WF), |
| 4467 | | propagate_empty_set_to_pred_false(T,MemRes), % if T becomes empty, we know that H must not be in Set2 |
| 4468 | | not_subset_of3(MemRes,T,Set2,WF) |
| 4469 | | ). |
| 4470 | | |
| 4471 | | :- block not_subset_of3(-,?,?,?). |
| 4472 | | not_subset_of3(pred_false,_T,_Set2,_WF). |
| 4473 | | not_subset_of3(pred_true,T,Set2,WF) :- not_subset_of2(T,Set2,WF). |
| 4474 | | |
| 4475 | | :- block propagate_empty_set_to_pred_false(-,-). |
| 4476 | | propagate_empty_set_to_pred_false(X,PredRes) :- X==[],!,PredRes=pred_false. |
| 4477 | | propagate_empty_set_to_pred_false(_,_). |
| 4478 | | |
| 4479 | | :- assert_must_succeed(exhaustive_kernel_check_wf(not_both_subset_of([int(1),int(2),int(5)], [] |
| 4480 | | ,[int(2),int(4),int(1),int(3)],[],WF),WF)). |
| 4481 | | :- assert_must_succeed(exhaustive_kernel_check_wf(not_both_subset_of([int(1),int(2),int(5)], [int(3)], |
| 4482 | | [int(2),int(5),int(1),int(3)],[int(1),int(4)],WF),WF)). |
| 4483 | | |
| 4484 | | not_both_subset_of(Set1A,Set1B, Set2A,Set2B, WF) :- |
| 4485 | | kernel_equality:subset_test(Set1A,Set2A,Result,WF), % not yet implemented ! % TODO ! -> sub_set,equal,super_set |
| 4486 | | not_both_subset_of_aux(Result,Set1B,Set2B,WF). |
| 4487 | | |
| 4488 | | :- block not_both_subset_of_aux(-,?,?,?). |
| 4489 | | not_both_subset_of_aux(pred_false,_Set1B,_Set2B,_WF). |
| 4490 | | not_both_subset_of_aux(pred_true,Set1B,Set2B,WF) :- |
| 4491 | | not_subset_of_wf(Set1B,Set2B,WF). |
| 4492 | | |
| 4493 | | /***********************************/ |
| 4494 | | /* not_strict_subset_of(Set1,Set2) */ |
| 4495 | | /* Set1 /<<: Set2 */ |
| 4496 | | /**********************************/ |
| 4497 | | |
| 4498 | | |
| 4499 | | :- 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)]))). |
| 4500 | | :- assert_must_succeed(exhaustive_kernel_succeed_check(not_strict_subset_of([int(1),int(2),int(5)], [int(2),int(5),int(1)]))). |
| 4501 | | :- 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)]))). |
| 4502 | | :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [int(1)], X=[int(2),int(1)])). |
| 4503 | | :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [], X=[int(2),int(1)])). |
| 4504 | | :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [[int(1),int(2)]], X=[[int(2)],[int(2),int(1)]])). |
| 4505 | | :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [fd(1,'Name')], X=global_set('Name'))). |
| 4506 | | :- assert_must_fail((kernel_objects:not_strict_subset_of(Y,X), Y = [fd(3,'Name'),fd(2,'Name')], X=global_set('Name'))). |
| 4507 | | :- 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'))). |
| 4508 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [fd(1,'Name'),fd(3,'Name')], X=global_set('Name'))). |
| 4509 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(1)], X=[int(2),int(1)])). |
| 4510 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(1),int(2)], X=[int(2),int(1)])). |
| 4511 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(2)], X=[int(2)])). |
| 4512 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [int(2)], X=[int(1)])). |
| 4513 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of(X,Y), Y = [], X=[int(1)])). |
| 4514 | | |
| 4515 | | not_strict_subset_of(Set1,Set2) :- |
| 4516 | | (preference(use_chr_solver,true) -> chr_not_subset_strict(Set1,Set2) ; true), |
| 4517 | | init_wait_flags(WF,[not_strict_subset_of]), |
| 4518 | | not_strict_subset_of_wf(Set1,Set2,WF), |
| 4519 | | ground_wait_flags(WF). |
| 4520 | | |
| 4521 | | :- block not_strict_subset_of_wf(-,?,?),not_strict_subset_of_wf(?,-,?). |
| 4522 | | not_strict_subset_of_wf(Set1,Set2,WF) :- |
| 4523 | | (both_global_sets(Set1,Set2,G1,G2) |
| 4524 | | -> not_strict_subset_of_global_sets(G1,G2) |
| 4525 | | ; not_strict_subset_of_wf1(Set1,Set2,WF) |
| 4526 | | ). |
| 4527 | ? | not_strict_subset_of_wf1(Set1,Set2,WF) :- not_subset_of_explicit_set(Set1,Set2,Code,WF),!, |
| 4528 | | equality_objects_wf(Set1,Set2,EqRes,WF), |
| 4529 | | not_strict_eq_check(EqRes,Code). |
| 4530 | | not_strict_subset_of_wf1(Set1,Set2,WF) :- |
| 4531 | | % OLD VERSION: not_subset_of(Set1,Set2) ; check_equal_object(Set1,Set2). |
| 4532 | | expand_custom_set_to_list_wf(Set1,ESet1,_,not_strict_subset_of_wf1,WF), |
| 4533 | | (nonvar(Set2),is_infinite_explicit_set(Set2) -> Inf=infinite ; Inf=unknown), |
| 4534 | | not_strict_subset_of2(ESet1,Set2,Inf,WF). |
| 4535 | | |
| 4536 | | :- block not_strict_eq_check(-,?). |
| 4537 | | not_strict_eq_check(pred_true,_). % if equal then not strict subset is true |
| 4538 | | not_strict_eq_check(pred_false,Code) :- call(Code). % check if not subset |
| 4539 | | |
| 4540 | | :- block not_strict_subset_of2(-,?,?,?). |
| 4541 | | not_strict_subset_of2([],R,_,WF) :- empty_set_wf(R,WF). |
| 4542 | | not_strict_subset_of2([H|T],Set2,Inf,WF) :- |
| 4543 | | membership_test_wf(Set2,H,MemRes,WF), |
| 4544 | | not_strict_subset_of3(MemRes,H,T,Set2,Inf,WF). |
| 4545 | | |
| 4546 | | :- block not_strict_subset_of3(-,?,?,?,?,?). |
| 4547 | | not_strict_subset_of3(pred_false,_H,_T,_Set2,_,_WF). |
| 4548 | | not_strict_subset_of3(pred_true,H,T,Set2,Inf,WF) :- |
| 4549 | | (Inf=infinite |
| 4550 | | -> RS2=Set2 % Set1 is finite; we just have to check that all elements are in Set2 and we have a strict subset |
| 4551 | | ; remove_element_wf(H,Set2,RS2,WF)), |
| 4552 | | not_strict_subset_of2(T,RS2,Inf,WF). |
| 4553 | | |
| 4554 | | |
| 4555 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,2),interval(1,3))). |
| 4556 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,2),interval(0,-1))). |
| 4557 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,2),interval(4,3))). |
| 4558 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(1,3))). |
| 4559 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,9000),interval(2,9999))). |
| 4560 | | :- assert_must_succeed((kernel_objects:not_strict_subset_of_global_sets(interval(X2,X4),interval(1,3)), |
| 4561 | | X2=2, X4=4)). |
| 4562 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(1,4))). |
| 4563 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(2,4))). |
| 4564 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(2,4),interval(0,10))). |
| 4565 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,2),interval(1,inf))). |
| 4566 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(-1,2),interval(0,inf))). |
| 4567 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(1,2),interval(1,inf))). |
| 4568 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(0,2),interval(0,inf))). |
| 4569 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(-1,2),interval(minus_inf,inf))). |
| 4570 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,inf),interval(1,inf))). |
| 4571 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(minus_inf,inf),interval(1,inf))). |
| 4572 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(minus_inf,inf),interval(0,inf))). |
| 4573 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(1,inf),interval(minus_inf,inf))). |
| 4574 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(1,inf),interval(1,inf))). |
| 4575 | | :- assert_must_fail(kernel_objects:not_strict_subset_of_global_sets(interval(1,inf),interval(0,inf))). |
| 4576 | | :- assert_must_succeed(kernel_objects:not_strict_subset_of_global_sets(interval(0,inf),interval(0,inf))). |
| 4577 | | |
| 4578 | | :- block not_strict_subset_of_global_sets(-,?), not_strict_subset_of_global_sets(?,-). |
| 4579 | | not_strict_subset_of_global_sets(interval(Low1,Up1),interval(Low2,Up2)) :- !, |
| 4580 | | % Note: if Low2>Up2 then nothing is a strict subset of the empty set, i.e., everything is not a strict subset |
| 4581 | | (finite_interval(Low1,Up1), finite_interval(Low2,Up2) |
| 4582 | | -> clpfd_interface:post_constraint2(((Low2 #=< Up2) #=> (Low1 #=< Up1 #/\ ((Low2 #> Low1) #\/ (Up1 #> Up2) #\/ ((Low1 #= Low2 #/\ Up1 #= Up2))))),Posted) |
| 4583 | | ; Posted=false), |
| 4584 | | (Posted==true -> true ; not_strict_subset_intervals(Low1,Up1,Low2,Up2)). |
| 4585 | | not_strict_subset_of_global_sets(G1,G2) :- |
| 4586 | | when((ground(G1),ground(G2)), \+check_strict_subset_of_global_sets(G1,G2)). |
| 4587 | | |
| 4588 | | :- block not_strict_subset_intervals(?,?,-,?), not_strict_subset_intervals(?,?,?,-). |
| 4589 | | % Instead of blocking on Low2,Up2 we could post bigger constraint (Low2 <= Up2 => (Low1 <= Up1 /\ .... |
| 4590 | | not_strict_subset_intervals(_Low1,_Up1,Low2,Up2) :- safe_less_than_with_inf(Up2,Low2),!. |
| 4591 | | not_strict_subset_intervals(Low1,Up1,Low2,Up2) :- |
| 4592 | | safe_less_than_equal_with_inf_clpfd(Low1,Up1), % if Low1..Up1 is empty then it would be a strict subset |
| 4593 | | not_check_strict_subset_intervals2(Low1,Up1,Low2,Up2). |
| 4594 | | :- block not_check_strict_subset_intervals2(-,?,?,?),not_check_strict_subset_intervals2(?,-,?,?), |
| 4595 | | not_check_strict_subset_intervals2(?,?,-,?). |
| 4596 | ? | not_check_strict_subset_intervals2(Low1,Up1,Low2,Up2) :- \+ check_strict_subset_intervals2(Low1,Up1,Low2,Up2). |
| 4597 | | |
| 4598 | | |
| 4599 | | /* Set1 /: FIN1(Set2) */ |
| 4600 | | :- assert_must_succeed((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(2)])). |
| 4601 | | :- assert_must_succeed((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X=[int(1)], Y=[int(1),int(2)])). |
| 4602 | | :- assert_must_succeed((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[])). |
| 4603 | | :- assert_must_fail((kernel_objects:not_non_empty_finite_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(1)])). |
| 4604 | | |
| 4605 | | :- block not_non_empty_finite_subset_of_wf(-,?,?). |
| 4606 | | not_non_empty_finite_subset_of_wf(Set1,Set2,WF) :- test_finite_set_wf(Set1,Finite,WF), |
| 4607 | | not_non_empty_finite_subset_of_aux(Finite,Set1,Set2,WF). |
| 4608 | | :- block not_non_empty_finite_subset_of_aux(-,?,?,?). |
| 4609 | | not_non_empty_finite_subset_of_aux(pred_false,_Set1,_Set2,_WF). |
| 4610 | | not_non_empty_finite_subset_of_aux(pred_true,Set1,Set2,WF) :- not_non_empty_subset_of_wf(Set1,Set2,WF). |
| 4611 | | |
| 4612 | | /* Set1 /: POW1(Set2) */ |
| 4613 | | :- assert_must_succeed(exhaustive_kernel_check_wf(not_non_empty_subset_of_wf([int(1)], [int(2),int(3)],WF),WF)). |
| 4614 | | :- assert_must_succeed(exhaustive_kernel_fail_check_wf(not_non_empty_subset_of_wf([int(2)], [int(2),int(3)],WF),WF)). |
| 4615 | | :- assert_must_succeed((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(2)])). |
| 4616 | | :- assert_must_succeed((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X=[int(1)], Y=[int(1),int(2)])). |
| 4617 | | :- assert_must_succeed((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[])). |
| 4618 | | :- assert_must_fail((kernel_objects:not_non_empty_subset_of_wf(Y,X,_WF), X = [int(1)], Y=[int(1)])). |
| 4619 | | |
| 4620 | | % Set1 /: POW1(Set2) |
| 4621 | | :- block not_non_empty_subset_of_wf(-,?,?). |
| 4622 | | not_non_empty_subset_of_wf(Set1,_,_WF) :- Set1==[],!. |
| 4623 | | not_non_empty_subset_of_wf(Set1,Set2,WF) :- % Maybe introduce binary choice point ? |
| 4624 | | empty_set_wf(Set1,WF) ; |
| 4625 | | not_subset_of_wf(Set1,Set2,WF). |
| 4626 | | |
| 4627 | | |
| 4628 | | /* min, max */ |
| 4629 | | |
| 4630 | | :- assert_must_succeed(exhaustive_kernel_check(minimum_of_set([int(1)],int(1),unknown,_WF))). |
| 4631 | | :- assert_must_succeed(exhaustive_kernel_check(minimum_of_set([int(2),int(3),int(1)],int(1),unknown,_WF))). |
| 4632 | | :- assert_must_succeed(exhaustive_kernel_fail_check(minimum_of_set([int(2),int(3),int(1)],int(2),unknown,_WF))). |
| 4633 | | :- assert_must_succeed((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(1)])). |
| 4634 | | :- assert_must_succeed((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(2),int(1)])). |
| 4635 | | :- assert_must_succeed((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(1),int(2),int(1),int(3)])). |
| 4636 | | :- assert_must_fail((kernel_objects:minimum_of_set(Y,X,unknown,_WF), X = int(2), Y=[int(1),int(2),int(1),int(3)])). |
| 4637 | | :- assert_must_abort_wf(kernel_objects:minimum_of_set([],_R,unknown,WF),WF). |
| 4638 | | %:- must_succeed(kernel_waitflags:assert_must_abort2_wf(kernel_objects:minimum_of_set([],_R,WF),WF)). |
| 4639 | | |
| 4640 | | :- block minimum_of_set_extension_list(-,?,?,?). |
| 4641 | | minimum_of_set_extension_list(ListOfValues,int(Min),Span,WF) :- |
| 4642 | | minimum_of_set2(ListOfValues,Min,Span,WF). |
| 4643 | | |
| 4644 | | :- block minimum_of_set(-,?,?,?). |
| 4645 | | minimum_of_set(Set1,Res,_Span,WF) :- is_custom_explicit_set(Set1,minimum_of_set), |
| 4646 | | min_of_explicit_set_wf(Set1,Min,WF), !, |
| 4647 | | equal_object_wf(Min,Res,minimum_of_set,WF). |
| 4648 | | minimum_of_set(Set1,int(Min),Span,WF) :- expand_custom_set_to_list_wf(Set1,ESet1,_,minimum_of_set,WF), |
| 4649 | | minimum_of_set2(ESet1,Min,Span,WF). |
| 4650 | | :- block minimum_of_set2(-,?,?,?). |
| 4651 | | minimum_of_set2([],Res,Span,WF) :- |
| 4652 | | add_wd_error_set_result('min applied to empty set','',Res,int(0),Span,WF). |
| 4653 | | minimum_of_set2([int(N)|T],Min,_,_) :- clpfd_geq2(N,Min,_),minimum_of_set3(T,N,Min,[N]). |
| 4654 | | |
| 4655 | | :- block minimum_of_set3(-,?,?,?). % with CLPFD: makes sense to also unfold if Min Variable; hence no longer block on : minimum_of_set3(?,-,-). |
| 4656 | | minimum_of_set3([],MinSoFar,MinSoFar,ListOfValues) :- |
| 4657 | | (var(MinSoFar) -> clpfd_minimum(MinSoFar,ListOfValues) ; true). |
| 4658 | | minimum_of_set3([int(M)|T],MinSoFar,Min,ListOfValues) :- clpfd_geq2(M,Min,_), |
| 4659 | | minimum(M,MinSoFar,NewMinSoFar), |
| 4660 | | minimum_of_set3(T,NewMinSoFar,Min,[M|ListOfValues]). |
| 4661 | | |
| 4662 | | |
| 4663 | | :- block minimum(-,?,?), minimum(?,-,?). |
| 4664 | | minimum(M1,M2,Min) :- M1<M2 -> Min=M1 ; Min=M2. |
| 4665 | | |
| 4666 | | :- assert_must_succeed(exhaustive_kernel_check(maximum_of_set([int(1)],int(1),unknown,_WF))). |
| 4667 | | :- assert_must_succeed(exhaustive_kernel_check(maximum_of_set([int(2),int(3),int(1)],int(3),unknown,_WF))). |
| 4668 | | :- assert_must_succeed(exhaustive_kernel_fail_check(maximum_of_set([int(2),int(3),int(1)],int(2),unknown,_WF))). |
| 4669 | | :- assert_must_succeed((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(1), Y=[int(1)])). |
| 4670 | | :- assert_must_succeed((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(2), Y=[int(2),int(1)])). |
| 4671 | | :- assert_must_succeed((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(3), Y=[int(1),int(2),int(1),int(3)])). |
| 4672 | | :- assert_must_fail((kernel_objects:maximum_of_set(Y,X,unknown,_WF), X = int(2), Y=[int(1),int(2),int(1),int(3)])). |
| 4673 | | :- assert_must_fail((preferences:preference(use_clpfd_solver,true), |
| 4674 | | kernel_objects:maximum_of_set([int(X),int(_Y)],int(3),unknown,_WF), X = 4)). % in CLPFD modus |
| 4675 | | :- assert_must_fail((preferences:preference(use_clpfd_solver,true), |
| 4676 | | kernel_objects:maximum_of_set([int(_),int(X)],int(3),unknown,_WF), X = 4)).% in CLPFD modus |
| 4677 | | :- assert_must_abort_wf(kernel_objects:maximum_of_set([],_R,unknown,WF),WF). |
| 4678 | | |
| 4679 | | :- block maximum_of_set_extension_list(-,?,?,?). |
| 4680 | | maximum_of_set_extension_list(ListOfValues,int(Max),Span,WF) :- |
| 4681 | | maximum_of_set2(ListOfValues,Max,Span,WF). |
| 4682 | | |
| 4683 | | :- block maximum_of_set(-,?,?,?). |
| 4684 | | maximum_of_set(Set1,Res,_Span,WF) :- |
| 4685 | | is_custom_explicit_set(Set1,maximum_of_set), |
| 4686 | | max_of_explicit_set_wf(Set1,Max,WF), !, |
| 4687 | | equal_object_wf(Max,Res,maximum_of_set,WF). |
| 4688 | | maximum_of_set(Set1,int(Max),Span,WF) :- |
| 4689 | | expand_custom_set_to_list_wf(Set1,ESet1,_,maximum_of_set,WF), |
| 4690 | | maximum_of_set2(ESet1,Max,Span,WF). |
| 4691 | | :- block maximum_of_set2(-,?,?,?). |
| 4692 | | maximum_of_set2([],Res,Span,WF) :- |
| 4693 | | 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))). |
| 4694 | | maximum_of_set2([int(N)|T],Max,_Span,_) :- clpfd_geq2(Max,N,_), |
| 4695 | | maximum_of_set3(T,N,Max,[N]). |
| 4696 | | |
| 4697 | | :- block maximum_of_set3(-,?,?,?). % with CLPFD: makes sense to also unfold if Max Variable; hence no longer block on : maximum_of_set3(?,-,-). |
| 4698 | | maximum_of_set3([],MaxSoFar,MaxSoFar,ListOfValues) :- |
| 4699 | | (var(MaxSoFar) -> clpfd_maximum(MaxSoFar,ListOfValues) ; true). |
| 4700 | | maximum_of_set3([int(M)|T],MaxSoFar,Max,ListOfValues) :- clpfd_geq2(Max,M,_), |
| 4701 | | maximum(M,MaxSoFar,NewMaxSoFar), |
| 4702 | | maximum_of_set3(T,NewMaxSoFar,Max,[M|ListOfValues]). |
| 4703 | | |
| 4704 | | :- block maximum(-,?,?), maximum(?,-,?). |
| 4705 | | maximum(M1,M2,Max) :- M1>M2 -> Max=M1 ; Max=M2. |
| 4706 | | |
| 4707 | | % card(ran(Function)); useful e.g. for q : 1 .. 16 --> 1 .. 16 & card(ran(q))=16 |
| 4708 | | :- block cardinality_of_range(-,?,?). |
| 4709 | | cardinality_of_range(CS,Card,WF) :- |
| 4710 | | is_custom_explicit_set(CS,cardinality_of_range), |
| 4711 | | range_of_explicit_set_wf(CS,Res,WF),!, |
| 4712 | | cardinality_as_int_wf(Res,Card,WF). |
| 4713 | | cardinality_of_range(Function,Card,WF) :- |
| 4714 | | expand_custom_set_to_list_wf(Function,EF1,Done,cardinality_of_range,WF), |
| 4715 | | project_on_range(EF1,ERange), |
| 4716 | | % when Done is set: we have a complete list and can compute MaxCard; TODO: maybe provide a version that can trigger earlier |
| 4717 | | when(nonvar(Done),cardinality_of_set_extension_list(ERange,Card,WF)). |
| 4718 | | |
| 4719 | | :- block project_on_range(-,?). |
| 4720 | | project_on_range([],[]). |
| 4721 | | project_on_range([(_,Ran)|T],[Ran|TR]) :- project_on_range(T,TR). |
| 4722 | | |
| 4723 | | |
| 4724 | | :- assert_must_succeed((cardinality_of_set_extension_list([fd(1,'Name')],R,_WF), R = int(1))). |
| 4725 | | :- assert_must_succeed((cardinality_of_set_extension_list([int(X),int(Y)],int(1),_WF), X=22, Y==22)). |
| 4726 | | |
| 4727 | | cardinality_of_set_extension_list(List,int(Card),WF) :- |
| 4728 | | length(List,MaxCard), less_than_equal_direct(Card,MaxCard), |
| 4729 | | cardinality_of_set_extension_list2(List,[],0,MaxCard,Card,WF). |
| 4730 | | |
| 4731 | | :- block cardinality_of_set_extension_list2(-,?,?,?,?,?). |
| 4732 | | cardinality_of_set_extension_list2([],_,AccSz,_MaxCard,Res,_WF) :- Res=AccSz. |
| 4733 | | cardinality_of_set_extension_list2([H|T],Acc,AccSz,MaxCard,Res,WF) :- |
| 4734 | | membership_test_wf(Acc,H,MemRes,WF), |
| 4735 | | (MaxCard==Res -> /* only solution is for H to be not in Acc */ MemRes=pred_false |
| 4736 | | ; AccSz==Res -> /* only solution is for H to be in Acc */ MemRes=pred_true |
| 4737 | | ; (var(Res),var(MemRes)) -> kernel_equality:equality_int(MaxCard,Res,EqMaxC),prop_if_pred_true(EqMaxC,MemRes,pred_false), |
| 4738 | | kernel_equality:equality_int(AccSz,Res,EqAccSz),prop_if_pred_true(EqAccSz,MemRes,pred_true) |
| 4739 | | ; true), |
| 4740 | | cardinality_of_set_extension_list3(MemRes,H,T,Acc,AccSz,MaxCard,Res,WF). |
| 4741 | | |
| 4742 | | :- block prop_if_pred_true(-,?,?). |
| 4743 | | prop_if_pred_true(pred_true,X,X). |
| 4744 | | prop_if_pred_true(pred_false,_,_). |
| 4745 | | |
| 4746 | | :- block cardinality_of_set_extension_list3(-,?,?,?,?,?,?,?). |
| 4747 | | cardinality_of_set_extension_list3(pred_true,_,T,Acc,AccSz,MaxCard,Res,WF) :- |
| 4748 | | % H is a member of Acc, do not increase Acc nor AccSz; however MaxCard now decreases |
| 4749 | | less_than_direct(Res,MaxCard), M1 is MaxCard-1, |
| 4750 | | cardinality_of_set_extension_list2(T,Acc,AccSz,M1,Res,WF). |
| 4751 | | cardinality_of_set_extension_list3(pred_false,H,T,Acc,AccSz,MaxCard,Res,WF) :- |
| 4752 | | A1 is AccSz+1, less_than_equal_direct(A1,Res), |
| 4753 | | cardinality_of_set_extension_list2(T,[H|Acc],A1,MaxCard,Res,WF). |
| 4754 | | |
| 4755 | | :- assert_must_succeed(exhaustive_kernel_check(is_finite_set_wf([fd(1,'Name'),fd(2,'Name')],_WF))). |
| 4756 | | :- assert_must_succeed((is_finite_set_wf(Y,_WF), Y = [])). |
| 4757 | | :- assert_must_succeed((is_finite_set_wf(Y,_WF), Y = [int(1),int(2)])). |
| 4758 | | :- use_module(typing_tools,[contains_infinite_type/1]). |
| 4759 | | :- use_module(custom_explicit_sets,[card_for_specific_custom_set/3]). |
| 4760 | | |
| 4761 | | is_finite_set_wf(Set,WF) :- test_finite_set_wf(Set,pred_true,WF). |
| 4762 | | |
| 4763 | | :- assert_must_succeed(exhaustive_kernel_fail_check(is_infinite_set_wf([fd(1,'Name'),fd(2,'Name')],_WF))). |
| 4764 | | :- assert_must_fail((is_infinite_set_wf(Y,_WF), Y = [int(1),int(2)])). |
| 4765 | | |
| 4766 | | is_infinite_set_wf(Set,WF) :- test_finite_set_wf(Set,pred_false,WF). |
| 4767 | | |
| 4768 | | %! test_finite_set_wf(+Set,?X,+WF) |
| 4769 | | :- block test_finite_set_wf(-,?,?). |
| 4770 | | %test_finite_set_wf(A,B,C) :- print(test_finite_set_wf(A,B,C)),nl,fail. |
| 4771 | | test_finite_set_wf([],X,_WF) :- !, X=pred_true. |
| 4772 | | test_finite_set_wf([_|T],X,WF) :- !, test_finite_set_wf(T,X,WF). % what if Tail contains closure ?? |
| 4773 | | test_finite_set_wf(avl_set(_),X,_WF) :- !, X=pred_true. |
| 4774 | | test_finite_set_wf(closure(_P,T,_B),X,_WF) :- \+ contains_infinite_type(T), !, X=pred_true. |
| 4775 | | test_finite_set_wf(closure(P,T,B),X,WF) :- !, test_finite_closure(P,T,B,X,WF). |
| 4776 | | test_finite_set_wf(Set,X,WF) :- /* also deals with global_set(_) */ |
| 4777 | | /* explicit_set_cardinality may trigger an enum warning */ |
| 4778 | | explicit_set_cardinality_wf(Set,Card,WF), |
| 4779 | | set_finite_result(Card,Set,explicit_set,X). |
| 4780 | | |
| 4781 | | :- use_module(bsyntaxtree,[is_a_disjunct/3]). |
| 4782 | | % we already check that contains_infinite_type above |
| 4783 | | test_finite_closure(P,T,B,X,WF) :- is_a_disjunct(B,D1,D2),!, |
| 4784 | | test_finite_closure(P,T,D1,X1,WF), |
| 4785 | | test_finite_disj2(X1,P,T,D2,X,WF). |
| 4786 | | % TO DO: add is_closure1_value_closure |
| 4787 | | test_finite_closure(P,T,B,X,WF) :- when(ground(B), test_finite_closure_ground(P,T,B,X,WF)). |
| 4788 | | |
| 4789 | | test_finite_disj2(pred_false,_P,_T,_D2,X,_WF) :- X=pred_false. |
| 4790 | | test_finite_disj2(pred_true,P,T,D2,X,WF) :- test_finite_closure(P,T,D2,X,WF). |
| 4791 | | |
| 4792 | | |
| 4793 | | % first: we need to check all constructors such as POW, FIN, ... which card_for_specific_custom_set supports |
| 4794 | | % 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) |
| 4795 | | test_finite_closure_ground(P,T,B,X,WF) :- |
| 4796 | ? | is_powerset_closure(closure(P,T,B),_Type,Subset), |
| 4797 | | % note: whether Type is fin, fin1, pow, or pow1 does not matter |
| 4798 | | !, |
| 4799 | | test_finite_set_wf(Subset,X,WF). |
| 4800 | | test_finite_closure_ground(P,T,B,X,WF) :- |
| 4801 | | custom_explicit_sets:is_lambda_value_domain_closure(P,T,B, Subset,_Expr), !, |
| 4802 | | test_finite_set_wf(Subset,X,WF). |
| 4803 | | test_finite_closure_ground(P,T,B,X,WF) :- |
| 4804 | | custom_explicit_sets:is_cartesian_product_closure(closure(P,T,B), A1,B2), !, |
| 4805 | | test_finite_set_wf(A1,AX,WF), |
| 4806 | | test_finite_set_wf(B2,BX,WF), |
| 4807 | | test_finite_cartesian_product_wf(AX,BX,A1,B2,X,WF). |
| 4808 | | test_finite_closure_ground(Par,Typ,Body, X,_WF) :- |
| 4809 | ? | custom_explicit_sets:is_geq_leq_interval_closure(Par,Typ,Body,Low,Up), !, |
| 4810 | | custom_explicit_sets:card_of_interval_inf(Low,Up,Card), |
| 4811 | | set_finite_result_no_warn(Card,X). |
| 4812 | | test_finite_closure_ground(P,T,B,X,WF) :- |
| 4813 | | custom_explicit_sets:is_member_closure(P,T,B,_,SET), nonvar(SET), |
| 4814 | | unary_member_closure_for_finite(SET,Check,SET1), |
| 4815 | | !, |
| 4816 | | (Check==finite -> test_finite_set_wf(SET1,X,WF) |
| 4817 | | ; kernel_equality:empty_set_test_wf(SET1,X,WF)). |
| 4818 | | % TO DO: catch other special cases : relations, struct,... |
| 4819 | | test_finite_closure_ground(P,T,B,X,_WF) :- |
| 4820 | | custom_explicit_sets:card_for_specific_closure(closure(P,T,B),ClosureKind,Card,Code),!, |
| 4821 | | call(Code), % TO DO: catch if we convert large integer due to overflow to inf ! |
| 4822 | | % maybe we can set / transmit a flag for is_overflowcheck ? overflow_float_pown ? factorial ? |
| 4823 | | set_finite_result(Card,closure(P,T,B),ClosureKind,X). |
| 4824 | | test_finite_closure_ground(P,T,B,X,WF) :- |
| 4825 | | on_enumeration_warning(expand_only_custom_closure_global(closure(P,T,B),Result,check,WF),fail), |
| 4826 | | !, |
| 4827 | | test_finite_set_wf(Result,X,WF). |
| 4828 | | test_finite_closure_ground(P,T,B,X,WF) :- X==pred_true, !, |
| 4829 | | get_enumeration_finished_wait_flag(WF,AWF), % only add warning if indeed we find a solution |
| 4830 | | finite_warning(AWF,P,T,B,is_finite_set_closure(P)). |
| 4831 | | test_finite_closure_ground(P,T,B,_X,_WF) :- !, |
| 4832 | | finite_warning(now,P,T,B,test_finite_closure(P)), |
| 4833 | | fail. % now we fail; used to be X=pred_true. % we assume set to be finite, but print a warning |
| 4834 | | % we could set up the closure and do a deterministic phase: if it fails or all variables become bounded, then it is finite |
| 4835 | | |
| 4836 | | unary_member_closure_for_finite(seq(b(value(SET1),_,_)),empty,SET1). % finite if SET1 is empty |
| 4837 | | unary_member_closure_for_finite(seq1(b(value(SET1),_,_)),empty,SET1). |
| 4838 | | unary_member_closure_for_finite(perm(b(value(SET1),_,_)),finite,SET1). % finite if SET1 is finite |
| 4839 | | unary_member_closure_for_finite(iseq(b(value(SET1),_,_)),finite,SET1). |
| 4840 | | unary_member_closure_for_finite(iseq1(b(value(SET1),_,_)),finite,SET1). |
| 4841 | | unary_member_closure_for_finite(identity(b(value(SET1),_,_)),finite,SET1). |
| 4842 | | % we could deal with POW/POW1... here |
| 4843 | | |
| 4844 | | :- block test_finite_cartesian_product_wf(-,?,?,?,?,?), test_finite_cartesian_product_wf(?,-,?,?,?,?). |
| 4845 | | test_finite_cartesian_product_wf(pred_true, pred_true, _,_,X,_) :- !, X=pred_true. % both finite |
| 4846 | | test_finite_cartesian_product_wf(pred_false,pred_false,_,_,X,_) :- !, X=pred_false. % both infinite |
| 4847 | | test_finite_cartesian_product_wf(pred_false,pred_true, _,B,X,WF) :- !, |
| 4848 | | kernel_equality:empty_set_test_wf(B,X,WF). % only finite if B empty |
| 4849 | | test_finite_cartesian_product_wf(pred_true, pred_false,A,_,X,WF) :- !, |
| 4850 | | kernel_equality:empty_set_test_wf(A,X,WF). % only finite if B empty |
| 4851 | | |
| 4852 | | |
| 4853 | | :- block set_finite_result_no_warn(-,?). |
| 4854 | | set_finite_result_no_warn(inf,X) :- !, X=pred_false. |
| 4855 | | set_finite_result_no_warn(_,pred_true). |
| 4856 | | |
| 4857 | | :- block set_finite_result(-,?,?,?). |
| 4858 | | set_finite_result(inf,_Set,_ClosureKind,X) :- !, |
| 4859 | | %(Set=closure(P,T,B), \+ precise_closure_kind(ClosureKind) |
| 4860 | | % -> finite_warning(now,P,T,B,test_finite_closure(P)) % we sometimes return inf for very large sets % TO DO: fix |
| 4861 | | % ; true), |
| 4862 | | X=pred_false. |
| 4863 | | set_finite_result(_,_,_,pred_true). |
| 4864 | | |
| 4865 | | % inf is now always real infinity; inf_overflow is finite very large cardinality not representable as number |
| 4866 | | %precise_closure_kind(special_closure). % is_special_infinite_closure is precise, inf is real infinity %%% |
| 4867 | | %precise_closure_kind(interval_closure). % here we also should never produce inf for a finite but large set |
| 4868 | | |
| 4869 | | |
| 4870 | | :- assert_must_succeed(exhaustive_kernel_check(cardinality_as_int([int(2),int(4),int(1)],int(3)))). |
| 4871 | | :- assert_must_succeed((cardinality_as_int(Y,int(2)), Y = [fd(1,'Name'),fd(2,'Name')])). |
| 4872 | | :- assert_must_succeed((cardinality_as_int(Y,int(2)), |
| 4873 | | nonvar(Y), Y = [H1|YY], nonvar(YY), YY=[H2], H1=int(0), H2=int(3) )). |
| 4874 | | :- assert_must_succeed((cardinality_as_int([A|Y],int(3)), |
| 4875 | | nonvar(Y), Y = [B|YY], nonvar(YY), YY=[C], A=int(1),B=int(3),C=int(2) )). |
| 4876 | | :- assert_must_succeed((cardinality_as_int(Y,int(1)), Y = [fd(1,'Name')])). |
| 4877 | | :- assert_must_succeed((cardinality_as_int(Y,int(0)), Y = [])). |
| 4878 | | :- assert_must_succeed((cardinality_as_int(X,int(3)), equal_object(X,global_set('Name')))). |
| 4879 | | :- assert_must_fail((cardinality_as_int(Y,int(X)), Y = [fd(1,'Name'),fd(2,'Name')],dif(X,2))). |
| 4880 | | :- assert_must_succeed_any((preferences:preference(use_clpfd_solver,false) ; |
| 4881 | | 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))). |
| 4882 | | :- assert_must_succeed((cardinality_as_int([int(1)|avl_set(node(int(3),true,0,empty,empty))],int(2)))). |
| 4883 | | :- assert_must_succeed((cardinality_as_int([int(1)|avl_set(node(int(3),true,0,empty,empty))],X),X==int(2))). |
| 4884 | | % check that we deal with repeated elements, in case no other predicate sets up a list ! |
| 4885 | | :- assert_must_fail((cardinality_as_int([int(1),int(1)],int(2)))). |
| 4886 | | :- assert_must_fail((cardinality_as_int([int(1),int(1)],_))). |
| 4887 | | :- assert_must_fail((cardinality_as_int(X,int(2)),X=[int(1),int(1)])). |
| 4888 | | :- assert_must_fail((cardinality_as_int([int(3)|avl_set(node(int(3),true,0,empty,empty))],_))). |
| 4889 | | :- assert_must_fail((cardinality_as_int([X|avl_set(node(int(3),true,0,empty,empty))],int(2)),X=int(3))). |
| 4890 | | |
| 4891 | | |
| 4892 | | cardinality_as_int(S,I) :- cardinality_as_int_wf(S,I,no_wf_available). % TO DO: remove this predicate ? |
| 4893 | | :- load_files(library(system), [when(compile_time), imports([environ/2])]). |
| 4894 | | :- if(environ(prob_data_validation_mode,true)). |
| 4895 | | :- block cardinality_as_int_wf(-,?,?). % avoid instantiating list skeletons; cause backtracking in unifications,... |
| 4896 | | :- else. |
| 4897 | | :- block cardinality_as_int_wf(-,-,?). |
| 4898 | | :- endif. |
| 4899 | | % can return inf ! |
| 4900 | | cardinality_as_int_wf(Set,int(Card),WF) :- |
| 4901 | | cardinality_as_int1(Set,Card,Card,WF). |
| 4902 | | |
| 4903 | | cardinality_as_int1(Set,Card,ResCard,WF) :- |
| 4904 | | (number(Card) |
| 4905 | | -> cardinality_as_int1b(Set,Card,ResCard,WF) |
| 4906 | | ; cardinality_as_int1b(Set,Card,ResCard,WF), |
| 4907 | | (var(Set) -> |
| 4908 | | (clpfd_domain(Card,Low,_Up), |
| 4909 | | number(Low), Low>1, |
| 4910 | | unbound_variable_for_card(Set) |
| 4911 | | % TO DO: also use this optimization later in cardinality_as_int2 |
| 4912 | | -> setup_ordered_list_skeleton(Low,Skel,open,WF), |
| 4913 | | Skel=Set |
| 4914 | | ; get_wait_flag(1,force_non_empty(Set,Card),WF,LWF), |
| 4915 | | force_non_empty0(Set,Card,LWF) |
| 4916 | | ) |
| 4917 | | ; true) |
| 4918 | | ). |
| 4919 | | % tests 1418, 1419, 1628, 1776 require that cardinality_as_int1b be triggered quickly |
| 4920 | | :- block cardinality_as_int1b(-,-,?,?). % with this the self-check with post_constraint('#>='(C,2) fails |
| 4921 | | % cardinality_as_int1(Set, CardValue, ComputedCardValue) : CardValue should be unified with ComputedCardValue afterwards |
| 4922 | | cardinality_as_int1b(Set,Card,ResCard,WF) :- |
| 4923 | | %portray_waitflags(WF),nl, |
| 4924 | | number(Card), unbound_variable_for_card(Set), |
| 4925 | | !, % we know the cardinality and the set is not yet bound; this improvement is tested in tests 1417, 1418 |
| 4926 | | setup_ordered_list_skeleton(Card,Skel,closed,WF), |
| 4927 | | (Card,Set) = (ResCard,Skel). % bypass equal_object: assign variable in one-go |
| 4928 | | cardinality_as_int1b(Set,Card,ResCard,WF) :- nonvar(Set),!, |
| 4929 | | cardinality_as_int2(Set,0,Card,ResCard,[],WF). |
| 4930 | | cardinality_as_int1b(Set,Card,ResCard,WF) :- |
| 4931 | | % Set is a variable but not unbound_variable_for_cons |
| 4932 | | % Unifications can be very expensive when we set up long lists |
| 4933 | | % Idea: multiply Card by a factor and delay instantiating; maybe we get a avl_set; see test 456 |
| 4934 | | Prio is Card*100, |
| 4935 | | get_wait_flag(Prio,cardinality_as_int1(Set,Card),WF,LWF2), |
| 4936 | | when((nonvar(Set) ; nonvar(LWF2)), |
| 4937 | | cardinality_as_int2(Set,0,Card,ResCard,[],WF)). |
| 4938 | | %force_non_empty0(Set,Card,1). |
| 4939 | | |
| 4940 | | :- if(environ(prob_data_validation_mode,true)). |
| 4941 | | :- block cardinality_as_int2(-,?,?,?,?,?). % avoid instantiating list skeletons; cause backtracking in unifications,... |
| 4942 | | :- else. |
| 4943 | | :- block cardinality_as_int2(-,?,-,?,?,?). |
| 4944 | | :- endif. |
| 4945 | | cardinality_as_int2(X,C,Res,ResultValue,_,WF) :- |
| 4946 | | C==Res,!,empty_set_wf(X,WF),ResultValue=Res. % avoid choice point below |
| 4947 | | cardinality_as_int2(X,C,Res,ResultValue,SoFar,WF) :- nonvar(X), X \= [], X\= [_|_],!, |
| 4948 | | (is_custom_explicit_set(X) |
| 4949 | | -> explicit_set_cardinality_wf(X,ESC,WF), blocking_add_card(C,ESC,ResultValue), |
| 4950 | | disjoint_sets(X,SoFar,WF) |
| 4951 | | ; add_error_fail(cardinality_as_int2,'First argument not set: ',cardinality_as_int2(X,C,Res)) |
| 4952 | | ). |
| 4953 | | cardinality_as_int2([],C,Res,ResultValue,_,_WF) :- C=ResultValue, Res=ResultValue. |
| 4954 | | cardinality_as_int2([H|T],C,Res,ResultValue,SoFar,WF) :- |
| 4955 | | C1 is C+1, |
| 4956 | | not_element_of_wf(H,SoFar,WF), % do we always need to check this ? relevant for test 1828 |
| 4957 | | add_new_element_wf(H,SoFar,SoFar2,WF), |
| 4958 | | (ground(Res) -> safe_less_than_equal(cardinality_as_int2,C1,Res) |
| 4959 | | /* check consistency so far if cardinality provided */ |
| 4960 | | ; clpfd_geq(Res,C1,_) |
| 4961 | | ), |
| 4962 | | force_non_empty(T,C1,Res,1), % Use WF ? |
| 4963 | | cardinality_as_int2(T,C1,Res,ResultValue,SoFar2,WF). |
| 4964 | | |
| 4965 | | % setup an list skeleton with ordering constraints to avoid duplicate solutions |
| 4966 | | setup_ordered_list_skeleton(0,R,Closed,_WF) :- !, (Closed=closed -> R=[] ; true). |
| 4967 | | setup_ordered_list_skeleton(N,[H|T],Closed,WF) :- |
| 4968 | | all_different_wf([H|T],WF), |
| 4969 | | N1 is N-1, setup_list_skel_aux(N1,H,T,Closed). |
| 4970 | | |
| 4971 | | |
| 4972 | | :- use_module(kernel_ordering,[ordered_value/2]). |
| 4973 | | %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 |
| 4974 | | setup_list_skel_aux(0,Prev,R,Closed) :- !, (Closed=closed -> R=[] ; lazy_ordered_value(R,Prev)). |
| 4975 | | setup_list_skel_aux(N,Prev,[H|T],Closed) :- ordered_value(Prev,H), |
| 4976 | | N>0, N1 is N-1, setup_list_skel_aux(N1,H,T,Closed). |
| 4977 | | |
| 4978 | | :- block lazy_ordered_value(-,?). |
| 4979 | | lazy_ordered_value([H|T],Prev) :- !, ordered_value(Prev,H), lazy_ordered_value(T,H). |
| 4980 | | lazy_ordered_value(_,_). |
| 4981 | | |
| 4982 | | |
| 4983 | | % TO DO: use clpfd all_different for integers !? |
| 4984 | | % get_integer_list(Set,IntList), clpfd_alldifferent(IntList). |
| 4985 | | % ensure we have all different constraint in case ordered_value does not succeed in enforcing order! |
| 4986 | | all_different_wf(ListOfValues,WF) :- |
| 4987 | | all_different2(ListOfValues,[],WF). |
| 4988 | | :- block all_different2(-,?,?). |
| 4989 | | all_different2([],_,_) :- !. |
| 4990 | | all_different2([H|T],SoFar,WF) :- !, all_different3(SoFar,H,WF), all_different2(T,[H|SoFar],WF). |
| 4991 | | all_different2(CS,SoFar,WF) :- is_custom_explicit_set(CS), |
| 4992 | | disjoint_sets(CS,SoFar,WF). % already done above by cardinality_as_int2 ? |
| 4993 | | all_different3([],_,_). |
| 4994 | | all_different3([H|T],X,WF) :- not_equal_object_wf(H,X,WF), all_different3(T,X,WF). |
| 4995 | | |
| 4996 | | :- block force_non_empty0(-,-,-). |
| 4997 | | force_non_empty0(Set,Card,LWF) :- var(Set), var(Card), |
| 4998 | | clpfd_domain(Card,Low,Up), |
| 4999 | | (integer(Low) ; integer(Up)), !, % we know we have a finite cardinality |
| 5000 | | clpfd_interface:try_post_constraint((Card#=0) #<=> EmptyR01), |
| 5001 | | prop_non_empty(EmptyR01,Set,LWF). |
| 5002 | | force_non_empty0(_,_,_). |
| 5003 | | |
| 5004 | | % here we assume that the cardinalities cannot be infinite inf |
| 5005 | | :- block force_non_empty(-,?,-,-). |
| 5006 | | force_non_empty(Set,CSoFar,TotalCard,LWF) :- |
| 5007 | | var(Set), var(TotalCard), |
| 5008 | | preference(data_validation_mode,false),!, |
| 5009 | | clpfd_interface:try_post_constraint((TotalCard#=CSoFar) #<=> EmptyR01), |
| 5010 | | prop_non_empty(EmptyR01,Set,LWF). |
| 5011 | | force_non_empty(_,_,_,_). |
| 5012 | | :- block prop_non_empty(-,-,?). |
| 5013 | | prop_non_empty(_,X,_) :- nonvar(X),!. % do nothing; cardinality_as_int2 will be called anyway |
| 5014 | | prop_non_empty(0,X,LWF) :- /* X is var; first arg nonvar */ !, not_empty_set_lwf(X,LWF). |
| 5015 | | %prop_non_empty(1,X,_). % empty_set not really required: TotalCard is now instantiated; cardinality_as_int2 will get called |
| 5016 | | prop_non_empty(_,_,_). |
| 5017 | | |
| 5018 | | |
| 5019 | | |
| 5020 | | :- assert_must_succeed(exhaustive_kernel_check(cardinality_as_int_for_wf(global_set('NATURAL'),inf))). |
| 5021 | | :- assert_must_succeed(exhaustive_kernel_check(cardinality_as_int_for_wf([],0))). |
| 5022 | | :- assert_must_succeed(exhaustive_kernel_check_opt(cardinality_as_int_for_wf([int(2)],1), |
| 5023 | | preferences:get_preference(convert_comprehension_sets_into_closures,false))). % in this case inf returned for closures |
| 5024 | | :- assert_must_succeed(exhaustive_kernel_check_opt(cardinality_as_int_for_wf([int(3),int(1),int(-1),int(100)],4), |
| 5025 | | preferences:get_preference(convert_comprehension_sets_into_closures,false))). |
| 5026 | | :- assert_must_succeed(exhaustive_kernel_fail_check_opt(cardinality_as_int_for_wf([int(3),int(1),int(-1),int(100)],1000), |
| 5027 | | preferences:get_preference(convert_comprehension_sets_into_closures,false))). |
| 5028 | | :- assert_must_succeed(exhaustive_kernel_fail_check_opt(cardinality_as_int_for_wf(global_set('NATURAL'),1000), |
| 5029 | | preferences:get_preference(convert_comprehension_sets_into_closures,false))). |
| 5030 | | % a simpler version without propagation to result; for waitflag priority computation or similar |
| 5031 | | % it may return inf for closures marked as symbolic ! |
| 5032 | | cardinality_as_int_for_wf(Set,Card) :- cardinality_as_int_for_wf0(Set,0,Card). |
| 5033 | | :- block cardinality_as_int_for_wf0(-,?,-). |
| 5034 | | cardinality_as_int_for_wf0(X,C,Res) :- |
| 5035 | | (nonvar(X) -> cardinality_as_int_for_wf1(X,C,Res) |
| 5036 | | ; Res==inf -> cardinality_as_int_for_inf(X,C) |
| 5037 | | % TODO: what about inf_overflow here |
| 5038 | | ; cardinality_as_int_for_wf2(X,C,Res)). |
| 5039 | | |
| 5040 | | :- block cardinality_as_int_for_inf(-,?). |
| 5041 | | cardinality_as_int_for_inf(X,C) :- cardinality_as_int_for_wf1(X,C,inf). |
| 5042 | | |
| 5043 | | cardinality_as_int_for_wf1([],C,Res) :- !,C=Res. |
| 5044 | | cardinality_as_int_for_wf1([_H|T],C,Res) :- !,C1 is C+1, |
| 5045 | | cardinality_as_int_for_wf0(T,C1,Res). |
| 5046 | | cardinality_as_int_for_wf1(X,C,Res) :- is_custom_explicit_set(X),!, |
| 5047 | | explicit_set_cardinality_for_wf(X,ESC), blocking_add_card(C,ESC,Res). |
| 5048 | | cardinality_as_int_for_wf1(term(T),C,Res) :- nonvar(T), T=no_value_for(ID), |
| 5049 | | 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 |
| 5050 | | !, C=Res. |
| 5051 | | cardinality_as_int_for_wf1(X,C,Res) :- |
| 5052 | | add_internal_error('First arg is not a set: ',cardinality_as_int_for_wf1(X,C,Res)),fail. |
| 5053 | | |
| 5054 | | % first argument was var, third argument not inf hence third arg must be set |
| 5055 | | %cardinality_as_int_for_wf2([],C,C). |
| 5056 | | cardinality_as_int_for_wf2([],C,Res) :- (C==Res -> ! ; C=Res). |
| 5057 | | cardinality_as_int_for_wf2([_H|T],C,Res) :- C<Res, C1 is C+1, |
| 5058 | | (var(T) -> cardinality_as_int_for_wf2(T,C1,Res) ; cardinality_as_int_for_wf1(T,C1,Res)). |
| 5059 | | |
| 5060 | | |
| 5061 | | |
| 5062 | | :- assert_must_succeed(exhaustive_kernel_check_wf(same_cardinality_wf(global_set('NATURAL'),global_set('NATURAL'),WF),WF)). |
| 5063 | | :- assert_must_succeed(exhaustive_kernel_check_wf(same_cardinality_wf(global_set('NATURAL'),global_set('NATURAL1'),WF),WF)). |
| 5064 | | :- assert_must_succeed(exhaustive_kernel_check_wf(same_cardinality_wf([int(2),int(1)],[int(11),int(22)],WF),WF)). |
| 5065 | | :- assert_must_succeed(exhaustive_kernel_fail_check_wf(same_cardinality_wf([],[int(11),int(22)],WF),WF)). |
| 5066 | | :- assert_must_succeed(exhaustive_kernel_fail_check_wf(same_cardinality_wf([int(11),int(22),int(33)],[int(11),int(22)],WF),WF)). |
| 5067 | | :- assert_must_succeed(exhaustive_kernel_fail_check_wf(same_cardinality_wf(global_set('NATURAL1'),[int(11),int(22)],WF),WF)). |
| 5068 | | |
| 5069 | | :- block same_cardinality_wf(-,-,?). |
| 5070 | | same_cardinality_wf(Set1,Set2,WF) :- |
| 5071 | | (var(Set1) -> same_card_aux(Set2,Set1,WF) ; same_card_aux(Set1,Set2,WF)). |
| 5072 | | |
| 5073 | | same_card_aux(Set1,Set2,WF) :- |
| 5074 | | (nonvar(Set1),is_custom_explicit_set(Set1,cardinality) |
| 5075 | | -> explicit_set_cardinality_wf(Set1,Card,WF), |
| 5076 | | (Card==inf -> is_infinite_set_wf(Set2,WF) |
| 5077 | | % assumption: if inf then immediately infinite; TO DO: distinguish between infinite(s) and very large |
| 5078 | | ; cardinality_as_int_wf(Set2,int(Card),WF) |
| 5079 | | ) |
| 5080 | | ; cardinality3(Set1,PCard,WF), |
| 5081 | | cardinality_peano_wf(Set2,PCard,WF) |
| 5082 | | ). |
| 5083 | | |
| 5084 | | :- assert_must_succeed(exhaustive_kernel_check(cardinality_peano_wf([],0,no_wf_available))). |
| 5085 | | :- assert_must_succeed(exhaustive_kernel_check(cardinality_peano_wf([int(11)],s(0),no_wf_available))). |
| 5086 | | :- assert_must_succeed(exhaustive_kernel_check(cardinality_peano_wf([int(11),int(22)],s(s(0)),no_wf_available))). |
| 5087 | | % cardinality as peano number |
| 5088 | | :- block cardinality_peano_wf(-,-,?). |
| 5089 | | cardinality_peano_wf(Set,PCard,WF) :- |
| 5090 | | (nonvar(Set),is_custom_explicit_set(Set,cardinality) |
| 5091 | | -> explicit_set_cardinality_wf(Set,Card,WF), |
| 5092 | | card_convert_int_to_peano(Card,PCard) |
| 5093 | | ; cardinality3(Set,PCard,WF) |
| 5094 | | ). |
| 5095 | | |
| 5096 | | :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(3,s(s(s(0)))))). |
| 5097 | | :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(2,S),S==s(s(0)))). |
| 5098 | | :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(X,s(s(s(0)))),X==3)). |
| 5099 | | :- assert_must_succeed((kernel_objects:card_convert_int_to_peano(X,s(s(s(Y)))),X=4,Y==s(0))). |
| 5100 | | :- assert_must_fail((kernel_objects:card_convert_int_to_peano(X,s(s(s(_Y)))),X=2)). |
| 5101 | | |
| 5102 | | :- block card_convert_int_to_peano(-,-). |
| 5103 | | card_convert_int_to_peano(X,S0) :- var(X), !, |
| 5104 | | peel_s(S0,SX,RemS), |
| 5105 | | (RemS==0 -> X=SX |
| 5106 | | ; int_plus(int(X1),int(SX),int(X)), |
| 5107 | | greater_than_equal(int(X1),int(0)), |
| 5108 | | card_convert_int_to_peano(X1,RemS)). |
| 5109 | | card_convert_int_to_peano(inf,X) :- !, |
| 5110 | | infinite_peano(X), |
| 5111 | | add_message(cardinality,'*** WARNING: Large or infinite Cardinality.'). |
| 5112 | | %convert_int_to_peano(100,X). % used to limit to 100 |
| 5113 | | card_convert_int_to_peano(X,P) :- convert_int_to_peano(X,P). |
| 5114 | | |
| 5115 | | :- block infinite_peano(-). |
| 5116 | | infinite_peano(inf). |
| 5117 | | infinite_peano(0) :- fail. |
| 5118 | | infinite_peano(s(X)) :- infinite_peano(X). |
| 5119 | | |
| 5120 | | peel_s(0,0,0). |
| 5121 | | peel_s(s(X),Res,SX) :- (var(X) -> Res=1, SX=X ; peel_s(X,RX,SX), Res is RX+1). |
| 5122 | | |
| 5123 | | :- block cardinality3(-,?,?). % avoids instantiating set; to do: use kernel_cardinality instead |
| 5124 | | % 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 |
| 5125 | | % :- block cardinality3(-,-,?). |
| 5126 | | cardinality3(Set,SC,WF) :- var(Set),!, |
| 5127 | | (SC=0 -> Set=[] ; SC=s(C),Set=[_|T],cardinality3(T,C,WF)). |
| 5128 | | cardinality3([],0,_). |
| 5129 | ? | cardinality3([_|T],s(C),WF) :- cardinality3(T,C,WF). |
| 5130 | | cardinality3(avl_set(AVL),Res,WF) :- cardinality_peano_wf(avl_set(AVL),Res,WF). |
| 5131 | | cardinality3(closure(P,T,B),Res,WF) :- cardinality_peano_wf(closure(P,T,B),Res,WF). |
| 5132 | | |
| 5133 | | |
| 5134 | | |
| 5135 | | |
| 5136 | | |
| 5137 | | |
| 5138 | | :- assert_must_succeed(exhaustive_kernel_check(card_geq([int(2),int(4),int(1)],s(s(s(0)))))). |
| 5139 | | :- assert_must_succeed((kernel_objects:card_geq(global_set('Name'),s(s(s(0)))))). |
| 5140 | | :- assert_must_succeed((kernel_objects:card_geq([int(1),int(2)],s(s(0))))). |
| 5141 | | :- assert_must_succeed((kernel_objects:card_geq([int(1),int(2)],s(0)))). |
| 5142 | | :- assert_must_fail((kernel_objects:card_geq(global_set('Name'),s(s(s(s(0))))))). |
| 5143 | | :- assert_must_fail((kernel_objects:card_geq([int(1),int(2)],s(s(s(0)))))). |
| 5144 | | |
| 5145 | | card_geq(Set,Card) :- card_geq_wf(Set,Card,no_wf_available). |
| 5146 | | |
| 5147 | | :- block card_geq_wf(-,-,?). |
| 5148 | | card_geq_wf(Set,Card,WF) :- |
| 5149 | | (nonvar(Set),is_custom_explicit_set(Set,card_geq) |
| 5150 | ? | -> explicit_set_cardinality_wf(Set,CCard,WF), geq_int_peano(CCard,Card) |
| 5151 | | ; card_geq2(Set,Card,WF) ). |
| 5152 | | % should we call setup_ordered_list_skeleton(Card,Set,open) |
| 5153 | | :- block card_geq2(?,-,?). |
| 5154 | | card_geq2(_,C,_) :- C==0,!. |
| 5155 | | card_geq2(S,C,_) :- S==[],!,C=0. |
| 5156 | | card_geq2(S,s(C),WF) :- var(S),!,S=[_|T],card_geq2(T,C,WF). |
| 5157 | | card_geq2([_|T],s(C),WF) :- card_geq2(T,C,WF). |
| 5158 | | card_geq2(avl_set(A),s(C),WF) :- card_geq_wf(avl_set(A),s(C),WF). |
| 5159 | | card_geq2(closure(P,T,B),s(C),WF) :- card_geq_wf(closure(P,T,B),s(C),WF). |
| 5160 | | card_geq2(global_set(G),s(C),WF) :- card_geq_wf(global_set(G),s(C),WF). |
| 5161 | | |
| 5162 | | :- block geq_int_peano(-,-). |
| 5163 | | geq_int_peano(_,0). |
| 5164 | ? | geq_int_peano(X,s(C)) :- geq_int_peano1(X,C). |
| 5165 | | :- block geq_int_peano1(-,?). |
| 5166 | | geq_int_peano1(inf,_) :- !. |
| 5167 | | geq_int_peano1(inf_overflow,_) :- !. |
| 5168 | ? | geq_int_peano1(X,C) :- X>0, X1 is X-1, geq_int_peano(X1,C). |
| 5169 | | |
| 5170 | | :- block convert_int_to_peano(-,?). |
| 5171 | | convert_int_to_peano(X,Y) :- convert_int_to_peano2(X,Y). |
| 5172 | | convert_int_to_peano2(inf,_). |
| 5173 | | convert_int_to_peano2(inf_overflow,_). |
| 5174 | | convert_int_to_peano2(X,R) :- number(X), |
| 5175 | | (X>100000 |
| 5176 | | -> print('*** Warning: converting large integer to peano: '),print(X),nl, |
| 5177 | | (X>1000000000 -> print('*** treat like inf'),nl % no hope of ever finishing, do not instantiate just like inf |
| 5178 | | ; convert_int_to_peano3(X,R)) |
| 5179 | | ; convert_int_to_peano3(X,R) |
| 5180 | | ). |
| 5181 | | convert_int_to_peano3(0,R) :- !, R=0. |
| 5182 | | convert_int_to_peano3(X,s(P)) :- |
| 5183 | | (X>0 -> X1 is X-1, convert_int_to_peano3(X1,P) |
| 5184 | | ; X<0 -> add_error_and_fail(convert_int_to_peano,'Negative nr cannot be converted to peano: ',X) |
| 5185 | | ). |
| 5186 | | |
| 5187 | | % not used: |
| 5188 | | %:- block convert_peano_to_int(-,?). |
| 5189 | | %convert_peano_to_int(0,0). |
| 5190 | | %convert_peano_to_int(s(P),X) :- convert_peano_to_int(P,X1), X is X1+1. |
| 5191 | | |
| 5192 | | :- assert_must_succeed((kernel_objects:cardinality_greater_equal(Set,set(integer),int(X),integer,_WF), X=3, |
| 5193 | | nonvar(Set),Set=[_|S2],nonvar(S2),S2=[_|S3],nonvar(S3),S3=[_|S4],var(S4), Set=[int(1),int(2),int(3)] )). |
| 5194 | | :- assert_must_succeed((kernel_objects:cardinality_greater(Set,set(integer),int(X),integer,_WF), X=2, |
| 5195 | | nonvar(Set),Set=[_|S2],nonvar(S2),S2=[_|S3],nonvar(S3),S3=[_|S4],var(S4), Set=[int(1),int(2),int(3)] )). |
| 5196 | | /* special predicates called for e.g. card(Set)>X */ |
| 5197 | | cardinality_greater(Set,TypeSet,int(X),_,WF) :- |
| 5198 | | kernel_objects:max_cardinality(TypeSet,MaxCard), |
| 5199 | | (number(MaxCard) -> less_than(int(X),int(MaxCard)) ; true), |
| 5200 | ? | card_greater2(Set,X,WF). |
| 5201 | | :- block card_greater2(?,-,?). |
| 5202 | ? | card_greater2(Set,X,WF) :- X1 is X+1, card_greater_equal2(Set,X1,WF). |
| 5203 | | |
| 5204 | | cardinality_greater_equal(Set,TypeSet,int(X),_,WF) :- |
| 5205 | | kernel_objects:max_cardinality(TypeSet,MaxCard), |
| 5206 | | (number(MaxCard) -> less_than_equal(int(X),int(MaxCard)) ; true), |
| 5207 | ? | card_greater_equal2(Set,X,WF). |
| 5208 | | :- block card_greater_equal2(?,-,?). |
| 5209 | | card_greater_equal2(Set,X,WF) :- |
| 5210 | | (X<1 -> true % potential WD issue, hence this predicates should only be called when no wd issue |
| 5211 | | ; X=1 -> not_empty_set_wf(Set,WF) % ditto: Set could be infinite |
| 5212 | | ; var(Set) -> setup_ordered_list_skeleton(X,Set,open,WF) |
| 5213 | | ; convert_int_to_peano(X,Peano), |
| 5214 | ? | card_geq_wf(Set,Peano,WF)). |
| 5215 | | |
| 5216 | | |
| 5217 | | |
| 5218 | | %is_cartesian_pair_or_times(P,X,Y) :- is_cartesian_pair(P,X,Y). |
| 5219 | | %is_cartesian_pair_or_times(int(Z),int(X),int(Y)) :- times(int(X),int(Y),int(Z)). |
| 5220 | | |
| 5221 | | is_cartesian_pair_wf((X,Y),XType,YType,WF) :- |
| 5222 | ? | check_element_of_wf(X,XType,WF), check_element_of_wf(Y,YType,WF). |
| 5223 | | |
| 5224 | | :- assert_must_succeed(exhaustive_kernel_check_wf(kernel_objects:not_is_cartesian_pair((int(1),int(1)), |
| 5225 | | [int(1),int(2)],[int(2),int(3)],WF),WF)). |
| 5226 | | :- assert_must_succeed(exhaustive_kernel_check_wf(kernel_objects:not_is_cartesian_pair((int(3),int(2)), |
| 5227 | | [int(1),int(2)],[int(2),int(3)],WF),WF)). |
| 5228 | | :- assert_must_succeed((kernel_objects:not_is_cartesian_pair((int(1),int(1)), |
| 5229 | | [int(1),int(2)],[int(2),int(3)],_WF))). |
| 5230 | | :- assert_must_succeed((kernel_objects:not_is_cartesian_pair((int(3),int(1)), |
| 5231 | | [int(1),int(2)],[int(2),int(3)],_WF))). |
| 5232 | | :- assert_must_fail((kernel_objects:not_is_cartesian_pair((int(1),int(3)), |
| 5233 | | [int(1),int(2)],[int(2),int(3)],_WF))). |
| 5234 | | :- assert_must_succeed((kernel_objects:not_is_cartesian_pair((X,int(3)), |
| 5235 | | [int(1),int(2)],[int(2),int(3)],_WF),X=int(4))). |
| 5236 | | |
| 5237 | | |
| 5238 | | not_is_cartesian_pair((X,Y),XType,YType,WF) :- |
| 5239 | ? | not_is_cartesian_pair0(X,Y,XType,YType,WF). |
| 5240 | | |
| 5241 | | :- block not_is_cartesian_pair0(-,-,?,?,?). |
| 5242 | | not_is_cartesian_pair0(X,Y,XType,YType,WF) :- |
| 5243 | ? | (nonvar(X) -> not_is_cartesian_pair1(X,Y,XType,YType,WF) |
| 5244 | | ; not_is_cartesian_pair1(Y,X,YType,XType,WF)). |
| 5245 | | |
| 5246 | | not_is_cartesian_pair1(X,Y,XType,YType,WF) :- |
| 5247 | | membership_test_wf(XType,X,MemResX,WF), |
| 5248 | | (var(MemResX) -> membership_test_wf(YType,Y,MemResY,WF) ; true), |
| 5249 | ? | not_is_cartesian_pair3(MemResX,X,XType,MemResY,Y,YType,WF). |
| 5250 | | |
| 5251 | | :- block not_is_cartesian_pair3(-,?,?, -,?,?, ?). |
| 5252 | | not_is_cartesian_pair3(MemResX,X,XType, MemResY,Y,YType, WF) :- |
| 5253 | | (MemResX==pred_false -> true |
| 5254 | | ; MemResY==pred_false -> true |
| 5255 | ? | ; MemResX==pred_true -> not_element_of_wf(Y,YType,WF) |
| 5256 | | ; not_element_of_wf(X,XType,WF) |
| 5257 | | ). |
| 5258 | | |
| 5259 | | |
| 5260 | | |
| 5261 | | /***************************/ |
| 5262 | | /* power_set(Set,TypeSet) */ |
| 5263 | | /* Set : POW(TypeSet) */ |
| 5264 | | /***************************/ |
| 5265 | | |
| 5266 | | :- assert_must_succeed(exhaustive_kernel_check(power_set([int(2),int(4)],[[int(2)], |
| 5267 | | [int(4)],[],[int(4),int(2)]]))). |
| 5268 | | :- assert_must_succeed(power_set([int(1)],[[int(1)],[]])). |
| 5269 | | :- assert_must_succeed((power_set([int(1),int(2)],R), |
| 5270 | | equal_object(R,[[],[int(1)],[int(2)],[int(1),int(2)]]))). |
| 5271 | | :- assert_must_succeed(power_set([],[[]])). |
| 5272 | | |
| 5273 | | % not used anymore, except for empty set and singleton sets (see do_not_keep_symbolic_unary) |
| 5274 | | :- block power_set(-,?). |
| 5275 | | power_set([],Res) :- !,equal_object_optimized([[]],Res,power_set). |
| 5276 | | power_set(Set1,Res) :- custom_explicit_sets:singleton_set(Set1,El),!, |
| 5277 | | equal_object_optimized([[],[El]],Res,power_set). |
| 5278 | | power_set(S,Res) :- |
| 5279 | | cardinality_peano_wf(S,Card,no_wf_available), |
| 5280 | | when(ground(Card), /* when all elements are known */ |
| 5281 | | (expand_custom_set_to_list_wf(S,SE,Done,power_set,no_wf_available), |
| 5282 | | when(nonvar(Done), |
| 5283 | | (gen_all_subsets(SE,PowerS), |
| 5284 | | equal_object_optimized(PowerS,Res,power_set) ) |
| 5285 | | ) |
| 5286 | | )). |
| 5287 | | |
| 5288 | | :- assert_must_succeed((kernel_objects:gen_all_subsets([X],R), R== [[],[X]])). |
| 5289 | | :- assert_must_succeed((kernel_objects:gen_all_subsets([X,Y],R), R== [[],[Y],[X],[Y,X]])). |
| 5290 | | % we do not use findall to keep variable links, see test 2103 |
| 5291 | | gen_all_subsets(List,AllSubLists) :- gen_all_subsets(List,[[]],AllSubLists). |
| 5292 | | add_el(H,T,[H|T]). |
| 5293 | | gen_all_subsets([],Acc,Acc). |
| 5294 | | gen_all_subsets([H|T],Acc,Res) :- gen_all_subsets(T,Acc,R1), |
| 5295 | | append(R1,R2,Res), % DCG would be better; but power_set is not really used anymore for longer lists |
| 5296 | | maplist(add_el(H),Acc,Acc2), gen_all_subsets(T,Acc2,R2). |
| 5297 | | |
| 5298 | | |
| 5299 | | :- assert_must_succeed(exhaustive_kernel_check(non_empty_power_set([int(2),int(4)],[[int(2)], |
| 5300 | | [int(4)],[int(4),int(2)]]))). |
| 5301 | | :- assert_must_succeed(non_empty_power_set([int(1)],[[int(1)]])). |
| 5302 | | :- assert_must_succeed((non_empty_power_set([int(1),int(2)],R), |
| 5303 | | equal_object(R,[[int(1)],[int(2)],[int(1),int(2)]]))). |
| 5304 | | :- assert_must_succeed(non_empty_power_set([],[])). |
| 5305 | | |
| 5306 | | :- block non_empty_power_set(-,?). |
| 5307 | | non_empty_power_set([],Res) :- !,equal_object_optimized([],Res,non_empty_power_set). |
| 5308 | | non_empty_power_set(Set1,Res) :- custom_explicit_sets:singleton_set(Set1,El),!, |
| 5309 | | equal_object_optimized([[El]],Res,non_empty_power_set). |
| 5310 | | non_empty_power_set(S,Res) :- |
| 5311 | | cardinality_peano_wf(S,Card,no_wf_available), |
| 5312 | | when(ground(Card), /* when all elements are known */ |
| 5313 | | (expand_custom_set_to_list_wf(S,SE,Done,non_empty_power_set,no_wf_available), |
| 5314 | | when(nonvar(Done), |
| 5315 | | (gen_all_subsets(SE,PowerS), |
| 5316 | | delete(PowerS,[],NE_PowerS), |
| 5317 | | equal_object_optimized(NE_PowerS,Res,non_empty_power_set) ) |
| 5318 | | ) |
| 5319 | | )). |
| 5320 | | |
| 5321 | | |
| 5322 | | |
| 5323 | | /* ------- */ |
| 5324 | | /* BOOLEAN */ |
| 5325 | | /* ------- */ |
| 5326 | | |
| 5327 | | % following predicates are not used: |
| 5328 | | %is_boolean(pred_true /* bool_true */). |
| 5329 | | %is_boolean(pred_false /* bool_false */). |
| 5330 | | %is_not_boolean(X) :- dif(X,pred_true /* bool_true */), dif(X,pred_false /* bool_false */). |
| 5331 | | |
| 5332 | | /* ------- */ |
| 5333 | | /* NUMBERS */ |
| 5334 | | /* ------- */ |
| 5335 | | |
| 5336 | | |
| 5337 | | is_integer(int(X),_WF) :- when(ground(X),integer(X)). |
| 5338 | | :- block is_not_integer(-). |
| 5339 | | is_not_integer(X) :- X \= int(_), % will be called for x /: INTEGER; should always fail. |
| 5340 | | add_internal_error('Wrong type argument: ',is_not_integer(X)),fail. |
| 5341 | | |
| 5342 | | is_natural(int(X),_WF) :- clpfd_geq2(X,0,Posted), (Posted==true -> true ; number_geq(X,0)). |
| 5343 | | is_natural1(int(X),_WF) :- clpfd_geq2(X,1,Posted), (Posted==true -> true ; number_geq(X,1)). |
| 5344 | | :- block number_geq(-,?). |
| 5345 | | number_geq(X,N) :- X>=N. |
| 5346 | | :- block number_leq(-,?). |
| 5347 | | number_leq(X,N) :- X=<N. |
| 5348 | | |
| 5349 | | :- assert_must_succeed(is_implementable_int(int(0),_WF)). |
| 5350 | | :- assert_must_fail(is_not_implementable_int(int(0))). |
| 5351 | | |
| 5352 | | |
| 5353 | | is_implementable_int(int(X),WF) :- element_of_global_integer_set_wf('INT',X,WF,unkmown). |
| 5354 | | is_implementable_nat(int(X),WF) :- element_of_global_integer_set_wf('NAT',X,WF,unknown). |
| 5355 | | is_implementable_nat1(int(X),WF) :- element_of_global_integer_set_wf('NAT1',X,WF,unknown). |
| 5356 | | is_not_implementable_int(X) :- not_element_of_global_set(X,'INT'). |
| 5357 | | is_not_implementable_nat(X) :- not_element_of_global_set(X,'NAT'). |
| 5358 | | is_not_implementable_nat1(X) :- not_element_of_global_set(X,'NAT1'). |
| 5359 | | |
| 5360 | | is_not_natural(int(X)) :- clpfd_geq2(-1,X,Posted), (Posted=true -> true ; number_leq(X,-1)). |
| 5361 | | is_not_natural1(int(X)) :- clpfd_geq2(0,X,Posted), (Posted==true -> true ; number_leq(X,0)). |
| 5362 | | |
| 5363 | | :- assert_must_succeed(exhaustive_kernel_check(less_than(int(2),int(3)))). |
| 5364 | | :- assert_must_succeed(( safe_less_than(A,B),A=3,B=5 )). |
| 5365 | | :- assert_must_succeed(( safe_less_than(A,B),B=5,A=3 )). |
| 5366 | | :- assert_must_fail(( safe_less_than(A,B),A=5,B=3 )). |
| 5367 | | :- assert_must_fail(( safe_less_than(A,B),B=3,A=5 )). |
| 5368 | | :- assert_must_fail(( safe_less_than(A,B),A=5,B=5 )). |
| 5369 | | :- assert_must_fail(( safe_less_than(A,B),B=5,A=5 )). |
| 5370 | | |
| 5371 | | less_than(int(X),int(Y)) :- |
| 5372 | | (number(X),number(Y) -> X < Y |
| 5373 | | ; clpfd_lt(X,Y,Posted), |
| 5374 | | (Posted=true -> true ; safe_less_than(X,Y))). |
| 5375 | | less_than_direct(X,Y) :- |
| 5376 | | (number(X),number(Y) -> X < Y |
| 5377 | | ; clpfd_lt(X,Y,Posted), |
| 5378 | | (Posted=true -> true ; safe_less_than(X,Y))). |
| 5379 | | :- block safe_less_than(-,?), safe_less_than(?,-). |
| 5380 | | safe_less_than(X,Y) :- |
| 5381 | | (number(X),number(Y) -> X<Y |
| 5382 | | ; add_internal_error('Arguments not numbers: ',safe_less_than(X,Y))). |
| 5383 | | |
| 5384 | | :- assert_must_succeed(exhaustive_kernel_check(less_than_equal(int(33),int(33)))). |
| 5385 | | less_than_equal(int(X),int(Y)) :- |
| 5386 | | (number(X),number(Y) -> X =< Y |
| 5387 | | ; clpfd_leq(X,Y,Posted), |
| 5388 | | (Posted=true -> true ; safe_less_than_equal(less_than_equal,X,Y))). |
| 5389 | | less_than_equal_direct(X,Y) :- |
| 5390 | | (number(X),number(Y) -> X =< Y |
| 5391 | | ; clpfd_leq(X,Y,Posted), |
| 5392 | | (Posted=true -> true ; safe_less_than_equal(less_than_equal_direct,X,Y))). |
| 5393 | | |
| 5394 | | safe_less_than_equal(X,Y) :- |
| 5395 | | safe_less_than_equal(safe_less_than_equal,X,Y). |
| 5396 | | :- block safe_less_than_equal(?,-,?), safe_less_than_equal(?,?,-). |
| 5397 | | safe_less_than_equal(PP,X,Y) :- |
| 5398 | | (number(X),number(Y) -> X=<Y |
| 5399 | | ; add_internal_error('Arguments not numbers: ',safe_less_than_equal(PP,X,Y))). |
| 5400 | | |
| 5401 | | :- assert_must_succeed(exhaustive_kernel_check(greater_than(int(2),int(1)))). |
| 5402 | | :- assert_must_succeed(exhaustive_kernel_fail_check(greater_than(int(2),int(2)))). |
| 5403 | | greater_than(int(X),int(Y)) :- less_than_direct(Y,X). |
| 5404 | | :- assert_must_succeed(exhaustive_kernel_check(greater_than(int(2),int(1)))). |
| 5405 | | :- assert_must_succeed(exhaustive_kernel_check(greater_than_equal(int(2),int(2)))). |
| 5406 | | :- assert_must_succeed(exhaustive_kernel_fail_check(greater_than_equal(int(1),int(2)))). |
| 5407 | | greater_than_equal(int(X),int(Y)) :- less_than_equal_direct(Y,X). |
| 5408 | | |
| 5409 | | |
| 5410 | | |
| 5411 | | |
| 5412 | | |
| 5413 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],int_plus(int(2),int(3),int(5)))). |
| 5414 | | :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],int_plus(int(2),int(3),int(6)))). |
| 5415 | | |
| 5416 | | :- assert_must_succeed(int_plus(int(1),int(2),int(3))). |
| 5417 | | :- assert_must_succeed(( int_plus2(A,B,C),A=3,B=2,C==5 )). |
| 5418 | | :- assert_must_succeed(( int_plus2(A,B,C),A=3,C=5,B==2 )). |
| 5419 | | :- assert_must_succeed(( int_plus2(A,B,C),B=2,A=3,C==5 )). |
| 5420 | | :- assert_must_succeed(( int_plus2(A,B,C),B=2,C=5,A==3 )). |
| 5421 | | :- assert_must_succeed(( int_plus2(A,B,C),C=5,A=3,B==2 )). |
| 5422 | | :- assert_must_succeed(( int_plus2(A,B,C),C=5,B=2,A==3 )). |
| 5423 | | :- assert_must_succeed(( int_plus2(A,B,C),A=0,B==C )). |
| 5424 | | :- assert_must_succeed(( int_plus2(A,B,C),B=0,A==C )). |
| 5425 | | |
| 5426 | | int_plus(int(X),int(Y),int(Plus)) :- |
| 5427 | ? | (two_vars_or_more(X,Y,Plus) |
| 5428 | | -> clpfd_eq(Plus,X+Y) % can have performance problems |
| 5429 | | ; true % otherwise we can compute the value directly below; we could skip the block declaration |
| 5430 | | ), |
| 5431 | | int_plus2(X,Y,Plus). |
| 5432 | | two_vars_or_more(X,Y,Z) :- var(X),!, (var(Y) ; var(Z)). |
| 5433 | | two_vars_or_more(_X,Y,Z) :- var(Y) , var(Z). |
| 5434 | | |
| 5435 | | :- block int_plus2(-,-,-). |
| 5436 | | int_plus2(X,Y,Plus) :- |
| 5437 | | ( ground(X) -> int_plus3(X,Y,Plus) |
| 5438 | | ; ground(Y) -> int_plus3(Y,X,Plus) |
| 5439 | | ; int_minus3(Plus,X,Y)). |
| 5440 | | |
| 5441 | | % int_plus3/3: the first argument must be ground when called |
| 5442 | | int_plus3(0,Y,Plus) :- !, Y=Plus. % not inferred by CLP(FD): Z #= Y+X, X=0. does not infer Y==Z |
| 5443 | | int_plus3(X,Y,Plus) :- % integer_dif(Y,Plus), % this generates overflows for test 1353, 1014 |
| 5444 | | int_plus4(X,Y,Plus). |
| 5445 | | |
| 5446 | | % int_plus4/3: the first argument must be ground when called |
| 5447 | | :- block int_plus4(?,-,-). |
| 5448 | | int_plus4(X,Y,Plus) :- |
| 5449 | | ( var(Plus) -> Plus is X+Y |
| 5450 | | ; Y is Plus-X). |
| 5451 | | |
| 5452 | | :- assert_must_succeed(exhaustive_kernel_check(int_minus(int(2),int(3),int(-1)))). |
| 5453 | | :- assert_must_succeed(exhaustive_kernel_fail_check(int_minus(int(2),int(3),int(1)))). |
| 5454 | | :- assert_must_succeed(int_minus(int(3),int(1),int(2))). |
| 5455 | | :- assert_must_succeed(( int_minus2(A,B,C),A=3,B=2,C==1 )). |
| 5456 | | :- assert_must_succeed(( int_minus2(A,B,C),A=3,C=1,B==2 )). |
| 5457 | | :- assert_must_succeed(( int_minus2(A,B,C),B=2,A=3,C==1 )). |
| 5458 | | :- assert_must_succeed(( int_minus2(A,B,C),B=2,C=1,A==3 )). |
| 5459 | | :- assert_must_succeed(( int_minus2(A,B,C),C=1,A=3,B==2 )). |
| 5460 | | :- assert_must_succeed(( int_minus2(A,B,C),C=1,B=2,A==3 )). |
| 5461 | | :- assert_must_succeed(( int_minus2(A,B,C),B=0,A==C )). |
| 5462 | | :- assert_must_succeed(( int_minus2(A,B,C),B=0,C=5,A==5 )). |
| 5463 | | :- assert_must_succeed(( int_minus2(A,B,5),B=0,A==5 )). |
| 5464 | | |
| 5465 | | int_minus(int(X),int(Y),int(Minus)) :- |
| 5466 | | int_minus2(X,Y,Minus), |
| 5467 | ? | (two_vars_or_more(X,Y,Minus) -> clpfd_eq(Minus,X-Y) % can have performance problems. |
| 5468 | | % we could also set Minus to 0 if X==Y; this is done in CHR (chr_integer_inequality) |
| 5469 | | ; true). % we can compute the value directly anyway |
| 5470 | | :- block int_minus2(-,-,-). |
| 5471 | | int_minus2(X,Y,Minus) :- |
| 5472 | | ( ground(Y) -> |
| 5473 | | ( Y=0 -> X=Minus |
| 5474 | | ; Y2 is -Y, int_plus3(Y2,X,Minus)) |
| 5475 | | ; ground(X) -> |
| 5476 | | int_minus3(X,Y,Minus) |
| 5477 | | ; int_plus3(Minus,Y,X) % will infer that Y=X if Minus=0 |
| 5478 | | ). |
| 5479 | | |
| 5480 | | % int_minus3/3: the first argument must be ground when called |
| 5481 | | :- block int_minus3(?,-,-). |
| 5482 | | int_minus3(X,Y,Minus) :- |
| 5483 | | ( var(Minus) -> Minus is X-Y |
| 5484 | | ; Y is X-Minus). |
| 5485 | | |
| 5486 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(2),int(3),int(0),unknown,_WF))). |
| 5487 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(7),int(2),int(3),unknown,_WF))). |
| 5488 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(8),int(2),int(4),unknown,_WF))). |
| 5489 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(9),int(2),int(4),unknown,_WF))). |
| 5490 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(2),int(-1),int(-2),unknown,_WF))). |
| 5491 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(9),int(-2),int(-4),unknown,_WF))). |
| 5492 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(-9),int(-3),int(3),unknown,_WF))). |
| 5493 | | :- assert_must_succeed(exhaustive_kernel_check(division(int(-1),int(4),int(0),unknown,_WF))). |
| 5494 | | :- assert_must_succeed((platform_is_64_bit |
| 5495 | | -> exhaustive_kernel_check(division(int(4294967296),int(2),int(2147483648),unknown,_WF)) |
| 5496 | | ; exhaustive_kernel_check(division(int(134217728),int(2),int(67108864),unknown,_WF)))). |
| 5497 | | :- assert_must_succeed((platform_is_64_bit |
| 5498 | | -> exhaustive_kernel_check(division(int(4294967296),int(2147483648),int(2),unknown,_WF)) |
| 5499 | | ; exhaustive_kernel_check(division(int(134217728),int(67108864),int(2),unknown,_WF)))). |
| 5500 | | :- assert_must_succeed(exhaustive_kernel_fail_check(division(int(2),int(3),int(1),unknown,_WF))). |
| 5501 | | :- assert_must_succeed(( division3(A,B,C,unknown,_),A=15,B=4,C==3 )). |
| 5502 | | :- assert_must_succeed(( division3(A,B,C,unknown,_),B=4,A=15,C==3 )). |
| 5503 | | |
| 5504 | | division(int(X),int(Y),int(XDY),Span,WF) :- var(Y), (var(X) ; var(XDY)), |
| 5505 | | preferences:preference(use_clpfd_solver,true),!, |
| 5506 | | (preferences:preference(disprover_mode,true) |
| 5507 | | -> clpfd_eq_div(XDY,X,Y) /* we can assume well-definedness */ |
| 5508 | | ; clpfd_eq_guarded_div(XDY,X,Y), |
| 5509 | | % TO DO: we could set up a choice point just before enumeration of infinite types for Y=0 & Y/=0; |
| 5510 | | % same for modulo |
| 5511 | | check_nonzero(X,Y,XDY,Span,WF) |
| 5512 | | ). |
| 5513 | | division(int(X),int(Y),int(XDY),Span,WF) :- |
| 5514 | | %% clpfd_eq_expr(XDY,X/Y), % can have performance problems; could hide division by 0 ! |
| 5515 | | division3(X,Y,XDY,Span,WF). |
| 5516 | | |
| 5517 | | :- block check_nonzero(?,-,?,?,?). |
| 5518 | | check_nonzero(X,Y,XDY,Span,WF) :- |
| 5519 | | (Y=0 -> add_wd_error_set_result('division by zero','/'(X,Y),XDY,0,Span,WF) |
| 5520 | | ; true). |
| 5521 | | |
| 5522 | | :- block division3(?,-,?,?,?). |
| 5523 | | division3(X,Y,XDY,Span,WF) :- |
| 5524 | | ( Y==0 -> add_wd_error_set_result('division by zero','/'(X,Y),XDY,0,Span,WF) |
| 5525 | | ; nonvar(X) -> XDY is X // Y |
| 5526 | | ; Y == 1 -> X=XDY |
| 5527 | | ; Y == -1,nonvar(XDY) -> X is -XDY |
| 5528 | | ; clpfd_eq_div(XDY,X,Y)). % we could setup constraint before Y is known; could hide division by 0 ? |
| 5529 | | |
| 5530 | | |
| 5531 | | |
| 5532 | | :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(2),int(3),int(0),unknown,_WF))). |
| 5533 | | :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(7),int(2),int(3),unknown,_WF))). |
| 5534 | | :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(-1),int(4),int(-1),unknown,_WF))). |
| 5535 | | :- assert_must_succeed(exhaustive_kernel_check(floored_division(int(-9),int(-3),int(3),unknown,_WF))). |
| 5536 | | floored_division(int(X),int(Y),int(XDY),Span,WF) :- var(Y), (var(X) ; var(XDY)), |
| 5537 | | preferences:preference(use_clpfd_solver,true),!, |
| 5538 | | (preferences:preference(disprover_mode,true) |
| 5539 | | -> clpfd_eq_fdiv(XDY,X,Y) /* we can assume well-definedness */ |
| 5540 | | ; clpfd_eq_guarded_fdiv(XDY,X,Y), |
| 5541 | | check_nonzero(X,Y,XDY,Span,WF) |
| 5542 | | ). |
| 5543 | | floored_division(int(X),int(Y),int(XDY),Span,WF) :- |
| 5544 | | %% clpfd_eq_expr(XDY,X/Y), % can have performance problems; could hide division by 0 ! |
| 5545 | | floored_division3(X,Y,XDY,Span,WF). |
| 5546 | | :- block floored_division3(?,-,?,?,?). |
| 5547 | | floored_division3(X,Y,XDY,Span,WF) :- |
| 5548 | | ( Y==0 -> add_wd_error_set_result('division by zero','/'(X,Y),XDY,0,Span,WF) |
| 5549 | | ; nonvar(X) -> XDY is X div Y |
| 5550 | | ; Y == 1 -> X=XDY |
| 5551 | | ; (Y == -1,nonvar(XDY)) -> X is -XDY |
| 5552 | | ; clpfd_eq_guarded_fdiv(XDY,X,Y)). % we could setup constraint before Y is known; could hide division by 0 ? |
| 5553 | | |
| 5554 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(2),int(3),int(2),unknown,WF),WF)). |
| 5555 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(7),int(2),int(1),unknown,WF),WF)). |
| 5556 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(8),int(2),int(0),unknown,WF),WF)). |
| 5557 | | :- assert_must_succeed(exhaustive_kernel_check_wfdet(modulo(int(9),int(2),int(1),unknown,WF),WF)). |
| 5558 | | :- assert_must_succeed((platform_is_64_bit |
| 5559 | | -> exhaustive_kernel_check_wfdet(modulo(int(4294967296),int(2147483648),int(0),unknown,WF),WF) |
| 5560 | | ; exhaustive_kernel_check_wfdet(modulo(int(134217728),int(67108864),int(0),unknown,WF),WF))). |
| 5561 | | :- assert_must_succeed((platform_is_64_bit |
| 5562 | | -> exhaustive_kernel_check_wfdet(modulo(int(4294967299),int(2147483648),int(3),unknown,WF),WF) |
| 5563 | | ; exhaustive_kernel_check_wfdet(modulo(int(134217731),int(67108864),int(3),unknown,WF),WF))). |
| 5564 | | :- assert_must_succeed(( modulo2(A,B,C,unknown,_),A=7,B=5,C==2 )). |
| 5565 | | :- assert_must_fail(( modulo2(A,B,C,unknown,_),A=7,B=5,C==3 )). |
| 5566 | | |
| 5567 | | modulo(int(X),int(Y),int(Modulo),Span,WF) :- |
| 5568 | | %% clpfd_eq(Modulo,X mod Y), % can have performance problems; could hide division by 0 ! |
| 5569 | | modulo2(X,Y,Modulo,Span,WF), |
| 5570 | | % assert that Modulo<Y, Modulo>=0 |
| 5571 | | (nonvar(X),nonvar(Y) -> true % we already have computed Modulo using modulo2 |
| 5572 | | ; nonvar(Modulo), Modulo < 0 -> true % we will generate well-definedness error; see comment next line |
| 5573 | | ; 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 !! |
| 5574 | | ; clpfd_modulo_prop(X,Y,Modulo,WF) |
| 5575 | | ). |
| 5576 | | :- use_module(specfile,[z_or_tla_minor_mode/0]). |
| 5577 | | :- block modulo2(-,?,?,?,?), modulo2(?,-,?,?,?). |
| 5578 | | modulo2(X,Y,Modulo,Span,WF) :- |
| 5579 | | ( Y>0 -> (X<0 -> (z_or_tla_minor_mode -> Modulo is X mod Y |
| 5580 | | ; add_wd_error_set_result('mod not defined for negative numbers in B:',mod(X,Y),Modulo,0,Span,WF)) |
| 5581 | | ; Modulo is X mod Y) |
| 5582 | | ; Y==0 -> add_wd_error_set_result('mod by zero:',mod(X,Y),Modulo,0,Span,WF) |
| 5583 | | ; 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 ? |
| 5584 | | |
| 5585 | | % propagate information about Modulo result if part of the information known |
| 5586 | | clpfd_modulo_prop(X,Y,Modulo,WF) :- %preferences:preference(use_clpfd_solver,true),!, |
| 5587 | | % in CLP(FD) this is sufficient; for non-CLPFD mode it is better to call in_nat_range to restrict enumeration |
| 5588 | | less_than_direct(Modulo,Y), |
| 5589 | | less_than_equal_direct(0,Modulo), % 0 <= Modulo < Y -> by transitivity this forces Y>0 and we no longer detect wd-errors |
| 5590 | | %less_than_equal_direct(Modulo,X). % by transitivity this imposes X >= 0 and we will never find WD problems with negative X |
| 5591 | | (preference(use_clpfd_solver,true) |
| 5592 | | -> get_wait_flag0(WF,WF0), |
| 5593 | | % avoid propagating complex too early, e.g., for x>2 & x:3..10 & x mod 3 = 1 & x mod 3 = 2 in test 2126 |
| 5594 | | % also see test 1959 which was initially failing due to adding WF0 delay |
| 5595 | | clpfd_modulo_prop2(X,Y,Modulo,WF0) |
| 5596 | | ; true). |
| 5597 | | |
| 5598 | | :- block clpfd_modulo_prop2(?,?,?,-). |
| 5599 | | clpfd_modulo_prop2(X,Y,Modulo,_WF0) :- |
| 5600 | | number(Modulo), % this test is required for test 1009, 417 : TO DO : investigate cause |
| 5601 | | var(X), % or should this be var(X) ; var(Y) ?? |
| 5602 | | fd_min(Y,MinY), number(MinY), MinY>0, |
| 5603 | | fd_min(X,MinX), number(MinX), MinX>=0, % modulo is well-defined |
| 5604 | | !, |
| 5605 | | clpfd_interface:clpfd_leq_expr(Modulo,X), |
| 5606 | | clpfd_interface:try_post_constraint(Modulo #= X mod Y). |
| 5607 | | %clpfd_modulo_prop2(X,Y,Modulo,_WF0) :- number(Y),!, |
| 5608 | | % % also makes tests 1009, 417 fail, but would enable solving x mod 256 = 0 & x>0 |
| 5609 | | % clpfd_interface:try_post_constraint(X#>=0 #=> Modulo #= X mod Y). % will also assert X#>Modulo |
| 5610 | | clpfd_modulo_prop2(X,_Y,_Modulo,_WF0) :- X==0,!. % no need to propagate, we already assert 0 <= Modulo above |
| 5611 | | clpfd_modulo_prop2(X,_Y,Modulo,_WF0) :- |
| 5612 | | 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). |
| 5613 | | % we could reify: Y>0 => Modulo <Y ? Is it worth it ? |
| 5614 | | % we could also use the CLP(FD) modulo operator X in 3..100, 1 #= X mod 20 infers X in 21..81 |
| 5615 | | % try_post_constraint((X#>=0 #/\ Y#>0) #=> Modulo #= X mod Y) |
| 5616 | | % 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.) |
| 5617 | | /* clpfd_modulo_prop(X,Y,Modulo,WF) :- clpfd_modulo_noclp(X,Y,Modulo,WF). |
| 5618 | | :- block clpfd_modulo_noclp(-,-,-,?). |
| 5619 | | clpfd_modulo_noclp(X,Y,Modulo,WF) :- print(mod(X,Y,Modulo,WF)),nl, |
| 5620 | | var(X),var(Modulo),number(Y),!, |
| 5621 | | Y1 is Y-1, |
| 5622 | | in_nat_range_wf(int(Modulo),int(0),int(Y1),WF). % problem: could enumerate lambda return variables !! |
| 5623 | | clpfd_modulo_noclp(_X,_Y,_Modulo,_WF). |
| 5624 | | */ |
| 5625 | | |
| 5626 | | |
| 5627 | | :- assert_must_succeed(exhaustive_kernel_check(unary_minus_wf(int(2),int(-2),_WF))). |
| 5628 | | :- assert_must_succeed(exhaustive_kernel_fail_check(unary_minus_wf(int(2),int(2),_WF))). |
| 5629 | | :- assert_must_succeed(( unary_minus2(A,B),A=7,B== -7 )). |
| 5630 | | :- assert_must_succeed(( unary_minus2(A,B),A= -7,B==7 )). |
| 5631 | | :- assert_must_succeed(( unary_minus2(B,A),A=7,B== -7 )). |
| 5632 | | :- assert_must_succeed(( unary_minus2(B,A),A= -7,B==7 )). |
| 5633 | | :- assert_must_fail(( unary_minus2(B,A),A= -7,B=6 )). |
| 5634 | | :- assert_must_fail(( unary_minus2(A,B),A= -7,B=6 )). |
| 5635 | | |
| 5636 | | unary_minus_wf(int(X),int(MX),_WF) :- |
| 5637 | | unary_minus2(X,MX), |
| 5638 | | (var(X),var(MX) -> clpfd_eq(MX,0 - X) % can have performance problems |
| 5639 | | ; true % we can compute the value without CLPFD |
| 5640 | | ). |
| 5641 | | :- block unary_minus2(-,-). |
| 5642 | | unary_minus2(X,MX) :- |
| 5643 | | ( ground(X) -> MX is -X |
| 5644 | | ; X is -MX). |
| 5645 | | |
| 5646 | | :- assert_must_succeed(first_of_pair((int(1),int(2)),int(1))). |
| 5647 | | :- assert_must_succeed(second_of_pair((int(1),int(2)),int(2))). |
| 5648 | | |
| 5649 | | first_of_pair((A,_B),R) :- equal_object(R,A,first_of_pair). |
| 5650 | | second_of_pair((_A,B),R) :- equal_object(R,B,second_of_pair). |
| 5651 | | |
| 5652 | | |
| 5653 | | :- assert_must_succeed(exhaustive_kernel_check(cartesian_product([int(2),int(4)],[int(3),int(1)], |
| 5654 | | [(int(2),int(1)),(int(2),int(3)),(int(4),int(3)),(int(4),int(1))]))). |
| 5655 | | :- assert_must_succeed(exhaustive_kernel_check(cartesian_product([],[int(3),int(1)],[]))). |
| 5656 | | :- assert_must_succeed(exhaustive_kernel_check(cartesian_product([int(3)],[],[]))). |
| 5657 | | :- assert_must_succeed(exhaustive_kernel_fail_check(cartesian_product([int(3)],[int(2)],[]))). |
| 5658 | | :- assert_must_succeed((cartesian_product(global_set('NAT'),[int(2)],_Res))). |
| 5659 | | :- assert_must_succeed((cartesian_product([int(1)],[int(2)],Res), |
| 5660 | | equal_object(Res,[(int(1),int(2))]))). |
| 5661 | | :- assert_must_succeed((cartesian_product([int(1)],[int(2)],[(int(1),int(2))]))). |
| 5662 | | :- assert_must_succeed((cartesian_product([],[int(1),int(2)],Res), |
| 5663 | | equal_object(Res,[]))). |
| 5664 | | :- assert_must_succeed((cartesian_product([int(1),int(2)],[],Res), |
| 5665 | | equal_object(Res,[]))). |
| 5666 | | :- assert_must_succeed((cartesian_product([int(1),int(2)],[int(2),int(3)],Res), |
| 5667 | | equal_object(Res,[(int(1),int(2)),(int(1),int(3)),(int(2),int(2)),(int(2),int(3))]))). |
| 5668 | | :- assert_must_succeed((cartesian_product([int(1)|T],[int(2)|T2],Res), |
| 5669 | | T = [int(2)], T2 = [int(3)], |
| 5670 | | equal_object(Res,[(int(1),int(2)),(int(1),int(3)),(int(2),int(2)),(int(2),int(3))]))). |
| 5671 | | :- assert_must_fail((cartesian_product([int(1)],[int(2),int(3)],Res),(Res=[_]; |
| 5672 | | equal_object(Res,[_,_,_|_])))). |
| 5673 | | |
| 5674 | | |
| 5675 | | cartesian_product(Set1,Set2,Res) :- cartesian_product_wf(Set1,Set2,Res,no_wf_available). |
| 5676 | | |
| 5677 | | :- block cartesian_product_wf(-,?,?,?), cartesian_product_wf(?,-,?,?). |
| 5678 | | cartesian_product_wf(Set1,Set2,Res,WF) :- |
| 5679 | | expand_custom_set_to_list_wf(Set1,ESet1,_,cartesian_product1,WF), |
| 5680 | | (ESet1==[] -> empty_set_wf(Res,WF) |
| 5681 | | ; expand_custom_set_to_list_wf(Set2,ESet2,_,cartesian_product2,WF), |
| 5682 | | (var(Res) |
| 5683 | | -> cartesian_product2(ESet1,ESet2,CRes,WF), |
| 5684 | | equal_object_optimized_wf(CRes,Res,cart_product,WF) |
| 5685 | | ; cartesian_product2(ESet1,ESet2,Res,WF)) |
| 5686 | | ). |
| 5687 | | |
| 5688 | | :- block cartesian_product2(-,?,?,?). |
| 5689 | | cartesian_product2([],_,Res,WF) :- empty_set_wf(Res,WF). |
| 5690 | | cartesian_product2([H|T],Set2,Res,WF) :- |
| 5691 | | cartesian_el_product(Set2,H,Res,InnerRes,WF), |
| 5692 | | cartesian_product2(T,Set2,InnerRes,WF). |
| 5693 | | |
| 5694 | | :- block cartesian_el_product(-,?,?,?,?). |
| 5695 | | cartesian_el_product([],_El,Res,InnerRes,WF) :- equal_object_optimized_wf(Res,InnerRes,cartesian_el_product_1,WF). |
| 5696 | | cartesian_el_product([H|T],El,ResSoFar,InnerRes,WF) :- |
| 5697 | | equal_object_wf(ResSoFar,[(El,H)|NewResSoFar],cartesian_el_product_2,WF), |
| 5698 | | cartesian_el_product(T,El,NewResSoFar,InnerRes,WF). |
| 5699 | | |
| 5700 | | |
| 5701 | | |
| 5702 | | :- assert_must_succeed(exhaustive_kernel_check(in_nat_range(int(2),int(2),int(3)))). |
| 5703 | | :- assert_must_succeed(exhaustive_kernel_check(in_nat_range_wf(int(2),int(2),int(3),_WF))). |
| 5704 | | :- assert_must_succeed(exhaustive_kernel_fail_check(in_nat_range_wf(int(2),int(3),int(2),_WF))). |
| 5705 | | :- assert_must_succeed((in_nat_range_wf(X,int(11),int(12),WF), |
| 5706 | | kernel_waitflags:ground_wait_flags(WF), X==int(12) )). |
| 5707 | | :- assert_must_fail((in_nat_range_wf(X,int(11),int(12),_WF), X=int(10) )). |
| 5708 | | :- assert_must_fail((in_nat_range_wf(X,int(11),int(12),_WF), X=int(13) )). |
| 5709 | | :- assert_must_succeed((in_nat_range_wf(X,int(11),int(12),_WF), X=int(11) )). |
| 5710 | | :- assert_must_fail((in_nat_range_wf(X,int(11),int(10),_WF), X=int(11) )). |
| 5711 | | :- assert_must_fail((in_nat_range_wf(X,int(11),int(10),_WF), X=int(10) )). |
| 5712 | | :- assert_must_fail((in_nat_range_wf(X,int(11),int(10),_WF), X=int(12) )). |
| 5713 | | |
| 5714 | | in_nat_range(int(X),int(Y),int(Z)) :- % does not enumerate, in contrast to in_nat_range_wf |
| 5715 | | clpfd_inrange(X,Y,Z,Posted), % better to call inrange rather than leq twice, avoids unecessary propagation |
| 5716 | | (Posted==true -> true |
| 5717 | | ; safe_less_than_equal(in_nat_range,Y,X), |
| 5718 | | safe_less_than_equal(in_nat_range,X,Z) |
| 5719 | | ). |
| 5720 | | in_nat_range_wf(int(X),int(Y),int(Z),WF) :- |
| 5721 | ? | clpfd_inrange(X,Y,Z,Posted), % better to call inrange rather than leq twice, avoids unecessary propagation |
| 5722 | | (Posted==true -> |
| 5723 | | /* if the constraint was posted: we do not need to add safe_less_than_equal,...: if overflow happes whole computation will fail anyway */ |
| 5724 | | add_nat_range_fd_variable_for_labeling(X,Y,Z,WF) % do we really need to do this ? maybe add just before enumeration finished ? |
| 5725 | | ; safe_less_than_equal(in_nat_range_wf,Y,X), |
| 5726 | | safe_less_than_equal(in_nat_range_wf,X,Z), |
| 5727 | | (ground(X) -> true |
| 5728 | | ; get_int_domain(X,Y,Z,RL,RU),get_nat_range_prio(X,RL,RU,WF,LWF), |
| 5729 | | call_enumerate_int(X,RL,RU,LWF)) |
| 5730 | | ). |
| 5731 | | % when((ground(X);nonvar(LWF)),(ground(X) -> true ; enumerate_int(X,RL,RU))). |
| 5732 | | |
| 5733 | | add_nat_range_fd_variable_for_labeling(X,_Low,_Up,_WF) :- nonvar(X),!. |
| 5734 | | % TO DO: avoid adding useless choice points; not adding makes test 328 fail |
| 5735 | | %add_nat_range_fd_variable_for_labeling(X,Low,Up,WF) :- !,Size is 100*(Up+1-Low), |
| 5736 | | % get_wait_flag(Size,add_nat_range_fd(X,Low,Up),WF,LWF), when(nonvar(LWF),add_fd_variable_for_labeling(X,WF)). |
| 5737 | | add_nat_range_fd_variable_for_labeling(_X,Low,Up,_WF) :- |
| 5738 | | (var(Low) ; var(Up)),!. % domain is not yet bounded; should we delay/block until Low and Up are known? |
| 5739 | | add_nat_range_fd_variable_for_labeling(X,_Low,_Up,WF) :- !,add_fd_variable_for_labeling(X,WF). |
| 5740 | | |
| 5741 | | |
| 5742 | | :- block get_nat_range_prio(?,-,?,?,?), get_nat_range_prio(?,?,-,?,?). |
| 5743 | | get_nat_range_prio(_Variable,Y,Z,WF,LWF) :- Size is Z+1-Y, |
| 5744 | | (Size>1 -> |
| 5745 | | % we do not use add_fd_variable_for_labeling(Variable,Size,WF,LWF) % will use CLP(FD) labeling |
| 5746 | | % either clpfd is off or we had a time-out or overflow; so labeling may generate instantiation error |
| 5747 | | get_wait_flag(Size,get_nat_range_prio(Y,Z),WF,LWF) |
| 5748 | | ; LWF=Size /* Size=0 or 1 -> we can either fail or determine variable */). |
| 5749 | | |
| 5750 | | :- assert_must_succeed((kernel_objects:call_enumerate_int(X,1,2,g), X==2)). |
| 5751 | | :- block call_enumerate_int(-,?,?,-). |
| 5752 | | call_enumerate_int(X,RL,RU,_LWF) :- |
| 5753 | | (ground(X) -> true |
| 5754 | | ; % get_int_domain(X,RL,RU,RLL,RUU) : if clp(fd) active then CLP(FD) labeling is used anyway |
| 5755 | ? | enumerate_int(X,RL,RU)). |
| 5756 | | |
| 5757 | | |
| 5758 | | |
| 5759 | | |
| 5760 | | :- assert_must_succeed(exhaustive_kernel_check(not_in_nat_range(int(2),int(3),int(2)))). |
| 5761 | | :- assert_must_succeed(exhaustive_kernel_fail_check(not_in_nat_range(int(2),int(2),int(3)))). |
| 5762 | | :- assert_must_succeed((not_in_nat_range(X,int(11),int(12)), X=int(10) )). |
| 5763 | | :- assert_must_succeed((not_in_nat_range(X,int(11),int(12)), X=int(13) )). |
| 5764 | | :- assert_must_fail((not_in_nat_range(X,int(11),int(12)), X=int(11) )). |
| 5765 | | :- assert_must_succeed((not_in_nat_range(X,int(11),int(10)), X=int(11) )). |
| 5766 | | :- assert_must_succeed((not_in_nat_range(X,int(11),int(10)), X=int(10) )). |
| 5767 | | :- assert_must_succeed((not_in_nat_range(X,int(11),int(10)), X=int(12) )). |
| 5768 | | |
| 5769 | ? | not_in_nat_range_wf(X,Y,Z,_WF) :- not_in_nat_range(X,Y,Z). |
| 5770 | | not_in_nat_range(int(X),int(Y),int(Z)) :- |
| 5771 | | (number(Y),number(Z) |
| 5772 | ? | -> (Z>=Y -> clpfd_not_in_non_empty_range(X,Y,Z) ; true /* interval empty */) |
| 5773 | | ; clpfd_not_inrange(X,Y,Z) |
| 5774 | | ). |
| 5775 | | |
| 5776 | | |
| 5777 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(1),int(0),int(10),pred_true,WF),WF)). |
| 5778 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(10),int(10),int(10),pred_true,WF),WF)). |
| 5779 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(1),int(1),int(10),pred_true,WF),WF)). |
| 5780 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(10),int(0),int(10),pred_true,WF),WF)). |
| 5781 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(11),int(10),int(9),pred_false,WF),WF)). |
| 5782 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(11),int(13),int(12),pred_false,WF),WF)). |
| 5783 | | :- assert_must_succeed(exhaustive_kernel_check_wf(test_in_nat_range_wf(int(11),int(13),int(15),pred_false,WF),WF)). |
| 5784 | | |
| 5785 | | % reified version |
| 5786 | | :- block test_in_nat_range_wf(-,-,?,-,?), test_in_nat_range_wf(-,?,-,-,?), test_in_nat_range_wf(?,-,-,-,?). |
| 5787 | | test_in_nat_range_wf(X,Y,Z,PredRes,WF) :- PredRes==pred_true,!, |
| 5788 | | in_nat_range_wf(X,Y,Z,WF). |
| 5789 | | test_in_nat_range_wf(X,Y,Z,PredRes,WF) :- PredRes==pred_false,!, |
| 5790 | | not_in_nat_range_wf(X,Y,Z,WF). |
| 5791 | | test_in_nat_range_wf(int(X),int(Low),int(Up),PredRes,WF) :- |
| 5792 | | clpfd_interface:post_constraint2(C1 #<=> (X #>= Low #/\ X #=< Up #/\ Low #=< Up),Posted1), |
| 5793 | | (Posted1 == true -> prop_01(C1,PredRes) ; test_in_nat_range_no_clpfd(X,Low,Up,PredRes,WF)). |
| 5794 | | |
| 5795 | | % Note: A #<=> (X #>= Low #/\ X#=< Up #/\ Low #=< Up), Low in 11..15, Up in 7..8. -> CLPFD infers A=0 |
| 5796 | | % without the redundant Low #=< Up it does not infer it ! |
| 5797 | | :- block prop_01(-,-). |
| 5798 | | prop_01(0,pred_false). |
| 5799 | | prop_01(1,pred_true). |
| 5800 | | |
| 5801 | | :- block test_in_nat_range_no_clpfd(-,?,?,-,?), test_in_nat_range_no_clpfd(?,-,?,-,?), |
| 5802 | | test_in_nat_range_no_clpfd(?,?,-,-,?). |
| 5803 | | test_in_nat_range_no_clpfd(X,Y,Z,PredRes,WF) :- PredRes==pred_true,!, |
| 5804 | | in_nat_range_wf(int(X),int(Y),int(Z),WF). |
| 5805 | | test_in_nat_range_no_clpfd(X,Y,Z,PredRes,WF) :- PredRes==pred_false,!, |
| 5806 | | not_in_nat_range_wf(int(X),int(Y),int(Z),WF). |
| 5807 | | test_in_nat_range_no_clpfd(X,Y,Z,PredRes,_WF) :- % X,Y,Z must be ground integers |
| 5808 | | (X >= Y, X =< Z, Y =< Z -> PredRes=pred_true ; PredRes=pred_false). |
| 5809 | | |
| 5810 | | :- assert_must_succeed(exhaustive_kernel_check_wf(square(int(3),int(9),WF),WF)). |
| 5811 | | % is now only called when CLPFD is FALSE |
| 5812 | | square(int(X),int(Sqr),WF) :- |
| 5813 | | int_square(X,Sqr,WF), |
| 5814 | | (var(X) -> clpfd_eq(Sqr,X * X) |
| 5815 | | ; true). % we can compute the value directly |
| 5816 | | |
| 5817 | | :- block int_square(-,-,?). |
| 5818 | | int_square(X,Sqr,_) :- ground(X),!, Sqr is X*X. |
| 5819 | | int_square(X,Sqr,WF) :- get_binary_choice_wait_flag(int_square,WF,WF2), int_square2(X,Sqr,WF2). |
| 5820 | | :- block int_square2(-,?,-). |
| 5821 | | int_square2(X,Sqr,_) :- ground(X),!, Sqr is X*X. |
| 5822 | | int_square2(X,Sqr,_WF2) :- |
| 5823 | | integer_square_root(Sqr,X). |
| 5824 | | |
| 5825 | | :- assert_must_succeed(( kernel_objects:integer_square_root(0,X),X==0 )). |
| 5826 | | :- assert_must_succeed(( kernel_objects:integer_square_root(1,X),X==1 )). |
| 5827 | | :- assert_must_succeed(( kernel_objects:integer_square_root(4,X),X==2 )). |
| 5828 | | :- assert_must_succeed(( kernel_objects:integer_square_root(49,X),X==7 )). |
| 5829 | | :- assert_must_succeed(( kernel_objects:integer_square_root(49,X),X==(-7) )). |
| 5830 | | :- assert_must_fail(( kernel_objects:integer_square_root(5,_) )). |
| 5831 | | :- assert_must_succeed(( X= 123456789, Y is X*X, kernel_objects:integer_square_root(Y,Z),Z==X)). |
| 5832 | | :- assert_must_fail(( X= 123456789, Y is 1+X*X, kernel_objects:integer_square_root(Y,_Z))). |
| 5833 | | :- assert_must_succeed(( X= 12345678900, Y is X*X, kernel_objects:integer_square_root(Y,Z),Z==X)). |
| 5834 | | |
| 5835 | | integer_square_root(0,Root) :- !, Root = 0. |
| 5836 | | :- if(current_prolog_flag(dialect, swi)). |
| 5837 | | % SWI's behavior when converting bigint to float is suboptimal - |
| 5838 | | % the value is always truncated toward zero instead of rounded to the nearest value, |
| 5839 | | % which introduces slight inaccuracies that don't happen on SICStus. |
| 5840 | | % See: https://github.com/SWI-Prolog/swipl-devel/issues/545 |
| 5841 | | % As a workaround, use CLP(FD) to calculate integer square roots. |
| 5842 | | % On SWI, CLP(FD) works with unlimited size integers and can calculate exact integer n-th roots. |
| 5843 | | :- use_module(library(clpfd), [(#=)/2, (#>)/2, (#=<)/2]). |
| 5844 | | integer_square_root(Sqr,Root) :- |
| 5845 | | Root*Root #= Sqr, |
| 5846 | | (Root #> 0 ; Root #=< 0). |
| 5847 | | :- else. |
| 5848 | | integer_square_root(Sqr,PMRoot) :- |
| 5849 | | Sqr>0, Root is truncate(sqrt(Sqr)), Sqr is Root*Root, |
| 5850 | | (PMRoot = Root ; PMRoot is -(Root)). |
| 5851 | | :- endif. |
| 5852 | | |
| 5853 | | % integer multiplication |
| 5854 | | times(int(X),int(Y),int(Times)) :- |
| 5855 | | int_times2(X,Y,Times), |
| 5856 | ? | (two_vars_or_more(X,Y,Times) -> clpfd_eq(Times,X * Y) % can have performance problems. |
| 5857 | | ; true). % we can compute the value directly |
| 5858 | | |
| 5859 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],times(int(2),int(3),int(6)))). |
| 5860 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],times(int(2),int(1),int(2)))). |
| 5861 | | :- assert_must_succeed(exhaustive_kernel_check([commutative],times(int(2),int(0),int(0)))). |
| 5862 | | :- assert_must_succeed(exhaustive_kernel_check(times(int(0),int(1),int(0)))). |
| 5863 | | :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],times(int(2),int(3),int(5)))). |
| 5864 | | :- assert_must_succeed(exhaustive_kernel_fail_check([commutative],times(int(1),int(3),int(2)))). |
| 5865 | | :- assert_must_succeed(( int_times2(A,B,C),A=3,B=2,C==6 )). |
| 5866 | | :- assert_must_succeed(( int_times2(A,B,C),A=3,C=6,B==2 )). |
| 5867 | | :- assert_must_succeed(( int_times2(A,B,C),B=2,A=3,C==6 )). |
| 5868 | | :- assert_must_succeed(( int_times2(A,B,C),B=2,C=6,A==3 )). |
| 5869 | | :- assert_must_succeed(( int_times2(A,B,C),C=6,A=3,B==2 )). |
| 5870 | | :- assert_must_succeed(( int_times2(A,B,C),C=6,B=2,A==3 )). |
| 5871 | | :- assert_must_succeed(( int_times2(A,_,C),A=0,C==0 )). |
| 5872 | | :- assert_must_succeed(( int_times2(_,B,C),B=0,C==0 )). |
| 5873 | | :- assert_must_succeed(( int_times2(A,B,C),A=1,B==C )). |
| 5874 | | :- assert_must_succeed(( int_times2(A,B,C),B=1,A==C )). |
| 5875 | | :- assert_must_succeed(( int_times2(A,1,C),A=2,C==2 )). |
| 5876 | | :- assert_must_succeed(( int_times2(_A,0,C),C==0 )). |
| 5877 | | :- assert_must_succeed(( int_times2(A,_,C),C=0,A=0 )). |
| 5878 | | :- assert_must_succeed(( int_times2(_,B,C),C=0,B=0 )). |
| 5879 | | :- assert_must_succeed(( int_times2(A,B,0),A=0,B=2 )). |
| 5880 | | :- assert_must_succeed(( int_times2(A,B,0),B=2,A=0 )). |
| 5881 | | :- assert_must_succeed(( int_times2(B,A,0),A=0,B=2 )). |
| 5882 | | :- assert_must_succeed(( int_times2(B,A,0),B=2,A=0 )). |
| 5883 | | :- assert_must_fail(( int_times2(A,_,C),A=3,C=7 )). |
| 5884 | | :- assert_must_fail(( int_times2(A,_,C),C=7,A=3 )). |
| 5885 | | :- assert_must_fail(( int_times2(_,B,C),B=2,C=7 )). |
| 5886 | | :- assert_must_fail(( int_times2(_,B,C),C=7,B=2 )). |
| 5887 | | :- assert_must_fail(( int_times2(A,_,C),C=7,A=0 )). |
| 5888 | | :- assert_must_fail(( int_times2(_,B,C),C=7,B=0 )). |
| 5889 | | :- assert_must_fail(( int_times2(B,A,0),B=2,A=1 )). |
| 5890 | | |
| 5891 | | :- block int_times2(-,-,-). |
| 5892 | | int_times2(X,Y,Times) :- |
| 5893 | | ( ground(X) -> |
| 5894 | | ( X==1 -> Y=Times |
| 5895 | | ; X==0 -> Times=0 |
| 5896 | | ; int_times3(X,Y,Times)) |
| 5897 | | ; ground(Y) -> |
| 5898 | | ( Y==1 -> X=Times |
| 5899 | | ; Y==0 -> Times=0 |
| 5900 | | ; int_times3(Y,X,Times)) |
| 5901 | | ; int_times4(X,Y,Times)). |
| 5902 | | % int_times3/3: First argument must be ground when called and non-zero |
| 5903 | | :- block int_times3(?,-,-). |
| 5904 | | int_times3(X,Y,Times) :- |
| 5905 | | ( ground(Y) -> Times is X*Y |
| 5906 | | ; Y is Times // X, Times is X*Y). |
| 5907 | | % int_times4/3: Third argument must be ground when called |
| 5908 | | :- block int_times4(-,-,?). |
| 5909 | | int_times4(X,Y,Times) :- |
| 5910 | | ( Times==0 -> |
| 5911 | | ( ground(X) -> (X==0 -> true; Y=0 ) |
| 5912 | | ; /* ground(Y) -> */ (Y==0 -> true; X=0 )) |
| 5913 | | ; /* Times /== 0 */ |
| 5914 | | ( ground(X) -> X\==0, Y is Times // X, Times is X*Y |
| 5915 | | ; /* ground(Y) -> */ Y\==0, X is Times // Y, Times is X*Y)). |
| 5916 | | |
| 5917 | | |
| 5918 | | :- assert_must_succeed(exhaustive_kernel_check(int_power(int(2),int(3),int(8),unknown,_))). |
| 5919 | | :- assert_must_succeed(exhaustive_kernel_check(int_power(int(2),int(1),int(2),unknown,_))). |
| 5920 | | :- assert_must_succeed(exhaustive_kernel_check(int_power(int(3),int(0),int(1),unknown,_))). |
| 5921 | | :- assert_must_succeed(exhaustive_kernel_check(int_power(int(1),int(3),int(1),unknown,_))). |
| 5922 | | :- assert_must_succeed(exhaustive_kernel_check(int_power(int(0),int(3),int(0),unknown,_))). |
| 5923 | | :- assert_must_succeed(exhaustive_kernel_fail_check(int_power(int(2),int(3),int(6),unknown,_))). |
| 5924 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=2,B=5,C==32 )). |
| 5925 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A= -2,B=5,C== -32 )). |
| 5926 | | %:- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=1,B= -5,C==1 )). % now aborts ! |
| 5927 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=1,C=1, B= -5 )). |
| 5928 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=1,C= 1,B = -5 )). |
| 5929 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=2,C=32,B==5 )). |
| 5930 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=10,C=1000,B==3 )). |
| 5931 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A= -2,C= -32,B==5 )). |
| 5932 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A= -2,C= 16,B==4 )). |
| 5933 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=2,C=1,B==0 )). |
| 5934 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,B=2,C==0 )). |
| 5935 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,C=0,B=2 )). |
| 5936 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,B=0,C==1 )). |
| 5937 | | :- assert_must_succeed(( int_power2(A,B,C,unknown,_),A=0,C=1,B==0 )). |
| 5938 | | :- assert_must_succeed(( int_power2(17,13,C,unknown,_),C==9904578032905937 )). |
| 5939 | | :- assert_must_succeed((platform_is_64_bit |
| 5940 | | -> int_power2(A,13,C,unknown,_),C=9904578032905937,A=17 |
| 5941 | | ; int_power2(A,9,C,unknown,_),C=134217728,A=8 )). |
| 5942 | | :- assert_must_fail((platform_is_64_bit |
| 5943 | | -> int_power2(A,13,C,unknown,_),C=9904578032905936,A=17 |
| 5944 | | ; int_power2(A,9,C,unknown,_),C=134217727,A=8 )). |
| 5945 | | :- assert_must_succeed((platform_is_64_bit |
| 5946 | | -> int_power2(A,10,C,unknown,_),C=576650390625,A=15 |
| 5947 | | ; true)). |
| 5948 | | :- assert_must_fail((platform_is_64_bit |
| 5949 | | -> int_power2(A,10,C,unknown,_),C=576650390626,A=15 |
| 5950 | | ; false)). |
| 5951 | | :- assert_must_succeed(( int_power2(A,100,C,unknown,_),A=2,C==1267650600228229401496703205376 )). |
| 5952 | | :- assert_must_fail(( int_power2(A,100,C,unknown,_),C=1267650600228229401496703205375,A=2 )). |
| 5953 | | :- assert_must_fail(( int_power2(A,100,C,unknown,_),C=1267650600228229401496703205377,A=2 )). |
| 5954 | | |
| 5955 | | :- assert_must_fail(( int_power2(A,B,C,unknown,_),A=2,B=5,C=33 )). |
| 5956 | | :- assert_must_abort_wf(( int_power2(A,B,_,unknown,WF),A=2,B= -5 ),WF). |
| 5957 | | :- assert_must_fail(( int_power2(A,_,C,unknown,_),A= -2,C=32 )). |
| 5958 | | :- assert_must_fail(( int_power2(A,_,C,unknown,_),A= -2,C= -16 )). |
| 5959 | | |
| 5960 | | :- use_module(specfile,[eventb_mode/0]). |
| 5961 | | % TODO: calculate X from Y und Pow (i.e., Yth root of Pow); in CLPFD mode this is more or less done |
| 5962 | | int_power(int(X),int(Y),int(Pow),Span,WF) :- % power_of AST node |
| 5963 | | ( preferences:preference(use_clpfd_solver,true) |
| 5964 | | -> int_power2(X,Y,Pow,Span,WF), int_power_clpfd_propagation(X,Y,Pow) |
| 5965 | | ; int_power1(X,Y,Pow,Span,WF)). |
| 5966 | | % TO DO ?: if all are variables we can still infer some knowledge |
| 5967 | | % e.g. if X is positive then Pow must be positive; but it is probably quite rare that we have models with unknown exponent ? |
| 5968 | | :- block int_power1(-,?,?,?,?). % ensure that Base X is known if CLPFD off |
| 5969 | | int_power1(X,Y,Pow,Span,WF) :- |
| 5970 | | int_power2(X,Y,Pow,Span,WF). |
| 5971 | | :- block int_power2(-,-,?,?,?), int_power2(?,-,-,?,?). |
| 5972 | | int_power2(X,Y,Pow,Span,WF) :- |
| 5973 | | ( ground(Y) -> |
| 5974 | | ( Y>=0 -> (integer(X) -> safe_int_power0(X,Y,PowXY,Span,WF), |
| 5975 | ? | clpfd_nr_eq(PowXY,Pow) % try and prevent overflow if PowXY is large |
| 5976 | | ; safe_int_power0(X,Y,Pow,Span,WF)) |
| 5977 | | ; add_wd_error_set_result('power with negative exponent','**'(X,Y),Pow,1,Span,WF)) |
| 5978 | | ; /* X & POW are ground */ |
| 5979 | | ( X==1 -> Pow==1 /* 1**Y = 1 */ |
| 5980 | | ; X==0, Pow==1 -> Y=0 |
| 5981 | | ; X==0 -> Pow==0 |
| 5982 | | ; X>0, Pow>0 -> |
| 5983 | | checked_precise_log(X,Y,Pow,Span,WF) |
| 5984 | | % TO DO: X<0 should raise WD error for Event-B ? |
| 5985 | | ; X<0, eventb_mode -> add_wd_error_set_result('power with negative base','^'(X,Y),Pow,1,Span,WF) |
| 5986 | | ; X<0, Pow<0 -> |
| 5987 | | PosPow is -(Pow), |
| 5988 | | NegX is -(X), |
| 5989 | | checked_precise_log(NegX,Y,PosPow,Span,WF), |
| 5990 | | odd(Y) |
| 5991 | | ; X<0, Pow>0 -> |
| 5992 | | NegX is -(X), |
| 5993 | | checked_precise_log(NegX,Y,Pow,Span,WF), |
| 5994 | | even(Y))). |
| 5995 | | |
| 5996 | | :- assert_must_succeed(( integer_log(3,59049,Log),Log==10 )). |
| 5997 | | :- assert_must_succeed(( integer_log(2,1024,Log),Log==10 )). |
| 5998 | | :- assert_must_succeed(( integer_log(4,1024,Log),Log==5 )). |
| 5999 | | :- assert_must_succeed(( integer_log(10,1,Log),Log==0 )). |
| 6000 | | :- assert_must_succeed(( integer_log(10,2,Log),Log==0 )). |
| 6001 | | :- assert_must_succeed(( integer_log(10,10,Log),Log==1 )). |
| 6002 | | :- assert_must_succeed(( integer_log(10,11,Log),Log==1 )). |
| 6003 | | :- assert_must_succeed(( integer_log(10,1000,Log),Log==3 )). |
| 6004 | | :- use_module(tools_portability, [check_arithmetic_function/1]). |
| 6005 | | :- if(check_arithmetic_function(log(2, 4))). |
| 6006 | | % Native log(Base, Power) function is available - use it. |
| 6007 | | integer_log(Base, Power, Exp) :- ApproximateExp is truncate(log(Base, Power)), |
| 6008 | | % it is precise for power of 2 it seems, but not for 3 |
| 6009 | | % | ?- X is log(3,59049). X = 9.999999999999998 ? -> truncate gives 9, correct value is 10 |
| 6010 | | correct_integer_log_approximation(Base,Power,ApproximateExp,_,Exp). |
| 6011 | | :- else. |
| 6012 | | % No native log(Base, Power) support, so construct it using natural logarithms. |
| 6013 | | integer_log(Base, Power, Exp) :- ApproximateExp is truncate(log(Power) / log(Base)), |
| 6014 | | correct_integer_log_approximation(Base,Power,ApproximateExp,_,Exp). |
| 6015 | | :- endif. |
| 6016 | | |
| 6017 | | correct_integer_log_approximation(Base,Power,Exp,Correction,Res) :- |
| 6018 | | BE is Base ^ Exp, |
| 6019 | | (Correction=decreasing, BE > Power % not sure this case will ever trigger |
| 6020 | | -> Exp1 is Exp-1, %write(dec(Base,Bower,Exp1)),nl, |
| 6021 | | correct_integer_log_approximation(Base,Power,Exp1,Correction,Res) |
| 6022 | | ; Correction=increasing, BE*Base =< Power |
| 6023 | | -> Exp1 is Exp+1, %write(inc(Base,Bower,Exp1)),nl, |
| 6024 | | correct_integer_log_approximation(Base,Power,Exp1,Correction,Res) |
| 6025 | | ; Res=Exp). |
| 6026 | | |
| 6027 | | % TO DO for checked_precise_log: we should take pre-cautions with try_find_abort |
| 6028 | | % 2**x + y = 1024 & y:0..100 -> will give x=10, y=0 but not give rise to possible WD error |
| 6029 | | checked_precise_log(1,Exp,Pow,_,_) :- !, % the SICStus Prolog log function does not work for Base=1 |
| 6030 | | Pow=1, less_than_equal_direct(0,Exp). |
| 6031 | | checked_precise_log(Base,Exp,Pow,Span,WF) :- |
| 6032 | | integer_log(Base,Pow,Exp), |
| 6033 | | safe_int_power(Base,Exp,Pow,Span,WF). % we have the perfect solution |
| 6034 | | % ; Exp is Try+1, write(inc(Base,Pow,Try)),nl, safe_int_power(Base,Exp,Pow,Span,WF) ,write(pow(Base,Exp,Pow)),nl). |
| 6035 | | |
| 6036 | | :- block even(-). |
| 6037 | | even(X) :- 0 is X mod 2. |
| 6038 | | :- block odd(-). |
| 6039 | | odd(X) :- 1 is X mod 2. |
| 6040 | | |
| 6041 | | % propagation rules if only one of the args known |
| 6042 | | :- block int_power_clpfd_propagation(-,-,-). |
| 6043 | | int_power_clpfd_propagation(Base,Exp,Pow) :- Exp==0, var(Base),var(Pow),!, % B**0 = 1 |
| 6044 | | Pow = 1. |
| 6045 | | int_power_clpfd_propagation(Base,Exp,Pow) :- Exp==1, var(Base),var(Pow),!, % B**1 = B |
| 6046 | | Pow = Base. |
| 6047 | | int_power_clpfd_propagation(Base,Exp,Pow) :- Base==1, var(Exp),var(Pow),!, % 1**E = 1 |
| 6048 | | Pow = Base. |
| 6049 | | %int_power_clpfd_propagation(Base,Exp,Pow) :- number(Base), Base>0,var(Exp),var(Pow),!, |
| 6050 | | % clpfd_leq(1,Pow,_). % causes problem with test 305 |
| 6051 | | int_power_clpfd_propagation(X,Y,Pow) :- |
| 6052 | | fd_min(X,MinX), number(MinX), MinX>0, |
| 6053 | | fd_min(Y,MinY), number(MinY), MinY>0, % ensures no WD problem possible |
| 6054 | | MinPow is MinX^MinY, |
| 6055 | | \+ integer_too_large_for_clpfd(MinPow), |
| 6056 | | fd_max(X,MaxX), number(MaxX), |
| 6057 | | fd_max(Y,MaxY), number(MaxY), |
| 6058 | | MaxPow is MaxX^MaxY, |
| 6059 | | \+ integer_too_large_for_clpfd(MaxPow), |
| 6060 | | % only do propagation if we are sure not to produce a CLPFD overflow |
| 6061 | | !, |
| 6062 | | clpfd_inrange(Pow,MinPow,MaxPow), |
| 6063 | | (number(X), fd_max(Pow,MaxPow2), number(MaxPow2), get_new_upper_bound(X,MaxPow2,NewMaxExp,NewMaxPow) |
| 6064 | | -> clpfd_leq(Pow,NewMaxPow,_), |
| 6065 | | clpfd_leq(Y,NewMaxExp,_) |
| 6066 | | ; true), |
| 6067 | | (number(X), fd_min(Pow,MinPow2), number(MinPow2), get_new_lower_bound(X,MinPow2,NewMinExp,NewMinPow) |
| 6068 | | -> clpfd_leq(NewMinPow,Pow,_), |
| 6069 | | clpfd_leq(NewMinExp,Y,_) |
| 6070 | | ; true), |
| 6071 | | true. |
| 6072 | | %result of this propagation: x = 3**y & y:3..5 & x /= 27 & x /= 243 -> deterministically forces x=81, y=4 |
| 6073 | | int_power_clpfd_propagation(Base,Exp,Pow) :- number(Base), Base>1, var(Exp), var(Pow), |
| 6074 | | fd_max(Pow,MaxPow), number(MaxPow),!, |
| 6075 | | (integer_log(Base,MaxPow,Log) |
| 6076 | | -> clpfd_leq(Exp,Log,_) |
| 6077 | | ; add_internal_error('Failed:',integer_log(Base,MaxPow,_)), |
| 6078 | | clpfd_lt(Exp,MaxPow,_Posted)). |
| 6079 | | int_power_clpfd_propagation(_,_,_). |
| 6080 | | % 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 |
| 6081 | | |
| 6082 | | :- assert_must_succeed((kernel_objects:get_new_lower_bound(2,3,E,P),E==2,P==4)). |
| 6083 | | :- assert_must_succeed((kernel_objects:get_new_lower_bound(2,11,E,P),E==4,P==16)). |
| 6084 | | :- assert_must_fail((kernel_objects:get_new_lower_bound(2,16,_,_))). |
| 6085 | | % given Base and Power, determine if Power is a proper power of Exp, if not determine the next possible power of Base |
| 6086 | | get_new_lower_bound(Base,Power,MinExp,MinPower) :- Base > 1, Power> 0, |
| 6087 | | integer_log(Base,Power,Exp), |
| 6088 | | BE is Base^Exp, |
| 6089 | | BE < Power, |
| 6090 | | MinPower is Base*BE, |
| 6091 | | MinPower>Power, |
| 6092 | | MinPower < 1125899906842624, % 2^50 \+ integer_too_large_for_clpfd(MinPower), |
| 6093 | | MinExp is Exp+1. |
| 6094 | | :- assert_must_succeed((kernel_objects:get_new_upper_bound(2,3,E,P),E==1,P==2)). |
| 6095 | | :- assert_must_succeed((kernel_objects:get_new_upper_bound(2,11,E,P),E==3,P==8)). |
| 6096 | | :- assert_must_fail((kernel_objects:get_new_upper_bound(2,16,_,_))). |
| 6097 | | get_new_upper_bound(Base,Power,MaxExp,MaxPower) :- Base > 1, Power> 0, |
| 6098 | | integer_log(Base,Power,MaxExp), |
| 6099 | | MaxPower is Base^MaxExp, |
| 6100 | | MaxPower < Power, |
| 6101 | | \+ integer_too_large_for_clpfd(MaxPower), |
| 6102 | | MaxPower*Base > Power. |
| 6103 | | |
| 6104 | | % safe exponentiation using the squaring algorithm (CLPFD supports exponentiation only for SICStus 4.9 or later) |
| 6105 | | % Note: in TLA mode 0^0 is undefined according to TLC; for B/Rodin it is 1 |
| 6106 | | safe_int_power0(Base,Exp,Result,Span,WF) :- var(Base), |
| 6107 | | 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 |
| 6108 | | % 3**38 generates overflow; 4**30 generates overflow on 64-bit systems |
| 6109 | | % To do: examine whether we should already delay with a smaller or larger exponent |
| 6110 | | when(nonvar(Base),safe_int_power(Base,Exp,Result,Span,WF)). % wait until Base is known to avoid CLPFD overflow |
| 6111 | | safe_int_power0(Base,Exp,Result,Span,WF) :- safe_int_power(Base,Exp,Result,Span,WF). |
| 6112 | | |
| 6113 | | safe_int_power(Base,Exp,Result,Span,WF) :- number(Base), Base<0, eventb_mode,!, |
| 6114 | | add_wd_error_set_result('power with negative base','^'(Base,Exp),Result,1,Span,WF). |
| 6115 | | safe_int_power(_Base,0,Result,_,_WF) :- !, Result = 1. |
| 6116 | | safe_int_power(Base,Exp,Result,_,_) :- number(Base),!, |
| 6117 | | Result is Base^Exp. % new integer exponentiation operator in SICStus 4.3 |
| 6118 | | safe_int_power(Base,Exp,Result,_,_) :- |
| 6119 | | Msb is msb(Exp), % most significant bit |
| 6120 | | ExpMask is 1<<Msb, |
| 6121 | | safe_int_power_clpfd2(ExpMask,Exp,Base,1,Result). |
| 6122 | | |
| 6123 | | :- use_module(clpfd_interface,[clpfd_eq_expr/2]). |
| 6124 | | safe_int_power_clpfd2(0,_,_,Prev,Result) :- !, Prev=Result. |
| 6125 | | safe_int_power_clpfd2(Mask,Exp,Base,Prev,Result) :- |
| 6126 | | P is Exp /\ Mask, % P is Exp's highest bit |
| 6127 | | Mask2 is Mask>>1, |
| 6128 | | clpfd_eq_expr(Quad,Prev*Prev), |
| 6129 | | ( P==0 -> Next = Quad |
| 6130 | | ; clpfd_eq_expr(Next,Quad*Base) ), |
| 6131 | | safe_int_power_clpfd2(Mask2,Exp,Base,Next,Result). |
| 6132 | | %% ------------------------------------------------------- |
| 6133 | | |
| 6134 | | :- assert_must_succeed(( singleton_set_element([int(1)],E,unknown,_WF), E==int(1) )). |
| 6135 | | :- assert_must_succeed(( singleton_set_element([int(X)],int(1),unknown,_WF), X==1 )). |
| 6136 | | :- assert_must_fail(singleton_set_element([int(1)],int(2),unknown,_WF) ). |
| 6137 | | :- assert_must_abort_wf(kernel_objects:singleton_set_element([int(1),int(2)],_E,unknown,WF),WF). |
| 6138 | | % This predicate computes the effect of the MU operator. |
| 6139 | | % Set should be a singleton set and Elem its only element. |
| 6140 | | % In case Set is empty or has more than one element, an error |
| 6141 | | % message is generated. |
| 6142 | | :- block singleton_set_element(-,?,?,?). |
| 6143 | | singleton_set_element([],_,Span,WF) :- !, |
| 6144 | | add_wd_error_span('argument of MU expression must have cardinality 1, but is empty ', '', Span,WF). |
| 6145 | | singleton_set_element([H|T],Elem,Span,WF) :- !, |
| 6146 | | empty_set_test_wf(T,Empty,WF), |
| 6147 | | when(nonvar(Empty), |
| 6148 | | (Empty=pred_true -> equal_object_wf(Elem,H,singleton_set_element,WF) |
| 6149 | | ; add_wd_error_span('argument of MU expression has more than one element ', |
| 6150 | | b(value([H|T]),set(any),[]), Span,WF))). |
| 6151 | | singleton_set_element(avl_set(A),Elem,Span,WF) :- !, |
| 6152 | | (is_one_element_avl(A,AEl) -> equal_object_wf(Elem,AEl,singleton_set_element,WF) |
| 6153 | | ; add_wd_error_span('argument of MU expression has more than one element ', |
| 6154 | | b(value(avl_set(A)),set(any),[]), Span,WF)). |
| 6155 | | singleton_set_element(Set,Elem,Span,WF) :- |
| 6156 | | cardinality_as_int_wf(Set,Card,WF), % we have a comprehension set; could return inf ! |
| 6157 | | singleton_set_element1(Card,Set,Elem,Span,WF). |
| 6158 | | :- block singleton_set_element1(-,?,?,?,?). |
| 6159 | | singleton_set_element1(int(Card),Set,Elem,Span,WF) :- !, |
| 6160 | | % 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 |
| 6161 | | singleton_set_element2(Card,Set,Elem,Span,WF). |
| 6162 | | singleton_set_element1(XX,_Set,_Elem,Span,WF) :- |
| 6163 | | add_wd_error_span('argument of MU expression must have cardinality 1, but has ', XX, Span,WF). |
| 6164 | | |
| 6165 | | :- block singleton_set_element2(-,?,?,?,?). |
| 6166 | | singleton_set_element2(1,Set,Elem,_Span,_WF) :- !, |
| 6167 | | exact_element_of(Elem,Set). |
| 6168 | | singleton_set_element2(Card,_Set,_Elem,Span,WF) :- |
| 6169 | | add_wd_error_span('argument of MU expression must have cardinality 1, but has ', Card, Span,WF). |
| 6170 | | |
| 6171 | | :- assert_must_succeed(( singleton_set_element_wd([int(1)],E,unknown,_WF), E==int(1) )). |
| 6172 | | :- assert_must_succeed(( singleton_set_element_wd([int(X)],int(1),unknown,_WF), X==1 )). |
| 6173 | | %:- assert_must_succeed(( singleton_set_element_wd([int(X)|T],int(1),unknown,_WF), X==1, T==[] )). |
| 6174 | | :- assert_must_fail(singleton_set_element_wd([int(1)],int(2),unknown,_WF) ). |
| 6175 | | % MU_WD: a version of singleton_set_element which propagates more strongly from result to input |
| 6176 | | % and thus may not raise WD errors in this case |
| 6177 | | :- block singleton_set_element_wd(-,-,?,?). |
| 6178 | | singleton_set_element_wd(Set,Elem,Span,WF) :- nonvar(Set),!, % TODO: first check if Elem is ground |
| 6179 | | singleton_set_element(Set,Elem,Span,WF). |
| 6180 | | singleton_set_element_wd(Set,Elem,_,WF) :- % TODO: only propagate if fully known? |
| 6181 | | %(debug_mode(on) -> add_message_wf('MU_WD','MU_WD result instantiated: ',Elem,Span,WF) ; true), |
| 6182 | | equal_object_wf(Set,[Elem],singleton_set_element_wd,WF). |
| 6183 | | |
| 6184 | | |
| 6185 | | %:- print(finished_loading_kernel_objects),nl. |