% Exercise 4.10 (parser) and 4.11 (building LF)

% Derived from Program 4.2, PS p. 102. by Eric Auer
% CG DCG producing logical forms.

% Note: run sample(X) with some ; ; ; to test this.

% Using Moortgat style: under is input
% as opposed to PS style: left is input

/*
   Categories:          PN = NP
   VITR = NP \ S        (PS syntax: S\NP)
   VTR =  (NP \ S) / NP (PS syntax: (S\NP)/NP)

   LF:                  PN: terry = terry'
   VITR: halts = halts'(arg)
   VTR: wrote = wrote'(arg1,arg2)

   LF building:
   node(in \ out) = node(out / in) = node'(in')
   (PS syntax: in \ out = in / out = ...)
*/

:- op(500, xfy, \).
:- op(500, xfy, /).

:- dynamic(sublist/1).
:- dynamic(listdone/1).

% ****************************************

% because not everything has arity 1, we cannot simply do:
% app(Out,LFo) --> { lex(W,(Out/In),LFw) },
%  [W], app(In,LFi), { functor(LFo,LFw,1), arg(1,LFo,LFi) }.

app(Cat,LF) --> { lex(Word, Cat, LF) },
  [Word].

app(OutCat,OutLF) --> { sub(InCat), sub(InCat\OutCat) },
   app(InCat,InLF),
   app(InCat\OutCat,InLF^OutLF).

app(OutCat,OutLF) --> { sub(InCat), sub(OutCat/InCat) },
   app(OutCat/InCat,InLF^OutLF),
   app(InCat,InLF).

% ****************************************

lex(shrdlu, np, shrdlu).
lex(bertrand, np, bertrand).
lex(terry, np, terry).
lex(halts, np \ s, X^halt(X)).
lex(wrote, np\s/np, X^Y^write(X,Y)).
lex(met, np\s/np, X^Y^meet(X,Y)).

% ****************************************

% type must be derivable to be allowed to occur as a sub:
% this is my way to avoid infinite loops. sigh...

% optimized using assert:
% if there is no list, generate a complete list,
% if there is a list, use it.

sub(_) :- \+ listdone(1), retractall(sublist/1),
   write('Generating sublist... '),
   bagof(Q,subA(Q),_Bag), % no setof needed to avoid duplicates,
                          % see below for the reason :-)
   write('done'),nl,
   assert(listdone(1)), fail. % fail to avoid double readings

sub(X) :- listdone(1), sublist(X). % use the list if available

subA(X) :- lex(_,X,_), addlist(X).
subA(X) :- lex(_,X/Y,_), lex(_,Y,_), addlist(X).
subA(X) :- lex(_,Y\X,_), lex(_,Y,_), addlist(X).

% a trivial macro to avoid duplicates:
addlist(X) :- ( sublist(X) -> true ; assert(sublist(X)) ).

% ****************************************

% the non-asserting version is here, shown for reference:

subold(X) :- lex(_,X,_).
subold(X) :- lex(_,X/Y,_), lex(_,Y,_).
subold(X) :- lex(_,Y\X,_), lex(_,Y,_).

% ****************************************

sample(1) :- phrase(app(s,X), [shrdlu,halts]),
  write(X), nl.
sample(2) :- phrase(app(s,X), [terry,wrote,shrdlu]),
  write(X), nl.