1 % (c) 2012-2026 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2 % Heinrich Heine Universitaet Duesseldorf
3 % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5 :- module(external_functions,[call_external_function/7, call_external_predicate/8,
6 call_external_substitution/6,
7 reset_external_functions/0,
8 print_external_function_instantiation_profile/0,
9 external_pred_always_true/1,
10 reset_side_effect_occurred/0,
11 side_effect_occurred/1,
12 performs_io/1, not_declarative/1,
13 is_external_function_name/1,
14 get_external_function_type/3, % version with types with Prolog variables
15 external_fun_type/3,
16 external_subst_enabling_condition/3,
17 external_fun_has_wd_condition/1,
18 external_fun_can_be_inverted/1,
19 external_function_requires_state/1,
20 expects_unevaluated_args/1,
21 do_not_evaluate_args/1,
22 reset_argv/0, set_argv_from_list/1, set_argv_from_atom/1,
23 set_current_state_for_external_fun/1, clear_state_for_external_fun/0,
24
25 observe_parameters/2, observe_state/1, observe_value/2,
26
27 consult_new_external_function_library/1, reload_external_libraries/0
28 ]).
29
30 % Note: there is also the predicate external_procedure_used/1 in bmachine_construction
31
32 :- use_module(error_manager).
33 :- use_module(self_check).
34 :- use_module(library(avl)).
35 :- use_module(library(lists)).
36 :- use_module(translate).
37
38 % TO DO: add external Prolog files
39 % Should we do auto-conversion of B to Prolog types ,... ?
40
41 :- use_module(kernel_waitflags).
42 :- use_module(debug).
43 :- use_module(bsyntaxtree).
44 :- use_module(custom_explicit_sets).
45
46 :- use_module(module_information,[module_info/2]).
47 :- module_info(group,external_functions).
48 :- module_info(description,'This module provides a way to call external functions and predicates.').
49
50 :- set_prolog_flag(double_quotes, codes).
51
52 :- dynamic side_effect_occurred/1.
53 % TRUE if a side effect has occured
54 % possible values (user_output, file)
55 reset_side_effect_occurred :- (retract(side_effect_occurred(_)) -> retractall(side_effect_occurred(_)) ; true).
56 assert_side_effect_occurred(Location) :-
57 (side_effect_occurred(Location) -> true ; assertz(side_effect_occurred(Location))).
58
59 :- discontiguous expects_waitflag/1.
60 :- discontiguous expects_spaninfo/1.
61 :- discontiguous expects_type/1. % only used for external functions, not predicates or subst
62 :- discontiguous performs_io/1.
63 :- discontiguous is_not_declarative/1. % does not perform io but is still not declarative, e.g., has hidden args
64 :- discontiguous does_not_modify_state/1.
65 :- discontiguous expects_unevaluated_args/1.
66 :- discontiguous do_not_evaluate_args/1. % currently only used for external predicates, not for functions
67 :- discontiguous expects_state/1. % currently only used for external predicates
68 :- discontiguous external_pred_always_true/1. % external predicates which are always true
69 :- discontiguous external_subst_enabling_condition/3. % external predicates which are always true
70 :- discontiguous external_fun_has_wd_condition/1.
71 :- discontiguous external_fun_can_be_inverted/1. % helps the ProB constraint solver
72 :- discontiguous external_function_requires_state/1. % true if the function/predicate works on the current state in the state space
73 :- discontiguous external_fun_type/3. % external_fun_type(FUN,ListOfTypeParameters,ListOfArgTypes); also applicable to external predicates
74
75 % declare those predicates multifile which an external function library
76 % (loaded by -load_external_library) may have to define
77 % in principle these are all the predicates above
78 :- multifile external_fun_type/3, performs_io/1, expects_spaninfo/1, expects_waitflag/1,
79 external_fun_has_wd_condition/1.
80
81 :- meta_predicate safe_call(0,-,-).
82 :- meta_predicate safe_call(0,-).
83
84 :- meta_predicate observe_ground(-,-,-,-,-,0).
85
86 not_declarative(FunName) :- if(performs_io(FunName),true,is_not_declarative(FunName)).
87
88 is_external_function_name(Name) :- if(external_fun_type(Name,_,_),true,
89 if(expects_waitflag(Name),true,
90 if(expects_spaninfo(Name),true,
91 if(external_subst_enabling_condition(Name,_,_),true,
92 if(not_declarative(Name),true,
93 if(expects_unevaluated_args(Name),true,fail)
94 ))))).
95
96
97 :- use_module(state_space,[current_state_id/1, get_current_context_state/1]).
98 :- dynamic current_state_id_for_external_fun/1.
99 % some external functions access the current state; here we can set a particular state, without changing the animator/state_space
100 % useful, e.g., when exporting a VisB HTML trace when the JSON glue file uses ENABLED
101 % TODO: some commands also access the history;
102
103 % we use this rather than set_context_state because this would lead to errors being stored in the state_space
104 set_current_state_for_external_fun(ID) :-
105 asserta(current_state_id_for_external_fun(ID)).
106
107 clear_state_for_external_fun :-
108 (retract(current_state_id_for_external_fun(_)) -> true ; format('No state for external functions stored!~n',[])).
109
110 get_current_state_id(ID) :-
111 (current_state_id_for_external_fun(CID) -> ID=CID
112 ; state_space:get_current_context_state(CID) -> ID=CID
113 ; current_state_id(ID)).
114
115 % get current history without root (and without current state id)
116 get_current_history(History,Span) :-
117 history(RH),!,
118 (state_space:get_current_context_state(CID),
119 (current_state_id(CID)
120 -> RH=[Last|_], \+ state_space:transition(Last,CID,_) % something wrong, this cannot be last state of history
121 ; true % the history was not made for context state CID
122 ),
123 append(_,[CID|RH2],RH) % stop at CID which is being set; not a perfect solution; CID could occur multiple times!
124 -> true
125 ; RH2=RH),
126 (RH2=[] -> History=[]
127 ; reverse(RH2,[root|HH]) -> History = HH
128 ; add_message(external_functions,'HISTORY does not start with root:',RH2,Span), % from ProB2: fix
129 reverse(RH2,History)
130 ).
131 get_current_history(History,Span) :- add_message(external_functions,'No HISTORY available','',Span), History=[].
132
133 :- use_module(runtime_profiler,[profile_single_call/4]).
134
135 :- assert_must_succeed(( external_functions:call_external_function('COS',[b(integer(0),integer,[])],
136 [int(0)],int(100),integer,unknown,_WF) )).
137 :- assert_must_succeed(( external_functions:call_external_function('SIN',[b(integer(0),integer,[])],
138 [int(0)],int(0),integer,unknown,_WF) )).
139 % first a few hard-wired external functions for efficiency:
140 call_external_function('COS',_,[X],Value,_,_,_WF) :- !, 'COS'(X,Value). % already use safe_is
141 call_external_function('SIN',_,[X],Value,_,_,_WF) :- !, 'SIN'(X,Value).
142 call_external_function('TAN',_,[X],Value,_,_,_WF) :- !, 'TAN'(X,Value).
143 %call_external_function('STRING_APPEND',_,[A,B],Value,_,_,WF) :- !, 'STRING_APPEND'(A,B,Value,WF). % do we need safe_call?
144 %call_external_function('STRING_LENGTH',_,[A],Value,_,_,_WF) :- !, 'STRING_LENGTH'(A,Value).
145 % now the generic case:
146 call_external_function(F,Args,EvaluatedArgs,Value,Type,SpanInfo,WF) :-
147 (expects_waitflag(F)
148 -> E1=[WF],
149 (expects_spaninfo(F) -> E2=[SpanInfo|E1] ; E2=E1)
150 ; E1=[],
151 (expects_spaninfo(F) -> add_call_stack_to_span(SpanInfo,WF,S2), E2=[S2|E1] ; E2=E1)
152 ),
153 (expects_unevaluated_args(F) -> E3=[Args|E2] ; E3=E2),
154 (expects_type(F) -> E4=[Type|E3] ; E4=E3),
155 append(EvaluatedArgs,[Value|E4],AV),
156 % Check if there is better way to do this
157 Call =.. [F|AV],
158 % print('EXTERNAL FUNCTION CALL: '), print(F), print(' '), print(Call),nl,
159 % we could pass get_current_state_id(.) instead of unknown
160 profile_single_call(F,external_functions,unknown,safe_call(Call,SpanInfo,WF))
161 %, print(result(Value)),nl.
162 .
163
164 call_external_predicate(F,Args,EvaluatedArgs,LocalState,State,PREDRES,SpanInfo,WF) :-
165 (expects_waitflag(F)
166 -> E1=[WF],
167 (expects_spaninfo(F) -> E2=[SpanInfo|E1] ; E2=E1)
168 ; E1=[],
169 (expects_spaninfo(F) -> add_call_stack_to_span(SpanInfo,WF,S2), E2=[S2|E1] ; E2=E1)
170 ),
171 (expects_unevaluated_args(F) -> E3=[Args|E2] ; E3=E2),
172 (expects_state(F) -> E4=[LocalState,State|E3] ; E4=E3),
173 append(EvaluatedArgs,[PREDRES|E4],AV),
174 Call =.. [F|AV],
175 % print('EXTERNAL PREDICATE CALL: '), print(Call),nl, %%
176 profile_single_call(F,external_functions,unknown,safe_call(Call,SpanInfo,WF)).
177
178 call_external_substitution(FunName,Args,InState,OutState,Info,WF) :-
179 % TO DO: signal if substitution can be backtracked
180 get_wait_flag_for_subst(FunName,WF,Flag),
181 (does_not_modify_state(FunName) -> OutState=[] ; OutState = OutState2),
182 call_external_substitution2(Flag,FunName,Args,InState,OutState2,Info,WF).
183
184 get_wait_flag_for_subst(FunName,WF,Flag) :- perform_directly(FunName),!,
185 get_wait_flag1(WF,Flag). % ensure that precondition, ... have been evaluated
186 get_wait_flag_for_subst(FunName,WF,Flag) :- performs_io(FunName),!,
187 get_enumeration_finished_wait_flag(WF,Flag). % ensure that precondition, ... have been evaluated
188 % get_enumeration_starting_wait_flag(external(FunName),WF,Flag).
189 get_wait_flag_for_subst(FunName,WF,Flag) :- get_binary_choice_wait_flag(external(FunName),WF,Flag).
190
191 :- block call_external_substitution2(-,?,?,?,?,?,?).
192 call_external_substitution2(_,F,Args,InState,OutState,SpanInfo,WF) :-
193 (expects_waitflag(F) -> E1=[WF] ; E1=[]),
194 (expects_spaninfo(F) -> E2=[SpanInfo|E1] ; E2=E1),
195 append(Args,[InState,OutState|E2],AV),
196 Call =.. [F|AV],
197 % print('EXTERNAL SUBSTITUTION CALL: '), print(Call),nl, %%
198 profile_single_call(F,external_functions,unknown,safe_call(Call,SpanInfo,WF)).
199
200 safe_call(X,SpanInfo) :- safe_call(X,SpanInfo,no_wf_available).
201 safe_call(X,SpanInfo,WF) :-
202 catch(call(X), Exception, add_exception_error(Exception,X,SpanInfo,WF)).
203
204 safe_is(Context,X,Y,Span) :- safe_is(Context,X,Y,Span,no_wf_available).
205 safe_is(Context,X,Y,Span,WF) :- % print(safe_is(Context,X,Y)),nl,
206 catch(X is Y, Exception, add_exception_error(Exception,Context,Span,WF)). %, print(res(X)),nl.
207
208 add_exception_error(Exception,Context,Span,WF) :-
209 get_function_call_info(Context,SimplifiedContext),
210 add_exception_error2(Exception,SimplifiedContext,Span,WF),
211 (debug:debug_mode(on) -> tools_printing:print_term_summary(Context),nl ; true).
212
213 get_function_call_info(external_functions:X,Func) :- nonvar(X),!,functor(X,Func,_Arity).
214 get_function_call_info(M:X,M:Func) :- nonvar(X),!,functor(X,Func,_Arity).
215 get_function_call_info(X,X).
216
217 :- use_module(kernel_waitflags,[add_error_wf/5, add_warning_wf/5,add_wd_error_span/4]).
218 add_exception_error2(error(existence_error(procedure,external_functions:FUN),_),_X,SpanInfo,WF) :-
219 FUN = PRED/_Arity,
220 external_fun_type(PRED,_,ArgTypes), length(ArgTypes,Len), NA is Len-1, !,
221 ajoin(['EXTERNAL function exists and expects ',NA,' B arguments:'],Msg),
222 add_error_wf(external_functions,Msg,FUN,SpanInfo,WF),
223 fail.
224 add_exception_error2(error(existence_error(procedure,external_functions:FUN),_),ExtFun,SpanInfo,WF) :-
225 FUN = ExtFun/_Arity, % the existence error is for the main external function being called
226 !,
227 add_error_wf(external_functions,
228 'EXTERNAL function does not exist (check that you have an up-to-date version of ProB):',FUN,SpanInfo,WF),
229 fail.
230 add_exception_error2(error(existence_error(procedure,MODULE:FUN),_),_X,SpanInfo,WF) :- !,
231 add_error_wf(external_functions,'Predicate called by EXTERNAL function does not exist (please report a bug):',MODULE:FUN,SpanInfo,WF),
232 fail.
233 add_exception_error2(error(undefined,ERR),X,SpanInfo,WF) :-
234 is_error(ERR,ExprTerm),!,
235 ajoin(['Arithmetic operation ',X,' not defined:'],Msg),
236 add_error_wf(external_functions,Msg,ExprTerm,SpanInfo,WF),
237 fail.
238 add_exception_error2(error(evaluation_error(undefined),ERR),X,SpanInfo,WF) :-
239 is_error(ERR,ExprTerm),!,
240 ajoin(['Arithmetic operation ',X,' not defined for given argument(s):'],Msg),
241 add_wd_error_span(Msg,ExprTerm,SpanInfo,WF).
242 add_exception_error2(error(evaluation_error(zero_divisor),ERR),X,SpanInfo,WF) :-
243 is_error(ERR,_),!,
244 % TO DO: use add_wd_error_set_result:
245 add_wd_error_span('Division by 0 in arithmetic operation: ',X,SpanInfo,WF).
246 add_exception_error2(error(existence_error(source_sink,File),Err2),X,SpanInfo,WF) :- !,
247 (arg(1,Err2,Call), get_file_open_mode(Call,append)
248 -> ajoin(['File does not exist and cannot be created (calling external function ',X,'):'],Msg)
249 ; arg(1,Err2,Call), get_file_open_mode(Call,write)
250 -> ajoin(['File cannot be created (calling external function ',X,'):'],Msg)
251 ; ajoin(['File does not exist (calling external function ',X,'):'],Msg)
252 ),
253 add_error_wf(external_functions,Msg,File,SpanInfo,WF),
254 fail.
255 add_exception_error2(error(consistency_error(Msg,_,format_arguments),_),_X,SpanInfo,WF) :- !,
256 add_error_wf(external_functions,'Illegal format string (see SICStus Prolog reference manual for syntax):',Msg,SpanInfo,WF),
257 fail.
258 add_exception_error2(enumeration_warning(A,B,C,D,E),X,SpanInfo,WF) :-
259 Exception = enumeration_warning(A,B,C,D,E),!,
260 debug_println(20,Exception),
261 get_predicate_name(X,Pred),
262 add_warning_wf(external_functions,'Enumeration warning occured while calling external function: ',Pred,SpanInfo,WF),
263 % or should we just print a message on the console ?
264 % or use
265 throw(Exception).
266 add_exception_error2(user_interrupt_signal,X,SpanInfo,WF) :- !,
267 get_predicate_name(X,Pred),
268 add_warning_wf(external_functions,'User Interrupt during external function evaluation: ',Pred,SpanInfo,WF),
269 throw(user_interrupt_signal).
270 add_exception_error2(Exception,X,SpanInfo,WF) :-
271 debug_println(20,Exception),
272 ajoin(['Exception occurred while calling external function ',X,':'],Msg),
273 add_error_wf(external_functions,Msg,Exception,SpanInfo,WF),
274 fail.
275
276 % get file open mode from a SICStus library call (e.g., that caused an existence_error exception)
277 get_file_open_mode(open(_File,Mode,_,_),Mode).
278 get_file_open_mode(open(_File,Mode,_),Mode).
279
280 get_predicate_name(Var,P) :- var(Var),!,P='_VAR_'.
281 get_predicate_name(external_functions:C,P) :- !, get_predicate_name(C,P).
282 get_predicate_name(Module:C,Module:P) :- !, get_predicate_name(C,P).
283 get_predicate_name(Call,F/P) :- functor(Call,F,P).
284
285 is_error(evaluation_error('is'(_,ExprTerm),2,_,_),ExprTerm).
286 is_error(domain_error('is'(_,ExprTerm),2,_,_),ExprTerm).
287
288 get_external_function_type(FunName,ArgTypes,ReturnType) :-
289 external_fun_type(FunName,TypeParas,AllTypes),
290 (member(TP,TypeParas),nonvar(TP)
291 -> add_internal_error('External function type parameter not a variable:,',
292 external_fun_type(FunName,TypeParas,AllTypes))
293 ; true
294 ),
295 append(ArgTypes,[ReturnType],AllTypes).
296
297 % STANDARD EXTERNAL FUNCTIONS
298
299
300 % -------------------------------
301
302
303 :- use_module(extrasrc(external_functions_reals)). % removed explicit imports for Spider
304 %:- use_module(extrasrc(external_functions_soft_floats)). % removed October 15th 2026
305 % is now in git@gitlab.cs.uni-duesseldorf.de:stups/prob/prob_prolog_extensions.git
306
307 :- use_module(extrasrc(external_functions_statistics_library)).
308
309 :- use_module(probsrc(tools),[get_set_optional_prolog_flag/3]).
310
311 :- dynamic new_external_library_loaded/1.
312 reset_external_libraries :-
313 true. % we do not do: retractall(new_external_library_loaded(_));
314 % at the moment the new libraries are loaded once for all runs
315
316 % load additional external functions that can be called
317 consult_new_external_function_library(File) :-
318 (new_external_library_loaded(File)
319 -> Msg = 'Re-Loading new external functions from: '
320 ; Msg = 'Loading new external functions from: ',
321 assert(new_external_library_loaded(File))),
322 add_message(external_functions,Msg,File),
323 get_set_optional_prolog_flag(redefine_warnings, Old, off),
324 get_set_optional_prolog_flag(single_var_warnings, Old2, off),
325 (catch(compile(File),
326 error(existence_error(_,_),_),
327 add_error_fail(external_functions,'Prolog module file with additional external functions does not exist:',File))
328 -> OK=true ; OK=false),
329 get_set_optional_prolog_flag(redefine_warnings, _, Old),
330 get_set_optional_prolog_flag(single_var_warnings, _, Old2),
331 OK=true.
332
333 reload_external_libraries :-
334 new_external_library_loaded(File),
335 consult_new_external_function_library(File),fail.
336 reload_external_libraries.
337
338 expects_waitflag('STRING_TO_REAL').
339 external_fun_type('STRING_TO_REAL',[],[string,real]).
340
341 expects_waitflag('RADD').
342 external_fun_type('RADD',[],[real,real,real]).
343 expects_waitflag('RSUB').
344 external_fun_type('RSUB',[],[real,real,real]).
345 expects_waitflag('RMUL').
346 external_fun_type('RMUL',[],[real,real,real]).
347 expects_waitflag('RDIV').
348 expects_spaninfo('RDIV').
349 external_fun_type('RDIV',[],[real,real,real]).
350 external_fun_has_wd_condition('RDIV').
351 expects_waitflag('RINV').
352 expects_spaninfo('RINV').
353 external_fun_type('RINV',[],[real,real]).
354 external_fun_has_wd_condition('RINV').
355
356 external_fun_type('RPI',[],[real]).
357 external_fun_type('RZERO',[],[real]).
358 external_fun_type('RONE',[],[real]).
359 external_fun_type('REULER',[],[real]).
360 external_fun_type('REPSILON',[],[real]).
361 external_fun_type('RMAXFLOAT',[],[real]).
362
363 external_fun_type('RSIN',[],[real,real]).
364 expects_waitflag('RSIN').
365 external_fun_type('RCOS',[],[real,real]).
366 expects_waitflag('RCOS').
367 external_fun_type('RTAN',[],[real,real]).
368 expects_waitflag('RTAN').
369 external_fun_type('RCOT',[],[real,real]).
370 expects_waitflag('RCOT').
371 external_fun_type('RSINH',[],[real,real]).
372 expects_waitflag('RSINH').
373 external_fun_type('RCOSH',[],[real,real]).
374 expects_waitflag('RCOSH').
375 external_fun_type('RTANH',[],[real,real]).
376 expects_waitflag('RTANH').
377 external_fun_type('RCOTH',[],[real,real]).
378 expects_waitflag('RCOTH').
379 external_fun_type('RASIN',[],[real,real]).
380 expects_waitflag('RASIN').
381 external_fun_type('RACOS',[],[real,real]).
382 expects_waitflag('RACOS').
383 external_fun_type('RATAN',[],[real,real]).
384 expects_waitflag('RATAN').
385 external_fun_type('RACOT',[],[real,real]).
386 expects_waitflag('RACOT').
387 external_fun_type('RASINH',[],[real,real]).
388 expects_waitflag('RASINH').
389 external_fun_type('RACOSH',[],[real,real]).
390 expects_waitflag('RACOSH').
391 external_fun_type('RATANH',[],[real,real]).
392 expects_waitflag('RATANH').
393 external_fun_type('RACOTH',[],[real,real]).
394 expects_waitflag('RACOTH').
395 external_fun_type('RATAN2',[],[real,real,real]).
396 expects_waitflag('RATAN2').
397 expects_spaninfo('RATAN2').
398 external_fun_type('RHYPOT',[],[real,real,real]).
399 expects_waitflag('RHYPOT').
400 expects_spaninfo('RHYPOT').
401 external_fun_type('RADIANS',[],[real,real]).
402 expects_waitflag('RADIANS').
403 expects_spaninfo('RADIANS').
404 external_fun_type('DEGREE',[],[real,real]).
405 expects_waitflag('DEGREE').
406 expects_spaninfo('DEGREE').
407
408
409 external_fun_type('RUMINUS',[],[real,real]).
410 expects_waitflag('RUMINUS').
411 external_fun_type('REXP',[],[real,real]).
412 expects_waitflag('REXP').
413 external_fun_type('RLOGe',[],[real,real]).
414 expects_waitflag('RLOGe').
415 expects_spaninfo('RLOGe').
416 external_fun_has_wd_condition('RLOGe').
417 external_fun_type('RSQRT',[],[real,real]).
418 expects_waitflag('RSQRT').
419 expects_spaninfo('RSQRT').
420 external_fun_has_wd_condition('RSQRT'). % for negative numbers obviously
421 external_fun_type('RABS',[],[real,real]).
422 expects_waitflag('RABS').
423 external_fun_type('ROUND',[],[real,integer]).
424 expects_waitflag('ROUND').
425 external_fun_type('RSIGN',[],[real,real]).
426 expects_waitflag('RSIGN').
427 external_fun_type('RINTEGER',[],[real,real]).
428 expects_waitflag('RINTEGER').
429 external_fun_type('RFRACTION',[],[real,real]).
430 expects_waitflag('RFRACTION').
431
432 expects_waitflag('RMAX').
433 expects_spaninfo('RMAX').
434 external_fun_type('RMAX',[],[real,real,real]).
435 expects_waitflag('RMIN').
436 expects_spaninfo('RMIN').
437 external_fun_type('RMIN',[],[real,real,real]).
438 expects_spaninfo('RPOW').
439 expects_waitflag('RPOW').
440 external_fun_type('RPOW',[],[real,real,real]).
441 external_fun_has_wd_condition('RPOW'). % for negative numbers, e.g., RPOW(-1.0,1.1) or RPOW(-1.0,0.5)
442 expects_spaninfo('RDECIMAL').
443 expects_waitflag('RDECIMAL').
444 external_fun_type('RDECIMAL',[],[integer,integer,real]).
445 expects_waitflag('RLOG').
446 expects_spaninfo('RLOG').
447 external_fun_type('RLOG',[],[real,real,real]).
448 external_fun_has_wd_condition('RLOG').
449
450 expects_waitflag('RLT').
451 external_fun_type('RLT',[],[real,real,boolean]).
452 expects_waitflag('REQ').
453 external_fun_type('REQ',[],[real,real,boolean]).
454 expects_waitflag('RNEQ').
455 external_fun_type('RNEQ',[],[real,real,boolean]).
456 expects_waitflag('RLEQ').
457 external_fun_type('RLEQ',[],[real,real,boolean]).
458 expects_waitflag('RGT').
459 external_fun_type('RGT',[],[real,real,boolean]).
460 expects_waitflag('RGEQ').
461 external_fun_type('RGEQ',[],[real,real,boolean]).
462 expects_waitflag('RMAXIMUM').
463 expects_spaninfo('RMAXIMUM').
464 external_fun_type('RMAXIMUM',[],[set(real),real]).
465 external_fun_has_wd_condition('RMAXIMUM'). % empty set or unbounded set
466 expects_waitflag('RMINIMUM').
467 expects_spaninfo('RMINIMUM').
468 external_fun_type('RMINIMUM',[],[set(real),real]).
469 external_fun_has_wd_condition('RMINIMUM'). % empty set or unbounded set
470
471 external_fun_type('RNEXT',[],[real,real]).
472 external_fun_type('RPREV',[],[real,real]).
473
474
475
476 % -------------------------------
477
478 :- use_module(extrasrc(external_functions_svg)). %, [svg_points/4, svg_train/8, svg_car/8, svg_axis/7, svg_set_polygon/7]).
479
480 expects_waitflag('svg_points').
481 expects_spaninfo('svg_points').
482 external_fun_type('svg_points',[T1,T2],[seq(couple(T1,T2)),string]). % T1, T2 should be numbers
483
484 expects_waitflag('svg_train').
485 expects_spaninfo('svg_train').
486 external_fun_type('svg_train',[T1,T2],[T1,T1,T2,T2,T2,string]). % T1, T2 should be numbers
487 expects_waitflag('svg_car').
488 expects_spaninfo('svg_car').
489 external_fun_type('svg_car',[T1,T2],[T1,T1,T2,T2,T2,string]). % T1, T2 should be numbers
490
491 expects_waitflag('svg_axis').
492 expects_spaninfo('svg_axis').
493 external_fun_type('svg_axis',[T1,T2],[set(T1),T2,T2,T2,string]). % T1, T2 should be numbers
494
495 expects_waitflag('svg_set_polygon').
496 expects_spaninfo('svg_set_polygon').
497 external_fun_type('svg_set_polygon',[T2],[set(integer),T2,T2,T2,string]). % T2 should be number type
498
499 expects_waitflag('svg_set_polygon_auto').
500 expects_spaninfo('svg_set_polygon_auto').
501 external_fun_type('svg_set_polygon_auto',[T2],[set(integer),T2,T2,string]). % T2 should be number type
502
503 expects_waitflag('svg_dasharray_for_intervals').
504 expects_spaninfo('svg_dasharray_for_intervals').
505 external_fun_type('svg_dasharray_for_intervals',[T1,T2],[set(couple(T1,T2)),string]). % T1, T2 should be numbers
506
507 expects_waitflag('svg_set_dasharray').
508 expects_spaninfo('svg_set_dasharray').
509 external_fun_type('svg_set_dasharray',[],[set(integer),string]).
510
511 % -------------------------------
512
513 % MATHEMATICAL FUNCTIONS
514
515 external_fun_type('COS',[],[integer,integer]).
516 :- public 'COS'/2.
517 :- block 'COS'(-,?). % redundant; we could add CLPFD constraints for R
518 'COS'(int(X),int(R)) :- cos2(100,X,R,unknown).
519 external_fun_type('COSx',[],[integer,integer,integer]).
520 expects_spaninfo('COSx').
521 :- public 'COSx'/4.
522 :- block 'COSx'(-,?,?,?),'COSx'(?,-,?,?).
523 'COSx'(int(PrecisionMultiplier),int(X),int(R),Span) :- cos2(PrecisionMultiplier,X,R,Span).
524 :- block cos2(-,?,?,?),cos2(?,-,?,?).
525 cos2(Multiplier,X,R,Span) :- safe_is('COSx',R,round(Multiplier*cos(X/Multiplier)),Span).
526
527 external_fun_type('SIN',[],[integer,integer]).
528 :- public 'SIN'/2.
529 :- block 'SIN'(-,?). % redundant; we could add CLPFD constraints for R
530 'SIN'(int(X),int(R)) :- sin2(100,X,R,unknown).
531 external_fun_type('SINx',[],[integer,integer,integer]).
532 expects_spaninfo('SINx').
533 :- public 'SINx'/4.
534 :- block 'SINx'(-,?,?,?),'SINx'(?,-,?,?).
535 'SINx'(int(PrecisionMultiplier),int(X),int(R),Span) :- %print('SINx'(PrecisionMultiplier,X,R)),nl,
536 sin2(PrecisionMultiplier,X,R,Span).
537 :- block sin2(-,?,?,?),sin2(?,-,?,?).
538 sin2(Multiplier,X,R,Span) :- safe_is('SINx',R,round(Multiplier*sin(X/Multiplier)),Span).
539
540 external_fun_type('TAN',[],[integer,integer]).
541 :- public 'TAN'/2.
542 :- block 'TAN'(-,?). % redundant; we could add CLPFD constraints for R
543 'TAN'(int(X),int(R)) :- tan2(100,X,R,unknown).
544 external_fun_type('TANx',[],[integer,integer,integer]).
545 expects_spaninfo('TANx').
546 :- public 'TANx'/4.
547 :- block 'TANx'(-,?,?,?),'TANx'(?,-,?,?).
548 'TANx'(int(PrecisionMultiplier),int(X),int(R),Span) :- tan2(PrecisionMultiplier,X,R,Span).
549 :- block tan2(?,-,?,?),tan2(-,?,?,?).
550 tan2(Multiplier,X,R,Span) :- safe_is('TANx',R,round(Multiplier*tan(X/Multiplier)),Span).
551
552
553 external_fun_type('PROLOG_FUN',[],[string,integer,integer,integer]).
554 external_fun_has_wd_condition('PROLOG_FUN').
555 expects_spaninfo('PROLOG_FUN').
556 :- public 'PROLOG_FUN'/5.
557 'PROLOG_FUN'(string(Function),int(PrecisionMultiplier),int(Argument),int(Result),Span) :-
558 prolog_fun2(Function,PrecisionMultiplier,Argument,Result,Span).
559 % Function can be:
560 % sin, cos, tan, cot, sinh, cosh, tanh, asin, acos, atan, acot, asinh, acosh, atanh, acoth, sqrt, log, exp
561 :- block prolog_fun2(?,-,?,?,?),prolog_fun2(-,?,?,?,?), prolog_fun2(?,?,-,?,?).
562 prolog_fun2(Function,Multiplier,X,R,Span) :-
563 E =.. [Function,X/Multiplier],
564 safe_is(Function,R,round(Multiplier*E),Span).
565
566 external_fun_has_wd_condition('LOGx'). % PrecisionMultiplier>0, Base>0, X>0
567 expects_spaninfo('LOGx').
568 external_fun_type('LOGx',[],[integer,integer,integer,integer]).
569 :- public 'LOGx'/5.
570 :- block 'LOGx'(-,?,?,?,?),'LOGx'(?,-,?,?,?), 'LOGx'(?,?,-,?,?).
571 'LOGx'(int(PrecisionMultiplier),int(Base),int(X),int(R),Span) :-
572 log2(PrecisionMultiplier,Base,X,R,Span).
573 :- block log2(?,-,?,?,?),log2(-,?,?,?,?),log2(?,?,-,?,?).
574 log2(Multiplier,Base,X,R,Span) :-
575 logx_internal(Multiplier,Base,X,R,Span).
576
577 :- use_module(tools_portability, [check_arithmetic_function/1]).
578 :- if(check_arithmetic_function(log(2, 4))).
579 % Native log(Base, Power) function is available - use it.
580 logx_internal(Multiplier,Base,X,R,Span) :-
581 safe_is('LOGx',R,round(Multiplier*log(Base/Multiplier,X/Multiplier)),Span).
582 :- else.
583 % No native log(Base, Power) support, so construct it using natural logarithms.
584 logx_internal(Multiplier,Base,X,R,Span) :-
585 safe_is('LOGx',R,round(Multiplier*(log(X/Multiplier)/log(Base/Multiplier))),Span).
586 :- endif.
587
588 :- use_module(clpfd_interface,[clpfd_gcd/3, clpfd_lcm/3, clpfd_abs/2, clpfd_sign/2]).
589 external_fun_type('GCD',[],[integer,integer,integer]).
590 :- public 'GCD'/3.
591 :- block 'GCD'(-,-,-).
592 'GCD'(int(X),int(Y),int(R)) :-
593 clpfd_gcd(X,Y,R).
594
595 % least / smallest common multiple
596 external_fun_type('LCM',[],[integer,integer,integer]).
597 :- public 'LCM'/3.
598 :- block 'LCM'(-,-,-).
599 'LCM'(int(X),int(Y),int(R)) :- clpfd_lcm(X,Y,R).
600
601 external_fun_type('ABS',[],[integer,integer]).
602 external_fun_can_be_inverted('ABS'). % there are two possible input values for an output value
603 :- public 'ABS'/2.
604 :- block 'ABS'(-,-). % do we need this ??
605 'ABS'(int(X),int(R)) :-
606 clpfd_abs(X,R).
607
608 external_fun_type('SIGN',[],[integer,integer]).
609 :- public 'SIGN'/2.
610 :- block 'SIGN'(-,-).
611 'SIGN'(int(X),int(R)) :-
612 clpfd_sign(X,R).
613
614
615 % TLA style floored division
616 external_fun_has_wd_condition('FDIV').
617 expects_spaninfo('FDIV').
618 expects_waitflag('FDIV').
619 external_fun_type('FDIV',[],[integer,integer,integer]).
620 :- public 'FDIV'/5.
621 :- block 'FDIV'(-,-,-,?,?).
622 'FDIV'(X,Y,Z,Span,WF) :-
623 kernel_objects:floored_division(X,Y,Z,Span,WF).
624
625 % ceiling division
626 external_fun_has_wd_condition('CDIV').
627 expects_spaninfo('CDIV').
628 expects_waitflag('CDIV').
629 external_fun_type('CDIV',[],[integer,integer,integer]).
630 :- public 'CDIV'/5.
631 :- block 'CDIV'(-,?,?,?,?),'CDIV'(?,-,?,?,?).
632 'CDIV'(int(X),int(Y),Res,Span,WF) :-
633 ceiling_division(X,Y,Res,Span,WF).
634
635 :- block ceiling_division(-,?,?,?,?),ceiling_division(?,-,?,?,?).
636 ceiling_division(X,Y,_Res,Span,WF) :- Y=0,!,
637 add_wd_error_span('Ceiling division by zero:',X,Span,WF).
638 ceiling_division(X,Y,Res,_Span,_WF) :-
639 X mod Y =:= 0,!,
640 XY is X//Y, Res = int(XY).
641 ceiling_division(X,Y,Res,Span,WF) :-
642 kernel_objects:floored_division(int(X),int(Y),int(Z),Span,WF),
643 Z1 is 1 + Z,
644 Res = int(Z1).
645
646 external_fun_has_wd_condition('SQRT').
647 expects_spaninfo('SQRT').
648 expects_waitflag('SQRT').
649 external_fun_type('SQRT',[],[integer,integer]).
650 %external_fun_can_be_inverted('SQRT'). % TODO : comment in after fixing TODOs below
651 :- public 'SQRT'/4.
652 :- block 'SQRT'(-,?,?,?).
653 'SQRT'(int(X),R,Span,WF) :-
654 positive_integer_sqrt(X,R,Span,WF). % TO DO: maybe do CLPFD propagation?
655 % TODO: backwards propagation from R to X; if X=2 -> X=+/-4,5,6,7,8
656
657 :- block positive_integer_sqrt(-,?,?,?).
658 positive_integer_sqrt(X,_,Span,WF) :- X<0,!,
659 add_wd_error_span('Trying to compute square root of negative number:',X,Span,WF).
660 positive_integer_sqrt(X,Res,Span,_WF) :-
661 Candidate is floor(sqrt(X)), % compute using floating number function
662 (Candidate*Candidate =< X
663 -> C1 is Candidate+1,
664 (C1*C1 > X
665 -> Res = int(Candidate)
666 ; (C1+1)*(C1+1) > X
667 -> Res = int(C1)
668 ; % SQR is (C1+1)^2, Delta is X-SQR, write(sqr_candidate(C1,SQR,X,Delta)),nl,
669 % >>> SQRT(9999911144210000019*9999911144210000019+2)
670 add_error(external_functions,'Rounding error (2) while computing SQRT of: ',X,Span),
671 Res = int(C1)
672 )
673 ; add_error(external_functions,'Rounding error (1) while computing SQRT of: ',X,Span),
674 % SQRT(999991114421000001*999991114421000001+2)
675 Res = int(Candidate)
676 ).
677
678 external_fun_type('MSB',[],[integer,integer]).
679 expects_spaninfo('MSB').
680 :- public 'MSB'/3.
681 :- block 'MSB'(-,?,?).
682 'MSB'(int(X),int(R),Span) :- msb2(X,R,Span). % most significant bit
683 :- block msb2(-,?,?).
684 msb2(X,R,Span) :- safe_is('MSB',R,msb(X),Span). % TO DO: could be made reversible by propagating constraint if R known
685
686
687 external_fun_type('FACTORIAL',[],[integer,integer]).
688 expects_spaninfo('FACTORIAL').
689 expects_waitflag('FACTORIAL').
690 :- public 'FACTORIAL'/4.
691 :- block 'FACTORIAL'(-,?,?,?).
692 'FACTORIAL'(int(X),int(R),Span,WF) :- fact(X,R,Span,WF). % most significant bit
693 :- block fact(-,?,?,?).
694 fact(X,_,Span,WF) :- X<0,!, add_wd_error_span('FACTORIAL applied to negative number: ',X,Span,WF).
695 fact(X,_,Span,WF) :- X>10000,!, add_wd_error_span('FACTORIAL overflow, argument too large: ',X,Span,WF).
696 fact(X,Res,_,_) :- fact_acc(X,1,Res).
697
698 fact_acc(0,Acc,Res) :- !,Res=Acc.
699 fact_acc(N,Acc,Res) :- NAcc is Acc*N,
700 N1 is N-1, fact_acc(N1,NAcc,Res).
701
702 % TODO: fact_k, choose_nk
703
704 % BITWISE OPERATORS
705 external_fun_type('BNOT',[],[integer,integer]).
706 external_fun_can_be_inverted('BNOT').
707 expects_spaninfo('BNOT').
708 :- public 'BNOT'/3.
709 :- if((current_prolog_flag(dialect, sicstus),
710 current_prolog_flag(version_data, sicstus(4,VN,_,_,_)), VN>=9)).
711 :- block 'BNOT'(-,-,?).
712 'BNOT'(int(X),int(R),Span) :-
713 (preferences:preference(use_clpfd_solver,true)
714 -> clpfd_eq_expr(R,'\\'(X))
715 ; bitwise_not(X,R,Span)
716 ).
717 :- else.
718 'BNOT'(int(X),int(R),Span) :- bitwise_not(X,R,Span).
719 :- endif.
720 :- block bitwise_not(-,-,?).
721 bitwise_not(X,R,Span) :- number(X),!,safe_is('BNOT',R,\(X),Span).
722 bitwise_not(X,R,Span) :- safe_is('BNOT',X,\(R),Span).
723
724 :- use_module(clpfd_interface,[clpfd_eq_expr/2]).
725
726 external_fun_type('BAND',[],[integer,integer,integer]).
727 :- public 'BAND'/3.
728 :- if((current_prolog_flag(dialect, sicstus),
729 current_prolog_flag(version_data, sicstus(4,VN,_,_,_)), VN>=9)).
730 :- block 'BAND'(-,-,-).
731 'BAND'(int(X),int(Y),int(R)) :-
732 (preferences:preference(use_clpfd_solver,true)
733 -> clpfd_eq_expr(R,'/\\'(X,Y))
734 ; bitwise_and(X,Y,R)).
735 :- else.
736 :- block 'BAND'(-,?,?),'BAND'(?,-,?).
737 'BAND'(int(X),int(Y),int(R)) :- bitwise_and(X,Y,R).
738 :- endif.
739 :- block bitwise_and(?,-,?),bitwise_and(-,?,?).
740 bitwise_and(X,Y,R) :- R is X /\ Y. % we could do some early consistency checking, e.g., when X and R known
741
742 external_fun_type('BOR',[],[integer,integer,integer]).
743 :- public 'BOR'/3.
744 :- if((current_prolog_flag(dialect, sicstus),
745 current_prolog_flag(version_data, sicstus(4,VN,_,_,_)), VN>=9)).
746 :- block 'BOR'(-,-,-).
747 'BOR'(int(X),int(Y),int(R)) :-
748 (preferences:preference(use_clpfd_solver,true)
749 -> clpfd_eq_expr(R,'\\/'(X,Y))
750 ; bitwise_or(X,Y,R)).
751 :- else.
752 :- block 'BOR'(-,?,?),'BOR'(?,-,?).
753 'BOR'(int(X),int(Y),int(R)) :- bitwise_or(X,Y,R).
754 :- block bitwise_or(?,-,?),bitwise_or(-,?,?).
755 :- endif.
756 bitwise_or(X,Y,R) :- R is X \/ Y. % we could do some early consistency checking, e.g., when X and R known
757
758 external_fun_type('BXOR',[],[integer,integer,integer]).
759 external_fun_can_be_inverted('BXOR').
760 :- public 'BXOR'/3.
761 :- if((current_prolog_flag(dialect, sicstus),
762 current_prolog_flag(version_data, sicstus(4,VN,_,_,_)), VN>=9)).
763 :- block 'BXOR'(-,-,-).
764 'BXOR'(int(X),int(Y),int(R)) :-
765 (preferences:preference(use_clpfd_solver,true)
766 -> clpfd_eq_expr(R,xor(X,Y))
767 ; bitwise_xor(X,Y,R)).
768 :- else.
769 :- block 'BXOR'(-,-,?),'BXOR'(?,-,-),'BXOR'(-,?,-).
770 'BXOR'(int(X),int(Y),int(R)) :- bitwise_xor(X,Y,R).
771 :- endif.
772 :- block bitwise_xor(-,-,?),bitwise_xor(?,-,-),bitwise_xor(-,?,-).
773 % DO WE NEED TO KNOW THE sizes of X,Y,R ?
774 bitwise_xor(X,Y,R) :- var(X),!, X is xor(R,Y).
775 bitwise_xor(X,Y,R) :- var(Y),!, Y is xor(X,R).
776 bitwise_xor(X,Y,R) :- R is xor(X,Y).
777
778 % TO DO: do some clpfd propagations ? X:0..N & Y:0..M -> BAND(X,Y) : 0..min(N,M)
779
780 % EXTERNAL_FUNCTION_BITS == INTEGER --> seq(INTEGER)
781 % BITS(x) == [0]
782 external_fun_type('BLSHIFT',[],[integer,integer,integer]).
783 :- public 'BLSHIFT'/3.
784 :- block 'BLSHIFT'(-,?,?),'BLSHIFT'(?,-,?).
785 'BLSHIFT'(int(X),int(Y),int(R)) :- bitwise_left_shift(X,Y,R).
786 :- block bitwise_left_shift(?,-,?),bitwise_left_shift(-,?,?).
787 bitwise_left_shift(X,Y,R) :- R is X << Y.
788 external_fun_type('BRSHIFT',[],[integer,integer,integer]).
789 :- public 'BRSHIFT'/3.
790 :- block 'BRSHIFT'(-,?,?),'BRSHIFT'(?,-,?).
791 'BRSHIFT'(int(X),int(Y),int(R)) :- bitwise_right_shift(X,Y,R).
792 :- block bitwise_right_shift(?,-,?),bitwise_right_shift(-,?,?).
793 bitwise_right_shift(X,Y,R) :- R is X >> Y.
794
795 :- assert_must_succeed(( external_functions:call_external_function('BITS',[12],[int(12)],R,integer,unknown,_WF),
796 equal_object(R,[(int(1),int(1)),(int(2),int(1)),(int(3),int(0)),(int(4),int(0))]) )).
797
798 external_fun_type('BITS',[],[integer,seq(integer)]).
799 :- public 'BITS'/2.
800 :- block 'BITS'(-,?).
801 'BITS'(int(X),Res) :- convert_to_bits(X,Res).
802
803 :- block convert_to_bits(-,?).
804 convert_to_bits(0,Res) :- !, convert_list_to_seq([int(0)],Res).
805 convert_to_bits(N,Res) :- convert_to_bits(N,[],List),
806 convert_list_to_seq(List,Res).
807 convert_to_bits(0,Acc,Res) :- !, Res=Acc.
808 convert_to_bits(X,Acc,Res) :- XM2 is X mod 2, XD2 is X // 2,
809 convert_to_bits(XD2,[int(XM2)|Acc],Res).
810 % TO DO: maybe do some constraint propagation from Result to number, or use CLP(FD) size info to infer size of sequence?
811
812 % -------------------------------
813
814 % THE CHOOSE operator (for TLA, recursive functions over sets,...)
815 % or choice operator from Abrial Book, page 60ff
816
817 :- use_module(kernel_reals,[is_interval_closure_or_realset/3, is_real/2]).
818 :- use_module(kernel_waitflags,[add_wd_error_span/4]).
819 :- use_module(b_global_sets,[b_integer_or_real_or_string_set/1]).
820 external_fun_type('CHOOSE',[X],[set(X),X]).
821 external_fun_has_wd_condition('CHOOSE').
822 expects_waitflag('CHOOSE').
823 expects_spaninfo('CHOOSE').
824 :- public 'CHOOSE'/4.
825 :- block 'CHOOSE'(-,?,?,?).
826 'CHOOSE'([],_,Span,WF) :- !,
827 add_wd_error_span('CHOOSE applied to empty set: ',[],Span,WF).
828 'CHOOSE'(CS,Res,_,_) :- is_interval_closure_or_integerset(CS,Low,Up), % TODO: also support reals
829 !,
830 choose_interval(Low,Up,H),Res=int(H).
831 'CHOOSE'([H|T],C,_Span,WF) :- T==[], !, kernel_objects:equal_object_optimized_wf(C,H,'CHOOSE',WF).
832 'CHOOSE'([H|T],C,Span,WF) :- !,
833 ground_value_check([H|T],Gr),
834 when(nonvar(Gr),
835 (convert_to_avl([H|T],AVL) -> 'CHOOSE'(AVL,C,Span,WF)
836 ; add_wd_error_span('Cannot determine minimum element for CHOOSE: ',[H|T],Span,WF),
837 kernel_objects:equal_object_wf(C,H,WF))
838 ).
839 'CHOOSE'(avl_set(A),H,_,WF) :- !, avl_min(A,Min), kernel_objects:equal_object_wf(H,Min,WF).
840 'CHOOSE'(global_set(GS),H,_,_) :- \+ b_integer_or_real_or_string_set(GS), !,
841 H = fd(1,GS). % assume GS not empty, integer sets covered above
842 'CHOOSE'(global_set('STRING'),H,_,_) :- !, H = string(''). % return empty string
843 'CHOOSE'(freetype(ID),H,Span,WF) :- !,
844 (kernel_freetypes:enumerate_freetype_wf(basic,FV,freetype(ID),WF)
845 -> kernel_objects:equal_object_wf(FV,H,WF)
846 ; add_internal_error('Could not generate freetype element: ','CHOOSE'(freetype(ID),H,Span,WF))).
847 'CHOOSE'(CS,H,Span,WF) :- custom_explicit_sets:is_cartesian_product_closure(CS,Set1,Set2),!,
848 'CHOOSE'(Set1,H1,Span,WF),
849 'CHOOSE'(Set2,H2,Span,WF),
850 kernel_objects:equal_object_wf(H,(H1,H2),WF).
851 'CHOOSE'(CS,Res,_,_) :- is_interval_closure_or_realset(CS,Low,Up), % TODO: also support reals
852 !,
853 choose_interval(Low,Up,H),
854 (H=0 -> is_real(Res,0.0) ; is_real(Res,H)).
855 'CHOOSE'(CS,H,Span,WF) :- is_custom_explicit_set(CS),
856 custom_explicit_sets:expand_custom_set_wf(CS,ER,'CHOOSE',WF),
857 'CHOOSE'(ER,H,Span,WF).
858
859 % choose a value from an interval; can be open interval and can be a real interval
860 :- block choose_interval(-,?,?).
861 choose_interval(Low,_Up,H) :- number(Low),!,H=Low.
862 choose_interval(_Low,Up,H) :- choose_interval2(Up,H). % lower-bound is minus infinity
863 :- block choose_interval2(-,?).
864 choose_interval2(Up,H) :- number(Up),!,H=Up. % for those intervals we choose Up
865 choose_interval2(_,0). % we have INTEGER or something equivalent with minus_inf,inf; simply choose 0
866
867 :- use_module(kernel_objects,[singleton_set_element/4, singleton_set_element_wd/4]).
868 external_fun_type('MU',[X],[set(X),X]).
869 external_fun_has_wd_condition('MU').
870 expects_waitflag('MU').
871 expects_spaninfo('MU').
872 :- public 'MU'/4.
873 'MU'(Set,Res,Span,WF) :-
874 singleton_set_element(Set,Res,Span,WF).
875
876 external_fun_type('MU_WD',[X],[set(X),X]).
877 external_fun_has_wd_condition('MU_WD').
878 expects_waitflag('MU_WD').
879 expects_spaninfo('MU_WD').
880 % a version of MU which propagates more strongly from result to input
881 % but may thus fail to generate WD errors; can be used for stronger constraint propagation if MU is known to be WD
882 :- public 'MU_WD'/4.
883 'MU_WD'(Set,Res,Span,WF) :-
884 singleton_set_element_wd(Set,Res,Span,WF).
885
886
887 % choose n elements from a set
888 % will currently fail without good error message when we cannot find enough solutions
889 external_fun_type('CHOOSE_n',[X],[integer,set(X),set(X)]).
890 external_fun_has_wd_condition('CHOOSE_n').
891 expects_waitflag('CHOOSE_n').
892 expects_spaninfo('CHOOSE_n').
893 expects_type('CHOOSE_n').
894 :- public 'CHOOSE_n'/6.
895 :- block 'CHOOSE_n'(-,?,?,?,?,?).
896 'CHOOSE_n'(int(Nr),Set,Result,set(Type),Span,WF) :-
897 ground_value_check(Set,GrSet),
898 choose_n_aux(Nr,GrSet,Set,Result,Type,Span,WF).
899
900 :- block 'choose_n_aux'(-,?,?,?,?,?,?),'choose_n_aux'(?,-,?,?,?,?,?).
901 choose_n_aux(Nr,_,Set,Result,Type,Span,WF) :-
902 generate_elements(Nr,Set,[],List,Type,Span,WF),
903 equal_object_wf(List,Result,WF).
904
905 % TODO: disable enumeration warnings when generating new elements
906 generate_elements(0,_,_,Res,_,_,_) :- !, Res=[].
907 generate_elements(Nr,Set,Acc,[H|T],Type,Span,WF) :-
908 init_wait_flags_with_call_stack(WF2,[operation_call('CHOOSE_n',[int(Nr)],Span)]),
909 check_element_of_wf(H,Set,WF2),
910 not_element_of_wf(H,Acc,WF2),
911 b_enumerate:b_enumerate_typed_values([H],[Type],WF2),
912 ground_wait_flags(WF2),
913 add_element_wf(H,Acc,Acc2,no_wf_available),
914 !,
915 N1 is Nr-1,
916 generate_elements(N1,Set,Acc2,T,Type,Span,WF).
917
918
919 % -----------------
920
921 % sort a set and generate a sequence
922 % external_fun_has_wd_condition('SORT'). SORT generates virtual time-out for infinite sets; but has no WD-condition
923 % important to remove wd_condition fact to allow b_compiler to pre-compute calls to SORT
924 expects_waitflag('SORT').
925 expects_spaninfo('SORT').
926 external_fun_type('SORT',[X],[set(X),seq(X)]).
927 :- public 'SORT'/4.
928 :- block 'SORT'(-,?,?,?).
929 'SORT'([],Res,_Span,_WF) :- !, Res=[].
930 'SORT'(CS,Res,_,WF) :- custom_explicit_sets:is_custom_explicit_set(CS),!,
931 expand_custom_set_to_list_wf(CS,ER,Done,'SORT',WF),
932 sort_aux(Done,ER,Res,WF).
933 'SORT'([H|T],Res,_,WF) :-
934 when(ground([H|T]),
935 (maplist(convert_to_avl_if_possible,[H|T],List),
936 sort(List,SList),sort_aux(done,SList,Res,WF))).
937
938 convert_to_avl_if_possible(H,Res) :- convert_to_avl(H,CH),!,Res=CH.
939 convert_to_avl_if_possible(H,H) :-
940 add_warning(external_functions,'Cannot guarantee order when sorting:',H).
941
942 :- block sort_aux(-,?,?,?).
943 sort_aux(_,ER,Res,_WF) :- convert_list_to_seq(ER,Res).
944
945 % construct a B sequence from a Prolog list
946 convert_list_to_seq(ER,Res) :- convert_list_to_seq(ER,1,Seq), equal_object_optimized(Seq,Res).
947
948 convert_list_to_seq([],_,[]).
949 convert_list_to_seq([H|T],N,[(int(N),H)|CT]) :- N1 is N+1, convert_list_to_seq(T,N1,CT).
950
951 % :- use_module(library(samsort),[samsort/3]).
952 % TO DO: version of SORT with samsort/3 and user provided sorting predicate
953
954 % Z Compaction / squash operator to fill up gaps in sequence
955 external_fun_has_wd_condition('SQUASH'). % needs to be a function
956 expects_waitflag('SQUASH').
957 external_fun_type('SQUASH',[X],[set(couple(integer,X)),seq(X)]). % input not necessarily proper sequence
958
959 :- use_module(kernel_z,[compaction/3]).
960 :- public 'SQUASH'/3.
961 'SQUASH'(Sequence,Value,WF) :- compaction(Sequence,Value,WF).
962
963 external_fun_has_wd_condition('REPLACE'). % needs to be a function
964 expects_waitflag('REPLACE').
965 expects_spaninfo('REPLACE').
966 external_fun_type('REPLACE',[X],[seq(X),seq(X),seq(X),set(seq(X))]).
967 % Replace a pattern by another pattern within a sequence
968 % Currently it also performs a squashing of its arguments and does not check if its argument is a function or sequence.
969 % REPLACE([a],[b],[a,c,a]) = { [b,c,a], [a,c,b] };
970 % REPLACE([a],[],[a,c,a]) = { [c,a], [a,c] };
971 % REPLACE([a,a],[],[a,c,a]) = { }
972 :- public 'REPLACE'/6.
973 :- block 'REPLACE'(-,?,?,?,?,?), 'REPLACE'(?,-,?,?,?,?), 'REPLACE'(?,?,-,?,?,?).
974 'REPLACE'(Pat,Replacement,InSequence,Res,Span,_WF) :-
975 ground_value_check((Pat,Replacement,InSequence),Gr),
976 replace_pat_aux(Gr,Pat,Replacement,InSequence,Res,Span).
977 :- block replace_pat_aux(-,?,?,?,?,?).
978 replace_pat_aux(_,Pat,Replacement,InSequence,Res,Span) :-
979 convert_to_sorted_seq_list(Pat,PL,Span),
980 convert_to_sorted_seq_list(Replacement,RL,Span),
981 convert_to_sorted_seq_list(InSequence,SL,Span),
982 findall(ResList,replace_pattern(PL,RL,SL,ResList),ResLists),
983 equal_object_optimized(ResLists,Res,'REPLACE').
984
985 % convert argument to avl list and then on to a list of elements without indices
986 convert_to_sorted_seq_list([],List,_Span) :- !, List=[].
987 convert_to_sorted_seq_list(Sequence,List,_Span) :-
988 convert_to_avl(Sequence,avl_set(AVL)),
989 custom_explicit_sets:get_avl_sequence(AVL,List),!.
990 convert_to_sorted_seq_list(Sequence,_,Span) :-
991 add_error(external_functions,'Cannot convert argument to finite sequences: ',Sequence,Span).
992
993 replace_pattern(Pat,Rep,Seq,ResBSequence) :- % Prefix.Pat.Post ---> Prefix.Rep.Post
994 append(Pat,Post,PatPost),
995 append(Rep,Post,RepPost),
996 append(Prefix,PatPost,Seq),
997 append(Prefix,RepPost,ResList),
998 convert_list_to_seq(ResList,ResBSequence).
999
1000
1001 % Prolog term order on encoding
1002 external_fun_type('LESS',[X],[X,X,boolean]).
1003 :- public 'LESS'/3.
1004 :- block 'LESS'(-,?,?), 'LESS'(?,-,?).
1005 'LESS'(string(A),string(B),Res) :- !, less2(A,B,Res).
1006 'LESS'(int(A),int(B),Res) :- !, less_clpfd(A,B,Res). % use CLPFD less ?
1007 'LESS'(fd(A,G),fd(B,G),Res) :- !, less_clpfd(A,B,Res).
1008 'LESS'(term(floating(A)),B,Res) :- !,
1009 kernel_reals:real_comp_wf('<',term(floating(A)),B,Res,no_wf_available).
1010 'LESS'(pred_false,B,Res) :- !, B=Res. % if B=pred_true then < , otherwise not
1011 'LESS'(pred_true,_,Res) :- !, Res=pred_false.
1012 % TO DO: expand finite closures, couples, avl_sets, ...
1013 'LESS'(X,Y,Res) :- when((ground(X),ground(Y)), less2(X,Y,Res)).
1014 % TO DO: use kernel_ordering,[ordered_value/2]).
1015
1016 :- use_module(clpfd_interface,[clpfd_leq_expr/2,clpfd_lt_expr/2]).
1017 :- block less_clpfd(-,?,-), less_clpfd(?,-,-).
1018 less_clpfd(A,B,Res) :- Res==pred_true, !, clpfd_lt_expr(A,B).
1019 less_clpfd(A,B,Res) :- Res==pred_false, !, clpfd_leq_expr(B,A).
1020 less_clpfd(A,B,Res) :- (A < B -> Res=pred_true ; Res=pred_false).
1021
1022
1023 :- block less2(-,?,?), less2(?,-,?).
1024 less2(A,B,Res) :- (A @< B -> Res=pred_true ; Res=pred_false).
1025
1026 :- use_module(kernel_ordering,[leq_ordered_value/3]).
1027
1028 :- public 'LEQ_SYM_BREAK'/4.
1029 expects_waitflag('LEQ_SYM_BREAK').
1030 external_fun_type('LEQ_SYM_BREAK',[X],[X,X,boolean]).
1031 'LEQ_SYM_BREAK'(A,B,Res,WF) :- 'LEQ_SYM'(A,B,Res,WF).
1032
1033 expects_waitflag('LEQ_SYM').
1034 external_fun_type('LEQ_SYM',[X],[X,X,boolean]).
1035 % true if arg1 <= arg2 according to Prolog term order; may return true for some symbolic representations
1036 % Note: it is sometimes ignored, e.g., by Kodkod or Z3 translation
1037 % Also: LEQ_SYM_BREAK / LEQ_SYM do not fully support all types yet, see sym_break_supported_type
1038 :- block 'LEQ_SYM'(-,?,?,?).
1039 'LEQ_SYM'(int(A),int(B),Res,_WF) :- !,
1040 b_interpreter_check:check_arithmetic_operator('<=',A,B,Res).
1041 'LEQ_SYM'(fd(A,G),fd(B,G),Res,_WF) :- !,
1042 b_interpreter_check:check_arithmetic_operator('<=',A,B,Res).
1043 'LEQ_SYM'(term(T),B,Res,WF) :- nonvar(T), T=floating(A), !,
1044 kernel_reals:real_comp_wf('=<',term(floating(A)),B,Res,WF).
1045 'LEQ_SYM'(pred_false,_,Res,_WF) :- !, Res=pred_true. % pred_false @< pred_true
1046 'LEQ_SYM'(pred_true,B,Res,_WF) :- !, Res=B. % if B=pred_true -> ok; otherwise Res=pred_false
1047 'LEQ_SYM'([],_,Res,_W) :- !, Res=pred_true. % the empty set is the smallest set
1048 'LEQ_SYM'(closure(_,_,_),_,Res,_) :- !, Res=pred_true. % otherwise we would have to expand it
1049 'LEQ_SYM'(global_set(_),_,Res,_) :- !, Res=pred_true. % ditto
1050 'LEQ_SYM'(X,Y,Res,WF) :- 'LEQ_SYM2'(X,Y,Res,WF).
1051
1052 :- block 'LEQ_SYM2'(?,-,?,?).
1053 %'LEQ_SYM'(X,Y,Res) :- print('LEQ_SYM'(X,Y,Res)),nl,fail.
1054 'LEQ_SYM2'(string(A),string(B),Res,_WF) :- !, less_eq2(A,B,Res).
1055 'LEQ_SYM2'(_,closure(_,_,_),Res,_WF) :- !, Res=pred_true. % we would have to expand it
1056 'LEQ_SYM2'(Set1,[],Res,WF) :- !, kernel_equality:empty_set_test_wf(Set1,Res,WF).
1057 'LEQ_SYM2'((A,B),(X,Y),Res,_WF) :- Res==pred_true,!, leq_ordered_value((A,B),(X,Y),_Equal).
1058 'LEQ_SYM2'(rec(FA),rec(FB),Res,_WF) :- Res==pred_true,!, leq_ordered_value(rec(FA),rec(FB),_Equal).
1059 % TODO: support sets, e.g., by comparing cardinality or minimal elements
1060 'LEQ_SYM2'(_A,_B,Res,_WF) :- Res=pred_true.
1061 %'LEQ_SYM2'(X,Y,Res,_WF) :- when((ground(X),ground(Y)), less_eq2(X,Y,Res)). % unsafe to use; we should normalize AVLs ...
1062 % TO DO: use kernel_ordering:leq_ordered_value/2 more or use lex_chain([[X,X],[Y,Z]],[op(#=<)]) for pairs/records of FD values
1063 % Note: it is reified in b_interpreter_check
1064
1065 :- block less_eq2(-,?,?), less_eq2(?,-,?).
1066 less_eq2(A,B,Res) :- (A @=< B -> Res=pred_true ; Res=pred_false).
1067
1068 % -------------------------------
1069
1070 % was a first prototype for implementing recursive functions
1071 % was still a bit clumsy to define recursive functions (using STRING parameter for names)
1072 % a restriction is that we can only have one version per machine, i.e.
1073 % one can only define recursive function in the CONSTANTS section and only
1074 % in a deterministic fashion not depending on enumerated constants,...
1075 % we now use generate_recursive_closure in b_interpreter for recursive_let/2 constructs
1076 %:- dynamic recursive_function/2.
1077 %expects_waitflag('REC'). % DEPRECATED
1078 %expects_spaninfo('RECx'). % DEPRECATED
1079 %expects_spaninfo('REC_LET'). % DEPRECATED
1080
1081
1082 reset_external_functions :-
1083 retractall(last_walltime(_)),
1084 reset_ident,
1085 reset_kodkod,
1086 reset_observe,
1087 reset_external_libraries,
1088 close_all_files.
1089
1090 :- use_module(eventhandling,[register_event_listener/3]).
1091 :- register_event_listener(clear_specification,reset_external_functions,
1092 'Reset B External Functions.').
1093
1094 print_external_function_instantiation_profile :-
1095 %TODO: we could register number of external function calls, ..
1096 portray_instantiations.
1097
1098
1099 % -------------------------------
1100
1101 expects_waitflag('FORCE').
1102 external_fun_type('FORCE',[T],[T,T]).
1103 :- public 'FORCE'/3.
1104 % example usage halve = FORCE( %x.(x:0..1000 & x mod 2 = 0 | x/2))
1105 :- block 'FORCE'(-,?,?).
1106 %'FORCE'(A,B,_) :- print(force(A)),nl,fail.
1107 'FORCE'(avl_set(A),Result,_) :- !, equal_object(avl_set(A),Result).
1108 'FORCE'([],Result,_) :- !, equal_object([],Result).
1109 'FORCE'(closure(P,T,B),Result,WF) :- !,
1110 (debug:debug_mode(on) -> print('FORCING : '),translate:print_bvalue(closure(P,T,B)),nl ; true),
1111 custom_explicit_sets:expand_closure_to_avl_or_list(P,T,B,ExpandedValue,no_check,WF),
1112 (debug:debug_mode(on) -> print('RESULT : '),translate:print_bvalue(ExpandedValue),nl,
1113 print(' ASSIGNING TO : '), translate:print_bvalue(Result),nl
1114 ; true),
1115 equal_object(ExpandedValue,Result).
1116 'FORCE'((A,B),(FA,FB),WF) :- !,'FORCE'(A,FA,WF), 'FORCE'(B,FB,WF).
1117 % TO DO: treat lists and records ...
1118 'FORCE'(A,B,_) :- equal_object_optimized(A,B,'FORCE').
1119
1120 % -----------------------------------------
1121
1122 :- use_module(tools, [read_term_from_file/2]).
1123 :- use_module(typing_tools, [check_type_of_value/2]).
1124
1125 expects_spaninfo('READ_PROB_DATA_FILE').
1126 expects_type('READ_PROB_DATA_FILE').
1127 external_fun_type('READ_PROB_DATA_FILE',[T],[set(T),string,T]).
1128 :- public 'READ_PROB_DATA_FILE'/5.
1129 :- block 'READ_PROB_DATA_FILE'(-,?,?,?,?), 'READ_PROB_DATA_FILE'(?,-,?,?,?).
1130 'READ_PROB_DATA_FILE'(_,string(File),Expr,Type,Span) :- % first arg provides type info
1131 read_prob_data_file(File,Expr,Type,Span).
1132
1133 :- use_module(tools,[start_ms_timer/1, stop_ms_timer_with_debug_msg/2]).
1134
1135 :- block read_prob_data_file(-,?,?,?).
1136 read_prob_data_file(File,ResExpr,Type,Span) :-
1137 b_absolute_file_name(File,AFile,Span),
1138 start_ms_timer(T),
1139 safe_call(read_term_from_file(AFile,Expr),Span), % can also be in fastrw format
1140 stop_ms_timer_with_debug_msg(T,'read PROB_DATA file'),
1141 (check_type_of_value(Type,Expr) -> ResExpr=Expr
1142 ; pretty_type(Type,TS),
1143 ajoin(['Type of B value does not match expected type ',TS,' in data file:'],Msg),
1144 add_error('READ_PROB_DATA_FILE',Msg,File,Span),
1145 fail).
1146
1147
1148
1149 % -----------------------------------------
1150
1151 :- public 'ENUM'/2.
1152 % example usage: ENUM((x,y)) : AVLSet
1153 % external function used for deriving info field annotations in ast_cleanup
1154 'ENUM'(Obj,Obj).
1155
1156 % -----------------------------------------
1157
1158 expects_unevaluated_args('DO_NOT_ENUMERATE').
1159 :- public 'DO_NOT_ENUMERATE'/3.
1160 :- block 'DO_NOT_ENUMERATE'(-,?,?).
1161 'DO_NOT_ENUMERATE'((A,B),PredRes,UEA) :- !, 'DO_NOT_ENUMERATE'(A,PredRes,UEA),'DO_NOT_ENUMERATE'(B,PredRes,UEA).
1162 'DO_NOT_ENUMERATE'(fd(V,_),PredRes,UEA) :- !, 'DO_NOT_ENUMERATE'(V,PredRes,UEA).
1163 'DO_NOT_ENUMERATE'(int(V),PredRes,UEA) :- !, 'DO_NOT_ENUMERATE'(V,PredRes,UEA).
1164 'DO_NOT_ENUMERATE'(string(V),PredRes,UEA) :- !, 'DO_NOT_ENUMERATE'(V,PredRes,UEA).
1165 'DO_NOT_ENUMERATE'(_Obj,PredRes,_UEA) :-
1166 %print('INSTANTIATED: '),nl, _UEA=[UnEvalArg],translate:print_bexpr(UnEvalArg),nl, print(_Obj),nl,
1167 PredRes=pred_true.
1168 % add_message('DO_NOT_ENUMERATE','Enumerating: ',UnEvalArgs).
1169
1170 % a utility to avoid propagation of values, can be used as "enumeration barrier"
1171 expects_waitflag('COPY').
1172 :- public 'COPY'/3.
1173 :- block 'COPY'(-,?,?).
1174 'COPY'(Val,Result,WF) :- ground_value_check(Val,GrVal),
1175 when(nonvar(GrVal),equal_object_optimized_wf(Val,Result,'COPY',WF)).
1176
1177
1178 % -------------------------------
1179
1180 :- assert_must_succeed(( external_functions:call_external_function('STRING_APPEND',[a,b],[string(a),string(b)],string(ab),string,unknown,_WF) )).
1181 % STRING MANIPULATION FUNCTIONS
1182
1183 :- use_module(kernel_strings,[b_string_append_wf/4, b_concat_sequence_of_strings_wf/4, b_string_reverse_wf/3,
1184 b_string_chars/2, b_string_codes/2, b_string_length/2,
1185 b_string_to_uppercase/2, b_string_to_lowercase/2]).
1186
1187 % function to append two strings, reversible
1188 external_fun_can_be_inverted('STRING_APPEND').
1189 expects_waitflag('STRING_APPEND').
1190 external_fun_type('STRING_APPEND',[],[string,string,string]).
1191 :- public 'STRING_APPEND'/4.
1192 'STRING_APPEND'(A,B,C,WF) :- b_string_append_wf(A,B,C,WF).
1193
1194 % function to append two strings, reversible
1195 external_fun_can_be_inverted('STRING_REV').
1196 expects_waitflag('STRING_REV').
1197 external_fun_type('STRING_REV',[],[string,string]).
1198 :- public 'STRING_REV'/3.
1199 'STRING_REV'(A,B,WF) :- b_string_reverse_wf(A,B,WF).
1200
1201 expects_waitflag('STRING_CONC').
1202 expects_spaninfo('STRING_CONC').
1203 external_fun_type('STRING_CONC',[],[seq(string),string]).
1204 :- public 'STRING_CONC'/4.
1205 :- block 'STRING_CONC'(-,?,?,?).
1206 % the conc(.) operator is mapped to this for strings (instead to concat_sequence)
1207 'STRING_CONC'(List,Res,Span,WF) :-
1208 b_concat_sequence_of_strings_wf(List,Res,Span,WF).
1209
1210 external_fun_can_be_inverted('STRING_CHARS').
1211 external_fun_type('STRING_CHARS',[],[string,seq(string)]).
1212 :- public 'STRING_CHARS'/2.
1213 'STRING_CHARS'(Str,SeqOfChars) :- b_string_chars(Str,SeqOfChars).
1214 /* Note: STRING_CONC can be used as inverse to combine the chars */
1215
1216 external_fun_can_be_inverted('CODES_TO_STRING').
1217 external_fun_type('CODES_TO_STRING',[],[seq(integer),string]).
1218 :- public 'CODES_TO_STRING'/2.
1219 'CODES_TO_STRING'(A,SeqRes) :- 'STRING_CODES'(SeqRes,A).
1220
1221 external_fun_can_be_inverted('STRING_CODES').
1222 external_fun_type('STRING_CODES',[],[string,seq(integer)]).
1223 :- public 'STRING_CODES'/2.
1224 'STRING_CODES'(A,SeqRes) :- b_string_codes(A,SeqRes).
1225
1226
1227 external_fun_type('STRING_TO_UPPER',[],[string,string]).
1228 :- public 'STRING_TO_UPPER'/2.
1229 'STRING_TO_UPPER'(S,S2) :- b_string_to_uppercase(S,S2).
1230 external_fun_type('STRING_TO_LOWER',[],[string,string]).
1231 :- public 'STRING_TO_LOWER'/2.
1232 'STRING_TO_LOWER'(S,S2) :- b_string_to_lowercase(S,S2).
1233
1234 :- use_module(kernel_strings,[b_string_equal_case_insensitive/3]).
1235 external_fun_type('STRING_EQUAL_CASE_INSENSITIVE',[],[string,string,boolean]).
1236 :- public 'GET_STRING_EQUAL_CASE_INSENSITIVE'/3.
1237 'STRING_EQUAL_CASE_INSENSITIVE'(S1,S2,Res) :- b_string_equal_case_insensitive(S1,S2,Res).
1238
1239 :- assert_must_succeed(( external_functions:call_external_function('STRING_LENGTH',[a],[string(a)],int(1),integer,unknown,_WF) )).
1240 % function to get length of a string
1241 external_fun_type('STRING_LENGTH',[],[string,integer]).
1242 :- public 'STRING_LENGTH'/2.
1243 'STRING_LENGTH'(S,L) :- b_string_length(S,L).
1244
1245 :- use_module(kernel_strings,[b_string_split_wf/4, b_string_join_wf/5]).
1246
1247 % function to split a string into a list of strings which were delimited by a separator
1248 % WARNING: if the seperator is of length more than one, then first match-strategy will be used
1249 external_fun_can_be_inverted('STRING_SPLIT').
1250 expects_waitflag('STRING_SPLIT').
1251 external_fun_type('STRING_SPLIT',[],[string,string,seq(string)]). % actually seq1(string)
1252 :- public 'STRING_SPLIT'/4.
1253 'STRING_SPLIT'(Str,Sep,Strings,WF) :- b_string_split_wf(Str,Sep,Strings,WF).
1254
1255 :- public 'STRING_JOIN'/5.
1256 expects_waitflag('STRING_JOIN').
1257 expects_spaninfo('STRING_JOIN').
1258 external_fun_type('STRING_JOIN',[],[seq(string),string,string]).
1259 'STRING_JOIN'(SplitAtoms,Sep,Res,Span,WF) :- b_string_join_wf(SplitAtoms,Sep,Res,Span,WF).
1260
1261
1262 expects_waitflag('STRING_CONTAINS_STRING').
1263 external_fun_type('STRING_CONTAINS_STRING',[],[string,string,boolean]).
1264 % TRUE when arg2 occurs as contiguous substring in arg1
1265 :- public 'STRING_CONTAINS_STRING'/4.
1266 :- block 'STRING_CONTAINS_STRING'(-,?,?,?), 'STRING_CONTAINS_STRING'(?,-,?,?).
1267 'STRING_CONTAINS_STRING'(string(A),string(B),PredRes,_WF) :-
1268 string_contains_string_aux(A,B,PredRes).
1269 :- use_module(library(lists),[sublist/5]).
1270 % TO DO: we could enumerate B if A known and waitflag instantiated
1271 :- block string_contains_string_aux(-,?,?),string_contains_string_aux(?,-,?).
1272 string_contains_string_aux(A,B,PredRes) :-
1273 atom_codes(A,ACodes),
1274 atom_codes(B,BCodes),
1275 ? (sublist(ACodes,BCodes,_,_,_) -> PredRes=pred_true ; PredRes=pred_false).
1276
1277 :- use_module(kernel_strings,[b_substring_wf/6]).
1278 :- public 'SUB_STRING'/6.
1279 expects_spaninfo('SUB_STRING').
1280 expects_waitflag('SUB_STRING').
1281 external_fun_type('SUB_STRING',[],[string,integer,integer,string]).
1282 'SUB_STRING'(S,From,Len,Res,Span,WF) :- b_substring_wf(S,From,Len,Res,Span,WF).
1283
1284
1285 :- use_module(kernel_strings,[b_string_replace/4]).
1286 :- public 'STRING_REPLACE'/4.
1287 external_fun_type('STRING_REPLACE',[],[string,string,string,string]).
1288 'STRING_REPLACE'(S,Pat,New,Res) :- b_string_replace(S,Pat,New,Res).
1289
1290
1291 :- use_module(probsrc(kernel_freetypes), [get_freetype_id/2, get_freeval_type/3, registered_freetype_case_value/3]).
1292 :- use_module(probsrc(translate), [pretty_type/2]).
1293 :- use_module(probsrc(btypechecker), [unify_types_werrors/4]).
1294
1295 external_fun_type('STRING_IS_FREETYPE',[],[string,boolean]).
1296 :- public 'STRING_IS_FREETYPE'/2.
1297 :- block 'STRING_IS_FREETYPE'(-,?).
1298 'STRING_IS_FREETYPE'(string(ID),Res) :-
1299 get_freeval_type(_,ID,_) -> Res=pred_true ; Res=pred_false.
1300
1301 external_fun_has_wd_condition('STRING_TO_FREETYPE').
1302 external_fun_type('STRING_TO_FREETYPE',[F],[string,F]). % F is freetype case
1303 expects_type('STRING_TO_FREETYPE').
1304 expects_spaninfo('STRING_TO_FREETYPE').
1305 :- public 'STRING_TO_FREETYPE'/4.
1306 :- block 'STRING_TO_FREETYPE'(-,?,?,?).
1307 'STRING_TO_FREETYPE'(string(ID),Value,Type,Span) :-
1308 string_to_freetype2(ID,Value,Type,Span).
1309
1310 :- block string_to_freetype2(-,?,?,?).
1311 string_to_freetype2(ID,Value,Type,Span) :-
1312 get_freetype_id(Type,FreetypeId), !, % checks implicitly that Type is freetype
1313 check_is_freetype_case(FreetypeId,ID,ArgType,Span),
1314 (Type = set(couple(_,freetype(_)))
1315 -> ExpectedType = set(couple(ArgType,freetype(FreetypeId)))
1316 ; ExpectedType = freetype(FreetypeId)
1317 ),
1318 unify_types_werrors(ExpectedType,Type,Span,'STRING_TO_FREETYPE'),
1319 (registered_freetype_case_value(ID,Type,Value) -> true
1320 ; add_error('STRING_TO_FREETYPE','error while accessing case value:',ID,Span)
1321 ).
1322 string_to_freetype2(ID,_,Type,Span) :-
1323 (nonvar(ID) -> pretty_type(Type,TS),
1324 add_error('STRING_TO_FREETYPE','STRING_TO_FREETYPE: Type mismatch: expected FREETYPE or FREETYPE case function (T <-> FREETYPE), but was',TS,Span)
1325 ; add_error('STRING_TO_FREETYPE','STRING_TO_FREETYPE cannot be inverted',ID,Span)),
1326 fail.
1327
1328 :- block check_is_freetype_case(?,-,?,?).
1329 check_is_freetype_case(FreetypeId,ID,ArgType,_) :- get_freeval_type(FreetypeId,ID,ArgType), !.
1330 check_is_freetype_case(_,ID,_,Span) :-
1331 add_error('STRING_TO_FREETYPE','STRING_TO_FREETYPE: no FREETYPE case found for string',ID,Span),
1332 fail.
1333
1334
1335 external_fun_has_wd_condition('TYPED_STRING_TO_ENUM').
1336 expects_waitflag('TYPED_STRING_TO_ENUM').
1337 expects_spaninfo('TYPED_STRING_TO_ENUM').
1338 external_fun_type('TYPED_STRING_TO_ENUM',[T],[set(T),string,T]).
1339 :- public 'TYPED_STRING_TO_ENUM'/5.
1340 :- block 'TYPED_STRING_TO_ENUM'(?,-,-,?,?),'TYPED_STRING_TO_ENUM'(-,?,?,?,?).
1341 'TYPED_STRING_TO_ENUM'(Type,string(S),Res,Span,WF) :-
1342 string_to_enum2(S,fd(Nr,GS),_,Span),
1343 check_type(Type,S,Nr,GS,Res,Span,WF).
1344
1345 :- block check_type(-,?,?, ?,?,?,?), check_type(?,-,?, ?,?,?,?), check_type(?,?,-, ?,?,?,?).
1346 check_type(GSTypeExpr,S,Nr,GS,Res,Span,WF) :-
1347 get_global_set_value_type(GSTypeExpr,'TYPED_STRING_TO_ENUM',ExpectedGS),
1348 ExpectedGS=GS,
1349 !,
1350 membership_test_wf(GSTypeExpr,fd(Nr,GS),MemTest,WF),
1351 check_value(MemTest,Nr,GS,Res,S,GSTypeExpr,Span,WF).
1352 check_type(GSTypeExpr,S,_,GS,_,Span,WF) :-
1353 get_global_set_value_type(GSTypeExpr,'TYPED_STRING_TO_ENUM',ExpectedGS),
1354 ajoin(['String value ',S,' is of type ',GS,' and not of expected type:'],Msg),
1355 add_wd_error_span(Msg,ExpectedGS,Span,WF).
1356
1357 :- block check_value(-,?,?,?,?,?,?,?).
1358 check_value(pred_true,Nr,GS,Res,_,_,_,_) :- !, Res=fd(Nr,GS).
1359 check_value(pred_false,_,_GS,_,S,GSTypeExpr,Span,WF) :-
1360 ajoin(['String value ',S,' is of correct type but not in set:'],Msg),
1361 translate:translate_bvalue(GSTypeExpr,SetStr),
1362 add_wd_error_span(Msg,SetStr,Span,WF).
1363
1364 % get type of a set of enumerated/deferred set elements
1365 get_global_set_value_type(global_set(GS),_,Res) :- !, Res=GS.
1366 get_global_set_value_type([fd(_,GS)|_],_,Res) :- !, Res=GS.
1367 get_global_set_value_type(avl_set(node(fd(_,GS),_True,_,_,_)),_,Res) :- !, Res=GS.
1368 get_global_set_value_type(Val,Source,_) :- translate:translate_bvalue(Val,VS),
1369 add_error(Source,'First argument of illegal type, it must be a set of deferred or enumerated set elements:',VS),fail.
1370
1371 :- use_module(probsrc(translate), [pretty_type/2]).
1372
1373 external_fun_can_be_inverted('STRING_TO_ENUM').
1374 external_fun_has_wd_condition('STRING_TO_ENUM').
1375 external_fun_type('STRING_TO_ENUM',[G],[string,G]). % G is enumerated set
1376 expects_type('STRING_TO_ENUM').
1377 expects_spaninfo('STRING_TO_ENUM').
1378 :- public 'STRING_TO_ENUM'/4.
1379 :- block 'STRING_TO_ENUM'(-,-,?,?).
1380 'STRING_TO_ENUM'(string(S),FD,global(Type),Span) :- !, string_to_enum2(S,FD,Type,Span).
1381 'STRING_TO_ENUM'(_,_,Type,Span) :- pretty_type(Type,TS),
1382 add_error('STRING_TO_ENUM','Illegal type for STRING_TO_ENUM (requires a SET type): ',TS,Span),fail.
1383
1384 :- block string_to_enum2(-,-,?,?).
1385 string_to_enum2(S,Res,Type,Span) :- nonvar(S),!,
1386 (b_global_sets:lookup_global_constant(S,FD),
1387 FD = fd(_,GS)
1388 -> check_type_aux(Type,GS,S,Span),
1389 Res=FD % fd(Nr,GS)
1390 ; % TO DO: use add_wd_error_set_result
1391 add_error('STRING_TO_ENUM','Could not convert string to enumerated set element: ',S,Span),fail).
1392 string_to_enum2(S,fd(Nr,GS),Type,Span) :-
1393 string_to_enum3(S,Nr,GS,Type,Span).
1394
1395
1396 check_type_aux(Type,GS,S,Span) :- Type \= GS,!,
1397 ajoin(['String value "',S,'" has illegal type ',GS,', expected: '],Msg),
1398 add_error('STRING_TO_ENUM',Msg,Type,Span),
1399 fail.
1400 check_type_aux(_,_,_,_).
1401
1402 :- block string_to_enum3(-,-,?,?,?),string_to_enum3(-,?,-,?,?).
1403 string_to_enum3(S,Nr,GS,Type,Span) :- nonvar(S),!,
1404 (b_global_sets:lookup_global_constant(S,fd(SNr,SGS))
1405 -> check_type_aux(Type,SGS,S,Span),
1406 (SGS,SNr) = (GS,Nr)
1407 ; add_error('STRING_TO_ENUM','Could not convert string to enumerated set element: ',S,Span),fail).
1408 string_to_enum3(S,Nr,GS,_,Span) :-
1409 (b_global_sets:is_b_global_constant_hash(GS,Nr,GNS)
1410 -> GNS=S
1411 ; add_error('STRING_TO_ENUM','Could not convert deferred set element to string: ',GS:Nr,Span),fail).
1412
1413 :- use_module(kernel_strings,[b_string_is_int/2]).
1414 external_fun_type('STRING_IS_INT',[],[string,boolean]).
1415 :- public 'GET_STRING_IS_INT'/2.
1416 'STRING_IS_INT'(S,Res) :- b_string_is_int(S,Res).
1417
1418 :- use_module(kernel_strings,[b_string_is_number/2]).
1419 external_fun_type('STRING_IS_NUMBER',[],[string,boolean]).
1420 :- public 'GET_STRING_IS_NUMBER'/2.
1421 'STRING_IS_NUMBER'(S,Res) :- b_string_is_number(S,Res).
1422
1423 :- use_module(kernel_strings,[b_string_is_decimal/2]).
1424 external_fun_type('STRING_IS_DECIMAL',[],[string,boolean]).
1425 :- public 'GET_STRING_IS_DECIMAL'/2.
1426 'STRING_IS_DECIMAL'(S,Res) :- b_string_is_decimal(S,Res).
1427
1428 external_fun_type('STRING_IS_ALPHANUMERIC',[],[string,boolean]).
1429 :- use_module(kernel_strings,[b_string_is_alphanumerical/2]).
1430 :- public 'GET_STRING_IS_ALPHANUMERIC'/2.
1431 'STRING_IS_ALPHANUMERIC'(X,Res) :- b_string_is_alphanumerical(X,Res).
1432
1433 % synonyms as use for functions to BOOL rather than predicates
1434 'GET_STRING_EQUAL_CASE_INSENSITIVE'(S1,S2,Res) :- 'STRING_EQUAL_CASE_INSENSITIVE'(S1,S2,Res).
1435 'GET_STRING_IS_ALPHANUMERIC'(S,Res) :- 'STRING_IS_ALPHANUMERIC'(S,Res).
1436 'GET_STRING_IS_DECIMAL'(S,Res) :- 'STRING_IS_DECIMAL'(S,Res).
1437 'GET_STRING_IS_NUMBER'(S,Res) :- 'STRING_IS_NUMBER'(S,Res).
1438 'GET_STRING_IS_INT'(S,Res) :- 'STRING_IS_INT'(S,Res).
1439
1440 % A Utility to convert Decimal Strings to Integers
1441 % TO DO: make a more precise version using just integers: currently DEC_STRING_TO_INT("1024.235",2) = 102423 !
1442 external_fun_has_wd_condition('DEC_STRING_TO_INT').
1443 expects_spaninfo('DEC_STRING_TO_INT').
1444 expects_waitflag('DEC_STRING_TO_INT').
1445 external_fun_type('DEC_STRING_TO_INT',[],[string,integer,integer]).
1446
1447 :- assert_must_succeed((atom_codes(A,"1024"),
1448 external_functions:'DEC_STRING_TO_INT'(string(A),int(0),int(1024),unknown,no_wf_available))).
1449 :- assert_must_succeed((atom_codes(A,"1024.1"),
1450 external_functions:'DEC_STRING_TO_INT'(string(A),int(1),int(10241),unknown,no_wf_available))).
1451 :- public 'DEC_STRING_TO_INT'/5.
1452 :- block 'DEC_STRING_TO_INT'(-,?,?,?,?),'DEC_STRING_TO_INT'(?,-,?,?,?).
1453 'DEC_STRING_TO_INT'(string(S),int(Precision),int(Res),Span,WF) :-
1454 dec_str_to_int(S,Precision,Res,Span,WF).
1455
1456 :- use_module(tools,[split_chars/3]).
1457 :- block dec_str_to_int(-,?,?,?,?),dec_str_to_int(?,-,?,?,?).
1458 dec_str_to_int(S,Precision,Res,Span,WF) :-
1459 atom_codes(S,Codes),
1460 split_chars(Codes,".",[Left|T]),
1461 (T=[] -> Right="", dec_str_to_int2(Left,Right,Precision,Res,Span,WF)
1462 ; T = [Right] -> dec_str_to_int2(Left,Right,Precision,Res,Span,WF)
1463 ; %add_error(external_functions,'Expecting integer or decimal number:',S,Span),fail
1464 add_wd_error_span('String contains multiple dots, expecting integer or decimal number for DEC_STRING_TO_INT:',S,Span,WF)
1465 ).
1466
1467
1468 get_sign([45|T],-1,Res) :- !,strip_ws(T,Res).
1469 get_sign([32|T],PosNeg,Res) :- !, get_sign(T,PosNeg,Res).
1470 get_sign(L,1,L).
1471 strip_ws([32|T],R) :- !, strip_ws(T,R).
1472 strip_ws(R,R).
1473
1474 ?rounding([H|_]) :- member(H,"56789").
1475
1476 is_zero(48). % code of 0
1477 is_digit(Code) :- Code >= 48, Code =< 57.
1478 check_digits(Codes,_,_,Res) :- maplist(is_digit,Codes),!,Res=ok.
1479 check_digits(Codes,Span,WF,ko) :-
1480 append([39|Codes],[39],C2), atom_codes(A,C2), % generate atom with quotes
1481 %add_error(external_functions,'Illegal number: ',A,Span),fail.
1482 add_wd_error_span('String contains illegal characters, expecting integer or decimal number for DEC_STRING_TO_INT:',A,Span,WF).
1483
1484 dec_safe_number_codes(Number,[],_,_) :- !, Number=0.
1485 dec_safe_number_codes(Number,Codes,Span,WF) :-
1486 (safe_number_codes(Nr,Codes) -> Number=Nr
1487 ; append([39|Codes],[39],C2), atom_codes(A,C2),
1488 %add_error(external_functions,'Cannot convert to number: ',A,Span),fail
1489 add_wd_error_span('Cannot convert string to number for DEC_STRING_TO_INT:',A,Span,WF),
1490 Number='$WDERROR$'
1491 ).
1492
1493 dec_str_to_int2(Left,Right,Precision,Res,Span,WF) :-
1494 maplist(is_zero,Right), Precision >= 0,
1495 !,
1496 dec_safe_number_codes(LeftNumber,Left,Span,WF),
1497 (LeftNumber=='$WDERROR$' -> true
1498 ; safe_is('DEC_STRING_TO_INT',Res,LeftNumber*(10^Precision),Span,WF)).
1499 dec_str_to_int2(Left,Right,Precision,Res,Span,WF) :- get_sign(Left,Sign,NewLeft),
1500 check_digits(NewLeft,Span,WF,Res1), check_digits(Right,Span,WF,Res2),
1501 (Res1==ok,Res2==ok
1502 -> shift(Precision,NewLeft,Right,ResL,ResR),
1503 dec_safe_number_codes(LeftInteger,ResL,Span,WF),
1504 ? (rounding(ResR)
1505 -> Res is Sign*(LeftInteger+1)
1506 ; Res is Sign*LeftInteger)
1507 ; true).
1508
1509 :- use_module(library(lists),[append_length/4]).
1510 % shift decimal values left or right depending on precision argument
1511 shift(0,Left,Right,Left,Right) :- !.
1512 shift(Pos,Left,Right,ResL,ResR) :- Pos>0,!,
1513 append(Left,Left2,ResL),
1514 length(Right,RLen),
1515 (RLen >= Pos -> append_length(Left2,ResR,Right,Pos) % take first Pos elements from R and shift left of .
1516 ; append(Right,Zeros,Left2), % take all of Right and add Zeros
1517 ResR = [],
1518 NrZeros is Pos - RLen,
1519 length(Zeros,NrZeros), maplist(is_zero,Zeros)
1520 ).
1521 shift(Pos,Left,Right,ResL,ResR) :- % Pos < 0
1522 length(Left,LLen), PPos is -Pos,
1523 (LLen >= PPos
1524 -> Shift is LLen-PPos, append_length(ResL,L2,Left,Shift), append(L2,Right,ResR)
1525 ; %Result always 0.0...
1526 NrZeros is PPos - LLen,length(Zeros,NrZeros), maplist(is_zero,Zeros),
1527 ResL = "0",
1528 append(Zeros,LR,ResR),
1529 append(Left,Right,LR)).
1530
1531 :- public 'STRING_PADLEFT'/6.
1532 external_fun_has_wd_condition('STRING_PADLEFT'). % PadChar must be string of length 1
1533 expects_waitflag('STRING_PADLEFT').
1534 expects_spaninfo('STRING_PADLEFT').
1535 external_fun_type('STRING_PADLEFT',[],[string,integer,string,string]).
1536 :- block 'STRING_PADLEFT'(-,?,?,?,?,?),'STRING_PADLEFT'(?,-,?,?,?,?),'STRING_PADLEFT'(?,?,-,?,?,?).
1537 'STRING_PADLEFT'(string(S),int(Width),string(PadChar),Res,Span,WF) :-
1538 string_pad_left(S,Width,PadChar,Res,Span,WF).
1539
1540 :- block string_pad_left(-,?,?,?,?,?),string_pad_left(?,-,?,?,?,?),string_pad_left(?,?,-,?,?,?).
1541 string_pad_left(_S,_Width,PadChar,_Res,Span,WF) :-
1542 atom_length(PadChar,Len), Len \= 1,
1543 !,
1544 add_wd_error_span('STRING_PADLEFT requires padding string of length 1: ',PadChar,Span,WF).
1545 string_pad_left(S,Width,PadChar,Res,_Span,_WF) :-
1546 atom_length(S,Len),
1547 (Len >= Width % no padding necessary
1548 -> Res = string(S)
1549 ; ToPad is Width-Len,
1550 atom_codes(PadChar,[PadCode]),
1551 atom_codes(S,Codes),
1552 pad_char(ToPad,PadCode,PaddedCodes,Codes),
1553 atom_codes(ResStr,PaddedCodes),
1554 Res = string(ResStr)
1555 ).
1556
1557 pad_char(0,_,Res,Tail) :- !, Res=Tail.
1558 pad_char(Nr,Code,[Code|TR],Tail) :- N1 is Nr-1, pad_char(N1,Code,TR,Tail).
1559
1560
1561
1562
1563 :- use_module(kernel_strings,[b_string_to_int_wf/4]).
1564 external_fun_has_wd_condition('STRING_TO_INT').
1565 expects_waitflag('STRING_TO_INT').
1566 expects_spaninfo('STRING_TO_INT').
1567 external_fun_type('STRING_TO_INT',[],[string,integer]).
1568 :- public 'STRING_TO_INT'/4.
1569 :- block 'STRING_TO_INT'(-,-,?,?).
1570 'STRING_TO_INT'(S,I,Span,WF) :- b_string_to_int_wf(S,I,Span,WF).
1571
1572
1573 :- use_module(kernel_strings,[int_to_b_string/2]).
1574 external_fun_type('INT_TO_STRING',[],[integer,string]).
1575 :- public 'INT_TO_STRING'/2.
1576 'INT_TO_STRING'(I,S) :- int_to_b_string(I,S).
1577
1578 :- use_module(kernel_strings,[int_to_dec_b_string/3, real_to_dec_b_string/4]).
1579 external_fun_type('INT_TO_DEC_STRING',[],[integer,integer,string]).
1580 :- public 'INT_TO_DEC_STRING'/3.
1581 'INT_TO_DEC_STRING'(I,Precision,S) :- int_to_dec_b_string(I,Precision,S).
1582
1583 external_fun_type('REAL_TO_DEC_STRING',[],[real,integer,string]).
1584 expects_spaninfo('REAL_TO_DEC_STRING').
1585 :- public 'REAL_TO_DEC_STRING'/4.
1586 'REAL_TO_DEC_STRING'(R,Precision,S,Span) :- real_to_dec_b_string(R,Precision,S,Span).
1587
1588 :- use_module(tools,[safe_read_term_from_atom/2]).
1589 % only for internal use in XTL mode! (used in execute by predicate to pass terms as parameters in a B predicate)
1590 external_fun_type('STRING_TO_TERM',[],[string,string]).
1591 :- public 'STRING_TO_TERM'/2.
1592 :- block 'STRING_TO_TERM'(-,?).
1593 'STRING_TO_TERM'(string(S),Res) :- !, Res = term(Term),
1594 safe_read_term_from_atom(S,Term).
1595 'STRING_TO_TERM'(Obj,_) :-
1596 add_error(external_functions,'Illegal type for STRING_TO_TERM, only accepts strings:',Obj),
1597 fail.
1598
1599
1600 :- use_module(kernel_strings,[to_b_string_with_type/3,to_b_string_with_type_and_options/4,format_to_b_string/3,format_to_b_string_with_type/4]).
1601 external_fun_type('TO_STRING',[X],[X,string]).
1602 expects_waitflag('TO_STRING').
1603 expects_spaninfo('TO_STRING').
1604 expects_unevaluated_args('TO_STRING').
1605 :- public 'TO_STRING'/5.
1606 'TO_STRING'(Value,S,[TExpr],Span,WF) :-
1607 get_large_finite_wait_flag(to_string,WF,AWF), %get_enumeration_finished_wait_flag(WF,AWF),
1608 tostring6(Value,TExpr,S,Span,WF,AWF).
1609
1610 :- block tostring6(-,?,?,?,?,-).
1611 tostring6(Value,TExpr,S,_,_WF,_AWF) :- (nonvar(Value); nonvar(S)),!,
1612 get_texpr_type(TExpr, Type),
1613 to_b_string_with_type(Value,Type,S).
1614 tostring6(Val,_,string(S),Span,WF,_) :-
1615 add_wd_error_span('Could not compute value in TO_STRING',Val,Span,WF),
1616 S = '<<WELL-DEF-ERROR>>'.
1617
1618 external_fun_type('TO_STRING_UNICODE',[X],[X,string]).
1619 expects_unevaluated_args('TO_STRING_UNICODE').
1620 :- public 'TO_STRING_UNICODE'/3.
1621 'TO_STRING_UNICODE'(Value,S,[TExpr]) :-
1622 get_texpr_type(TExpr, Type),
1623 to_b_string_with_type_and_options(Value,Type,[unicode],S).
1624
1625 external_fun_type('FORMAT_TO_STRING',[X],[string,seq(X),string]).
1626 expects_unevaluated_args('FORMAT_TO_STRING').
1627 :- public 'FORMAT_TO_STRING'/4.
1628 'FORMAT_TO_STRING'(FormatString,ListOfStrings,Res,[_,TExprs]) :-
1629 (get_texpr_type(TExprs, seq(Type)) % if the type of the given format args is a sequence we can use the contained type
1630 -> format_to_b_string_with_type(FormatString,ListOfStrings,Type,Res)
1631 ; format_to_b_string(FormatString,ListOfStrings,Res)).
1632
1633
1634 external_fun_type('STRINGIFY',[X],[X,string]).
1635 expects_unevaluated_args('STRINGIFY').
1636 :- public 'PRETTY_PRINT_TO_STRING'/3.
1637 :- public 'STRINGIFY'/3.
1638 % pretty print a formula to string, the value is not used (but will currently be evaluated !)
1639 % TO DO: should we enforce a certain mode? (ascii, unicode, ...)
1640
1641 'PRETTY_PRINT_TO_STRING'(V,R,A) :- 'STRINGIFY'(V,R,A). % old name
1642 'STRINGIFY'(_Value,Res,[AST]) :-
1643 translate:translate_bexpression(AST,S),
1644 Res = string(S).
1645
1646 external_fun_type('HASH',[X],[X,integer]).
1647 :- public 'HASH'/2.
1648 :- block 'HASH'(-,?).
1649 'HASH'(Value,Int) :-
1650 % TO DO: use ground_value_check
1651 when(ground(Value),(term_hash(Value,H),Int=int(H))).
1652
1653
1654 external_fun_type('TO_INT',[X],[X,integer]). % can translate enumerated/deferred set elements to integer
1655 expects_waitflag('TO_INT').
1656 expects_spaninfo('TO_INT').
1657 :- public 'TO_INT'/4.
1658 :- block 'TO_INT'(-,?,?,?).
1659 'TO_INT'(fd(X,_),I,_,_) :- !, I=int(X).
1660 'TO_INT'(int(X),I,_,_) :- !, I=int(X).
1661 'TO_INT'(string(X),I,Span,WF) :- !, 'STRING_TO_INT'(string(X),I,Span,WF).
1662 'TO_INT'(Val,_,Span,_WF) :- !, translate:translate_bvalue(Val,VS),
1663 add_error(external_functions,'Illegal argument type for TO_INT:',VS,Span).
1664
1665
1666 external_fun_has_wd_condition('INT_TO_ENUM').
1667 expects_waitflag('INT_TO_ENUM').
1668 expects_spaninfo('INT_TO_ENUM').
1669 external_fun_type('INT_TO_ENUM',[T],[set(T),integer,T]).
1670 :- public 'INT_TO_ENUM'/5.
1671 :- block 'INT_TO_ENUM'(?,-,?,?,?),'INT_TO_ENUM'(-,?,?,?,?).
1672 'INT_TO_ENUM'(GSTypeExpr,int(I),Res,Span,WF) :-
1673 get_global_set_value_type(GSTypeExpr,'INT_TO_ENUM',GS),
1674 int2enum(GS,GSTypeExpr,I,Res,Span,WF).
1675 :- use_module(b_global_sets,[b_get_fd_type_bounds/3]).
1676
1677 :- use_module(library(clpfd), []). % for .. operator
1678 :- block int2enum(?,?,-,?,?,?).
1679 int2enum(GS,_,I,_,Span,WF) :-
1680 b_get_fd_type_bounds(GS,Low,Up),
1681 (I<Low ; integer(Up),I>Up),!,
1682 ajoin(['INT_TO_ENUM integer value ',I,' is not in expected range for ',GS,' :'],Msg),
1683 add_wd_error_span(Msg,Low..Up,Span,WF).
1684 int2enum(GS,GSTypeExpr,I,Res,Span,WF) :- Res = fd(I,GS),
1685 membership_test_wf(GSTypeExpr,Res,MemTest,WF),
1686 check_value(MemTest,I,GS,Res,I,GSTypeExpr,Span,WF).
1687
1688 % -------------------------------
1689 % REGULAR EXPRESSION FUNCTIONS
1690 % Using ECMAScript syntax: http://www.cplusplus.com/reference/regex/ECMAScript/
1691
1692 :- use_module(extension('regexp/regexp'),
1693 [regexp_match/4, is_regexp/1, regexp_replace/5,
1694 regexp_search_first/4, regexp_search_first_detailed/5]).
1695 external_fun_type('REGEX_MATCH',[],[string,string,boolean]).
1696 expects_spaninfo('REGEX_MATCH').
1697 :- public 'REGEX_MATCH'/4, 'REGEX_IMATCH'/4.
1698 :- block 'REGEX_MATCH'(-,?,?,?), 'REGEX_MATCH'(?,-,?,?).
1699 'REGEX_MATCH'(string(String),string(Pattern),Res,Span) :-
1700 block_regex_match(String,Pattern,match_case,Res,Span).
1701
1702 external_fun_type('REGEX_IMATCH',[],[string,string,boolean]).
1703 expects_spaninfo('REGEX_IMATCH').
1704 :- block 'REGEX_IMATCH'(-,?,?,?), 'REGEX_IMATCH'(?,-,?,?).
1705 'REGEX_IMATCH'(string(String),string(Pattern),Res,Span) :-
1706 block_regex_match(String,Pattern,ignore_case,Res,Span).
1707
1708 :- block block_regex_match(-,?,?,?,?), block_regex_match(?,-,?,?,?).
1709 block_regex_match(String,Pattern,IgnoreCase,Res,Span) :-
1710 (regexp_match(String,Pattern,IgnoreCase,Span) -> Res=pred_true ; Res=pred_false).
1711
1712 external_fun_type('IS_REGEX',[],[string,boolean]).
1713 :- public 'IS_REGEX'/2.
1714 :- block 'IS_REGEX'(-,?).
1715 'IS_REGEX'(string(Pattern),Res) :- block_is_regexp(Pattern,Res).
1716 :- block block_is_regexp(-,?).
1717 block_is_regexp(Pattern,Res) :-
1718 (is_regexp(Pattern) -> Res=pred_true ; Res=pred_false).
1719
1720
1721 :- public 'GET_IS_REGEX'/2.
1722 :- public 'GET_IS_REGEX_MATCH'/4.
1723 :- public 'GET_IS_REGEX_IMATCH'/4.
1724 expects_spaninfo('GET_IS_REGEX_MATCH').
1725 expects_spaninfo('GET_IS_REGEX_IMATCH').
1726 % synonyms as use for functions to BOOL rather than predicates
1727 'GET_IS_REGEX'(A,Res) :- 'IS_REGEX'(A,Res).
1728 'GET_IS_REGEX_MATCH'(S1,S2,Res,Span) :- 'REGEX_MATCH'(S1,S2,Res,Span).
1729 'GET_IS_REGEX_IMATCH'(S1,S2,Res,Span) :- 'REGEX_IMATCH'(S1,S2,Res,Span).
1730
1731 external_fun_type('REGEX_REPLACE',[],[string,string,string,string]).
1732 :- public 'REGEX_REPLACE'/4.
1733 :- block 'REGEX_REPLACE'(-,?,?,?), 'REGEX_REPLACE'(?,-,?,?), 'REGEX_REPLACE'(?,?,-,?).
1734 'REGEX_REPLACE'(string(String),string(Pattern),string(ReplString),Res) :-
1735 block_regex_replace(String,Pattern,match_case,ReplString,Res).
1736
1737 external_fun_type('REGEX_IREPLACE',[],[string,string,string,string]).
1738 :- public 'REGEX_IREPLACE'/4.
1739 :- block 'REGEX_IREPLACE'(-,?,?,?), 'REGEX_IREPLACE'(?,-,?,?), 'REGEX_IREPLACE'(?,?,-,?).
1740 'REGEX_IREPLACE'(string(String),string(Pattern),string(ReplString),Res) :-
1741 block_regex_replace(String,Pattern,ignore_case,ReplString,Res).
1742
1743 :- block block_regex_replace(-,?,?,?,?), block_regex_replace(?,-,?,?,?), block_regex_replace(?,?,?,-,?).
1744 block_regex_replace(String,Pattern,IgnoreCase,ReplString,Result) :-
1745 regexp_replace(String,Pattern,IgnoreCase,ReplString,Res), Result=string(Res).
1746
1747
1748 external_fun_type('REGEX_SEARCH_STR',[],[string,string,string]).
1749 :- public 'REGEX_SEARCH_STR'/3, 'REGEX_ISEARCH_STR'/3.
1750 :- block 'REGEX_SEARCH_STR'(-,?,?), 'REGEX_SEARCH_STR'(?,-,?).
1751 'REGEX_SEARCH_STR'(string(String),string(Pattern),Res) :- block_regex_search_first(String,Pattern,match_case,Res).
1752 external_fun_type('REGEX_ISEARCH_STR',[],[string,string,string]).
1753 :- block 'REGEX_ISEARCH_STR'(-,?,?), 'REGEX_ISEARCH_STR'(?,-,?).
1754 'REGEX_ISEARCH_STR'(string(String),string(Pattern),Res) :- block_regex_search_first(String,Pattern,ignore_case,Res).
1755 :- block block_regex_search_first(-,?,?,?), block_regex_search_first(?,-,?,?).
1756 block_regex_search_first(String,Pattern,IgnoreCase,Result) :-
1757 regexp_search_first(String,Pattern,IgnoreCase,Res), Result=string(Res).
1758
1759 external_fun_type('REGEX_SEARCH',[],[string,integer,string,
1760 record([field(length,integer),field(position,integer),
1761 field(string,string),
1762 field(submatches,seq(string))])]).
1763 :- public 'REGEX_SEARCH'/4, 'REGEX_ISEARCH'/4.
1764 'REGEX_SEARCH'(S,From,Pat,Res) :- 'REGEX_SEARCH5'(S,From,Pat,match_case,Res).
1765 external_fun_type('REGEX_ISEARCH',TV,T) :- external_fun_type('REGEX_SEARCH',TV,T).
1766 'REGEX_ISEARCH'(S,From,Pat,Res) :- 'REGEX_SEARCH5'(S,From,Pat,ignore_case,Res).
1767
1768 :- block 'REGEX_SEARCH5'(-,?,?,?,?), 'REGEX_SEARCH5'(?,-,?,?,?), 'REGEX_SEARCH5'(?,?,-,?,?).
1769 'REGEX_SEARCH5'(string(String),int(From),string(Pattern),IgnoreCase,Res) :-
1770 block_regex_search_first_detailed(String,From,Pattern,IgnoreCase,Res).
1771
1772 :- block block_regex_search_first_detailed(-,?,?,?,?),
1773 block_regex_search_first_detailed(?,-,?,?,?), block_regex_search_first_detailed(?,?,-,?,?).
1774 block_regex_search_first_detailed(String,FromIndex,Pattern,IgnoreCase,Result) :-
1775 regexp_search_first_detailed(String,FromIndex,Pattern,IgnoreCase,Res),
1776 construct_match_result(Res,Result).
1777
1778 construct_match_result(match(Pos,Len,[Str|SubMatches]),Res) :- !,
1779 BPos is Pos+1,
1780 maplist(mkstring,SubMatches,SubMatchesStr),
1781 convert_list_to_seq(SubMatchesStr,SubList),
1782 Res = rec([field(length,int(Len)), field(position,int(BPos)),
1783 field(string,string(Str)), field(submatches,SubList)]).
1784 construct_match_result('no-match',Res) :- !,
1785 Res = rec([field(length,int(-1)), field(position,int(-1)), field(string,string('')), field(submatches,[])]).
1786
1787 mkstring(A,string(A)).
1788
1789 :- use_module(extension('regexp/regexp'), [regexp_search_all/4]).
1790 external_fun_type('REGEX_SEARCH_ALL',[],[string,string,seq(string)]).
1791 :- public 'REGEX_SEARCH_ALL'/3, 'REGEX_ISEARCH_ALL'/3.
1792 :- block 'REGEX_SEARCH_ALL'(-,?,?), 'REGEX_SEARCH_ALL'(?,-,?).
1793 'REGEX_SEARCH_ALL'(string(String),string(Pattern),Res) :- block_regex_search_all(String,Pattern,match_case,Res).
1794
1795 external_fun_type('REGEX_ISEARCH_ALL',[],[string,string,seq(string)]).
1796 :- block 'REGEX_ISEARCH_ALL'(-,?,?), 'REGEX_ISEARCH_ALL'(?,-,?).
1797 'REGEX_ISEARCH_ALL'(string(String),string(Pattern),Res) :- block_regex_search_all(String,Pattern,ignore_case,Res).
1798
1799 :- block block_regex_search_all(-,?,?,?), block_regex_search_all(?,-,?,?).
1800 block_regex_search_all(String,Pattern,IgnoreCase,Result) :-
1801 regexp_search_all(String,Pattern,IgnoreCase,Matches),
1802 maplist(mkstring,Matches,MatchesStr),
1803 convert_list_to_seq(MatchesStr,Result).
1804
1805
1806 % -------------------------------
1807
1808 external_fun_type('SHA_HASH',[X],[X,set(couple(integer,integer))]).
1809 expects_waitflag('SHA_HASH').
1810 :- use_module(extension('probhash/probhash'),[raw_sha_hash/2]).
1811 :- use_module(store,[normalise_value_for_var/3]).
1812 :- public 'SHA_HASH'/3.
1813 :- block 'SHA_HASH'(-,?,?).
1814 'SHA_HASH'(Value,Res,WF) :-
1815 normalise_value_for_var('SHA_HASH',Value,NValue),
1816 ground_value_check(NValue,Gr),
1817 sha_hash(NValue,Gr,Res,WF).
1818 :- block sha_hash(?,-,?,?).
1819 sha_hash(Value,_,Res,WF) :-
1820 raw_sha_hash(Value,List),
1821 convert_to_int_seq(List,1,Seq),
1822 equal_object_optimized_wf(Seq,Res,'SHA_HASH',WF).
1823
1824 convert_to_int_seq([],_,[]).
1825 convert_to_int_seq([H|T],N,[(int(N),int(H))|CT]) :- N1 is N+1, convert_to_int_seq(T,N1,CT).
1826
1827 external_fun_type('SHA_HASH_HEX',[X],[X,string]).
1828 :- public 'SHA_HASH_HEX'/2.
1829 :- block 'SHA_HASH_HEX'(-,?).
1830 'SHA_HASH_HEX'(Value,Res) :-
1831 normalise_value_for_var('SHA_HASH_HEX',Value,NValue),
1832 ground_value_check(NValue,Gr),
1833 sha_hash_string(NValue,Gr,Res).
1834 :- block sha_hash_string(?,-,?).
1835 sha_hash_string(Value,_,Res) :-
1836 sha_hash_as_hex_codes(Value,SHAHexCodes), atom_codes(Atom,SHAHexCodes),
1837 Res = string(Atom).
1838
1839 :- use_module(extension('probhash/probhash'),[raw_sha_hash_file/3]).
1840 performs_io('SHA_HASH_FILE_HEX').
1841 expects_spaninfo('SHA_HASH_FILE_HEX').
1842 external_fun_type('SHA_HASH_FILE_HEX',[],[string,string]).
1843 :- public 'SHA_HASH_FILE_HEX'/3.
1844 :- block 'SHA_HASH_FILE_HEX'(-,?,?).
1845 'SHA_HASH_FILE_HEX'(string(File),Res,Span) :-
1846 sha_hash_file(File,Res,Span).
1847 :- block sha_hash_file(-,?,?).
1848 sha_hash_file(File,Res,Span) :-
1849 b_absolute_file_name(File,AFile),
1850 raw_sha_hash_file(AFile,Term,Span),
1851 get_hex_bytes(Term,SHAHexCodes), atom_codes(Atom,SHAHexCodes),
1852 Res = string(Atom).
1853
1854 % -------------------------------
1855
1856 % STRING FILE SYSTEM FUNCTIONS
1857
1858
1859 :- use_module(kernel_objects).
1860 :- use_module(library(file_systems)).
1861 performs_io('FILES').
1862 external_fun_type('FILES',[],[string,set(string)]).
1863 :- public 'FILES'/2.
1864 :- block 'FILES'(-,?).
1865 'FILES'(string(A),L) :- files2(A,L).
1866 :- block files2(-,?).
1867 files2(Dir,List) :- b_absolute_file_name(Dir,ADir),
1868 findall(string(F),file_member_of_directory(ADir,F,_FLong),L),
1869 equal_object_optimized(L,List,files2).
1870 performs_io('FULL_FILES').
1871 external_fun_type('FULL_FILES',[],[string,set(string)]).
1872 :- public 'FULL_FILES'/2.
1873 :- block 'FULL_FILES'(-,?).
1874 'FULL_FILES'(string(A),L) :- full_files2(A,L).
1875 :- block full_files2(-,?).
1876 full_files2(Dir,List) :-
1877 b_absolute_file_name(Dir,ADir),
1878 findall(string(FLong),file_member_of_directory(ADir,_F,FLong),L),
1879 equal_object_optimized(L,List,full_files2).
1880
1881
1882 performs_io('DIRECTORIES').
1883 external_fun_type('DIRECTORIES',[],[string,set(string)]).
1884 :- public 'DIRECTORIES'/2.
1885 :- block 'DIRECTORIES'(-,?).
1886 'DIRECTORIES'(string(A),L) :- dir2(A,L).
1887 :- block dir2(-,?).
1888 dir2(Dir,List) :- b_absolute_file_name(Dir,ADir),
1889 findall(string(F),directory_member_of_directory(ADir,F,_FLong),L),
1890 equal_object_optimized(L,List,dir2).
1891 performs_io('FULL_DIRECTORIES').
1892 external_fun_type('FULL_DIRECTORIES',[],[string,set(string)]).
1893 :- public 'FULL_DIRECTORIES'/2.
1894 :- block 'FULL_DIRECTORIES'(-,?).
1895 'FULL_DIRECTORIES'(string(A),L) :- full_dir2(A,L).
1896 :- block full_dir2(-,?).
1897 full_dir2(Dir,List) :- b_absolute_file_name(Dir,ADir),
1898 findall(string(FLong),directory_member_of_directory(ADir,_,FLong),L),
1899 equal_object_optimized(L,List,full_dir2).
1900
1901 :- public 'GET_FILE_EXISTS'/2.
1902 'GET_FILE_EXISTS'(S,PREDRES) :- 'FILE_EXISTS'(S,PREDRES). % synonym as external function
1903 performs_io('FILE_EXISTS').
1904 external_fun_type('FILE_EXISTS',[],[string,boolean]).
1905 :- public 'FILE_EXISTS'/2.
1906 :- block 'FILE_EXISTS'(-,?).
1907 'FILE_EXISTS'(string(A),PREDRES) :- file_exists2(A,PREDRES).
1908 :- block file_exists2(-,?).
1909 file_exists2(A,PREDRES) :- b_absolute_file_name(A,AA),
1910 (file_exists(AA) -> PREDRES=pred_true ; PREDRES=pred_false).
1911
1912 :- public 'GET_DIRECTORY_EXISTS'/2.
1913 'GET_DIRECTORY_EXISTS'(S,PREDRES) :- 'DIRECTORY_EXISTS'(S,PREDRES). % synonym as external function
1914 performs_io('DIRECTORY_EXISTS').
1915 external_fun_type('DIRECTORY_EXISTS',[],[string,boolean]).
1916 :- public 'DIRECTORY_EXISTS'/2.
1917 :- block 'DIRECTORY_EXISTS'(-,?).
1918 'DIRECTORY_EXISTS'(string(A),PREDRES) :- dir_exists2(A,PREDRES).
1919 :- block dir_exists2(-,?).
1920 dir_exists2(A,PREDRES) :- b_absolute_file_name(A,AA),
1921 (directory_exists(AA) -> PREDRES=pred_true ; PREDRES=pred_false).
1922
1923 :- use_module(tools,[get_parent_directory/2]).
1924 % a variant of the predicate b_absolute_file_name_relative_to_main_machine in bmachine using safe_call (with span):
1925 b_absolute_file_name(File,AbsFileName) :- b_absolute_file_name(File,AbsFileName,unknown).
1926 b_absolute_file_name(File,AbsFileName,Span) :-
1927 bmachine:b_get_main_filename(MainFileName),!,
1928 get_parent_directory(MainFileName,Directory),
1929 % in Jupyter main file is (machine from Jupyter cell).mch, which confuses SICStus as the file does not exist
1930 safe_call(
1931 absolute_file_name(File,AbsFileName,[relative_to(Directory)]),
1932 Span).
1933 b_absolute_file_name(File,AbsFileName,Span) :-
1934 % call is executed without machine context; we could simply throw an error and fail
1935 safe_call(
1936 absolute_file_name(File,AbsFileName),
1937 Span).
1938
1939 :- public 'GET_FILE_PROPERTY'/3.
1940 'GET_FILE_PROPERTY'(S1,S2,PREDRES) :- 'FILE_PROPERTY'(S1,S2,PREDRES). % synonym as external function
1941 performs_io('FILE_PROPERTY').
1942 external_fun_type('FILE_PROPERTY',[],[string,string,boolean]).
1943 :- public 'FILE_PROPERTY'/3.
1944 :- block 'FILE_PROPERTY'(-,?,?), 'FILE_PROPERTY'(?,-,?).
1945 'FILE_PROPERTY'(string(A),string(P),BoolRes) :-
1946 file_property2(A,P,BoolRes).
1947 :- block file_property2(-,?,?), file_property2(?,-,?).
1948 file_property2(File,Prop,BoolRes) :-
1949 b_absolute_file_name(File,AFile),
1950 file_property(AFile,Prop) -> BoolRes=pred_true ; BoolRes=pred_false.
1951 % possible properties: readable, writable, executable
1952
1953 performs_io('FILE_PROPERTY_VALUE').
1954 external_fun_type('FILE_PROPERTY_VALUE',[],[string,string,integer]).
1955 :- public 'FILE_PROPERTY_VALUE'/3.
1956 :- block 'FILE_PROPERTY_VALUE'(-,?,?), 'FILE_PROPERTY_VALUE'(?,-,?).
1957 'FILE_PROPERTY_VALUE'(string(A),string(P),int(R)) :-
1958 file_property_val2(A,P,R).
1959 :- block file_property_val2(-,?,?), file_property_val2(?,-,?).
1960 file_property_val2(File,Prop,Res) :-
1961 b_absolute_file_name(File,AFile),
1962 file_property(AFile,Prop,Val) -> Res=Val
1963 ; add_error(external_functions,'Illegal FILE_PROPERTY',Prop),Res=int(-1).
1964 % possible properties:
1965 % size_in_bytes, create_timestamp, modify_timestamp, access_timestamp
1966 % + on unix the follwing is also an integer: owner_user_id, owner_group_id
1967
1968 :- public 'GET_DIRECTORY_PROPERTY'/3.
1969 'GET_DIRECTORY_PROPERTY'(S1,S2,PREDRES) :- 'DIRECTORY_PROPERTY'(S1,S2,PREDRES). % synonym as external function
1970 performs_io('DIRECTORY_PROPERTY').
1971 external_fun_type('DIRECTORY_PROPERTY',[],[string,string,boolean]).
1972 :- public 'DIRECTORY_PROPERTY'/3.
1973 :- block 'DIRECTORY_PROPERTY'(-,?,?), 'DIRECTORY_PROPERTY'(?,-,?).
1974 'DIRECTORY_PROPERTY'(string(A),string(P),BoolRes) :-
1975 dir_property2(A,P,BoolRes).
1976 :- block dir_property2(-,?,?), dir_property2(?,-,?).
1977 dir_property2(File,Prop,BoolRes) :-
1978 b_absolute_file_name(File,AFile),
1979 directory_property(AFile,Prop) -> BoolRes=pred_true ; BoolRes=pred_false.
1980
1981 performs_io('DIRECTORY_PROPERTY_VALUE').
1982 external_fun_type('DIRECTORY_PROPERTY_VALUE',[],[string,string,integer]).
1983 :- public 'DIRECTORY_PROPERTY_VALUE'/3.
1984 :- block 'DIRECTORY_PROPERTY_VALUE'(-,?,?), 'DIRECTORY_PROPERTY_VALUE'(?,-,?).
1985 'DIRECTORY_PROPERTY_VALUE'(string(A),string(P),int(R)) :-
1986 dir_property_val2(A,P,R).
1987 :- block dir_property_val2(-,?,?), dir_property_val2(?,-,?).
1988 dir_property_val2(File,Prop,Res) :-
1989 b_absolute_file_name(File,AFile),
1990 directory_property(AFile,Prop,Val) -> Res=Val
1991 ; add_error(external_functions,'Illegal DIRECTORY_PROPERTY',Prop), Res=int(-1).
1992 % --------------------------------
1993
1994 % I/O
1995
1996
1997 % printf as predicate; can also be used as a function to BOOL
1998 expects_spaninfo('fprintf').
1999 external_pred_always_true('fprintf').
2000 :- public fprintf/5.
2001 :- block fprintf(-,?,?,?,?), fprintf(?,-,?,?,?), fprintf(?,?,-,?,?).
2002 fprintf(string(File),string(FormatString),Value,PredRes,Span) :- !, PredRes = pred_true,
2003 when((ground(FormatString),ground(Value)),
2004 fprintf2(File,FormatString,Value,Span)).
2005 fprintf(File,F,V,P,S) :- add_internal_error('Illegal call: ',fprintf(File,F,V,P,S)), P=pred_true.
2006
2007 expects_spaninfo('printf_opt_trace').
2008 external_pred_always_true('printf_opt_trace').
2009 :- public printf_opt_trace/5.
2010 :- block printf_opt_trace(-,?,?,?,?), printf_opt_trace(?,-,?,?,?).
2011 printf_opt_trace(string(FormatString),Value,Trace,PredRes,Span) :- !, PredRes = pred_true,
2012 when((ground(FormatString),ground(Value)),
2013 (fprintf2(user_output,FormatString,Value,Span),
2014 (Trace==pred_true -> try_trace ; true)
2015 )
2016 ).
2017 printf_opt_trace(F,V,T,P,S) :- add_internal_error('Illegal call: ',printf_opt_trace(F,V,T,P,S)), P=pred_true.
2018
2019 % try to perform trace commend if we are not in compiled version
2020 try_trace :-
2021 catch(trace, error(existence_error(_,_),_), (
2022 format('Cannot trace into source code in compiled version of ProB!~n<<<Type RETURN-Key to continue>>>',[]),
2023 read_line(user_input,_),nl
2024 )).
2025
2026 expects_spaninfo('printf').
2027 external_pred_always_true('printf').
2028 external_fun_type('printf',[T],[string,seq(T),boolean]).
2029
2030 :- assert_must_succeed(external_functions:printf(string('test ok = ~w~n'),[(int(1),pred_true)],pred_true,unknown)).
2031 :- block printf(-,?,?,?), printf(?,-,?,?).
2032 printf(string(FormatString),Value,PredRes,Span) :- !, PredRes = pred_true,
2033 when((ground(FormatString),ground(Value)),
2034 fprintf2(user_output,FormatString,Value,Span)).
2035 printf(F,V,P,S) :- add_internal_error('Illegal call: ',printf(F,V,P,S)), P=pred_true.
2036
2037 expects_spaninfo('printf_two'). % print two values, triggers as soon as first value is known
2038 external_pred_always_true('printf_two').
2039 :- assert_must_succeed(external_functions:printf_two(string('test ok = ~w~n'),[(int(1),pred_true)],string('test ok = ~w~n'),[(int(1),pred_true)],pred_true,unknown)).
2040 :- public printf_two/6.
2041 :- block printf_two(-,?,?,?,?,?), printf_two(?,-,?,?,?,?).
2042 printf_two(string(FormatString),Value,string(FormatString2),Value2,PredRes,Span) :- !, PredRes = pred_true,
2043 when((ground(FormatString),ground(Value)),
2044 (fprintf2(user_output,FormatString,Value,Span),
2045 fprintf2(user_output,FormatString2,Value2,Span))).
2046 printf_two(F,V,F2,V2,P,S) :- add_internal_error('Illegal call: ',printf_two(F,V,F2,V2,P,S)), P=pred_true.
2047
2048
2049 expects_spaninfo('printf_nonvar'). % print as soon as value becomes nonvar (printf waits until the value is ground)
2050 external_pred_always_true('printf_nonvar').
2051 :- public printf_nonvar/4.
2052 :- block printf_nonvar(-,?,?,?), printf_nonvar(?,-,?,?).
2053 printf_nonvar(string(FormatString),Value,PredRes,Span) :- !, PredRes = pred_true,
2054 when((ground(FormatString),nonvar(Value)),
2055 fprintf2(user_output,FormatString,Value,Span)).
2056 printf_nonvar(F,V,P,S) :- add_internal_error('Illegal call: ',printf(F,V,P,S)), P=pred_true.
2057
2058
2059 expects_spaninfo('dprintf'). % a version of printf which delays setting itself to TRUE until printing is performed
2060 external_pred_always_true('dprintf').
2061 :- public dprintf/4.
2062 :- block dprintf(-,?,?,?), dprintf(?,-,?,?).
2063 dprintf(string(FormatString),Value,PredRes,Span) :- !,
2064 when((ground(FormatString),ground(Value)),
2065 (fprintf2(user_output,FormatString,Value,Span),PredRes = pred_true)).
2066 dprintf(F,V,P,S) :- add_internal_error('Illegal call: ',dprintf(F,V,P,S)), P=pred_true.
2067
2068 :- use_module(kernel_strings,[convert_b_sequence_to_list_of_atoms/3]).
2069 fprintf2(File,FormatString,Value,Span) :-
2070 convert_b_sequence_to_list_of_atoms(Value,ListOfAtoms,Done),
2071 when(nonvar(Done),
2072 (file_format(File,FormatString,ListOfAtoms,Span),
2073 print_hash((FormatString,Value)),
2074 print_stats,
2075 fprint_log_info(File,Span)
2076 )).
2077 %fprintf2(File,FormatString,Value,Span) :- print('BACKTRACKING ') , file_format(File,FormatString,['?'],Span),nl,fail.
2078 % warning: format can call an argument as goal with ~@; this is dangerous
2079 % and we should prohibit this
2080 % Luckily PRINTF("@: <>~@<>~n","print(danger)") where print(danger)
2081 % is arbitrary code is not a security exploit:
2082 % our PRINTF translates the argument to an atom, i.e., one could
2083 % only call Prolog predicates without arguments, anything else leads to an exception
2084 % (even PRINTF("@: <>~@<>~n","nl") leads to an exception)
2085
2086
2087 :- use_module(hashing,[my_term_hash/2]).
2088 % optionally print hash and allow breakpoints
2089 print_hash(V) :-
2090 external_fun_pref(printf_hash,'TRUE'), % use SET_PREF("printf_hash","TRUE")
2091 !,
2092 my_term_hash(V,H), format('% HASH = ~w~n',H),
2093 %((H = 158201315 ; H=29759067) -> trace ; true),
2094 true.
2095 print_hash(_).
2096
2097
2098 :- use_module(probsrc(tools),[statistics_memory_used/1]).
2099 :- dynamic nr_of_printfs/1.
2100 nr_of_printfs(0).
2101 print_stats :-
2102 external_fun_pref(printf_stats,PFS), % use SET_PREF("printf_stats","TRUE")
2103 PFS='TRUE',
2104 retract(nr_of_printfs(N)),
2105 !,
2106 N1 is N+1,
2107 assertz(nr_of_printfs(N1)),
2108 statistics(walltime,[X,SL]),
2109 statistics_memory_used(M), MB is M / 1000000, % used instead of deprecated 1048576,
2110 statistics(gc_count,GCs),
2111 format('% Call ~w at walltime ~w ms (since last ~w ms), memory ~3f MB (~w GCs)~n',[N1,X,SL,MB,GCs]).
2112 print_stats.
2113
2114 :- dynamic external_fun_pref/2.
2115 % valid keys: log_info
2116 valid_external_fun_pref(log_info).
2117 valid_external_fun_pref(printf_stats).
2118 valid_external_fun_pref(printf_hash).
2119
2120 fprint_log_info(File,Span) :- external_fun_pref(log_info,X),
2121 'GET_INFO'(string(X),string(Res)),
2122 file_format(File,'%%% ~w~n',[Res],Span).
2123 fprint_log_info(_,_).
2124
2125 % example usage SET_PREF("log_info","time") or SET_PREF("printf_stats","TRUE")
2126 external_fun_type('SET_PREF',[],[string,string,boolean]).
2127 :- public 'SET_PREF'/3.
2128 :- block 'SET_PREF'(-,?,?), 'SET_PREF'(?,-,?).
2129 'SET_PREF'(string(S),string(Val),R) :-
2130 preferences:eclipse_preference(S,Pref),!, R=pred_true,
2131 format('Setting ProB preference ~w := ~w~n',[S,Val]),
2132 preferences:set_preference(Pref,Val).
2133 'SET_PREF'(string(S),string(Val),R) :- valid_external_fun_pref(S),!,
2134 R=pred_true,
2135 retractall(external_fun_pref(S,_)),
2136 format('Setting external function preference ~w := ~w~n',[S,Val]),
2137 assertz(external_fun_pref(S,Val)).
2138 'SET_PREF'(P,V,R) :-
2139 add_internal_error('Illegal call: ','SET_PREF'(P,V,R)), R=pred_false.
2140
2141 external_fun_type('GET_PREF',[],[string,string]).
2142 expects_waitflag('GET_PREF').
2143 expects_spaninfo('GET_PREF').
2144 :- assert_must_succeed(external_functions:'GET_PREF'(string('CLPFD'),string(_),unknown,_)).
2145 :- public 'GET_PREF'/4.
2146 'GET_PREF'(Str,Res,Span,WF) :-
2147 kernel_waitflags:get_wait_flag(10,'GET_PREF',WF,WF10), % will enumerate possible input strings
2148 get_pref2(Str,Res,_,WF10,Span).
2149 external_fun_type('GET_PREF_DEFAULT',[],[string,string]).
2150 expects_waitflag('GET_PREF_DEFAULT').
2151 expects_spaninfo('GET_PREF_DEFAULT').
2152 :- assert_must_succeed(external_functions:'GET_PREF_DEFAULT'(string('CLPFD'),string(true),unknown,_)).
2153 :- public 'GET_PREF_DEFAULT'/4.
2154 'GET_PREF_DEFAULT'(Str,Res,Span,WF) :-
2155 (nonvar(Str) -> true
2156 ; kernel_waitflags:get_wait_flag(10,'GET_PREF',WF,WF10)), % will enumerate possible input strings
2157 get_pref2(Str,_,Res,WF10,Span).
2158
2159 :- block get_pref2(-,?,?,-,?).
2160 get_pref2(string(S),Res,Res2,_,Span) :-
2161 if((preferences:eclipse_preference(S,Pref),
2162 preferences:get_preference(Pref,Val),
2163 preferences:preference_default_value(Pref,DefVal)),
2164 (make_string(Val,Res),make_string(DefVal,Res2)),
2165 (add_error(external_functions,'Illegal argument for GET_PREF: ',S,Span),
2166 fail)).
2167
2168
2169 % printf followed by fail; useful for print fail loops in the REPL
2170 expects_spaninfo('printfail').
2171 :- assert_must_fail(external_functions:printfail(string('test ok = ~w~n'),[(int(1),pred_true)],pred_true,unknown)).
2172 :- block printfail(-,?,?,?), printfail(?,-,?,?).
2173 printfail(string(FormatString),Value,PredRes,Span) :- !, PredRes = pred_true,
2174 when((ground(FormatString),ground(Value)),
2175 (fprintf2(user_output,FormatString,Value,Span),fail)).
2176 printfail(F,V,P,S) :-
2177 add_internal_error('Illegal call: ',printfail(F,V,P,S)), P=pred_true.
2178
2179 % a version of printf with automatic indenting and backtracking feedback
2180 expects_spaninfo('iprintf').
2181 external_pred_always_true('iprintf').
2182 :- assert_must_succeed(external_functions:iprintf(string('test ok = ~w~n'),[(int(1),pred_true)],pred_true,unknown)).
2183 :- block iprintf(-,?,?,?), iprintf(?,-,?,?).
2184 iprintf(string(FormatString),Value,PredRes,Span) :- !, PredRes = pred_true,
2185 when((ground(FormatString),ground(Value)),
2186 ifprintf2(user_output,FormatString,Value,no_trace,Span)).
2187 iprintf(F,V,P,S) :- add_internal_error('Illegal call: ',iprintf(F,V,P,S)), P=pred_true.
2188 ifprintf2(File,FormatString,Value,Trace,Span) :-
2189 my_term_hash((FormatString,Value),Hash),
2190 format(user_output,'[hash ~w] ',[Hash]), % (Hash=1087266573122589201 -> (trace ; trace,fail) ; true),
2191 translate:translate_bvalue(Value,TV),
2192 indent_format(File,FormatString,[TV],Trace),
2193 fprint_log_info(File,Span).
2194 expects_spaninfo('itprintf').
2195 external_pred_always_true('itprintf').
2196 :- public itprintf/4.
2197 :- block itprintf(-,?,?,?), itprintf(?,-,?,?).
2198 itprintf(string(FormatString),Value,PredRes,Span) :- PredRes = pred_true,
2199 when((ground(FormatString),ground(Value)),
2200 ifprintf2(user_output,FormatString,Value,trace,Span)).
2201
2202 % ---------------
2203
2204 % a more light-weight version of observe_indent below
2205 :- public observe/5.
2206 expects_spaninfo('observe').
2207 expects_unevaluated_args('observe').
2208 expects_waitflag('observe').
2209 external_pred_always_true('observe').
2210 external_fun_type('observe',[T],[T,boolean]).
2211 observe(Value,PredRes,[Arg],Span,WF) :-
2212 observe6(Value,PredRes,[Arg],Span,_,WF).
2213
2214 % a version which does not print instantiations; just registers them and the patterns
2215 % can be inspected later with -prob-profile (calling portray_instantiations)
2216 :- public observe_silent/5.
2217 expects_spaninfo('observe_silent').
2218 expects_unevaluated_args('observe_silent').
2219 expects_waitflag('observe_silent').
2220 external_pred_always_true('observe_silent').
2221 external_fun_type('observe_silent',[T],[T,boolean]).
2222 observe_silent(Value,PredRes,[Arg],Span,WF) :-
2223 observe6(Value,PredRes,[Arg],Span,silent,WF).
2224
2225 observe6(Value,PredRes,[Arg],_Span,IndentVar,WF) :-
2226 observe_couples(Value,Arg,IndentVar,WF),
2227 PredRes=pred_true,
2228 (Arg\=b(couple(_,_),_,_)
2229 -> true
2230 ; translate_bexpression(Arg,AS),
2231 ground_value_check(Value,GrVal),
2232 block_print_value_complete(GrVal,AS,Value,IndentVar,WF)
2233 ).
2234
2235 observe_couples((V1,V2),b(couple(A1,A2),_,_),IndentVar,WF) :- !,
2236 observe_couples(V1,A1,IndentVar,WF),
2237 observe_couples(V2,A2,IndentVar,WF).
2238 observe_couples(Val,Arg,IndentVar,WF) :-
2239 translate_bexpression(Arg,ArgString),
2240 (IndentVar==silent -> true ; format(user_output,' observing ~w~n',[ArgString])), % for values we could print_span
2241 ground_value_check(Val,GrVal),
2242 block_print_value(GrVal,ArgString,Val,IndentVar,WF).
2243
2244 :- block block_print_value(-,?,?,?,?).
2245 block_print_value(_,ArgString,V,IndentVar,WF) :-
2246 print_value(ArgString,V,IndentVar,WF).
2247 print_value(ArgString,V,IndentVar,WF) :-
2248 register_instantiation_wf(ArgString,WF),
2249 (IndentVar==silent -> true
2250 ; translate_bvalue(V,VS), statistics(walltime,[WT,_]),
2251 get_wf_summary(WF,WS),
2252 indent_var(IndentVar),
2253 format(user_output,' ~w = ~w (walltime: ~w ms) ~w~n',[ArgString,VS,WT,WS])
2254 %,set_prolog_flag(profiling,on), print_profile
2255 ).
2256 :- block block_print_value_complete(-,?,?,?,?).
2257 block_print_value_complete(_,ArgString,V,IndentVar,WF) :- print_value_complete(ArgString,V,IndentVar,WF).
2258 print_value_complete(ArgString,V,IndentVar,WF) :-
2259 register_instantiation_wf(ArgString,WF),
2260 (IndentVar==silent -> true
2261 ; translate_bvalue(V,VS), statistics(walltime,[WT,_]),
2262 get_wf_summary(WF,WS),
2263 indent_var(IndentVar),
2264 format(user_output,'* Value complete: ~w = ~w (walltime: ~w ms) ~w~n------~n',[ArgString,VS,WT,WS])
2265 %,set_prolog_flag(profiling,on), print_profile,trace
2266 ).
2267 % TODO: determine indentation based on overall instantiation of full value
2268
2269 :- use_module(kernel_waitflags,[get_minimum_waitflag_prio/3]).
2270 get_wf_summary(WF,R) :- debug_mode(on),get_minimum_waitflag_prio(WF,MinPrio,_Info),!, R=MinPrio.
2271 get_wf_summary(_,'').
2272
2273 % TODO: store indent var in WF store; so that we can share results/indentation amongst multiple observes
2274 % indent based upon a shared variable and increment it; it displays indentation locally for every observe call
2275 % using put_wf_dynamic_info we could display it for every WF store
2276 indent_var(X) :- var(X),!, X=inst(_). %, register_instantiation(ArgStr,Pred,Level).
2277 indent_var(inst(X)) :- !,print('.'), indent_var(X).
2278 indent_var(_) :- print('***').
2279
2280 % a small utility to observe list of atomic variable names with Prolog value terms
2281 % can be used on Ids,Vars for calls to set_up_localstate(Ids,Vars,LocalState,LetState)
2282 :- public observe_variables/2. %useful for debugging
2283 observe_variables(ListOfIDs,ListOfVals) :- observe_variables(ListOfIDs,ListOfVals,_).
2284 observe_variables([],[],_).
2285 observe_variables([TID|T],[Val|TV],IndentVar) :-
2286 (atomic(TID) -> ID=TID ; get_texpr_id(TID,ID) -> true ; ID=TID),
2287 ground_value_check(Val,GrVal),
2288 block_print_value(GrVal,ID,Val,IndentVar,no_wf_available),
2289 observe_variables(T,TV,IndentVar).
2290
2291 :- dynamic instantiation_link/4, instantiation_level_reached/1.
2292 % keep track of how variables are instantiated in which order
2293 register_instantiation(ArgStr,Pred,Level) :-
2294 (instantiation_level_reached(Level) -> true ; assertz(instantiation_level_reached(Level))),
2295 (retract(instantiation_link(Pred,ArgStr,Level,Hits))
2296 -> H1 is Hits+1
2297 ; H1 is 1),
2298 assertz(instantiation_link(Pred,ArgStr,Level,H1)).
2299
2300 :- use_module(probsrc(preferences), [get_preference/2]).
2301 % register information that this argument/variable is now instantiated:
2302 register_instantiation_wf(ArgInstantiated,WF) :-
2303 (get_wf_dynamic_info(WF,instantiation_info,lvl_prev(Level,PrevArgInstantiated))
2304 -> true
2305 ; Level=0,
2306 (get_preference(provide_trace_information,false)
2307 -> Infos=[] % only have one virtual root
2308 ; get_wait_flag_infos(WF,Infos) %portray_wait_flag_infos(Infos),
2309 % Warning: these Infos can be large terms which get asserted below; they contain the call-stack
2310 ),
2311 PrevArgInstantiated = root(Infos)
2312 ),
2313 register_instantiation(ArgInstantiated,PrevArgInstantiated,Level),
2314 L1 is Level+1,
2315 put_wf_dynamic_info(WF,instantiation_info,lvl_prev(L1,ArgInstantiated)).
2316
2317 reset_observe :- retractall(instantiation_level_reached(_)),
2318 retractall(instantiation_link(_,_,_,_)).
2319
2320 portray_instantiations :-
2321 (instantiation_level_reached(0) -> true),
2322 format('--- ProB instantiation patterns observed ---~n',[]),
2323 instantiation_link(root(Infos),_,0,_),
2324 format('*PATTERNS*~n',[]),
2325 portray_wait_flag_infos(Infos),
2326 (Infos=[],get_preference(provide_trace_information,false)
2327 -> format(' (Set TRACE_INFO preference to TRUE to obtain more information.)~n',[])
2328 ; true),
2329 portray_inst(0,root(Infos)),
2330 fail.
2331 portray_instantiations.
2332
2333 % portray how the instantiations occurred
2334 portray_inst(Level,ArgStr) :-
2335 instantiation_link(ArgStr,Successor,Level,Hits),
2336 i_indent(Level), format(' ~w hits : ~w~n',[Hits,Successor]),
2337 L1 is Level+1,
2338 portray_inst(L1,Successor).
2339
2340 i_indent(X) :- X < 1, !, write('->').
2341 i_indent(X) :- write('-+'), X1 is X-1, i_indent(X1).
2342
2343 % ---------------
2344
2345 :- public observe_indent/5.
2346 expects_spaninfo('observe_indent').
2347 expects_unevaluated_args('observe_indent').
2348 expects_waitflag('observe_indent').
2349 external_pred_always_true('observe_indent').
2350 external_fun_type('observe_indent',[T],[T,boolean]).
2351 % observe pairs of values
2352 observe_indent(Value,PredRes,UnEvalArgs,Span,WF) :-
2353 observe2(Value,PredRes,UnEvalArgs,no_trace,Span,WF).
2354
2355 :- public tobserve/5.
2356 expects_spaninfo('tobserve'). % observe_indent but with tracing enabled
2357 expects_unevaluated_args('tobserve').
2358 expects_waitflag('tobserve').
2359 external_pred_always_true('tobserve').
2360 tobserve(Value,PredRes,UnEvalArgs,Span,WF) :-
2361 observe2(Value,PredRes,UnEvalArgs,trace,Span,WF).
2362
2363 observe2(Value,PredRes,[Arg],Trace,Span,WF) :- PredRes=pred_true,
2364 %kernel_waitflags:portray_waitflags(WF),
2365 kernel_waitflags:get_wait_flag0(WF,WF0),
2366 kernel_waitflags:get_wait_flag1(observe,WF,WF1),
2367 when(nonvar(WF0),(indent_format(user_output,'WAITFLAG 0 set~n',[],no_trace),kernel_waitflags:portray_waitflags(WF))),
2368 when(nonvar(WF1),(indent_format(user_output,'WAITFLAG 1 set~n',[],no_trace),kernel_waitflags:portray_waitflags(WF))),
2369 Hook = print_value_as_table_if_possible(Arg,Value),
2370 observe_aux(Value,Arg,1,_,Trace,Span,Hook),
2371 iprintf(string("observe full value complete: ~w~n~n"),Value,_,Span).
2372
2373 :- use_module(extrasrc(table_tools),[print_value_as_table/2]).
2374 :- public print_value_as_table_if_possible/2. % used as hook above
2375 %print_value_as_table_if_possible(_,_) :- !.
2376 print_value_as_table_if_possible(Arg,Value) :-
2377 translate:print_bexpr(Arg),nl,
2378 (print_value_as_table(Arg,Value) -> true ; true).
2379
2380 observe_aux((V1,V2),b(couple(A1,A2),_,_),Nr,R,Trace,Span,Hook) :- !,
2381 observe_aux(V1,A1,Nr,N1,Trace,Span,Hook),
2382 observe_aux(V2,A2,N1,R,Trace,Span,Hook).
2383 observe_aux(V,Arg,Nr,R,Trace,Span,Hook) :- R is Nr+1,
2384 translate:translate_bexpression(Arg,ArgString), %print(obs(Nr,ArgString)),nl,
2385 atom_codes(ArgString,ArgCodes),
2386 observe_value(V,ArgCodes,Nr,Trace,Span,Hook).
2387
2388 % entry for other modules:
2389 observe_value(Value,Info) :- (Info=[_|_] -> PCodes = Info ; atom_codes(Info,PCodes)),
2390 observe_value(Value,PCodes,1,no_trace,unknown,true).
2391
2392 observe_value(Value,ArgCodes,Nr,Trace,Span,Hook) :- %print(obs(Nr,ArgString)),nl,
2393 number_codes(Nr,NrCodes), append(NrCodes,") = ~w~n",Tail1), append(" (",Tail1,Tail2),
2394 append(ArgCodes,Tail2,FormatString),
2395 observe_set(Value,ArgCodes,1,Trace,Span,Value,Hook),
2396 when((ground(FormatString),ground(Value)),ifprintf2(user_output,FormatString,Value,Trace,Span)).
2397 observe_value_with_full_value(Value,ArgCodes,Nr,Trace,Span,FullValue,Hook) :- %print(obs(Nr,ArgString)),nl,
2398 number_codes(Nr,NrCodes), append(NrCodes,"):FULL = ~w~n",Tail1), append(" (",Tail1,Tail2),
2399 append(ArgCodes,Tail2,FormatString),
2400 observe_set(Value,ArgCodes,1,Trace,Span,Value,Hook),
2401 when((ground(FormatString),ground(Value)),
2402 observe_ground(FormatString,Value,FullValue,Trace,Span,Hook)).
2403
2404 observe_ground(FormatString,Value,FullValue,Trace,Span,Hook) :-
2405 ifprintf2(user_output,FormatString,rec([field(value,Value),field(full,FullValue)]),Trace,Span),
2406 (call(Hook) -> true ; print(hook_failed(Hook)),nl).
2407
2408
2409
2410 % observe sets and records:
2411 :- block observe_set(-,?,?,?,?,?,?).
2412 observe_set([],_ArgCodes,_,_Trace,_Span,_,_) :- !.
2413 observe_set([Value|T],ArgCodes,Pos,Trace,Span,FullValue,Hook) :- !, %print(obs(Value,Pos)),nl,
2414 append(ArgCodes," el -> ",ArgN),
2415 observe_value_with_full_value(Value,ArgN,Pos,Trace,Span,FullValue,Hook),
2416 %tools_files:put_codes(ArgN,user_output),print(Pos),print(' = '),tools_printing:print_arg(Value),nl,
2417 P1 is Pos+1, observe_set(T,ArgCodes,P1,Trace,Span,FullValue,Hook).
2418 observe_set((V1,V2),ArgCodes,Pos,Trace,Span,FullValue,Hook) :-
2419 preferences:preference(observe_precise_values,true),
2420 !, %print(obs(Value,Pos)),nl,
2421 append(ArgCodes," prj1 -> ",ArgN1),
2422 observe_value_with_full_value(V1,ArgN1,Pos,Trace,Span,FullValue,Hook),
2423 %tools_files:put_codes(ArgN,user_output),print(Pos),print(' = '),tools_printing:print_arg(Value),nl,
2424 Pos2 is Pos+1,
2425 append(ArgCodes," prj2 -> ",ArgN2),
2426 observe_value_with_full_value(V2,ArgN2,Pos2,Trace,Span,FullValue,Hook).
2427 observe_set(rec(Fields),ArgCodes,Pos,Trace,Span,_FullValue,Hook) :-
2428 preferences:preference(observe_precise_values,true),
2429 !,
2430 append(ArgCodes," rec -> ",ArgN),
2431 observe_field(Fields,ArgN,Pos,Trace,Span,Hook).
2432 observe_set(_,_,_,_,_,_,_).
2433
2434 :- block observe_field(-,?,?,?,?,?).
2435 observe_field([],ArgN,Pos,Trace,Span,_Hook) :-
2436 append(ArgN," complete (~w)~n",FormatString),
2437 ifprintf2(user_output,FormatString,Pos,Trace,Span).
2438 observe_field([field(Name,Value)|TFields],ArgN,Pos,Trace,Span,Hook) :-
2439 observe_value((string(Name),Value),ArgN,Pos,Trace,Span,Hook),
2440 observe_field(TFields,ArgN,Pos,Trace,Span,Hook).
2441
2442 :- use_module(bsyntaxtree,[get_texpr_id/2]).
2443 :- use_module(store,[lookup_value_with_span_wf/6]).
2444 % utility function for other modules to use observe on parameters
2445 observe_parameters(Parameters,LocalState) :-
2446 skel(LocalState,SetupDone),
2447 reset_ident, reset_walltime,
2448 when(nonvar(SetupDone),observe_parameters_aux(Parameters,1,LocalState)).
2449 :- block skel(-,?).
2450 skel([],pred_true).
2451 skel([_|T],Done) :- skel(T,Done).
2452 :- block observe_parameters_aux(-,?,?), observe_parameters_aux(?,?,-).
2453 observe_parameters_aux([],_,_).
2454 observe_parameters_aux([TID|T],Nr,LS) :-
2455 safe_get_texpr_id(TID,ID), atom_codes(ID,PCodes),
2456 lookup_value_with_span_wf(ID,[],LS,Value,TID,no_wf_available),
2457 debug_println(9,observing(ID,Value,LS)),
2458 Hook = print_value_as_table_if_possible(TID,Value),
2459 observe_value(Value,PCodes,Nr,no_trace,unknown,Hook),
2460 N1 is Nr+1,
2461 observe_parameters_aux(T,N1,LS).
2462 safe_get_texpr_id(TID,ID) :- (atom(TID) -> ID=TID ; get_texpr_id(TID,ID)).
2463
2464 construct_bind(Id,V,bind(Id,V)).
2465 % observe a list of identifiers and values
2466 :- public observe_state/2. % debugging utility
2467 observe_state(Ids,Values) :-
2468 maplist(construct_bind,Ids,Values,State),!,
2469 observe_state(State).
2470 observe_state(Ids,Values) :- add_internal_error('Illegal id and value lists: ',observe_state(Ids,Values)).
2471
2472 % utility to observe a state using the observe external function
2473 observe_state(State) :-
2474 reset_ident, reset_walltime,
2475 observe_state_aux(State,1).
2476 :- block observe_state_aux(-,?).
2477 observe_state_aux(no_state,_) :- !.
2478 observe_state_aux([],_) :- !.
2479 observe_state_aux(concrete_constants(C),Nr) :- !, observe_state_aux(C,Nr).
2480 observe_state_aux([Binding|T],Nr) :- get_binding_value(Binding,Nr,PCodes,Value),!,
2481 %print(observe(Id,Value,Nr,T)),nl,
2482 observe_value(Value,PCodes,Nr,no_trace,unknown,true),
2483 N1 is Nr+1,
2484 observe_state_aux(T,N1).
2485 observe_state_aux(State,Nr) :- add_internal_error('Illegal state: ',observe_state_aux(State,Nr)).
2486
2487 :- block get_binding_value(-,?,?,?).
2488 get_binding_value(bind(Id,Value),_,PCodes,Value) :- atom_codes(Id,PCodes).
2489 get_binding_value(typedval(Value,_Type,Id,_Trigger),_,PCodes,Value) :- atom_codes(Id,PCodes).
2490 get_binding_value(Value,Nr,PCodes,Value) :- number_codes(Nr,PCodes). % we have just a list of values without ids
2491
2492
2493 external_fun_type('observe_fun',[X],[X,boolean]).
2494 expects_unevaluated_args('observe_fun').
2495 external_pred_always_true('observe_fun').
2496 :- public observe_fun/3.
2497 % a specific predicate to observe enumeration of functions,...
2498 :- block observe_fun(-,-,?).
2499 observe_fun(Value,PredRes,[UnEvalArg]) :-
2500 translate:translate_bexpression(UnEvalArg,Str), format('Observe function : ~w~n',[Str]),
2501 obs_fun(Value,Str,Value),PredRes=pred_true.
2502
2503 :- block obs_fun(-,?,?).
2504 obs_fun([],_,_) :- !.
2505 obs_fun([(A,B)|T],Str,FullVal) :- !,
2506 obs_idx(A,B,Str,FullVal),
2507 obs_fun(T,Str,FullVal).
2508 obs_fun(V,Str,_) :- print(uncovered_obs_fun(V,Str)),nl.
2509
2510 :- block obs_idx(-,?,?,?), obs_idx(?,-,?,?).
2511 obs_idx(A,B,Str,FullVal) :-
2512 when(ground((A,B)),obs_idx_complete(FullVal,A,B,Str)).
2513
2514 obs_idx_complete(FullVal,A,B,Str) :-
2515 format('~n ~w = ',[Str]),obs_idx_complete_aux(FullVal,A,B).
2516 obs_idx_complete(FullVal,A,B,Str) :-
2517 format('~n [BACKTRACK] ~w = ',[Str]),obs_idx_complete_aux(FullVal,A,B),fail.
2518
2519 obs_idx_complete_aux(V,_,_) :- var(V),!,print(' OPEN '),nl.
2520 obs_idx_complete_aux([],_,_) :- !, nl.
2521 obs_idx_complete_aux([(X,Y)|T],A,B) :- !,
2522 ((X,Y)==(A,B) -> print(' * ') ; print(' ')), print_bvalue((X,Y)),
2523 obs_idx_complete_aux(T,A,B).
2524 obs_idx_complete_aux(_,_,_) :- print(unknown),nl.
2525
2526
2527 % -----------------------------
2528
2529 :- public tprintf/4.
2530 expects_spaninfo('tprintf').
2531 external_pred_always_true('tprintf').
2532 % a debugging version that switches into trace mode
2533 :- block tprintf(-,?,?,?), tprintf(?,-,?,?).
2534 tprintf(string(FormatString),Value,PredRes,Span) :- PredRes = pred_true,
2535 when((ground(FormatString),ground(Value)),
2536 (fprintf2(user_output,FormatString,Value,Span),
2537 try_trace %,print_profile,set_prolog_flag(profiling,on)
2538 )).
2539
2540 :- public 'prolog_printf'/5.
2541 expects_spaninfo('prolog_printf').
2542 expects_waitflag('prolog_printf').
2543 external_pred_always_true('prolog_printf').
2544 prolog_printf(string(FormatString),Value,PredRes,Span,WF) :- PredRes = pred_true,
2545 file_format(user_output,FormatString,[initial(Value,WF)],Span),
2546 when(nonvar(Value),file_format(user_output,FormatString,[nonvar(Value,WF)],Span)),
2547 when((ground(FormatString),ground(Value)),
2548 fprintf2(user_output,FormatString,Value,Span)).
2549
2550 % vprintf: expression which returns argument as value
2551 expects_spaninfo('vprintf').
2552 external_fun_type('vprintf',[T],[string,T,T]).
2553 :- public vprintf/4.
2554 vprintf(Format,Value,ValueRes,Span) :-
2555 printf(Format,[(int(1),Value)],pred_true,Span), % use itprintf for tracing
2556 equal_object(Value,ValueRes,vprintf). % we could generate a version which only instantiates when printing done
2557 expects_spaninfo('fvprintf').
2558 :- public fvprintf/5.
2559 fvprintf(File,Format,Value,ValueRes,Span) :-
2560 fprintf(File,Format,[(int(1),Value)],pred_true,Span),
2561 equal_object(Value,ValueRes,fvprintf). % we could generate a version which only instantiates when printing done
2562
2563
2564 % PRINT a single value as substitution
2565 performs_io('PRINT').
2566 external_subst_enabling_condition('PRINT',_,Truth) :- create_texpr(truth,pred,[],Truth).
2567 does_not_modify_state('PRINT').
2568 :- public 'PRINT'/3.
2569 :- block 'PRINT'(-,?,?), 'PRINT'(?,-,?).
2570 'PRINT'(Val,_Env,OutEnv) :- %print('PRINT : '), print(Env),nl,
2571 assert_side_effect_occurred(user_output),
2572 print_value(Val),nl, OutEnv=[].
2573
2574 % PRINT a single value as substitution; show backtracking
2575 performs_io('PRINT_BT').
2576 perform_directly('PRINT_BT').
2577 external_subst_enabling_condition('PRINT_BT',_,Truth) :- create_texpr(truth,pred,[],Truth).
2578 does_not_modify_state('PRINT_BT').
2579 :- public 'PRINT_BT'/3.
2580 :- block 'PRINT_BT'(-,?,?), 'PRINT_BT'(?,-,?).
2581 'PRINT_BT'(Val,_Env,OutEnv) :- %print('PRINT : '), print(Env),nl,
2582 assert_side_effect_occurred(user_output),
2583 print_value(Val),nl, OutEnv=[].
2584 'PRINT_BT'(Val,_Env,_OutEnv) :-
2585 assert_side_effect_occurred(user_output),
2586 print('BACKTRACKING: '),print_value(Val),nl, fail.
2587
2588 print_value(Val) :- translate:translate_bvalue(Val,TV), print(TV).
2589
2590
2591 performs_io('DEBUG_PRINT_STATE').
2592 external_subst_enabling_condition('DEBUG_PRINT_STATE',_,Truth) :- create_texpr(truth,pred,[],Truth).
2593 does_not_modify_state('DEBUG_PRINT_STATE').
2594 :- public 'DEBUG_PRINT_STATE'/3.
2595 :- block 'DEBUG_PRINT_STATE'(-,?,?).
2596 'DEBUG_PRINT_STATE'(Value,Env,OutEnv) :-
2597 assert_side_effect_occurred(user_output),
2598 print_value(Value),translate:print_bstate(Env),nl, OutEnv=[].
2599
2600 % PRINTF as substitution
2601 expects_spaninfo('PRINTF').
2602 performs_io('PRINTF').
2603 external_subst_enabling_condition('PRINTF',_,Truth) :- create_texpr(truth,pred,[],Truth).
2604 does_not_modify_state('PRINTF').
2605 :- public 'PRINTF'/5.
2606 :- block 'PRINTF'(-,?,?,?,?), 'PRINTF'(?,-,?,?,?), 'PRINTF'(?,?,-,?,?).
2607 'PRINTF'(string(FormatString),Value,_Env,OutEnvModifications,Span) :-
2608 % print('PRINTF'(FormatString,Value,_Env)),nl,
2609 when((ground(FormatString),ground(Value)),
2610 (fprintf2(user_output,FormatString,Value,Span),
2611 OutEnvModifications=[] /* substitution finished */
2612 )).
2613
2614 expects_spaninfo('FPRINTF').
2615 performs_io('FPRINTF').
2616 external_subst_enabling_condition('FPRINTF',_,Truth) :- create_texpr(truth,pred,[],Truth).
2617 does_not_modify_state('FPRINTF').
2618 :- public 'FPRINTF'/6.
2619 :- block 'FPRINTF'(-,?,?,?,?,?), 'FPRINTF'(?,-,?,?,?,?), 'FPRINTF'(?,?,-,?,?,?).
2620 'FPRINTF'(string(File),string(FormatString),Value,_Env,OutEnvModifications,Span) :-
2621 when((ground(FormatString),ground(Value)),
2622 (fprintf2(File,FormatString,Value,Span),
2623 OutEnvModifications=[] /* substitution finished */
2624 )).
2625
2626 file_format(user_output,FormatString,Args,Span) :- !,
2627 assert_side_effect_occurred(user_output),
2628 safe_call(myformat(user_output,FormatString,Args,Span),Span).
2629 file_format(File,FormatString,Args,Span) :-
2630 open(File,append,Stream,[encoding(utf8)]),
2631 assert_side_effect_occurred(file),
2632 safe_call(myformat(Stream,FormatString,Args,Span),Span),
2633 close(Stream). % TO DO: call_cleanup
2634
2635 % Simple check if the user forgot to put format specifiers in the format string.
2636 format_string_is_missing_tildes(FormatString) :-
2637 atom_codes(FormatString, Codes),
2638 \+ memberchk(0'~, Codes).
2639
2640 :- meta_predicate catch_format_error(0, 0).
2641 catch_format_error(Goal, Recover) :-
2642 catch(
2643 catch(
2644 Goal,
2645 error(consistency_error(_,_,format_arguments),_), % SICStus
2646 Recover),
2647 error(format(_Message),_), % SWI
2648 Recover).
2649
2650 :- public myformat/4.
2651 myformat(Stream,FormatString,Args,Span) :-
2652 catch_format_error(
2653 (Args \== [], format_string_is_missing_tildes(FormatString) ->
2654 % backup: the user has not provided ~w annotations:
2655 % instead print just the format string and then all arguments separately.
2656 % This case was previously detected by catching format errors,
2657 % but this causes problems with incomplete or duplicated output on SWI,
2658 % because SWI reports errors only during printing
2659 % (unlike SICStus, which checks the entire format string before printing anything).
2660 format(Stream,FormatString,[]),
2661 nl(Stream),
2662 format_args(Stream,Args)
2663 ; format(Stream,FormatString,Args)
2664 ),
2665 (length(Args,NrArgs),
2666 ajoin(['Illegal format string, expecting ',NrArgs,' ~w arguments (see SICStus Prolog reference manual for syntax):'],Msg),
2667 add_error(external_functions,Msg,FormatString,Span),
2668 format_args(Stream,Args))
2669 ),
2670 flush_output(Stream).
2671
2672 format_args(_Stream,[]).
2673 format_args(Stream,[H|T]) :- format(Stream,'~w~n',H), format_args(Stream,T).
2674
2675 % a format with indentation and backtracking info:
2676 :- dynamic indentation_level/1.
2677 indentation_level(0).
2678 inc_indent :- retract(indentation_level(X)), X1 is X+1, assertz(indentation_level(X1)).
2679 dec_indent :- retract(indentation_level(X)), X1 is X-1, assertz(indentation_level(X1)).
2680 reset_ident :- retractall(indentation_level(_)), assertz(indentation_level(0)).
2681 get_indent_level(L) :- indentation_level(LL), L is ceiling(sqrt(LL)).
2682 indent(Stream) :- get_indent_level(L), %(L>28 -> trace ; true),
2683 indent_aux(L,Stream).
2684 indent_aux(X,Stream) :- X < 1, !, write(Stream,' ').
2685 indent_aux(X,Stream) :- write(Stream,'+-'), X1 is X-1, indent_aux(X1,Stream).
2686
2687 indent_format(Stream,Format,Args,Trace) :- inc_indent,
2688 indent(Stream), format(Stream,Format,Args),
2689 print_walltime(Stream),
2690 % my_term_hash(Args,Hash), format(Stream,'[hash ~w]~n',[Hash]), (Hash=101755762 -> trace ; true), %%
2691 flush_output(Stream),
2692 (Trace=trace -> try_trace ; true).
2693 %indent_format(_Stream,_Format,Args,_Trace) :- my_term_hash(Args,Hash),(Hash=553878463258718990 -> try_trace).
2694 indent_format(Stream,Format,Args,Trace) :-
2695 indent(Stream), write(Stream,'BACKTRACKING '),
2696 % my_term_hash(Args,Hash), format(Stream,'[hash ~w] ',[Hash]), %% (Hash=553878463258718990 -> try_trace ; true), %%
2697 format(Stream,Format,Args),
2698 print_walltime(Stream), %% comment in to see walltime info
2699 flush_output(Stream),
2700 dec_indent,
2701 (Trace=trace -> try_trace ; true),
2702 fail.
2703
2704 :- dynamic ref_walltime/1, prev_walltime/1.
2705 reset_walltime :- retractall(prev_walltime(_)), retractall(ref_walltime(_)),
2706 statistics(walltime,[WT,_]),
2707 assertz(prev_walltime(WT)),
2708 assertz(ref_walltime(WT)).
2709 print_walltime(File) :- statistics(walltime,[WT,_]),
2710 (ref_walltime(RefWT) -> RWT is WT-RefWT ; RWT = 0, assertz(ref_walltime(WT))),
2711 (retract(prev_walltime(PWT)) -> T is WT-PWT, indent(File),format(File,' ~w ms (walltime; total ~w ms)~n',[T,RWT])
2712 ; true),
2713 assertz(prev_walltime(WT)).
2714 :- public 'TRACE'/2.
2715 :- block 'TRACE'(-,?).
2716 'TRACE'(pred_true,R) :- !,trace,R=pred_true.
2717 'TRACE'(pred_false,pred_true).
2718
2719 % --------------------------------------------
2720
2721 % ARGV, ARGC
2722
2723 :- dynamic argv_string/2, argc_number/1.
2724 argc_number(0).
2725 reset_argv :-
2726 retractall(argv_string(_,_)),
2727 retractall(argc_number(_)),
2728 assertz(argc_number(0)).
2729
2730 :- use_module(kernel_strings,[split_atom_string/3]).
2731 % call to set the commandline arguments, e.g., from probcli
2732 set_argv_from_atom(X) :-
2733 retractall(argv_string(_,_)),
2734 retractall(argc_number(_)),
2735 split_atom_string(X,' ',List),
2736 set_argv_from_list(List).
2737 set_argv_from_list(List) :-
2738 retractall(argv_string(_,_)),
2739 retractall(argc_number(_)),
2740 set_argv_from_list_aux(List).
2741 set_argv_from_list_aux(List) :-
2742 length(List,Len),
2743 assertz(argc_number(Len)),
2744 debug:debug_println(9,argc(Len)),
2745 nth1(N,List,String), % we number the arguments in B style
2746 debug:debug_println(9,argv(N,String)),
2747 assertz(argv_string(N,String)),
2748 fail.
2749 set_argv_from_list_aux(_).
2750
2751 external_fun_type('ARGV',[],[integer,string]).
2752 % access to the command-line arguments provided to probcli (after --)
2753 % first argument is ARGV(1) not ARGV(0)
2754 :- public 'ARGV'/2.
2755 :- block 'ARGV'(-,?).
2756 'ARGV'(int(N),S) :- argv2(N,S).
2757 :- block argv2(-,?).
2758 argv2(Nr,Res) :- % print(get_argv(Nr,Res)),nl,
2759 (argv_string(Nr,S) -> Res=string(S)
2760 ; Nr=0 -> add_error(external_functions,'Command-line argument does not exist, numbering starts at 1: ',Nr), Res=string('')
2761 ; add_error(external_functions,'Command-line argument does not exist: ',Nr), Res=string('')).
2762
2763 external_fun_type('ARGC',[],[integer]).
2764 :- public 'ARGC'/1.
2765 'ARGC'(int(X)) :- argc_number(X).
2766
2767 % --------------------------------------------
2768
2769 % RANDOM
2770
2771
2772 :- assert_must_succeed(( external_functions:call_external_function('RANDOM',[0,1],[int(0),int(1)],int(0),integer,unknown,_WF) )).
2773 :- use_module(library(random),[random/3, random/1]).
2774
2775 % Generate a random number >= Low and < Up
2776 % warning: this is not a mathematical function
2777 % example usage r=RANDOM(1,6)
2778 :- public 'RANDOM'/3.
2779 is_not_declarative('RANDOM').
2780 external_fun_type('RANDOM',[],[integer,integer,integer]).
2781 :- block 'RANDOM'(-,?,?), 'RANDOM'(?,-,?).
2782 'RANDOM'(int(Low),int(Up),int(R)) :- random2(Low,Up,R).
2783 :- block random2(-,?,?), random2(?,-,?).
2784 random2(L,U,R) :- random(L, U, R). % also works with reals
2785
2786 :- public 'RAND'/3.
2787 % example usage r=RAND(0.0,1.0)
2788 is_not_declarative('RAND').
2789 external_fun_type('RAND',[],[real,real,real]).
2790 :- block 'RAND'(-,?,?), 'RAND'(?,-,?).
2791 'RAND'(RLow,Rup,RR) :- is_real(RLow,Low),
2792 is_real(Rup,Up), is_real(RR,R),
2793 random2(Low,Up,R).
2794
2795
2796 :- use_module(library(between),[between/3]).
2797 :- public 'RAND_SAMPLES'/4.
2798 % example usage r=RAND_SAMPLES(5,0.0,1.0) % takes 5 samples and returns as set
2799 is_not_declarative('RAND_SAMPLES').
2800 external_fun_type('RAND_SAMPLES',[],[integer,real,real,set(real)]).
2801 :- block 'RAND_SAMPLES'(-,?,?,?), 'RAND_SAMPLES'(?,-,?,?), 'RAND_SAMPLES'(?,?,-,?).
2802 'RAND_SAMPLES'(int(Samples),RLow,Rup,RSet) :- is_real(RLow,Low),
2803 is_real(Rup,Up), is_real(RR,R),
2804 findall(RR,(between(1,Samples,_),random2(Low,Up,R)), List),
2805 kernel_objects:equal_object_optimized(List,RSet).
2806
2807
2808 :- public 'RAND_BOOL'/2.
2809 % example usage r=RAND_BOOL(0.2) -> 20 % chance of returning TRUE
2810 is_not_declarative('RAND_BOOL').
2811 external_fun_type('RAND_BOOL',[],[real,boolean]).
2812 :- block 'RAND_BOOL'(-,?).
2813 'RAND_BOOL'(Rlim,RR) :- is_real(Rlim,Limit),
2814 random(X),
2815 (X =< Limit -> RR=pred_true ; RR=pred_false).
2816
2817 % TODO: RANDOM_VALUE({0.2|->"a",0.8|->"b"})
2818
2819 % pick a random element from a set
2820 :- public 'random_element'/4.
2821 is_not_declarative('random_element').
2822 external_fun_type('random_element',[T],[set(T),T]).
2823 expects_waitflag('random_element').
2824 expects_spaninfo('random_element').
2825 :- block 'random_element'(-,?,?,?).
2826 random_element([],_,Span,WF) :- !,
2827 add_wd_error_span('random_element applied to empty set: ',[],Span,WF).
2828 random_element([H|T],El,_,WF) :- !,
2829 expand_custom_set_to_list_wf(T,ET,_Done,'random_element',WF),
2830 block_length(ET,1,Len),
2831 random_select_from_list([H|ET],Len,El).
2832 random_element(CS,Res,_,_) :- is_interval_closure_or_integerset(CS,Low,Up,finite),!, % TODO: also support reals
2833 U1 is Up+1,
2834 random(Low,U1,H), Res = int(H).
2835 random_element(CS,X,Span,WF) :-
2836 custom_explicit_sets:expand_custom_set_wf(CS,ER,random_element,WF),
2837 random_element(ER,X,Span,WF).
2838
2839 :- block block_length(-,?,?).
2840 block_length([],Acc,Acc).
2841 block_length([_|T],Acc,R) :- A1 is Acc+1, block_length(T,A1,R).
2842
2843 :- use_module(library(random),[random_member/2]).
2844 :- block random_select_from_list(?,-,?).
2845 random_select_from_list(List,_,Res) :-
2846 random_member(El,List),
2847 kernel_objects:equal_object(El,Res).
2848
2849 :- use_module(library(random),[random_numlist/4]).
2850 :- public 'random_numset'/6.
2851 is_not_declarative('random_numset').
2852 external_fun_type('random_numset',[],[integer,integer,integer,integer,set(integer)]).
2853 expects_waitflag('random_numset').
2854 :- block random_numset(-,?,?,?,?,?),random_numset(?,-,?,?,?,?),random_numset(?,?,-,?,?,?),random_numset(?,?,?,-,?,?).
2855 random_numset(int(P),int(Q),int(Low),int(Up),Res,WF) :-
2856 Prob is P/Q,
2857 random_numlist(Prob,Low,Up,List),
2858 maplist(gen_int,List,IntList),
2859 kernel_objects:equal_object_optimized_wf(IntList,Res,random_numset,WF).
2860
2861 gen_int(I,int(I)).
2862
2863
2864 :- public 'NORMAL'/3.
2865 is_not_declarative('NORMAL').
2866 external_fun_type('NORMAL',[],[integer,integer,integer]).
2867 % GAUSSIAN Distribution
2868 :- block 'NORMAL'(-,?,?), 'NORMAL'(?,-,?).
2869 'NORMAL'(int(Mu),int(Sigma),int(R)) :- random_normal(Mu,Sigma,R).
2870
2871 :- block random_normal(-,?,-), random_normal(?,-,?).
2872 random_normal(Mu,Sigma,R) :-
2873 random_normal(N),
2874 R is round(Mu+N*Sigma).
2875
2876 :- use_module(kernel_reals,[is_real/2]).
2877 :- public 'RNORMAL'/3.
2878 is_not_declarative('RNORMAL').
2879 external_fun_type('RNORMAL',[],[real,real,real]).
2880 :- block 'RNORMAL'(-,?,?), 'RNORMAL'(?,-,?).
2881 'RNORMAL'(RMU,RSigma,RR) :- is_real(RMU,MU),
2882 is_real(RSigma,Sigma), is_real(RR,R),
2883 random_normal_real(MU,Sigma,R).
2884
2885 :- block random_normal_real(-,?,-), random_normal_real(?,-,?).
2886 random_normal_real(Mu,Sigma,R) :-
2887 random_normal(N),
2888 R is (Mu+N*Sigma).
2889
2890 % inspired by: https://stackoverflow.com/questions/44503752/how-to-generate-normal-distributed-random-numbers-in-prolog
2891 % https://en.wikipedia.org/wiki/Box–Muller_transform
2892 :- dynamic cached_gauss/1.
2893 :- use_module(library(random),[random/1]).
2894 random_normal(R) :- retract(cached_gauss(N)),!,R=N.
2895 random_normal(R) :-
2896 random(U1), random(U2),
2897 Z0 is sqrt(-2 * log(U1)) * cos(2*pi*U2),
2898 Z1 is sqrt(-2 * log(U1)) * sin(2*pi*U2),
2899 assertz(cached_gauss(Z1)),
2900 R = Z0.
2901
2902 :- public 'RPOISSON_COUNT'/2.
2903 is_not_declarative('RPOISSON_COUNT').
2904 external_fun_type('RPOISSON_COUNT',[],[real,integer]).
2905 % draw number of arrivals (integer) within a time-unit of a Poisson distribution
2906 % Note: REXP(-746.0) = 0.0 -> so all values >= 746 lead to same distribution
2907 % TODO: try out other implementation, https://www.johndcook.com/blog/2010/06/14/generating-poisson-random-values/?
2908 :- block 'RPOISSON_COUNT'(-,?).
2909 'RPOISSON_COUNT'(RLambda,Res) :-
2910 is_real(RLambda,Lambda),
2911 poisson_real(Lambda,Res).
2912 :- block poisson_real(-,?).
2913 poisson_real(Lambda,Res) :-
2914 L is exp(-Lambda),
2915 iterate_poisson(0,1.0,L,Res).
2916
2917 % Knuth's Algorithm for generating random samples from a Poisson distribution
2918 % The complexity is linear in the returned value k, which is λ on average.
2919 % https://en.wikipedia.org/wiki/Poisson_distribution#Generating_Poisson-distributed_random_variables
2920 iterate_poisson(K,P,L,Res) :-
2921 random(U), P1 is P*U,
2922 P1 > L,!,
2923 K1 is K+1, iterate_poisson(K1,P1,L,Res).
2924 iterate_poisson(K,_,_,int(K)).
2925
2926 :- public 'RPOISSON_WAIT'/2.
2927 % RPOISSON_WAIT(lambda) == -RLOGe(RAND(0.0,1.0))/lambda;
2928 is_not_declarative('RPOISSON_WAIT').
2929 external_fun_type('RPOISSON_WAIT',[],[real,real]).
2930 % draw number of arrivals (integer) within a time-unit of a Poisson distribution
2931 :- block 'RPOISSON_WAIT'(-,?).
2932 'RPOISSON_WAIT'(RLambda,Res) :-
2933 is_real(RLambda,Lambda),
2934 poisson_wait_real(Lambda,Res).
2935 :- block poisson_wait_real(-,?).
2936 poisson_wait_real(Lambda,Res) :-
2937 random(U),
2938 R is -log(U)/Lambda,
2939 is_real(Res,R).
2940
2941
2942 % generates a random subset of a finite set
2943 :- public 'random_subset'/4.
2944 is_not_declarative('random_subset').
2945 external_fun_type('random_subset',[T],[set(T),set(T)]).
2946 expects_waitflag('random_subset').
2947 expects_spaninfo('random_subset').
2948 :- block 'random_subset'(-,?,?,?).
2949 random_subset(Set,Subset,Span,WF) :- !,
2950 expand_custom_set_to_list_wf(Set,ESet,Done,'random_subset',WF),
2951 random_subset_aux(Done,ESet,Subset,Span,WF).
2952
2953 :- use_module(library(random),[random_subseq/3]).
2954 :- block random_subset_aux(-,?,?,?,?).
2955 random_subset_aux(_Done,ESet,Subset,_Span,WF) :-
2956 random_subseq(ESet,Result,_Rest),
2957 kernel_objects:equal_object_wf(Result,Subset,WF).
2958
2959 % generates a random subset of a finite set
2960 :- public 'random_ordering'/4.
2961 is_not_declarative('random_ordering').
2962 external_fun_type('random_ordering',[T],[set(T),seq(T)]).
2963 expects_waitflag('random_ordering').
2964 expects_spaninfo('random_ordering').
2965 :- block 'random_ordering'(-,?,?,?).
2966 random_ordering(Set,Permutation,Span,WF) :- !,
2967 expand_custom_set_to_list_wf(Set,ESet,Done,'random_ordering',WF),
2968 random_perm_aux(Done,ESet,Permutation,Span,WF).
2969
2970 :- use_module(library(random),[random_permutation/2]).
2971 :- block random_perm_aux(-,?,?,?,?).
2972 random_perm_aux(_Done,ESet,Permutation,_Span,_WF) :-
2973 random_permutation(ESet,Result),
2974 convert_list_to_seq(Result,Permutation). % should we call WF version
2975
2976 % generates a random subset of a finite sequence
2977 :- public 'random_permutation'/4.
2978 is_not_declarative('random_permutation').
2979 external_fun_type('random_permutation',[T],[seq(T),seq(T)]).
2980 expects_waitflag('random_permutation').
2981 expects_spaninfo('random_permutation').
2982 :- block 'random_permutation'(-,?,?,?).
2983 random_permutation(Set,Permutation,Span,WF) :- !,
2984 expand_custom_set_to_list_wf(Set,ESet,Done,'random_permutation',WF),
2985 random_perm_seq_aux(Done,ESet,Permutation,Span,WF).
2986
2987 :- block random_perm_seq_aux(-,?,?,?,?).
2988 random_perm_seq_aux(_Done,ESet,Permutation,_Span,_WF) :-
2989 sort(ESet,Sorted),
2990 maplist(drop_index,Sorted,PrologList),
2991 random_permutation(PrologList,Result),
2992 convert_list_to_seq(Result,Permutation). % should we call WF version
2993
2994 drop_index((int(_),El),El).
2995
2996 :- use_module(library(system)).
2997
2998 :- assert_must_succeed(( external_functions:call_external_function('TIME',[y],[string(year)],int(Y),integer,unknown,_WF), number(Y), Y>2011 )).
2999 :- assert_must_succeed(( external_functions:call_external_function('TIME',[m],[string(month)],int(M),integer,unknown,_WF), number(M), M>0, M<13 )).
3000 external_fun_type('TIME',[],[string,integer]).
3001 :- public 'TIME'/2.
3002 is_not_declarative('TIME'). % as time can change with next call
3003 'TIME'(string(S),int(N)) :- time2(S,N).
3004 :- block time2(-,?).
3005 time2(now,N) :- !, now(N). % provide UNIX timesstamp
3006 time2(year,N) :- !,datime(datime(N,_,_,_,_,_)).
3007 time2(month,N) :- !,datime(datime(_,N,_,_,_,_)).
3008 time2(day,N) :- !,datime(datime(_,_,N,_,_,_)).
3009 time2(hour,N) :- !,datime(datime(_,_,_,N,_,_)).
3010 time2(min,N) :- !,datime(datime(_,_,_,_,N,_)).
3011 time2(sec,N) :- !,datime(datime(_,_,_,_,_,N)).
3012 time2(OTHER,_) :- add_error(time2,'Illegal time field (must be now,year,month,day,hour,min,sec): ',OTHER),fail.
3013
3014 :- assert_must_succeed(( external_functions:call_external_function('GET_INFO',[time],[string(time)],string(M),string,unknown,_WF), atom(M) )).
3015 external_fun_type('GET_INFO',[],[string,string]).
3016 :- public 'GET_INFO'/2.
3017 'GET_INFO'(string(S),Res) :- get_info2(S,Res).
3018 :- use_module(library(codesio)).
3019 :- block get_info2(-,?).
3020 get_info2(time,Res) :- !, datime(datime(Year,Month,Day,Hour,Min,Sec)),
3021 (Min<10
3022 -> format_to_codes('~w/~w/~w - ~wh0~w ~ws',[Day,Month,Year,Hour,Min,Sec],Codes)
3023 ; format_to_codes('~w/~w/~w - ~wh~w ~ws',[Day,Month,Year,Hour,Min,Sec],Codes)
3024 ),
3025 atom_codes(INFO, Codes), Res=string(INFO).
3026 get_info2(OTHER,_) :- add_error(time2,'Illegal GET_INFO field (must be time): ',OTHER),fail.
3027
3028 :- public 'TIMESTAMP_INFO'/3.
3029 :- assert_must_succeed(external_functions:'TIMESTAMP_INFO'(string('year'),int(1498484624),int(2017))).
3030 :- assert_must_succeed(external_functions:'TIMESTAMP_INFO'(string('month'),int(1498484624),int(6))).
3031 % second argument is ticks obtained by TIME("now")
3032 external_fun_type('TIMESTAMP_INFO',[],[string,integer,integer]).
3033 :- block 'TIMESTAMP_INFO'(-,-,-).
3034 'TIMESTAMP_INFO'(string(S),int(Ticks),int(Res)) :- time_info2(S,Ticks,Res).
3035 :- block time_info2(-,?,?), time_info2(?,-,?).
3036 time_info2(year,Ticks,N) :- !,datime(Ticks,datime(N,_,_,_,_,_)).
3037 time_info2(month,Ticks,N) :- !,datime(Ticks,datime(_,N,_,_,_,_)).
3038 time_info2(day,Ticks,N) :- !,datime(Ticks,datime(_,_,N,_,_,_)).
3039 time_info2(hour,Ticks,N) :- !,datime(Ticks,datime(_,_,_,N,_,_)).
3040 time_info2(min,Ticks,N) :- !,datime(Ticks,datime(_,_,_,_,N,_)).
3041 time_info2(sec,Ticks,N) :- !,datime(Ticks,datime(_,_,_,_,_,N)).
3042 time_info2(OTHER,_,_) :- add_error(time_info2,'Illegal time field (must be now,year,month,day,hour,min,sec): ',OTHER),fail.
3043
3044 :- public 'TIMESTAMP'/7.
3045 % TIMESTAMP/datime converts between a Unix timestamp (UTC) and *local* time.
3046 % To avoid depending on the system time zone,
3047 % build the timestamp dynamically based on the expected test date.
3048 % This way the timestamp varies slightly depending on the system time zone,
3049 % but the date will always be consistent.
3050 % in LibraryIO.def
3051 :- assert_must_succeed((
3052 datime(Timestamp, datime(2017,6,26,15,43,44)),
3053 % Sanity check to ensure that Timestamp is roughly in the right range.
3054 Timestamp >= 1498437824, Timestamp =< 1498545824,
3055 external_functions:'TIMESTAMP'(int(2017),int(6),int(26),int(H),int(Min),int(S),int(Timestamp)),
3056 H==15, Min==43, S==44
3057 )).
3058 external_fun_type('TIMESTAMP',[],[integer,integer,integer,integer,integer,integer,integer]).
3059 :- block 'TIMESTAMP'(-,-,-,-,-,-,-).
3060 'TIMESTAMP'(int(Y),int(M),int(D),int(H),int(Min),int(S),int(Res)) :-
3061 timestamp2(Y,M,D,H,Min,S,Res).
3062
3063 :- block timestamp2(-,?,?,?,?,?,-), timestamp2(?,-,?,?,?,?,-), timestamp2(?,?,-,?,?,?,-),
3064 timestamp2(?,?,?,-,?,?,-), timestamp2(?,?,?,?,?,-,-).
3065 timestamp2(Y,M,D,H,Min,S,ResTimeStamp) :- datime(ResTimeStamp, datime(Y,M,D,H,Min,S)).
3066
3067
3068 :- public 'WALLTIME'/1.
3069 is_not_declarative('WALLTIME'). % as time can change with next call
3070 'WALLTIME'(int(X)) :- statistics(walltime,[X,_]).
3071
3072 :- volatile last_walltime/1.
3073 :- dynamic last_walltime/1.
3074 :- public 'DELTA_WALLTIME'/1.
3075 is_not_declarative('DELTA_WALLTIME'). % as time can change with next call
3076 'DELTA_WALLTIME'(int(D)) :- statistics(walltime,[X,_]),
3077 (retract(last_walltime(L)) -> D is X-L ; D = 0),
3078 assertz(last_walltime(X)).
3079
3080 :- public 'RUNTIME'/1.
3081 is_not_declarative('RUNTIME'). % as time can change with next call
3082 'RUNTIME'(int(X)) :- statistics(runtime,[X,_]).
3083
3084 :- public 'SLEEP'/3.
3085 external_subst_enabling_condition('SLEEP',_,Truth) :- create_texpr(truth,pred,[],Truth).
3086 :- use_module(library(system),[sleep/1]).
3087 :- block 'SLEEP'(-,?,?), 'SLEEP'(?,-,?).
3088 'SLEEP'(int(X),_Env,OutEnvModifications) :- when(nonvar(X),
3089 (Seconds is X / 1000, sleep(Seconds), OutEnvModifications=[])).
3090 'SLEEP'(term(floating(X)),_Env,OutEnvModifications) :- when(nonvar(X),
3091 (Seconds is X / 1000, sleep(Seconds), OutEnvModifications=[])).
3092
3093
3094 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3095 % check if a given expression is valued in the deterministic phase; warn otherwise
3096
3097 :- use_module(kernel_tools,[ground_value_check/2]).
3098 expects_spaninfo('CHECK_DET').
3099 expects_unevaluated_args('CHECK_DET').
3100 expects_waitflag('CHECK_DET').
3101 :- public 'CHECK_DET'/5.
3102 'CHECK_DET'(Value,PredRes,[UnEvalArg],Span,WF) :-
3103 ground_value_check(Value,Ground),
3104 kernel_waitflags:get_wait_flag0(WF,WF0),
3105 kernel_waitflags:get_wait_flag1(WF,WF1),
3106 PredRes=pred_true,
3107 check_det_aux(Ground,Value,WF0,WF1,UnEvalArg,Span).
3108
3109 :- block check_det_aux(-,?,?,-,?,?).
3110 check_det_aux(Ground,Value,_WF0,_WF1,UnEvalArg,Span) :- var(Ground),!,
3111 translate:translate_bexpression(UnEvalArg,S),
3112 add_error(external_functions,'Argument has not been computed deterministically: ',S,Span),
3113 translate:print_bvalue(Value),nl.
3114 check_det_aux(_Ground,Value,WF0,WF1,UnEvalArg,_Span) :- debug:debug_mode(on),!,
3115 translate:translate_bexpression(UnEvalArg,S),
3116 format('Value determined (WF0=~w,WF1=~w) : ~w~n',[WF0,WF1,S]),
3117 translate:print_bvalue(Value),nl.
3118 check_det_aux(_Ground,_Value,_WF0,_WF1,_UnEvalArgs,_Span).
3119
3120 % check if a given expression has already a ground value when
3121 % the predicate is called
3122
3123 % the predicate is true when the value is ground, false otherwise
3124 :- public 'IS_DETERMINED'/2.
3125 'IS_DETERMINED'(Value,PredRes) :- ground(Value),!,PredRes=pred_true.
3126 'IS_DETERMINED'(_Value,pred_false).
3127
3128 % other variant: the predicate is always true, the information if the variable is written
3129 % to a file to check it later.
3130 expects_spaninfo('IS_DETERMINED_INTO_FILE').
3131 :- public 'IS_DETERMINED_INTO_FILE'/5.
3132 'IS_DETERMINED_INTO_FILE'(FileValue,VariableValue,Value,PredRes,SpanInfo) :-
3133 check_value_is_string(FileValue,'IS_DETERMINED_INTO_FILE','file name',SpanInfo,File),
3134 check_value_is_string(VariableValue,'IS_DETERMINED_INTO_FILE','variable name',SpanInfo,Varname),
3135 ( ground(File) ->
3136 open(File,write,S,[encoding(utf8)]),
3137 call_cleanup( check_determined2(Value,S,Varname), close(S))
3138 ;
3139 add_error(external_functions,'### EXTERNAL Unspecified file in check_determined','',SpanInfo)),
3140 PredRes = pred_true.
3141 check_determined2(Value,S,Varname) :-
3142 check_determined3(Value,Varname,Term),
3143 writeq(S,Term),write(S,'.\n').
3144 check_determined3(Value,Name,Term) :- ground(Value),!,Term=determined_value(Name,Value).
3145 check_determined3(_Value,Name,not_determined_value(Name)).
3146
3147 check_value_is_string(string(S),_PredName,_Location,_SpanInfo,String) :-
3148 !, String=S.
3149 check_value_is_string(Value,PredName,Location,SpanInfo,_String) :-
3150 atom_concat('### EXTERNAL ',PredName,Msg1),
3151 atom_concat(Msg1,': Type error, expected string as ',Msg2),
3152 atom_concat(Msg2,Location,Msg),
3153 add_error(external_functions,Msg,Value,SpanInfo),
3154 fail.
3155
3156
3157 :- public 'SEE'/3.
3158 is_not_declarative('SEE').
3159 :- dynamic open_stream/2.
3160 'SEE'(string(File),_S,[]) :- b_absolute_file_name(File,AFile),
3161 open_stream(AFile,_),!,
3162 print('File already open: '), print(File),nl.
3163 'SEE'(string(File),_S,[]) :-
3164 b_absolute_file_name(File,AFile),
3165 open_absolute_file_for_reading(AFile,_Stream).
3166
3167 open_file_for_reading_if_necessary(File,Stream) :-
3168 b_absolute_file_name(File,AFile),
3169 (open_stream(AFile,S) -> Stream=S
3170 ; open_absolute_file_for_reading(AFile,Stream)).
3171 open_absolute_file_for_reading(AFile,Stream) :-
3172 open(AFile,read,Stream,[encoding(utf8)]),
3173 print(opened_file(AFile,Stream)),nl,
3174 assert_side_effect_occurred(file),
3175 assertz(open_stream(AFile,Stream)).
3176
3177 %correct_file_open_mode(read).
3178 %correct_file_open_mode(write).
3179 %correct_file_open_mode(append).
3180
3181 :- public 'GET_CODE'/2.
3182 performs_io('GET_CODE').
3183 'GET_CODE'(string(File),int(Code)) :-
3184 b_absolute_file_name(File,AFile),
3185 open_stream(AFile,S),
3186 assert_side_effect_occurred(file),
3187 get_code(S,Code). %,print(got_code(S,Code)),nl.
3188
3189 :- public 'GET_CODE_STDIN'/1.
3190 performs_io('GET_CODE_STDIN').
3191 'GET_CODE_STDIN'(int(Code)) :-
3192 get_code(user_input,Code). % can be problematic if called in ProB2UI
3193 % TODO: check get_prob_application_type(prob2) ?
3194
3195 :- public 'SEEN'/3.
3196 is_not_declarative('SEEN').
3197 'SEEN'(string(File),_S,[]) :- b_absolute_file_name(File,AFile),
3198 retract(open_stream(AFile,S)),
3199 assert_side_effect_occurred(file),
3200 close(S).
3201
3202 close_all_files :- retract(open_stream(_File,S)),
3203 close(S),fail.
3204 close_all_files.
3205
3206
3207 open_utf8_file_for_reading(AFile,Stream,SpanInfo) :-
3208 safe_call(open(AFile,read,Stream,[encoding(utf8)]),SpanInfo).
3209
3210 :- public 'READ_FILE_AS_STRINGS'/3.
3211 performs_io('READ_FILE_AS_STRINGS').
3212 external_subst_enabling_condition('READ_FILE_AS_STRINGS',_,Truth) :- create_texpr(truth,pred,[],Truth).
3213 expects_spaninfo('READ_FILE_AS_STRINGS').
3214 :- block 'READ_FILE_AS_STRINGS'(-,?,?).
3215 'READ_FILE_AS_STRINGS'(string(File),Res,SpanInfo) :-
3216 read_file_as_strings2(File,Res,SpanInfo).
3217 'READ_FILE_AS_STRINGS'(string(File),_Res,_SpanInfo) :-
3218 format('% Opening file failed: ~w~n',[File]),fail.
3219 :- block read_file_as_strings2(-,?,?).
3220 read_file_as_strings2(File,Res,SpanInfo) :-
3221 b_absolute_file_name(File,AFile,SpanInfo),
3222 open_utf8_file_for_reading(AFile,Stream,SpanInfo),!,
3223 format('% Opened file: ~w~n',[File]),
3224 % no side-effect: as everything read in one go
3225 call_cleanup(read_lines(Stream,Res),
3226 close(Stream)).
3227
3228 read_lines(File,Res) :- read_lines_loop(1,File,Lines),
3229 kernel_objects:equal_object(Res,Lines).
3230 read_lines_loop(Nr,Stream,Lines) :- read_line(Stream,Line),
3231 debug:debug_println(9,read_line(Nr,Line)),
3232 (Line = end_of_file -> Lines = []
3233 ; atom_codes(Atom,Line), Lines = [(int(Nr),string(Atom))|T],
3234 N1 is Nr+1,read_lines_loop(N1,Stream,T)).
3235
3236
3237 :- public 'READ_FILE_AS_STRING'/3.
3238 performs_io('READ_FILE_AS_STRING').
3239 external_subst_enabling_condition('READ_FILE_AS_STRING',_,Truth) :- create_texpr(truth,pred,[],Truth).
3240 expects_spaninfo('READ_FILE_AS_STRING').
3241 :- block 'READ_FILE_AS_STRING'(-,?,?).
3242 'READ_FILE_AS_STRING'(string(File),Res,SpanInfo) :-
3243 read_file_as_string2(File,Res,SpanInfo).
3244 :- block read_file_as_string2(-,?,?).
3245 read_file_as_string2(File,Res,SpanInfo) :-
3246 b_absolute_file_name(File,AFile,SpanInfo),
3247 open_utf8_file_for_reading(AFile,Stream,SpanInfo),!,
3248 format('% Opened file: ~w~n',[File]),
3249 % no side-effect: as everything read in one go
3250 call_cleanup(read_all_codes(Stream,All,[]),
3251 close(Stream)),
3252 atom_codes(ResStr,All), Res = string(ResStr).
3253
3254 % read all codes in the stream:
3255 read_all_codes(Stream) --> {read_line(Stream,Line), Line \= end_of_file, !},
3256 Line, "\n",
3257 read_all_codes(Stream).
3258 read_all_codes(_) --> "".
3259
3260
3261 :- public 'READ_LINE'/3.
3262 expects_spaninfo('READ_LINE').
3263 external_subst_enabling_condition('READ_LINE',_,Truth) :- create_texpr(truth,pred,[],Truth).
3264 performs_io('READ_LINE').
3265 :- block 'READ_LINE'(-,?,?).
3266 'READ_LINE'(string(File),Res,SpanInfo) :-
3267 read_line2(File,Res,SpanInfo).
3268 :- block read_line2(-,?,?).
3269 read_line2(File,Res,_SpanInfo) :-
3270 open_file_for_reading_if_necessary(File,Stream),
3271 read_line(Stream,Line),
3272 debug:debug_println(9,read_line(Line)),
3273 assert_side_effect_occurred(file),
3274 (Line = end_of_file
3275 -> add_error(external_functions,'Attempting to read past EOF: ',File),
3276 Res = ""
3277 ; atom_codes(Atom,Line), Res = string(Atom)).
3278
3279 is_not_declarative('EOF').
3280 :- public 'EOF'/2.
3281 :- block 'EOF'(-,?).
3282 'EOF'(string(File),Res) :- eof2(File,Res).
3283 :- block eof2(-,?).
3284 eof2(File,Res) :-
3285 open_file_for_reading_if_necessary(File,Stream),
3286 ((peek_code(Stream,C), C = -1) -> Res = pred_true ; Res = pred_false). % for Linux compatibility
3287 % (at_end_of_stream(Stream) -> Res = pred_true ; Res=pred_false).
3288
3289 is_not_declarative('EOF_STDIN').
3290 :- public 'EOF_STDIN'/2.
3291 'EOF_STDIN'(_,Res) :- % dummy argument to enable valid external predicate type declarations
3292 ((peek_code(user_input,C), C = -1) -> Res = pred_true ; Res = pred_false).
3293
3294
3295 external_fun_type('CURRENT_FILE_POSITION',[],[string,string,integer]).
3296 is_not_declarative('CURRENT_FILE_POSITION').
3297 :- public 'CURRENT_FILE_POSITION'/3.
3298 'CURRENT_FILE_POSITION'(string(File),string(Field),Res) :-
3299 open_file_for_reading_if_necessary(File,Stream),
3300 stream_position(Stream,Pos),
3301 % POS must be one of byte_count [only for binary streams], line_count, character_count, line_position
3302 stream_position_data(Field,Pos,R), Res=int(R).
3303
3304 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3305
3306 :- public 'ADD_ERROR'/6.
3307 expects_spaninfo('ADD_ERROR').
3308 expects_waitflag('ADD_ERROR').
3309 performs_io('ADD_ERROR').
3310 'ADD_ERROR'(string(Msg),Expr,_State,[],SpanInfo,WF) :-
3311 add_error_wf('ADD_ERROR',Msg,Expr,SpanInfo,WF).
3312
3313 :- public 'ADD_STATE_ERROR'/6.
3314 expects_spaninfo('ADD_STATE_ERROR').
3315 expects_waitflag('ADD_STATE_ERROR').
3316 performs_io('ADD_STATE_ERROR').
3317 'ADD_STATE_ERROR'(string(Msg),Expr,_State,[],SpanInfo,WF) :-
3318 %add_wd_error_span_now(Msg,Expr,SpanInfo,WF).
3319 %add_wd_error_span(Msg,Expr,SpanInfo,WF).
3320 add_state_error_wf('ADD_STATE_ERROR',Msg,Expr,SpanInfo,WF). % does not fail
3321
3322 :- public 'ADD_WARNING'/6.
3323 expects_spaninfo('ADD_WARNING').
3324 expects_waitflag('ADD_WARNING').
3325 performs_io('ADD_WARNING').
3326 'ADD_WARNING'(string(Msg),Expr,_State,[],SpanInfo,WF) :-
3327 add_warning_wf('ADD_WARNING',Msg,Expr,SpanInfo,WF).
3328
3329
3330 :- public 'ADD_ERRORS'/5.
3331 expects_spaninfo('ADD_ERRORS').
3332 expects_waitflag('ADD_ERRORS').
3333 performs_io('ADD_ERRORS').
3334 :- block 'ADD_ERRORS'(-,?,?,?,?).
3335 'ADD_ERRORS'(SetOfStrings,_State,[],SpanInfo,WF) :-
3336 expand_custom_set_to_list_wf(SetOfStrings,ESet,_,add_errors,WF),
3337 add_errors_aux(ESet,SpanInfo,WF).
3338 :- block add_errors_aux(-,?,?).
3339 add_errors_aux([],_SpanInfo,_WF).
3340 add_errors_aux([string(Msg)|T],SpanInfo,WF) :-
3341 add_error('ADD_ERRORS',Msg,'',SpanInfo),
3342 add_errors_aux(T,SpanInfo,WF).
3343
3344 :- public 'ADD_STATE_ERRORS'/5.
3345 expects_spaninfo('ADD_STATE_ERRORS').
3346 expects_waitflag('ADD_STATE_ERRORS').
3347 performs_io('ADD_STATE_ERRORS').
3348 :- block 'ADD_STATE_ERRORS'(-,?,?,?,?).
3349 'ADD_STATE_ERRORS'(SetOfStrings,_State,[],SpanInfo,WF) :-
3350 expand_custom_set_to_list_wf(SetOfStrings,ESet,_,add_state_errors,WF),
3351 add_state_errors_aux(ESet,SpanInfo,WF).
3352 :- block add_state_errors_aux(-,?,?).
3353 add_state_errors_aux([],_SpanInfo,_WF).
3354 add_state_errors_aux([string(Msg)|T],SpanInfo,WF) :-
3355 add_state_error_wf('ADD_STATE_ERRORS',Msg,'',SpanInfo,WF),
3356 add_state_errors_aux(T,SpanInfo,WF).
3357
3358 :- public 'ADD_WARNINGS'/5.
3359 expects_spaninfo('ADD_WARNINGS').
3360 expects_waitflag('ADD_WARNINGS').
3361 performs_io('ADD_WARNINGS').
3362 :- block 'ADD_WARNINGS'(-,?,?,?,?).
3363 'ADD_WARNINGS'(SetOfStrings,_State,[],SpanInfo,WF) :-
3364 expand_custom_set_to_list_wf(SetOfStrings,ESet,_,add_warnings,WF),
3365 add_warnings_aux(ESet,SpanInfo,WF).
3366 :- block add_warnings_aux(-,?,?).
3367 add_warnings_aux([],_SpanInfo,_WF).
3368 add_warnings_aux([string(Msg)|T],SpanInfo,WF) :-
3369 add_warning('ADD_WARNINGS',Msg,'',SpanInfo),
3370 % we do not add with WF and call stack: call stack contains call to ADD_WARNINGS with all error messages again
3371 add_warnings_aux(T,SpanInfo,WF).
3372
3373 :- public 'ASSERT_TRUE'/5.
3374 expects_spaninfo('ASSERT_TRUE').
3375 expects_waitflag('ASSERT_TRUE').
3376 external_fun_has_wd_condition('ASSERT_TRUE').
3377 external_fun_type('ASSERT_TRUE',[],[boolean,string,boolean]). % external predicate in LibraryProB.def
3378
3379 'ASSERT_TRUE'(PredVal,string(Msg),PredRes,SpanInfo,WF) :-
3380 assert_true(PredVal,Msg,PredRes,SpanInfo,WF).
3381
3382 :- block assert_true(-,?,?,?,?).
3383 assert_true(pred_true,_Msg,pred_true,_SpanInfo,_WF).
3384 assert_true(pred_false,Msg,Res,SpanInfo,WF) :-
3385 debug_format(19,'% Waiting for enumeration to finish to raise ASSERT_TRUE:~n ~w~n',[Msg]),
3386 add_error_ef('ASSERT_TRUE',Msg,'',SpanInfo,WF,Res).
3387
3388 % we could also use: add_wd_error_set_result
3389 add_error_ef(Source,Msg,Term,Span,WF,Res) :-
3390 get_enumeration_finished_wait_flag(WF,AWF),
3391 add_error_ef_aux(AWF,Source,Msg,Term,Span,WF,Res).
3392
3393 :- block add_error_ef_aux(-,?,?,?,?,?,?).
3394 add_error_ef_aux(_AWF,Source,Msg,Term,Span,_WF,Res) :-
3395 add_error(Source,Msg,Term,Span),
3396 Res = pred_false.
3397
3398 :- public 'ASSERT_EXPR'/6.
3399 expects_spaninfo('ASSERT_EXPR').
3400 expects_waitflag('ASSERT_EXPR').
3401 external_fun_has_wd_condition('ASSERT_EXPR').
3402 external_fun_type('ASSERT_EXPR',[T],[boolean,string,T,T]).
3403
3404 'ASSERT_EXPR'(PredVal,string(Msg),ExprVal,Res,SpanInfo,WF) :-
3405 % TO DO: call assertion_expression(Cond,ErrMsg,Expr) or a variant there-of
3406 % current problem: Expr is evaluated even if PredVal is false; if evaluation fails we do not get an error message
3407 % ideally we want to delay evaluating Expr until Predval is true
3408 assert_expr(PredVal,Msg,ExprVal,Res,SpanInfo,WF).
3409
3410 :- block assert_expr(-,?,?,?,?,?).
3411 assert_expr(pred_true,_Msg,ExprVal,Res,_SpanInfo,_WF) :-
3412 Res = ExprVal.
3413 assert_expr(pred_false,Msg,_ExprVal,Res,SpanInfo,WF) :-
3414 add_error_ef('ASSERT_EXPR',Msg,'',SpanInfo,WF,Res).
3415
3416 % --------------------------
3417 % Reflection Functions
3418
3419 external_fun_type('STATE_AS_STRING',[],[integer,string]).
3420 external_function_requires_state('STATE_AS_STRING').
3421 :- public 'STATE_AS_STRING'/3.
3422 expects_waitflag('STATE_AS_STRING').
3423 'STATE_AS_STRING'(int(X),StateStr,WF) :-
3424 state_space:get_state_space_stats(NrNodes,_NrTransitions,_ProcessedNodes),
3425 get_wait_flag(NrNodes,'STATE_AS_STRING',WF,LWF),
3426 get_state2(X,StateStr,LWF).
3427 :- block get_state2(-,?,-).
3428 get_state2(X,StateStr,_) :-
3429 convert_id_to_nr(IDX,X),
3430 state_space:visited_expression(IDX,S),
3431 translate:translate_any_state(S,Str),
3432 StateStr = string(Str).
3433
3434 :- public 'CURRENT_STATE_AS_TYPED_STRING'/1.
3435 external_function_requires_state('CURRENT_STATE_AS_TYPED_STRING').
3436 external_fun_type('CURRENT_STATE_AS_TYPED_STRING',[],[string]).
3437 % translate current state values as parseable string
3438 'CURRENT_STATE_AS_TYPED_STRING'(string(Translation)) :-
3439 'VARS_AS_TYPED_STRING'(string(''),string(Translation)).
3440
3441 external_function_requires_state('VARS_AS_TYPED_STRING').
3442 external_fun_type('VARS_AS_TYPED_STRING',[],[string,string]).
3443 :- block 'VARS_AS_TYPED_STRING'(-,?).
3444 'VARS_AS_TYPED_STRING'(string(Prefix),string(Translation)) :- % the name is a bit misleading, as it is also searched for constants
3445 get_current_state_id(ID),
3446 visited_expression(ID,State),
3447 state_corresponds_to_fully_setup_b_machine(State,FullState),
3448 b_get_machine_constants(Constants),
3449 include(identifier_matches_prefix(Prefix),Constants,C1),
3450 b_get_machine_variables(Vars),
3451 include(identifier_matches_prefix(Prefix),Vars,V1),
3452 append(C1,V1,Ids),
3453 translate_ids_to_typed_parseable(Ids,FullState,Translation).
3454
3455 translate_ids_to_typed_predicate(Ids,FullState,Pred) :-
3456 findall(Equality,(member(TID,Ids),
3457 generate_equality(TID,FullState,Equality)),Eqs),
3458 generate_typing_predicates(Ids,TypePreds),
3459 append(TypePreds,Eqs,Ps),
3460 conjunct_predicates(Ps,Pred).
3461 translate_ids_to_typed_parseable(Ids,FullState,Translation) :-
3462 translate_ids_to_typed_predicate(Ids,FullState,Pred),
3463 translate_bexpr_to_parseable(Pred,Translation).
3464
3465 :- use_module(probsrc(tools_strings), [atom_prefix/2]).
3466 identifier_matches_prefix(Prefix,b(identifier(ID),_,_)) :- atom_prefix(Prefix,ID).
3467
3468 generate_equality(TID,FullState,Equality) :- TID = b(identifier(ID),Type,_),
3469 if(member(bind(ID,Val),FullState),
3470 safe_create_texpr(equal(TID,b(value(Val),Type,[])),pred,Equality),
3471 add_error_fail('VARS_AS_TYPED_STRING','Could not find identifier:',TID)).
3472
3473 external_function_requires_state('IDS_AS_TYPED_STRING').
3474 expects_waitflag('IDS_AS_TYPED_STRING').
3475 external_fun_type('IDS_AS_TYPED_STRING',[],[set(string),string]).
3476 :- public 'IDS_AS_TYPED_STRING'/3.
3477 :- block 'IDS_AS_TYPED_STRING'(-,?,?).
3478 'IDS_AS_TYPED_STRING'(SetOfStrings,string(Translation),WF) :-
3479 expand_custom_set_to_list_wf(SetOfStrings,StringIds,_,'IDS_AS_TYPED_STRING',WF),
3480 get_current_state_id(ID),
3481 ids_as_typed_string_for_state(ID,StringIds,Pred),
3482 translate_bexpr_to_parseable(Pred,Translation).
3483
3484 :- block ids_as_typed_string_for_state(-,-,?).
3485 ids_as_typed_string_for_state(StateId,StringIds,Pred) :-
3486 visited_expression(StateId,State),
3487 state_corresponds_to_fully_setup_b_machine(State,FullState),
3488 b_get_machine_constants(Constants),
3489 b_get_machine_variables(Vars),
3490 (StringIds=[] -> C1=Constants ; include(identifier_member_exact(StringIds),Constants,C1)),
3491 (StringIds=[] -> V1=Vars ; include(identifier_member_exact(StringIds),Vars,V1)),
3492 append(C1,V1,Ids),
3493 translate_ids_to_typed_predicate(Ids,FullState,Pred).
3494
3495 identifier_member_exact(StringIds,b(identifier(ID),_,_)) :- member(string(ID),StringIds), !.
3496 identifier_member_exact(StringIds,b(identifier(ID),_,_)) :- member(ID,StringIds).
3497
3498 external_function_requires_state('WRITE_CURRENT_STATE_AS_MACHINE').
3499 expects_waitflag('WRITE_CURRENT_STATE_AS_MACHINE').
3500 performs_io('WRITE_CURRENT_STATE_AS_MACHINE').
3501 external_fun_type('WRITE_CURRENT_STATE_AS_MACHINE',[],[string,set(string)]). % output path, set of IDs
3502 :- public 'WRITE_CURRENT_STATE_AS_MACHINE'/4.
3503 :- block 'WRITE_CURRENT_STATE_AS_MACHINE'(-,-,?,?).
3504 'WRITE_CURRENT_STATE_AS_MACHINE'(string(OutputPath),SetOfStrings,Res,WF) :-
3505 expand_custom_set_to_list_wf(SetOfStrings,StringIds,_,'WRITE_CURRENT_STATE_AS_MACHINE',WF),
3506 get_current_state_id(ID),
3507 write_state_as_machine_string(OutputPath,ID,StringIds),
3508 Res = pred_true.
3509 :- block write_state_as_machine_string(-,-,-).
3510 write_state_as_machine_string(OutputPath,StateId,StringIds) :-
3511 ids_as_typed_string_for_state(StateId,StringIds,Pred),
3512 tools:get_modulename_filename(OutputPath,MchName),
3513 translate:translate_predicate_into_machine(Pred,MchName,Machine),
3514 tools_io:safe_open_file(OutputPath,write,Stream,[encoding(utf8)]),
3515 write(Stream,Machine), close(Stream).
3516
3517
3518 :- use_module(state_space,[visited_expression/2]).
3519 :- use_module(probsrc(tools_strings),[match_atom/3]).
3520 :- use_module(specfile,[property/2, xtl_mode/0]).
3521 :- public 'STATE_PROPERTY'/3.
3522 % a useful function for VisB and XTL or CSP models to query state of model
3523 expects_spaninfo('STATE_PROPERTY').
3524 external_function_requires_state('STATE_PROPERTY').
3525 external_fun_type('STATE_PROPERTY',[],[string,string]).
3526 :- block 'STATE_PROPERTY'(-,?,?).
3527 'STATE_PROPERTY'(string(Prop),Res,Span) :- state_property2(Prop,Res,Span).
3528 :- block state_property2(-,?,?).
3529 state_property2(Prop,Res,Span) :-
3530 get_current_state_id(ID),
3531 visited_expression(ID,State),
3532 atom_codes(Prop,PC),
3533 (property(State,'='(StateProp,Val)), % TODO: this leads to error in B mode due to atom_codes error
3534 match_atom(Prop,PC,StateProp)
3535 -> (atom(Val) -> Res = string(Val)
3536 ; number(Val), number_codes(Val,CC), atom_codes(Atom,CC) -> Res = string(Atom)
3537 ; add_message(external_functions,'Cannot convert STATE_PROPERTY value to STRING ',Val,Span),
3538 Res = string('UNKNOWN')
3539 )
3540 ; xtl_mode -> Res = string('UNKNOWN') % the user can define their own properties in prop/2; see test 2511
3541 ; add_message(external_functions,'Unknown value for STATE_PROPERTY: ',Prop,Span),
3542 Res = string('UNKNOWN')
3543 ).
3544
3545 :- public 'STATE_PROPERTIES'/2.
3546 % query all available state properties with prefix Pref
3547 external_function_requires_state('STATE_PROPERTIES').
3548 external_fun_type('STATE_PROPERTIES',[],[string,set(string)]).
3549 :- block 'STATE_PROPERTIES'(-,?).
3550 'STATE_PROPERTIES'(string(Prefix),Res) :- state_properties_aux(Prefix,Res).
3551 :- block state_properties_aux(-,?).
3552 state_properties_aux(Prefix,Res) :-
3553 get_current_state_id(ID),
3554 visited_expression(ID,State),
3555 findall(Prop,property(State,'='(Prop,_Val)),PropIds),
3556 include(atom_prefix(Prefix),PropIds,PrefIds),
3557 maplist(mkstring,PrefIds,Res).
3558
3559 :- public 'STATE_SUCC'/5.
3560 external_fun_type('STATE_SUCC',[],[integer,integer,boolean]).
3561 expects_waitflag('STATE_SUCC').
3562 expects_spaninfo('STATE_SUCC').
3563 'STATE_SUCC'(X,Y,Res,Span,WF) :- 'STATE_TRANS'(X,_,Y,Res,Span,WF).
3564
3565 % synonym for function to BOOL rather than predicate
3566 'GET_IS_ENABLED'(OperationName,Res,Span,WF) :- 'ENABLED'(OperationName,Res,Span,WF).
3567 :- public 'GET_IS_ENABLED'/4.
3568 expects_waitflag('ENABLED').
3569 expects_waitflag('GET_IS_ENABLED').
3570 expects_spaninfo('ENABLED').
3571 expects_spaninfo('GET_IS_ENABLED').
3572 external_function_requires_state('ENABLED').
3573 external_function_requires_state('GET_IS_ENABLED').
3574 external_fun_type('ENABLED',[],[string,boolean]).
3575 'ENABLED'(OperationName,Res,Span,WF) :-
3576 get_current_state_id(ID),
3577 tcltk_interface:compute_all_transitions_if_necessary(ID,false),
3578 NrOps = 10, get_wait_flag(NrOps,'ENABLED',WF,LWF),
3579 % format('Checking ENABLED of ~w in state ~w~n',[OperationName,ID]),
3580 enabled_op(ID,OperationName,Res,Span,LWF).
3581
3582 :- use_module(probsrc(specfile),[b_or_z_mode/0, get_possible_event/1]).
3583 :- block enabled_op(?,-,?,?,-).
3584 enabled_op(ID,string(OpName),Res,Span,_) :-
3585 (var(OpName) -> get_possible_event(OpName) % is b_top_level_operation in b_or_z_mode
3586 ; b_or_z_mode, \+ get_possible_event(OpName)
3587 -> (b_is_operation_name(OpName)
3588 -> add_warning('ENABLED','Not a top-level operation, use GET_GUARD_STATUS for: ',OpName,Span)
3589 ; add_warning('ENABLED','Unknown operation/event: ',OpName,Span)
3590 )
3591 ; true
3592 ),
3593 (state_space_transition(ID,_,string(OpName),_,unknown) -> Res=pred_true
3594 ; Res=pred_false,
3595 (get_preference(maxNrOfEnablingsPerOperation,0)
3596 -> add_warning('ENABLED','MAX_OPERATIONS is 0, you may want to use GET_GUARD_STATUS instead for: ',OpName,Span); true)
3597 ).
3598
3599
3600 :- use_module(b_operation_guards,[get_quantified_operation_enabling_condition/5]).
3601 :- public 'GET_GUARD_STATUS'/4.
3602 expects_waitflag('GET_GUARD_STATUS').
3603 expects_spaninfo('GET_GUARD_STATUS').
3604 %expects_state('GET_GUARD_STATUS'). % passing state does not always work: to the outside it looks like this call requires no variables and constants
3605 external_function_requires_state('GET_GUARD_STATUS').
3606 external_fun_type('GET_GUARD_STATUS',[],[string,boolean]).
3607 % in contrast to ENABLED, this external function works by computing the guard and evaluating it
3608 % ENABLED just checks the state space; which is in principle more efficient but does not work when
3609 % either MAX_OPERATIONS=0 or subsidiary operations are inspected
3610 'GET_GUARD_STATUS'(Op,PredRes,Span,WF) :-
3611 get_current_state_id(ID),
3612 NrOps = 10, get_wait_flag(NrOps,'GET_GUARD_STATUS',WF,LWF),
3613 get_guard_status(ID,Op,PredRes,Span,WF,LWF).
3614 :- block get_guard_status(?,-,?,?,?,-).
3615 get_guard_status(ID,string(OpName),PredRes,Span,WF,_) :-
3616 Simplify=true,
3617 if(get_quantified_operation_enabling_condition(OpName, BExpr, _BSVars, Precise, Simplify),
3618 ((Precise=precise -> true
3619 ; add_message('GET_GUARD_STATUS','Guard of operation/event not precise: ',OpName,Span)),
3620 test_formula_in_state(ID,BExpr,PredRes,WF)),
3621 (add_error('GET_GUARD_STATUS','Unknown operation/event: ',OpName,Span),
3622 PredRes=pred_false)).
3623
3624
3625 :- public 'GET_IS_ENABLED_TRANSITION'/3.
3626 :- public 'ENABLED_TRANSITION'/3.
3627 % a variation of ENABLED where we can check for arguments; useful for VisB but it relies on argument order
3628 external_fun_type('ENABLED_TRANSITION',[],[string,boolean]).
3629 expects_waitflag('ENABLED_TRANSITION').
3630 expects_waitflag('GET_IS_ENABLED_TRANSITION').
3631 external_function_requires_state('ENABLED_TRANSITION').
3632 external_function_requires_state('GET_IS_ENABLED_TRANSITION').
3633 'ENABLED_TRANSITION'(TransString,Res,WF) :- get_enabled_transition(event,TransString,Res,WF).
3634 % synonym for function to BOOL rather than predicate
3635 'GET_IS_ENABLED_TRANSITION'(TransString,Res,WF) :- get_enabled_transition(event,TransString,Res,WF).
3636 :- public 'GET_IS_ENABLED_TRANSITION_DESCRIPTION'/3.
3637 'GET_IS_ENABLED_TRANSITION_DESCRIPTION'(TransString,Res,WF) :- get_enabled_transition(description,TransString,Res,WF).
3638 external_fun_type('GET_IS_ENABLED_TRANSITION_DESCRIPTION',[],[string,boolean]).
3639 expects_waitflag('GET_IS_ENABLED_TRANSITION_DESCRIPTION').
3640
3641 get_enabled_transition(Kind,TransString,Res,WF) :-
3642 get_current_state_id(ID),
3643 tcltk_interface:compute_all_transitions_if_necessary(ID,false),
3644 NrOps = 10, get_wait_flag(NrOps,'GET_IS_ENABLED_TRANSITION',WF,LWF),
3645 % format('Checking ENABLED_TRANSITION of ~w in state ~w~n',[TransString,ID]),
3646 enabled_trans(Kind,ID,TransString,Res,LWF).
3647
3648 :- block enabled_trans(?,?,-,?,-),enabled_trans(?,?,-,-,?).
3649 enabled_trans(Kind,ID,string(TransitionStr),Res,LWF) :-
3650 enabled_trans2(Kind,ID,TransitionStr,Res,LWF).
3651 :- block enabled_trans2(?,?,-,?,-),enabled_trans2(?,?,-,-,?).
3652 enabled_trans2(Kind,ID,TransitionStr,Res,_) :- var(TransitionStr),!,
3653 (Res==pred_true -> transition_string(Kind,ID,Str,1000,_), TransitionStr=Str
3654 ; enabled_trans2(Kind,ID,TransitionStr,Res2,_), % wait until TransitionStr is known
3655 Res = Res2
3656 ).
3657 enabled_trans2(Kind,ID,TransitionStr,Res,_) :-
3658 atom_length(TransitionStr,Limit),
3659 (transition_string(Kind,ID,TransitionStr,Limit,_) -> Res=pred_true ; Res=pred_false).
3660
3661 :- use_module(state_space,[transition/4]).
3662 :- use_module(translate,[translate_event_with_src_and_target_id/5]).
3663 :- use_module(probsrc(specfile),[get_operation_description_for_transition/4]).
3664 transition_string(Kind,ID,TransitionStr,Limit,ToID) :-
3665 transition(ID,TransitionTerm,_TransID,ToID),
3666 % This will currently also output --> Res for operation results; probably we do not want that
3667 ( Kind=event,
3668 translate_event_with_src_and_target_id(TransitionTerm,ID,ToID,Limit,TransitionStr)
3669 ; Kind=description,
3670 get_operation_description_for_transition(ID,TransitionTerm,ToID,TransitionStr)
3671 ).
3672
3673 :- public 'NON_DET_STATE'/1.
3674 %is_not_declarative('NON_DET_STATE'). % depends on current state, but for any given state it is declarative
3675 external_fun_type('NON_DET_STATE',[],[boolean]).
3676 external_function_requires_state('NON_DET_STATE').
3677 % check if there is a non-deterministic transition: same transition different target state
3678 % similar to tcltk_goto_a_non_deterministic_node
3679 'NON_DET_STATE'(Res) :- get_current_state_id(ID),
3680 non_det_transition(ID,_OperationName,_,_), !,
3681 Res = pred_true.
3682 'NON_DET_STATE'(pred_false).
3683
3684 :- public 'NON_DET_OUTPUT_STATE'/1.
3685 %is_not_declarative('NON_DET_OUTPUT_STATE'). % depends on current state, but for any given state it is declarative
3686 external_function_requires_state('NON_DET_OUTPUT_STATE').
3687 external_fun_type('NON_DET_OUTPUT_STATE',[],[boolean]).
3688 % check if there is a non-deterministic transition: same transition different classic B operation result
3689 % similar to tcltk_goto_a_non_deterministic_output_node
3690 'NON_DET_OUTPUT_STATE'(Res) :- get_current_state_id(ID),
3691 non_det_output_transition2(ID,_OperationName), !,
3692 Res = pred_true.
3693 'NON_DET_OUTPUT_STATE'(pred_false).
3694
3695 % check if we find a state ID where OperationName leads to two different states with same arguments
3696 non_det_transition(ID,OperationName,TID1,TID2) :-
3697 tcltk_interface:compute_all_transitions_if_necessary(ID,false),
3698 transition(ID,Transition,TID1,ID1),
3699 get_operation_name(Transition,OperationName),
3700 get_operation_arguments(Transition,OperationArgs),
3701 transition(ID,Transition2,TID2,ID2),
3702 TID2 > TID1, ID1 \= ID2,
3703 get_operation_name(Transition2,OperationName), % same operation
3704 get_operation_arguments(Transition2,OperationArgs). % same arguments
3705
3706 :- use_module(probltlsrc(ltl_propositions), [non_det_output_transition/4]).
3707 % check if we find a state where an operation with output/result parameters is non-det in the output
3708 non_det_output_transition2(ID,OperationName) :-
3709 tcltk_interface:compute_all_transitions_if_necessary(ID,false), % TODO: detect if we are looping and computing guards/actions
3710 non_det_output_transition(ID,OperationName,_TID1,_TID2).
3711
3712 :- public 'GET_IS_DET'/3.
3713 expects_spaninfo('GET_IS_DET').
3714 external_function_requires_state('GET_IS_DET').
3715 external_fun_type('GET_IS_DET',[],[string,boolean]).
3716 % check if there is a non-deterministic transition for a given operation: same transition different target state
3717 :- block 'GET_IS_DET'(-,?,?).
3718 'GET_IS_DET'(string(OperationName),Res,Span) :-
3719 get_current_state_id(ID),
3720 nondet_op2(ID,OperationName,'GET_IS_DET',Res,Span).
3721
3722
3723 :- public 'GET_IS_DET_OUTPUT'/3.
3724 expects_spaninfo('GET_IS_DET_OUTPUT').
3725 external_function_requires_state('GET_IS_DET_OUTPUT').
3726 external_fun_type('GET_IS_DET_OUTPUT',[],[string,boolean]).
3727 % check if there is a non-deterministic transition for a given operation: same transition different target state
3728 :- block 'GET_IS_DET_OUTPUT'(-,?,?).
3729 'GET_IS_DET_OUTPUT'(string(OperationName),Res,Span) :-
3730 get_current_state_id(ID),
3731 nondet_op2(ID,OperationName,'GET_IS_DET_OUTPUT',Res,Span).
3732
3733 :- block nondet_op2(?,-,?,?,?).
3734 nondet_op2(_ID,OperationName,XFUN,Res,Span) :- \+ b_top_level_operation(OperationName),!,
3735 add_error(XFUN,'Not a valid top-level operation:',OperationName,Span),
3736 Res = pred_false.
3737 % Check if it has outputs and throw warning if not ?
3738 nondet_op2(ID,OperationName,'GET_IS_DET',Res,_Span) :-
3739 non_det_transition(ID,OperationName,_,_),
3740 !,
3741 Res = pred_false.
3742 nondet_op2(ID,OperationName,'GET_IS_DET_OUTPUT',Res,_Span) :-
3743 non_det_output_transition2(ID,OperationName),
3744 !,
3745 Res = pred_false.
3746 nondet_op2(_,_,_,pred_true,_Span).
3747
3748 :- public 'NON_DET_OUTPUT_OPERATIONS'/1.
3749 external_function_requires_state('NON_DET_OUTPUT_OPERATIONS').
3750 external_fun_type('NON_DET_OUTPUT_OPERATIONS',[],[set(string)]).
3751 'NON_DET_OUTPUT_OPERATIONS'(Res) :-
3752 get_current_state_id(ID),
3753 findall(string(OpName),
3754 non_det_output_transition2(ID,OpName),
3755 List),
3756 sort(List,SList),
3757 kernel_objects:equal_object_optimized(SList,Res).
3758
3759
3760 % -------------------
3761
3762 % usage e.g. for scheduler.mch: {x|x:PID & GET_IS_ENABLED_WITH_ARGS("new",x)=TRUE}
3763 expects_waitflag('GET_IS_ENABLED_WITH_ARGS').
3764 external_fun_type('GET_IS_ENABLED_WITH_ARGS',[X],[string,X,boolean]).
3765 expects_spaninfo('GET_IS_ENABLED_WITH_ARGS').
3766 external_function_requires_state('GET_IS_ENABLED_WITH_ARGS').
3767 expects_unevaluated_args('GET_IS_ENABLED_WITH_ARGS').
3768 :- public 'GET_IS_ENABLED_WITH_ARGS'/6.
3769 :- block 'GET_IS_ENABLED_WITH_ARGS'(-,?,?,?,?,?).
3770 % we would expect the operation name to be known statically, as the type of the arguments may differ amongst operations
3771 'GET_IS_ENABLED_WITH_ARGS'(OperationName,OperationArgs,Res,[OpNameExpr,UnEvalArgs|_],SpanInfo,WF) :-
3772 OperationName = string(OpName),
3773 check_operation_name_and_arg_type(OpName,UnEvalArgs,'GET_IS_ENABLED_WITH_ARGS',OpNameExpr),
3774 get_current_state_id(CurID),
3775 tcltk_interface:compute_all_transitions_if_necessary(CurID,false),
3776 'STATE_TRANS_ARGS'(int(CurID),OperationName,OperationArgs,_,Res,SpanInfo,WF).
3777
3778 %:- block check_operation_name(-,?,?).
3779 %check_operation_name(OpName,_,_) :- b_top_level_operation(OpName),!.
3780 %check_operation_name(OpName,XFUN,Span) :-
3781 % add_error(XFUN,'Unknown operation name:',OpName,Span).
3782 :- use_module(bmachine,[b_get_machine_operation_for_animation/4, b_is_operation_name/1]).
3783 :- block check_operation_name_and_arg_type(-,?,?,?).
3784 check_operation_name_and_arg_type(OpName,Args,XFUN,_) :- b_top_level_operation(OpName),!,
3785 get_texpr_type(Args,ArgType),
3786 b_get_machine_operation_for_animation(OpName,_Results,Parameters,_Body),
3787 check_argument_type_against_params(Parameters,OpName,ArgType,XFUN,Args).
3788 check_operation_name_and_arg_type(OpName,_,XFUN,Span) :- b_is_operation_name(OpName),!,
3789 % will never be executed as transition in state_space
3790 add_warning(XFUN,'Not a top-level operation name:',OpName,Span).
3791 check_operation_name_and_arg_type(OpName,_,XFUN,Span) :-
3792 add_error(XFUN,'Unknown operation name:',OpName,Span).
3793
3794 check_argument_type_against_params([],OpName,_,XFUN,Args) :- !,
3795 add_error(XFUN,'Operation has no arguments, use GET_IS_ENABLED instead:',OpName,Args).
3796 check_argument_type_against_params([Para],_OpName,ArgType,XFUN,Args) :- !,
3797 check_type(Para,ArgType,XFUN,Args).
3798 check_argument_type_against_params([Para|TParas],OpName,couple(PType1,PTypeRest),XFUN,Args) :- !,
3799 check_type(Para,PType1,XFUN,Args),
3800 check_argument_type_against_params(TParas,OpName,PTypeRest,XFUN,Args).
3801 check_argument_type_against_params(_,OpName,_ArgType,XFUN,Args) :- !,
3802 add_error(XFUN,'Not enough arguments provided for operation:',OpName,Args).
3803
3804 :- use_module(probsrc(btypechecker), [lookup_type_for_expr/2, unify_types_werrors/4]).
3805 check_type(Arg1,Type2,XFUN,Pos) :-
3806 get_texpr_type(Arg1,Type1),
3807 unify_types_werrors(Type1,Type2,Pos,XFUN).
3808
3809 :- use_module(probltlsrc(ltl),[parse_and_preprocess_formula/3]).
3810 :- use_module(probltlsrc(ltl_verification), [evaluate_ltl_state_property/3]).
3811 external_fun_type('EVAL_LTL_STATE_PROPERTY',[],[string,boolean]).
3812 expects_waitflag('EVAL_LTL_STATE_PROPERTY').
3813 expects_spaninfo('EVAL_LTL_STATE_PROPERTY').
3814 external_function_requires_state('EVAL_LTL_STATE_PROPERTY').
3815 :- public 'EVAL_LTL_STATE_PROPERTY'/4.
3816 :- block 'EVAL_LTL_STATE_PROPERTY'(-,?,?,?).
3817 % we would expect the operation name to be known statically, as the type of the arguments may differ amongst operations
3818 'EVAL_LTL_STATE_PROPERTY'(string(LTLFormula),Result,SpanInfo,WF) :-
3819 get_current_state_id(CurID),
3820 parse_and_preprocess_formula(LTLFormula,ltl,TypeCheckedCondition), % TODO: cache parsing
3821 (evaluate_ltl_state_property(TypeCheckedCondition,CurID,Res)
3822 -> ( Res=false -> Result=pred_false
3823 ; Res=true -> Result=pred_true
3824 ; add_wd_error_span('EVAL_LTL_STATE_PROPERTY result unknown:',string(LTLFormula),SpanInfo,WF)
3825 )
3826 ; add_error('EVAL_LTL_STATE_PROPERTY', 'Could not evaluate LTL formula:', LTLFormula, SpanInfo)
3827 ).
3828
3829 external_fun_type('STATE_TRANS',[],[integer,string,integer,boolean]).
3830 expects_waitflag('STATE_TRANS').
3831 expects_spaninfo('STATE_TRANS').
3832 'STATE_TRANS'(int(X),OperationName,int(Y),Res,SpanInfo,WF) :-
3833 'STATE_TRANS_ARGS'(int(X),OperationName,_,int(Y),Res,SpanInfo,WF).
3834
3835 external_fun_type('STATE_TRANS_ARGS',[X],[integer,string,X,integer,boolean]).
3836 expects_waitflag('STATE_TRANS_ARGS').
3837 expects_spaninfo('STATE_TRANS_ARGS').
3838 'STATE_TRANS_ARGS'(int(X),OperationName,OperationArgs,int(Y),Res,SpanInfo,WF) :-
3839 (nonvar(X)
3840 -> true
3841 ; state_space:get_state_space_stats(NrNodes,_NrTransitions,_ProcessedNodes),
3842 get_wait_flag(NrNodes,'STATE_TRANS',WF,LWF)
3843 ),
3844 get_wait_flag1('STATE_TRANS_ARGS',WF,WF1),
3845 get_succ2(X,OperationName,OperationArgs,Y,Res,LWF,WF1,SpanInfo).
3846 :- block get_succ2(-,?,?,-,?,-,?,?),
3847 get_succ2(?,?,?,?,?,?,-,?). % wait at least until WF1 (or at least wf0); as we do non-deterministic enumeration ! (e.g., otherwise b_interpreter_components gets confused !!)
3848 get_succ2(X,OperationName,OperationArgs,Y,Res,_,_,Pos) :- convert_id_to_nr(IDX,X),
3849 if((state_space_transition(IDX,IDY,OperationName,OperationArgs,Pos),
3850 convert_id_to_nr(IDY,Y)),
3851 Res=pred_true,Res=pred_false).
3852
3853 state_space_transition(IDX,IDY,OperationName,OperationArgs,Pos) :-
3854 state_space:transition(IDX,Transition,IDY),
3855 op_functor(Transition,OperationName),
3856 op_args(Transition,OperationArgs,Pos).
3857
3858 % root is represented as -1
3859 :- block convert_id_to_nr(-,-).
3860 convert_id_to_nr(ID,X) :- ID==root, !, X is -1.
3861 convert_id_to_nr(ID,X) :- X == -1, !, ID=root.
3862 convert_id_to_nr(X,X).
3863
3864 :- use_module(specfile,[get_operation_name/2,get_operation_arguments/2, get_operation_return_values_and_arguments/3]).
3865 op_functor(OpTerm,Res) :- get_operation_name(OpTerm,Name),
3866 Res = string(Name).
3867
3868 :- use_module(tools,[convert_list_into_pairs/2]).
3869 op_args(OpTerm,OperationArgs,Pos) :-
3870 get_operation_arguments(OpTerm,As),
3871 convert_list_into_pairs(As,ArgTerm),
3872 % first check if types are compatible; user could have provided wrong types;
3873 % TODO: sometimes we check_operation_name_and_arg_type and could remove this check in then
3874 kernel_objects:check_values_have_same_type(OperationArgs,ArgTerm,Pos),
3875 kernel_objects:equal_object(OperationArgs,ArgTerm).
3876
3877
3878 :- public 'STATE_SAT'/4.
3879 expects_waitflag('STATE_SAT').
3880 external_fun_type('STATE_SAT',[],[integer,string,boolean]).
3881 % check whether formula as string holds in a state
3882 :- block 'STATE_SAT'(?,-,?,?).
3883 'STATE_SAT'(int(X),string(Formula),Res,WF) :- %print(parsing(Formula)),nl, trace,
3884 parse_pred(Formula,TFormula),
3885 state_space:get_state_space_stats(NrNodes,_NrTransitions,_ProcessedNodes),
3886 get_wait_flag(NrNodes,'STATE_SAT',WF,LWF),
3887 state_sat2(X,TFormula,Res,LWF,WF).
3888 :- block state_sat2(?,-,?,?,?),state_sat2(-,?,?,-,?).
3889 state_sat2(X,TFormula,PredRes,_,WF) :-
3890 (number(X) -> test_formula_in_state(X,TFormula,PredRes,WF)
3891 ; test_formula_in_state(ID,TFormula,PredRes,WF), ID \= root, X=ID % avoid CLPFD errors on X
3892 ).
3893
3894 :- use_module(b_global_sets,[add_prob_deferred_set_elements_to_store/3]).
3895 :- use_module(specfile,[state_corresponds_to_fully_setup_b_machine/2]).
3896 %:- use_module(b_interpreter,[b_try_check_boolean_expression_wf/5]).
3897 test_formula_in_state(ID,Pred,PredRes,WF) :-
3898 state_space:visited_expression(ID,State),
3899 state_corresponds_to_fully_setup_b_machine(State,FullState),
3900 add_prob_deferred_set_elements_to_store(FullState,FullState1,visible),
3901 debug_println(9,check(Pred,FullState1,PredRes)),
3902 b_interpreter:b_try_check_boolean_expression_wf(Pred,[],FullState1,WF,PredRes).
3903
3904
3905 :- public 'EVAL'/6.
3906 expects_waitflag('EVAL'). % external function with unknown return type
3907 expects_type('EVAL').
3908 expects_spaninfo('EVAL').
3909 :- block 'EVAL'(?,-,?,?,?,?).
3910 'EVAL'(int(X),string(Expr),Value,Type,Span,WF) :-
3911 state_eval1(X,Expr,Value,pred_true,Type,Span,WF).
3912
3913 % evaluate expression and check whether value corresponds to provided value
3914 % (needed for type inference of the external predicate)
3915 %:- block 'STATE_EVAL'(?,-,?,?,?,?,?).
3916 %'STATE_EVAL'(int(X),string(Expr),Value,PredRes,Span,WF) :-
3917 % state_eval1(X,Expr,Value,PredRes,any,Span,WF).
3918
3919 :- use_module(btypechecker, [unify_types_strict/2]).
3920 :- block state_eval1(?,-,?,?,?,?,?).
3921 state_eval1(X,Expr,Value,PredRes,ExpectedType,Span,WF) :-
3922 % string must be provided ; we assume it will be ground
3923 parse_expr(Expr,TExpr),
3924 get_texpr_type(TExpr,Type),
3925 (unify_types_strict(ExpectedType,Type) -> true
3926 ; pretty_type(Type,TS), pretty_type(ExpectedType,ETS),
3927 ajoin(['Type ',TS, ' does not match expected type ', ETS, ' for:'],Msg),
3928 add_error('EVAL',Msg,Expr,Span),fail
3929 ),
3930 state_space:get_state_space_stats(NrNodes,_NrTransitions,_ProcessedNodes),
3931 get_wait_flag(NrNodes,'STATE_SAT',WF,LWF),
3932 state_eval2(X,TExpr,Value,LWF,PredRes).
3933 :- block state_eval2(?,-,?,?,?),state_eval2(-,?,?,-,?).
3934 state_eval2(X,TExpr,Value,_,PredRes) :-
3935 (number(X)
3936 -> eval_formula_in_state(TExpr,PredRes,X,Value)
3937 ; eval_formula_in_state(TExpr,PredRes,ID,Value), ID \= root, X=ID % avoid CLPFD errors on X
3938 ).
3939 :- use_module(kernel_equality,[equality_objects/3]).
3940 eval_formula_in_state(TExpr,PredRes,ID,Value) :-
3941 state_space:visited_expression(ID,State),
3942 state_corresponds_to_fully_setup_b_machine(State,FullState),
3943 add_prob_deferred_set_elements_to_store(FullState,FullState1,visible),
3944 debug_println(9,eval(TExpr,FullState1,Value)),
3945 equality_objects(Value,TExprValue,PredRes), % TO DO: Stronger Checks that types compatible
3946 b_interpreter:b_compute_expression_nowf(TExpr,[],FullState1,TExprValue,'STATE_EVAL',ID).
3947
3948 :- use_module(library(terms),[term_hash/2]).
3949 :- use_module(bmachine,[b_parse_machine_predicate/3]).
3950 :- dynamic parse_pred_cache/3.
3951 parse_pred(PredStr,TPred) :- term_hash(PredStr,Hash), parse_pred(PredStr,Hash,TPred).
3952 parse_pred(PredStr,Hash,TPred) :- parse_pred_cache(Hash,PredStr,TC),!, TPred=TC.
3953 parse_pred(PredStr,Hash,TPred) :-
3954 b_parse_machine_predicate(PredStr,[prob_ids(visible),variables],TC),
3955 assertz(parse_pred_cache(Hash,PredStr,TC)),
3956 TPred=TC.
3957
3958 :- dynamic parse_expr_cache/3.
3959 parse_expr(ExprStr,TExpr) :- term_hash(ExprStr,Hash), parse_expr(ExprStr,Hash,TExpr).
3960 parse_expr(ExprStr,Hash,TExpr) :- parse_expr_cache(Hash,ExprStr,TC),!, TExpr=TC.
3961 parse_expr(ExprStr,Hash,TExpr) :-
3962 atom_codes(ExprStr,Codes), %print(parsing(Expr,Codes)),nl,
3963 bmachine:b_parse_machine_expression_from_codes_with_prob_ids(Codes,TC),
3964 assertz(parse_expr_cache(Hash,ExprStr,TC)),
3965 TExpr=TC.
3966
3967 :- use_module(kernel_strings,[generate_code_sequence/3]).
3968 external_fun_type('HISTORY',[],[seq(integer)]).
3969 expects_spaninfo('HISTORY').
3970 :- public 'HISTORY'/2.
3971 'HISTORY'(Value,Span) :-
3972 get_current_history(H,Span), % does not include current state
3973 generate_code_sequence(H,1,Hist),
3974 kernel_objects:equal_object(Value,Hist).
3975
3976
3977 :- use_module(probsrc(state_space), [visited_state_corresponds_to_initialised_b_machine/1,history/1]).
3978
3979
3980 external_fun_type('EVAL_OVER_HISTORY',[X],[X,integer,seq(X)]).
3981 expects_unevaluated_args('EVAL_OVER_HISTORY').
3982 expects_spaninfo('EVAL_OVER_HISTORY').
3983 is_not_declarative('EVAL_OVER_HISTORY'). % depends on history, not explicitly part of arguments
3984
3985 :- public 'EVAL_OVER_HISTORY'/5.
3986 % related to tcltk_evaluate_expression_over_history
3987 :- block 'EVAL_OVER_HISTORY'(-,?,?,?,?), 'EVAL_OVER_HISTORY'(?,-,?,?,?).
3988 'EVAL_OVER_HISTORY'(CurValue,int(Limit),Res,Infos,Span) :-
3989 eval_over_history(CurValue,Limit,Res,Infos,Span).
3990
3991 :- use_module(probsrc(tools_lists),[include_maplist/3]).
3992 :- block eval_over_history(?,-,?,?,?).
3993 eval_over_history(CurValue,Limit,Res,[AST|_],Span) :-
3994 get_current_history(H,Span), % does not include current state
3995 (H=[ID1|SeqOfStateIds], \+visited_state_corresponds_to_initialised_b_machine(ID1) -> true ; SeqOfStateIds=H),
3996 (Limit<0 -> Seq2=SeqOfStateIds ; limit_history(SeqOfStateIds,Limit,Seq2,_Len)),
3997 include_maplist(eval_formula_in_state(AST,pred_true),Seq2,Values),
3998 append(Values,[CurValue],AllValues),
3999 convert_list_to_seq(AllValues,Res).
4000
4001 limit_history([],_,[],0).
4002 limit_history([H|T],Lim,Res,Len1) :- limit_history(T,Lim,TRes,Len), Len1 is Len+1,
4003 (Len >= Lim -> Res = TRes ; Res = [H|TRes]).
4004
4005
4006 :- use_module(probsrc(bool_pred),[negate/2]).
4007 external_fun_type('CHANGED',[X],[X,boolean]).
4008 expects_unevaluated_args('CHANGED').
4009 expects_spaninfo('CHANGED').
4010 is_not_declarative('CHANGED'). % depends on history, not explicitly part of arguments
4011
4012 :- public 'CHANGED'/4.
4013 % check if an expression has changed wrt the preceding state in the history
4014 :- block 'CHANGED'(-,?,?,?).
4015 'CHANGED'(CurValue,Res,[AST|_],Span) :-
4016 (get_current_history(H,Span),
4017 last(H,PrevID), % get_current_predecessor_state_id does not take current_state_id_for_external_fun into account
4018 visited_state_corresponds_to_initialised_b_machine(PrevID)
4019 -> eval_formula_in_state(AST,pred_true,PrevID,PrevValue),
4020 % TODO: the AST could refer to local variables, e.g., if CHANGED is called in a set comprehension
4021 % currently this will lead to identifier not found error messages
4022 equality_objects(CurValue,PrevValue,EqRes),
4023 negate(EqRes,Res)
4024 ; Res=pred_false
4025 ).
4026 external_fun_type('INCREASING',[X],[X,boolean]).
4027 expects_unevaluated_args('INCREASING').
4028 expects_spaninfo('INCREASING').
4029 is_not_declarative('INCREASING'). % depends on history, not explicitly part of arguments
4030
4031 :- public 'INCREASING'/4.
4032 % check if an expression has increased wrt the preceding state in the history
4033 :- block 'INCREASING'(-,?,?,?).
4034 'INCREASING'(CurValue,Res,[AST|_],Span) :-
4035 (get_current_history(H,Span),
4036 last(H,PrevID), % get_current_predecessor_state_id does not take current_state_id_for_external_fun into account
4037 visited_state_corresponds_to_initialised_b_machine(PrevID)
4038 -> eval_formula_in_state(AST,pred_true,PrevID,PrevValue),
4039 'LESS'(PrevValue,CurValue,Res) % LESS can handle numbers, strings, enumerated sets, ...
4040 ; Res=pred_false
4041 ).
4042
4043
4044 :- use_module(state_space,[is_initial_state_id/1]).
4045
4046 :- public 'INITIAL_STATE'/3.
4047 expects_waitflag('INITIAL_STATE'). % external function with unknown return type
4048 'INITIAL_STATE'(int(InitialState),PredRes,WF) :-
4049 get_wait_flag(2,'INITIAL_STATE',WF,LWF),
4050 is_init2(InitialState,PredRes,LWF).
4051 :- block is_init2(-,-,?), is_init2(-,?,-).
4052 is_init2(InitialState,PredRes,_) :-
4053 PredRes == pred_true,!,
4054 is_initial_state_id(InitialState).
4055 is_init2(InitialState,PredRes,_) :- number(InitialState),!,
4056 (is_initial_state_id(InitialState) -> PredRes=pred_true ; PredRes=pred_false).
4057 is_init2(InitialState,PredRes,_LWF) :-
4058 PredRes == pred_false,!,
4059 when(nonvar(InitialState), \+is_initial_state_id(InitialState)).
4060 is_init2(InitialState,PredRes,LWF) :-
4061 add_internal_error('Uncovered case: ', is_init2(InitialState,PredRes,LWF)),fail.
4062
4063
4064 % provide information about a particular B machine in the project
4065 :- public 'MACHINE_INFO'/4.
4066 expects_waitflag('MACHINE_INFO').
4067 external_fun_type('MACHINE_INFO',[],[string,string,string]).
4068 :- block 'MACHINE_INFO'(?,-,?,?).
4069 'MACHINE_INFO'(M,string(I),Value,WF) :-
4070 get_wait_flag(2,'MACHINE_INFO',WF,LWF), % TO DO: use number of machines
4071 machine_info2(I,M,Value,LWF).
4072
4073 :- use_module(b_machine_hierarchy,[machine_type/2]).
4074 :- block machine_info2(-,?,?,?), machine_info2(?,-,?,-).
4075 machine_info2(INFO,M,Value,_LWF) :-
4076 (ground(M) -> M = string(MachineName) ; true),
4077 machine_info3(INFO,MachineName,Type),
4078 (M,Value) = (string(MachineName),string(Type)).
4079
4080 :- use_module(b_machine_hierarchy,[machine_type/2]).
4081 % :- use_module(extension('probhash/probhash'),[raw_sha_hash/2]). % already imported above
4082 :- use_module(bmachine,[get_full_b_machine/2]).
4083 machine_info3('TYPE',MachineName,Type) :- !, machine_type(MachineName,Type).
4084 % SHA_HASH
4085 machine_info3(INFO,_,_) :- add_error('MACHINE_INFO','Unknown info field (TYPE recognised): ',INFO),fail.
4086
4087
4088 :- use_module(tools_strings,[get_hex_codes/2]).
4089 external_fun_type('INT_TO_HEX_STRING',[],[integer,string]).
4090 :- public 'INT_TO_HEX_STRING'/2.
4091 :- block 'INT_TO_HEX_STRING'(-,?).
4092 'INT_TO_HEX_STRING'(int(Int),Res) :- int_to_hex(Int,Res).
4093
4094 :- block int_to_hex(-,?).
4095 int_to_hex(Int,Res) :-
4096 (Int >= 0 -> Nat=Int ; Nat is -(Int)),
4097 get_hex_codes(Nat,Chars),
4098 (Int >= 0 -> atom_codes(Atom,Chars) ; atom_codes(Atom,[45|Chars])), % "-" = [45]
4099 Res = string(Atom).
4100
4101
4102 :- use_module(tools_strings,[get_hex_bytes/2]).
4103 sha_hash_as_hex_codes(Term,SHAHexCodes) :-
4104 raw_sha_hash(Term,RawListOfBytes),
4105 get_hex_bytes(RawListOfBytes,SHAHexCodes).
4106
4107
4108
4109 %-------------------
4110
4111 % returns list of strings for info string such as files, variables,...
4112 external_fun_type('PROJECT_STATISTICS',[],[string,integer]).
4113 expects_waitflag('PROJECT_STATISTICS').
4114 expects_spaninfo('PROJECT_STATISTICS').
4115 :- public 'PROJECT_STATISTICS'/4.
4116 'PROJECT_STATISTICS'(Str,Res,Span,WF) :-
4117 kernel_waitflags:get_wait_flag(10,'PROJECT_STATISTICS',WF,WF10), % will enumerate possible input strings
4118 project_stats1(Str,Res,WF10,Span).
4119
4120 :- use_module(bmachine,[b_machine_statistics/2]).
4121 :- block project_stats1(-,?,-,?).
4122 project_stats1(string(INFO),Res,_,Span) :-
4123 if(b_machine_statistics(INFO,Nr), Res=int(Nr),
4124 add_error('PROJECT_STATISTICS','Unknown info field: ',INFO,Span)).
4125
4126
4127 % returns list of strings for info string such as files, variables,...
4128 external_fun_type('PROJECT_INFO',[],[string,set(string)]).
4129 expects_waitflag('PROJECT_INFO').
4130 expects_spaninfo('PROJECT_INFO').
4131 :- public 'PROJECT_INFO'/4.
4132 'PROJECT_INFO'(Str,Res,Span,WF) :-
4133 kernel_waitflags:get_wait_flag(10,'PROJECT_INFO',WF,WF10), % will enumerate possible input strings
4134 project_info1(Str,Res,WF10,Span).
4135
4136 :- block project_info1(-,?,-,?).
4137 project_info1(string(INFO),Res,_,_Span) :- INFO==help,!,
4138 L = [files, absolute-files, main-file, main-machine, sha-hash,
4139 variables, constants, sets, operations, assertion_labels, invariant_labels],
4140 maplist(make_string,L,SL),
4141 kernel_objects:equal_object(SL,Res).
4142 project_info1(string(INFO),Res,_,Span) :-
4143 if(list_info(INFO,L),
4144 (maplist(make_string,L,SL),
4145 kernel_objects:equal_object(SL,Res)),
4146 (add_error(external_functions,'Illegal argument for PROJECT_INFO or :list (use help to obtain valid arguments) : ',INFO,Span),
4147 fail)).
4148
4149 :- use_module(bmachine).
4150 :- use_module(bsyntaxtree, [get_texpr_ids/2, get_texpr_label/2]).
4151 :- use_module(tools,[get_tail_filename/2]).
4152 list_info(files,TL) :- (b_get_all_used_filenames(L) -> true ; L=[]), maplist(get_tail_filename,L,TL).
4153 list_info('absolute-files',L) :- (b_get_all_used_filenames(L) -> true ; L=[]).
4154 list_info('main-file',L) :- (b_get_main_filename(F) -> get_tail_filename(F,TF),L=[TF] ; L=[]).
4155 list_info('main-machine',L) :- findall(Name,get_full_b_machine(Name,_),L). % gets only the main machine
4156 list_info('sha-hash',[AtomHash]) :-
4157 get_full_b_machine_sha_hash(Bytes),
4158 get_hex_bytes(Bytes,Hash), atom_codes(AtomHash,Hash).
4159 list_info(variables,L) :- b_get_machine_variables(LT), get_texpr_ids(LT,L).
4160 list_info(constants,L) :- b_get_machine_constants(LT), get_texpr_ids(LT,L).
4161 list_info(sets,L) :- findall(S,b_get_machine_set(S),L).
4162 list_info(operations,L) :- findall(S,b_top_level_operation(S),L).
4163 list_info(assertion_labels,L) :-
4164 findall(ID,(b_get_assertions(all,_,Ass), member(Assertion,Ass),get_texpr_label(Assertion,ID)),L).
4165 list_info(invariant_labels,L) :-
4166 findall(ID,(b_get_invariant_from_machine(C), conjunction_to_list(C,CL),
4167 member(Inv,CL),get_texpr_label(Inv,ID)),L).
4168
4169
4170 make_string(X,Res) :- atom(X),!,Res=string(X).
4171 make_string(X,Res) :- format_to_codes('~w',X,C), atom_codes(Atom,C), Res=string(Atom).
4172
4173 % obtain the source code of an identifier
4174 external_fun_type('SOURCE',[],[string,string]).
4175 :- public 'SOURCE'/2.
4176 'SOURCE'(string(ID),SourceCode) :- source2(ID,SourceCode).
4177 :- block source2(-,?).
4178 source2(ID,SourceCode) :-
4179 source_code_for_identifier(ID,_,_,_OriginStr,_,Source),
4180 translate:translate_bexpression(Source,SC),
4181 SourceCode = string(SC).
4182
4183
4184 % obtain various information about ProB (STRING result)
4185 external_fun_type('PROB_INFO_STR',[],[string,string]).
4186 expects_waitflag('PROB_INFO_STR').
4187 :- assert_must_succeed(external_functions:'PROB_INFO_STR'(string('prob-version'),string(_),_)).
4188 :- public 'PROB_INFO_STR'/3.
4189 % :- block 'PROB_INFO_STR'(-,?). % no block: this way we can via backtracking generate solutions
4190 'PROB_INFO_STR'(Str,Res,WF) :-
4191 kernel_waitflags:get_wait_flag(10,'PROB_INFO_STR',WF,WF10), % will enumerate possible input strings
4192 prob_info1(Str,Res,WF10,WF).
4193
4194 :- use_module(tools,[ajoin_with_sep/3]).
4195 :- block prob_info1(-,?,-,?).
4196 prob_info1(string(INFO),Res,_,WF) :-
4197 if(prob_info2(INFO,Str),true,
4198 (findall(I,prob_info2(I,_),Is),
4199 ajoin_with_sep(['Unknown info field, known fields:'|Is],' ',Msg),
4200 add_error_wf('PROB_INFO_STR',Msg,I,unknown,WF),
4201 Str = 'ERROR'
4202 )),
4203 make_string(Str,Res).
4204
4205 :- use_module(probsrc(tools_strings),[ajoin/2]).
4206 :- use_module(parsercall,[get_parser_version/1, get_java_command_path/1, get_java_fullversion/3]).
4207 :- use_module(version, [version_str/1, revision/1, lastchangeddate/1]).
4208 prob_info2('prob-version',V) :- version_str(V).
4209 prob_info2('parser-version',V) :- get_parser_version(V).
4210 prob_info2('prolog-version',V) :- current_prolog_flag(version,V).
4211 prob_info2('prob-revision',V) :- revision(V).
4212 prob_info2('prob-last-changed-date',V) :- lastchangeddate(V).
4213 prob_info2('java-version',V) :- get_java_fullversion(Maj,Min,Sfx), ajoin([Maj,'.',Min,'.',Sfx],V).
4214 prob_info2('java-command-path',V) :- get_java_command_path(V).
4215 prob_info2('current-time',V) :- get_info2(time,string(V)). % Maybe we can get rid of GET_INFO ?
4216
4217
4218 % obtain various information about ProB (INTEGER result)
4219 external_fun_type('PROB_STATISTICS',[],[string,integer]).
4220 expects_waitflag('PROB_STATISTICS').
4221 expects_spaninfo('PROB_STATISTICS').
4222 external_function_requires_state('PROB_STATISTICS'). % e.g., for current-state-id
4223 :- public 'PROB_STATISTICS'/4.
4224 'PROB_STATISTICS'(Str,Res,Span,WF) :-
4225 kernel_waitflags:get_wait_flag(10,'PROB_STATISTICS',WF,WF10), % will enumerate possible input strings
4226 prob_info_int1(Str,Res,Span,WF10,WF).
4227
4228 % old name of function:
4229 :- public 'PROB_INFO_INT'/4.
4230 'PROB_INFO_INT'(Str,Res,Span,WF) :- 'PROB_STATISTICS'(Str,Res,Span,WF).
4231
4232 :- block prob_info_int1(-,?,?,-,?).
4233 prob_info_int1(string(INFO),Res,Span,_,WF) :-
4234 if(prob_info_int1(INFO,I), Res=int(I),
4235 (add_error_wf('PROB_STATISTICS','Unknown info field: ',INFO,Span,WF),
4236 fail)).
4237
4238 :- use_module(state_space_exploration_modes,[get_current_breadth_first_level/1]).
4239 :- use_module(state_space,[get_state_space_stats/3]).
4240 prob_info_int1('current-state-id',StateIDNr) :- get_current_state_id(ID),convert_id_to_nr(ID,StateIDNr).
4241 prob_info_int1('states',NrNodes) :- get_state_space_stats(NrNodes,_,_).
4242 prob_info_int1('transitions',NrTransitions) :- get_state_space_stats(_,NrTransitions,_).
4243 prob_info_int1('processed-states',ProcessedNodes) :- get_state_space_stats(_,_,ProcessedNodes).
4244 prob_info_int1('bf-level',Level) :- (get_current_breadth_first_level(R) -> Level = R ; Level = -1).
4245 prob_info_int1('now-timestamp',N) :- now(N). % provide UNIX timesstamp
4246 prob_info_int1('prolog-runtime',V) :- statistics(runtime,[V,_]).
4247 prob_info_int1('prolog-walltime',V) :- statistics(walltime,[V,_]).
4248 prob_info_int1('prolog-memory-bytes-used',V) :- statistics(memory_used,V).
4249 prob_info_int1('prolog-memory-bytes-free',V) :- statistics(memory_free,V).
4250 prob_info_int1('prolog-global-stack-bytes-used',V) :- statistics(global_stack_used,V).
4251 prob_info_int1('prolog-local-stack-bytes-used',V) :- statistics(local_stack_used,V).
4252 %prob_info_int1('prolog-global-stack-bytes-free',V) :- statistics(global_stack_free,V).
4253 %prob_info_int1('prolog-local-stack-bytes-free',V) :- statistics(local_stack_free,V).
4254 prob_info_int1('prolog-trail-bytes-used',V) :- statistics(trail_used,V).
4255 prob_info_int1('prolog-choice-bytes-used',V) :- statistics(choice_used,V).
4256 prob_info_int1('prolog-atoms-bytes-used',V) :- statistics(atoms_used,V).
4257 prob_info_int1('prolog-atoms-nb-used',V) :- statistics(atoms_nbused,V).
4258 prob_info_int1('prolog-gc-count',V) :- statistics(gc_count,V).
4259 prob_info_int1('prolog-gc-time',V) :- statistics(gc_time,V).
4260
4261 % --------------------
4262
4263 % coverage/projection functions:
4264
4265 external_fun_type('STATE_VALUES',[T],[string,set(couple(couple(integer,integer),T))]).
4266 expects_unevaluated_args('STATE_VALUES').
4267 :- public 'STATE_VALUES'/3.
4268 :- block 'STATE_VALUES'(-,?,?).
4269 'STATE_VALUES'(_Value,Res,[AST]) :-
4270 state_space_reduction:compute_set_of_covered_values_for_typed_expression(AST,Set),
4271 kernel_objects:equal_object_optimized(Set,Res).
4272
4273 % TODO: other projection/reduction operators: projection as graph, ...
4274 % could be useful to have a minimum/maximum operator on sets which uses Prolog order in avl
4275
4276 % -----------------
4277
4278 % obtain various information about bvisual2 Formulas
4279 external_fun_type('FORMULA_INFOS',[],[string,seq(string)]).
4280 expects_waitflag('FORMULA_INFOS').
4281 :- public 'FORMULA_INFOS'/3.
4282 'FORMULA_INFOS'(Str,Res,WF) :-
4283 kernel_waitflags:get_wait_flag(10,'FORMULA_INFOS',WF,WF10), % will enumerate possible input strings
4284 formula_info(Str,_,Res,_,WF10).
4285 external_fun_type('FORMULA_VALUES',[],[string,seq(string)]).
4286 expects_waitflag('FORMULA_VALUES').
4287 :- public 'FORMULA_VALUES'/3.
4288 'FORMULA_VALUES'(Str,Res,WF) :-
4289 kernel_waitflags:get_wait_flag(10,'FORMULA_VALUES',WF,WF10), % will enumerate possible input strings
4290 formula_info(Str,_,_,Res,WF10).
4291
4292 :- use_module(extrasrc(bvisual2),[bv_get_top_level_formula/4, bv_value_to_atom/2]).
4293
4294 % valid TopLevelCategories are constants, definitions, guards_top_level, inv, sets, variables
4295 :- block formula_info(-,?,?,?,-).
4296 formula_info(string(TopLevelCategory),CatTextRes,LabelRes,ValuesRes,_) :-
4297 bv_get_top_level_formula(TopLevelCategory,CatText,Labels,Values),
4298 CatTextRes = string(CatText),
4299 maplist(make_string,Labels,LS),
4300 convert_list_to_seq(LS,LabelRes),
4301 maplist(make_value,Values,LV),
4302 convert_list_to_seq(LV,ValuesRes).
4303
4304 make_value(V,string(A)) :- bv_value_to_atom(V,A).
4305 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4306
4307
4308 % --------------------------
4309
4310 :- use_module(covsrc(hit_profiler),[add_hit/2, add_hit_if_not_covered/2,
4311 get_profile_statistics/2, profile_functor/1]). %profiler:profile_statistics.
4312
4313 :- public 'GET_PROFILE_STATISTICS'/3.
4314 is_not_declarative('GET_PROFILE_STATISTICS').
4315 :- block 'GET_PROFILE_STATISTICS'(-,?,?).
4316 'GET_PROFILE_STATISTICS'(string(PP),_DummyType,Res) :- % DummyType is just there for typing purposes
4317 if(profile_functor(PP),
4318 (get_profile_statistics(PP,Hits),
4319 maplist(translate_hit_to_b,Hits,List)),
4320 List = []),
4321 equal_object_optimized(List,Res, 'GET_PROFILE_STATISTICS').
4322 %equal_object(List,Res,'GET_PROFILE_STATISTICS'), print(res(Res)),nl.
4323
4324 translate_hit_to_b(hit(Arg,Nr),(Arg,int(Nr))).
4325
4326 :- public 'GET_PROFILE_POINTS'/1.
4327 'GET_PROFILE_POINTS'(Res) :- findall(string(S),profile_functor(S),List),
4328 equal_object_optimized(List,Res,'PROFILE_POINT').
4329
4330 expects_spaninfo('PROFILE').
4331 :- public 'PROFILE'/5.
4332 :- block 'PROFILE'(-,?,?,?,?), 'PROFILE'(?,-,?,?,?). %, 'PROFILE'(?,-,?,?,?).
4333 'PROFILE'(string(PP),Count,Value,ValueRes,SpanInfo) :-
4334 add_profile_exf_hit(Value,PP,SpanInfo,Count),
4335 equal_object(Value,ValueRes,'PROFILE').
4336
4337 :- block add_profile_exf_hit(-,?,?,?), add_profile_exf_hit(?,-,?,?).
4338 add_profile_exf_hit(pred_true,PP,SpanInfo,Count) :- !, add_value_hit(Count,pred_true,PP,SpanInfo).
4339 add_profile_exf_hit(pred_false,PP,SpanInfo,Count) :- !, add_value_hit(Count,pred_false,PP,SpanInfo).
4340 add_profile_exf_hit(int(X),PP,SpanInfo,Count) :- !, add_int_hit(X,PP,SpanInfo,Count).
4341 add_profile_exf_hit(string(X),PP,SpanInfo,Count) :- !, add_string_hit(X,PP,SpanInfo,Count).
4342 add_profile_exf_hit(Value,PP,SpanInfo,Count) :- when(ground(Value), add_complex_hit(Value,PP,SpanInfo,Count)).
4343
4344 add_complex_hit(Value,PP,SpanInfo,Count) :- print(PP), print(' : '), translate:print_bvalue(Value),nl,
4345 add_value_hit(Count,Value,PP,SpanInfo).
4346
4347 :- block add_int_hit(-,?,?,?).
4348 add_int_hit(X,PP,SpanInfo,Count) :- add_value_hit(Count,int(X),PP,SpanInfo).
4349 :- block add_string_hit(-,?,?,?).
4350 add_string_hit(X,PP,SpanInfo,Count) :- add_value_hit(Count,string(X),PP,SpanInfo).
4351
4352 add_value_hit(pred_true,Val,PP,_) :- add_hit(PP,Val).
4353 add_value_hit(pred_false,Val,PP,_) :- add_hit_if_not_covered(PP,Val).
4354
4355 % -------------------
4356
4357 :- use_module(memoization,[get_complete_memoization_expansion/6]).
4358
4359 expects_spaninfo('MEMOIZE_STORED_FUNCTION').
4360 expects_waitflag('MEMOIZE_STORED_FUNCTION').
4361 :- public 'MEMOIZE_STORED_FUNCTION'/4.
4362 :- block 'MEMOIZE_STORED_FUNCTION'(-,?,?,?).
4363 'MEMOIZE_STORED_FUNCTION'(int(MemoID),Res,Span,WF) :- memoize_get_aux(MemoID,Res,Span,WF).
4364
4365 :- block memoize_get_aux(-,?,?,?).
4366 memoize_get_aux(MemoID,Res,Span,WF) :-
4367 if(get_complete_memoization_expansion(MemoID,RV,_Done,Span,'MEMOIZE_STORED_FUNCTION',WF),
4368 kernel_objects:equal_object_wf(Res,RV,WF),
4369 add_error(external_functions,'Function ID not registered:',MemoID,Span)).
4370
4371 % -------------------
4372
4373 :- use_module(eval_let_store,[stored_let_value/3, set_stored_let_value/3,
4374 retract_stored_let_value/3, reset_let_values/0,
4375 extend_state_with_stored_lets/2, get_stored_let_typing_scope/1]).
4376
4377 :- public 'STORE'/4.
4378 external_fun_type('STORE',[X],[X,X]).
4379 expects_waitflag('STORE').
4380 expects_unevaluated_args('STORE').
4381 % stores values just like :let in the REPL does, but can be used within a predicate;
4382 % here name inferred from AST and it is a transparent function for more convenient annotation
4383 % also a way to store global values
4384 :- block 'STORE'(-,?,?,?).
4385 'STORE'(Val,Res,[TVal],WF) :- equal_object_optimized_wf(Val,Res,'STORE',WF),
4386 (translate:try_get_identifier(TVal,ID) -> true % also checks for was_identifier
4387 ; translate:translate_bexpression(TVal,ID),
4388 add_warning('STORE','The expression is not an identifier:',ID,TVal)
4389 ),
4390 'STORE_VALUE'(string(ID),Val,pred_true,[_,TVal],WF).
4391
4392 external_fun_type('STORE_VALUE',[X],[string,X,boolean]).
4393 expects_waitflag('STORE_VALUE').
4394 expects_unevaluated_args('STORE_VALUE').
4395 % stores values just like :let in the REPL does, but can be used within a predicate
4396 :- block 'STORE_VALUE'(-,?,?,?,?).
4397 'STORE_VALUE'(string(ID),Val,PredRes,UnevaluatedArgs,WF) :- PredRes=pred_true,
4398 get_enumeration_finished_wait_flag(WF,EWF),
4399 (UnevaluatedArgs = [_,TVal]
4400 -> get_texpr_type(TVal,Type)
4401 ; add_error('STORE_VALUE','Unexpected AST for arguments:',UnevaluatedArgs),
4402 Type=any),
4403 store_value(ID,Type,Val,EWF).
4404
4405 :- block store_value(-,?,?,?), store_value(?,?,?,-).
4406 store_value(ID,Type,Val,_) :-
4407 adapt_stored_id(ID,FullID),
4408 set_stored_let_value(FullID,Type,Val).
4409
4410 adapt_stored_id(ID,FullID) :-
4411 atom_concat('$USER.',ID,FullID). % avoid name clashes with other variables
4412 % Note: with :let in the REPL you want to re-use the variable; here we probably only access it using RECALL_VALUE
4413
4414 :- use_module(btypechecker, [unify_types_werrors/4]).
4415 :- public 'RECALL_VALUE'/5.
4416 external_fun_type('RECALL_VALUE',[X],[string,X]).
4417 expects_waitflag('RECALL_VALUE').
4418 expects_spaninfo('RECALL_VALUE').
4419 expects_type('RECALL_VALUE').
4420 % typically has to be used within a predicate to type the return value x:INTEGER & x=RECALL_VALUE("name")
4421 :- block 'RECALL_VALUE'(-,?,?,?,?).
4422 'RECALL_VALUE'(string(ID),Res,Type,Span,WF) :-
4423 recall_value(ID,Res,Type,Span,WF).
4424
4425 :- block recall_value(-,?,?,?,?).
4426 recall_value(ID,Res,Type,Span,WF) :-
4427 adapt_stored_id(ID,FullID),
4428 stored_let_value(FullID,StoredType,Val),
4429 !,
4430 (unify_types_werrors(Type,StoredType,Span,'RECALL_VALUE')
4431 -> equal_object_optimized_wf(Val,Res,'RECALL_VALUE',WF)
4432 ; add_error_wf('RECALL_VALUE','Stored value has incompatible type:',ID,Span,WF)
4433 ).
4434 recall_value(ID,_,_,Span,WF) :-
4435 add_error_wf('RECALL_VALUE','No value stored with STORE_VALUE or :let for:',ID,Span,WF),
4436 fail.
4437
4438
4439 :- public 'TRY_RECALL_VALUE'/6.
4440 external_fun_type('TRY_RECALL_VALUE',[X],[string,X,X]).
4441 expects_waitflag('TRY_RECALL_VALUE').
4442 expects_spaninfo('TRY_RECALL_VALUE').
4443 expects_type('TRY_RECALL_VALUE').
4444 % can be used more easily within an expression as type provided by default value
4445 :- block 'TRY_RECALL_VALUE'(-,?,?,?,?,?).
4446 'TRY_RECALL_VALUE'(string(ID),DefaultValue,Res,Type,Span,WF) :-
4447 recall_value_with_default(ID,DefaultValue,Res,Type,Span,WF).
4448
4449 :- block recall_value_with_default(-,?,?,?,?,?).
4450 recall_value_with_default(ID,_Default,Res,Type,Span,WF) :-
4451 adapt_stored_id(ID,FullID),
4452 stored_let_value(FullID,StoredType,Val),
4453 !,
4454 (unify_types_werrors(Type,StoredType,Span,'TRY_RECALL_VALUE')
4455 -> equal_object_optimized_wf(Val,Res,'RECALL_VALUE',WF)
4456 ; add_error_wf('TRY_RECALL_VALUE','Stored value has incompatible type:',ID,Span,WF)
4457 ).
4458 recall_value_with_default(_ID,Default,Res,_,_Span,WF) :-
4459 equal_object_optimized_wf(Default,Res,'TRY_RECALL_VALUE',WF).
4460
4461 :- public 'CAN_RECALL_VALUE'/3.
4462 external_fun_type('CAN_RECALL_VALUE',[],[string,boolean]).
4463 expects_waitflag('CAN_RECALL_VALUE').
4464 :- block 'CAN_RECALL_VALUE'(-,?,?).
4465 'CAN_RECALL_VALUE'(ID,PredRes,WF) :-
4466 (nonvar(ID) -> true
4467 ; kernel_waitflags:get_wait_flag(10,'CAN_RECALL_VALUE',WF,WF10)),
4468 has_stored_value(ID,PredRes,WF10).
4469
4470 :- block has_stored_value(-,?,-).
4471 has_stored_value(string(ID),PredRes,_) :- nonvar(ID),!,
4472 adapt_stored_id(ID,FullID),
4473 if(stored_let_value(FullID,_StoredType,_Val),PredRes=pred_true,PredRes=pred_false).
4474 has_stored_value(string(ID),PredRes,_) :-
4475 if(stored_let_value(FullID,_StoredType,_Val),PredRes=pred_true,PredRes=pred_false),
4476 adapt_stored_id(ID,FullID).
4477
4478 % TODO: do we need a DELETE_STORED_VALUE external function
4479
4480 % -------------------
4481 % a few ugraphs (unweighted graphs) utilities:
4482
4483 % an alternate implementation of closure1, cubic and using Warshall's algorithm from ugraphs
4484 expects_spaninfo('CLOSURE1').
4485 external_fun_type('CLOSURE1',[X],[set(couple(X,X)),set(couple(X,X))]).
4486 :- public 'CLOSURE1'/3.
4487 :- block 'CLOSURE1'(-,?,?).
4488 'CLOSURE1'([],Res,_) :- !, kernel_objects:equal_object(Res,[]).
4489 'CLOSURE1'(avl_set(A),Res,_) :- !, closure1_for_avl_set(A,R), kernel_objects:equal_object_optimized(R,Res).
4490 'CLOSURE1'(A,Res,Span) :- ground_value_check(A,Gr), closure1_gr(A,Gr,Res,Span).
4491
4492 closure1_gr(Set,_,Res,Span) :- convert_to_avl(Set,AVL),!, 'CLOSURE1'(AVL,Res,Span).
4493 closure1_gr(Set,_,_,Span) :-
4494 add_error(external_functions,'Cannot convert CLOSURE1 argument to set: ',Set,Span).
4495
4496 % compute strongly connected components
4497 expects_spaninfo('SCCS').
4498 external_fun_type('SCCS',[X],[set(couple(X,X)),set(set(X))]).
4499 :- public 'SCCS'/3.
4500 :- block 'SCCS'(-,?,?).
4501 'SCCS'([],Res,_) :- !, kernel_objects:equal_object(Res,[]).
4502 'SCCS'(avl_set(A),Res,_) :- !, sccs_for_avl_set(A,R), kernel_objects:equal_object_optimized(R,Res).
4503 'SCCS'(A,Res,Span) :- ground_value_check(A,Gr), sccs_gr(A,Gr,Res,Span).
4504
4505 sccs_gr(Set,_,Res,Span) :- convert_to_avl(Set,AVL),!, 'SCCS'(AVL,Res,Span).
4506 sccs_gr(Set,_,_,Span) :-
4507 add_error(external_functions,'Cannot convert SCCS argument to set: ',Set,Span).
4508
4509 :- use_module(extrasrc(avl_ugraphs),[avl_transitive_closure/2, avl_scc_sets/2]).
4510 closure1_for_avl_set(A,Res) :-
4511 avl_transitive_closure(A,TC),
4512 construct_avl_set(TC,Res).
4513 sccs_for_avl_set(A,Res) :-
4514 avl_scc_sets(A,TC),
4515 construct_avl_set(TC,Res).
4516 construct_avl_set(Avl,Res) :- empty_avl(Avl) -> Res = [] ; Res = avl_set(Avl).
4517 % -------------------
4518
4519 reset_kodkod :-
4520 true. %retractall(kodkod_pred(_,_)).
4521
4522 %:- use_module(probsrc(bsyntaxtree), [b_compute_expression/5]).
4523
4524 % KODKOD(ProblemID, LocalIDsOfPredicate, WaitToBeGroundBeforePosting, PredicateAsBooleanFunction)
4525 % EXTERNAL_PREDICATE_KODKOD(T1,T2) == INTEGER*T1*T2*BOOL;
4526 %:- dynamic kodkod_pred/2. % now stored as attribute in WF store
4527 do_not_evaluate_args('KODKOD').
4528 expects_unevaluated_args('KODKOD').
4529 expects_waitflag('KODKOD').
4530 expects_spaninfo('KODKOD').
4531 expects_state('KODKOD').
4532
4533 :- use_module(bsyntaxtree,[create_negation/2]).
4534 :- use_module(b_compiler,[b_optimize/6]).
4535 :- use_module(b_interpreter,[b_compute_expression/5]).
4536 :- public 'KODKOD'/6.
4537 :- block 'KODKOD'(-,?,?,?,?,?).
4538 'KODKOD'(PredRes,LocalState,State,UnevaluatedArgs,Span,WF) :-
4539 UnevaluatedArgs = [TID,IDEXPR,WAITIDEXPR,UEA],
4540 get_integer(TID,ID),
4541 construct_predicate(UEA,KPredicate),
4542 (PredRes == pred_false -> create_negation(KPredicate,Predicate) ; Predicate=KPredicate),
4543 must_get_identifiers('KODKOD',IDEXPR,TIdentifiers),
4544 get_texpr_ids(TIdentifiers,Ids),
4545 b_compute_expression(WAITIDEXPR,LocalState,State,WaitVal,WF),
4546 when(ground(WaitVal),
4547 ( b_optimize(Predicate,Ids,LocalState,State,CPredicate,WF),
4548 (debug:debug_mode(off) -> true
4549 ; add_message(kodkod,'STORING FOR KODKOD : ',ID:PredRes,Span), translate:print_bexpr(CPredicate),nl),
4550 kernel_waitflags:my_add_predicate_to_kodkod(WF,ID,CPredicate),
4551 %assertz(kodkod_pred(ID,CPredicate)), % TO DO: attach to WF Store !; assertz will break Prolog variable links !
4552 % TO DO: retract upon backtracking + store negation if PredRes = pred_false
4553 PredRes=pred_true
4554 )).
4555
4556
4557 :- use_module(probsrc(bsyntaxtree), [safe_create_texpr/3]).
4558 construct_predicate(b(convert_bool(P),_,_),Res) :- !, Res=P.
4559 construct_predicate(BoolExpr,Res) :-
4560 safe_create_texpr(equal(BoolExpr,b(boolean_true,boolean,[])),pred,Res).
4561
4562 :- use_module(kodkodsrc(kodkod), [replace_by_kodkod/3]).
4563 % EXTERNAL_PREDICATE_KODKOD_SOLVE(T1,T2) == INTEGER*T1*T2;
4564 expects_unevaluated_args('KODKOD_SOLVE').
4565 expects_waitflag('KODKOD_SOLVE').
4566 expects_state('KODKOD_SOLVE').
4567 :- public 'KODKOD_SOLVE'/8.
4568 :- block 'KODKOD_SOLVE'(-,?,?,?,?,?,?,?).
4569 'KODKOD_SOLVE'(int(ID),Ids,WaitIds,PredRes,LocalState,State,UEA,WF) :-
4570 when(ground(WaitIds),
4571 kodkod_solve_aux(ID,Ids,WaitIds,PredRes,LocalState,State,UEA,WF)).
4572
4573 :- use_module(library(ordsets),[ord_subtract/3]).
4574 kodkod_solve_aux(ID,Ids,_WaitIds,PredRes,LocalState,State,UEA,WF) :-
4575 %print(trigger_SOLVE(_WaitIds)),nl,
4576 get_wait_flag(2,'KODKOD_SOLVE',WF,LWF), % give other co-routines chance to fire
4577 kodkod_solve_aux2(ID,Ids,PredRes,LocalState,State,UEA,WF,LWF).
4578
4579 :- block kodkod_solve_aux2(?,?,?,?,?,?,?,-).
4580 kodkod_solve_aux2(ID,_,PredRes,LocalState,State,[_,IDEXPR,WAITIDEXPR],WF,_) :-
4581 %print(ls(LocalState,State)),nl,
4582 %findall(P,kodkod_pred(ID,P),Ps), % TO DO: obtain from WF Store
4583 kernel_waitflags:my_get_kodkod_predicates(WF,ID,Ps),
4584 length(Ps,Len),
4585 reverse(Ps,RPs), % we reverse Ps to put predicates in same order they were added by KODKOD / seems to influence analysis time
4586 conjunct_predicates(RPs,Predicate),
4587 %translate:print_bexpr(Predicate),nl,
4588 must_get_identifiers('KODKOD_SOLVE',IDEXPR,TIdentifiers),
4589 get_texpr_ids(TIdentifiers,Ids),
4590 ((get_identifiers(WAITIDEXPR,TWaitIds,[]), get_texpr_ids(TWaitIds,WaitIds),
4591 sort(WaitIds,SWIds),
4592 formatsilent('KODKOD_SOLVE Problem ~w (~w conjuncts), Identifiers: ~w, Waiting for ~w~n',[ID,Len,Ids,SWIds]),
4593 sort(Ids,SIds),
4594 ord_subtract(SIds,SWIds,IdsToSolve))
4595 -> b_optimize(Predicate,IdsToSolve,LocalState,State,CPredicate,WF), % inline known values
4596 (silent_mode(on) -> true ; print('compiled: '),translate:print_bexpr(CPredicate),nl,nl)
4597 ; CPredicate=Predicate
4598 ),
4599 (replace_by_kodkod(TIdentifiers,CPredicate,NewPredicate)
4600 -> (silent_mode(on) -> true ; print('AFTER KODKOD: '),translate:print_bexpr(NewPredicate),nl),
4601 b_interpreter:b_test_boolean_expression(NewPredicate,LocalState,State,WF)
4602 ; print('KODKOD cannot be applied'),nl,
4603 b_interpreter:b_test_boolean_expression(CPredicate,LocalState,State,WF)
4604 ),
4605 PredRes=pred_true.
4606
4607 must_get_identifiers(PP,TExpr,Res) :-
4608 (get_identifiers(TExpr,Ids,[]) -> Res=Ids
4609 ; add_error(PP,'Could not get identifiers: ',TExpr),fail).
4610
4611 get_identifiers(b(couple(A1,A2),_,_)) --> !, get_identifiers(A1), get_identifiers(A2).
4612 get_identifiers(b(identifier(ID),T,I)) --> [b(identifier(ID),T,I)].
4613 get_identifiers(b(integer(_),_,_)) --> []. % to do: accept other ground values; in case they are compiled
4614 get_identifiers(b(value(_),_,_)) --> []. % identifier has already been compiled
4615 get_identifiers(b(string(_),_,_)) --> [].
4616
4617
4618 % -------------------
4619 do_not_evaluate_args('SATSOLVER').
4620 expects_unevaluated_args('SATSOLVER').
4621 expects_waitflag('SATSOLVER').
4622 expects_spaninfo('SATSOLVER').
4623 expects_state('SATSOLVER').
4624
4625 :- use_module(kernel_tools,[value_variables/2]).
4626 :- public 'SATSOLVER'/6.
4627 :- block 'SATSOLVER'(-,?,?,?,?,?).
4628 'SATSOLVER'(PredRes,LocalState,State,UnevaluatedArgs,Span,WF) :-
4629 UnevaluatedArgs = [TID,IDEXPR,WAITIDEXPR,UEA],
4630 get_integer(TID,ID),
4631 construct_predicate(UEA,KPredicate),
4632 (PredRes == pred_false -> create_negation(KPredicate,Predicate) ; Predicate=KPredicate),
4633 must_get_identifiers('SATSOLVER',IDEXPR,TIdentifiers),
4634 get_texpr_ids(TIdentifiers,Ids),
4635 % Note: the Ids are not really necessary here; they are just used for b_optimize; see SATSOLVER_SOLVE below
4636 b_interpreter:b_compute_expression(WAITIDEXPR,LocalState,State,WaitVal,WF),
4637 value_variables(WaitVal,WVars),
4638 when(ground(WVars),
4639 ( %print(compile_for(ID,Ids)),nl,
4640 %nl,add_message(satsolver,'Optimzing for SATSOLVER_SOLVE: ',Predicate,Span), debug:nl_time,
4641 %translate:nested_print_bexpr(Predicate),nl,
4642 b_optimize(Predicate,Ids,LocalState,State,CPredicate,WF), % Ids are left in the closure
4643 (debug:debug_mode(off) -> true
4644 ; add_message(satsolver,'Storing for SATSOLVER_SOLVE: ',CPredicate,Span)
4645 ),
4646 kernel_waitflags:my_add_predicate_to_satsolver(WF,ID,CPredicate),
4647 % TO DO: retract upon backtracking + store negation if PredRes = pred_false
4648 PredRes=pred_true
4649 )).
4650
4651 expects_unevaluated_args('SATSOLVER_SOLVE').
4652 expects_waitflag('SATSOLVER_SOLVE').
4653 expects_state('SATSOLVER_SOLVE').
4654 :- public 'SATSOLVER_SOLVE'/8.
4655 :- block 'SATSOLVER_SOLVE'(-,?,?,?,?,?,?,?).
4656 'SATSOLVER_SOLVE'(int(ID),Ids,WaitIds,PredRes,LocalState,State,UEA,WF) :-
4657 value_variables(WaitIds,WVars),
4658 get_wait_flag1('SATSOLVER_SOLVE',WF,WF1),
4659 when(ground((WF1,WVars)),
4660 satsolver_solve_aux(ID,Ids,WaitIds,PredRes,LocalState,State,UEA,WF)).
4661 % Note: the Ids are not really necessary here; they are just used for b_optimize
4662 % The b_to_cnf conversion will look up all identifiers anyway, identifier or value(_) node makes no difference!
4663 % TODO: probably remove them
4664
4665 :- use_module(library(ordsets),[ord_subtract/3]).
4666 satsolver_solve_aux(ID,Ids,_WaitIds,PredRes,LocalState,State,UEA,WF) :-
4667 %print(trigger_SOLVE(_WaitIds)),nl,
4668 get_idle_wait_flag('SATSOLVER_SOLVE',WF,LWF), % give other co-routines chance to fire
4669 satsolver_solve_aux2(ID,Ids,PredRes,LocalState,State,UEA,WF,LWF).
4670
4671 :- use_module(extension('satsolver/b2sat'), [solve_predicate_with_satsolver/2]).
4672
4673 :- block satsolver_solve_aux2(?,?,?,?,?,?,?,-).
4674 satsolver_solve_aux2(ID,_,PredRes,LocalState,State,[_,IDEXPR,WAITIDEXPR],WF,_) :-
4675 print('SATSOLVER_SOLVE:'),nl,
4676 kernel_waitflags:my_get_satsolver_predicates(WF,ID,Ps),
4677 length(Ps,Len), format('Got ~w SATSOLVER predicates for ID: ~w~n',[Len,ID]),
4678 reverse(Ps,RPs), % we reverse Ps to put predicates in same order they were added, necessary??
4679 conjunct_predicates(RPs,Predicate),
4680 %translate:print_bexpr(Predicate),nl,
4681 must_get_identifiers('SATSOLVER_SOLVE',IDEXPR,TIdentifiers),
4682 get_texpr_ids(TIdentifiers,Ids),
4683 ((get_identifiers(WAITIDEXPR,TWaitIds,[]), get_texpr_ids(TWaitIds,WaitIds),
4684 sort(WaitIds,SWIds),
4685 formatsilent('Sat Solver identifiers: ~w ; waiting for ~w~n',[Ids,SWIds]),
4686 sort(Ids,SIds),
4687 ord_subtract(SIds,SWIds,IdsToSolve))
4688 -> b_optimize(Predicate,IdsToSolve,LocalState,State,CPredicate,WF), % inline known values
4689 (debug_mode(off) -> true
4690 ; print('compiled: '),translate:print_bexpr(CPredicate),nl,nl)
4691 ; CPredicate=Predicate
4692 ),
4693 (solve_predicate_with_satsolver(CPredicate,State)
4694 % if(b_interpreter:b_test_boolean_expression(CPredicate,[],State,WF),print(ok),
4695 % add_error_wf('SATSOLVER_SOLVE','SAT result not confirmed by ProB:',ID,CPredicate,WF))
4696 % TODO: catch errors if b_sat fails!
4697 %-> true
4698 % ; print('Calling SAT solver failed'),nl,
4699 % b_interpreter:b_test_boolean_expression(CPredicate,LocalState,State,WF)
4700 ),
4701 PredRes=pred_true.
4702 % -------------------
4703
4704
4705 expects_waitflag('UNSAT_CORE'). % WF not used at the moment
4706 expects_spaninfo('UNSAT_CORE').
4707 :- public 'UNSAT_CORE'/5.
4708 % EXTERNAL_FUNCTION_UNSAT_CORE(T) == (POW(T)-->BOOL)*POW(T) --> POW(T);
4709 % UNSAT_CORE(Fun,Set) == Set
4710 % example: UNSAT_CORE(f,0..200) = {2} with f = %x.(x:POW(INTEGER)|bool(x /\ 1..2={}))
4711 'UNSAT_CORE'(FunToBool,Set,ValueRes,SpanInfo,WF) :-
4712 'UNSAT_CORE_ACC'(FunToBool,Set,[],ValueRes,SpanInfo,WF).
4713
4714
4715 expects_waitflag('UNSAT_CORE_ACC'). % WF not used at the moment
4716 expects_spaninfo('UNSAT_CORE_ACC').
4717 % EXTERNAL_FUNCTION_UNSAT_CORE_ACC(T) == (POW(T)-->BOOL)*POW(T)*POW(T) --> POW(T);
4718 % UNSAT_CORE_ACC(Fun,Set,Acc) == Set\/Acc;
4719 % example: UNSAT_CORE_ACC(f,0..200,{}) = {2} & f = %x.(x:POW(INTEGER)|bool(x /\ 1..2={}))
4720 % provides a way to initialise the accumulator of the unsat core computation
4721 'UNSAT_CORE_ACC'(FunToBool,Set,Acc,ValueRes,SpanInfo,WF) :-
4722 expand_custom_set_to_list_wf(Set,ESet,_,compute_apply_true,WF),
4723 expand_custom_set_to_list_wf(Acc,EAcc,_,compute_apply_true,WF),
4724 debug_println(9,computing_unsat_core(ESet,EAcc)),
4725 when(ground((FunToBool,ESet)), compute_unsat_core(ESet,FunToBool,no_time_out,EAcc,ValueRes,SpanInfo,WF)).
4726
4727 % EXTERNAL_FUNCTION_UNSAT_CORE_ACC_TIMEOUT(T) == (POW(T)-->BOOL)*POW(T)*POW(T)*INTEGER --> POW(T);
4728 % UNSAT_CORE_ACC_TIMEOUT(Fun,Set,Acc,TO) == Set\/Acc;
4729 % example: UNSAT_CORE_ACC_TIMEOUT(f,0..200,{},100) = {2} & f = %x.(x:POW(INTEGER)|bool(x /\ 1..2={}))
4730 expects_waitflag('UNSAT_CORE_ACC_TIMEOUT'). % WF not used at the moment
4731 expects_spaninfo('UNSAT_CORE_ACC_TIMEOUT').
4732 :- public 'UNSAT_CORE_ACC_TIMEOUT'/7.
4733 'UNSAT_CORE_ACC_TIMEOUT'(FunToBool,Set,Acc,int(TimeOut),ValueRes,SpanInfo,WF) :-
4734 expand_custom_set_to_list_wf(Set,ESet,_,compute_apply_true,WF),
4735 expand_custom_set_to_list_wf(Acc,EAcc,_,compute_apply_true,WF),
4736 debug_println(9,computing_unsat_core(ESet,EAcc)),
4737 when(ground((FunToBool,ESet,TimeOut)), compute_unsat_core(ESet,FunToBool,TimeOut,EAcc,ValueRes,SpanInfo,WF)).
4738
4739 compute_unsat_core([],_FunToBool,_TimeOut,Core,Result,_SpanInfo,WF) :- equal_object_wf(Result,Core,WF).
4740 compute_unsat_core([H|T],FunToBool,TimeOut,Core,Result,SpanInfo,WF) :-
4741 debug_println(9,trying_to_remove(H,core(Core))),
4742 append(Core,T,CoreT),
4743 if(compute_apply_true_timeout(TimeOut,FunToBool,CoreT,SpanInfo),
4744 compute_unsat_core(T,FunToBool,TimeOut,[H|Core],Result,SpanInfo,WF), % we found a solution, H is needed in core
4745 compute_unsat_core(T,FunToBool,TimeOut, Core, Result,SpanInfo,WF) % contradiction also exists without H
4746 ).
4747
4748 :- use_module(library(timeout)).
4749 compute_apply_true_timeout(no_time_out,FunToBool,CoreT,SpanInfo) :- !,
4750 compute_apply_true(FunToBool,CoreT,SpanInfo).
4751 compute_apply_true_timeout(TO,FunToBool,CoreT,SpanInfo) :-
4752 time_out(compute_apply_true(FunToBool,CoreT,SpanInfo), TO, TORes),
4753 (TORes == success -> true ,format(user_output,'~nSUCCESS~n~n',[])
4754 ; format(user_output,'~nTIME-OUT: ~w~n~n',[TORes]),fail). % treat time-out like failure
4755
4756 compute_apply_true(FunToBool,CoreT,SpanInfo) :-
4757 init_wait_flags_with_call_stack(WF1,[prob_command_context(compute_apply_true,unknown)]),
4758 bsets_clp:apply_to(FunToBool,CoreT,pred_true,SpanInfo,WF1), % TO DO: also pass function type
4759 ground_wait_flags(WF1).
4760
4761 expects_waitflag('MAX_SAT').
4762 expects_spaninfo('MAX_SAT').
4763 :- public 'MAX_SAT'/5.
4764 % EXTERNAL_FUNCTION_MAX_SAT(T) == (POW(T)-->BOOL)*POW(T) --> POW(T);
4765 % MAX_SAT(Fun,Set) == Set;
4766 % example: MAX_SAT(f,0..3) = {0,3} & f = %x.(x:POW(INTEGER)|bool(x /\ 1..2={}))
4767
4768 'MAX_SAT'(FunToBool,Set,ValueRes,SpanInfo,WF) :-
4769 expand_custom_set_to_list_wf(Set,ESet,_,compute_apply_true,WF),
4770 debug_println(9,computing_unsat_core(ESet)),
4771 when(ground((FunToBool,ESet)), compute_maxsat_ground(ESet,FunToBool,ValueRes,SpanInfo,WF)).
4772
4773 compute_maxsat_ground(ESet,FunToBool,ValueRes,SpanInfo,WF) :-
4774 debug_println(9,computing_maxsat(ESet)), %nl,reset_walltime,
4775 get_wait_flag(1,'MAX_SAT',WF,LWF), % avoid computing straightaway in case pending co-routines fail; not really sure it is needed
4776 when(nonvar(LWF),compute_maxsat(ESet,FunToBool,[],ValueRes,SpanInfo,WF)).
4777 compute_maxsat([],_FunToBool,Core,Result,_SpanInfo,_WF) :- equal_object(Result,Core).
4778 compute_maxsat([H|T],FunToBool,Core,Result,SpanInfo,WF) :-
4779 debug_println(9,trying_to_add(H,core(Core))),
4780 %nl,nl,nl,print(maxsat(H,Core)),nl, print_walltime(user_output),nl,
4781 if(compute_apply_true(FunToBool,[H|Core],SpanInfo),
4782 compute_maxsat(T,FunToBool,[H|Core],Result,SpanInfo,WF),
4783 compute_maxsat(T,FunToBool, Core, Result,SpanInfo,WF) % contradiction also exists without H
4784 ).
4785
4786 % can be used to maximize a bounded integer expression
4787 % more limited than optimizing_solver (only optimizing integers), but using inlined branch and bound enumeration
4788 % example usage: xx:1..10 & res=10*xx-xx*xx & MAXIMIZE_EXPR(res)
4789 :- use_module(clpfd_interface,[clpfd_domain/3, clpfd_inrange/3, clpfd_size/2, clpfd_eq/2]).
4790 expects_waitflag('MAXIMIZE_EXPR').
4791 expects_spaninfo('MAXIMIZE_EXPR').
4792 :- public 'MAXIMIZE_EXPR'/4.
4793 'MAXIMIZE_EXPR'(int(X),PredRes,Span,WF) :-
4794 %get_wait_flag1('MAXIMIZE_EXPR',WF,LWF),
4795 get_wait_flag(2,'MAXIMIZE_EXPR',WF,LWF),
4796 PredRes=pred_true,
4797 maximize_expr_wf(LWF,X,Span,WF).
4798 :- block maximize_expr_wf(-,?,?,?).
4799 maximize_expr_wf(_LWF,X,Span,WF) :-
4800 clpfd_size(X,Size), Size \= sup,
4801 clpfd_domain(X,Min,Max),
4802 Mid is round((Min + Max)/2),
4803 !,
4804 maximize_expr_6(Min,Mid,Max,X,Span,WF).
4805 maximize_expr_wf(_,_,Span,_) :-
4806 add_error(external_functions,'MAXIMIZE_EXPR/MINIMIZE_EXPR called on unbounded expression',Span),
4807 fail.
4808 maximize_expr_6(M,M,M,X,Span,WF) :- !, X=M,
4809 add_message(external_functions,'Checking optimisation target for MAXIMIZE_EXPR/MINIMIZE_EXPR: ',X,Span),
4810 ground_wait_flags(WF). % NOTE: without fully grounding WF: we do not know if a solution has really been found !
4811 maximize_expr_6(Min,Mid,Max,X,Span,WF) :- % tools_printing:print_term_summary(maximize_expr_6(Min,Mid,Max,X)),nl,
4812 %add_message(external_functions,'Optimisation target for MAXIMIZE_EXPR/MINIMIZE_EXPR: ',Min:Max,Span),
4813 if( (clpfd_inrange(X,Mid,Max),
4814 NMid is round((Mid+Max)/2),
4815 maximize_expr_6(Mid,NMid,Max,X,Span,WF)),
4816 true, % we found a solution in the upper half
4817 (Mid>Min, M1 is Mid-1,
4818 clpfd_inrange(X,Min,M1),
4819 NMid is round((Min+M1)/2),
4820 maximize_expr_6(Min,NMid,M1,X,Span,WF)
4821 ) ).
4822
4823 expects_waitflag('MINIMIZE_EXPR').
4824 expects_spaninfo('MINIMIZE_EXPR').
4825 :- public 'MINIMIZE_EXPR'/4.
4826 'MINIMIZE_EXPR'(int(X),PredRes,Span,WF) :-
4827 clpfd_eq(-X,MaxVar),
4828 'MAXIMIZE_EXPR'(int(MaxVar),PredRes,Span,WF).
4829
4830
4831 :- use_module(kernel_tools,[bexpr_variables/2]).
4832 % maximize is actually quite similar to CHOOSE; but it will choose maximum and use special algorithm for closures
4833 expects_waitflag('MAXIMIZE').
4834 expects_spaninfo('MAXIMIZE').
4835 :- public 'MAXIMIZE'/4.
4836 :- block 'MAXIMIZE'(-,?,?,?).
4837 'MAXIMIZE'([],_,Span,WF) :- !,
4838 add_wd_error_span('MAXIMIZE applied to empty set: ',[],Span,WF).
4839 'MAXIMIZE'(avl_set(A),H,_,_) :- !, avl_max(A,Max),kernel_objects:equal_object(H,Max).
4840 'MAXIMIZE'(closure(P,T,Body),FunValue,SpanInfo,WF) :- !,
4841 bexpr_variables(Body,ClosureWaitVars),
4842 debug_println(19,wait_maximize(P,ClosureWaitVars)),
4843 when(ground(ClosureWaitVars),maximize_closure(P,T,Body,FunValue,SpanInfo,WF)).
4844 'MAXIMIZE'([H|T],C,Span,WF) :- !,
4845 when(ground([H|T]),
4846 (convert_to_avl([H|T],AVL) -> 'MAXIMIZE'(AVL,C,Span,WF)
4847 ; add_wd_error_span('Cannot determine maximum element for MAXIMIZE: ',[H|T],Span,WF),
4848 kernel_objects:equal_object_wf(C,H,WF))
4849 ).
4850 'MAXIMIZE'(_,_,SpanInfo,_WF) :-
4851 add_error(external_functions,'MAXIMIZE requires set of values',SpanInfo),
4852 fail.
4853
4854 % move to optimizing solver
4855 % difference here is that entire constraint is re-set up every time; allowing Kodkod to be used
4856 maximize_closure(Parameters,ParameterTypes,ClosureBody,FunValue,_SpanInfo,WF) :-
4857 debug_println(maximizing(Parameters)),
4858 length(Parameters,Len), length(ParValues,Len),
4859 test_closure(Parameters,ParameterTypes,ClosureBody,ParValues),
4860 debug_println(19,found_initial_solution(ParValues)),
4861 !,
4862 maximize_closure2(Parameters,ParameterTypes,ClosureBody,ParValues,FunValue,WF).
4863 maximize_closure(_Parameters,_ParameterTypes,_ClosureBody,_FunValue,SpanInfo,_WF) :-
4864 add_error(external_functions,'MAXIMIZE: could not find solution for set comprehension',SpanInfo),
4865 fail.
4866
4867 maximize_closure2(Parameters,ParameterTypes,ClosureBody,PrevSol,FunValue,WF) :-
4868 Parameters=[PMax|_], ParameterTypes=[T1|_],
4869 PrevSol = [ PrevVal | _],
4870 debug_println(19,trying_to_improve_upon(PrevVal,PMax)),
4871 better_sol_pred(PMax,T1,PrevVal,Better),
4872 %translate:print_bexpr(Better),nl,
4873 bsyntaxtree:conjunct_predicates([Better,ClosureBody],NewBody),
4874 length(Parameters,Len), length(NewParValues,Len),
4875 test_closure(Parameters,ParameterTypes,NewBody,NewParValues),
4876 debug_println(19,found_better_solution(NewParValues)),
4877 !,
4878 maximize_closure2(Parameters,ParameterTypes,ClosureBody,NewParValues,FunValue,WF).
4879 maximize_closure2(_Parameters,_ParameterTypes,_ClosureBody,PrevSol,FunValue,WF) :-
4880 debug_println(19,cannot_improve),
4881 tools:convert_list_into_pairs(PrevSol,ParTuple),
4882 kernel_objects:equal_object_wf(ParTuple,FunValue,WF).
4883
4884 :- use_module(probsrc(solver_interface),[apply_kodkod_or_other_optimisations/4]).
4885 test_closure(Parameters,ParameterTypes,Body,ParValues) :-
4886 apply_kodkod_or_other_optimisations(Parameters,ParameterTypes,Body,Body2),
4887 custom_explicit_sets:b_test_closure(Parameters,ParameterTypes,Body2,ParValues,positive,no_wf_available). % positive instead of all_solutions
4888
4889 % generate predicate for better solution; % TO DO: support MINIMIZE by inverting args
4890 % TO DO: support more types: couples, booleans, ...
4891 better_sol_pred(PMax,integer,PrevVal,Better) :- !,
4892 Better = b(less(b(value(PrevVal),integer,[]),b(identifier(PMax),integer,[])),pred,[]).
4893 better_sol_pred(PMax,set(T1),PrevVal,Better) :- !,
4894 % WARNING: for sets we will only find one maximum, not all due to the cuts in maximize_closure(2) above
4895 Better = b(subset_strict(b(value(PrevVal),set(T1),[]),b(identifier(PMax),set(T1),[])),pred,[]).
4896 better_sol_pred(PMax,Type,_Val,_) :-
4897 add_error(external_functions,'MAXIMIZE requires first argument of set comprehension to be integer or set; cannot optimize: ',PMax:Type),fail.
4898
4899 % ----------------------------------
4900
4901 % EXTERNAL_FUNCTION_READ_XML == STRING --> seq(XML_ELement_Type);
4902 % with XML_ELement_Type == struct( recId: NATURAL1, pId:NATURAL, element:STRING, attributes: STRING +-> STRING, meta: STRING +-> STRING );
4903
4904 % XML_ELement_Type from LibraryXML.def:
4905 xml_element_type(record([ field(recId,integer), field(pId, integer), field(element,string),
4906 field(attributes, set(couple(string,string))),
4907 field(meta, set(couple(string,string))) ]) ).
4908
4909 performs_io('READ_XML').
4910 expects_spaninfo('READ_XML').
4911 :- public 'READ_XML'/3.
4912 :- block 'READ_XML'(-,?,?).
4913 'READ_XML'(string(File),Res,Span) :-
4914 read_xml(File,auto,Res,Span).
4915
4916 %expects_spaninfo('READ_XML'). both versions expect span info
4917 external_fun_type('READ_XML',[],[string,string,seq(XT)]) :- xml_element_type(XT).
4918 :- public 'READ_XML'/4.
4919 :- block 'READ_XML'(-,?,?,?),'READ_XML'(?,-,?,?).
4920 'READ_XML'(string(File),string(Encoding),Res,Span) :-
4921 read_xml(File,Encoding,Res,Span).
4922
4923
4924 :- use_module(tools, [read_string_from_file/3, detect_xml_encoding/3]).
4925 :- use_module(extrasrc(xml2b), [convert_xml_to_b/4]).
4926 :- use_module(preferences, [is_of_type/2]).
4927 :- block read_xml(-,?,?,?), read_xml(?,-,?,?).
4928 read_xml(File,EncodingPref,Res,Span) :-
4929 b_absolute_file_name(File,AFile,Span),
4930 (EncodingPref = 'auto',
4931 detect_xml_encoding(AFile,_Version,HeaderEncoding)
4932 -> (is_of_type(HeaderEncoding,text_encoding)
4933 -> Encoding=HeaderEncoding
4934 ; add_warning(read_xml,'Illegal encoding in XML header (must be "UTF-8", "UTF-16", "ISO-8859-1",...): ',HeaderEncoding),
4935 Encoding=auto
4936 )
4937 ; is_of_type(EncodingPref,text_encoding) -> Encoding = EncodingPref
4938 ; add_error(read_xml,'Illegal encoding preference (must be "auto", "UTF-8", "UTF-16", "ISO-8859-1",...): ',EncodingPref),
4939 Encoding=auto
4940 ),
4941 statistics(walltime,_),
4942 safe_call(read_string_from_file(AFile,Encoding,Codes),Span),
4943 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to read in ~w~n',[W1,AFile]),
4944 convert_xml_to_b(Codes,BDataSequence,File,Span),
4945 statistics(walltime,[_,W2]),
4946 formatsilent('% Walltime ~w ms to parse and convert XML in ~w~n',[W2,AFile]),
4947 kernel_objects:equal_object_optimized(Res,BDataSequence).
4948
4949
4950 external_fun_type('READ_XML_FROM_STRING',[],[string,seq(XT)]) :- xml_element_type(XT).
4951 expects_spaninfo('READ_XML_FROM_STRING').
4952 :- public 'READ_XML_FROM_STRING'/3.
4953 :- block 'READ_XML_FROM_STRING'(-,?,?).
4954 'READ_XML_FROM_STRING'(string(Contents),Res,Span) :-
4955 atom_codes(Contents,Codes),
4956 statistics(walltime,[W1,_]),
4957 convert_xml_to_b(Codes,BDataSequence,'string',Span),
4958 statistics(walltime,[W2,_]), W is W2-W1,
4959 formatsilent('% Walltime ~w ms to parse and convert XML~n',[W]),
4960 kernel_objects:equal_object_optimized(Res,BDataSequence).
4961
4962 :- use_module(extrasrc(json_parser),[json_parse_file/3,json_parse/3]).
4963 :- use_module(extrasrc(json_freetype),[json_parser_to_json_freetype/2]).
4964 performs_io('READ_JSON').
4965 external_fun_type('READ_JSON',[],[string,freetype('JsonValue')]).
4966 expects_spaninfo('READ_JSON').
4967 :- public 'READ_JSON'/3.
4968 :- block 'READ_JSON'(-,?,?).
4969 'READ_JSON'(string(File),Res,Span) :-
4970 read_json(File,Res,Span).
4971 :- block read_json(-,?,?).
4972 read_json(File,Res,Span) :-
4973 b_absolute_file_name(File,AFile,Span),
4974 statistics(walltime,_),
4975 safe_call(json_parse_file(AFile,Json,[]),Span),
4976 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to read and parse ~w~n',[W1,AFile]),
4977 json_parser_to_json_freetype(Json,JsonFreetype),
4978 statistics(walltime,[_,W2]),
4979 formatsilent('% Walltime ~w ms to convert JSON from ~w~n',[W2,AFile]),
4980 kernel_objects:equal_object_optimized(Res,JsonFreetype).
4981
4982 :- use_module(extrasrc(xml2b), [convert_json_to_b/3]).
4983 % reads in JSON file producing the same format as READ_XML
4984 performs_io('READ_JSON_AS_XML').
4985 external_fun_type('READ_JSON_AS_XML',[],[string,seq(XT)]) :- xml_element_type(XT).
4986 expects_spaninfo('READ_JSON_AS_XML').
4987 :- public 'READ_JSON_AS_XML'/3.
4988 :- block 'READ_JSON_AS_XML'(-,?,?).
4989 'READ_JSON_AS_XML'(string(File),Res,Span) :-
4990 read_json_as_xml(File,Res,Span).
4991 :- block read_json_as_xml(-,?,?).
4992 read_json_as_xml(File,Res,Span) :-
4993 statistics(walltime,_),
4994 b_absolute_file_name(File,AFile,Span),
4995 safe_call(json_parse_file(AFile,JSONList,[position_infos(true)]),Span),
4996 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to read and parse ~w~n',[W1,AFile]),
4997 convert_json_to_b(JSONList,BDataSequence,Span),
4998 statistics(walltime,[_,W2]),
4999 formatsilent('% Walltime ~w ms to convert JSON from ~w~n',[W2,AFile]),
5000 kernel_objects:equal_object_optimized(Res,BDataSequence).
5001
5002 external_fun_type('READ_JSON_FROM_STRING',[],[string,freetype('JsonValue')]).
5003 expects_spaninfo('READ_JSON_FROM_STRING').
5004 :- public 'READ_JSON_FROM_STRING'/3.
5005 :- block 'READ_JSON_FROM_STRING'(-,?,?).
5006 'READ_JSON_FROM_STRING'(string(Contents),Res,Span) :-
5007 read_json_from_string(Contents,Res,Span).
5008 :- block read_json_from_string(-,?,?).
5009 read_json_from_string(Contents,Res,Span) :-
5010 statistics(walltime,_),
5011 atom_codes(Contents,Codes),
5012 safe_call(json_parse(Codes,Json,[]),Span),
5013 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to parse string~n',[W1]),
5014 json_parser_to_json_freetype(Json,JsonFreetype),
5015 statistics(walltime,[_,W2]),
5016 formatsilent('% Walltime ~w ms to convert JSON~n',[W2]),
5017 kernel_objects:equal_object_optimized(Res,JsonFreetype).
5018
5019 external_fun_type('READ_JSON_FROM_STRING_AS_XML',[],[string,seq(XT)]) :- xml_element_type(XT).
5020 expects_spaninfo('READ_JSON_FROM_STRING_AS_XML').
5021 :- public 'READ_JSON_FROM_STRING_AS_XML'/3.
5022 :- block 'READ_JSON_FROM_STRING_AS_XML'(-,?,?).
5023 'READ_JSON_FROM_STRING_AS_XML'(string(Contents),Res,Span) :-
5024 read_json_from_string_as_xml(Contents,Res,Span).
5025 :- block read_json_from_string_as_xml(-,?,?).
5026 read_json_from_string_as_xml(Contents,Res,Span) :-
5027 atom_codes(Contents,Codes),
5028 statistics(walltime,_),
5029 safe_call(json_parse(Codes,JSONList,[position_infos(true)]),Span),
5030 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to parse string~n',[W1]),
5031 convert_json_to_b(JSONList,BDataSequence,Span),
5032 statistics(walltime,[_,W2]),
5033 formatsilent('% Walltime ~w ms to convert JSON~n',[W2]),
5034 kernel_objects:equal_object_optimized(Res,BDataSequence).
5035
5036 expects_spaninfo('WRITE_XML').
5037 external_fun_type('WRITE_XML',[],[seq(XT),string]) :- xml_element_type(XT).
5038 :- public 'WRITE_XML'/4.
5039 :- block 'WRITE_XML'(-,?,?,?),'WRITE_XML'(?,-,?,?).
5040 'WRITE_XML'(Records,string(File),Res,Span) :- write_xml2(Records,File,Res,Span).
5041 :- block write_xml2(?,-,?,?).
5042 write_xml2(Records,File,Res,Span) :-
5043 b_absolute_file_name(File,AFile,Span),
5044 statistics(walltime,_),
5045 'WRITE_XML_TO_STRING'(Records,String,Span),
5046 String = string(S),
5047 when(nonvar(S),
5048 (statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to convert XML for ~w~n',[W1,AFile]),
5049 open(AFile,write,Stream,[encoding(utf8)]),
5050 write(Stream,S),nl(Stream),
5051 close(Stream),
5052 statistics(walltime,[_,W2]), formatsilent('% Walltime ~w ms to write XML to file ~w~n',[W2,AFile]),
5053 Res = pred_true
5054 )).
5055
5056
5057 %sequence of records of type:
5058 % rec(attributes:{("version"|->"03.04")},
5059 % element:"Data",
5060 % meta:{("xmlLineNumber"|->"2")},
5061 % pId:0,
5062 % recId:1),
5063 :- use_module(probsrc(xml_prob),[xml_parse/4, xml_pp/1]).
5064 expects_spaninfo('WRITE_XML_TO_STRING').
5065 :- public 'WRITE_XML_TO_STRING'/3.
5066 :- block 'WRITE_XML_TO_STRING'(-,?,?).
5067 'WRITE_XML_TO_STRING'(Records,Res,Span) :-
5068 custom_explicit_sets:expand_custom_set_to_list(Records,ESet,Done,'WRITE_XML_TO_STRING'),
5069 ground_value_check(ESet,Gr),
5070 when((nonvar(Done),nonvar(Gr)),
5071 ( % print(expanded(ESet)),nl,
5072 gen_prolog_xml_term(ESet,Prolog,Span),
5073 %print(prolog(Prolog)),nl,
5074 xml_parse(Codes,Prolog,[],Span),
5075 (debug:debug_mode(on) -> xml_pp(Prolog) ; true),
5076 atom_codes(S,Codes),
5077 Res = string(S))).
5078
5079 :- use_module(extrasrc(json_parser),[json_write/3,json_write_file/3]).
5080 :- use_module(extrasrc(json_freetype),[json_freetype_to_json_parser/2]).
5081 expects_spaninfo('WRITE_JSON').
5082 external_fun_type('WRITE_JSON',[],[freetype('JsonValue'),string]).
5083 :- public 'WRITE_JSON'/4.
5084 :- block 'WRITE_JSON'(-,?,?,?),'WRITE_JSON'(?,-,?,?).
5085 'WRITE_JSON'(JsonFreetype,string(File),Res,Span) :-
5086 ground_value_check(JsonFreetype,GrJ),
5087 write_json(GrJ,JsonFreetype,File,Res,Span).
5088 :- block write_json(-,?,?,?,?),write_json(?,?,-,?,?).
5089 write_json(_,JsonFreetype,File,Res,Span) :-
5090 statistics(walltime,_),
5091 json_freetype_to_json_parser(JsonFreetype,Json),
5092 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to convert JSON to parser representation for ~w~n',[W1,AFile]),
5093 b_absolute_file_name(File,AFile,Span),
5094 safe_call(json_write_file(AFile,Json,[pretty(true)]),Span),
5095 statistics(walltime,[_,W2]), formatsilent('% Walltime ~w ms to write JSON for ~w~n',[W2,AFile]),
5096 Res = pred_true.
5097
5098 expects_spaninfo('WRITE_JSON_TO_STRING').
5099 external_fun_type('WRITE_JSON_TO_STRING',[],[freetype('JsonValue'),string]).
5100 :- public 'WRITE_JSON_TO_STRING'/3.
5101 'WRITE_JSON_TO_STRING'(JsonFreetype,Res,Span) :-
5102 ground_value_check(JsonFreetype,GrJ),
5103 write_json_to_string(GrJ,JsonFreetype,Res,Span).
5104 :- block write_json_to_string(-,?,?,?).
5105 write_json_to_string(_,JsonFreetype,Res,Span) :-
5106 statistics(walltime,_),
5107 json_freetype_to_json_parser(JsonFreetype,Json),
5108 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to convert JSON to parser representation~n',[W1]),
5109 safe_call(json_write(Json,Codes,[pretty(true)]),Span),
5110 atom_codes(S,Codes),
5111 statistics(walltime,[_,W2]), formatsilent('% Walltime ~w ms to write JSON to string~n',[W2]),
5112 Res = string(S).
5113
5114 gen_prolog_xml_term(List,xml( [version="1.0", encoding="ASCII"], ContentList),Span) :-
5115 InitialLineNr = 2, % first line is xml-header !?
5116 gen_prolog_xml_dcg(InitialLineNr,_,0,[],ContentList,Span,List,[]).
5117
5118 gen_prolog_xml_dcg(LastLineNr,FinalLineNr,CurLevel, Parents, ResContentList,Span) -->
5119 [(int(Index),rec(Fields))],
5120 { %print(treat(Index,Fields)),nl,
5121 get_parentId(Fields,CurLevel,Span)}, % The element should be added to the current content list
5122 !,
5123 {get_element(Fields,Element,Span),
5124 get_attributes(Fields,Attributes,Span),
5125 get_line(Fields,LineNr,Span),
5126 gen_element(LastLineNr,LineNr,Element, Attributes, InnerContentList, ResContentList, TailContentList)
5127 },
5128 gen_prolog_xml_dcg(LineNr,LineNr2,Index,[CurLevel|Parents],InnerContentList,Span),
5129 gen_prolog_xml_dcg(LineNr2,FinalLineNr,CurLevel, Parents, TailContentList,Span).
5130 gen_prolog_xml_dcg(L,L,_,_,[],_Span) --> [].
5131
5132 gen_element(LastLineNr,NewLineNr,'CText',['='(text,Codes)],[], [PCDATA|Tail],Tail) :-
5133 insert_newlines(LastLineNr,NewLineNr,Codes,NLCodes),
5134 !,
5135 PCDATA=pcdata(NLCodes).
5136 gen_element(LastLineNr,NewLineNr,Element, Attributes, InnerContentList, [pcdata(NL),XELEMENT|Tail],Tail) :-
5137 LastLineNr < NewLineNr,
5138 insert_newlines(LastLineNr,NewLineNr,[],NL),
5139 !,
5140 XELEMENT = element( Element, Attributes, InnerContentList).
5141 gen_element(_,_,Element, Attributes, InnerContentList, [XELEMENT|Tail],Tail) :-
5142 XELEMENT = element( Element, Attributes, InnerContentList).
5143
5144 insert_newlines(LastLineNr,NewLineNr,C,R) :- NewLineNr =< LastLineNr,!,R=C.
5145 % TO DO: maybe we have to use 13 on Windows ??
5146 insert_newlines(LastLineNr,NewLineNr,C,[10|Res]) :- L1 is LastLineNr+1, insert_newlines(L1,NewLineNr,C,Res).
5147
5148 get_parentId(Fields,Nr,Span) :-
5149 (member(field(pId,int(ParentID)),Fields) -> Nr=ParentID
5150 ; add_error('WRITE_XML_TO_STRING','The record has no pId field: ',Fields,Span),
5151 Nr = 0).
5152 get_element(Fields,Atom,Span) :-
5153 (member(field(element,string(Atom)),Fields) -> true
5154 ; add_error('WRITE_XML_TO_STRING','The record has no element field: ',Fields,Span),
5155 Atom = '??').
5156
5157 get_attributes(Fields,Attrs,Span) :-
5158 (member(field(attributes,Set),Fields)
5159 -> custom_explicit_sets:expand_custom_set_to_list(Set,ESet,_Done,'get_attributes'),
5160 (maplist(get_xml_attr,ESet,Attrs) -> true
5161 ; add_error('WRITE_XML_TO_STRING','Illegal attributes field: ',ESet,Span),
5162 Attrs = []
5163 )
5164 ; add_error('WRITE_XML_TO_STRING','The record has no attributes field: ',Fields,Span),
5165 Attrs = []).
5166 get_line(Fields,LineNr,Span) :-
5167 (member(field(meta,Set),Fields)
5168 -> custom_explicit_sets:expand_custom_set_to_list(Set,ESet,_Done,'get_line'),
5169 (member((string(xmlLineNumber),string(LineNrS)),ESet)
5170 -> atom_codes(LineNrS,CC), number_codes(LineNr,CC)
5171 ; add_error('WRITE_XML_TO_STRING','The meta field has no xmlLineNumber entry: ',ESet,Span),
5172 LineNr = -1
5173 )
5174 ; add_error('WRITE_XML_TO_STRING','The record has no meta field: ',Fields,Span),
5175 LineNr = -1).
5176
5177 get_xml_attr((string(Attr),string(Val)),'='(Attr,ValCodes)) :- atom_codes(Val,ValCodes).
5178
5179
5180 % ----------------------------------
5181 % A flexible CVS Reader that always uses the same type
5182 % rec([field(attributes,BAttributes),field(lineNr,LineNr)])
5183
5184 % EXTERNAL_FUNCTION_READ_CSV_STRINGS == STRING --> seq(CSV_ELement_Type);
5185 % with CSV_ELement_Type == STRING +-> STRING ;
5186
5187 performs_io('READ_CSV_STRINGS').
5188 expects_spaninfo('READ_CSV_STRINGS').
5189 external_fun_type('READ_CSV_STRINGS',[],[string,seq(set(couple(string,string)))]).
5190 :- public 'READ_CSV_STRINGS'/3.
5191 :- block 'READ_CSV_STRINGS'(-,?,?).
5192 'READ_CSV_STRINGS'(string(File),Res,Span) :- read_csv_strings(File,Res,Span).
5193
5194 read_csv_strings(File,ResAVL,Span) :-
5195 b_absolute_file_name(File,AFile,Span),
5196 open_utf8_file_for_reading(AFile,Stream,Span),
5197 statistics(walltime,_),
5198 read_line(Stream,Line1),
5199 (Line1 = end_of_file -> ResAVL = []
5200 ; split_csv_line(1,Stream,[],HeadersCodes,Span,Line1,[]),
5201 maplist(process_header,HeadersCodes,Headers),
5202 formatsilent('CSV Line Headers = ~w for ~w~n',[Headers,AFile]),
5203 safe_call(read_csv_strings_lines(Stream,1,Span,Headers,Res),Span),
5204 statistics(walltime,[_,W1]), formatsilent('% Walltime ~w ms to read in ~w~n',[W1,AFile]),
5205 kernel_objects:equal_object_optimized(Res,ResAVL),
5206 statistics(walltime,[_,W2]), formatsilent('% Walltime ~w ms to normalise in ~w~n',[W2,AFile])
5207 ),
5208 close(Stream). % TO DO: call_cleanup
5209
5210 process_header(HeaderC,HeaderAtom) :- safe_atom_codes(HeaderAtom,HeaderC).
5211
5212 read_csv_strings_lines(Stream,PrevLineNr,Span,Headers,Res) :-
5213 read_line(Stream,Line),
5214 (Line = end_of_file -> Res = []
5215 ; LineNr is PrevLineNr+1,
5216 debug_format(9,'~nCSV line ~w: ~s~n',[LineNr,Line]),
5217 split_csv_line(LineNr,Stream,[],AtomsC,Span,Line,[]),
5218 Res = [(int(PrevLineNr),Attrs)|ResT],
5219 construct_attributes(AtomsC,Headers,Attrs,Span,LineNr,1),
5220 read_csv_strings_lines(Stream,LineNr,Span,Headers,ResT)
5221 ).
5222
5223 construct_attributes([],_,[],_,_,_).
5224 construct_attributes([ [] | T],[ _|HT],Res,Span,LineNr,ColNr) :- !, % empty column
5225 C1 is ColNr+1,
5226 construct_attributes(T,HT,Res,Span,LineNr,C1).
5227 construct_attributes([ AtomC | T], [], Res,Span,LineNr,ColNr) :- !,
5228 safe_atom_codes(A,AtomC),
5229 length(AtomC,NrChars),
5230 ajoin(['Additional field with ',NrChars,' chars on line ',LineNr,' and column ',ColNr,': '],Msg),
5231 add_warning('READ_CSV_STRINGS',Msg,A,Span),
5232 Res=[(string('ExtraField'),string(A))|TR],
5233 C1 is ColNr+1,
5234 construct_attributes(T, [], TR,Span,LineNr,C1).
5235 construct_attributes([ AtomC | T], [ Header | HT],
5236 [ (string(Header),string(A)) | ResT],Span,LineNr,ColNr) :-
5237 safe_atom_codes(A,AtomC),
5238 %format('Col ~w: ~w~n',[ColNr,A]),flush_output,
5239 C1 is ColNr+1,
5240 construct_attributes(T,HT,ResT,Span,LineNr,C1).
5241
5242 % ----------------------------------
5243 % A CSV Reader that uses the B types to adapt how it reads in values
5244
5245 performs_io('READ_CSV').
5246 expects_spaninfo('READ_CSV').
5247 expects_type('READ_CSV').
5248
5249 :- public 'READ_CSV'/6.
5250 :- block 'READ_CSV'(-,?,?,?,?,?).
5251 'READ_CSV'(string(File),BoolSkipLine1,AllowExtraValues,Res,Type,Span) :-
5252 read_csv(File,BoolSkipLine1,AllowExtraValues,pred_false,Res,Type,Span).
5253
5254 external_fun_type('READ_CSV',[T],[string,T]).
5255 :- public 'READ_CSV'/4.
5256 :- block 'READ_CSV'(-,?,?,?).
5257 'READ_CSV'(string(File),Res,Type,Span) :-
5258 read_csv(File,pred_false,pred_false,pred_false,Res,Type,Span).
5259
5260 performs_io('READ_CSV_SEQUENCE').
5261 expects_spaninfo('READ_CSV_SEQUENCE').
5262 expects_type('READ_CSV_SEQUENCE').
5263 :- public 'READ_CSV_SEQUENCE'/6.
5264 :- block 'READ_CSV_SEQUENCE'(-,?,?,?,?,?).
5265 'READ_CSV_SEQUENCE'(string(File),BoolSkipLine1,AllowExtraValues,Res,Type,Span) :-
5266 read_csv(File,BoolSkipLine1,AllowExtraValues,pred_true,Res,Type,Span).
5267
5268 :- use_module(bsyntaxtree,[get_set_type/2]).
5269 :- block read_csv(-,?,?,?,?,?,?).
5270 read_csv(File,BoolSkipLine1,AllowExtraValues,CreateSequence,Res,InType,Span) :-
5271 (CreateSequence=pred_true
5272 -> (get_set_type(InType,couple(integer,T)) -> Type=set(T), SeqIndex=1
5273 ; add_error('READ_CSV_SEQUENCE','Expecting sequence as return type:',InType),
5274 Type=InType, SeqIndex=none
5275 )
5276 ; SeqIndex=none,Type=InType),
5277 get_column_types(Type,Types,Skel,Vars,Span),
5278 b_absolute_file_name(File,AFile,Span),
5279 open_utf8_file_for_reading(AFile,Stream,Span),
5280 (debug:debug_mode(off) -> true
5281 ; formatsilent('~nReading CSV file ~w with Types = ~w and Skel = ~w for Vars = ~w~n~n',[AFile,Types,Skel,Vars])),
5282 (read_csv_lines(1,SeqIndex,BoolSkipLine1,AllowExtraValues,Stream,Types,Skel,Vars,Res,Span) -> true
5283 ; add_error('READ_CSV','Reading CSV File failed: ',AFile)),
5284 close(Stream). % TO DO: call_cleanup
5285
5286 read_csv_lines(Nr,SeqIndex,BoolSkipLine1,AllowExtraValues,Stream,Types,Skel,Vars,Res,Span) :- %print(line(Nr,Types)),nl,
5287 read_line(Stream,Line),
5288 debug:debug_println(9,read_line(Nr,Line)),
5289 (Line = end_of_file -> Res = []
5290 ; split_csv_line(Nr,Stream,[],AtomsC,Span,Line,[]),
5291 %print(atoms(Nr,Atoms)),nl,
5292 %maplist(convert_atom_codes(Span),Types,Atoms,Tuple), % TO DO: check same length
5293 (Nr=1,BoolSkipLine1=pred_true
5294 -> maplist(codes_to_atom,AtomsC,Atoms), format('Skipping line 1: ~w~n',[Atoms]),
5295 Res=ResT
5296 ; Line=[] -> format('Skipping empty line ~w~n',[Nr]), Res=ResT
5297 ; l_convert_atom_codes(Types,AtomsC,Tuple,Span,Nr,AllowExtraValues),
5298 copy_term((Vars,Skel),(Tuple,BValue)),
5299 (number(SeqIndex) -> S1 is SeqIndex+1, Res = [(int(SeqIndex),BValue)|ResT]
5300 ; S1 = SeqIndex, Res = [BValue|ResT]
5301 )
5302 ),
5303 N1 is Nr+1,
5304 read_csv_lines(N1,S1,BoolSkipLine1,AllowExtraValues,Stream,Types,Skel,Vars,ResT,Span)).
5305
5306 codes_to_atom(C,A) :- atom_codes(A,C).
5307
5308 l_convert_atom_codes([],[],Vals,_Span,_LineNr,_) :- !, Vals=[].
5309 l_convert_atom_codes([Type|TT],[AtomC|TC],[Val|VT],Span,LineNr,AllowExtraValues) :- !,
5310 convert_atom_codes(Span,LineNr,Type,AtomC,Val),
5311 l_convert_atom_codes(TT,TC,VT,Span,LineNr,AllowExtraValues).
5312 l_convert_atom_codes([Type|TT],[],_,Span,LineNr,_) :- !,
5313 ajoin(['Missing value(s) on CSV line ',LineNr,' for types: '],Msg),
5314 add_error('READ_CSV',Msg,[Type|TT],Span),fail.
5315 l_convert_atom_codes([],[AtomC|AT],Vals,Span,LineNr,AllowExtraValues) :- !,
5316 (AllowExtraValues=pred_true -> true
5317 ; safe_atom_codes(Atom,AtomC),
5318 ajoin(['Extra value(s) on CSV line ',LineNr,' : ',Atom,' Rest = '],Msg),
5319 add_error('READ_CSV',Msg,AT,Span)
5320 ), Vals=[].
5321
5322 convert_atom_codes(Span,LineNr,T,AtomC,Val) :-
5323 (convert_atom2(T,AtomC,Val,Span,LineNr) -> true ;
5324 atom_codes(Atom,AtomC),
5325 ajoin(['Could not convert value to type ',T,' on CSV line ',LineNr,': '],Msg),
5326 add_error('READ_CSV',Msg,Atom,Span),
5327 Val = term('READ_CSV_ERROR')).
5328 :- use_module(tools,[safe_number_codes/2, safe_atom_codes/2]).
5329 convert_atom2(string,C,string(A),_,_) :- safe_atom_codes(A,C).
5330 convert_atom2(integer,C,int(Nr),_Span,LineNr) :-
5331 (C=[] -> (debug:debug_mode(off) -> true ; format('Translating empty string to -1 on line ~w~n',[LineNr])),
5332 % add_warning('READ_CSV','Translating empty string to -1 on line: ',LineNr,Span),
5333 Nr is -1
5334 ; safe_number_codes(Nr,C)).
5335 convert_atom2(global(G),C,FD,Span,LineNr) :- safe_atom_codes(A,C),convert_to_enum(G,A,FD,Span,LineNr).
5336 convert_atom2(boolean,C,Bool,Span,LineNr) :- safe_atom_codes(A,C),
5337 (convert_to_bool(A,Bool) -> true
5338 ; ajoin(['Could not convert value to BOOL on line ',LineNr,'; assuming FALSE: '],Msg),
5339 add_warning('READ_CSV',Msg,A,Span),
5340 Bool=pred_false).
5341 % TO DO: support set(_), seq(_)
5342
5343 convert_to_bool('0',pred_false).
5344 convert_to_bool('1',pred_true).
5345 convert_to_bool('FALSE',pred_false).
5346 convert_to_bool('TRUE',pred_true).
5347 convert_to_bool('false',pred_false).
5348 convert_to_bool('true',pred_true).
5349
5350 convert_to_enum(G,A,FD,Span,LineNr) :- string_to_enum2(A,FD,_,Span),
5351 (FD=fd(_,G) -> true ; add_error('READ_CSV','Enumerated element of incorrect type: ',A:expected(G):line(LineNr),Span)).
5352
5353 % split a CSV line into individual AtomCode lists
5354 split_csv_line(LineNr,Stream,[],T,Span) --> " ", !, split_csv_line(LineNr,Stream,[],T,Span).
5355 split_csv_line(LineNr,Stream,Acc,[AtomC|T],Span) --> sep, !,
5356 {reverse(Acc,AtomC)}, split_csv_line(LineNr,Stream,[],T,Span).
5357 split_csv_line(LineNr,Stream,[],ResultList,Span,[34|InLine],OutLine) :- % "
5358 nonmember(34,InLine), % string is not terminated,
5359 !, % CSV files do not encode newlines within strings
5360 debug_println(19,csv_string_not_terminated_on_line(LineNr)),
5361 extend_line_until_eos(Stream,NewLines),
5362 append([InLine|NewLines],ExtendedLine),
5363 split_csv_line_inside_string(LineNr,Stream,ResultList,Span,ExtendedLine,OutLine).
5364 split_csv_line(LineNr,Stream,[],ResultList,Span) --> [34], !, % "
5365 split_csv_line_inside_string(LineNr,Stream,ResultList,Span).
5366 split_csv_line(LineNr,Stream,Acc,Atoms,Span) --> [X], !, split_csv_line(LineNr,Stream,[X|Acc],Atoms,Span).
5367 split_csv_line(_,_,Acc,[AtomC],_Span) --> !, % end of line
5368 {reverse(Acc,AtomC)}.
5369
5370 split_csv_line_inside_string(LineNr,Stream,[String|T],Span) -->
5371 scan_to_end_of_string(LineNr,[],String,Span),
5372 (sep -> split_csv_line(LineNr,Stream,[],T,Span)
5373 ; [XX] -> {atom_codes(AS,String),
5374 atom_codes(XS,[XX]), ajoin(['String on line ',LineNr,' not followed by separator but by ',XS,':'],Msg),
5375 add_error('READ_CSV',Msg,string(AS),Span)},
5376 split_csv_line(LineNr,Stream,[XX],T,Span)
5377 ; {T=[]}).
5378
5379
5380 extend_line_until_eos(Stream,[[10],Line|T]) :- % insert newline symbol; maybe use 13 on Windows ??
5381 read_line(Stream,Line), % note: we do not update line number; thus error msg refer to logical CSV lines
5382 Line \= end_of_file,!,
5383 (member(34,Line) -> T=[] % end of string found
5384 ; extend_line_until_eos(Stream,T)).
5385 extend_line_until_eos(_,[]). % string not terminated in entire CSV file; error will be generated below
5386
5387 sep --> " ",!, sep.
5388 sep --> ("," ; ";" ; " ,").
5389
5390 scan_to_end_of_string(_,Acc,AtomC,_) --> [34],!, % we found end of string "
5391 {reverse(Acc,AtomC)}.
5392 scan_to_end_of_string(LineNr,Acc,String,Span) --> [X],!, scan_to_end_of_string(LineNr,[X|Acc],String,Span).
5393 scan_to_end_of_string(LineNr,Acc,AtomC,Span) -->
5394 {reverse(Acc,AtomC),atom_codes(String,AtomC),
5395 ajoin(['String not terminated on CSV line ',LineNr,':'],Msg),
5396 add_error('READ_CSV',Msg,String,Span)}.
5397
5398 % get the list of column types along with Value skeleton with variables in the places where CSV values should be inserted
5399 get_column_types(set(X),Types,Skel,Vars,_) :- !,flatten_pairs(X,Types,[]), %print(types(Types)),nl,
5400 flatten_pairs_value_skeleton(X,Skel,Vars,[]). % print(skel(Skel,Vars)),nl.
5401 get_column_types(seq(X),Types,Skel,Vars,Span) :- !,
5402 get_column_types(set(couple(integer,X)),Types,Skel,Vars,Span).
5403 get_column_types(Type,_,_,_,Span) :- add_error('READ_CSV','Invalid return type (must be relation): ',Type,Span),fail.
5404
5405 % flatten couple pairs and generate skeleton term
5406 flatten_pairs(couple(A,B)) --> !,flatten_pairs(A), flatten_pairs(B).
5407 flatten_pairs(record(Fields)) --> !, flatten_fields(Fields).
5408 flatten_pairs(X) --> [X].
5409
5410 /* note: currently record fields have to be alphabetically in the same order as in CSV file: the fields are sorted by ProB's kernel ! : TO DO: try and recover the original order of the fields */
5411 flatten_fields([]) --> [].
5412 flatten_fields([field(_Name,Type)|T]) --> [Type], % no nesting allowed; this has to be a basic type for CSV reading to work
5413 flatten_fields(T).
5414
5415 % generate a value skeleton
5416 flatten_pairs_value_skeleton(couple(A,B),(CA,CB)) --> !,
5417 flatten_pairs_value_skeleton(A,CA), flatten_pairs_value_skeleton(B,CB).
5418 flatten_pairs_value_skeleton(record(Fields),rec(SF)) --> !, flatten_field_skel(Fields,SF).
5419 flatten_pairs_value_skeleton(_X,Var) --> [Var].
5420
5421 flatten_field_skel([],[]) --> [].
5422 flatten_field_skel([field(Name,_Type)|T],[field(Name,Var)|ST]) --> [Var],
5423 flatten_field_skel(T,ST).
5424
5425
5426 % ----------------------------------
5427 % Writing a matrix to a .pgm graphics file
5428 % The header of such a file looks like:
5429 % P5
5430 % 752 864 (width height)
5431 % 255 (maximal pixel value)
5432 % after that we have bytes of grayscale values
5433 % https://en.wikipedia.org/wiki/Netpbm#File_formats
5434
5435 % TODO: try and support colors (.ppm files)
5436 % improve performance; possibly avoiding to expand avl_sets
5437
5438 :- use_module(probsrc(tools_io),[read_byte_line/2, read_byte_word/2, put_bytes/2]).
5439
5440 :- public 'READ_PGM_IMAGE_FILE'/4.
5441 external_fun_type('READ_PGM_IMAGE_FILE',[],[string,seq(seq(integer))]).
5442 expects_waitflag('READ_PGM_IMAGE_FILE').
5443 expects_spaninfo('READ_PGM_IMAGE_FILE').
5444 :- block 'READ_PGM_IMAGE_FILE'(-,?,?,?).
5445 'READ_PGM_IMAGE_FILE'(string(FileName),Matrix,Span,WF) :-
5446 when(nonvar(FileName),
5447 (statistics(walltime,[_,_]),
5448 b_absolute_file_name(FileName,AFile,Span),
5449 open(AFile,read,Stream,[type(binary)]),
5450 call_cleanup(read_pgm_file(Stream,MatrixList,Span,WF), close(Stream)),
5451 statistics(walltime,[_,W2]),
5452 formatsilent('% Walltime ~w ms to read matrix from PGM file ~w~n',[W2,AFile]),
5453 kernel_objects:equal_object_optimized(Matrix,MatrixList)
5454 )).
5455
5456 read_pgm_file(Stream,Matrix,Span,_WF) :-
5457 read_byte_line(Stream,FileType),
5458 (FileType = "P5"
5459 -> read_byte_number(Stream,Width,Span),
5460 read_byte_number(Stream,Height,Span),
5461 read_byte_number(Stream,MaxPix,Span),
5462 formatsilent('% Detected PGM file width=~w, height=~w, max=~w~n',[Width,Height,MaxPix]),
5463 read_pgm_matrix(1,Height,Width,MaxPix,Stream,Matrix,Span)
5464 ; atom_codes(FT,FileType),
5465 add_error('READ_PGM_IMAGE_FILE','Can only support P5 grayscale type:',FT,Span),fail
5466 ).
5467
5468 % read pgm bytes and covert to B sequence of sequence of numbers
5469 read_pgm_matrix(Nr,Height,_,_,Stream,Res,Span) :- Nr > Height, !,
5470 get_byte(Stream,Code),
5471 (Code = -1 -> true
5472 ; add_warning('READ_PGM_IMAGE_FILE','Bytes ignored after reading rows=',Height,Span)),
5473 Res=[].
5474 read_pgm_matrix(RowNr,Height,Width,MaxPix,Stream,[(int(RowNr),Row1)|ResT],Span) :-
5475 read_pgm_row(1,Width,MaxPix,Stream,Row1,Span),
5476 N1 is RowNr+1,
5477 read_pgm_matrix(N1,Height,Width,MaxPix,Stream,ResT,Span).
5478
5479 read_pgm_row(Nr,Width,_,_Stream,Res,_Span) :- Nr>Width, !, Res=[].
5480 read_pgm_row(ColNr,Width,MaxPix,Stream,[(int(ColNr),int(Code))|ResT],Span) :-
5481 (get_byte(Stream,Code), Code >= 0
5482 -> (Code =< MaxPix -> true
5483 ; add_warning('READ_PGM_IMAGE_FILE','Grayscale pixel value exceeds maximum: ',Code,Span)
5484 )
5485 ; add_error('READ_PGM_IMAGE_FILE','Unexpected EOF at column:',ColNr),
5486 fail
5487 ),
5488 N1 is ColNr+1,
5489 read_pgm_row(N1,Width,MaxPix,Stream,ResT,Span).
5490
5491
5492 % read a word (until ws or eof) and convert it to a number
5493 read_byte_number(Stream,Nr,Span) :- read_byte_word(Stream,Codes),
5494 (safe_number_codes(Nr,Codes) -> true
5495 ; add_error('READ_PGM_IMAGE_FILE','Expected number:',Codes,Span)
5496 ).
5497
5498 :- public 'WRITE_PGM_IMAGE_FILE'/5.
5499 external_fun_type('WRITE_PGM_IMAGE_FILE',[],[string,seq(seq(integer),boolean)]).
5500 expects_waitflag('WRITE_PGM_IMAGE_FILE').
5501 expects_spaninfo('WRITE_PGM_IMAGE_FILE').
5502 :- block 'WRITE_PGM_IMAGE_FILE'(-,?,?,?,?), 'WRITE_PGM_IMAGE_FILE'(?,-,?,?,?).
5503 'WRITE_PGM_IMAGE_FILE'(string(FileName),Matrix,Res,Span,WF) :-
5504 custom_explicit_sets:expand_custom_set_to_list(Matrix,ESet,Done,'WRITE_PGM_IMAGE_FILE'),
5505 ground_value_check(ESet,Gr),
5506 when((nonvar(FileName),nonvar(Done),nonvar(Gr)),
5507 (statistics(walltime,[_,_]),
5508 b_absolute_file_name(FileName,AFile,Span),
5509 open(AFile,write,Stream,[type(binary)]),
5510 call_cleanup(put_pgm_file(Stream,ESet,Width,Height,WF),
5511 close(Stream)),
5512 statistics(walltime,[_,W2]),
5513 formatsilent('% Walltime ~w ms to write matrix to PGM file (width=~w, height=~w) ~w~n',[W2,Width,Height,AFile]),
5514 Res = pred_true
5515 )).
5516
5517 put_pgm_file(Stream,ESet,Width,Height,WF) :-
5518 ESet = [(int(_),Row)|_],
5519 bsets_clp:size_of_sequence(Row,int(Width),WF),
5520 put_bytes(Stream,"P5\n"),
5521 number_codes(Width,WC), put_bytes(Stream,WC),
5522 put_bytes(Stream," "),
5523 bsets_clp:size_of_sequence(ESet,int(Height),WF),
5524 number_codes(Height,HC), put_bytes(Stream,HC),
5525 put_bytes(Stream,"\n"),
5526 put_bytes(Stream,"255\n"),
5527 sort(ESet,SESet),
5528 put_pgm_matrix(Stream,Width,SESet).
5529
5530 % put a pgm grayscale matrix as bytes into a stream
5531 put_pgm_matrix(_,_,[]).
5532 put_pgm_matrix(Stream,Width,[(int(_),RowVector)|T]) :-
5533 custom_explicit_sets:expand_custom_set_to_list(RowVector,ESet,_,'WRITE_PGM_IMAGE_FILE'),
5534 sort(ESet,SESet),
5535 put_pgm_row(Stream,Width,SESet),
5536 put_pgm_matrix(Stream,Width,T).
5537
5538 put_zeros(_,X) :- X<1, !.
5539 put_zeros(Stream,X) :- put_byte(Stream,0), X1 is X-1, put_zeros(Stream,X1).
5540
5541 put_pgm_row(Stream,W,[]) :-
5542 (W=0 -> true
5543 ; add_error('WRITE_PGM_IMAGE_FILE','Illegal PGM width in row: ',W),
5544 put_zeros(Stream,W)
5545 ).
5546 put_pgm_row(Stream,W,[(_,int(Pixel))|T]) :-
5547 W1 is W-1,
5548 ( W<1 -> add_error('WRITE_PGM_IMAGE_FILE','Additional PGM pixel in row: ',Pixel)
5549 ; Pixel >=0, Pixel =< 255
5550 -> put_byte(Stream,Pixel),
5551 put_pgm_row(Stream,W1,T)
5552 ; add_error('WRITE_PGM_IMAGE_FILE','Illegal PGM pixel (must be 0..255): ',Pixel),
5553 put_byte(Stream,0),
5554 put_pgm_row(Stream,W1,T)
5555 ).
5556
5557 % -----------------
5558
5559 :- use_module(extrasrc(mcts_game_play), [mcts_auto_play/4, mcts_auto_play_available/0]).
5560 external_subst_enabling_condition('MCTS_AUTO_PLAY',_,Truth) :- create_texpr(truth,pred,[],Truth).
5561 external_function_requires_state('MCTS_AUTO_PLAY').
5562 :- public 'MCTS_AUTO_PLAY'/3.
5563 :- block 'MCTS_AUTO_PLAY'(-,?,?).
5564 'MCTS_AUTO_PLAY'(_,_Env,OutEnvModifications) :- % TO DO: pass simulation runs and time_out as parameter
5565 mcts_auto_play_available,!,
5566 get_current_state_id(CurID),
5567 mcts_auto_play(CurID,_ActionAsTerm,_TransID,State2),
5568 state_space:get_variables_state_for_id(State2,OutEnvModifications).
5569 'MCTS_AUTO_PLAY'(_,_,[]).
5570
5571 % EXTERNAL_SUBSTITUTION_MCTS_AUTO_PLAY == BOOL; MCTS_AUTO_PLAY(x) == skip;
5572
5573 % -----------------
5574
5575 :- use_module(extension('zmq_rpc/zmq_rpc'),
5576 [zmq_rpc_init/2, stream_socket_rpc_init/2,
5577 zmq_rpc_destroy/1, zmq_rpc_send/4,
5578 stream_socket_rpc_accept_request/3, stream_socket_rpc_send_answer/3]).
5579
5580 % connect to a JSON-RPC ZMQ socket
5581 performs_io('ZMQ_RPC_INIT').
5582 external_fun_type('ZMQ_RPC_INIT',[],[string,integer]).
5583 :- public 'ZMQ_RPC_INIT'/2.
5584 :- block 'ZMQ_RPC_INIT'(-,?).
5585 'ZMQ_RPC_INIT'(string(Endpoint), Res) :-
5586 when(nonvar(Endpoint), zmq_rpc_init(Endpoint, Res)).
5587
5588 % connect to a JSON-RPC regular socket using ndjson single-line messages
5589 performs_io('SOCKET_RPC_INIT').
5590 external_fun_type('SOCKET_RPC_INIT',[],[integer,integer]).
5591 :- public 'SOCKET_RPC_INIT'/2.
5592 :- block 'SOCKET_RPC_INIT'(-,?).
5593 'SOCKET_RPC_INIT'(int(Port), Res) :-
5594 when(nonvar(Port), stream_socket_rpc_init(Port, Res)).
5595
5596 performs_io('ZMQ_RPC_DESTROY').
5597 external_fun_type('ZMQ_RPC_DESTROY',[],[integer]).
5598 :- public 'ZMQ_RPC_DESTROY'/3.
5599 :- block 'ZMQ_RPC_DESTROY'(-,?,?).
5600 'ZMQ_RPC_DESTROY'(int(Socket), _EnvIn, EnvOut) :-
5601 when(nonvar(Socket),zmq_rpc_destroy(Socket)),
5602 EnvOut = [].
5603
5604 performs_io('ZMQ_RPC_SEND').
5605 expects_waitflag('ZMQ_RPC_SEND').
5606 external_fun_type('ZMQ_RPC_SEND',[],[integer,string,set(couple(string,freetype('JsonValue'))),freetype('RpcResult')]).
5607 :- public 'ZMQ_RPC_SEND'/5.
5608 :- block 'ZMQ_RPC_SEND'(-,?,?,?,?), 'ZMQ_RPC_SEND'(?,-,?,?,?), 'ZMQ_RPC_SEND'(?,?,-,?,?).
5609 'ZMQ_RPC_SEND'(int(Socket), string(Name), Args, Res,WF) :-
5610 expand_custom_set_to_list_wf(Args, ExpArgs, _Done, 'ZMQ_RPC_SEND',WF),
5611 ground_value_check(ExpArgs,Ground),
5612 block_zmq_rpc_send(Socket, Name, Ground, ExpArgs, Res).
5613
5614 :- block block_zmq_rpc_send(-,?,?,?,?), block_zmq_rpc_send(?,-,?,?,?),
5615 block_zmq_rpc_send(?,?,-,?,?).
5616 block_zmq_rpc_send(Socket, Name, _, ExpArgs, Res) :-
5617 zmq_rpc_send(Socket, Name, ExpArgs, Res).
5618
5619 performs_io('SOCKET_RPC_ACCEPT').
5620 external_fun_type('SOCKET_RPC_ACCEPT',[],[integer,freetype('JsonValue')]).
5621 :- public 'SOCKET_RPC_ACCEPT'/2.
5622 :- block 'SOCKET_RPC_ACCEPT'(-,?).
5623 'SOCKET_RPC_ACCEPT'(int(Port), Request) :-
5624 when(nonvar(Port),
5625 (stream_socket_rpc_accept_request(Port,_Id,FreeVal), % the Id is stored in zmq_rpc
5626 kernel_objects:equal_object_optimized(Request,FreeVal))).
5627
5628
5629 performs_io('SOCKET_RPC_REPLY').
5630 external_fun_type('SOCKET_RPC_REPLY',[],[integer,freetype('RpcResult')]).
5631 :- public 'SOCKET_RPC_REPLY'/3.
5632 :- block 'SOCKET_RPC_REPLY'(-,?,?),'SOCKET_RPC_REPLY'(?,-,?).
5633 'SOCKET_RPC_REPLY'(int(Port), FreeVal,Res) :-
5634 ground_value_check(FreeVal,Gr),
5635 when((nonvar(Port),nonvar(Gr)),
5636 (stream_socket_rpc_send_answer(Port,_Id,FreeVal), Res=pred_true)).