1:- module(cil, [unify/2, 2 find_key/3, 3 close_btree/1, 4 distribute_constr/2, 5 region_constr_of_leaves/4 6 ]). 7:- use_module([ 8 library(lists), 9 library(sort), 10 library(ordsets)]). 11 12% for test. 13% ?- qcompile(util('ptq-fragment')), module(cil). 14 15 16 /**************************************************** 17 * CIL attributed variables version * 18 * based on attr_unify_hook/2. * 19 ****************************************************/ 20 21% for short. 22% ?- put_attr(con(total), X). 23put_attr(X, Attr):- put_attr(X, cil, Attr). 24% 25get_attr(X, Attr):- get_attr(X, cil, Attr). 26 27% After Jan's advice. 28attr_unify_hook(V, Y):- 29 ( get_attr(Y, cil, A) 30 -> attr_unify(V, A, Y) 31 ; attr_unify(V, Y) 32 ).
37attr_unify(btree(X), Y):- is_btree(Y), !, unify(X, Y). 38attr_unify(con(Rgn, _), Y):- is_btree(Y), !, 39 distribute_constr(Y, Rgn). 40attr_unify(_, _).
48attr_unify(btree(X), btree(Y), _):- unify(X, Y). 49attr_unify(btree(X), con(Rgn, D), Z):- 50 distribute_constr(X, Rgn), 51 put_attr(Z, con(Rgn, D), Z), 52 subsume(X, D). 53attr_unify(con(Rgn, Y), btree(D), Z):- 54 distribute_constr(D, Rgn), 55 put_attr(Z, con(Rgn, Y)), 56 subsume(D, Y). 57attr_unify(con(Rgn, Y), con(Rgn0, Y0), Z):- 58 meet_region(Rgn, Rgn0, Rgn1), 59 add_only_new(Y, Y0, Y1), 60 put_attr(Z, con(Rgn1, Y1)), 61 unify(Y, Y0). 62 63 /**************************************************** 64 * Unification over feature sructures * 65 ****************************************************/ 66 67% Kernel Of CIL by K. Mukai 01-DEC-85 68% 69% Originally coded in 1985 at ICOT. 70% 71% Revised around 2016-11-13. 72% 73% This is a unifier over feature structures rewritten on top of 74% attributed variables in SWI-7. 75% 76% 77% key := <prolog ground term> 78% 79% btree := [] (void tree) 80% | t(key, zterm, btree, btree) 81% 82% zterm := btree 83% | <prolog variable> 84% | <prolog atomic term> 85% | <prolog atom>(zterm, ..., zterm) 86 87 88 /*************************************** 89 * Unifier over feature structues. * 90 ***************************************/ 91 92% For test. 93% ?- module(cil). 94% ?- X.a=1. 95% ?- X.a=1, X=Y, Y.a=V. 96% ?- X=Y, X.a=1, Y.a=V. 97% ?- X.a=1, Y.a=V, X=Y. 98% ?- X.a #= Y.b, X={b:1}, X=Y, Y.a=V. 99% ?- X.a = X.b, X={b:1}. 100% ?- X={a:2}, Y={b:1}, X=Y. 101% ?- X=f({a:2}), Y=f({b:1}), X=Y, f(A)= X, B = A.b. 102% ?- X=f({a:2}), Y=f({b:1}), X=Y. 103 104is_btree(t(_,_,_,_)). 105is_btree({}). 106% 107apply_constr(X, con(I,_)):- distribute_constr(X, I).
112distribute_constr(X, Rgn):- var(X), !, 113 ( get_attr(X, A) 114 -> ( A = con(RgnA, D) 115 -> meet_region(RgnA, Rgn, RgnA0), 116 put_attr(X, con(RgnA0, D)) 117 ; A = btree(A0), 118 distribute_constr(A0, Rgn) 119 ) 120 ; put_attr(X, con(Rgn, [])) 121 ). 122distribute_constr({}, _):-!. 123distribute_constr(t(K,_,L,R), Rgn):- 124 has_member(Rgn, K), 125 meet_region(Rgn, lower(K), LowK), 126 meet_region(Rgn, upper(K), UppK), 127 distribute_constr(L, LowK), 128 distribute_constr(R, UppK).
135region_constr_of_leaves(X, Rgn, P, Q):- child_of_node(X, K, _, L, R), !, 136 meet_region(lower(K), Rgn, RgnL), 137 region_constr_of_leaves(L, RgnL, P, P0), 138 meet_region(upper(K), Rgn, RgnR), 139 region_constr_of_leaves(R, RgnR, P0, Q). 140region_constr_of_leaves(X, Rgn, [put_attr(X, cil, con(Rgn, []))|P], P):- var(X), !. 141region_constr_of_leaves(_, _, P, P).
147unify(X, Y):- (attvar(X); attvar(Y)), !, X=Y. 148unify(X, Y):- (var(X); var(Y)), !, X=Y. 149unify(X, Y):- is_btree(X), is_btree(Y), !, subsume(X, Y). 150unify(X, X). % cool !
subsume(X,Y) and subsume(Y,X) implies X=Y.156subsume(X, Y):-attvar(X), !, 157 get_attr(X, A), 158 ( A=btree(T) 159 -> subsume(T, Y) 160 ; A=con(Rgn, S), 161 add_only_new([Y], S, S0), % sounds natural ! 162 put_attr(X, con(Rgn, S0)) 163 ). 164subsume(X, Y):-var(X), !, 165 put_attr(X, con(total, [Y])). 166subsume(t(K,V,L,R), Y):- 167 find_key(Y, K, U), 168 unify(V, U), 169 subsume(L, Y), 170 subsume(R, Y). 171subsume({}, _).
177child_of_node(X, K, V, L, R):- var(X), !, 178 get_attr(X, A), 179 A=btree(t(K, V, L, R)). 180child_of_node(t(K, V, L, R), K, V, L, R). 181 182%%% 183% inspect_node(X, A):-var(X), (get_attr(X, A); A=var(X)), !. 184% inspect_node(X, X).
192% ?- module(cil). 193% ?- cil:weak_subsume({a:2}, {a:1}, Z). 194% ?- cil:weak_subsume({a:2, b:1, c:3}, {a:1, b:X, c:5, d:6}, Z). 195weak_subsume(X, Y, Z):-attvar(X), !, 196 get_attr(X, A), 197 ( A=btree(T) 198 -> weak_subsume(T, Y, Z) 199 ; Z = Y 200 ). 201weak_subsume(X, Y, Y):-var(X), !. 202weak_subsume(t(K,V,L,R), Y, Z):- 203 find_key(Y, K, U), 204 (unify(V, U); true), 205 !, 206 weak_subsume(L, Y, Z), 207 weak_subsume(R, Y, Z). 208weak_subsume({}, Y, Y). 209 210% :- module(cil). 211%@ true. 212%@ true.
?- {a:1}=X, close_btree(X), X={b:1}.
?- {a:1}=X, close_btree(X).
220close_btree(X):- child_of_node(X, _, _, L, R), !, 221 close_btree(L), 222 close_btree(R). 223close_btree({}):-!. 224close_btree(t(_, _, L, R)):-close_btree(L), 225 close_btree(R). 226 227% ?- [util('ptq-fragment')]. 228%% is_equal_btree(+X:btree, +Y:btree) is det. 229% True if closed X is equaivalent to closed Y as open dict. 230 231% ?-is_equal_btree({a:1}, {a:1}). 232% ?-is_equal_btree({a:1, b:2}, {b:2, a:1}). 233% ?-is_equal_btree({a:f(2)}, {a:f(1)}). % false 234% ?-is_equal_btree({a:f({b:2})}, {a:f({b:3})}). % false 235is_equal_btree(X, Y):- is_equal_by_stack([X],[Y]). 236 237% 238is_equal_by_stack(X, Y):- skip_leaves(X, X0), 239 skip_leaves(Y, Y0), 240 is_equal_pair(X0, Y0). 241% 242is_equal_pair([],[]). 243is_equal_pair([pair(K, V)|L],[pair(K, U)|M]):- 244 is_equal_arg(V, U), 245 is_equal_by_stack(L, M). 246% 247is_equal_arg(X, Y):- var(X), var(Y), X==Y, !. 248is_equal_arg(X, Y):- 249 ( child_of_node(X, K, V, L, R) 250 -> ( child_of_node(Y, K0, V0, L0, R0) 251 -> is_equal_by_stack( [L, pair(K, V), R], 252 [L0, pair(K0, V0), R0]) 253 ; false 254 ) 255 ; ( child_of_node(Y, _, _, _, _) 256 -> false 257 ; is_equal_non_btree(X, Y) 258 ) 259 ). 260% 261is_equal_non_btree(X, Y):- (var(X); var(Y)), !, X==Y. 262is_equal_non_btree(X, Y):- (atomic(X); atomic(Y)), !, X==Y. 263is_equal_non_btree(X, Y):- X=..[F|Xs], 264 Y=..[F|Ys], 265 maplist(is_equal_arg, Xs, Ys). 266% 267skip_leaves([], []). 268skip_leaves([X|Xs], U):- child_of_node(X, K, V, L, R),!, 269 skip_leaves([L, pair(K,V), R|Xs], U). 270skip_leaves([X|Xs], U):- (var(X); X==[]), !, 271 skip_leaves(Xs, U). 272skip_leaves(X, X).
278userrole(K, X, V):- when(ground(K), find_key(X, K, U)), 279 unify(V, U). 280 281% 282min(X, Y, X):- X@<Y, !. 283min(_, Y, Y). 284 285max(X, Y, Y):- X@<Y, !. 286max(X, _, X).
292% ?- find_key({a:1}, a, V, R). 293% ?- find_key(X, a, V). 294% ?- find_key(t(k, 1, L, R), k, V). 295find_key(B, K, V):- 296 ( var(B) 297 -> ( get_attr(B, U) 298 -> ( U=btree(U0) 299 -> find_key(U0, K, V) 300 ; insert_key(U, K, V, B) 301 ) 302 ; T = t(K, V, L, R), 303 put_attr(L, con(lower(K),[])), 304 put_attr(R, con(upper(K),[])), 305 put_attr(B, btree(T)) 306 ) 307 ; B=t(J,U,L,R), 308 ( J==K 309 -> V=U 310 ; ( J @< K 311 -> find_key(R, K, V) 312 ; find_key(L, K, V) 313 ) 314 ) 315 ). 316 317% 318find_key_list([], _, _). 319find_key_list([Y|Ys], K, V):- find_key(Y, K, V), 320 find_key_list(Ys, K, V).
t(K, V, L, R)
such that L and R have the region constraint con(Rgn, Ys)
making all members of Ys having a subtree t(K, V, _, _).
i.e, N.K=V, and Y.K=V for all Y in Ys.
329insert_key(con(Rgn, Ys), K, V, N):-
330 has_member(Rgn, K),
331 meet_region(Rgn, lower(K), RgnL),
332 meet_region(Rgn, upper(K), RgnR),
333 put_attr(L, con(RgnL, Ys)),
334 put_attr(R, con(RgnR, Ys)),
335 put_attr(N, btree(t(K, V, L, R))),
336 find_key_list(Ys, K, V).340has_member(total, _). 341has_member(seg(L,R), X):- L@<X, X@<R. 342has_member(lower(U), X):- X@<U. 343has_member(upper(U), X):- U@<X.
348meet_region(X, Y):- meet_region(X, Y, Z), Z\==[].355% ?- meet_region(lower(a), lower(b), X). 356% ?- meet_region(seg(a, p), seg(b, z), X). 357% ?- meet_region(seg(a, z), seg(b, z), X). 358meet_region(total, X, X). 359meet_region(X, total, X). 360meet_region([], _, []). 361meet_region(_, [], []). 362meet_region(lower(A), lower(B), lower(C)):- min(A, B, C). 363meet_region(lower(A), upper(B), R):- 364 ( B @< A -> R = seg(B, A) 365 ; R = [] 366 ). 367meet_region(lower(C), seg(A,B), R):- 368 ( C @=< A -> R = [] 369 ; R = seg(A, D), 370 min(B,C,D) 371 ). 372meet_region(upper(A), upper(B), upper(C)):- max(A, B, C). 373meet_region(upper(A), lower(B), R):- 374 ( A @< B -> R = seg(A, B) 375 ; R = [] 376 ). 377meet_region(upper(C), seg(A, B), R):- 378 ( C @>= B 379 -> R = [] 380 ; R = seg(D, B), 381 max(A, C, D) 382 ). 383meet_region(seg(A, B), lower(C), R):- 384 ( C @=< A -> R = [] 385 ; R = seg(A, D), 386 min(B,C,D) 387 ). 388meet_region(seg(A, B), upper(C), R):- 389 ( C @>= B 390 -> R = [] 391 ; R = seg(D, B), 392 max(A, C, D) 393 ). 394meet_region(seg(A, B), seg(C, D), M):- 395 max(A,C,L), 396 min(B,D,R), 397 ( L @>= R -> M = [] 398 ; M = seg(L, R) 399 ). 400 401% % contain(+X, +Y) is det. 402% True if region X contains region Y, i.e. Y is a subset of X. 403% ?- contain(lower(i), lower(j)). 404% ?- contain(lower(j), lower(j)). 405 406contain(total,_). 407contain(_, []). 408contain(lower(A), lower(B)) :- B@=<A. 409contain(lower(A), seg(_,B)) :- B@=<A. 410contain(upper(A), upper(B)) :- A@=<B. 411contain(upper(A), seg(B,_)) :- A@=<B. 412contain(seg(A,B), seg(A0, B0)) :- A@=<A0, B0@=<B. 413 414% 415add_only_new([], X, X):- !. 416add_only_new([X|Y], Z, U):- memq(X, Z), !, 417 add_only_new(Y, Z, U). 418add_only_new([X|Y], Z, [X|U]):- 419 add_only_new(Y, Z, U). 420% 421memq(X, [Y|_]):- X==Y, !. 422memq(X, [_|Y]):- memq(X, Y)