1 % (c) 2009-2026 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2 % Heinrich Heine Universitaet Duesseldorf
3 % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5
6 :- module(tools, [exact_member/2,
7 exact_member_lookup/4, exact_member_replace/5,
8 remove/3, remove_all/3, insert/3,
9 remove_variables/3,
10 list_intersection/3, list_difference/3,
11 disjoint_list_union/3, lists_are_disjoint/2,
12 string_concatenate/3, is_upper_case_name/1,
13 %write_to_file/2, write_to_utf8_file/2, put_codes/2, % now in tools_files
14 %print_error/1,
15 print_message/1, print_message_with_max_depth/2,
16 print_short_msg/1,
17 print_bt_message/1, print_bt_trace_message/1, bt_trace/1,
18 format_bt/2,
19 print_wtime/1,
20 print_mb/1, print_gb/1,
21 prints/1,
22 is_absolute_path/1,
23 split_common_path/4,
24 gen_relative_path/3, gen_relative_path_to_cur_dir/2,
25 get_parent_directory/2, get_parent_directory_name/2,
26 get_parent_directory_of_directory/2,
27 get_tail_filename/2, get_modulename_filename/2,
28 get_filename_extension/2,
29 get_option_from_list/4, get_options_from_list/2,
30 get_options/4,get_options/5,
31 arg_is_number/2, arg_is_number_or_wildcard/2,
32 check_filename_arg/2,
33 arg_is_integer/2,
34 split_filename/3,
35 safe_absolute_file_name/2, safe_absolute_file_name/3,
36 host_file_name_case_insensitive/0,
37 same_file_name/2,
38
39 filter/4,
40 flatten/2,
41 % count_occurences/2, % now in tools_lists
42 split_last/4,
43 split_atom/3, split_chars/3, split_complex_sep/3,
44 latex_escape_atom/2,
45 b_escape_string_atom/2, b_string_escape_codes/2,
46 string_escape/2, print_escaped/1, % can also be used for dot
47 simple_dot_string_escape/2, % for dot, just quoting "
48 xml_escape/2, xml_escape_codes/2,
49 html_escape/2, html_escape_codes/2,
50 xml_attribute_escape/2,
51 read_term_from_file/2,
52 safe_read_term_from_atom/2, safe_read_term_from_codes/2,
53 read_string_from_file/2, read_string_from_file/3,
54 safe_read_string_from_file/3,
55 read_atom_from_file/3,
56 % write_lines_to_file/2, % now in tools_files
57 open_temp_file/3,
58 open_temp_file/4,
59 detect_xml_encoding/3,
60
61 ajoin/2,
62 ajoin_with_limit/3,
63 ajoin_with_sep/3,
64 substitute/4,
65 % call_residue/2, % now in tools_meta
66
67 catch_call/1,
68 observe_user_interrupt_signal/3,
69 %safe_on_exception/3, safe_on_exception_silent/3, % now in tools_meta
70 %reraise_important_exception/1, % now in tools_meta
71 % catch_matching/3, % now in tools_meta
72
73 convert_list_into_pairs/2, convert_pairs_into_list/3,
74
75 safe_univ/2, safe_univ_no_cutoff/2,
76 safe_sort/3,
77 safe_set_sort/3,
78 safe_functor/4,
79
80 safe_atom_codes/2, safe_atom_chars/3,
81 atom_codes_with_limit/2, atom_codes_with_limit/3,
82 truncate_atom/3, wrap_and_truncate_atom/4,
83 safe_number_codes/2,
84 atom_or_number_codes/2,
85 ensure_atom/2,
86 number_suffix/3,
87
88 print_size_of_table/1,
89 print_runtime/0, start_ms_timer/1, stop_ms_timer/2, stop_ms_timer/1,
90 stop_ms_timer_with_msg/2,
91 stop_ms_timer_with_silent_msg/2,
92 stop_ms_timer_with_debug_msg/2,
93 stop_ms_walltimer_with_msg/2,
94 bt_start_ms_timer/1, bt_stop_ms_timer/1,
95 get_elapsed_walltime/2,
96 get_elapsed_timer/2, combiner_timer/3,
97 get_elapsed_runtime/2,
98 cputime/1, walltime/1,
99 convert_ms_time_to_string/2,
100
101 retract_with_statistics/2,
102 statistics_memory_used/1,
103 get_memory_used/1, print_memory_used_difference/2, print_memory_used/1,
104 print_memory_used_wo_gc/0, print_memory_used_wo_gc/1,
105
106 split_list/4,
107 split_list_idx/5, re_split_list_idx/4,
108
109 minimize_lasso/4,
110
111 map_split_list/4,
112 foldl/4,foldl/5,foldl/6,
113 maplist5/5,
114 average/2,
115
116 map_optlist/2,
117 optlist_to_list/2,
118
119 (space_call)/1,
120 assert_once/1,
121
122 % safe_time_out/3, % now in tools_meta
123 % time_out_call/2, time_out_call/1, time_out_with_factor_call/3, % now in tools_timeout
124
125 unique_id/2,
126
127 get_PROBPATH/1,
128 atom_to_number/2,
129 get_set_optional_prolog_flag/3,
130
131 bb_safe_get/2,
132 bb_inc/1, bb_inc_by/2,
133
134 top_sort/3
135 ]).
136
137 :- meta_predicate foldl(3,?,?,?).
138 :- meta_predicate foldl2(?,3,?,?).
139 :- meta_predicate foldl(4,?,?,?,?).
140 :- meta_predicate foldl2(?,4,?,?,?).
141 :- meta_predicate foldl(5,?,?,?,?,?).
142 :- meta_predicate foldl2(?,5,?,?,?,?).
143 :- meta_predicate maplist5(4,-,-,-,-).
144 :- meta_predicate catch_call(0).
145 :- meta_predicate assert_once(0).
146 :- meta_predicate split_list_idx(1,?,?,?,?).
147 :- meta_predicate split_list_idx2(?,1,?,?,?).
148 :- meta_predicate map_split_list(2,?,?,?).
149 :- meta_predicate map_split_list2(?,2,?,?).
150 :- meta_predicate split_list(1,?,?,?).
151 :- meta_predicate split_list2(?,1,?,?).
152 :- meta_predicate observe_user_interrupt_signal(-,-,0).
153 :- meta_predicate filter(1,*,*,*).
154 :- meta_predicate get_options(+,4,-,-).
155 :- meta_predicate get_options(+,4,-,-,0).
156 :- meta_predicate retract_all_count(0,-,-).
157 :- meta_predicate space_call(0).
158 :- meta_predicate map_optlist(1,-).
159 :- meta_predicate map_optlist_aux(-,1).
160 :- meta_predicate call_optional(1,-).
161 :- meta_predicate call_optional_aux(-,1,-).
162
163 :- meta_predicate get_calls_for_table(:,-).
164 :- meta_predicate print_size_of_table(:).
165
166 :- meta_predicate string_escape(2,-,-).
167
168 :- meta_predicate bb_safe_get(0,-).
169 :- meta_predicate bb_inc(0).
170 :- meta_predicate bb_inc_by(0,-).
171
172 :- use_module(module_information).
173
174 :- module_info(group,infrastructure).
175 :- module_info(description,'This module contains many general helper predicates.').
176
177 :- use_module(pathes,[runtime_application_path/1]). % we just import it to set-up pathes, we don't need any predicates
178
179 :- use_module(library(lists)).
180 :- use_module(library(system)).
181 %%:- use_module(library(file_systems)). %% not required ?
182 %% :- use_module(library(codesio)).
183
184
185 :- use_module(tools_meta,[reraise_important_exception/1, safe_on_exception/3]).
186
187 :- set_prolog_flag(double_quotes, codes).
188
189
190 catch_call(Call) :-
191 catch(call(Call), Exception, (
192 add_error(catch_call,'Call raised an exception: ',(Call:Exception)),
193 /* read(_), */
194 reraise_important_exception(Exception),
195 fail
196 )).
197
198 :- use_module(error_manager,[add_warning/4]).
199 % catch CTRL-C and print a message if it happens and re-throw the interrupt
200 observe_user_interrupt_signal(Context,Span,Call) :-
201 catch(Call, user_interrupt_signal, (
202 add_warning(user_interrupt_signal,'CTRL-C occurred in context: ',Context,Span),
203 %(pending_abort_error(WF,Msg,_ErrTerm,Span)
204 % % Unfortunately any abort errors induced by Call itself are already removed by the exception
205 % -> add_message(user,'Pending WD-Error could cause long runtimes: ',Msg,Span) ; true),
206 throw(user_interrupt_signal)
207 )).
208
209
210
211 :- use_module(self_check). % put after search paths have been set
212
213 % These predicates from tools_platform are tested here to avoid module load order issues.
214
215 :- use_module(tools_platform, [map_host_platform/2, map_host_processor/2, host_platform/1]).
216 :- assert_must_succeed(map_host_platform("x86-win32-nt-4",windows)).
217 :- assert_must_succeed(map_host_platform("x86_64-win32-nt-4",windows)).
218 :- assert_must_succeed(map_host_platform("x86_64-darwin-10.6.0",darwin)).
219 :- assert_must_succeed(map_host_platform("x86_64-darwin-18.7.0",darwin)).
220 :- assert_must_succeed(map_host_platform("arm64-darwin-20.1.0",darwin)).
221 :- assert_must_succeed(map_host_platform("x86-linux-glibc2.7",linux)).
222 :- assert_must_succeed(map_host_platform("x86_64-linux-glibc2.17",linux)).
223 :- assert_must_succeed(map_host_platform("aarch64-linux-glibc2.28",linux)).
224 :- assert_must_succeed(map_host_platform("nonsense-potatos-4.2",unknown)).
225 % On SWI, the arch/host_type flag doesn't include an OS version number.
226 :- assert_must_succeed(map_host_platform("i386-win32",windows)).
227 :- assert_must_succeed(map_host_platform("x64-win64",windows)).
228 :- assert_must_succeed(map_host_platform("x86_64-darwin",darwin)).
229 :- assert_must_succeed(map_host_platform("arm64-darwin",darwin)).
230 :- assert_must_succeed(map_host_platform("aarch64-linux",linux)).
231 :- assert_must_succeed(map_host_platform("nonsense-potatos",unknown)).
232
233 :- assert_must_succeed((host_platform(Platform), Platform \= unknown)).
234
235
236 :- assert_must_succeed(map_host_processor("x86-win32-nt-4",x86)).
237 :- assert_must_succeed(map_host_processor("x86_64-win32-nt-4",x86_64)).
238 :- assert_must_succeed(map_host_processor("x86_64-darwin-10.6.0",x86_64)).
239 :- assert_must_succeed(map_host_processor("x86_64-darwin-18.7.0",x86_64)).
240 :- assert_must_succeed(map_host_processor("arm64-darwin-20.1.0",aarch64)).
241 :- assert_must_succeed(map_host_processor("x86-linux-glibc2.7",x86)).
242 :- assert_must_succeed(map_host_processor("x86_64-linux-glibc2.17",x86_64)).
243 :- assert_must_succeed(map_host_processor("aarch64-linux-glibc2.28",aarch64)).
244 :- assert_must_succeed(map_host_processor("nonsense-potatos-4.2",unknown)).
245 % On SWI, the arch/host_type flag doesn't include an OS version number.
246 :- assert_must_succeed(map_host_processor("i386-win32",x86)).
247 :- assert_must_succeed(map_host_processor("x64-win64",x86_64)).
248 :- assert_must_succeed(map_host_processor("x86_64-darwin",x86_64)).
249 :- assert_must_succeed(map_host_processor("arm64-darwin",aarch64)).
250 :- assert_must_succeed(map_host_processor("aarch64-linux",aarch64)).
251 :- assert_must_succeed(map_host_processor("nonsense-potatos",unknown)).
252
253 % --------------------------------------
254
255 cputime(T) :-
256 statistics(runtime,[T,_]).
257
258 walltime(WT) :-
259 statistics(walltime,[WT,_]).
260 % --------------------------------------
261
262
263 :- use_module(error_manager,[add_error/3, add_internal_error/2]).
264 print_message(Msg) :- print_message_with_max_depth(Msg,20).
265 print_message_with_max_depth(Msg,MaxDepth) :-
266 safe_on_exception(E,print_message2(Msg,MaxDepth),
267 add_error(tools,'Exception in print_message: ',E)). % added because sometimes in Windows/Vista we get an exception here
268 print_message2(Msg,MaxDepth) :-
269 (var(Msg) -> print_message(informational,'_')
270 ; write(user_output,'% '),write_term(user_output,Msg,[max_depth(MaxDepth)]),nl(user_output) ).
271 print_short_msg(Msg) :-
272 write(user_output,Msg).
273
274 format_bt(Msg,P) :- format(Msg,P).
275 format_bt(Msg,P) :- print(' * BACKTRACK: '),format(Msg,P),
276 fail.
277
278 print_bt_message(Msg) :- print_message(Msg).
279 print_bt_message(Msg) :- print_message(backtrack(Msg)),
280 %(Msg = found_enumeration_of_constants(_,_) -> trace ; true),
281 fail.
282
283 % like print_bt_message but trace upon backtrack
284 print_bt_trace_message(Msg) :- print_message(Msg).
285 print_bt_trace_message(Msg) :- trace,
286 print_message(backtrack(Msg)),
287 fail.
288
289 % trace upon backtrack:
290 bt_trace(_) :- true.
291 bt_trace(PP) :- print(' * BACKTRACK: '), print(PP),nl, trace,fail.
292
293 print_wtime(PP) :- statistics(walltime,[WT,_]),
294 format('~w : ~w ms ~n', [PP,WT]).
295
296 % a print that will automatically stop after 25 prints and give the user the option to inspect the printed messages
297 :- dynamic prints_count/1.
298 prints_count(25).
299 prints(L) :- print_bt_message(L),
300 (retract(prints_count(X)) -> true ; X=25),
301 (X<1
302 -> print('*** Stopped printing >'),
303 read(RT),
304 (number(RT) -> X1=RT ; X1=25)
305 ; X1 is X-1
306 ), assertz(prints_count(X1)).
307
308 :- assert_pre(tools:exact_member(_Var,Vs),
309 (list_skeleton(Vs))).
310 :- assert_post(tools:exact_member(_Var,_Vs), true).
311 :- assert_must_succeed(tools:exact_member(V,[V])).
312 :- assert_must_succeed(tools:exact_member(V,[_X,_Z,V])).
313 :- assert_must_fail(tools:exact_member(_W,[_X,_Z,_V])).
314 :- assert_must_fail(tools:exact_member(_W,[])).
315
316 exact_member(X,[Y|T]) :-
317 (X==Y -> true ; exact_member(X,T)).
318
319
320 :- assert_pre(tools:exact_member_lookup(_Var,_ValRes,Vs,Vals),
321 (list_skeleton(Vs),list_skeleton(Vals))).
322 :- assert_post(tools:exact_member_lookup(_Var,_ValRes,_Vs,_Vals), true).
323 :- assert_must_succeed(tools:exact_member_lookup(V,2,[V],[2])).
324 :- assert_must_succeed(tools:exact_member_lookup(V,2,[_X,_Z,V],[1,3,2])).
325 :- assert_must_fail(tools:exact_member_lookup(V,3,[_X,_Z,V],[1,3,2])).
326 :- assert_must_fail(tools:exact_member_lookup(_W,3,[_X,_Z,_V],[1,3,2])).
327 :- assert_must_fail(tools:exact_member_lookup(_W,3,[],[1,3,2])).
328
329 exact_member_lookup(Var,ValRes,[V|TV],[Val|TVal]) :-
330 (Var==V -> ValRes=Val ; exact_member_lookup(Var,ValRes,TV,TVal)).
331
332
333 :- assert_pre(tools:exact_member_replace(_Var,_ValRes,Vs,Vals,_),
334 (list_skeleton(Vs),list_skeleton(Vals))).
335 :- assert_post(tools:exact_member_replace(_Var,_ValRes,_Vs,_Vals,NewVals),
336 list_skeleton(NewVals)).
337 :- assert_must_succeed(tools:exact_member_replace(V,44,[_X,_Z,V],[1,3,2],[1,3,44])).
338 :- assert_must_fail(tools:exact_member_replace(_V,44,[_X,_Z,_VV],[1,3,2],[1,3,44])).
339
340 exact_member_replace(Var,NewVal,[V|TV],[Val|TVal],[NV|TN]) :-
341 ((Var==V) -> (NV=NewVal,TN=TVal)
342 ; (NV=Val,exact_member_replace(Var,NewVal,TV,TVal,TN))).
343
344
345
346 remove([X|T],X,T).
347 ?remove([Y|T],X,[Y|DT]) :- \+(X=Y), remove(T,X,DT).
348
349 :- assert_must_succeed(tools:flatten([],[])).
350 :- assert_must_succeed(tools:flatten([[1,2,3]],[1,2,3])).
351 :- assert_must_succeed(tools:flatten([[1],[[99]],[2,3],[4,5]],[1,99,2,3,4,5])).
352 :- assert_must_succeed(tools:flatten([[]],[])).
353
354 flatten(List,FlatList) :- flatten1(List,[],FlatList).
355 flatten1([],L,L) :- !.
356 flatten1([H|T],Tail,List) :- !, flatten1(H,FlatList,List), flatten1(T,Tail,FlatList).
357 flatten1(NonList,Tail,[NonList|Tail]).
358
359
360 :- use_module(tools_lists,[count_occurences/2]).
361 :- assert_must_succeed((tools_lists:count_occurences([a,b,a,a,b],R),R == [a-3,b-2])).
362
363
364
365 :- assert_must_succeed((tools:filter(var,[1,2,X,3,Y],R,Out),R == [X,Y],Out == [1,2,3])).
366 :- assert_must_succeed((tools:filter(nonvar,[1,2,X,3,Y],R,Out),R == [1,2,3],Out == [X,Y])).
367
368 filter(_Pred,[],[],[]).
369 filter(Pred,[H|T],True,False) :-
370 (call(Pred,H) -> True = [H|TT], filter(Pred,T,TT,False)
371 ? ; False = [H|FF], filter(Pred,T,True,FF)).
372
373 :- public is_a_comment/3. % used for testing filter
374 :- assert_must_succeed((tools: filter(tools:is_a_comment('/*','*/'),['This comment ','/* comment */','will be ignored!'],R,Out),
375 R==['/* comment */'],Out==['This comment ','will be ignored!'])).
376 % checking whether an atom is a comment /* ... */
377 is_a_comment(Begin,End,Comment) :-
378 maplist(atom_codes,[Begin,End,Comment],[BL,EL,CL]),
379 prefix(CL,BL),suffix(CL,EL).
380
381 :- assert_must_succeed((tools:remove_variables([X,Y,Z],[Y],R),R==[X,Z])).
382 remove_variables(List,Vars,Remaining) :-
383 exclude(exact_member_rev(Vars),List,Remaining).
384 % a version of exact member with reversed parameters - usefull with
385 % higher-order functions
386 exact_member_rev(List,Member) :- exact_member(Member,List).
387
388 :- assert_must_succeed(tools:insert([],a,[a])).
389 :- assert_must_succeed(tools:insert([a,b,c,d],a,[a,b,c,d])).
390 :- assert_must_succeed(tools:insert([a,b,c,d],b,[a,b,c,d])).
391 :- assert_must_succeed(tools:insert([a,b,c,d],d,[a,b,c,d])).
392 :- assert_must_succeed(tools:insert([a,b,c,d],x,[a,b,c,d,x])).
393 insert([],X,[X]).
394 insert([H|T],X,R) :- (H=X -> R=[H|T] ; R=[H|R2],insert(T,X,R2)).
395
396
397 :- assert_must_succeed(tools:list_intersection([a,b,c,d],[d,f,b],[b,d])).
398
399 list_intersection([],_L,[]).
400 list_intersection([H|T],L,Res) :-
401 ? (remove(L,H,NL) -> (Res=[H|RR]) ; (Res=RR,NL=L)),
402 list_intersection(T,NL,RR).
403
404 insert_new([],X,[X]).
405 insert_new([H|T],X,R) :- (H=X -> fail ; R=[H|R2],insert_new(T,X,R2)).
406
407 :- assert_must_succeed(tools:disjoint_list_union([a,b,c,d],[e,f,g],[e,f,g,a,b,c,d])).
408 :- assert_must_fail(tools:disjoint_list_union([a,b,c,d],[d,f,b],_)).
409 :- assert_must_fail(tools:disjoint_list_union([a,b,c,d],[d,f,b],[d,f,b,a,c])).
410 disjoint_list_union([],L,L).
411 disjoint_list_union([H|T],L,Res) :- insert_new(L,H,L2), disjoint_list_union(T,L2,Res).
412
413 :- assert_must_succeed(tools:lists_are_disjoint([a,b,c,d],[e,f,g])).
414 :- assert_must_succeed(tools:lists_are_disjoint([a,b,c,d],[])).
415 :- assert_must_succeed(tools:lists_are_disjoint([],[e,f,g])).
416 :- assert_must_fail(tools:lists_are_disjoint([a,b,c,d],[e,f,g,d])).
417 lists_are_disjoint([],_).
418 lists_are_disjoint([H|T],List2) :- \+ member(H,List2), lists_are_disjoint(T,List2).
419
420 :- assert_must_succeed(tools:list_difference([a,b,c,d],[b,f,d],[a,c])).
421
422 list_difference([],_L,[]).
423 list_difference([H|T],L,Res) :-
424 (remove(L,H,NL) -> (Res=RR) ; (Res=[H|RR],NL=L)),
425 list_difference(T,NL,RR).
426
427 :- use_module(tools_strings,[string_concatenate/3]).
428 :- assert_must_succeed(( tools_strings:string_concatenate('5','.10',R), R=='5.10' )).
429
430
431
432
433 :- assert_must_succeed(tools:is_upper_case_name('GOODS')).
434 :- assert_must_succeed(tools:is_upper_case_name('ZZAA')).
435 :- assert_must_fail(tools:is_upper_case_name('capacity')).
436 :- assert_must_fail(tools:is_upper_case_name('PARAs')).
437
438 :- use_module(tools_strings,[safe_name/2]).
439 is_upper_case_name(Name) :-
440 safe_name(Name,AsciiList),
441 upper_case_list(AsciiList).
442
443 upper_case_list([]).
444 upper_case_list([H|T]) :- 0'A =< H, H =< 0'Z, upper_case_list(T).
445
446
447 :- assert_must_succeed(tools:split_common_path('/aaaa/bbb/cc/d.app','/aaaa/bbb/cc/','/aaaa/bbb/cc','d.app')).
448 :- assert_must_succeed(tools:split_common_path('/aaaa/bbb/cc/d.app','/aaaa/bbb/cc/e','/aaaa/bbb/cc','d.app')).
449 :- assert_must_succeed(tools:split_common_path('/aaaa/bbb/cc/d.app','/aaaa/bbb/ce/e','/aaaa/bbb','cc/d.app')).
450 :- assert_must_succeed(tools:split_common_path('/aaaa/bbb/cc/d.app','/aaaa/e','/aaaa','bbb/cc/d.app')).
451 split_common_path(Path1,Path2,CommonPrefix,Suffix1) :-
452 split_atom_with_empty(Path1,['/','\\'],PC1),
453 split_atom_with_empty(Path2,['/','\\'],PC2),
454 split_com_aux(PC1,PC2,Com,Suff),
455 ajoin_with_sep(Com,'/',CommonPrefix),
456 ajoin_with_sep(Suff,'/',Suffix1).
457
458 split_com_aux([],_,[],Suffix) :- !, Suffix=[].
459 split_com_aux([H|T1],[H|T2],[H|CT],Suffix) :- !,
460 split_com_aux(T1,T2,CT,Suffix).
461 split_com_aux(P1,_,[],P1).
462
463
464 :- assert_must_succeed(tools:gen_relative_path('/aaaa/bbb/cc/d.app','/aaaa/e.app','bbb/cc/d.app')).
465 :- assert_must_succeed(tools:gen_relative_path('/aaaa/bbb/cc/d.app','/aaaa/bbb/e.app','cc/d.app')).
466 :- assert_must_succeed(tools:gen_relative_path('/aaaa/bbb/cc/d.app','/aaaa/bbb/cc/e.app','d.app')).
467 :- assert_must_succeed(tools:gen_relative_path('/aaaa/bbb/cc/d.app','/aaaa/xx/e.app','../bbb/cc/d.app')).
468 :- assert_must_succeed(tools:gen_relative_path('/aaaa/bbb/cc/d.app','/aaaa/xx/yy/e.app','../../bbb/cc/d.app')).
469 :- assert_must_succeed(tools:gen_relative_path('/aaaa/bbb/cc/d.app','/aaaa/xx/yy/','../../bbb/cc/d.app')).
470 :- assert_must_succeed(tools:gen_relative_path('d.app','/aaaa/xx/yy/','d.app')).
471 :- assert_must_succeed(tools:gen_relative_path('d/e.app','/aaaa/xx/yy/','d/e.app')).
472 % can be used for already expanded full paths;
473 % the relative_to option absolute_file_name does not seem to work on already expanded full paths
474 gen_relative_path(Path,ReferencePath,RelPath) :-
475 split_atom_with_empty(Path,['/','\\'],PC1),
476 (PC1 = [File|_], File \= ''
477 -> % this is a relative path, not an absolute one; this is not the intended use of this predicate
478 RelPath = Path % but can happen, e.g., in error_manager
479 ; split_atom_with_empty(ReferencePath,['/','\\'],PC2),
480 split_com_aux(PC1,PC2,_,Suff1),
481 split_com_aux(PC2,PC1,_,Suff2),
482 (Suff2=[_|D2] -> true ; D2=Suff2), % remove last entry
483 maplist(replace_by_dotdot,D2,DotDot), % replace directory names by ..
484 append(DotDot,Suff1,Rel1),
485 ajoin_with_sep(Rel1,'/',RelPath)
486 ).
487
488 replace_by_dotdot(_,'..').
489
490 :- use_module(library(file_systems),[current_directory/1]).
491 gen_relative_path_to_cur_dir(Path,RelPath) :-
492 current_directory(CurDir),
493 gen_relative_path(Path,CurDir,RelPath).
494
495
496 :- assert_must_succeed(tools:is_absolute_path('/aaaa/bbb/cc/d.app')).
497 :- assert_must_fail(tools:is_absolute_path('cc/d.app')).
498 :- assert_must_fail(tools:is_absolute_path('./cc/')).
499 is_absolute_path(Path) :-
500 atom_chars(Path,PathAscii),
501 PathAscii = ['/'|_]. % TO DO: add other rules for windows C: ...
502
503 :- assert_must_succeed(tools:get_parent_directory('/aaaa/bbb/cc/d.app','/aaaa/bbb/cc/')).
504 :- assert_must_succeed(tools:get_parent_directory('/aaaa/bbb/cc/','/aaaa/bbb/cc/')).
505 :- assert_must_succeed(tools:get_parent_directory('d.app','')).
506 :- assert_must_succeed(tools:get_parent_directory('/a/b/cc/(machine from Jupyter cell).mch','/a/b/cc/')).
507 :- assert_must_succeed(tools:get_parent_directory('D:\\Users\\OneDrive - hhu\\[Master] PA\\models\\r\\RF.mch',
508 'D:\\Users\\OneDrive - hhu\\[Master] PA\\models\\r\\')).
509
510 get_parent_directory(Path,NewPath) :-
511 atom_chars(Path,PathAscii),
512 strip_last(PathAscii,[],[],New),
513 atom_chars(NewPath,New).
514
515 :- assert_must_succeed(tools:get_parent_directory_of_directory('/aaaa/bbb/cc/d.app','/aaaa/bbb/cc/')).
516 :- assert_must_succeed(tools:get_parent_directory_of_directory('/aaaa/bbb/cc/','/aaaa/bbb/')).
517 :- assert_must_succeed(tools:get_parent_directory_of_directory('\\aaaa\\bb b\\cc\\','\\aaaa\\bb b\\')).
518 % just like get_parent_directory, except when last character is a slash
519 get_parent_directory_of_directory(Path,NewPath) :-
520 atom_chars(Path,PathAscii0),
521 (append(PathAscii,[Last],PathAscii0), is_path_slash(Last)
522 -> true ; PathAscii=PathAscii0),
523 strip_last(PathAscii,[],[],New),
524 atom_chars(NewPath,New).
525
526 is_path_slash('/').
527 is_path_slash('\\'). % Windows
528
529 :- assert_must_succeed(tools:get_parent_directory_name('/aaaa/bbb/cc/d.app','cc')).
530 :- assert_must_succeed(tools:get_parent_directory_name('/aaaa/bbb/cc/','cc')).
531 :- assert_must_succeed(tools:get_parent_directory_name('\\aaaa\\bbb\\cc\\','cc')).
532 :- assert_must_succeed(tools:get_parent_directory_name('\\aaaa\\bbb b\\cc c\\','cc c')).
533 :- assert_must_fail(tools:get_parent_directory_name('d.app',_)).
534 :- assert_must_succeed(tools:get_parent_directory_name('/a/b/cd/(machine from Jupyter cell).mch','cd')).
535
536 get_parent_directory_name(Path,DirName) :-
537 atom_chars(Path,P1),
538 split_last2_lst(P1, ['/','\\'], [],[], P2, _),
539 split_last2_lst(P2, ['/','\\'], [],[], _, DChars),
540 atom_chars(DirName,DChars).
541
542 :- use_module(library(lists)).
543
544 % strip part after last path slash
545 strip_last([],ResSoFar,_,Res) :- reverse(ResSoFar,Res).
546 strip_last([Slash|Tail],ResSoFar,StripSoFar,Res) :- is_path_slash(Slash), !,
547 append([Slash|StripSoFar],ResSoFar,NewRes),
548 strip_last(Tail,NewRes,[],Res).
549 strip_last([A|Tail],ResSoFar,StripSoFar,Res) :-
550 strip_last(Tail,ResSoFar,[A|StripSoFar],Res).
551
552 :- assert_must_succeed((tools:split_atom('ef,g',[','],R), R==[ef,g])).
553 :- assert_must_succeed((tools:split_atom('ef, g',[',',' '],R), R==[ef,g])).
554 :- assert_must_succeed((tools:split_atom('ab,cd,ef,g',[','],R), R==['ab','cd',ef,g])).
555 :- assert_must_succeed((tools:split_atom('ab,cd,ef;g',[',',';'],R), R==['ab','cd',ef,g])).
556 :- assert_must_succeed((tools:split_atom('/ef/g/',['/'],R), R==[ef,g])).
557
558 split_atom(Atom,SepList,SplitList) :-
559 atom_chars(Atom,ListAscii),
560 split2(ListAscii,SepList,SplitList).
561
562 split2([],_,R) :- !,R=[].
563 split2(List,Sep,Res) :- get_next_word(List,Sep,Word,Tail),!,
564 (Word=[]
565 -> split2(Tail,Sep,Res) % skip empty atom
566 ; Res=[Atom|TA], atom_chars(Atom,Word),
567 split2(Tail,Sep,TA)).
568
569 get_next_word([],_Sep,[],[]).
570 get_next_word([H|T],Sep,Word,Tail) :-
571 member(H,Sep) -> Word=[],Tail=T
572 ; Word=[H|TR], get_next_word(T,Sep,TR,Tail).
573
574
575 :- assert_must_succeed((tools:split_atom_with_empty('/ef/g/',['/'],R), R==['',ef,g,''])).
576 :- assert_must_succeed((tools:split_atom_with_empty('/ef/g',['/'],R), R==['',ef,g])).
577 :- assert_must_succeed((tools:split_atom_with_empty('ef/g',['/'],R), R==[ef,g])).
578 :- assert_must_succeed((tools:split_atom_with_empty('efg',['/'],R), R==[efg])).
579
580 % a version of split atom that also returns empty sub atoms
581 split_atom_with_empty(Atom,SepList,SplitList) :-
582 atom_chars(Atom,ListAscii),
583 split_wempty2(ListAscii,SepList,SplitList).
584
585 split_wempty2(List,Sep,Res) :-
586 get_next_match(List,Sep,Word,Tail),!,
587 Res=[Atom|TA], atom_chars(Atom,Word),
588 split_wempty2(Tail,Sep,TA).
589 split_wempty2(List,_,[Atom]) :- atom_chars(Atom,List).
590
591 get_next_match([H|T],Sep,Word,Tail) :-
592 member(H,Sep) -> Word=[],Tail=T
593 ; Word=[H|TR], get_next_match(T,Sep,TR,Tail).
594
595
596 :- assert_must_succeed((tools:split_complex_sep("ef,,g,h",",,",R), R==["ef","g,h"])).
597 % a version of split that allows longer seperators, % TO DO: make more efficient
598 split_complex_sep(L,Sep,[First|Rest]) :- append(Sep,LRest,SepR),
599 append(First,SepR,L),
600 !,
601 split_complex_sep(LRest,Sep,Rest).
602 split_complex_sep(H,_,[H]).
603
604
605 :- assert_must_succeed((tools:split_chars("ef,g",",",R), R==["ef","g"])).
606 :- assert_must_succeed((tools:split_chars("10",".",R), R==["10"])).
607 :- assert_must_succeed((tools:split_chars("",".",R), R==[""])).
608 :- assert_must_succeed((tools:split_chars("1.0",".",R), R==["1","0"])).
609 :- assert_must_succeed((tools:split_chars("1.",".",R), R==["1",""])).
610 :- assert_must_succeed((tools:split_chars(".1",".",R), R==["","1"])).
611
612 split_chars(List,Sep,Res) :- get_next_word_until_sep(List,Sep,Word,Tail),!,
613 Res=[Word|TA],
614 split_chars(Tail,Sep,TA).
615 split_chars(List,_,[List]).
616
617 get_next_word_until_sep([H|T],Sep,Word,Tail) :-
618 member(H,Sep) -> Word=[],Tail=T
619 ; Word=[H|TR], get_next_word_until_sep(T,Sep,TR,Tail).
620
621 :- assert_must_succeed(tools:split_last('/aaaa/bbb/cc/d.app','/','/aaaa/bbb/cc','d.app')).
622 :- assert_must_succeed(tools:split_last('/aaaa/bbb/cc/d.app','.','/aaaa/bbb/cc/d','app')).
623 split_last(Atom, Sep, Head, Tail) :- \+ atom(Sep),!,
624 add_internal_error('Separator not an atom: ', split_last(Atom, Sep, Head, Tail)),fail.
625 split_last(Atom, Sep, Head, Tail) :- atom_chars(Sep,SepACodes),
626 split_last_lst(Atom,SepACodes,Head,Tail).
627
628
629 :- assert_must_succeed(tools:split_last_lst('/aaaa/bbb;cc/d.app',['/',';'],'/aaaa/bbb;cc','d.app')).
630 :- assert_must_succeed(tools:split_last_lst('/aaaa/bbb/cc/d.app',['.'],'/aaaa/bbb/cc/d','app')).
631 % a list version of split_last: obtains a list of sperator chars
632 split_last_lst(Atom, Seps, Head, Tail) :- \+ atom(Atom),!,
633 add_internal_error('First arg not an atom: ', split_last_lst(Atom, Seps, Head, Tail)),fail.
634 split_last_lst(Atom, Seps, Head, Tail) :-
635 atom_chars(Atom,ListAscii),
636 split_last2_lst(ListAscii,Seps,[],[],HeadA, TailA),
637 atom_chars(Head,HeadA), atom_chars(Tail,TailA).
638
639 split_last2_lst([],_,CurSplit,[_|Head],ResH,ResT) :-
640 reverse(CurSplit,ResT),
641 reverse(Head,ResH).
642 ?split_last2_lst([Sep|Tail],Seps,CurSplit,Head,ResH,ResT) :- member(Sep,Seps), % TO DO: use ord_member ?
643 !,
644 append([Sep|CurSplit],Head,NewHead),
645 split_last2_lst(Tail,Seps,[],NewHead,ResH,ResT).
646 split_last2_lst([H|Tail],Seps,CurSplit,Head,ResH,ResT) :-
647 split_last2_lst(Tail,Seps,[H|CurSplit],Head,ResH,ResT).
648
649
650
651 :- assert_must_succeed(tools:split_filename('/aaaa/bbb/cc/d.app','/aaaa/bbb/cc/d','app')).
652 :- assert_must_succeed((Z='/aaaa/bbb/cc/d',tools:split_filename(Z,R,X),X=='',R==Z)).
653
654 split_filename(Filename,Base,Ext) :-
655 (split_last(Filename,'.',Base,Ext) -> true ; Base=Filename,Ext='').
656
657
658 :- assert_must_succeed(tools:get_tail_filename('/aaaa/bbb/cc/d.app','d.app')).
659 :- assert_must_succeed(tools:get_tail_filename('\\aaaa\\bbb\\c\\d.app','d.app')).
660 :- assert_must_succeed(tools:get_tail_filename('d.app','d.app')).
661 :- assert_must_succeed(tools:get_tail_filename('/aaaa/bbb/cc/','')).
662 get_tail_filename(Path,Tail) :- compound(Path),!,
663 add_internal_error('Not a filename: ',get_tail_filename(Path,Tail)),
664 Tail=Path.
665 get_tail_filename(Path,Tail) :- (split_last_lst(Path, ['/','\\'], _, T) -> Tail=T ; Tail=Path).
666
667 :- assert_must_succeed(tools:get_modulename_filename('/aaaa/bbb/cc/d.app','d')).
668 :- assert_must_succeed(tools:get_modulename_filename('d.app','d')).
669 get_modulename_filename(Path,Module) :-
670 get_tail_filename(Path,Tail),
671 (split_last(Tail, '.', M, _) -> Module=M ; Module=Tail).
672
673
674 :- assert_must_succeed(get_filename_extension('/aaaa/bbb/cc/d.app','app')).
675 get_filename_extension(Path,Ext) :- split_filename(Path,_,Ext).
676
677 % also works if numbers passed (can happen by accident in test_runner ...)
678 % absolute_file_name('$a',X) generates a permission error
679 safe_absolute_file_name(F,AF,Options) :-
680 ensure_atom(F,A),
681 catch(
682 absolute_file_name(A,AF,Options),
683 error(permission_error(_,_,_),ERR),
684 (format('*** Permission Error for absolute_file_name: ~w~n',[ERR]),AF=F)).
685
686 safe_absolute_file_name(F,AF) :- safe_absolute_file_name(F,AF,[]).
687
688 % host_platform specific check if file names match
689 same_file_name(F,F) :- !.
690 same_file_name(File1,File2) :- host_file_name_case_insensitive,
691 atom_codes(File1,FC1),
692 atom_codes(File2,FC2),
693 maplist(case_insensitive_match,FC1,FC2).
694
695 case_insensitive_match(Code,Code) :- !.
696 case_insensitive_match(C1,C2) :-
697 simple_lowcase(C1,L1),
698 simple_lowcase(C2,L1).
699
700 % TODO: are there other changes to be made in Windows filenames?
701 simple_lowcase(H,R) :- H >="A", H=<"Z", !, R is H+"a"-"A".
702 simple_lowcase(92,R) :- !, R=47. % convert Windows path divider \ to Unix one /
703 simple_lowcase(Code,Code).
704
705 host_file_name_case_insensitive :-
706 host_platform(Platform),
707 host_file_name_case_insensitive(Platform).
708 host_file_name_case_insensitive(windows).
709 host_file_name_case_insensitive(darwin). % by default case insensitive, but up/lower case stored
710 % TODO: can we check if main filesystem is case sensitive??
711
712 %*******************************************************************************
713 % remove_all(A,B,Result): Result is the list of elements of A which do not occur in B
714 remove_all([],_,[]).
715 remove_all([H|T],Remove,Result) :-
716 ? (member(H,Remove) -> !,Result = Rest ; Result = [H|Rest]),
717 remove_all(T,Remove,Rest).
718
719
720
721 %*******************************************************************************
722 % get options from Prolog list passed as parameter
723
724
725 :- assert_must_succeed((get_option_from_list(b,2,[a/false,b/true],B),B==true)).
726 get_option_from_list(Option,Default, OptionList,Value) :-
727 (memberchk(Option/V,OptionList) -> Value=V ; Value=Default).
728
729
730 :- assert_must_succeed(get_options_from_list([option(a,true,false)],[a/false,b/true])).
731 :- assert_must_succeed((get_options_from_list([option(a,true,A)],[a/false,b/true]),A==false)).
732 :- assert_must_succeed((get_options_from_list([option(c,3,C),option(b,1,B),option(a,2,A)],[a/false,b/true]),
733 A==false,B==true,C==3)).
734
735 :- use_module(library(lists), [select/3]).
736
737 get_options_from_list([],_OptionList). % TO DO: provide optional check that no other options left
738 get_options_from_list([option(OptionName,Default,Value)|T],OptionList) :-
739 (select(OptionName/V,OptionList,Rest) -> Value=V
740 ; Value=Default, Rest=OptionList),
741 get_options_from_list(T,Rest).
742
743
744 %*******************************************************************************
745 % get_options/4 for parsing command line arguments
746
747
748 get_options(List,Pred,Options,Rest) :-
749 get_options(List,Pred,Options,Rest,halt).
750 get_options([],_,[],[],_).
751 get_options([X|T],Recognised,Options,Args,HALTCMD) :-
752 ? ( call(Recognised,X,Opt,Values,Action)
753 ->
754 ( append(Values, Rest, T) -> true
755 ;
756 length(Values,Len),
757 length(T,TLen),
758 (TLen < Len
759 -> format('Command ~w expects ~w argument(s); ~w provided.~n',[X,Len,TLen])
760 ; format('~nInvalid argument(s) for option: ~w.~n',[X]) % will never happen ??
761 ),
762 HALTCMD),
763 ( call(Action) -> true
764 ;
765 format('~nInvalid argument(s) for option ~w : ~w.~n',[X,Values]),
766 HALTCMD),
767 RT = Rest,
768 Options = [Opt|OT], Args = AT
769 ; % option not recognised, keep in Args list (for probcli these are assumed to be files)
770 Options = OT, Args = [X|AT],
771 RT = T
772 ),
773 get_options(RT,Recognised,OT,AT,HALTCMD).
774
775 arg_is_number(Arg,Nr) :- number(Arg),!,Nr=Arg.
776 arg_is_number(Arg,Nr) :- atom(Arg),atom_codes(Arg,Str),safe_number_codes(Nr,Str),number(Nr).
777 arg_is_integer(Arg,Nr) :-
778 ( append("-",SPos,Arg) -> % negative number
779 arg_is_number(SPos,Pos),
780 Nr is -Pos
781 ;
782 arg_is_number(Arg,Nr)).
783
784 % utilities for command-line arguments
785 % allow Number, _, >Number, <Number
786 arg_is_number_or_wildcard('_',R) :- !, R=_.
787 arg_is_number_or_wildcard('*',R) :- !, R=_. % * on command-line is expanded to files unless quoted
788 arg_is_number_or_wildcard(Arg,R) :- arg_is_number(Arg,N),!,R=N.
789 arg_is_number_or_wildcard(Comparator,R) :- atom(Comparator), atom_codes(Comparator,AC),
790 comparator(AC,CompOp,NC), safe_number_codes(Nr,NC), R=comparison_operator(CompOp,Nr).
791 comparator([0'>|T],>,T). % Ascii code 62
792 comparator([0'<|T],<,T).
793 comparator([0'>,0'=|T],'>=',T).
794 comparator([0'=,0'<|T],'=<',T).
795
796
797 % TO DO: add comparator
798
799 :- use_module(error_manager,[add_warning/3]).
800 check_filename_arg(File,Command) :- tools:arg_is_number(File,_),!,
801 ajoin(['File argument to -',Command,' is a number: '],Msg),
802 add_warning(Command,Msg,File).
803 check_filename_arg(File,Command) :- atom(File),
804 sub_atom(File,0,1,_,'-'), % atom_concat('-',_,File),
805 !,
806 ajoin(['File argument to -',Command,' starts with a hypen: '],Msg),
807 add_warning(Command,Msg,File).
808 check_filename_arg(_,_).
809
810
811 :- assert_must_succeed( tools:convert_list_into_pairs([a],a)).
812 :- assert_must_succeed( (tools:convert_list_into_pairs([a,b,c],R), R = ((a,b),c) )).
813
814 convert_list_into_pairs([X|T],Res) :- !,conv2(T,X,Res).
815 convert_list_into_pairs([],Res) :- !, Res=[].
816 convert_list_into_pairs(X,R) :- add_internal_error('Not a list: ',convert_list_into_pairs(X,R)),R=X.
817 conv2([],X,X).
818 conv2([X|T],Acc,Res) :- conv2(T,(Acc,X),Res).
819
820 :- assert_must_succeed(( tools:convert_pairs_into_list([x],a,R), R==[a] )).
821 %:- assert_must_succeed(( b_interpreter:convert_pairs_into_list([x,y,z],((a,b),c),R), R == [a,b,c] )).
822 :- assert_must_succeed(( tools:convert_pairs_into_list([x,y,z],((a,b),c),R), R == [a,b,c] )).
823 :- assert_must_succeed(( tools:convert_pairs_into_list([x,y,z],A,B),nonvar(A),nonvar(B),A=((_,_),_),B=[_,_,_] )).
824
825 % the first argument just indicates the identifiers, the second is a constructed pair and the third the list of values
826 convert_pairs_into_list([_],X,R) :- !,R=[X].
827 convert_pairs_into_list([_|Guide],Pair,R) :- !, R = [A|TValList],
828 conv4(Guide,A,Pair,TValList).
829 convert_pairs_into_list(List,Pairs,Result) :-
830 add_internal_error('Illegal arguments:',convert_pairs_into_list(List,Pairs,Result)),
831 fail.
832
833 conv4([],X,X,[]).
834 conv4([_|T],Acc,Res,[X|TValList]) :- conv4(T,(Acc,X),Res,TValList).
835
836
837 /* ex: substitute(1, [1,2,3,4], 5, X). */
838 :- assert_must_succeed(( tools:substitute(1, [1,2,3,4], 5, X), X==[5,2,3,4])).
839 substitute(X,L,Y,Res) :- sub(L,X,Y,Res).
840 sub([],_,_,[]).
841 sub([H|T],X,Y,[SH|ST]) :-
842 (H=X -> SH=Y ; SH=H),
843 sub(T,X,Y,ST).
844
845
846
847 :- use_module(tools_strings,[ajoin/2, ajoin_with_sep/3, ajoin_with_limit/3]).
848 % tests are stored here to avoid cyclic module dependencies
849 :- assert_must_succeed((tools_strings: ajoin_with_sep([link,a,xa],'.',Text), Text == 'link.a.xa')).
850 :- assert_must_succeed((tools_strings: ajoin_with_sep([link],'.',Text), Text == 'link')).
851 :- assert_must_succeed((tools_strings: ajoin_with_sep(['',a,''],'.',Text), Text == '.a.')).
852
853 :- assert_must_succeed((tools_strings: ajoin_with_limit(['A','B','C','D'],100,Text), Text == 'ABCD')).
854 :- assert_must_succeed((tools_strings: ajoin_with_limit(['A','B','C','D'],2,Text), Text == 'AB...')).
855
856
857 :- use_module(error_manager,[add_error_and_fail/3]).
858 safe_univ(Term,List) :- nonvar(Term),!,Term=..List.
859 safe_univ(Term,List) :- var(List), !,add_error_and_fail(tools,'Arguments to safe_univ (=..) both var:', safe_univ(Term,List)).
860 safe_univ(Term,List) :- %Term is a variable
861 current_prolog_flag(max_arity,MA),
862 (MA = unbounded -> CL = List ; cut_off_list(List,MA,CL)),
863 !, % avoid pending choice points
864 Term =.. CL.
865
866 cut_off_list([],_,[]).
867 cut_off_list([H|T],MA,R) :- (MA<2 -> R=['...'] ; R=[H|TR],MA1 is MA-1, cut_off_list(T,MA1,TR)).
868
869
870 % a version of safe_univ which does not remove args; just puts the extra arguments into the last arg
871
872 safe_univ_no_cutoff(Term,List) :- nonvar(Term),!,Term=..List.
873 safe_univ_no_cutoff(Term,List) :- var(List), !,
874 add_error_and_fail(tools,'Arguments to safe_univ (=..) both var:', safe_univ_no_cutoff(Term,List)).
875 safe_univ_no_cutoff(Term,List) :- %Term is a variable
876 current_prolog_flag(max_arity,MA),
877 (MA = unbounded -> CL = List ; squash_list(List,MA,CL)),
878 !, % avoid pending choice points
879 Term =.. CL.
880 squash_list([],_,[]).
881 squash_list([H|T],MA,R) :- (MA<3,T\=[] -> R=[H,T] ; R=[H|TR],MA1 is MA-1, squash_list(T,MA1,TR)).
882
883 safe_atom_chars(A,B,Loc) :-
884 catch(atom_chars(A,B), error(E1,E2), (
885 add_internal_error('atom_chars error: ',Loc:E1),
886 throw(error(E1,E2))
887 )).
888
889 :- use_module(tools_strings,[atom_codes_with_limit/2, atom_codes_with_limit/3]).
890
891 safe_atom_codes(V,C) :- var(V),var(C),!,
892 add_internal_error('Variables in call: ',safe_atom_codes(V,C)), C='$VARIABLE$'.
893 safe_atom_codes(A,C) :-
894 catch(atom_codes(A,C), error(representation_error(max_atom_length),_), (
895 print(exception(max_atom_length)),nl,
896 atom_codes_with_limit(A,1000,C)
897 )).
898
899 safe_number_codes(V,C) :- var(V),var(C),!,
900 add_internal_error('Variables in call: ',safe_number_codes(V,C)), C='$VARIABLE$'.
901 safe_number_codes(A,C) :-
902 catch(number_codes(A,C), error(syntax_error(_N),_), (
903 %print(9,syntax_error_in_number_codes(_N)),nl,
904 % in this case safe_number_codes fails ; we cannot convert the codes into a number
905 fail
906 )).
907
908 % for an identifier "x" and a number N, create a new identifier "x$N"
909 number_suffix(Id,N,FullId) :-
910 safe_atom_chars(Id,IdChars,number_suffix1),number_chars(N,NChars),
911 append(IdChars,['$'|NChars],FullIdChars),
912 safe_atom_chars(FullId,FullIdChars,number_suffix2).
913
914
915 :- assert_must_succeed(ensure_atom(19,'19')).
916 % ensure that numbers get converted to atoms:
917 ensure_atom(Var,A) :- var(Var),!, A='_'.
918 ensure_atom(N,Res) :- number(N),!,number_codes(N,C), atom_codes(A,C), Res=A.
919 ensure_atom(A,A).
920
921
922 :- assert_must_succeed(atom_or_number_codes(19,"19")).
923 :- assert_must_succeed(atom_or_number_codes(aa,"aa")).
924 atom_or_number_codes(N,Res) :- number(N),!,number_codes(N,Res).
925 atom_or_number_codes(A,Res) :- atom(A),!,atom_codes(A,Res).
926 atom_or_number_codes(Other,Res) :-
927 add_internal_error('Not atom or number: ',atom_or_number_codes(Other,Res)),
928 Res = [].
929
930
931 :- use_module(tools_strings,[truncate_atom/3]).
932 :- assert_must_succeed((tools_strings:truncate_atom(abcd,100,Text), Text == 'abcd')).
933 :- assert_must_succeed((tools_strings:truncate_atom(abcd,2,Text), Text == 'ab...')).
934 :- assert_must_succeed((tools_strings:truncate_atom(abcd,0,Text), Text == '...')).
935
936
937 wrap_and_truncate_atom(Atom,LineLength,Limit,NewAtom) :- \+ atom(Atom),!,
938 add_internal_error('Argument to wrap_and_truncate_atom not atom: ',wrap_and_truncate_atom(Atom,LineLength,Limit,NewAtom)),
939 NewAtom=Atom.
940 wrap_and_truncate_atom(Atom,LineLength,Limit,NewAtom) :-
941 atom_codes(Atom,Codes),
942 wrap_and_truncate_codes(Codes,LineLength,LineLength,Limit,NewCodes,Chng),
943 (Chng=true -> atom_codes(NewAtom,NewCodes) ; NewAtom=Atom).
944
945 wrap_and_truncate_codes([],_,_,_,[],false).
946 wrap_and_truncate_codes([H|T],CharsOnLineCount,MaxLineLength,TotCount,Res,Chng) :-
947 (TotCount<1 -> Res = [46,46,46],Chng=true /* '...' */
948 ; (CharsOnLineCount<1 -> Res=[92,110,H|TT], /* add newline \n */
949 TR=T, L1 is MaxLineLength, Chng=true
950 ; H=92,T=[H2|T2] -> Res = [H,H2|TT], /* do not split escaped char */
951 TR=T2, L1 is CharsOnLineCount-1, Chng2=Chng
952 ; Res = [H|TT], TR=T, L1 is CharsOnLineCount-1, Chng2=Chng),
953 TC1 is TotCount-1, wrap_and_truncate_codes(TR,L1,MaxLineLength,TC1,TT,Chng2)
954 ).
955
956
957 % print_size_of_table counts the number of succeeded calls of the
958 % given predicate
959 get_calls_for_table(Module:P/N,Call) :- !,
960 functor(Call,P,N),
961 call(Module:Call).
962 get_calls_for_table(P/N,Call) :-
963 functor(Call,P,N),
964 call(Call).
965
966 :- volatile count/1.
967 :- dynamic count/1.
968 print_size_of_table(Pred) :- retractall(count(_)),
969 assertz(count(0)),
970 get_calls_for_table(Pred,_),inc_size_of_table,fail.
971 print_size_of_table(Pred) :-
972 print('% size of table for '), print(Pred), print(': '), count(X), print(X),nl.
973 inc_size_of_table :- retract(count(X)),X1 is X+1, assertz(count(X1)).
974
975
976 % ----------------- Sorting ---------------
977
978 safe_sort(Orig,A,B) :- var(A),!, add_internal_error('Illegal call: ',safe_sort(Orig,A,B)),A=B.
979 safe_sort(_,A,B) :- sort(A,B).
980
981 :- use_module(library(samsort)).
982 % a sorting function which checks that there were no multiples in the original list
983 safe_set_sort(Orig,S,Res) :- var(S),!, add_internal_error('Illegal call: ',safe_set_sort(Orig,S,Res)),S=Res.
984 %safe_set_sort(Orig,S,Res) :- !,sort(S,Res).
985 safe_set_sort(Orig,S,Res) :- samsort(S,SS),
986 (SS=[H|T] -> (check_for_multiples(T,H,Orig) -> Res=SS ; sort(SS,Res)) ; Res=SS).
987 check_for_multiples([],_,_).
988 check_for_multiples([H|T],Prev,Origin) :-
989 (H=Prev
990 -> add_error(Origin,'Multiple occurrences in set list of: ',H),fail
991 ; check_for_multiples(T,H,Origin)).
992
993 % ----------------------
994
995 safe_functor(Src,F,A,Term) :- var(F),var(A),var(Term),!,
996 add_internal_error('Illegal functor call: ',safe_functor(Src,F,A,Term)),
997 fail.
998 safe_functor(_,F,A,T) :- functor(F,A,T).
999
1000
1001 print_runtime :- statistics(runtime,[Tot,SinceLast]), print(' Total runtime: '), print(Tot),
1002 print(' ms, since last: '), print(SinceLast), print(' ms'),nl.
1003
1004 :- use_module(debug,[debug_mode/1, silent_mode/1]).
1005 start_ms_timer(timer(R,T,W)) :- statistics(runtime,[R,_]),
1006 statistics(total_runtime,[T,_]),
1007 statistics(walltime,[W,_]).
1008 stop_ms_timer(T) :- stop_ms_timer(T,[runtime/RT,total_runtime/RTT,walltime/WT]),
1009 format('% Runtime: ~w ms (with gc: ~w ms, walltime: ~w ms)~n',[RT,RTT,WT]).
1010 stop_ms_timer_with_debug_msg(T,Msg) :-
1011 (debug_mode(on) -> stop_ms_timer_with_msg(T,Msg) ; true).
1012 stop_ms_timer_with_silent_msg(T,Msg) :-
1013 (silent_mode(on) -> true ; stop_ms_timer_with_msg(T,Msg)).
1014 stop_ms_timer_with_msg(T,Msg) :- stop_ms_timer(T,[runtime/RT,total_runtime/RTT,walltime/WT]),
1015 statistics(walltime,[WE,_]),
1016 convert_ms_time_to_string(WE,WEStr),
1017 format('% Runtime for ~w: ~w ms (with gc: ~w ms, walltime: ~w ms); since start: ~w~n',[Msg,RT,RTT,WT,WEStr]).
1018 stop_ms_walltimer_with_msg(T,Msg) :- stop_ms_timer(T,[runtime/_RT,total_runtime/_RTT,walltime/WT]),
1019 format('% Walltime for ~w: ~w ms~n',[Msg,WT]).
1020 stop_ms_timer(timer(R,T,W),[runtime/RT,total_runtime/RTT,walltime/WT]) :-!,
1021 statistics(runtime,[RE,_]),
1022 % These refer to CPU time used while executing, excluding time spent in memory management tasks or or in system calls.
1023 statistics(total_runtime,[TE,_]),
1024 % These refer to total CPU time used while executing, including memory management tasks such as garbage collection but excluding system calls.
1025 statistics(walltime,[WE,_]),
1026 % These refer to absolute time elapsed.
1027 RT is RE-R, RTT is TE-T, WT is WE-W.
1028 stop_ms_timer(X,Y) :-
1029 add_internal_error('Illegal call: ', stop_ms_timer(X,Y)),
1030 Y = [].
1031 get_elapsed_walltime(timer(_R,_T,W),WTot) :-
1032 statistics(walltime,[W2,_]), WTot is W2-W.
1033
1034 % convert ms time to a user readable time string
1035 convert_ms_time_to_string(TimeMS,Str) :-
1036 convert_ms_time_to_hms(TimeMS,H,M,S,MS),
1037 (H > 0 -> ajoin([H,' h ', M, ' min ', S, ' sec ', MS, ' ms'],Str)
1038 ; M > 0 -> ajoin([M, ' min ', S, ' sec ', MS, ' ms'],Str)
1039 ; ajoin([S, ' sec ', MS, ' ms'],Str)).
1040
1041 convert_ms_time_to_hms(TimeMS,Hours,MinsMod,SecsMod,MilSecs) :-
1042 MilSecs is TimeMS mod 1000,
1043 Secs is TimeMS // 1000, SecsMod is Secs mod 60,
1044 Mins is Secs // 60, MinsMod is Mins mod 60,
1045 Hours is Mins // 60.
1046
1047 % get delta timer between old timer1 and current time
1048 get_elapsed_timer(timer(R1,T1,W1),timer(R,T,W)) :-
1049 statistics(runtime,[R2,_]),
1050 statistics(total_runtime,[T2,_]),
1051 statistics(walltime,[W2,_]),
1052 R is R2-R1, T is T2-T1, W is W2-W1.
1053 get_elapsed_runtime(timer(R1,_,_),Delta) :-
1054 statistics(runtime,[R2,_]),
1055 Delta is R2-R1.
1056
1057 % combine (add) two timers
1058 combiner_timer(0,T2,R) :- !, R=T2.
1059 combiner_timer(timer(R1,T1,W1),timer(R2,T2,W2),timer(R,T,W)) :-
1060 R is R1+R2, T is T1+T2, W is W1+W2.
1061
1062 % a timer that measures backtracking times
1063 :- dynamic last_bt_timer/2.
1064 bt_start_ms_timer(Msg) :- retractall(last_bt_timer(Msg,_)),
1065 start_ms_timer(T), assertz(last_bt_timer(Msg,T)).
1066 bt_start_ms_timer(Msg) :- retract(last_bt_timer(Msg,Timer)),
1067 stop_ms_timer(Timer,[runtime/RT,total_runtime/_RTT,walltime/WT]),
1068 format('% Runtime to FINALISE ~w: ~w ms (walltime: ~w ms)~n',[Msg,RT,WT]),
1069 fail.
1070
1071
1072 bt_stop_ms_timer(Msg) :-
1073 retract(last_bt_timer(Msg,Last)),
1074 stop_ms_timer(Last,[runtime/RT,total_runtime/_RTT,walltime/WT]),
1075 format('% Runtime for SOLUTION for ~w: ~w ms (walltime: ~w ms)~n',[Msg,RT,WT]).
1076 bt_stop_ms_timer(Msg) :- start_ms_timer(BT_Timer),
1077 assertz(last_bt_timer(Msg,BT_Timer)),
1078 fail.
1079 % ---------------------------
1080
1081
1082 retract_with_statistics(Module,ListOfFacts) :-
1083 nl,print('Retracting Facts'),nl,
1084 get_memory_used(M),
1085 print(' Memory usage: '),print_memory_used(M),nl,
1086 retract_with_statistics(Module,ListOfFacts,M).
1087
1088
1089 retract_with_statistics(_Module,[],_) :- nl.
1090 retract_with_statistics(Module,[Fact|T],Mem) :-
1091 format('~w : ',[Fact]),
1092 %retractall(Module:Fact),
1093 retract_all_count(Module:Fact,0,Nr), format(' ~w facts : ',[Nr]),
1094 get_memory_used(NewMem),
1095 print_memory_used(NewMem),
1096 print_memory_used_difference(Mem,NewMem),
1097 retract_with_statistics(Module,T,NewMem).
1098
1099 retract_all_count(Fact,Acc,Res) :- \+ (\+ (retract(Fact))),!, A1 is Acc+1, retract_all_count(Fact,A1,Res).
1100 retract_all_count(_,R,R).
1101
1102 :- if(current_prolog_flag(dialect, swi)).
1103 % this could possibly be moved to SWI compatibility code
1104 statistics_memory_used(M) :-
1105 statistics(stack,GL), statistics(trail,T), statistics(heapused,H), M is GL+T+H.
1106 % not sure this computes all of memory used; other keys: globalused, localused, codes
1107 :- else.
1108 statistics_memory_used(M) :- statistics(memory_used,M).
1109 :- endif.
1110
1111 get_memory_used([M,PU]) :- garbage_collect,garbage_collect_atoms, get_memory_used_wo_gc([M,PU]).
1112 get_memory_used_wo_gc([M,PU]) :- statistics(program,[PU,_]),statistics_memory_used(M).
1113 print_memory_used_wo_gc :- print_memory_used_wo_gc(user_output).
1114 print_memory_used_wo_gc(Stream) :- get_memory_used_wo_gc(M), print_memory_used(Stream,M).
1115
1116 print_memory_used(M) :- print_memory_used(user_output,M).
1117 print_memory_used(Stream,[M,PU]) :- print_mb(Stream,M),
1118 write(Stream,' ('), print_mb(Stream,PU), write(Stream,' program) ').
1119
1120 print_memory_used_difference([M1,_PU1],[NewM2,_PU2]) :- Diff is (M1)-(NewM2),
1121 (Diff >= 0 -> print(' freed: '), print_bytes(Diff)
1122 ; print(' allocated: '), D2 is -(Diff), print_bytes(D2)),nl.
1123 %print(' / '),Diff2 is (PU1)-(PU2), print_mb(Diff2).
1124 print_bytes(X) :- (X<50000 -> print_kb(X) ; print_mb(X)).
1125 print_gb(X) :- XGB is X / 1000000000, % used instead of deprecated 1048576
1126 format(' ~3f GB',[XGB]).
1127 print_mb(X) :- print_mb(user_output,X).
1128 print_mb(Stream,X) :- XMB is X / 1000000, % used instead of deprecated 1048576
1129 format(Stream,' ~3f MB',[XMB]).
1130 print_kb(X) :- XKB is X / 1000, % used instead of deprecated 1024
1131 format(' ~3f KB',[XKB]).
1132
1133 space_call(Call) :- get_memory_used(M1),
1134 call(Call),
1135 get_memory_used(M2),
1136 print_memory_used(M2),
1137 print_memory_used_difference(M1,M2).
1138
1139 % ---------------------------
1140
1141 :- use_module(library(fastrw),[fast_read/2]).
1142
1143 read_term_from_file(Filename,Term) :-
1144 absolute_file_name(Filename,AbsFilename,[]),
1145 open(AbsFilename,read,Stream),
1146 peek_code(Stream,Code),
1147 read_term_from_file2(Code,Stream,AbsFilename,Term).
1148
1149 read_term_from_file2(Code,Stream,File,Term) :-
1150 fastrw_start_code(Code), !,
1151 close(Stream),
1152 open(File,read,NewStream,[type(binary)]),
1153 fast_read(NewStream,Term),
1154 close(NewStream).
1155 read_term_from_file2(_,Stream,_,Term) :-
1156 read_term(Stream,Term,[]),
1157 close(Stream).
1158
1159 fastrw_start_code(0'D). % like for .prob in parsercall
1160
1161 :- use_module(library(codesio), [read_from_codes/2]).
1162 safe_read_term_from_atom(Atom,Term) :-
1163 safe_atom_codes(Atom,Codes),
1164 safe_read_term_from_codes(Codes,Term).
1165 safe_read_term_from_codes(Codes,Term) :-
1166 (append(_,[46],Codes) % add dot: 46 = '.' if required
1167 -> Codes1 = Codes
1168 ; append(Codes,[46],Codes1)
1169 ),
1170 catch(read_from_codes(Codes1,Term),
1171 error(syntax_error(StxMsg),_),
1172 (atom_codes(AT,Codes),
1173 ajoin(['Prolog syntax error: ',StxMsg,' in'],Msg),
1174 add_error(read_term_from_codes,Msg,AT), fail)
1175 ).
1176
1177
1178 read_string_from_file(Filename,String) :-
1179 absolute_file_name(Filename,AbsFilename,[]),
1180 open(AbsFilename,read,S), % utf
1181 read_string(S,String),
1182 close(S).
1183
1184 % Encoding can be any value of text_encoding preference category: auto, 'ISO-8859-1', 'UTF-8', ...
1185 read_string_from_file(Filename,auto,String) :- !, read_string_from_file(Filename,String).
1186 read_string_from_file(Filename,Encoding,String) :-
1187 absolute_file_name(Filename,AbsFilename,[]),
1188 open(AbsFilename,read,S,[encoding(Encoding)]),
1189 read_string(S,String),
1190 close(S).
1191
1192 read_string(S,String) :-
1193 get_code(S,C),!,
1194 (C= -1
1195 -> String = []
1196 ; String = [C|Rest], read_string(S,Rest)).
1197
1198 read_atom_from_file(Filename,Encoding,Atom) :-
1199 read_string_from_file(Filename,Encoding,String),
1200 atom_codes(Atom,String).
1201
1202 % version which catches exceptions
1203 safe_read_string_from_file(Filename,Encoding,String) :-
1204 catch(read_string_from_file(Filename,Encoding,String), E, (
1205 ajoin(['Could not read string from file ',Filename,':'],Msg),
1206 add_error(read_string_from_file,Msg,E),
1207 fail
1208 )).
1209
1210 :- use_module(debug,[debug_format/3]).
1211 % open a file using auto and try and read XML header
1212 % <?xml version="1.0" encoding="UTF-8"?>
1213 % useful to first open file and detect encoding and then re-open file using the found encoding
1214 detect_xml_encoding(Filename,Version,Encoding) :-
1215 absolute_file_name(Filename,AbsFilename,[]),
1216 open(AbsFilename,read,Stream),
1217 call_cleanup(
1218 (
1219 match(" <?xml_version = \"",Stream),
1220 read_quoted_xml_string_contents(Stream,Version),
1221 debug_format(19,'XML version ~s detected~n',[Version]),
1222 (match(" encoding = \"",Stream)
1223 -> read_quoted_xml_string_contents(Stream,EncodingCodes),
1224 debug_format(19,'XML encoding ~s detected~n',[EncodingCodes]),
1225 (EncodingCodes = "windows 1252" -> UEnc=Encoding % only encoding using lower case
1226 ; maplist(simple_upcase,EncodingCodes,UEnc) % convert utf-8 to UTF-8;
1227 ),
1228 atom_codes(Encoding,UEnc)
1229 ; debug_format(19,'No XML encoding detected in header, using auto ~w~n',[Filename]),
1230 Encoding = auto
1231 )
1232 ),
1233 close(Stream)).
1234
1235
1236 simple_upcase(H,R) :- H >="a", H=<"z", !, R is H+"A"-"a".
1237 simple_upcase(H,H).
1238
1239 % simple read contents of a string until end quote; no escaping detected (yet)
1240 read_quoted_xml_string_contents(Stream,String) :-
1241 get_code(Stream,C),!,
1242 (C= -1
1243 -> String = []
1244 ; C = 34 -> String = [] % string finished
1245 ; String=[C|Rest],read_quoted_xml_string_contents(Stream,Rest)).
1246
1247 match([],_).
1248 match([H|T],Stream) :- !, get_code(Stream,C),
1249 match2(H,T,C,Stream).
1250
1251 match2(32,T,C,Stream) :- !, % treat a space character as optional whitespace
1252 (is_ws(C) -> match([32|T],Stream)
1253 ; T = [H1|T1],
1254 match2(H1,T1,C,Stream)
1255 ).
1256 match2(95,T,C,Stream) :- !, % treat underscore as mandatory whitespace
1257 (is_ws(C) -> match([32|T],Stream)
1258 ; debug_format(19,'Not a valid xml header ("~s" instead of whitespace)~n',[[C]]),fail
1259 ).
1260 match2(H,T,C,Stream) :-
1261 (C=H -> match(T,Stream)
1262 ; format('Not a valid xml header ("~s" instead of "~s")~n',[[C],[H]]),fail
1263 ).
1264
1265 is_ws(32).
1266 is_ws(9). % tab
1267 is_ws(10).
1268 is_ws(13).
1269
1270 %! open_temp_file(+BaseName, -Path, -Stream, +Options) is det.
1271 %
1272 % Compatible way to create and open a temporary file.
1273 %
1274 % ReqName will be used as the file name if possible,
1275 % but the actual file name may be different
1276 % (e. g. it may have a unique suffix added).
1277 % Path is the temporary file's full path,
1278 % which is automatically opened for writing as Stream.
1279 % Supported Options are type(binary) and encoding(Encoding).
1280 % see also tmpdir preference, default /tmp/ on Unix
1281
1282 :- if(predicate_property(tmp_file_stream(_,_,_), _)). % SWI
1283
1284 :- use_module(library(lists), [select/4]).
1285 open_temp_file(ReqName, Path, Stream, Options) :-
1286 select(type(binary), Options, encoding(octet), OptionsMod),
1287 !,
1288 open_temp_file(ReqName, Path, Stream, OptionsMod).
1289 open_temp_file(ReqName, Path, Stream, Options) :-
1290 % tmp_file_stream only allows controlling the extension, not the name before it.
1291 get_filename_extension(ReqName, Extension),
1292 tmp_file_stream(Path, Stream, [extension(Extension)|Options]).
1293
1294 :- else. % SICStus
1295
1296 open_temp_file(ReqName, Path, Stream, Options) :-
1297 open(temp(ReqName), write, Stream, [if_exists(generate_unique_name)|Options]),
1298 stream_property(Stream, file_name(Path)).
1299
1300 :- endif.
1301
1302 open_temp_file(ReqName, Path, Stream) :- open_temp_file(ReqName, Path, Stream, []).
1303
1304 % ------------------------------
1305
1306 % encoding atoms for Latex:
1307
1308 latex_escape_atom(Atom,EscAtom) :- \+ atom(Atom),!,
1309 add_internal_error('Cannot escape: ',latex_escape_atom(Atom,EscAtom)),
1310 EscAtom=Atom.
1311 latex_escape_atom(Atom,EscAtom) :-
1312 atom_codes(Atom,Codes), latex_escape_codes(Codes,ECodes), atom_codes(EscAtom,ECodes).
1313
1314 latex_escape_codes([],[]).
1315 %latex_escape_codes([92,C|T],[92,C|ET]) :- !, % already escaped
1316 % latex_escape_codes(T,ET).
1317 latex_escape_codes([C|T],[92,C|ET]) :- latex_escape_code(C),!, % 95 = _ underscore, 92 = \ backslash
1318 latex_escape_codes(T,ET).
1319 latex_escape_codes([Code|T],ET) :- translate_code(Code,String),
1320 !,
1321 append(String,ET2,ET),
1322 latex_escape_codes(T,ET2).
1323 latex_escape_codes([H|T],[H|ET]) :- latex_escape_codes(T,ET).
1324
1325 latex_escape_code(35). % #
1326 latex_escape_code(36). % $
1327 latex_escape_code(37). % %
1328 latex_escape_code(38). % &
1329 latex_escape_code(95). % 95 = _ underscore
1330 latex_escape_code(123). % {
1331 latex_escape_code(125). % }
1332
1333 translate_code(92,"\\textbackslash{}"). % \ % \textbackslash seems to work in both math and normal mode
1334 translate_code(94,"\\textasciicircum{}"). % ^
1335 translate_code(126,"\\textasciitilde{}"). % ~
1336 %translate_code(126,"\\~{}"). % 126 = ~ tilde -> \~{} (\sim would be alternative in math mode)
1337
1338 % ------------------------------
1339
1340 % encoding atoms for B Strings:
1341 % escape special characters so that we can output the string between quotes "..." and obtain a valid value
1342
1343 :- assert_must_succeed(tools:b_escape_string_atom('{"a"}','{\\"a\\"}')).
1344 :- assert_must_succeed(tools:b_escape_string_atom('{"a \\/ b"}','{\\"a \\/ b\\"}')).
1345
1346 b_escape_string_atom(Atom,EscAtom) :- \+ atom(Atom),!,
1347 add_internal_error('Cannot escape: ',b_escape_string_atom(Atom,EscAtom)),
1348 EscAtom=Atom.
1349 b_escape_string_atom(Atom,EscAtom) :-
1350 atom_codes(Atom,Codes), b_string_escape_codes(Codes,ECodes), atom_codes(EscAtom,ECodes).
1351
1352 b_string_escape_codes([],R) :- !, R=[].
1353 b_string_escape_codes([C|T],Res) :-
1354 (C=92, T=[C2|_], % 92 = \ backslash
1355 \+ valid_backslash_escape(C2) % we do not need to escape the \ in \x for example, but we need to escape in \n
1356 -> Res = [92|ET]
1357 ; b_escape_code(C,EC) -> Res = [92,EC|ET]
1358 ; Res = [C|ET]
1359 ),
1360 b_string_escape_codes(T,ET).
1361
1362 b_escape_code(9,116). % tab, 116 = t
1363 b_escape_code(10,110). % newline, 110 = n
1364 b_escape_code(13,114). % return 114 = r
1365 b_escape_code(34,34). % "
1366 %b_escape_code(39,39). % ' % not necessary for "..." literals
1367 b_escape_code(92,92). % \
1368
1369 % these are the escape codes the parser / ProB currently supports:
1370 valid_backslash_escape(34). % "
1371 valid_backslash_escape(39). % '
1372 valid_backslash_escape(92). % \
1373 valid_backslash_escape(110). %n
1374 valid_backslash_escape(114). %r
1375 valid_backslash_escape(116). %t
1376
1377 % ------------------------------
1378
1379
1380 %%
1381 % Escape is needed for &, \/, /\, ", ', etc.
1382 % used mainly for dot output
1383 % It seems dotty does not understand escapes, neither C style nor HTML style.
1384 % Dot does render '&' correctly, no matter of escape.
1385 %
1386
1387 print_escaped(Atom) :- string_escape(Atom,E), write(E).
1388
1389 :- use_module(library(lists), [
1390 maplist/3,
1391 scanlist/4]).
1392
1393 string_escape(Atom, EscapedAtom):-
1394 string_escape(dot_string_escape_map, Atom, EscapedAtom).
1395
1396
1397 string_escape(_,Number, EscapedAtom):-
1398 number(Number),!, number_chars(Number,C), atom_chars(EscapedAtom,C). % to detect when label=value
1399 string_escape(Map, Atom, EscapedAtom):-
1400 atom(Atom),
1401 atom_chars(Atom, Chars),
1402 maplist(Map, Chars, EscapedChars),
1403 scanlist(x_atom_concat_rev, EscapedChars, '', EscapedAtom),!.
1404 string_escape(Map,Term, EscapedTerm):-
1405 Term =.. [Fkt|Args],
1406 string_escape(Map, Fkt, EscapedFkt),
1407 maplist(string_escape(Map), Args, EscapedArgs),!,
1408 EscapedTerm =.. [EscapedFkt|EscapedArgs].
1409 string_escape(_,X,X).
1410
1411
1412 x_atom_concat_rev(A,B,BA):-
1413 atom_concat(B,A,BA).
1414
1415
1416 % simple escape, just ensuring no syntax errors and not disturbing records already constructed as B string,...
1417 % however, not that fields of records are already escaped
1418 simple_dot_string_escape(Number, EscapedAtom) :- number(Number),!,
1419 number_chars(Number,C), atom_chars(EscapedAtom,C).
1420 simple_dot_string_escape(Atom, EscapedAtom) :- atom(Atom),!,
1421 atom_chars(Atom,Chars),
1422 simple_dot_esc( Chars, EC), atom_chars(EscapedAtom,EC).
1423 simple_dot_string_escape(Atom,Res) :-
1424 add_internal_error('Not atomic: ',simple_dot_string_escape(Atom,Res)),
1425 Res=Atom.
1426
1427 simple_dot_esc([],[]).
1428 simple_dot_esc(['\\','"' | T],['\\','"' |TR]) :- !, % already escaped
1429 simple_dot_esc(T,TR).
1430 simple_dot_esc(['\\','\\' | T],['\\','\\' |TR]) :- !, % already escaped
1431 simple_dot_esc(T,TR).
1432 simple_dot_esc(['"' | T],['\\','"' |TR]) :- !,
1433 simple_dot_esc(T,TR).
1434 simple_dot_esc([H | T],[H|TR]) :-simple_dot_esc(T,TR).
1435
1436
1437 % ----------------
1438
1439
1440 % escape for XML attribute values for use in double quotes
1441 %https://stackoverflow.com/questions/19766669/which-characters-are-permitted-in-xml-attributes
1442 % AttValue ::= '"' ([^<&"] | Reference)* '"'
1443 % | "'" ([^<&'] | Reference)* "'"
1444
1445 xml_attribute_escape(Codes,EscapedCodes) :- xml_attr_escape(Codes,EscapedCodes,[]).
1446 xml_attr_escape([]) --> "".
1447 xml_attr_escape([0'&|T]) --> !, "&", xml_attr_escape(T).
1448 xml_attr_escape([0'<|T]) --> !, "<", xml_attr_escape(T).
1449 xml_attr_escape([0'>|T]) --> !, ">", xml_attr_escape(T). % strictly speaking not necessary for attribute values
1450 xml_attr_escape([10|T]) --> !, " ", xml_attr_escape(T). % newline
1451 xml_attr_escape([9|T]) --> !, " ", xml_attr_escape(T). % tab
1452 xml_attr_escape([0'"|T]) --> !, """, xml_attr_escape(T).
1453 xml_attr_escape([H|T]) --> [H], xml_attr_escape(T).
1454
1455 % ----------------
1456
1457 xml_escape(Number, EscapedAtom) :-
1458 number(Number),!, number_chars(Number,C), atom_chars(EscapedAtom,C).
1459 xml_escape(Atom, EscapedAtom) :-
1460 atom_codes(Atom,Codes),
1461 xml_escape_codes(Codes,ECodes),
1462 atom_codes(EscapedAtom,ECodes).
1463
1464 xml_escape_codes([],[]).
1465 xml_escape_codes([H|T],Res) :-
1466 xml_string_escape_map(H,NewCodes), !,
1467 append(NewCodes,TR,Res),
1468 xml_escape_codes(T,TR).
1469 xml_escape_codes([H|T],[H|TR]) :-
1470 xml_escape_codes(T,TR).
1471
1472 xml_string_escape_map(34,[38,113,117,111,116,59]) :- !. % " -> "
1473 xml_string_escape_map(38,[38,97,109,112,59]) :- !. % & -> &
1474 xml_string_escape_map(39,[38,97,112,111,115,59]) :- !. % ' -> '
1475 xml_string_escape_map(60,[38,108,116,59]) :- !. % < -> <
1476 xml_string_escape_map(62,[38,103,116,59]) :- !. % > -> >
1477
1478
1479 html_escape(Number, EscapedAtom) :-
1480 number(Number),!, number_chars(Number,C), atom_chars(EscapedAtom,C). % to detect when label=value
1481 html_escape(Atom, EscapedAtom) :-
1482 atom_codes(Atom,Codes),
1483 html_escape_codes(Codes,ECodes),
1484 atom_codes(EscapedAtom,ECodes).
1485 % atom_chars(Atom, Chars),
1486 % maplist(html_string_escape_map, Chars, EscapedChars),!,
1487 % scanlist(x_atom_concat_rev, EscapedChars, '', EscapedAtom). % very inefficient for large atoms
1488
1489
1490 html_escape_codes([],[]).
1491 html_escape_codes([H|T],Res) :-
1492 \+ no_escape_necessary(H), % avoid calling atom_codes
1493 atom_codes(Atom,[H]),
1494 html_string_escape_map(Atom,NewAtom), % TODO: rewrite html_escape map to work with codes
1495 !,
1496 atom_codes(NewAtom,NewCodes),
1497 append(NewCodes,TR,Res),
1498 html_escape_codes(T,TR).
1499 html_escape_codes([H|T],[H|TR]) :-
1500 html_escape_codes(T,TR).
1501
1502 no_escape_necessary(32).
1503 no_escape_necessary(40). % (
1504 no_escape_necessary(41). % )
1505 no_escape_necessary(44). % ,
1506 no_escape_necessary(45). % -
1507 no_escape_necessary(46). % .
1508 no_escape_necessary(61). % =
1509 no_escape_necessary(95).
1510 no_escape_necessary(X) :- (X>=97,X=<122) ; (X>=65, X=<90) ; (X>=48, X=<57). % alphadigit
1511
1512 dot_string_escape_map('\n', '\\n').
1513 dot_string_escape_map('\\', '\\\\').
1514 dot_string_escape_map('"', '\\"').
1515 dot_string_escape_map('\'', '\\\'').
1516 dot_string_escape_map('{', '\\{'). % important if used inside dot records
1517 dot_string_escape_map('}', '\\}'). % important if used inside dot records
1518 dot_string_escape_map('|', '\\|'). % important if used inside dot records
1519 dot_string_escape_map('>', '\\>'). % important if used inside dot records
1520 dot_string_escape_map('<', '\\<'). % important if used inside dot records
1521 dot_string_escape_map(A,B) :- x_string_escape_map(A,B).
1522
1523 html_string_escape_map('&', '&') :- !. % michael: habe diese 3 Zeilen auskommentiert
1524 html_string_escape_map('<', '<') :- !.
1525 html_string_escape_map('>', '>') :- !.
1526 html_string_escape_map('"', '"') :- !.
1527 html_string_escape_map(A,B) :- x_string_escape_map(A,B),!.
1528
1529
1530 % this is the SICSTus encoding for Unicode either \octal_number\ or \xHexNumber\
1531 % See Section 4.1.7.6 Escape Sequences in SICStus Manual (page 60)
1532 x_string_escape_map('\344\', 'ä'). % a mit Umlaut
1533 x_string_escape_map('\366\', 'ö'). % o mit Umlaut
1534 x_string_escape_map('\374\', 'ü'). % u mit Umlaut
1535 x_string_escape_map('\304\', 'Ä'). % A mit Umlaut
1536 x_string_escape_map('\326\', 'Ö'). % O mit Umlaut
1537 x_string_escape_map('\334\', 'Ü'). % U mit Umlaut
1538
1539 x_string_escape_map('\353\', 'ë'). % e mit Umlaut
1540 x_string_escape_map('\313\', 'Ë'). % E mit Umlaut
1541
1542 x_string_escape_map('\350\', 'è'). % e mit Accent
1543 x_string_escape_map('\351\', 'é').
1544 x_string_escape_map('\352\', 'ê').
1545 x_string_escape_map('\310\', 'È'). % E mit Accent
1546 x_string_escape_map('\311\', 'É').
1547 x_string_escape_map('\312\', 'Ê').
1548
1549 x_string_escape_map('\340\', 'à'). % a mit Accent
1550 x_string_escape_map('\341\', 'á').
1551 x_string_escape_map('\342\', 'â').
1552 x_string_escape_map('\300\', 'À'). % A mit Accent
1553 x_string_escape_map('\301\', 'Á').
1554 x_string_escape_map('\302\', 'Â').
1555
1556 x_string_escape_map('\354\', 'ì'). % i mit Accent
1557 x_string_escape_map('\355\', 'í').
1558 x_string_escape_map('\356\', 'î').
1559 x_string_escape_map('\314\', 'Ì'). % I mit Accent
1560 x_string_escape_map('\315\', 'Í').
1561 x_string_escape_map('\316\', 'Î').
1562
1563 x_string_escape_map('\362\', 'ò'). % o mit Accent
1564 x_string_escape_map('\363\', 'ó').
1565 x_string_escape_map('\364\', 'ô').
1566 x_string_escape_map('\322\', 'Ò'). % O mit Accent
1567 x_string_escape_map('\323\', 'Ó').
1568 x_string_escape_map('\324\', 'Ô').
1569
1570 x_string_escape_map('\347\', 'ç'). % cedille
1571 x_string_escape_map('\307\', 'Ç'). % Cedille
1572
1573 x_string_escape_map('\337\', 'ß'). % scharfes S (sz)
1574 x_string_escape_map('\361\', 'ñ'). % n with tilde
1575
1576 x_string_escape_map('\1661\', 'α'). % Greek
1577 x_string_escape_map('\1662\', 'β').
1578 x_string_escape_map('\1663\', 'γ').
1579 x_string_escape_map('\1664\', 'δ').
1580 x_string_escape_map('\1665\', 'ε').
1581 x_string_escape_map('\1666\', 'ζ').
1582 x_string_escape_map('\1667\', 'η').
1583 x_string_escape_map('\1670\', 'θ').
1584 x_string_escape_map('\1671\', 'ι').
1585 x_string_escape_map('\1672\', 'κ').
1586 x_string_escape_map('\1673\', 'λ').
1587 x_string_escape_map('\1674\', 'μ').
1588 x_string_escape_map('\1675\', 'ν').
1589 x_string_escape_map('\1676\', 'ξ').
1590 x_string_escape_map('\1677\', 'ο').
1591 x_string_escape_map('\1700\', 'π').
1592 x_string_escape_map('\1701\', 'ρ').
1593 x_string_escape_map('\1702\', 'ς').
1594 x_string_escape_map('\1703\', 'σ').
1595 x_string_escape_map('\1704\', 'τ').
1596 x_string_escape_map('\1705\', 'υ').
1597 x_string_escape_map('\1706\', 'φ').
1598 x_string_escape_map('\1707\', 'χ').
1599 x_string_escape_map('\1710\', 'ψ').
1600 x_string_escape_map('\1711\', 'ω').
1601
1602 % to do: add missing upper-case Greek letters:
1603 x_string_escape_map('\1624\', 'Δ').
1604 x_string_escape_map('\1630\', 'Θ').
1605 x_string_escape_map('\1633\', 'Λ').
1606 x_string_escape_map('\1636\', 'Ξ').
1607 x_string_escape_map('\1645\', 'Υ').
1608 x_string_escape_map('\1647\', 'Χ').
1609 x_string_escape_map('\1650\', 'Ψ').
1610 x_string_escape_map('\1651\', 'Ω').
1611
1612 % other symbols (converted using http://www.online-toolz.com/tools/unicode-html-entities-convertor.php )
1613 x_string_escape_map('\21242\','⊢'). %vdash turnstyle decimal: 8866
1614 x_string_escape_map('\21250\','⊨'). %models turnstyle decimal: 8872
1615 x_string_escape_map('\x21D4\','⇔'). % equivalence
1616 x_string_escape_map('\x21D2\','⇒'). % implication
1617 x_string_escape_map('\x2203\','∃'). % exists
1618 x_string_escape_map('\x2200\','∀'). % forall
1619 x_string_escape_map('ยท','·'). % dot used for quantifiers, ASCII 183
1620 x_string_escape_map('\x2227\','∧'). % conjunct
1621 x_string_escape_map('\x2228\','∨'). % disjunct
1622 x_string_escape_map('\xAC\','¬'). % negation
1623 x_string_escape_map('\x21A6\','↦'). % maplet |->
1624 x_string_escape_map('\x2286\','⊆'). % <: subseteq
1625 x_string_escape_map('\x222A\','∪'). % union
1626 x_string_escape_map('\x2229\','∩'). % intersection
1627 x_string_escape_map('\x2205\','∅'). % empty set
1628 x_string_escape_map('\x2260\','≠'). % not equal
1629 x_string_escape_map('\x2264\','≤'). % less equal
1630 x_string_escape_map('\x2265\','≥'). % greater equal
1631 x_string_escape_map('\x2124\','ℤ'). % Z (INTEGER)
1632 x_string_escape_map('\x2115\','ℕ'). % NATURAL
1633
1634 % Numbers without HTML translation: .. 8229
1635
1636 % translate unknown unicode chars to lozenge
1637 x_string_escape_map(Unicode, Result) :- atom(Unicode),
1638 atom_codes(Unicode,[Nr]), Nr>127,
1639 !,
1640 ajoin(['&#',Nr,';'],Result).
1641 %x_string_escape_map(Unicode, '◊') :-
1642 % atom(Unicode), atom_codes(Unicode,[Code]), Code>127.
1643 % format(user_output,'Uni: ~w ~n',[Unicode]).
1644 x_string_escape_map(X, X).
1645
1646 %
1647 % split_list(Pred,List,ListA,ListB):
1648 % List contains exactly the same elements as ListA and ListB
1649 % An element E is member of ListA iff Pred(E) is true and E is element of List.
1650 % An element E is member of ListB iff Pred(E) is false and E is element of List.
1651 % combination of include/exclude from library(lists) (include_exclude)
1652 :- assert_must_succeed(( split_list(number,[1,a,2,b],S,F), S==[1,2], F==[a,b] )).
1653 split_list(Pred,List,A,B) :-
1654 split_list2(List,Pred,A,B).
1655 split_list2([],_Pred,[],[]).
1656 split_list2([Elem|Rest],Pred,A,B) :-
1657 ? ( call(Pred,Elem) -> A=[Elem|AR], B=BR
1658 ; A=AR, B=[Elem|BR]),
1659 split_list2(Rest,Pred,AR,BR).
1660
1661
1662 :- assert_must_succeed(( map_split_list(just_for_unit_test_add(0),[1,2,3],S,F), S==[10,20,30], F==[] )).
1663 % like map_list but put unsuccessful elements in a second list
1664 map_split_list(Pred,List,A,B) :-
1665 map_split_list2(List,Pred,A,B).
1666 map_split_list2([],_Pred,[],[]).
1667 map_split_list2([Elem|Rest],Pred,A,B) :-
1668 ( call(Pred,Elem,Res) -> A=[Res|AR], B=BR
1669 ; A=AR, B=[Elem|BR]),
1670 map_split_list2(Rest,Pred,AR,BR).
1671
1672 % a variation of split_list which also returns a list of predicate results
1673 % with re_split_list_idx(L,PredResult,A,B) : we can split another list using the same pattern
1674 split_list_idx(Pred,List,PredResult,A,B) :-
1675 split_list_idx2(List,Pred,PredResult,A,B).
1676 split_list_idx2([],_Pred,[],[],[]).
1677 split_list_idx2([Elem|Rest],Pred,[PredTrue|PT],A,B) :-
1678 (call(Pred,Elem) -> PredTrue=true, A=[Elem|AR], B=BR
1679 ; PredTrue=false, A=AR, B=[Elem|BR]),
1680 split_list_idx2(Rest,Pred,PT,AR,BR).
1681
1682
1683 re_split_list_idx([],[],[],[]).
1684 re_split_list_idx([Elem|Rest],[PredTrue|PT],A,B) :-
1685 (PredTrue=true -> A=[Elem|AR], B=BR
1686 ; A=AR, B=[Elem|BR]),
1687 re_split_list_idx(Rest,PT,AR,BR).
1688
1689
1690
1691 % try and avoid going through same transitions twice
1692 % works with simple transition ids, or with atom/3 entries from ltl model_checker
1693 :- assert_must_succeed((minimize_lasso([0,1,2,4,8,14,7,12],[15,4,8,14,7,12],P,L),
1694 P==[0,1,2], L==[4,8,14,7,12,15])).
1695 minimize_lasso(Prefix,Loop,NewPrefix,NewLoop) :- reverse(Prefix,RP), reverse(Loop,RL),
1696 common_prefix(RP,RL,Common,RestP,RestLoop),
1697 append(RestLoop,Common,NewLR), reverse(NewLR,NewLoop),
1698 reverse(RestP,NewPrefix).
1699 common_prefix([H|T1],[H|T2],[H|Res],Rest1,Rest2) :- !, common_prefix(T1,T2,Res,Rest1,Rest2).
1700 common_prefix(T1,T2,[],T1,T2).
1701
1702
1703
1704 just_for_unit_test_add(A,B,C) :- C is A+(10*B).
1705 :- assert_must_succeed(( foldl(just_for_unit_test_add,[],0,R), R==0 )).
1706 :- assert_must_succeed(( foldl(just_for_unit_test_add,[3,6,7,2,6],0,R), R==36726 )).
1707
1708 foldl(MPred,List,Start,Result) :-
1709 foldl2(List,MPred,Start,Result).
1710 foldl2([],_Pred,Value,Value).
1711 foldl2([Elem|Rest],MPred,OldValue,NewValue) :-
1712 call(MPred,Elem,OldValue,Value),
1713 foldl2(Rest,MPred,Value,NewValue).
1714
1715
1716 just_for_unit_test_add2(A,B,C,D) :- D is 100*C+10*A+B.
1717 :- assert_must_succeed(( foldl(just_for_unit_test_add2,[],[],0,R), R==0 )).
1718 :- assert_must_succeed(( foldl(just_for_unit_test_add2,[3,6,7,2,6],[5,2,9,0,8],0,R), R==3562792068 )).
1719
1720 foldl(MPred,List,List1,Start,Result) :-
1721 foldl2(List,MPred,List1,Start,Result).
1722 foldl2([],_Pred,[],Value,Value).
1723 foldl2([Elem|Rest],MPred,[H1|R1],OldValue,NewValue) :-
1724 call(MPred,Elem,H1,OldValue,Value),
1725 foldl2(Rest,MPred,R1,Value,NewValue).
1726
1727
1728 just_for_unit_test_add3(A,B,C,D,E) :- E is D*1000+100*A+10*B+C.
1729 :- assert_must_succeed(( foldl(just_for_unit_test_add3,[],[],[],0,R), R==0 )).
1730 :- assert_must_succeed(( foldl(just_for_unit_test_add3,[3,6,7],[5,2,9],[4,1,0],0,R),
1731 R==354621790 )).
1732
1733 foldl(MPred,A,B,C,Start,Result) :-
1734 foldl2(A,MPred,B,C,Start,Result).
1735 foldl2([],_Pred,[],[],Value,Value).
1736 foldl2([Elem|Rest],MPred,[H1|R1],[H2|R2],OldValue,NewValue) :-
1737 call(MPred,Elem,H1,H2,OldValue,Value),
1738 foldl2(Rest,MPred,R1,R2,Value,NewValue).
1739
1740
1741 :- assert_must_succeed(( maplist5(just_for_unit_test_add2,[],[],[],R), R==[] )).
1742 :- assert_must_succeed(( maplist5(just_for_unit_test_add2,[1],[2],[3],R), R==[312] )).
1743 :- assert_must_succeed(( maplist5(just_for_unit_test_add2,[1,1],[2,0],[3,0],R), R==[312,10] )).
1744
1745 maplist5(_P,[],[],[],[]).
1746 maplist5(P,[H1|T1],[H2|T2],[H3|T3],[H4|T4]) :-
1747 if(call(P,H1,H2,H3,H4),
1748 ? maplist5(P,T1,T2,T3,T4),
1749 (add_internal_error('Call fails: ',maplist5(P,H1,H2,H3,H4)),
1750 fail)).
1751
1752
1753 :- assert_must_succeed(( average([2,4,8,10],Avg), D is abs(Avg-6),D<0.001 )).
1754 :- assert_must_succeed(( average([2],Avg), D is abs(Avg-2), D<0.001 )).
1755 average(List,Avg) :-
1756 length(List,N),sumlist(List,Sum),Avg is Sum/N.
1757
1758
1759 % assert_once works like assertz, but checks if the fact has already been stored before and
1760 % will not store it a second time
1761 assert_once(MPredicate) :-
1762 (call(MPredicate) -> true ; assertz(MPredicate)).
1763
1764
1765
1766 :- dynamic id_counter/1.
1767 unique_id(Prefix,Id) :-
1768 (id_counter(V) -> retractall(id_counter(_)) ; V is 0),
1769 N is V+1,
1770 assertz( id_counter(N) ),
1771 number_codes(N,NCodes),
1772 append(Prefix,NCodes,ICodes),
1773 atom_codes(Id,ICodes).
1774
1775 % PROBPATH is the runtime search path for defintion files not found relative to the original machine.
1776 % By default this is the stdlib directory relative to the prob base dir.
1777 % The user can provide a list of : separated directories in the PROBPATH
1778 % environment variables which are prepended to the default path.
1779 get_PROBPATH(PROBPATH) :-
1780 environ('PROBPATH', CustomPATH),
1781 atom_length(CustomPATH, L),
1782 L > 0, !,
1783 get_path_separator(PS),
1784 get_stdlib_path(STDLIB), ajoin([CustomPATH, PS, STDLIB], PROBPATH).
1785
1786 get_PROBPATH(PROBPATH) :- get_stdlib_path(PROBPATH).
1787
1788 get_stdlib_path(STDLIB) :- runtime_application_path(Base), atom_concat(Base, '/stdlib', STDLIB).
1789
1790 % Platform specific path separator char
1791 map_path_separator(windows, ';').
1792 map_path_separator(_, ':').
1793
1794 get_path_separator(PS) :- host_platform(Platform), map_path_separator(Platform, PS), !.
1795
1796 %% atom_to_number(?Atom, ?Number).
1797 atom_to_number(Atom, Number) :-
1798 atom(Atom),
1799 catch((
1800 atom_codes(Atom, Codes),
1801 number_codes(Number, Codes)
1802 ), _, fail).
1803 atom_to_number(Atom, Number) :-
1804 number(Number),
1805 number_codes(Number, Codes),
1806 atom_codes(Atom, Codes).
1807
1808 % ----------
1809
1810 % useful for e.g. SWI Prolog where redefine_warnings is not defined
1811 get_set_optional_prolog_flag(Flag,Old,New) :-
1812 (catch(current_prolog_flag(Flag, Old), error(domain_error(_, _), _), fail) ->
1813 set_prolog_flag(Flag, New)
1814 ;
1815 current_prolog_flag(dialect, Prolog),
1816 format('Prolog flag ~w not supported on ~w~n', [Flag, Prolog])
1817 ).
1818
1819
1820 % ----------
1821
1822 % predicates for lists with optional items represented using optional_value(V,pred_true/pred_false)
1823 % we assume that optional values constructors (optional_value/2) are instantiated *before* calling maplist_optional
1824
1825 ?map_optlist(Pred,List) :- map_optlist_aux(List,Pred).
1826
1827 :- block map_optlist_aux(-,?).
1828 map_optlist_aux([],_) :- !.
1829 map_optlist_aux([H|T],Pred) :- !,
1830 ? call_optional(Pred,H),
1831 ? map_optlist_aux(T,Pred).
1832 map_optlist_aux(Other,Pred) :-
1833 add_internal_error('First argument not a list:',map_optlist_aux(Other,Pred)).
1834
1835 call_optional(Pred,OptVal) :-
1836 is_optional_value(OptVal,Val,Use),
1837 !,
1838 call_optional_aux(Use,Pred,Val).
1839 ?call_optional(Pred,Val) :- call(Pred,Val).
1840
1841 :- block call_optional_aux(-,?,?).
1842 call_optional_aux(pred_true,Pred,Val) :- !, call(Pred,Val).
1843 call_optional_aux(pred_false,_,_) :- !. % ignore optional item
1844 call_optional_aux(Other,Pred,_) :-
1845 add_internal_error('First argument not a BOOL:',call_optional_aux(Other,Pred)).
1846
1847 :- block optlist_to_list(-,?).
1848 optlist_to_list([],R) :- !, R=[].
1849 optlist_to_list([OptVal|T],R) :- !,
1850 (is_optional_value(OptVal,Val,Use)
1851 -> optlist_to_list_aux(Use,Val,T,R)
1852 ; R = [OptVal|RT], optlist_to_list(T,RT)
1853 ).
1854 optlist_to_list(Other,R) :-
1855 add_internal_error('First argument not a list:',optlist_to_list(Other,R)),
1856 R=Other.
1857
1858 :- block optlist_to_list_aux(-,?,?,?).
1859 optlist_to_list_aux(pred_true,Val,T,[Val|TR]) :- !, optlist_to_list(T,TR).
1860 optlist_to_list_aux(pred_false,_,T,R) :- !, optlist_to_list(T,R).
1861 optlist_to_list_aux(Other,V,T,R) :-
1862 add_internal_error('First argument not a BOOL:',optlist_to_list_aux(Other,V,T,R)),
1863 fail.
1864
1865 is_optional_value(OptVal,Val,Use) :- nonvar(OptVal), OptVal = optional_value(Val,Use).
1866
1867 % ---------
1868
1869 % blackboard utilities
1870
1871
1872 bb_safe_get(Counter,R) :- (bb_get(Counter,X) -> R=X ; R=0).
1873
1874 bb_inc(Counter) :- bb_inc_by(Counter,1).
1875
1876 bb_inc_by(Counter,Inc) :-
1877 bb_safe_get(Counter,R),
1878 R1 is R+Inc, bb_put(Counter,R1).
1879
1880
1881 % ---------
1882
1883
1884 :- if(current_prolog_flag(dialect, swi)).
1885
1886 :- use_module(library(ugraphs),[top_sort/2]).
1887
1888 % this version fails if there are cycles and cannot report the number of unsorted nodes:
1889 top_sort(Graph,Sorted,UnsortedNr) :- top_sort(Graph, Sorted), UnsortedNr=0.
1890
1891 % disable code below currently for SWI, as top_sort below calls internal predicate of ugraphs: fanin_counts
1892 :- else.
1893 :- use_module(library(avl),[ord_list_to_avl/2]).
1894
1895 % a slight variation of top_sort from library(ugraphs) which allows the sorting to be not completed
1896 % top_sort(G,S,0) corresponds to top_sort in ugraphs
1897 top_sort(Graph,Sorted,UnsortedNr) :-
1898 ugraphs:fanin_counts(Graph, Counts),
1899 ugraphs:get_top_elements(Counts, Top, 0, I),
1900 ord_list_to_avl(Counts, Map),
1901 top_sort_aux(Top, I, Map, Sorted,UnsortedNr).
1902
1903 top_sort_aux([], I, _, [], UnsortedNr) :- UnsortedNr = I.
1904 top_sort_aux([V-VN|Top0], I, Map0, [V|Sorted],UnsortedNr) :-
1905 ugraphs:dec_counts(VN, I, J, Map0, Map, Top0, Top),
1906 top_sort_aux(Top, J, Map, Sorted,UnsortedNr).
1907 :- endif.