%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  File:  grammar8.pl
%
%  Course:  HPSG Grammars in ALE
%
%  Purpose:  1.  Lexical Rules for inflectional verb form(s)
%            2.  CELR and SELR to replace traces
%            3.  Introduces passive lexical rule
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%**********************  Type Hierarchy

bot cons bot.

bot sub [sign,list,set,cat,head,vform,boolean,mod_synsem, 
         loc,nonloc,cont,marking,sl].

mod_synsem sub [synsem,none].                

synsem sub [pre_mod_synsem, post_mod_synsem]  
   intro [loc:loc,
          nonloc:nonloc].

pre_mod_synsem sub [].
post_mod_synsem sub [].
none sub [].

loc sub []
   intro [cat:cat,
          cont:cont].            

cont sub [].

nonloc sub []
   intro [inherited:sl,
          tobind:sl].

sl sub []
  intro [slash:set].

set sub [e_set,ne_set].

ne_set sub []
   intro [elt:loc,
          elts:set].

e_set sub [].

sign sub []
   intro [synsem:synsem].

cat sub []
   intro [head:head,
          subj:list,
          comps:list,
          spr:list,
          marking:marking].

marking sub [marked, unmarked].

marked sub [comp,conj].

comp sub [that,for].

that sub [].
for  sub [].

conj sub [].

unmarked sub [].
                                
head sub [subst,func].
                      
subst sub [noun,verb,adj]             
    intro [prd:boolean,               
           mod:mod_synsem].           

func sub [mark,det]   
  intro [spec:synsem].

noun sub [].
det sub [].
adj sub [].
mark sub [].

verb sub []
  intro [vform:vform,
         aux:boolean,
         inv:boolean].

boolean sub [yes,no].

yes sub [].
no sub [].

vform sub [fin,inf,pas,bse].

fin sub [].
pas sub [].
inf sub [].
bse sub [].

list sub [e_list,ne_list].

ne_list sub []
   intro [hd:bot,
	  tl:list].

e_list sub [].

%%%**********************  Macros

np macro                        
  loc:cat:(head:noun,         
       comps:[],
       subj:[],
       spr:[],
       marking:unmarked).

nbar macro                     
  loc:cat:(head:noun,                 
       comps:[],
       subj:[],
       spr:[_],
       marking:unmarked).

detp macro                    
  loc:cat:(subj:[],
       comps:[],
       spr:[],
       head:det,
       marking:unmarked).

comp macro                    
  loc:cat:marking:comp.

marking(Marking) macro
   loc:cat:marking:Marking.

s macro
  loc:cat:(head:verb,
       comps:[],
       subj:[]).

vp macro                      
  loc:cat:(head:verb,
       comps:[],
	 subj:[_]).

noslash macro
   nonloc:(inherited:slash:e_set,
           tobind:slash:e_set).

%%%**********************  Lexical Entries

%%**********  Nouns

kim ---> (synsem:(@ np,                      
                  loc:cat:head:mod:none,
                  @ noslash)).
                                             
sandy ---> (synsem:(@ np,
                  loc:cat:head:mod:none,
                  @ noslash)).

books --->  (synsem:(@ np,
                  loc:cat:head:mod:none,
                  @ noslash)).

book ---> (synsem:(@ nbar,
                  loc:cat:head:mod:none,
                  @ noslash)).

%%**********  Adjectives

red ---> (synsem:(loc:cat:(head:(adj,                   
                                mod:(pre_mod_synsem,
                                     @ nbar)),
                          spr:[],
                          subj:[],
                          comps:[],
                          marking:unmarked),
                  @ noslash)).

%%**********  Adverbs

definitely ---> (synsem:(loc:cat:(head:(adj,
                                        prd:no,
                                        mod:(@ vp,
                                             @ marking(unmarked))),
                                 spr:[],
                                 subj:[],
                                 comps:[],
                                 marking:unmarked),
                         @ noslash)).

%%**********  Determiners

the ---> (synsem:(loc:cat:(head:(det,
                                spec:(@ nbar)),
                          spr:[],
                          subj:[], 
                          comps:[],
                          marking:unmarked),
                  @ noslash)).

%%**********  Main Verbs

snore ---> (synsem:(loc:cat:(head:(verb,
		 	          mod:none,
                                  vform:bse,
                                  aux:no,
                                  inv:no),
                            subj:[(@ np)],
                            comps:[],
                            spr:[(@ comp)],
                            marking:unmarked),
                    @ noslash)).

