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