/*firstgram.fit
  adapted by PB from Graham Wilcock's version, in SW09-Grammar1.fit*/

/*******************************************************/
/*                 GramKit SW9-HPSG1                   */
/*      Implementing Sag & Wasow 1999 (Chapter 9)      */
/*       in ProFIT for GramKit parser/generator        */
/*                                                     */
/*  Graham Wilcock   (graham@ccl.umist.ac.uk)   98/12  */
/*******************************************************/

:- multifile '--->'/2.
:- op(1200, yfx, --->).
:- use_module(lists, library(lists), [append/3, 
				      is_list/1,
				      reverse/2,
				      permutation/2]).

/*******************************************************/
/*       Sort Hierarchy and Feature Declarations       */
/*******************************************************/

top > [feat_struc].
  feat_struc > [synsem_struc, agr_cat, gram_cat, val_cat, 
                pos, sem_struc, pred, ind].
    synsem_struc > [phrase, lex_item]
                 intro [phon, syn:gram_cat, sem:sem_struc].
      lex_item > [word, lxm]
               intro [arg_st].
        lxm > [const_lxm, infl_lxm].
          const_lxm > [prep_lxm, adj_lxm, adv_lxm, conj_lxm].
            prep_lxm > [pdp_lxm, mkp_lxm].
          infl_lxm > [noun_lxm, verb_lxm].
            noun_lxm > [pron_lxm, pn_lxm, cn_lxm].
            verb_lxm > [iv_lxm, tv_lxm]. 
              tv_lxm > [stv_lxm, dtv_lxm].
    agr_cat fin_dom [m,f,n] * [sg,pl] * [1,2,3].
    gram_cat intro [head:pos, val:val_cat].
    val_cat intro [comps, spr].
    pos > [verb, adv, adj, conj, prep, nom]
        intro [form, mod].
      nom > [noun, det]
          intro [agr:agr_cat].
        noun intro [case, ana].
	det  intro [count].
      prep intro [p_obj].
    sem_struc intro [mode, index, restr].
    pred > [inst, arg, two_arg, name, sit]
         intro [reln, sit].
      inst intro [inst].
      arg  intro [arg].
      two_arg intro [arg1, arg2].
      name intro [name, named].
      sit > [give, love, see, walk]. 
	give intro [giver, recip, gift].
	love intro [lover, loved].
	see  intro [seer, seen].
	walk intro [walker].


/******************************/
/*     HPSG Principles        */
/******************************/

/* Head Feature Principle */

'HFP1' := (syn!head!HF ---> [syn!head!HF|_]).
'HFP2' := (syn!head!HF ---> [_,syn!head!HF|_]).

/* Valence Principle */

'VALP1' := (syn!val!spr!Spr  ---> [syn!val!spr!Spr|_]).
'VALP2' := (syn!val!comps![] ---> [_,syn!val!comps![]|_]).

/* Semantics Principle */

'SemP1' := (sem!(mode!M & index!I) ---> [sem!(mode!M & index!I)|_]).
'SemP2' := (sem!(mode!M & index!I) ---> [_,sem!(mode!M & index!I)|_]).

'Restr1' := (sem!restr!R0-RN ---> [sem!restr!R0-RN]).
'Restr2' := (sem!restr!R0-RN ---> [sem!restr!R0-R1,sem!restr!R1-RN]).
'Restr3' := (sem!restr!R0-RN ---> [sem!restr!R0-R1,sem!restr!R1-R2,sem!restr!R2-RN]).

/* Phon Concatenation */

'Phon1' := (phon!P0-PN ---> [phon!P0-PN]).
'Phon2' := (phon!P0-PN ---> [phon!P0-P1,phon!P1-PN]).
'Phon3' := (phon!P0-PN ---> [phon!P0-P1,phon!P1-P2,phon!P2-PN]).

/*******************************************************/
/*               Phrase Structure Rules                */
/*******************************************************/

/******************************/
/* Head-Specifier Rule        */
/******************************/

@'Phon2' & @'HFP2' & @'VALP2' & @'SemP2' & @'Restr2' & (
<phrase & syn!val!spr![]
--->
    [ Spr,
      <phrase & syn!val!spr![Spr] ]).

/******************************/
/* Head-Complement Rule       */
/******************************/

@'Phon1' & @'HFP1' & @'VALP1' & @'SemP1' & @'Restr1' & (
<phrase & syn!val!comps![]
--->
    [ <word & syn!val!comps![] ]).

@'Phon2' & @'HFP1' & @'VALP1' & @'SemP1' & @'Restr2' & (
<phrase & syn!val!comps![]
--->
    [ <word & syn!val!comps![Comp],
      Comp & <phrase ]).

@'Phon3' & @'HFP1' & @'VALP1' & @'SemP1' & @'Restr3' & (
<phrase & syn!val!comps![]
--->
    [ <word & syn!val!comps![Comp1,Comp2],
      Comp1 & <phrase,
      Comp2 & <phrase ]).


/*******************************************************/
/*                       Lexicon                       */
/*******************************************************/

