1% BEGIN LICENSE BLOCK
2% Version: CMPL 1.1
3%
4% The contents of this file are subject to the Cisco-style Mozilla Public
5% License Version 1.1 (the "License"); you may not use this file except
6% in compliance with the License.  You may obtain a copy of the License
7% at www.eclipse-clp.org/license.
8%
9% Software distributed under the License is distributed on an "AS IS"
10% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
11% the License for the specific language governing rights and limitations
12% under the License.
13%
14% The Original Code is  The ECLiPSe Constraint Logic Programming System.
15% The Initial Developer of the Original Code is  Cisco Systems, Inc.
16% Portions created by the Initial Developer are
17% Copyright (C) 1994-2006 Cisco Systems, Inc.  All Rights Reserved.
18%
19% Contributor(s): ECRC GmbH.
20%
21% END LICENSE BLOCK
22
23%
24% Predicates for pasing values to Tk and displaying.
25%
26
27:- begin_module(grace).
28:- call(lib(fd)).
29
30el_to_const(I, S, 1) :-
31    atomic(I),
32    !,
33    (I = dummy_var ->
34	S = ""
35    ;
36	S = I
37    ).
38el_to_const(V, S, Size) :-
39    true,
40    meta(V),
41    dvar_dest(V, D, Size),
42    part_dom_to_const(D, S).
43
44:- mode int_to_const(+, -).
45int_to_const(I, I) :-
46    integer(I).
47int_to_const(A..B, C) :-
48    concat_string([A, .., B], C).
49
50:- mode int_to_const(+, ?, ?).
51int_to_const(I) -->
52    {integer(I)},
53    [I].
54int_to_const(A..B) -->
55    {concat_string([A, .., B], S)},
56    [S].
57
58:- mode part_dom_to_const(++, -).
59part_dom_to_const(N, N) :-
60    integer(N).
61part_dom_to_const(D, S) :-
62    compound(D),
63    term_string(D, SL),
64    string_length(SL, L),
65    L2 is L - 2,
66    substring(SL, 2, L2, S).		% remove the list brackets
67
68const_to_el("", _) :- !.
69const_to_el(I, [I]) :-
70    integer(I),
71    !.
72const_to_el(String, List) :-
73    term_string(T, String),
74    comma_to_list(T, List).
75
76comma_to_list((A,B), [A|L]) :-
77    !,
78    comma_to_list(B, L).
79comma_to_list(A, [A]).
80
81make_tcl_list(From, HowMany, String) :-
82    make_label_list(From, HowMany, List),
83    concat_string([' {'|List], String).
84
85delay lazy_list(_, L) if var(L).
86lazy_list(_, []).
87lazy_list(N, [N|L]) :-
88    N1 is N + 1,
89    lazy_list(N1, L).
90
91make_label_list(I, 1, [I, '} ']) :- !.
92make_label_list(I, N, [I, ' '|L]) :-
93    I1 is I + 1,
94    N1 is N - 1,
95    make_label_list(I1, N1, L).
96
97dvar_domlist(Var, String) :-
98    Var :: DomList,
99    intervals_to_list(DomList, IList),
100    tcl_string(IList, String).
101
102intervals_to_list([], []).
103intervals_to_list([A..B|L], [[A,B]|L1]) :-
104    !,
105    intervals_to_list(L, L1).
106intervals_to_list([A|L], [A|L1]) :-
107    intervals_to_list(L, L1).
108
109list_to_tcl(List, String) :-
110    add_spaces(List, SpList),
111    concat_string([' {'|SpList], String).
112
113add_spaces([], ['} ']).
114add_spaces([H|T], [H, ' '|L]) :-
115    add_spaces(T, L).
116
117goals_to_tcl(Goals, TclList) :-
118    open(_, string, S),
119    printf(S, "{", []),
120    goals_to_strings(S, Goals),
121    get_stream_info(S, name, TclList),
122    close(S).
123
124goals_to_strings(S, []) :-
125    printf(S, "}", []).
126goals_to_strings(S, [Goal|L]) :-
127    our_goal(Goal),
128    !,
129    goals_to_strings(S, L).
130goals_to_strings(S, [Goal|L]) :-
131    printf(S, " \"%GDmw\"", [Goal]),
132    goals_to_strings(S, L).
133
134goal_to_string(Goal, String) :-
135    open(_, string, S),
136    printf(S, "%GDmw", [Goal]),
137    get_stream_info(S, name, String),
138    close(S).
139
140dvar_dest(Var, D, Size) :-
141    dvar_domain(Var, dom(D, Size)).
142
143% convert a domain to list of interval pairs
144var_domain_list(Var, IList) :-
145    dvar_dest(Var, D, _),
146    interval_list(D, IList).
147
148interval_list([], ['}']).
149interval_list([A..B|L], [S|IL]) :-
150    !,
151    concat_string(['{', A, ' ', B, '} '], S),
152    interval_list(L, IL).
153interval_list([I|L], [S|IL]) :-
154    (integer(I) ->
155        concat_string([I, ' '], S)
156     ; S = ' '
157    ),
158    interval_list(L, IL).
159
160%
161% Make a difference of two domain variables in a form which
162% can be passed to Tk for colored display.
163%
164domain_difference(Var, EV, List, Link) :-
165    dvar_domain(Var, DO),
166    dvar_domain(EV, DN),
167    (dom_difference(DO, DN, DomDif, _) ->
168	sorted_list_to_dom(NewL, DN),
169	sorted_list_to_dom(DifL, DomDif),
170	merge_difs(NewL, DifL, List, Link)
171    ;
172	% they are equal
173	List = [Const, '" "'|Link],
174	el_to_const(Var, Const1, _),
175	(substring(Const1, " ", _) ->
176	    remove_spaces(Const1, Const)
177	;
178	    Const = Const1
179	)
180    ).
181
182merge_difs(New, Dif, List, Link) :-
183    merge_difs(New, Dif, [""|NL], NL, List, Link).
184
185merge_difs([], [], N, []) -->
186    !,
187    empty_new(N).
188merge_difs([New|LN], [], N, NL) -->
189    !,
190    {int_to_const(New, C)},
191    ({LN = []} ->
192	{NL = [C|NL1]}
193    ;
194	{NL = [C, ','|NL1]}
195    ),
196    merge_difs(LN, [], N, NL1).
197merge_difs([], [Dif|LD], N, []) -->
198    !,
199    empty_new(N),
200    int_to_const(Dif),
201    ({LD = []} ->
202	{true}
203    ;
204	merge_difs([], LD, [','|NL1], NL1)
205    ).
206merge_difs([New|LN], [Dif|LD], N, NL) -->
207    ({before(New, Dif)} ->
208	{int_to_const(New, C),
209	NL = [C, ','|NL1]},
210	merge_difs(LN, [Dif|LD], N, NL1)
211    ;
212	{NL = []},
213	empty_new(N),
214	int_to_const(Dif),
215	merge_difs([New|LN], LD, [','|NL1], NL1)
216    ).
217
218empty_new([]) -->
219    {true}.
220empty_new([""]) -->
221    !,
222    ['{} '].
223empty_new(N) -->
224    {concat_string(N, S)},
225    [S].
226
227before(New, Dif) :-
228    integer(New),
229    (Dif = A.._ ->
230	New < A
231    ;
232	New < Dif
233    ).
234before(_..B, Dif) :-
235    (Dif = A.._ ->
236	B < A
237    ;
238	B < Dif
239    ).
240
241%
242% Convert a goal to a Tcl list in the node format
243%
244goal_to_node(Index, String) :-
245    goal_format(Index, Goal, RealExit),
246    gfunctor(Goal, F, A),
247    (gfunctor(RealExit, F, A) ->
248	Exit = RealExit
249    ;
250	printf("goal %d: %w has exit %w\n%b", [Index, Goal, RealExit]),
251	Exit = Goal
252    ),
253    decompose_expr(Goal, List1, Vars),
254    sumnodes(vars, Exit, EV, []),
255    (length(Vars) =:= length(EV) ->
256	EVars = EV
257    ;
258	% Some variables have been instantiated; we have to
259	% find the corresponding terms by simultaneous lookup
260    vars_from(Goal, Exit, EVars, []) ->
261	true
262    ;
263	printf("cannot match %mw and %mw\n%b", [Goal, Exit]),
264	EVars = EV
265    ),
266    %printf("difference %mw -> %mw\n%b", [Vars, EVars]),
267    start_with_nonvar(List1, List2),
268    goal_domains(List2, EVars, List3),
269    list_to_tcl(List3, String).
270
271goal_modified(Index) :-
272    goal_format(Index, Goal, RealExit),
273    Goal \== RealExit,
274    not variant(Goal, RealExit).
275
276vars_from(T1, T2) -->
277    {var(T1),
278    !},
279    [T2].
280vars_from(T1, T2) -->
281    {T1 = [_|_],
282    T2 = [_|_],
283    !},
284    vars_from_list(T1, T2).
285vars_from(T1, T2) -->
286    {T1 =.. [F|L1],
287    T2 =.. [F|L2] ->
288	true
289    ;
290    T2 = [] ->		% accept a truncated linear term
291	true
292    },
293    vars_from_list(L1, L2).
294
295vars_from_list([], []) --> {true}.
296vars_from_list([K*V1|L1], [K*V2|L2]) -->
297    ({var(V1), !},
298	[V2]
299    ;
300    	{true}
301    ),
302    vars_from_list(L1, L2).
303vars_from_list([_*V1|L1], L2) -->
304    {nonvar(V1), !},
305    vars_from_list(L1, L2).
306vars_from_list([H|L1], [K|L2]) -->
307    vars_from(H, K),
308    vars_from_list(L1, L2).
309
310
311% extended functor that matches variables
312gfunctor(Var, _, 0) :-
313    var(Var).
314gfunctor(Term, F, A) :-
315    nonvar(Term),
316    functor(Term, F, A).
317
318start_with_nonvar([H|T], L) :-
319    (var(H) ->
320	L = [{}, H|T]
321    ;
322    H = "" ->
323	start_with_nonvar(T, L)
324    ;
325	L = [H|T]
326    ).
327
328goal_domains([], [], []).
329goal_domains([Var|L], EVars, [' {', Id, ' {'| C]) :-
330    var(Var),
331    !,
332    var_id(Var, Id),
333    (EVars = [EV|EL],
334    (var_id(EV, Id); atomic(EV)) ->
335	domain_difference(Var, EV, C, ['}} '|T]),
336	goal_domains(L, EL, T)
337    ;
338	printf("Cannot make difference of %Dmw with vars %Dmw, list %Dmw\n%b",
339		[Var, EVars, L]),
340	el_to_const(Var, S, _),
341	C = [S, '}} '|T],
342	goal_domains(L, EVars, T)
343    ).
344goal_domains([C|L], EV, [C|T]) :-
345    goal_domains(L, EV, T).
346
347% Take a Prolog term and return a list of strings and vars which,
348%  when concatenated, represent the printed form of the term.
349decompose_expr(Expr, List, Vars) :-
350    sumnodes(vars, Expr, Vars, []),
351    open(_, string, Stream),		% simulate term_string without attribs.
352    printf(Stream, "%GDw", [Expr]),
353    %printf("%GDw\n%b", [Expr]),
354    get_stream_info(Stream, name, String),
355    close(Stream),
356    open(String, string, S),
357    read_token(S, Tok, Class),
358    scan_expression(S, Tok, Class, Vars, List, CL, CL).
359
360scan_expression(S, _, end_of_file, [], [String], CList, []) :-
361    !,
362    concat_string(CList, String),
363    close(S).
364scan_expression(S, _, var, [Var|Vars], [String, Var|List], CList, []) :-
365    !,
366    concat_string(CList, String),
367    read_token(S, Tok, Class),
368    scan_expression(S, Tok, Class, Vars, List, CL, CL).
369scan_expression(S, _, comma, Vars, List, CList, [','|CL]) :-
370    !,
371    read_token(S, NewTok, NewClass),
372    scan_expression(S, NewTok, NewClass, Vars, List, CList, CL).
373scan_expression(S, Tok, atom, Vars, List, CList, [RepTok|CL]) :-
374    % We must escape backslashes
375    replace_token(Tok, RepTok),
376    !,
377    read_token(S, NewTok, NewClass),
378    scan_expression(S, NewTok, NewClass, Vars, List, CList, CL).
379scan_expression(S, Tok, _, Vars, List, CList, [Tok|CL]) :-
380    read_token(S, NewTok, NewClass),
381    scan_expression(S, NewTok, NewClass, Vars, List, CList, CL).
382
383vars(X) -->
384    {var(X)} -> [X];[].
385
386:- mode replace_token(+, -).
387replace_token(#\=, "#\\\\=") :- !.
388replace_token(#\+, "#\\\\+") :- !.
389replace_token(#\/, "#\\\\/") :- !.
390replace_token(#/\, "#/\\\\") :- !.
391
392remove_spaces(SpString, Atom) :-
393    name(SpString, SpList),
394    delete_all(SpList, 0' , List),
395    name(Atom, List).
396
397delete_all([], _, []).
398delete_all([H|T], H, L) :-
399    !,
400    delete_all(T, H, L).
401delete_all([H|T], C, [H|L]) :-
402    delete_all(T, C, L).
403
404domain_element(I, [H|T], Val) :-
405    domain_element(I, H, T, Val).
406
407domain_element(1, L.._, _, L) :-
408    !.
409domain_element(1, H, _, H) :-
410    !.
411domain_element(I, L..U, T, Val) :-
412    !,
413    (I =< U - L + 1 ->
414        Val is L + I - 1
415    ;
416    	I1 is I - U + L - 1,
417    	domain_element(I1, T, Val)
418    ).
419domain_element(I, _, [H|T], Val) :-
420    I1 is I - 1,
421    domain_element(I1, H, T, Val).
422