/*  ProGram - LIB PRS

    PRS is a stand-alone version of the ProGram parser. It provides a single
    predicate prs/0 which parses phrases from standard input and writes the
    results to standard output. All data modules (features, normed idrules
    etc.) must be reconsulted EXPLICITLY before the parser is called). The
    only switches operative are ONEPARSE, NOCONJ, NOFOOT, NOLEX. These all
    default to off - asserting the (atomic) clause in the database switches
    them on. See *PRS

    The code below is all cut down versions of main system modules - see the
    originals for comments etc.
*/

:- op(250,fx,feature),
   op(250,fx,boolean),
   op(250,fx,syncat),
   op(200,xfy,controls),
   op(200,fx,+),
   op(200,fx,-),
   op(200,fx,~).

/* -- bits from parse.pl -------------------------------------------------- */

prs :-
        setuppaths,
        repeat,
        t_read(S),
        ( S = end_of_file; S = [end]
          ;
          parse_string(S),fail).

parse_string(S) :- find_parse(S,Result),display_parse(Result),!.

find_parse([],[]) :- !.
find_parse([H|T],[NH|NT]) :-
        find_parse(T,NTT),
        lexcat(H,LC),
        tryrule(LC,NTT,NH,NT).

tryrule(H,T,NH,NT) :-
        rulefor([H|T],NH1,NT1),
        tryrule(NH1,NT1,NH,NT).
tryrule(H,T,H,T).

display_parse([Tree]) :-
        Tree = node(_,C,_),
        not(nrac(C)),
        f_write(Tree),
        !,
        oneparse.

lexcat(Word,node({N},Cat,Word)) :- !,
        lexrule(Word,lex(N),Cat),
        freeze(Cat),
        not(nfcr(Cat)).

rulefor(Input,node(R,M,Used),IRem) :- !,
        getidrule(Input,R,M,DL),
        tryidrule(Input,M,DL,Used,IRem,R).

getidrule(Input,R,M,DL) :- !,
        checklexcat(Input,Rulename),
        baserule(Rulename,HL,M,DL,_),
        nodename(HL,Rulename,R,M).

checklexcat([node({N},_,_)|_],M) :- not(nolex),!,clc(N,M).
checklexcat(_,_).

clc(N,N) :- (integer(N);atomic(N)),!.
clc(N,M) :- functor(N,M,_);functor(N,P,Q),functor(M,P,Q).

tryidrule(Input,M,DL,Used,IRem,_) :-
        ffp1(M,MF,MFOld),
        rulematch(Input,DL,_,Used,IRem,[],DFoot),
        ffp2(DFoot,MFOld,MF),
        crp(M,Used),
        freeze(M),
        not(nfcr(M)).

nodename(no,R,R,M) :- !.
nodename(H,R,A,M) :- append(H,[R],A).

rulematch([Node|CL], D, M, [Node|U], IRem, LCats, Foot) :-
        arg(2,Node,C),
        matchd(D,C,M,FInc),
        FInc = Foot,
        lp_check(LCats,C),
        rulematch(CL,D,M,U,IRem,[C|LCats],Foot).
rulematch(C,D,M,[],C,_,_) :- neednone(M,D).

lp_check([],C) :- !.
lp_check([LC|Cats],C) :- not(lp(C,LC)),!,lp_check(Cats,C).

matchd([c(Tag,Hd,Lv,Type,D)|Tl],C,[M|Ml],FInc) :-
        setmark(M,Type),
        not(not(C=D)),
        copycat(Type,D,D1),
        getfootinc(D1,C,FInc),
        fcdflag(C,Flag),
        C=[FN|_],
        fcd(C,D1,Hd,Tag,Lv,C,Flag,FN)
        ;
        matchd(Tl,C,Ml,FInc).

copycat(Type,D,D) :- (Type=no;Type=opt),!.
copycat(Type,D,D1) :- copy(D,D1),!.

setmark(M,Type) :- var(M),!,((Type=no;Type=opt),M=dead;M=ok),!.
setmark(ok,_).

neednone(M,[]) :- !.
neednone([M|Ml],[c(_,_,_,T,D)|B]) :-
        (nonvar(M);T=opt;T=star),!,neednone(Ml,B).

freeze(C) :-
    (pathfor(foot,C,[['~']]);true),!,
    (pathfor(conj,C,[['~']]);true),!,
    freeze2(C).

freeze2(unspec) :- !.
freeze2([F|A]) :- !,freezelist(A),!.

freezelist([]) :- !.
freezelist([H|T]) :- !,freeze2(H),!,freezelist(T),!.

