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