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