like ---> (synsem:(loc:cat:(head:(verb,
			       mod:none,
                               vform:bse,
                               aux:no,
                               inv:no),
                           subj:[(@ np)],
                           comps:[(@ np)],
                           spr:[(@ comp)],
                           marking:unmarked),
                   @ noslash)).

give ---> (synsem:(loc:cat:(head:(verb,
			         mod:none,
                                 vform:bse,
                                 aux:no,
                                 inv:no),
                           subj:[(@ np)],
                           comps:[(@ np),(@ np)],
                           spr:[(@ comp)],
                           marking:unmarked),
                   @ noslash)).

believe ---> (synsem:(loc:cat:(head:(verb,
				     mod:none,
                                     vform:bse,
                                     aux:no,
                                     inv:no),
                               subj:[(@ np)],
                               comps:[(@ s)],
                               spr:[(@ comp)],
                               marking:unmarked),
                      @ noslash)).

%%**********  Auxiliary Verbs

can ---> (synsem:(loc:cat:(head:(verb,
			      mod:none,
                              vform:fin,
                              aux:yes),
                          comps:[(@ vp,
                                  loc:cat:(subj:Subj,
		                           head:vform:bse))],
                          subj:Subj,
                          spr:[(@ comp)],
                          marking:unmarked),
                  @ noslash)).

does ---> (synsem:(loc:cat:(head:(verb,
	                          mod:none,
                                  vform:fin,
                                  aux:yes),
                            comps:[(@ vp,
                                    loc:cat:(subj:Subj,
	                                     head:vform:bse))],
                            subj:Subj,
                            spr:[(@ comp)],
                            marking:unmarked),
                    @ noslash)).

was ---> (synsem:(loc:cat:(head:(verb,
	                         mod:none,
                                 vform:fin,
                                 aux:yes),
                           comps:[(@ vp,
                                   loc:cat:(subj:Subj,
	                                    head:vform:pas))],
                           subj:Subj,
                           spr:[(@ comp)],
                           marking:unmarked),
                    @ noslash)).

%%**********  Complementisers

that ---> 
  (synsem:(loc:(cat:(head:(mark,
                           spec:(@ s,
                                 loc:cat:(head:vform:(fin; bse),
                                          marking:unmarked))),
                     spr:[],
                     subj:[],
                     comps:[],
                     marking:that)),
           @ noslash)).

for --->
 (synsem:(loc:(cat:(head:(mark,
                           spec:(@ s,
                                 loc:cat:(head:vform:(inf),
                                            marking:unmarked))),
                   spr:[],
                   subj:[],
                   comps:[],
                   marking:for)),
            @ noslash)).

%%**********  Lexical Rules

pres_3s lex_rule
   (synsem:(loc:cat:(head:(verb,
                           vform:bse,
                           aux:no,
                           mod:Mod,
                           inv:Inv),
                     spr:Spr,
                     subj:Subj,
                     comps:Comps,
                     marking:Marking),
           nonloc:(inherited:slash:e_set,
                   tobind:slash:e_set)))
  **>
   (synsem:(loc:cat:(head:(verb,
                           vform:fin,
                           aux:no,
                           mod:Mod,
                           inv:Inv),
                     spr:Spr,
                     subj:Subj,
                     comps:Comps,
                     marking:Marking),
           nonloc:(inherited:slash:e_set,
                   tobind:slash:e_set)))
  morphs
    (X,y) becomes (X,ies),
     X becomes (X,s).


celr lex_rule
   (synsem:(loc:cat:(head:Head,
                     spr:Spr,
                     marking:Marking,
                     subj:Subj,
                     comps:Compsin),
            nonloc:(inherited:slash:e_set,
                    tobind:slash:e_set)))
  **>
   (synsem:(loc:cat:(head:Head,
                     spr:Spr,
                     marking:Marking,
                     subj:Subj,
                     comps:Compsout),
            nonloc:(inherited:slash:(elt:Loc,
                                     elts:e_set),
                    tobind:slash:e_set)))
  if
    select((loc:Loc),Compsin,Compsout)
  morphs
    X becomes X.

select(X,(hd:X,tl:Z),Z) if true.
select(X,[Hd|Y],[Hd|Z]) if select(X,Y,Z).

%*** Subject Extractions (SELR):