dict(Lex, <word &
     phon![Lex|P]-P & syn!Syn & arg_st!ArgSt & 
     sem!(mode!M & index!I & restr![Pred|R]-R)) 
:-
        lex(Lex, <word &
	    syn!Syn & arg_st!ArgSt & sem!(mode!M & index!I & restr![Pred])).

dict(Lex, <word &
     phon![Lex|P]-P & syn!Syn & arg_st!ArgSt &
     sem!(mode!M & index!I & restr!R-R)) 
:-
        lex(Lex, <word &
	    syn!Syn & arg_st!ArgSt & sem!(mode!M & index!I & restr![])).

/******************************/
/*  Abbreviation Templates    */
/******************************/

'N'   := <word   & syn!head!<noun.
'NP'  := <phrase & syn!(head!<noun & val!(spr![]      & comps![])).   
'NP'(acc) := <phrase & syn!(head!case!acc & val!spr![]).


'V'  := <word   & syn!head!<verb.
'VP' := <phrase & syn!(head!<verb & val!(spr![@'NP'] & comps![])).    
'S'  := <phrase & syn!(head!<verb & val!(spr![]      & comps![])).    


np(Case, Index) := <phrase &
		   syn!(head!case!Case &
		        val!(spr![] & comps![])) &
		   sem!index!Index.


/******************************/
/*  Nominal Lexeme Templates  */
/******************************/

noun_lxm := <noun_lxm &
	syn!head!(<noun & mod!none & ana!-) &
	sem!mode!ref.                     



/******************************/
/*  Proper Nouns              */
/******************************/

% Proper Noun Lexeme Template    
pn_lxm(Name) := <pn_lxm & @noun_lxm &
	syn!(head!agr!(3&sg) &
	     val!(spr![] & comps![])) &
	arg_st![] &
	sem!(index!I & restr![reln!name & name!Name & named!I]).

% Proper Noun Lexical Rule
lex(Name, <word & syn!Syn & arg_st!Arg_St & sem!Sem)
:-
	lex(Name, @pn_lxm(_) & syn!Syn & arg_st!Arg_St & sem!Sem).

% Proper Noun Lexeme List
lex('Dana', @pn_lxm('Dana')).
lex('John', @pn_lxm('John')).
lex('Kim',  @pn_lxm('Kim')).
lex('Pat',  @pn_lxm('Pat')).
lex('Sandy',@pn_lxm('Sandy')).


/******************************/
/*  Main Verbs                */
/******************************/

% Verbal Lexeme Templates             
verb_lxm := <verb_lxm &
	syn!(head!(<verb & mod!none) &
             val!(spr![Subj] &
		  comps!Comps)) &
	arg_st![Subj & _X|Comps] &	%changed by PB, 18/1/00
	sem!(mode!prop &
	     index!Sit &
	     restr![sit!Sit|_]).

iv_lxm := <iv_lxm & @verb_lxm &
	arg_st![_Subj].                   

tv_lxm := <tv_lxm & @verb_lxm &
	arg_st![_Subj, @'NP'|_].          

stv_lxm := <stv_lxm & @tv_lxm &
	arg_st![_Subj, _Obj].             

dtv_lxm := <dtv_lxm & @tv_lxm &
	arg_st![_Subj, _Obj, @'NP'].      


	
%  Verb Lexeme List

lex(give, @dtv_lxm &
	arg_st![@np(_,I), @np(acc,J), @np(acc,K)] &
        sem!restr![reln!give & giver!I & recip!J & gift!K]).

lex(love, @stv_lxm &
	arg_st![@np(_,I),@np(acc,J)] &
        sem!restr![reln!love & lover!I & loved!J]).

lex(see, @stv_lxm &
	arg_st![@np(_,I),@np(acc,J)] &
        sem!restr![reln!see & seer!I & seen!J]).

lex(walk, @iv_lxm &
	arg_st![@np(_,I)] &
	sem!restr![reln!walk & walker!I]).
	     

% Present 3sg Lexical Rule
lex(Verb3sg, <word &
        syn!(head!(<verb & mod!Mod & form!fin) &
             val!(Val & spr![syn!head!(case!nom & agr!(3&sg))])) &
	arg_st!Arg_St &
        sem!(restr!Restr & index!Index))
:-
	lex(VerbBase, @verb_lxm &
        	syn!(head!(<verb & mod!Mod & form!inf) &
        	     val!Val) &
		arg_st!Arg_St &
	        sem!(restr!Restr & index!Index)),
	morph_3sg(VerbBase, Verb3sg).

% Past Lexical Rule
lex(VerbPast, <word &
        syn!(head!(<verb & mod!Mod & form!fin) &
             val!(Val & spr![syn!head!case!nom])) &
	arg_st!Arg_St &
        sem!Sem)
:-
	lex(VerbBase, @verb_lxm &
        	syn!(head!(<verb & mod!Mod & form!inf) &
        	     val!Val) &
		arg_st!Arg_St &
	        sem!Sem),
	morph_past(VerbBase, VerbPast).

