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