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