selr lex_rule
   (synsem:(loc:cat:(head:Head,
                     spr:Spr,
                     marking:Marking,
                     subj:Subj,
                     comps:Compsin),
            nonloc:(inherited:slash:e_set,
                    tobind:slash:e_set)))
  **>
   (synsem:(loc:cat:(head:Head,
                     spr:Spr,
                     marking:Marking,
                     subj:Subj,
                     comps:Compsout),
            nonloc:(inherited:slash:(elt:Loc,
                                     elts:e_set),
                    tobind:slash:e_set)))
  if
    subst((loc:(cat:(head:vform:fin,
                     subj:e_list,
                     comps:e_list))),
          (loc:(cat:(head:vform:fin,
                     subj:[(@ np,loc:Loc)],
                     comps:e_list))),
          Compsin,
          Compsout)
  morphs
    X becomes X.

subst(X,Y,(hd:X,tl:Z),(hd:Y,tl:Z)) if true.
subst(X,Y,[Hd|Tl1],[Hd|Tl2]) if subst(X,Y,Tl1,Tl2).

%*** Passive participles:

passive lex_rule
   (synsem:(loc:cat:(head:(verb,
                             vform:bse,
                             aux:no,
                             inv:Inv,
                             prd:Prd,
                             mod:Mod),
                     comps:([loc:(cat:(head:(noun,
                                            prd:ObjPrd,
                                            mod:ObjMod),
                                      subj:[],
                                      comps:[],
                                      marking:ObjMarking))|ObjRest]),
                     marking:Marking),
           nonloc:(inherited:slash:e_set,
                   tobind:slash:e_set)))
  **>
   (synsem:(loc:cat:(head:(verb,
                             vform:pas,
                             aux:no,
                             inv:Inv,
                             prd:Prd,
                             mod:Mod),
                     subj:[(loc:(cat:(head:(noun,
                                            prd:ObjPrd,
                                            mod:ObjMod),
                                      subj:[],
                                      comps:[],
                                      marking:ObjMarking)))],
                     comps:ObjRest,
                     marking:Marking),
           nonloc:(inherited:slash:e_set,
                   tobind:slash:e_set)))
  morphs
    give becomes given,
    (X,e) becomes (X,ed),
    X becomes (X,ed).

%%%**********************  Grammmar Rules

subject_head rule        
(Mother, synsem:loc:cat:(spr:Spr,
                         subj:[], 
                         comps:[]))
===>
cat> (SubjDtr),  
goal> (sign_to_synsem(SubjDtr,SubjSynsem)),       
cat> (HeadDtr, synsem:loc:cat:(spr:Spr,           
                               subj:[SubjSynsem],
                               comps:[])),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (nonlocal_feature_principle(HeadDtr,[SubjDtr],Mother)),
goal> (marking_principle(Mother,HeadDtr)).

head_complement rule 
(Mother, synsem:loc:cat:(spr:Spr,
                         subj:Subjs,
                         comps:[]))
===>
cat> (HeadDtr, synsem:loc:cat:(spr:Spr,
                               subj:Subjs, 
                               comps:CompSynsems)),
goal> (list_sign_to_synsem(Comps,CompSynsems)),
cats> (Comps,ne_list),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (nonlocal_feature_principle(HeadDtr,Comps,Mother)),
goal> (marking_principle(Mother,HeadDtr)).

head_subject_complement rule
(Mother, synsem:loc:cat:(spr:[],
                         subj:[],
                         comps:[]))
===>
cat> (HeadDtr, synsem:loc:cat:(head:inv:yes,
                               subj:[SubjSynsem], 
                               comps:CompSynsems)),
goal> (list_sign_to_synsem(Comps,CompSynsems)),
cat> (SubjDtr),
goal> (sign_to_synsem(SubjDtr,SubjSynsem)),
cats> (Comps,ne_list),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (nonlocal_feature_principle(HeadDtr,[SubjDtr|Comps],Mother)),
goal> (marking_principle(Mother,HeadDtr)).

specifier_head rule
(Mother, synsem:loc:cat:(spr:[],
                         subj:[],
                         comps:[]))
===>
cat> (SpecDtr, synsem:loc:cat:(spr:[],
                               subj:[],
                               comps:[])),
goal> (sign_to_synsem(SpecDtr,SpecSynsem)),
cat> (HeadDtr, synsem:loc:cat:(spr:[SpecSynsem],
                               subj:[], 
                               comps:[])),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (nonlocal_feature_principle(HeadDtr,[SpecDtr],Mother)),
goal> (marking_principle(Mother,SpecDtr)).

adjunct_head rule                                   
(Mother, synsem:loc:cat:(spr:Spr, 
                         subj:Subj, 
                         comps:[]))
