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