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 :- module(tools_meta,[safe_time_out/3,
6 safe_time_out_or_virtual_time_out/3,
7 no_time_out_value/1,
8 call_residue/2,
9 residue_has_only_clpfd_in_constraints/1,
10 safe_on_exception/3, safe_on_exception_silent/3,
11 reraise_important_exception/1,
12 det_call_cleanup/2,
13 frozen_member/2,
14 catch_matching/3,
15 safe_numbervars/3,
16 translate_term_into_atom/2,
17 translate_term_into_atom_with_max_depth/2, translate_term_into_atom_with_max_depth/3,
18 setof4/4
19 ]).
20
21 :- use_module(module_information).
22
23 :- meta_predicate safe_time_out(0,*,*).
24 :- meta_predicate setof4(*,*,0,*).
25
26 :- module_info(group,infrastructure).
27 :- module_info(description,'A utility on timeouts safe_time_out seperated out from tools.pl to avoid cyclic module dependencies.').
28
29 no_time_out_value(2147483646). % special value to turn time_out off
30
31 :- use_module(library(timeout),[time_out/3]).
32 safe_time_out(Call,TO,Res) :- \+ integer(TO),!,
33 print('### Warning: TIME_OUT value not an integer: '), print(TO),nl,
34 ITO is round(TO),
35 safe_time_out(Call,ITO,Res).
36 safe_time_out(Call,TO,Res) :-
37 % unsat cores used to set time_out to float; SICStus time_out/3 silently fails with float
38 no_time_out_value(MaxTO),
39 (TO >= MaxTO
40 -> (TO=MaxTO -> true % special value to turn time_out off (set by -disable_time_out); time_out has an overhead
41 ; print('### Warning: TIME_OUT value too high (>2147483646): '), print(TO),nl,
42 print('### Calling goal without TIME_OUT (use 2147483646 to turn TIME_OUT off silently)'),nl),
43 call(Call), Res=success
44 ; TO < 1 -> print('### Warning: TIME_OUT value too small: '), print(TO),nl,
45 time_out(Call,1,Res)
46 ? ; time_out(Call,TO,Res)).
47
48 :- meta_predicate safe_time_out_or_virtual_time_out(0,*,*).
49 % catches virtual-time_out exceptions and returns them as normal time_out result
50 safe_time_out_or_virtual_time_out(Call,TO,Res) :-
51 catch(safe_time_out(Call,TO,Res), enumeration_warning(_,_,_,_,_), Res=time_out).
52
53 :- meta_predicate call_residue(0,*).
54
55
56
57 % If possible, call frozen/2 on the entire list of variables at once.
58 % This is possible on SICStus 4.6 and later as well as SWI,
59 % where frozen/2 can be called on any term
60 % to get the goals for all attributed variables in that term.
61 % On SICStus 4.5 and older, Ciao, and YAP (and possibly others),
62 % frozen/2 can only be called directly on a variable.
63 % In that case we need to manually iterate over the residual variables
64 % and call frozen/2 on each one.
65 :- if(catch((dif(X,Y), frozen([X,Y],_)), _, false)).
66
67 ?call_residue(X,Residue) :- call_residue_vars(X,V),
68 frozen(V,R),
69 %(R=true -> Residue=[] ; Residue = [R]).
70 flatten_conj(R,Residue,[]).
71
72 flatten_conj(true) --> !,[].
73 flatten_conj((A,B)) --> !, flatten_conj(A), flatten_conj(B).
74 flatten_conj(C) --> [C].
75
76 :- else.
77
78 /* from File: sp4_compatibility_mappings.pl */
79 /* Created: 08/05/2007 by Michael Leuschel */
80 call_residue(X,Residue) :- call_residue_vars(X,V),filter_residue_vars(V,Residue).
81
82 filter_residue_vars([],[]).
83 filter_residue_vars([H|T],Res) :-
84 frozen(H,FH),
85 (FH=true -> Res=RT
86 ; %format('Residue for variable ~w: ~w~n',[H,FH]),
87 Res = [FH|RT]),
88 filter_residue_vars(T,RT).
89
90 :- endif.
91
92 % residue only has clpfd: X in Y constraints
93 residue_has_only_clpfd_in_constraints([]).
94 residue_has_only_clpfd_in_constraints([clpfd:in(_,_)|T]) :-
95 residue_has_only_clpfd_in_constraints(T).
96
97 % --------------------------
98
99 :- meta_predicate safe_on_exception(*,0,0).
100 % use if you want to catch any exception; ensures time_out not treated and passed on
101 safe_on_exception(E,Call,ExcCode) :-
102 catch(call(Call), E, (
103 print(exception(E)),nl,
104 reraise_important_exception(E),
105 ExcCode
106 )).
107 :- meta_predicate safe_on_exception_silent(*,0,0).
108 safe_on_exception_silent(E,Call,ExcCode) :-
109 catch(call(Call), E, (
110 reraise_important_exception(E),
111 ExcCode
112 )).
113
114 % reraise important exceptions
115 reraise_important_exception(time_out) :- !, throw(time_out).
116 reraise_important_exception(_).
117
118 % --------------------------
119
120
121 :- meta_predicate det_call_cleanup(0,0).
122 % a simplified version of call_cleanup; only really works for deterministic predicates
123 % or if it is ok to call CleanUpCall multiple times on success of Call
124 % is much faster, as call_cleanup has an overhead of about 300 Prolog instructions
125 % but this seems even slower ?? add_transitions__with_timeout_fail_loop
126
127 det_call_cleanup(Call,CleanUpCall) :-
128 catch(
129 if(Call,CleanUpCall,CleanUpCall),
130 E,
131 (CleanUpCall, throw(E))).
132
133 % --------------------------
134
135 %:- meta_predicate frozen_member(*,0). % without meta_predicate we can call frozen_member with a variable for Goal
136 % check if Goal is attached as a pending co-routine to Var
137 frozen_member(Var,Goal) :- var(Var), frozen(Var,Frozen),
138 frozen_mem_aux(Frozen,Goal).
139
140 frozen_mem_aux((A,B),Goal) :- !, (frozen_mem_aux(A,Goal) ; frozen_mem_aux(B,Goal)).
141 frozen_mem_aux(Goal,Goal).
142
143
144 % --------------------------
145
146 % like catch/3, but it does not fail if an exception occurs that is not
147 % unifiable with the second argument. Instead it re-throws the original
148 % exception.
149 :- meta_predicate catch_matching(0,*,0).
150 catch_matching(Call,Exception,Handler) :-
151 catch(Call, E, (E=Exception -> Handler ; throw(E))).
152
153 % --------------------------
154
155 safe_numbervars(Term,Start,End) :-
156 catch(numbervars(Term,Start,End), E, (
157 print('Exception during numbervars: '),print(E),nl,nl,
158 reraise_important_exception(E)
159 )).
160
161 % --------------------------
162
163
164 :- use_module(library(codesio), [write_term_to_codes/3]).
165 translate_term_into_atom(CTerm,Atom) :- atom(CTerm),!, Atom=CTerm.
166 translate_term_into_atom(Nr,Atom) :- number(Nr),!, number_codes(Nr,C), atom_codes(Atom,C).
167 translate_term_into_atom(CTerm,Atom) :-
168 copy_term(CTerm,Term), safe_numbervars(Term,0,_),
169 write_term_to_codes(Term,Temp,[quoted(true),numbervars(true)]),
170 atom_codes(Atom,Temp).
171 translate_term_into_atom_with_max_depth(Term,Atom) :-
172 translate_term_into_atom_with_max_depth(Term,20,Atom).
173 translate_term_into_atom_with_max_depth(Term,_,Atom) :- atomic(Term),!,Atom=Term.
174 translate_term_into_atom_with_max_depth(Term,Limit,Atom) :-
175 write_term_to_codes(Term,Temp,[quoted(true),numbervars(true),max_depth(Limit)]),
176 atom_codes(Atom,Temp).
177
178 % --------------------------
179
180 % a re-implementation of setof to overcome issue that
181 % the order of solutions of setof in SICStus was different on Intel and Arm platforms (cf test 1033)
182
183 setof4(DynamicPart,StaticPart,P,DynamicSolutions) :-
184 % first find all solutions
185 findall(sol(StaticPart,DynamicPart),
186 call(P), SolList),
187 sort(SolList,SList),
188 % now extract static parts and for each static part a list of all dynamic solutions
189 ? get_merged_solution(SList,StaticPart,DynamicSolutions).
190
191
192
193 % extract solutions in a set_of style manner
194 get_merged_solution([sol(StaticPart1,Sol1)|T],StaticPart,MergedSols) :-
195 merge_sols(T,StaticPart1,TSol,Rest), % get all solutions with same static part
196 (StaticPart=StaticPart1, MergedSols = [Sol1|TSol]
197 ;
198 ? get_merged_solution(Rest,StaticPart,MergedSols)).
199
200 % get all solutions with same staticPart and return tail of list
201 merge_sols([sol(StaticPart,Sol)|TS],StaticPart,[Sol|TSol],Rest) :- !,
202 merge_sols(TS,StaticPart,TSol,Rest).
203 merge_sols(Rest,_,[],Rest).