===>
cat> (AdjDtr,synsem:loc:cat:(head:mod:(Mod, pre_mod_synsem),
                      spr:[],
                      subj:[],
                      comps:[])),
cat> (HeadDtr,synsem:(Mod, 
                      loc:cat:(spr:Spr, 
                               subj:Subj, 
                               comps:[]))),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (nonlocal_feature_principle(HeadDtr,[AdjDtr],Mother)),
goal> (marking_principle(Mother,HeadDtr)).

head_adjunct rule                                   
(Mother, synsem:loc:cat:(spr:Spr, 
                         subj:Subj,
                         comps:[]))
===>
cat> (HeadDtr,synsem:(Mod,
                      loc:cat:(spr:Spr, 
                               subj:Subj, 
                               comps:[]))),
cat> (AdjDtr,synsem:loc:cat:(head:mod:(Mod, post_mod_synsem),
                      spr:[],
                      subj:[],
                      comps:[])),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (nonlocal_feature_principle(HeadDtr,[AdjDtr],Mother)),
goal> (marking_principle(Mother,HeadDtr)).

filler_head rule             
(Mother, synsem:(loc:cat:(spr:Spr,
                          subj:[],
                          comps:[])))
===>
cat> (synsem:loc:Slash),  
cat> (HeadDtr,synsem:(loc:cat:(spr:Spr,
                               subj:[],
                               comps:[]),
                      nonloc:(inherited:slash:elt:Slash,
                              tobind:slash:elt:Slash))),
goal> (head_feature_principle(Mother,HeadDtr)),
goal> (marking_principle(Mother,HeadDtr)).

%%%**********************  Universal Principles

%%%******** Simple HFP

head_feature_principle(synsem:loc:cat:head:Head,     
                       synsem:loc:cat:head:Head)
      if true.

%%%******** Simple Marking Principle:

marking_principle(synsem:loc:cat:marking:Mark,
                  synsem:loc:cat:marking:Mark)
   if true.


%%%********  NLFP handling sets of inherited and tobind values

nonlocal_feature_principle(
            (HDtr, synsem:nonloc:tobind:slash:HTSlash),
             ODtrs,
            (synsem:nonloc:inherited:slash:MISlash))
 if
   islashes_of([HDtr|ODtrs],e_set,DISlash),
   set_diff(HTSlash,DISlash,MISlash).

%%%**********************  Definite Constraints

sign_to_synsem(synsem:Synsem,Synsem) if true.        

list_sign_to_synsem([],[]) if true.

list_sign_to_synsem([H|T],[S|R]) if
     sign_to_synsem(H,S),
     list_sign_to_synsem(T,R). 

append([],Xs,Xs) if
  true.
append([H|T1],L2,[H|T2]) if
  append(T1,L2,T2).

islashes_of([],ISlash,ISlash) if
  true.
islashes_of([(synsem:nonloc:inherited:slash:e_set)|Dtrs],Accum,ISlash) if
  islashes_of(Dtrs,Accum,ISlash),
  !.
islashes_of([(synsem:nonloc:inherited:slash:DISlash)|Dtrs],Accum,ISlash) if
  union(Accum,DISlash,NewAccum),
  islashes_of(Dtrs,NewAccum,ISlash).

union(e_set,Xs,Xs) if       
  true.
union((elt:X,elts:Xs),Ys,Zs) if
  set_member_eq(X,Ys),
  !,union(Xs,Ys,Zs).
union((elt:X,elts:Xs),Ys,(elt:X,elts:Zs)) if
  set_select(X,Ys,YsRest),
  union(Xs,YsRest,Zs).
union((elt:X,elts:Xs),Ys,(elt:X,elts:Zs)) if
  union(Xs,Ys,Zs).

set_diff(e_set,Set,Set) if  
  !,true.                   
                            
set_diff((elt:X,elts:Xs),Set,Diff) if
  set_select_eq(X,Set,Rest),
  set_diff(Xs,Rest,Diff).

set_select(X,(elt:X,elts:Xs),Xs) if
  true.
set_select(Member,(elt:X,elts:Xs),(elt:X,elts:Rest)) if
  set_select(Member,Xs,Rest).

set_select_eq(X,(elt:Y,elts:Xs),Xs) if    
  (X =@ Y).
set_select_eq(Member,(elt:X,elts:Xs),(elt:X,elts:Rest)) if
  set_select_eq(Member,Xs,Rest).

%%%**********************  End of File