fcrtest(X,Y) :- !,call(X),!,not(Y),!.

/* -- bits from ffp.pl ---------------------------------------------------- */

ffp1(_,_,_) :- nofoot,!.
ffp1(M,[foot|MF],[foot|MFOld]) :-
        pathfor(foot,M,MF),!,
        copy(MF,MFOld),!.
ffp1(_,_,_) :- !.

ffp2(_,_,_) :- nofoot,!.
ffp2(DIncs,MOld,MNew) :-
        inc(MOld,MNew,MInc,_),
        ext(DIncs,MInc),
        DIncs = MNew,!.

getfootinc(_,_,_) :- nofoot,!.
getfootinc(D,C,[foot|IL]) :-
        pathfor(foot,D,DF),
        pathfor(foot,C,CF),!,
        (  CF=[['~']];
           inclist(DF,CF,IL,_)
        ),!.
getfootinc(_,_,_).

inc(X,Y,I,F) :- ivar(Y),!,var(X).
inc(X,Y,I,F) :- var(X),!,(ivar(Y);copy(Y,I),F=ok),!.
inc([F|A1],[F|A2],I,Flag) :-
        inclist(A1,A2,IL,Flag),
        (var(Flag);I=[F|IL]),!.

ivar(X) :- var(X),!.
ivar(unspec).

inclist(L1,L2,L3,_) :-
        ( var(L2);
          var(L1),copy(L2,L3)
        ),!.
inclist([],[],[],_).
inclist([H1|T1],[H2|T2],[H3|T3],F) :-
        inc(H1,H2,H3,F2),!,
        inclist(T1,T2,T3,F),!,
        F=F2.

ext(X,Y) :- X==Y,!.
ext(X,Y) :- var(X),!,var(Y),X=Y,!.
ext(X,Y) :- var(Y),!,X=Y,!.
ext([F|A1],[F|A2]) :- !,extlist(A1,A2),!.

extlist([],[]) :- !.
extlist([H1|T1],[H2|T2]) :- !,ext(H1,H2),!,extlist(T1,T2),!.


/* -- bits from crp.pl ---------------------------------------------------- */

crp(_,_) :- noconj,!.
crp(M,D) :- conjcats(D,DC),(DC=[],!;allext(M,DC)),!.

conjcats([H|T],A) :- !,
        (  H=node(_,F,_),pathfor(conj,F,C),not(C=[['~']]),A=[F|TT]
           ;
           A=TT ),!,
        conjcats(T,TT).
conjcats(_,[]).

allext(M,DList) :-
        (strip(DList,F,AList); F=unspec),
        ae1(M,F,AList).

ae1([conj,['~']],conj,_) :- !.
ae1(unspec,unspec,_) :- !.
ae1(M,F,AList) :-
        M = [F|A],
        allextlist(A,AList).

strip([],_,[]).
strip([[F|Args]|T],F,[Args|TT]) :- strip(T,F,TT),!.
strip([unspec|T],unspec,[[]|TT]) :- strip(T,unspec,TT),!.

allextlist([A|T],Alist) :-
        splitlist(Alist,Hds,Tls),!,
        allext(A,Hds),
        allextlist(T,Tls).
allextlist([],_) :- !.

splitlist([],[],[]) :- !.
splitlist([[H|T]|T2],[H|T3],[T|T4]) :- splitlist(T2,T3,T4),!.

/* -- bits from fcd.pl ---------------------------------------------------- */

fcdflag(C,F) :- pathfor(conj,C,Conjcoeff),!,
                (Conjcoeff=[['~']], F=yes; F=no),!.
fcdflag(C,yes) :- !.

fcd(unspec,B,_,_,_,_,_,_) :- !,var(B),!.
fcd([lexical|N],[lexical|N],_,_,_,_,_,lexical) :- !.
fcd(FA,FB,H,T,L,CT,F,FName) :-
        FA=[FName|FLA],
        ( FName = foot ;
          FName = head, nonvar(H) ;
          FName = agr, nonvar(T)),
        !,
        FB=[FName|FLB],!,
        fcdlist(FLA,FLB,H,T,L,CT,no,FName),!.
fcd([FN|A],[G|B],H,T,L,CT,F,FN) :-
        nonvar(G),
        FN=G,!,
        fcdlist(A,B,H,T,L,CT,F,FN),!.
fcd([F|A],[F|B],H,T,Lev,CT,yes,F) :-
        nfcd(F,_,_,_,_),!,
        fcdtest(F,Lev,CT),!,
        fcdlist(A,B,H,T,Lev,CT,yes,F),!.