% Morphological Function for 3rd Singular Present
morph_3sg(be, is) :- !.
morph_3sg(have, has) :- !.
morph_3sg(VerbBase, Verb3sg) :-
	atomic(VerbBase),
	name(VerbBase, SpellBase),
	reverse(SpellBase, RevBase),
	reverse_3sg(RevBase, Rev3sg),
	reverse(Rev3sg, Spell3sg),
	name(Verb3sg, Spell3sg).

reverse_3sg([0'o|Rev], [0's,0'e,0'o|Rev]) :- !.
reverse_3sg([0'y,0'e|Rev], [0's,0'y,0'e|Rev]) :- !.
reverse_3sg([0'y|Rev], [0's,0'e,0'i|Rev]) :- !.
reverse_3sg([0's|Rev], [0's,0'e,0's|Rev]) :- !.
reverse_3sg([0'x|Rev], [0's,0'e,0'x|Rev]) :- !.
reverse_3sg(Rev, [0's|Rev]).

% Morphological Function for Past
morph_past(be, was) :- !.
morph_past(give, gave) :- !.
morph_past(have, had) :- !.
morph_past(hit, hit) :- !.
morph_past(know, knew) :- !.
morph_past(run, ran) :- !.
morph_past(see, saw) :- !.
morph_past(swim, swam) :- !.
morph_past(write, wrote) :- !.
morph_past(VerbBase, VerbPast) :-
	atomic(VerbBase),
	name(VerbBase, SpellBase),
	reverse(SpellBase, RevBase),
	reverse_past(RevBase, RevPast),
	reverse(RevPast, SpellPast),
	name(VerbPast, SpellPast).

reverse_past([0'o|Rev], [0's,0'e,0'o|Rev]) :- !.
reverse_past([0'y,Vowel|Rev], [0'd,0'e,0'y,Vowel|Rev]) :- vowel(Vowel), !.
reverse_past([0'y|Rev], [0'd,0'e,0'i|Rev]) :- !.
reverse_past([0'e|Rev], [0'd,0'e|Rev]) :- !.
reverse_past(Rev, [0'd,0'e|Rev]).





vowel(0'a). vowel(0'e). vowel(0'i). vowel(0'o). vowel(0'u).

/*******************************************************/
/*       Interface for GramKit parser/generator        */
/*******************************************************/

lookup_word(Word, Sign) :-
	dict(Word, Sign).


lookup_term(Pred, Word, Sign) :-
	dict(Word, Sign & sem!restr![Pred|R]-R),
	\+ empty_sem(Word, Sign).

empty_sem(Word, Sign) :-
	dict(Word, Sign & sem!restr!R1-R2),
	R1 == R2.

semantics(sem!(index!Index & restr!Restr-[]), Restr).

string(phon!Phon-[], Phon).

/*******************************************************/
/*      Interface for tree formatter/printer           */
/*******************************************************/

format_tree_node(In, Out) :-
	node_format(In, Out).


node_format(@'N',   'N').
node_format(@'NP',  'NP').


node_format(@'V'  & syn!head!form!Form, 'V'(Form)).
node_format(@'VP' & syn!head!form!Form, 'VP'(Form)).
node_format(@'S'  & syn!head!form!Form, 'S'(Form)).


node_format(In, Functor) :- functor(In, Functor, _).

/*******************************************************/
/*      Interface for semantics printer                */
/*******************************************************/

gensym_sem(restr!Preds-[]) :-	% MRS structure
	gensym_refs(Preds).
gensym_sem([Rel|Rels]) :-	% MRS list (Liszt)
	gensym_refs([Rel|Rels]).

gensym_refs([]).
gensym_refs([Rel|Rels]) :-
	gensym_ref(Rel),
	gensym_refs(Rels).

gensym_ref(name!Name & named!Ref) :- gensym_init(Name, Ref), !.
gensym_ref(reln!Reln & inst!Ref) :-  gensym_init(Reln, Ref), !.
gensym_ref(reln!Reln & sit!Ref) :-   gensym_init(Reln, Ref), !.
gensym_ref(_).

gensym_init(Lexeme, Var) :-
        atom(Lexeme),
        var(Var),
        name(Lexeme, [L|_]),
        (L > 90 -> C is L - 32
                 ; C = L),
        name(Root, [C]),
        gensym(Root, Var).

/*******************************************************/
/* gensym/2                  (from Clocksin & Mellish) */
/*******************************************************/

gensym(Root,Atom) :-
        getNum(Root,Num),
        name(Root,Name1),
        numeral(Num,Name2),
        append(Name1,Name2,Name),
        name(Atom,Name).

getNum(Root,Num) :-
        retract(current_num(Root,Num1)),!,
        Num is Num1+1,
        asserta(current_num(Root,Num)).
getNum(Root,1) :- asserta(current_num(Root,1)).

numeral(Int,List) :- numeral(Int,[],List).
numeral(I,Sofar,[C|Sofar]) :-
        I < 10,!, C is I + 48.
numeral(I,Sofar,List) :-
        Tophalf is I//10,        % '//' for integer in Sicstus.
        Bothalf is I mod 10,
        C is Bothalf+48,
        numeral(Tophalf,[C|Sofar],List).

/*******************************************************/
/*          End of GramKit Grammar 1                   */
/*******************************************************/