1:- module(ptqfrag, []).    2term_expansion --> pac:expand_pac.
    3:- use_module(library(clpfd)).    4
    5role(X, Y, Z):- user:role(X, Y, Z).
    6
    7% Note 1: `pred' is a special symbol in the pac.
    8% Note 2:  quote is reserved in pac quote. So asis is used instead.
    9% Note 3:  open dicts are not expanded in pred.
   10
   11% sample queries.
   12
   13% ?- module(ptqfrag).
   14% ?- run_samples.
   15% ?- disable_odict.
   16% ?- disable_pac_query.
   17% ?- enable_odict.
   18% ?- enable_pac_query.
   19
   20% ?- X={a:{}}.
   21% ?- X={a:1}, Y={a:1}.
   22% ?- X={a:1}, Y={a:1}, X=Y.
   23% ?- X={a:1}, X={b:2}.
   24% ?- X={a:1}, X={b:2}, Ans=X.a.
   25% ?- X={a:1}, X.a=Ans, X={a:1}, X={a:2}.  % <= shoud be false.
   26% ?- 1=X.a.b, X={a:{b:A}}.
   27% ?- {}=X.a.b, X={a:{b:A}}, Ans=X.a.b.
   28% ?- X.a - X.b #= 1, X.a+X.b #= 3, [X.a, X.b] ins 1..10, write(['X.a'=X.a, 'X.b'=X.b]).
   29% ?- A - B #= 1, A + B #= 3, [A,B] ins 1..10.
   30% ?- X.a - X.b #= 1, X.a+X.b #= 3, [X.a, X.b] ins 1..10, writeln(X.a), writeln(X.b).
   31% ?- X.a - X.b #= 1, X.a + X.b #= 3, [X.a, X.b] ins 1..10, writeln(X.a), writeln(X.b).
   32% ?- X.a = Y.b.
   33
   34% Example use of the iterm
   35% ?-  U= {a:X,  b:f(X, X)}, X = hello, Ans = U.b.
   36% ?-  U= {a:X,  b:X.c.d}, X={c:{d:hello}}, Ans= U.b.
   37% ?-  U= {a:f(X.a(I))}, X={a(1):1, a(2):hello, a(3):3}, Ans=X.a(I), I=2.
   38% ?-  U= {a:f(X.a, X.b)}, X={a:hello, b:world}, Ans=U.a.
   39% ?-  U= {a:f(X.a)}, X={a:hello, b:world}, Ans=U.a.
   40% ?-  U= {a:f(X.a, X.b)}, X={a:hello, b:world}, Ans=U.a, Ans0=X.b.
   41% ?-  U= {a:f(X.a, X.b)}, X={a:hello, b:world}, Ans=U.a, Ans0=X.b, btree_to_odict(U, D).
   42% ?-  A = {a:1}, call(pred(A, [X]:- X= A), U), writeln(U.a).
   43
   44put_attr(X,A):- put_attr(X, cil, A).
   45get_attr(X,A):- get_attr(X, cil, A).
   46
   47	/*******************************
   48	*         PTQ sample runs      *
   49	*******************************/
   50
   51% ?- trace, ptqfrag:run_samples.
   52run_samples :- sample(S), format("~w.\n",[S]),
   53       once(call(ptqfrag:S, X)),
   54	   once(call(ptqfrag:X, V)),
   55       format("Ans = ~w.~n",[V]), fail.
   56run_samples:- nl.
   57
   58%
   59sample(ptq(s, [john, is, a, man], [man(j),find(j,j)])).
   60sample(ptq(s, [every, man, is, john], [man(j),find(j,j)])).
   61sample(ptq(s, [every, man, is, john], [man(j),man(k)])).
   62sample(ptq(s, [every, man, finds, every, man], [man(j), man(k), find(j,j)])).
   63sample(ptq(pn, [john], [])).
   64sample(ptq(np, [a, unicorn], [male(j),male(b),female(m),unicorn(u), find(m,u),walk(j),walk(b),walk(m)])).
   65sample(ptq(s, [a, unicorn, walks], [male(j),male(b),female(m),unicorn(u), find(m,u),walk(j),walk(b),walk(m)])).
   66sample(ptq(vp, [find, a, unicorn], [male(j),male(b),female(m),unicorn(u), find(m,u),walk(j),walk(b),walk(m)])).
   67sample(ptq(s, [john,finds, a, unicorn], [male(j),male(b),female(m),unicorn(u), find(m,u),walk(j),walk(b),walk(m)])).
   68sample(ptq(tv, [find], [man(a),find(j,a),walk(j)])).
   69sample(ptq(itv, [walk], [man(a),find(j,a),walk(j)])).
   70sample(ptq(vp, [find, a, unicorn], [unicorn(a),find(j,a),walk(j)])).
   71sample(ptq(s, [john, walks], [man(a),find(j,a),walk(j)])).
   72sample(ptq(s, [every, man,  walks], [man(a),find(j,a),walk(j)])).
   73sample(ptq(s, [every, man,  walks], [man(j),find(j,a),walk(j)])).
   74
   75	/************************************
   76	*           For ptq testing.	    *
   77	************************************/
   78%
   79ptq(S, F)  :- ptq(s, S, F).
   80%
   81ptq(C, S, F) :- ptq(C, S, F, V),
   82				call(V, R),
   83			    writeln(V),
   84			    format("Ans = ~w.\n", [R]).
   85%
   86ptq(P, S, F, Fun):- call(P, E, S, []),
   87				 individuals(F, Inds),
   88				 Fun = eval_ptq(E.sem, world(Inds, F)).
   89ptq(_,_,_,'** syntax error ').
   90
   91% ?- ptq(s, [every, man,  is, every, man], [man(j)]).
   92% ?- ptq(s, [every, man,  is, every, man], [man(j), man(k)]).
   93% ?- ptq(s, [a, man,  is, every, man], [man(j), man(k)]).
   94% ?- ptq(s, [a, man, finds, every, man], [man(j), man(k), find(j, k)]).
   95% ?- ptq(s, [a, man,  walks], [man(j), walk(j)]).
   96% ?- ptq(s, [every, man, finds, every, man], [man(j), man(k), find(j, j), find(j, k)]).
   97% ?- ptq(s, [john, walks], [walk(j)]).
   98% ?- ptq(s, [john, is, a, man], [man(j), is(j, j)]).
   99% ?- ptq(s, [john, finds, john], [find(j, m)]).
  100% ?- ptq(s, [john, finds, a,  unicorn], [find(j, u), unicorn(u), man(m), walk(m)]).
  101% ?- ptq(s, [every, man, walks], [man(j), walk(j)]).
  102% ?- ptq(s, [every, man, finds, a,  unicorn], [find(m, u), unicorn(u), man(m), walk(m)]).
  103% ?- ptq(vp, [finds, a,  man], [man(k), man(m), find(m, k), find(k, k)]).
  104% ?- ptq(vp, [finds, john], [find(j, j)]).
  105% ?- ptq(vp, [finds, every, man], [man(j), man(k), find(j, j), find(j, k)]).
  106% ?- ptq(vp, [is, a, man], [man(j)])
  107% ?- ptq(vp, [is, john], [man(j)])
  108% ?- ptq(np, [a, man], [man(j), man(k), man(l)]).
  109% ?- ptq(np, [every, man], [man(k), man(m), find(m, k), find(k, k)]).
  110
  111% ?- ptq(np, [every, man], [man(k)]).
  112% ?- ptq(determiner, [a], [man(j), walk(j)]).
  113% ?- ptq(tv, [find], [find(j, k), find(l, m)]).
  114% ?- ptq(pn, [john], [man(x),find(j,x),walk(j)]).
  115% ?- ptq(cn, [unicorn], [unicorn(u)]).
  116
  117	/******************************************
  118	*            A simple subset of PTQ       *
  119	******************************************/
  120
  121% Sentence
  122s({ sem:truth(in(VP.sem, NP.sem)) }) -->
  123	np(NP),  vp(VP), { NP.agree = VP.agree }.
  124
  125% Noun phrase
  126np({ sem:app(rel_to_fun(Det.sem), CN.sem),
  127	agree:CN.agree }) -->	determiner(Det), cn(CN).
  128np({ sem:principal_filter(PN.sem),
  129	agree:PN.agree,
  130	cat: PN.cat }
  131   ) --> pn(PN).
  132
  133% Verb phrase
  134
  135% ?- listing(vp).
  136
  137vp(ITV)  --> itv(ITV).
  138vp({ sem:inverse_image(rel_to_fun(TV.sem), NP.sem),
  139    agree:TV.agree }) --> tv(TV), np(NP).
  140
  141% Intransitive verb
  142itv(A) --> dict(itv, A).
  143% Transitive verb
  144tv(A) --> dict(tv, A).
  145% Common noun
  146cn(A) --> dict(cn, A).
  147% Proper name
  148pn(A) --> dict(pn, A).
  149%
  150determiner(A) --> dict(det, A).
  151
  152%
  153dict(Cat, A) --> [X], { dict(X, A), A.cat=Cat }.
  154
  155% Agreement feature 1
  156agree_3s({ per:3, num:s }).		% ex. walks
  157
  158% Agreement feature 2
  159agree_n3s({ per:X, num:Y }):-	% ex. walk
  160	when((nonvar(X), nonvar(Y)),
  161		 member(X-Y, [	1-s, 1-p,
  162						2-s, 2-p,
  163							 3-p ])).
  164
  165% Dict
  166dict(walk, { sem:predicate(walk/1),
  167			agree:X,
  168			cat:itv }):- agree_n3s(X).
  169dict(walks, { sem:predicate(walk/1),
  170			 agree:X,
  171			 cat:itv }):- agree_3s(X).
  172dict(is, { sem:predicate(is/2),
  173			agree:X,
  174			cat:tv }):- agree_3s(X).
  175dict(find, { sem:predicate(find/2),
  176			agree:X,
  177			cat:tv }):- agree_n3s(X).
  178dict(finds, { sem:predicate(find/2),
  179			 agree:X,
  180			 cat:tv }):- agree_3s(X).
  181dict(kick, { sem:predicate(kick/2),
  182			agree:X,
  183			cat:tv }):- agree_n3s(X).
  184dict(kicks, { sem:predicate(kick/2),
  185			 agree:X,
  186			 cat:tv }):- agree_3s(X).
  187
  188% pronoun. Not used yet.
  189dict(i, { agree:{ per:1, num:s },
  190		 cat:prn }).
  191dict(we,{ agree:{ per:1, num:p },
  192		 cat:prn }).
  193dict(you, { agree:{ per:2, num:X },
  194		   cat:prn }):-
  195	when(nonvar(X), member(X, [s, p])).
  196dict(he, { agree:{ per:3, num:s },
  197		  cat:prn }).
  198dict(she, { agree:{ per:3, num:s },
  199		   cat:prn }).
  200dict(they, { agree:{ per:3, num:p },
  201			cat:prn }).
  202
  203%
  204dict(john, { sem: ind(j),
  205			agree:{ per:3, num:s },
  206			cat:pn }).
  207dict(bill, { sem:ind(b),
  208			agree:{ per:3, num:s },
  209			cat:pn }).
  210dict(mary, { sem: ind(m),
  211			agree:{ per:3, num:s },
  212			cat:pn }).
  213%
  214dict(unicorn, { sem:predicate(unicorn/1),
  215			   agree:{ per:3, num:s },
  216			   cat:cn }).
  217dict(man,	{ sem:predicate(man/1),
  218		     agree:{ per:3, num:s },
  219			 cat:cn }).
  220dict(woman, { sem:predicate(woman/1),
  221			agree:{ per:3, num:s },
  222			cat:cn }).
  223%
  224dict(a,		{ sem:quant(a),
  225			 cat:det }).
  226dict(every, {  sem:quant(every),
  227			 cat:det }).
  228
  229	/**************************************************
  230	*        Interpreting semantic expressions.       *
  231	**************************************************/
  232
  233% ?- module(ptqfrag).
  234% ?- [misc('ptq-fragment')].
  235% ?- listing(eval_ptq).
  236
  237% ?- eval_ptq(predicate(walk/1), world([i, j], [walk(i), walk(j)]),  S).
  238
  239eval_ptq(truth(X), W, S) :-  eval_boole(X, W, S).
  240eval_ptq(asis(X), _, X) :- !.  % quote is reserved.
  241eval_ptq(if(X, Y, Z), W, S):-
  242	eval_boole(X, W, B),
  243	( B==true ->  eval_ptq(Y, W, S)
  244	;	eval_ptq(Z, W, S)
  245	).
  246eval_ptq(app(F, A), W, V):- !,
  247	eval_ptq(F, W, F0),
  248	eval_ptq(A, W, A0),
  249	memberchk(A0-V, F0).
  250eval_ptq(call(X), _, _):- !, once(X).
  251eval_ptq(X, W, S)  :- is_boole(X), !,
  252	eval_boole(X, W, S).
  253eval_ptq(L, _, L):- (L==[]; L=[_|_]), !.
  254eval_ptq(X, W, S)  :- eval_atom(X, W, S), !.
  255
  256%
  257eval_atom(predicate(X), W, S) :- !, basic_ext(predicate(X), W, S).
  258eval_atom(ind(X), _, [X]) :- !.
  259eval_atom(filter(S), W, V) :- !, eval_ptq(S, W, V0),
  260 		filter(W, V0, V).
  261eval_atom(principal_filter(S), W, V) :- !,
  262	( S = ind(J) ->  Ind=J
  263	; Ind = S
  264	),
  265	filter(W, [Ind], V).
  266eval_atom(quant(Q), W, V) :- !, eval_quant(Q, W, V).
  267eval_atom(X, W, Y):- X=..[F|As],
  268			 maplist(eval_arg(W), As, Bs),
  269			G=..[F|Bs],
  270			call(G, Y).
  271
  272%
  273eval_arg(_, X, X):- var(X),!.
  274eval_arg(W, X, Y):- eval_ptq(X, W, Y).
  275
  276%
  277is_boole(truth(_)).
  278is_boole(true).
  279is_boole(false).
  280is_boole(and(_,_)).
  281is_boole(or(_,_)).
  282is_boole(implry(_,_)).
  283is_boole(not(_,_)).
  284is_boole(in(_,_)).
  285is_boole(=(_,_)).
  286
  287%
  288ind(I, _, I).
  289
  290% ?- eval_boole(truth(not(true)), _, X).
  291% ?- eval_boole(truth(not(true)), _, X).
  292% ?- eval_boole(or(1=2, 2=1), _, X).
  293% ?- eval_boole(imply(1=2, 2=1), _, X).
  294
  295eval_boole(true, _, true).
  296eval_boole(false, _, false).
  297eval_boole(and(X,Y), M, V):-eval_and(X, Y, M, V).
  298eval_boole(or(X,Y), M, V):-eval_boole(not(and(not(X), not(Y))), M, V).
  299eval_boole(not(X), M, V):- eval_not(X, M, V).
  300eval_boole(imply(X,Y), M, V):-eval_boole(or(not(X), Y), M, V).
  301eval_boole(in(X,Y), M, V):- eval_ptq(X, M, X0),
  302							eval_ptq(Y, M, Y0),
  303							check_truth(member(X0, Y0), V).
  304eval_boole(truth(X), W, V):- eval_boole(X, W, V).
  305eval_boole(X, _,  V):- check_truth(X, V).
  306
  307%
  308eval_not(X, M, V):- eval_boole(X, M, U),
  309					   ( U== true -> V = false
  310					   ; V = true
  311					   ).
  312
  313%
  314eval_and(X, Y, M, V):- eval_boole(X, M, U),
  315						  ( U == false -> V=false
  316						  ; eval_boole(Y, M, V)
  317						  ).
  318
  319%
  320check_truth(X, true) :-  call(X), !.
  321check_truth(_, false).
  322
  323% ?- basic_ext(predicate(love/2),world(_, [love(c,b), love(a,b)]),  X).
  324% ?- basic_ext(predicate(walk/1), world(_, [walk(a)]),  X).
  325% ?- basic_ext(predicate(is/2), world([a,b], [walk(a)]),  X).
  326
  327basic_ext(predicate(P/N), DB, E):-!, basic_ext(P/N, DB, E).
  328basic_ext(P/1, world(_,F), E):-!,
  329	T =..[P, X],
  330	( setof(X, member(T, F), E) -> true
  331	;  E = []
  332	).
  333basic_ext(is/2, world(D, _), E):-!,
  334	( setof(X-X, member(X, D), E) -> true
  335	;  E = []
  336	).
  337basic_ext(P/2, world(_,F), E):-!,
  338	T =..[P, X, Y],
  339	( setof(X-Y, member(T, F), E) -> true
  340	;  E = []
  341	).
  342
  343% ?- eval_quant(a, world([1,2],_),  R).
  344% ?- eval_quant(every, world([1,2], _),  R).
  345eval_quant(Q, world(D, _), R):- eval_quant_(Q, D, R0), sort_pairs(R0, R).
  346
  347%
  348sort_pairs([X-Y|R], [X0-Y0|R0]):- sort(X, X0), sort(Y, Y0),
  349								 sort_pairs(R, R0).
  350sort_pairs([],[]).
  351
  352eval_quant_(a, D, R):- !,
  353	(   powerset(D, D0),
  354		maplist(sort, D0, PowD),
  355	    setof(X-Y, (member(X,PowD), member(Y,PowD), meet(X,Y)), R)
  356	->  true
  357	;   R=[]
  358	).
  359eval_quant_(every, D, R):- !,
  360	(   powerset(D,D0),
  361		maplist(sort, D0, PowD),
  362	    setof(X-Y, (member(X,PowD), member(Y,PowD), subset(X,Y)), R)
  363	->  true
  364	;   R=[]
  365	).
  366
  367% ?- individuals([f(a);g(b)], S).
  368
  369individuals(F, S):- maplist(atoms,F,F1),
  370	append(F1, F2),
  371	sort(F2,S).
  372
  373%
  374atoms(X,[X]):-atomic(X),!.
  375atoms(X,Y):- is_list(X),!,
  376	maplist(atoms, X, Z),
  377	append(Z, Y).
  378atoms(X,Y):- X=..[_|A],
  379	maplist(atoms, A, B),
  380	append(B, Y).
  381
  382	/*****************************************
  383	*                Helper predicates       *
  384	*****************************************/
  385
  386pair(A-B, A, B).
  387pair(A=B, A, B).
  388pair(A:B, A, B).
  389
  390% ?- rel_to_fun([a-b, x-y, a-c, x-z], R).
  391% ?- rel_to_fun([a=b, x-y, a=c, x-z], R).
  392% ?- rel_to_fun([a-c, x-y, a-b, x-z], R).
  393% ?- rel_to_fun([a:c, x-y, a=b, x:z], R).
  394
  395rel_to_fun(X, Y):- rel_to_fun(X, Y, sort_right).
  396%
  397rel_to_fun(X, Y, []):-!, rel_to_fun_(X, [], Y).
  398rel_to_fun(X, Y, G):- rel_to_fun_(X, [], Y0),
  399					  call(G, Y0, Y).
  400
  401%
  402rel_to_fun_([], X, X).
  403rel_to_fun_([P|R], X, Y):- pair(P, A, B),
  404		( select(A-M, X, X0)
  405		->	rel_to_fun_(R, [A-[B|M]|X0], Y)
  406		;	rel_to_fun_(R, [A-[B]|X], Y)
  407		).
  408%
  409sort_right([], []).
  410sort_right([L-R|M], [L-R0|M0]):-
  411	sort(R, R0),
  412	sort_right(M, M0).
  413
  414% ?-  powerset([a,b], X).
  415powerset(X, Y):- powerset(X, [[]], Y).
  416
  417powerset([], X, X).
  418powerset([A|R], X, Y):-
  419	powerset(X, A, X, X0),
  420	powerset(R, X0, Y).
  421
  422%
  423powerset([], _, X, X).
  424powerset([X|R], A, S, Y):- powerset(R, A, [[A|X]|S], Y).
  425
  426% ?- filter(world([a,b,c,d], _), [c], R, mapsort).
  427% ?- filter(world([a,b,c,d], _), [c], F,  []).
  428% ?- filter(world([a,b,c,d], _), [c], R).
  429
  430filter(W, D,  F):- filter(W, D, F, mapsort).
  431
  432%
  433filter(W, D, F, []):- !, filter_(W, D, F).
  434filter(W, D, F, G):-  filter_(W, D, F0),
  435	  call(G, F0, F).
  436%
  437filter_(world(X, _), D, F):- subtract(X, D, Y),
  438	powerset(Y, P),
  439	maplist(append(D), P, F).
  440
  441%
  442mapsort(X, Y):- maplist(sort, X, Y0),
  443				sort(Y0, Y).
  444
  445% ?- principal_filter([a,b,c], b, X).
  446% ?- principal_filter([a,b,c], b, X, []).
  447
  448principal_filter(D, A, PF):- principal_filter(D, A, PF, mapsort).
  449%
  450principal_filter(D, A, PF, []):- !, principal_filter_(D, A, PF).
  451principal_filter(D, A, PF, G):- principal_filter_(D, A, PF0),
  452								call(G, PF0, PF).
  453%
  454principal_filter_(D, A, PF):- select(A, D, D0), !,
  455	powerset(D0,  PD),
  456	maplist(cons(A), PD, PF0),
  457	maplist(sort, PF0, PF).
  458principal_filter_(_, _, []).
  459
  460%
  461cons(X,Y,[X|Y]).
  462
  463%
  464meet(X, Y):- member(A, X), member(A, Y).
  465
  466% ?- image([a-v, b-u], [a,b], S).
  467image(F, X, S):- fun_image(X, F, S0, []),
  468				 sort(S0, S).
  469
  470%
  471fun_image([], _, S, S).
  472fun_image([X|Y], F, [X0|S], T):- memberchk(X-X0, F), !,
  473	fun_image(Y, F, S, T).
  474fun_image([_|Y], F, S, T):- fun_image(Y, F, S, T).
  475
  476% ?- inverse([a-x, b-y], R).
  477inverse([], []).
  478inverse([X-Y|R], [Y-X|R0]):-
  479	inverse(R, R0).
  480
  481% ?- inverse_image([a-x, b-y, c-y, d-z], [x, y], U).
  482inverse_image(F, Y, U):-
  483	inverse_image(F, Y, V, []),
  484	sort(V, U).
  485%
  486inverse_image([], _, U, U).
  487inverse_image([X-Y|Fs], P, [X|U], V):-	memberchk(Y, P), !,
  488	inverse_image(Fs, P, U, V).
  489inverse_image([_|Fs], P, U, V):-
  490	inverse_image(Fs, P, U, V).
  491
  492% Not mine but from SWI-Prolog mailing list.
  493term_size(Term, Size) :-
  494    setup_call_cleanup(
  495        (
  496            current_prolog_flag(gc, Bool),
  497            set_prolog_flag(gc, false)
  498        ),
  499        (
  500            statistics(globalused, Used0),
  501            duplicate_term(Term, _TermCp),
  502            statistics(globalused, Used1),
  503            Size is Used1 - Used0
  504        ),
  505        set_prolog_flag(gc, Bool)
  506    )