fcd([FN|A],[FN|B],H,T,L,CT,F,FN) :- !,fcdlist(A,B,H,T,L,CT,F,FN),!.

fcdtest(F,[lexical|_],CT) :- !,nfcd(F,CT,C,C,_),!.
fcdtest(F,_,CT) :- !,nfcd(F,CT,C,_,C),!.

fcdlist(L1,L2,H,T,L,CT,F,FN) :- !,
        (getfeatspec(FN,FNA); FNA=['~']),
        fcdlist2(L1,L2,H,T,L,CT,F,FNA),!.

fcdlist2([],[],_,_,_,_,_,[]) :- !.
fcdlist2([H1|T1],[H2|T2],H,T,L,CT,F,[FNH|FNT]) :-
        fcdsplit(FNH,FNH2),
        fcd(H1,H2,H,T,L,CT,F,FNH2),!,
        fcdlist2(T1,T2,H,T,L,CT,F,FNT),!.

fcdsplit({L},M) :- !,cmember(M,L).
fcdsplit(L,L) :- !.

/* -- miscellaneous bits (from monitor.pl etc.) --------------------------- */

oneparse :- fail.
noconj :- fail.
nofoot :- fail.
nolex :- fail.

t_read(X) :- get0(C),(C = 26,X=end_of_file; t_read(X,C)),!.

    t_read([],C) :- t_term(C),!.
    t_read(X,C) :- t_sep(C),!,get0(C1),t_read(X,C1).
    t_read([X|Y],C) :- get0(C2),t_read(XN,C,C2,CN),name(X,XN),t_read(Y,CN).

    t_read([C],C,C2,C2) :- t_sep(C2),!.
    t_read([C|N],C,C2,CN) :- get0(C3),t_read(N,C2,C3,CN).

    t_sep(C) :- C < 33.
    t_term(C) :- C=10;C=26.

f_write(X) :- write(X),write('.'),nl.

featname(X) :- (atom(X);integer(X)),!.

getfeatspec(N,A) :- feature [N|A],!.
getfeatspec(N,[{'+','-'}]) :- boolean N,!.
getfeatspec(N,[]).

setuppaths :-
        retractall(pathfor(_,_,_)),
        retractall(premajor(_,_,_)),
        getpremajor(PM),
        getpaths([foot],[]),
        getpaths([conj],[cat]),
        getpaths([PM,cat,lexical,bar,head,major,agr],[foot]).

path(F,_,_,_,_,E) :- member(F,E),!,fail.
path(F,Fl,[F|C],F,C,E) :- member(F,Fl).
path({A},Fl,P,F,C,E) :- cmember(V,A),path(V,Fl,P,F,C,E).
path(F,Fl,[F|P],FA,C,E) :-
        getfeatspec(F,Args),
        paths(Args,Fl,P,FA,C,E).

paths([H|T],Fl,[PH|PT],F,C,E) :-
        path(H,Fl,PH,F,C,E);
        paths(T,Fl,PT,F,C,E).

getpaths(Targets,Excl) :-
        syncat(Top),
        path(Top,Targets,P,T,C,Excl),
        assert(pathfor(T,P,C)),
        fail.
getpaths(_,_).

getpremajor(F) :-
        feature([F|A]),member(major,A),!,
        setmajorarg(A,L,Arg),
        assert(premajor(F,L,Arg)).
getpremajor(nopremajor). /* dummy vaule if no major feature found */

setmajorarg([],[],_).
setmajorarg([major|T],[H|TT],H) :- !,setmajorarg(T,TT,_).
setmajorarg([H|T],[HH|TT],X) :- setmajorarg(T,TT,X).

once(X) :- call(X),!.

member(X,[X| _ ]).
member(X,[ _ |Y]) :- member(X,Y).

cmember(X,(A,B)) :- !,(X=A;cmember(X,B)).
cmember(X,X).

closelist([]) :- !.
closelist([H|T]) :- closelist(T).

copy(X,Y) :- var(X),!.
copy(unspec,unspec) :- !.
copy([F|A1],[F|A2]) :- !,copylist(A1,A2),!.

copylist(X,Y) :- var(X),!.
copylist([],[]) :- !.
copylist([H1|T1],[H2|T2]) :- !,copy(H1,H2),!,copylist(T1,T2),!.

/* -- default clauses etc. ------------------------------------------------ */

feature(X) :- mishap("Features not loaded",[]).
syncat(X)  :- mishap("No syncats specified",[]).
boolean(X) :- fail.
premajor(X,Y,Z) :- fail.
