msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

first experiments running Predication with the big lexicon and the other RGL modules

Browse Source
This commit is contained in:
aarne
2014-02-04 20:11:03 +00:00
parent 9e8be757d8
commit 56bda6bb09
3 changed files with 337 additions and 417 deletions
Download Patch File Download Diff File Expand all files Collapse all files

480
lib/src/experimental/PredEng.gf
View File

@@ -1,51 +1,83 @@
concrete PredEng of Pred = open Prelude, ResEng in { concrete PredEng of Pred = CatEng - [Pol] ** open ResEng, TenseX, Prelude in {
-- English predication, based on Swedish ---------------------
-- two principles: -- parameters -------
-- - keep records discontinuous as long as possible (last step from Cl to S) ---------------------
-- - select from tables as soon as possible (first step from V to VP)
-- a question: would it make sense to make this into a functor?
{- -- standard general
param param
{-
Number = Sg | Pl ; Number = Sg | Pl ;
Person = P1 | P2 | P3 ; Person = P1 | P2 | P3 ;
Agr = Ag Number Person ;
VAgr = VASgP1 | VASgP3 | VAPl ;
Case = Nom | Acc ;
STense = Pres | Past | Fut | Cond ;
Anteriority = Simul | Anter ; Anteriority = Simul | Anter ;
Polarity = Pos | Neg ; Polarity = Pos | Neg ;
VForm = VInf | VPres | VPast | VPastPart | VPresPart ; STense = Pres | Past | Fut | Cond ;
-}
Voice = Act | Pass ; Voice = Act | Pass ;
Unit = UUnit ;
-- predication specific
FocusType = NoFoc | FocSubj | FocObj ; -- sover hon/om hon sover, vem älskar hon/vem hon älskar, vem sover/vem som sover FocusType = NoFoc | FocSubj | FocObj ; -- sover hon/om hon sover, vem älskar hon/vem hon älskar, vem sover/vem som sover
Unit = UUnit ; {-
-- standard English
Gender = Neutr | Masc | Fem ;
Agr = AgP1 Number | AgP2 Number | AgP3Sg Gender | AgP3Pl ;
Case = Nom | Acc ;
NPCase = NCase Case | NPAcc | NPNomPoss ;
VForm = VInf | VPres | VPast | VPPart | VPresPart ;
-}
oper
STense = ResEng.Tense ;
-- language dependent
param
VAgr = VASgP1 | VASgP3 | VAPl ;
oper oper
subjCase : NPCase = NCase Nom ;
objCase : NPCase = NPAcc ;
agentCase : ComplCase = "by" ;
ComplCase = Str ; -- preposition
NounPhrase = {s : NPCase => Str ; a : Agr} ;
Preposition = {s : Str} ;
appComplCase : ComplCase -> NounPhrase -> Str = \p,np -> p ++ np.s ! objCase ;
noComplCase : ComplCase = [] ;
prepComplCase : Preposition -> ComplCase = \p -> p.s ;
noObj : Agr => Str = \\_ => [] ;
NAgr = Number ; NAgr = Number ;
AAgr = Unit ; AAgr = Unit ;
IPAgr = Number ; IPAgr = Number ;
defaultAgr : Agr = Ag Sg P3 ; defaultAgr : Agr = AgP3Sg Neutr ;
ComplCase = Str ; -- preposition
-- omitting rich Agr information -- omitting rich Agr information
agr2vagr : Agr -> VAgr = \a -> case a of { agr2vagr : Agr -> VAgr = \a -> case a of {
Ag Sg P1 => VASgP1 ; AgP1 Sg => VASgP1 ;
Ag Sg P3 => VASgP3 ; AgP3Sg _ => VASgP3 ;
_ => VAPl _ => VAPl
} ; } ;
agr2aagr : Agr -> AAgr = \n -> UUnit ; agr2aagr : Agr -> AAgr = \n -> UUnit ;
agr2nagr : Agr -> NAgr = \a -> case a of { agr2nagr : Agr -> NAgr = \a -> case a of {
Ag n _ => n AgP1 n => n ;
AgP2 n => n ;
AgP3Sg _ => Sg ;
AgP3Pl => Pl
} ; } ;
-- restoring full Agr -- restoring full Agr
ipagr2agr : IPAgr -> Agr = \n -> Ag n P3 ; ipagr2agr : IPAgr -> Agr = \n -> case n of {
Sg => AgP3Sg Neutr ; ---- gender
Pl => AgP3Pl
} ;
ipagr2vagr : IPAgr -> VAgr = \n -> case n of { ipagr2vagr : IPAgr -> VAgr = \n -> case n of {
Sg => VASgP3 ; Sg => VASgP3 ;
@@ -54,38 +86,58 @@ oper
--- this is only needed in VPC formation --- this is only needed in VPC formation
vagr2agr : VAgr -> Agr = \a -> case a of { vagr2agr : VAgr -> Agr = \a -> case a of {
VASgP1 => Ag Sg P1 ; VASgP1 => AgP1 Sg ;
VASgP3 => Ag Sg P3 ; VASgP3 => AgP3Sg Neutr ;
VAPl => Ag Pl P3 VAPl => AgP3Pl
} ; } ;
vPastPart : AAgr -> VForm = \_ -> VPPart ;
vPresPart : AAgr -> VForm = \_ -> VPresPart ;
------------------------------------
-- lincats
-------------------------------------
lincat lincat
{-
-- standard general
Tense = {s : Str ; t : STense} ;
Ant = {s : Str ; a : Anteriority} ;
Pol = {s : Str ; p : Polarity} ;
Utt = {s : Str} ;
IAdv = {s : Str} ;
-}
Pol = {s : Str ; p : Polarity} ;
-- predication-specific
Arg = {s : Str} ; Arg = {s : Str} ;
V = { PrV = {
v : VForm => Str ; v : VForm => Str ;
p : Str ; -- verb particle
c1 : ComplCase ; c1 : ComplCase ;
c2 : ComplCase ; c2 : ComplCase ;
isSubjectControl : Bool ; isSubjectControl : Bool ;
isAux : Bool ; isAux : Bool ;
isRefl : Bool ;
} ; } ;
oper oper
VerbPhrase = { PrVerbPhrase = {
v : VAgr => Str * Str * Str ; -- ska,ha,sovit v : VAgr => Str * Str * Str ; -- would,have,slept
inf : Str * Str ; -- ha,sovit inf : Str * Str ; -- have,slept
c1 : ComplCase ; c1 : ComplCase ;
c2 : ComplCase ; c2 : ComplCase ;
part : Str ; -- (look) up
adj : Agr => Str ; adj : Agr => Str ;
obj1 : (Agr => Str) * Agr ; obj1 : (Agr => Str) * Agr ; -- agr for object control
obj2 : (Agr => Str) * Bool ; -- subject control = True obj2 : (Agr => Str) * Bool ; -- subject control = True
adv : Str ; adv : Str ;
adV : Str ; adV : Str ;
ext : Str ; ext : Str ;
qforms : VAgr => Str * Str -- special Eng for introducing "do" in questions qforms : VAgr => Str * Str -- special Eng for introducing "do" in questions
} ; } ;
Clause = { PrClause = {
v : Str * Str * Str ; v : Str * Str * Str ;
inf : Str * Str ; inf : Str * Str ;
adj,obj1,obj2 : Str ; adj,obj1,obj2 : Str ;
@@ -93,17 +145,17 @@ oper
adV : Str ; adV : Str ;
ext : Str ; ext : Str ;
subj : Str ; subj : Str ;
c3 : ComplCase ; -- for a slashed adjunct, not belonging to the verb valency c3 : ComplCase ; -- for a slashed adjunct, not belonging to the verb valency
qforms : Str * Str qforms : Str * Str
} ; } ;
lincat lincat
VP = VerbPhrase ; PrVP = PrVerbPhrase ;
Cl = Clause ; PrCl = PrClause ;
QCl = Clause ** { PrQCl = PrClause ** {
foc : Str ; -- the focal position at the beginning, e.g. *vem* älskar hon foc : Str ; -- the focal position at the beginning: *who* does she love
focType : FocusType ; --- if already filled, then use other place: vem älskar *vem* focType : FocusType ; --- if already filled, then use other place: who loves *who*
} ; } ;
VPC = { VPC = {
@@ -118,32 +170,37 @@ lincat
c3 : ComplCase ; c3 : ComplCase ;
} ; } ;
Tense = {s : Str ; t : STense} ; PrAdv = {s : Str ; isAdV : Bool} ;
Ant = {s : Str ; a : Anteriority} ; PrS = {s : Str} ;
Pol = {s : Str ; p : Polarity} ;
NP = {s : Case => Str ; a : Agr} ; PrAP = {
Adv = {s : Str ; isAdV : Bool} ;
S = {s : Str} ;
Utt = {s : Str} ;
AP = {
s : AAgr => Str ; s : AAgr => Str ;
c1, c2 : ComplCase ; c1, c2 : ComplCase ;
obj1 : Agr => Str obj1 : Agr => Str
} ; } ;
CN = {
PrCN = {
s : NAgr => Str ; s : NAgr => Str ;
c1, c2 : ComplCase ; c1, c2 : ComplCase ;
obj1 : Agr => Str obj1 : Agr => Str
} ; } ;
IP = {s : Str ; a : IPAgr} ;
{-
-- language specific
NP = {s : NPCase => Str ; a : Agr} ;
IP = {s : NPCase => Str ; n : IPAgr} ; ---- n : Number in Eng
Prep = {s : Str} ; Prep = {s : Str} ;
Conj = {s : Str} ; Conj = {s1,s2 : Str ; n : Number} ;
IAdv = {s : Str} ; -}
----------------------------
--- linearization rules ----
----------------------------
lin lin
aNone, aS, aV, aA, aQ, aN = {s = []} ;
aNP a = a ; -- standard general
TPres = {s = [] ; t = Pres} ; TPres = {s = [] ; t = Pres} ;
TPast = {s = [] ; t = Past} ; TPast = {s = [] ; t = Past} ;
@@ -151,266 +208,63 @@ lin
TCond = {s = [] ; t = Cond} ; TCond = {s = [] ; t = Cond} ;
ASimul = {s = [] ; a = Simul} ; ASimul = {s = [] ; a = Simul} ;
AAnter = {s = [] ; a = Anter} ; AAnter = {s = [] ; a = Anter} ;
PPos = {s = [] ; p = Pos} ; PPos = {s = [] ; p = Pos} ;
PNeg = {s = [] ; p = Neg} ; PNeg = {s = [] ; p = Neg} ;
-- predication specific
aNone, aS, aV, aA, aQ, aN = {s = []} ;
aNP a = a ;
UseV a t p _ v = { UseV a t p _ v = {
v = \\agr => tenseV (a.s ++ t.s ++ p.s) t.t a.a p.p Act agr v ; v = \\agr => tenseV (a.s ++ t.s ++ p.s) t.t a.a p.p Act agr v ;
inf = tenseInfV a.s a.a p.p Act v ; inf = tenseInfV a.s a.a p.p Act v ;
c1 = v.c1 ; c1 = v.c1 ;
c2 = v.c2 ; c2 = v.c2 ;
part = v.p ;
adj = noObj ; adj = noObj ;
obj1 = <noObj, defaultAgr> ; ---- not used, just default value obj1 = <case v.isRefl of {True => \\a => reflPron ! a ; False => \\_ => []}, defaultAgr> ; ---- not used, just default value
obj2 = <noObj, v.isSubjectControl> ; obj2 = <noObj, v.isSubjectControl> ;
adV = negAdV p ; adV = negAdV p ; --- just p.s in Eng
adv = [] ; adv = [] ;
ext = [] ; ext = [] ;
qforms = \\agr => qformsV (a.s ++ t.s ++ p.s) t.t a.a p.p agr v ; qforms = \\agr => qformsV (a.s ++ t.s ++ p.s) t.t a.a p.p agr v ;
} ; } ;
PassUseV a t p _ v = {
v = \\agr => tenseV (a.s ++ t.s ++ p.s) t.t a.a p.p Pass agr v ;
inf = tenseInfV a.s a.a p.p Pass v ;
c1 = v.c1 ;
c2 = v.c2 ;
adj = noObj ;
obj1 = <noObj, defaultAgr> ; ---- not used, just default value
obj2 = <noObj, True> ; -- becomes subject control even if object control otherwise "*she was promised by us to love ourselves"
adV = negAdV p ;
adv = [] ;
ext = [] ;
qforms = \\agr => qformsBe (a.s ++ t.s ++ p.s) t.t a.a p.p agr ;
} ;
AgentPassUseV a t p _ v np = {
v = \\agr => tenseV (a.s ++ t.s ++ p.s) t.t a.a p.p Pass agr v ;
inf = tenseInfV a.s a.a p.p Pass v ;
c1 = v.c1 ;
c2 = v.c2 ;
adj = \\a => [] ;
obj1 = <noObj, defaultAgr> ;
obj2 = <noObj, True> ;
adV = negAdV p ;
adv = appComplCase agentCase np ; ---- add a specific field for agent?
ext = [] ;
qforms = \\agr => qformsBe (a.s ++ t.s ++ p.s) t.t a.a p.p agr ;
} ;
UseAP a t p _ ap = {
v = \\agr => be_Aux (a.s ++ t.s ++ p.s) t.t a.a p.p agr ;
inf = tenseInfV a.s a.a p.p Act be_V ;
c1 = ap.c1 ;
c2 = ap.c2 ;
adj = \\a => ap.s ! agr2aagr a ;
obj1 = <ap.obj1, defaultAgr> ;
obj2 = <noObj, True> ; --- there are no A3's
adV = negAdV p ;
adv = [] ;
ext = [] ;
qforms = \\agr => qformsBe (a.s ++ t.s ++ p.s) t.t a.a p.p agr ;
} ;
SlashV2 x vp np = vp ** {
obj1 : (Agr => Str) * Agr = <\\a => np.s ! Acc, np.a> -- np.a for object control ---- Acc to be abstracted
} ;
SlashV3 x vp np = addObj2VP vp (\\a => np.s ! Acc) ; -- control is preserved ---- Acc to be abstracted
ComplVS x vp cl = addExtVP vp (that_Compl ++ declSubordCl (lin Cl cl)) ; ---- sentence form
ComplVQ x vp qcl = addExtVP vp (questSubordCl qcl) ; ---- question form
ComplVV x vp vpo = addObj2VP vp (\\a => infVP a vpo) ; ---- infForm
ComplVA x vp ap = addObj2VP vp (\\a => ap.s ! agr2aagr a ++ ap.obj1 ! a) ; ---- adjForm
ComplVN x vp cn = addObj2VP vp (\\a => cn.s ! agr2nagr a ++ cn.obj1 ! a) ; ---- cnForm
SlashV2S x vp cl = addExtVP vp (that_Compl ++ declSubordCl (lin Cl cl)) ; ---- sentence form
SlashV2Q x vp cl = addExtVP vp (questSubordCl (lin QCl cl)) ; ---- question form
SlashV2V x vp vpo = addObj2VP vp (\\a => infVP a (lin VP vpo)) ; ---- infForm
SlashV2A x vp ap = addObj2VP vp (\\a => ap.s ! agr2aagr a ++ ap.obj1 ! a) ; ---- adjForm
SlashV2N x vp cn = addObj2VP vp (\\a => cn.s ! agr2nagr a ++ cn.obj1 ! a) ; ---- cn form
ReflVP x vp = vp ** {
obj1 : (Agr => Str) * Agr = <\\a => reflPron a, defaultAgr> ; --- hack: defaultAgr will not be used but subj.a instead
} ;
ReflVP2 x vp = vp ** {
obj2 : (Agr => Str) * Bool = <\\a => reflPron a, vp.obj2.p2> ; --- subj/obj control doesn't matter any more
} ;
PredVP x np vp = vp ** { PredVP x np vp = vp ** {
v = vp.v ! agr2vagr np.a ; v = vp.v ! agr2vagr np.a ;
subj = np.s ! Nom ; subj = np.s ! subjCase ;
adj = vp.adj ! np.a ; adj = vp.adj ! np.a ;
obj1 = vp.c1 ++ vp.obj1.p1 ! np.a ; ---- apply complCase obj1 = vp.part ++ vp.c1 ++ vp.obj1.p1 ! np.a ; ---- apply complCase ---- place of part depends on obj
obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ; ---- apply complCase obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ; ---- apply complCase
c3 = noComplCase ; -- for one more prep to build ClSlash c3 = noComplCase ; -- for one more prep to build ClSlash
qforms = vp.qforms ! agr2vagr np.a ; qforms = vp.qforms ! agr2vagr np.a ;
} ; } ;
PrepCl p x cl = cl ** { -- Cl/NP ::= Cl PP/NP
c3 = prepComplCase p ;
} ;
SlashClNP x cl np = cl ** { -- Cl ::= Cl/NP NP
adv = cl.adv ++ appComplCase cl.c3 np ; ---- again, adv just added
c3 = noComplCase ; -- complCase has been consumed
} ;
-- QCl ::= Cl by just adding focus field
QuestCl x cl = cl ** {foc = [] ; focType = NoFoc} ; -- NoFoc implies verb first: älskar hon oss
QuestIAdv x iadv cl = cl ** {foc = iadv.s ; focType = FocObj} ; -- FocObj implies Foc + V + Subj: varför älskar hon oss
QuestVP x ip vp = let ipa = ipagr2agr ip.a in
vp ** {
v = vp.v ! ipagr2vagr ip.a ;
foc = ip.s ; -- vem älskar henne
focType = FocSubj ;
subj = [] ;
adj = vp.adj ! ipa ;
obj1 = vp.c1 ++ vp.obj1.p1 ! ipa ; ---- appComplCase
obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ipa ; False => vp.obj1.p2}) ; ---- appComplCase
c3 = noComplCase ; -- for one more prep to build ClSlash ---- ever needed for QCl?
qforms = vp.qforms ! ipagr2vagr ip.a ;
} ;
QuestSlash x ip cl =
let
ips = cl.c3 ++ ip.s ; -- in Cl/NP, c3 is the only prep ---- appComplCase for ip
focobj = case cl.focType of {
NoFoc => <ips, [], FocObj> ; -- put ip object to focus if there is no focus yet
t => <[], ips, t> -- put ip object in situ if there already is a focus
} ;
in cl ** {
foc = focobj.p1 ;
focType = focobj.p3 ;
subj = cl.subj ;
obj1 = cl.obj1 ++ focobj.p2 ; ---- just add to a field?
c3 = noComplCase ;
} ;
UseCl cl = {s = declCl cl} ; UseCl cl = {s = declCl cl} ;
UseQCl cl = {s = questCl cl} ; UseQCl cl = {s = questCl cl} ;
UseAdvCl adv cl = {s = adv.s ++ declInvCl cl} ; ---- UseAdvCl adv cl = {s = adv.s ++ declInvCl cl} ;
UttS s = s ; UttS s = s ;
AdvCl a x cl = cl ** case a.isAdV of {True => {adV = cl.adV ++ a.s ; adv = cl.adv} ; False => {adv = cl.adv ++ a.s ; adV = cl.adV}} ;
AdvQCl a x cl = cl ** {adv = cl.adv ++ a.s} ;
PresPartAP x v = {
s = \\a => v.v ! vPresPart a ;
c1 = v.c1 ; -- tittande på henne
c2 = v.c2 ;
obj1 = noObj ;
} ;
PastPartAP x v = {
s = \\a => v.v ! vPastPart a ;
c1 = v.c1 ;
c2 = v.c2 ;
obj1 = noObj ;
} ;
AgentPastPartAP x v np = {
s = \\a => v.v ! vPastPart a ;
c1 = v.c1 ;
c2 = v.c2 ;
obj1 = \\_ => appComplCase agentCase np ; ---- addObj
} ;
StartVPC c x v w = { ---- some loss of quality seems inevitable
v = \\a =>
let
vv = v.v ! a ;
wv = w.v ! a ;
vpa = vagr2agr a ;
in
vv.p1 ++ v.adV ++ vv.p2 ++ vv.p3 ++ v.adj ! vpa ++
v.c1 ++ v.obj1.p1 ! vpa ++ v.c2 ++ v.obj2.p1 ! vpa ++ v.adv ++ v.ext ---- appComplCase
++ c.s ++
wv.p1 ++ w.adV ++ wv.p2 ++ wv.p3 ++ w.adj ! vpa ++ ---- appComplCase
w.c1 ++ w.obj1.p1 ! vpa ++ w.c2 ++ w.obj2.p1 ! vpa ++ w.adv ++ w.ext ;
inf = \\a =>
infVP a (lin VP v) ++ c.s ++ infVP a (lin VP w) ;
c1 = [] ; ---- w.c1 ? --- the full story is to unify v and w...
c2 = [] ; ---- w.c2 ?
} ;
UseVPC x vpc = { ---- big loss of quality (overgeneration) seems inevitable
v = \\a => <[], [], vpc.v ! a> ;
inf = <[], vpc.inf ! defaultAgr> ; ---- agreement
c1 = vpc.c1 ;
c2 = vpc.c2 ;
adj = \\a => [] ;
obj1 = <noObj, defaultAgr> ;
obj2 = <noObj,True> ;
adv,adV = [] ;
ext = [] ;
qforms = \\a => <"do", vpc.inf ! defaultAgr> ; ---- do/does/did
} ;
StartClC c x a b = {
s = declCl (lin Cl a) ++ c.s ++ declCl (lin Cl b) ;
c3 = b.c3 ; ----
} ;
UseClC x cl = {
subj = [] ;
v = <[],[],cl.s> ; ----
inf = <[],[]> ;
adj = [] ;
obj1 = [] ;
obj2 = [] ;
adV = [] ;
adv = [] ;
ext = [] ;
c3 = cl.c3 ;
qforms = <[],[]> ; ---- qforms
} ;
---- the following may become parameters for a functor
oper oper
vPastPart : AAgr -> VForm = \_ -> VPastPart ; infVP : Agr -> PrVerbPhrase -> Str = \a,vp ->
vPresPart : AAgr -> VForm = \_ -> VPresPart ;
be_V : V = lin V {v = mkVerb "be" "is" "was" "been" "being" ; c1,c2 = [] ; isAux = True ; isSubjectControl = False} ;
negAdV : Pol -> Str = \p -> p.s ;
reflPron : Agr -> Str = \a -> case a of {
Ag Sg P1 => "myself" ;
Ag Sg P2 => "yourself" ;
Ag Sg P3 => "herself" | "himself" | "itself" ; ----
Ag Pl P1 => "ourselves" ;
Ag Pl P2 => "ourselves" ;
Ag Pl P3 => "yourselves"
} ;
infVP : Agr -> VP -> Str = \a,vp ->
let let
a2 = case vp.obj2.p2 of {True => a ; False => vp.obj1.p2} a2 = case vp.obj2.p2 of {True => a ; False => vp.obj1.p2}
in in
vp.adV ++ vp.inf.p1 ++ vp.inf.p2 ++ vp.adV ++ vp.inf.p1 ++ vp.inf.p2 ++ vp.part ++
vp.adj ! a ++ vp.c1 ++ vp.obj1.p1 ! a ++ vp.c2 ++ vp.obj2.p1 ! a2 ++ vp.adv ++ vp.ext ; vp.adj ! a ++ vp.c1 ++ vp.obj1.p1 ! a ++ vp.c2 ++ vp.obj2.p1 ! a2 ++ vp.adv ++ vp.ext ;
qformsV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str = qformsV : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrV -> Str * Str =
\sta,t,a,p,agr,v -> \sta,t,a,p,agr,v ->
let let
verb = tenseActV sta t a Neg agr v ; verb = tenseActV sta t a Neg agr v ;
@@ -428,20 +282,20 @@ oper
let verb = be_AuxL sta t a p agr let verb = be_AuxL sta t a p agr
in <verb.p1, verb.p2> ; -- is , not ---- TODO isn't , in <verb.p1, verb.p2> ; -- is , not ---- TODO isn't ,
tenseV : Str -> STense -> Anteriority -> Polarity -> Voice -> VAgr -> V -> Str * Str * Str = tenseV : Str -> STense -> Anteriority -> Polarity -> Voice -> VAgr -> PrV -> Str * Str * Str =
\sta,t,a,p,o,agr,v -> \sta,t,a,p,o,agr,v ->
case o of { case o of {
Act => tenseActV sta t a p agr v ; Act => tenseActV sta t a p agr v ;
Pass => tensePassV sta t a p agr v Pass => tensePassV sta t a p agr v
} } {-
| ---- leaving out variants makes compilation time go down from 900ms to 300ms. | ---- leaving out these variants makes compilation time go down from 900ms to 300ms.
---- parsing time of "she sleeps" goes down from 300ms to 60ms. 4/2/2014 ---- parsing time of "she sleeps" goes down from 300ms to 60ms. 4/2/2014
case o of { case o of {
Act => tenseActVContracted sta t a p agr v ; Act => tenseActVContracted sta t a p agr v ;
Pass => tensePassVContracted sta t a p agr v Pass => tensePassVContracted sta t a p agr v
} ; -} ;
tenseActV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tenseActV : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrV -> Str * Str * Str = \sta,t,a,p,agr,v ->
let vt : VForm = case <t,agr> of { let vt : VForm = case <t,agr> of {
<Pres,VASgP3> => VPres ; <Pres,VASgP3> => VPres ;
<Past|Cond,_ > => VPast ; <Past|Cond,_ > => VPast ;
@@ -458,12 +312,12 @@ oper
} }
} ; } ;
<Pres|Past, Anter> => <have_Aux vt Pos, not_Str p, sta ++ v.v ! VPastPart> ; <Pres|Past, Anter> => <have_Aux vt Pos, not_Str p, sta ++ v.v ! VPPart> ;
<Fut|Cond, Simul> => <will_Aux vt Pos, not_Str p, sta ++ v.v ! VInf> ; <Fut|Cond, Simul> => <will_Aux vt Pos, not_Str p, sta ++ v.v ! VInf> ;
<Fut|Cond, Anter> => <will_Aux vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPastPart> <Fut|Cond, Anter> => <will_Aux vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPPart>
} ; } ;
tenseActVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tenseActVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrV -> Str * Str * Str = \sta,t,a,p,agr,v ->
let vt : VForm = case <t,agr> of { let vt : VForm = case <t,agr> of {
<Pres,VASgP3> => VPres ; <Pres,VASgP3> => VPres ;
<Past|Cond,_ > => VPast ; <Past|Cond,_ > => VPast ;
@@ -480,31 +334,31 @@ oper
Neg => <do_Aux vt p, [], sta ++ v.v ! VInf> Neg => <do_Aux vt p, [], sta ++ v.v ! VInf>
} }
} ; } ;
<Pres|Past, Anter> => <have_AuxC vt p, [], sta ++ v.v ! VPastPart> <Pres|Past, Anter> => <have_AuxC vt p, [], sta ++ v.v ! VPPart>
| <have_AuxC vt Pos, not_Str p, sta ++ v.v ! VPastPart> ; | <have_AuxC vt Pos, not_Str p, sta ++ v.v ! VPPart> ;
<Fut|Cond, Simul> => <will_AuxC vt p, [], sta ++ v.v ! VInf> <Fut|Cond, Simul> => <will_AuxC vt p, [], sta ++ v.v ! VInf>
| <will_AuxC vt Pos, not_Str p, sta ++ v.v ! VInf> ; | <will_AuxC vt Pos, not_Str p, sta ++ v.v ! VInf> ;
<Fut|Cond, Anter> => <will_AuxC vt p, have_Aux VInf Pos, sta ++ v.v ! VPastPart> <Fut|Cond, Anter> => <will_AuxC vt p, have_Aux VInf Pos, sta ++ v.v ! VPPart>
| <will_AuxC vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPastPart> | <will_AuxC vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPPart>
} ; } ;
tensePassV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tensePassV : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrV -> Str * Str * Str = \sta,t,a,p,agr,v ->
let let
be = be_AuxL sta t a p agr ; be = be_AuxL sta t a p agr ;
done = v.v ! VPastPart done = v.v ! VPPart
in in
<be.p1, be.p2, be.p3 ++ done> ; <be.p1, be.p2, be.p3 ++ done> ;
tensePassVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tensePassVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> PrV -> Str * Str * Str = \sta,t,a,p,agr,v ->
let let
be = be_AuxC sta t a p agr ; be = be_AuxC sta t a p agr ;
done = v.v ! VPastPart done = v.v ! VPPart
in in
<be.p1, be.p2, be.p3 ++ done> ; <be.p1, be.p2, be.p3 ++ done> ;
tenseInfV : Str -> Anteriority -> Polarity -> Voice -> V -> Str * Str = \sa,a,p,o,v -> tenseInfV : Str -> Anteriority -> Polarity -> Voice -> PrV -> Str * Str = \sa,a,p,o,v ->
case a of { case a of {
Simul => <[], sa ++ v.v ! VInf> ; -- hon vill sova Simul => <[], sa ++ v.v ! VInf> ; -- (she wants to) sleep
Anter => <have_Aux VInf Pos, sa ++ v.v ! VPastPart> -- hon vill (ha) sovit Anter => <have_Aux VInf Pos, sa ++ v.v ! VPPart> -- (she wants to) have slept
} ; } ;
----- dangerous variants for PMCFG generation - keep apart as long as possible ----- dangerous variants for PMCFG generation - keep apart as long as possible
@@ -545,19 +399,19 @@ oper
_ => beV _ => beV
} ; } ;
declCl : Clause -> Str = \cl -> cl.subj ++ cl.v.p1 ++ cl.adV ++ cl.v.p2 ++ restCl cl ; declCl : PrClause -> Str = \cl -> cl.subj ++ cl.v.p1 ++ cl.adV ++ cl.v.p2 ++ restCl cl ;
declSubordCl : Clause -> Str = declCl ; declSubordCl : PrClause -> Str = declCl ;
declInvCl : Clause -> Str = declCl ; declInvCl : PrClause -> Str = declCl ;
questCl : QCl -> Str = \cl -> case cl.focType of { questCl : PrQCl -> Str = \cl -> case cl.focType of {
NoFoc => cl.foc ++ cl.qforms.p1 ++ cl.subj ++ cl.adV ++ cl.qforms.p2 ++ restCl cl ; -- does she sleep NoFoc => cl.foc ++ cl.qforms.p1 ++ cl.subj ++ cl.adV ++ cl.qforms.p2 ++ restCl cl ; -- does she sleep
FocObj => cl.foc ++ cl.qforms.p1 ++ cl.subj ++ cl.adV ++ cl.qforms.p2 ++ restCl cl ; -- who does she love FocObj => cl.foc ++ cl.qforms.p1 ++ cl.subj ++ cl.adV ++ cl.qforms.p2 ++ restCl cl ; -- who does she love
FocSubj => cl.foc ++ cl.v.p1 ++ cl.subj ++ cl.adV ++ cl.v.p2 ++ restCl cl -- who loves her FocSubj => cl.foc ++ cl.v.p1 ++ cl.subj ++ cl.adV ++ cl.v.p2 ++ restCl cl -- who loves her
} ; } ;
questSubordCl : QCl -> Str = \cl -> questSubordCl : PrQCl -> Str = \cl ->
let let
rest = cl.subj ++ cl.adV ++ cl.v.p1 ++ (cl.v.p2 | []) ++ restCl cl rest = cl.subj ++ cl.adV ++ cl.v.p1 ++ cl.v.p2 ++ restCl cl
in case cl.focType of { in case cl.focType of {
NoFoc => "if" ++ cl.foc ++ rest ; -- om she sleeps NoFoc => "if" ++ cl.foc ++ rest ; -- om she sleeps
FocObj => cl.foc ++ rest ; -- who she loves / why she sleeps FocObj => cl.foc ++ rest ; -- who she loves / why she sleeps
@@ -567,27 +421,37 @@ oper
that_Compl : Str = "that" | [] ; that_Compl : Str = "that" | [] ;
-- this part is usually the same in all reconfigurations -- this part is usually the same in all reconfigurations
restCl : Clause -> Str = \cl -> cl.v.p3 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ++ cl.c3 ; restCl : PrClause -> Str = \cl -> cl.v.p3 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ++ cl.c3 ;
agentCase : ComplCase = "by" ;
appComplCase : ComplCase -> NP -> Str = \p,np -> p ++ np.s ! Acc ; addObj2VP : PrVerbPhrase -> (Agr => Str) -> PrVerbPhrase = \vp,obj -> vp ** {
noComplCase : ComplCase = [] ;
prepComplCase : Prep -> ComplCase = \p -> p.s ;
noObj : Agr => Str = \\_ => [] ;
addObj2VP : VerbPhrase -> (Agr => Str) -> VerbPhrase = \vp,obj -> vp ** {
obj2 = <\\a => vp.obj2.p1 ! a ++ obj ! a, vp.obj2.p2> ; obj2 = <\\a => vp.obj2.p1 ! a ++ obj ! a, vp.obj2.p2> ;
} ; } ;
addExtVP : VerbPhrase -> Str -> VerbPhrase = \vp,ext -> vp ** { addExtVP : PrVerbPhrase -> Str -> PrVerbPhrase = \vp,ext -> vp ** {
ext = ext ; ext = ext ;
} ; } ;
-}
oper
be_V : PrV = lin PrV {
v = table {
VInf => "be" ;
VPres => "is" ;
VPast => "was" ;
VPPart => "been" ;
VPresPart => "being"
} ;
p,c1,c2 = [] ; isAux = True ; isSubjectControl,isRefl = False
} ;
negAdV : PredEng.Pol -> Str = \p -> p.s ;
oper oper

261
lib/src/experimental/PredicationEng.gf
View File

@@ -6,45 +6,74 @@ concrete PredicationEng of Predication = open Prelude in {
-- - select from tables as soon as possible (first step from V to VP) -- - select from tables as soon as possible (first step from V to VP)
-- a question: would it make sense to make this into a functor? -- a question: would it make sense to make this into a functor?
---------------------
-- parameters -------
---------------------
-- standard general
param param
Number = Sg | Pl ; Number = Sg | Pl ;
Person = P1 | P2 | P3 ; Person = P1 | P2 | P3 ;
Agr = Ag Number Person ;
VAgr = VASgP1 | VASgP3 | VAPl ;
Case = Nom | Acc ;
STense = Pres | Past | Fut | Cond ;
Anteriority = Simul | Anter ; Anteriority = Simul | Anter ;
Polarity = Pos | Neg ; Polarity = Pos | Neg ;
VForm = VInf | VPres | VPast | VPastPart | VPresPart ; STense = Pres | Past | Fut | Cond ;
Voice = Act | Pass ; Voice = Act | Pass ;
Unit = UUnit ;
-- predication specific
FocusType = NoFoc | FocSubj | FocObj ; -- sover hon/om hon sover, vem älskar hon/vem hon älskar, vem sover/vem som sover FocusType = NoFoc | FocSubj | FocObj ; -- sover hon/om hon sover, vem älskar hon/vem hon älskar, vem sover/vem som sover
Unit = UUnit ; -- standard English
Gender = Neutr | Masc | Fem ;
Agr = AgP1 Number | AgP2 Number | AgP3Sg Gender | AgP3Pl ;
Case = Nom | Acc ;
NPCase = NCase Case | NPAcc | NPNomPoss ;
VForm = VInf | VPres | VPast | VPPart | VPresPart ;
-- language dependent
VAgr = VASgP1 | VASgP3 | VAPl ;
oper oper
subjCase : NPCase = NCase Nom ;
objCase : NPCase = NPAcc ;
agentCase : ComplCase = "by" ;
ComplCase = Str ; -- preposition
appComplCase : ComplCase -> NounPhrase -> Str = \p,np -> p ++ np.s ! objCase ;
noComplCase : ComplCase = [] ;
prepComplCase : Preposition -> ComplCase = \p -> p.s ;
noObj : Agr => Str = \\_ => [] ;
NAgr = Number ; NAgr = Number ;
AAgr = Unit ; AAgr = Unit ;
IPAgr = Number ; IPAgr = Number ;
defaultAgr : Agr = Ag Sg P3 ; defaultAgr : Agr = AgP3Sg Neutr ;
ComplCase = Str ; -- preposition
-- omitting rich Agr information -- omitting rich Agr information
agr2vagr : Agr -> VAgr = \a -> case a of { agr2vagr : Agr -> VAgr = \a -> case a of {
Ag Sg P1 => VASgP1 ; AgP1 Sg => VASgP1 ;
Ag Sg P3 => VASgP3 ; AgP3Sg _ => VASgP3 ;
_ => VAPl _ => VAPl
} ; } ;
agr2aagr : Agr -> AAgr = \n -> UUnit ; agr2aagr : Agr -> AAgr = \n -> UUnit ;
agr2nagr : Agr -> NAgr = \a -> case a of { agr2nagr : Agr -> NAgr = \a -> case a of {
Ag n _ => n AgP1 n => n ;
AgP2 n => n ;
AgP3Sg _ => Sg ;
AgP3Pl => Pl
} ; } ;
-- restoring full Agr -- restoring full Agr
ipagr2agr : IPAgr -> Agr = \n -> Ag n P3 ; ipagr2agr : IPAgr -> Agr = \n -> case n of {
Sg => AgP3Sg Neutr ; ---- gender
Pl => AgP3Pl
} ;
ipagr2vagr : IPAgr -> VAgr = \n -> case n of { ipagr2vagr : IPAgr -> VAgr = \n -> case n of {
Sg => VASgP3 ; Sg => VASgP3 ;
@@ -53,35 +82,53 @@ oper
--- this is only needed in VPC formation --- this is only needed in VPC formation
vagr2agr : VAgr -> Agr = \a -> case a of { vagr2agr : VAgr -> Agr = \a -> case a of {
VASgP1 => Ag Sg P1 ; VASgP1 => AgP1 Sg ;
VASgP3 => Ag Sg P3 ; VASgP3 => AgP3Sg Neutr ;
VAPl => Ag Pl P3 VAPl => AgP3Pl
} ; } ;
vPastPart : AAgr -> VForm = \_ -> VPPart ;
vPresPart : AAgr -> VForm = \_ -> VPresPart ;
------------------------------------
-- lincats
-------------------------------------
-- standard general
lincat lincat
Tense = {s : Str ; t : STense} ;
Ant = {s : Str ; a : Anteriority} ;
Pol = {s : Str ; p : Polarity} ;
Utt = {s : Str} ;
IAdv = {s : Str} ;
-- predication-specific
Arg = {s : Str} ; Arg = {s : Str} ;
V = { V = {
v : VForm => Str ; v : VForm => Str ;
p : Str ; -- verb particle
c1 : ComplCase ; c1 : ComplCase ;
c2 : ComplCase ; c2 : ComplCase ;
isSubjectControl : Bool ; isSubjectControl : Bool ;
isAux : Bool ; isAux : Bool ;
isRefl : Bool ;
} ; } ;
oper oper
VerbPhrase = { VerbPhrase = {
v : VAgr => Str * Str * Str ; -- ska,ha,sovit v : VAgr => Str * Str * Str ; -- would,have,slept
inf : Str * Str ; -- ha,sovit inf : Str * Str ; -- have,slept
c1 : ComplCase ; c1 : ComplCase ;
c2 : ComplCase ; c2 : ComplCase ;
part : Str ; -- (look) up
adj : Agr => Str ; adj : Agr => Str ;
obj1 : (Agr => Str) * Agr ; obj1 : (Agr => Str) * Agr ; -- agr for object control
obj2 : (Agr => Str) * Bool ; -- subject control = True obj2 : (Agr => Str) * Bool ; -- subject control = True
adv : Str ; adv : Str ;
adV : Str ; adV : Str ;
ext : Str ; ext : Str ;
qforms : VAgr => Str * Str -- special Eng for introducing "do" in questions qforms : VAgr => Str * Str -- special Eng for introducing "do" in questions
} ; } ;
Clause = { Clause = {
@@ -92,7 +139,7 @@ oper
adV : Str ; adV : Str ;
ext : Str ; ext : Str ;
subj : Str ; subj : Str ;
c3 : ComplCase ; -- for a slashed adjunct, not belonging to the verb valency c3 : ComplCase ; -- for a slashed adjunct, not belonging to the verb valency
qforms : Str * Str qforms : Str * Str
} ; } ;
@@ -101,8 +148,8 @@ lincat
Cl = Clause ; Cl = Clause ;
QCl = Clause ** { QCl = Clause ** {
foc : Str ; -- the focal position at the beginning, e.g. *vem* älskar hon foc : Str ; -- the focal position at the beginning: *who* does she love
focType : FocusType ; --- if already filled, then use other place: vem älskar *vem* focType : FocusType ; --- if already filled, then use other place: who loves *who*
} ; } ;
VPC = { VPC = {
@@ -117,52 +164,63 @@ lincat
c3 : ComplCase ; c3 : ComplCase ;
} ; } ;
Tense = {s : Str ; t : STense} ; Adv = {s : Str ; isAdV : Bool} ;
Ant = {s : Str ; a : Anteriority} ; S = {s : Str} ;
Pol = {s : Str ; p : Polarity} ;
NP = {s : Case => Str ; a : Agr} ;
Adv = {s : Str ; isAdV : Bool} ;
S = {s : Str} ;
Utt = {s : Str} ;
AP = { AP = {
s : AAgr => Str ; s : AAgr => Str ;
c1, c2 : ComplCase ; c1, c2 : ComplCase ;
obj1 : Agr => Str obj1 : Agr => Str
} ; } ;
CN = { CN = {
s : NAgr => Str ; s : NAgr => Str ;
c1, c2 : ComplCase ; c1, c2 : ComplCase ;
obj1 : Agr => Str obj1 : Agr => Str
} ; } ;
IP = {s : Str ; a : IPAgr} ;
Prep = {s : Str} ; -- language specific
Conj = {s : Str} ;
IAdv = {s : Str} ; NP = NounPhrase ;
IP = {s : NPCase => Str ; n : IPAgr} ; ---- n : Number in Eng
Prep = Preposition ;
Conj = {s1,s2 : Str ; n : Number} ;
oper
NounPhrase = {s : NPCase => Str ; a : Agr} ;
Preposition = {s : Str} ;
----------------------------
--- linearization rules ----
----------------------------
-- standard general
lin lin
aNone, aS, aV, aA, aQ, aN = {s = []} ;
aNP a = a ;
TPres = {s = [] ; t = Pres} ; TPres = {s = [] ; t = Pres} ;
TPast = {s = [] ; t = Past} ; TPast = {s = [] ; t = Past} ;
TFut = {s = [] ; t = Fut} ; TFut = {s = [] ; t = Fut} ;
TCond = {s = [] ; t = Cond} ; TCond = {s = [] ; t = Cond} ;
ASimul = {s = [] ; a = Simul} ; ASimul = {s = [] ; a = Simul} ;
AAnter = {s = [] ; a = Anter} ; AAnter = {s = [] ; a = Anter} ;
PPos = {s = [] ; p = Pos} ; PPos = {s = [] ; p = Pos} ;
PNeg = {s = [] ; p = Neg} ; PNeg = {s = [] ; p = Neg} ;
-- predication specific
aNone, aS, aV, aA, aQ, aN = {s = []} ;
aNP a = a ;
UseV a t p _ v = { UseV a t p _ v = {
v = \\agr => tenseV (a.s ++ t.s ++ p.s) t.t a.a p.p Act agr v ; v = \\agr => tenseV (a.s ++ t.s ++ p.s) t.t a.a p.p Act agr v ;
inf = tenseInfV a.s a.a p.p Act v ; inf = tenseInfV a.s a.a p.p Act v ;
c1 = v.c1 ; c1 = v.c1 ;
c2 = v.c2 ; c2 = v.c2 ;
part = v.p ;
adj = noObj ; adj = noObj ;
obj1 = <noObj, defaultAgr> ; ---- not used, just default value obj1 = <case v.isRefl of {True => \\a => reflPron ! a ; False => \\_ => []}, defaultAgr> ; ---- not used, just default value
obj2 = <noObj, v.isSubjectControl> ; obj2 = <noObj, v.isSubjectControl> ;
adV = negAdV p ; adV = negAdV p ; --- just p.s in Eng
adv = [] ; adv = [] ;
ext = [] ; ext = [] ;
qforms = \\agr => qformsV (a.s ++ t.s ++ p.s) t.t a.a p.p agr v ; qforms = \\agr => qformsV (a.s ++ t.s ++ p.s) t.t a.a p.p agr v ;
@@ -173,6 +231,7 @@ lin
inf = tenseInfV a.s a.a p.p Pass v ; inf = tenseInfV a.s a.a p.p Pass v ;
c1 = v.c1 ; c1 = v.c1 ;
c2 = v.c2 ; c2 = v.c2 ;
part = v.p ;
adj = noObj ; adj = noObj ;
obj1 = <noObj, defaultAgr> ; ---- not used, just default value obj1 = <noObj, defaultAgr> ; ---- not used, just default value
obj2 = <noObj, True> ; -- becomes subject control even if object control otherwise "*she was promised by us to love ourselves" obj2 = <noObj, True> ; -- becomes subject control even if object control otherwise "*she was promised by us to love ourselves"
@@ -187,11 +246,12 @@ lin
inf = tenseInfV a.s a.a p.p Pass v ; inf = tenseInfV a.s a.a p.p Pass v ;
c1 = v.c1 ; c1 = v.c1 ;
c2 = v.c2 ; c2 = v.c2 ;
part = v.p ;
adj = \\a => [] ; adj = \\a => [] ;
obj1 = <noObj, defaultAgr> ; obj1 = <noObj, defaultAgr> ;
obj2 = <noObj, True> ; obj2 = <noObj, True> ;
adV = negAdV p ; adV = negAdV p ;
adv = appComplCase agentCase np ; ---- add a specific field for agent? adv = appComplCase agentCase np ;
ext = [] ; ext = [] ;
qforms = \\agr => qformsBe (a.s ++ t.s ++ p.s) t.t a.a p.p agr ; qforms = \\agr => qformsBe (a.s ++ t.s ++ p.s) t.t a.a p.p agr ;
} ; } ;
@@ -201,6 +261,7 @@ lin
inf = tenseInfV a.s a.a p.p Act be_V ; inf = tenseInfV a.s a.a p.p Act be_V ;
c1 = ap.c1 ; c1 = ap.c1 ;
c2 = ap.c2 ; c2 = ap.c2 ;
part = [] ;
adj = \\a => ap.s ! agr2aagr a ; adj = \\a => ap.s ! agr2aagr a ;
obj1 = <ap.obj1, defaultAgr> ; obj1 = <ap.obj1, defaultAgr> ;
obj2 = <noObj, True> ; --- there are no A3's obj2 = <noObj, True> ; --- there are no A3's
@@ -211,10 +272,10 @@ lin
} ; } ;
SlashV2 x vp np = vp ** { SlashV2 x vp np = vp ** {
obj1 : (Agr => Str) * Agr = <\\a => np.s ! Acc, np.a> -- np.a for object control ---- Acc to be abstracted obj1 : (Agr => Str) * Agr = <\\a => np.s ! objCase, np.a> -- np.a for object control
} ; } ;
SlashV3 x vp np = addObj2VP vp (\\a => np.s ! Acc) ; -- control is preserved ---- Acc to be abstracted SlashV3 x vp np = addObj2VP vp (\\a => np.s ! objCase) ; -- control is preserved
ComplVS x vp cl = addExtVP vp (that_Compl ++ declSubordCl (lin Cl cl)) ; ---- sentence form ComplVS x vp cl = addExtVP vp (that_Compl ++ declSubordCl (lin Cl cl)) ; ---- sentence form
@@ -237,18 +298,18 @@ lin
SlashV2N x vp cn = addObj2VP vp (\\a => cn.s ! agr2nagr a ++ cn.obj1 ! a) ; ---- cn form SlashV2N x vp cn = addObj2VP vp (\\a => cn.s ! agr2nagr a ++ cn.obj1 ! a) ; ---- cn form
ReflVP x vp = vp ** { ReflVP x vp = vp ** {
obj1 : (Agr => Str) * Agr = <\\a => reflPron a, defaultAgr> ; --- hack: defaultAgr will not be used but subj.a instead obj1 : (Agr => Str) * Agr = <\\a => reflPron ! a, defaultAgr> ; --- defaultAgr will not be used but subj.a instead
} ; } ;
ReflVP2 x vp = vp ** { ReflVP2 x vp = vp ** {
obj2 : (Agr => Str) * Bool = <\\a => reflPron a, vp.obj2.p2> ; --- subj/obj control doesn't matter any more obj2 : (Agr => Str) * Bool = <\\a => reflPron ! a, vp.obj2.p2> ; --- subj/obj control doesn't matter any more
} ; } ;
PredVP x np vp = vp ** { PredVP x np vp = vp ** {
v = vp.v ! agr2vagr np.a ; v = vp.v ! agr2vagr np.a ;
subj = np.s ! Nom ; subj = np.s ! subjCase ;
adj = vp.adj ! np.a ; adj = vp.adj ! np.a ;
obj1 = vp.c1 ++ vp.obj1.p1 ! np.a ; ---- apply complCase obj1 = vp.part ++ vp.c1 ++ vp.obj1.p1 ! np.a ; ---- apply complCase ---- place of part depends on obj
obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ; ---- apply complCase obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ; ---- apply complCase
c3 = noComplCase ; -- for one more prep to build ClSlash c3 = noComplCase ; -- for one more prep to build ClSlash
qforms = vp.qforms ! agr2vagr np.a ; qforms = vp.qforms ! agr2vagr np.a ;
@@ -265,26 +326,26 @@ lin
-- QCl ::= Cl by just adding focus field -- QCl ::= Cl by just adding focus field
QuestCl x cl = cl ** {foc = [] ; focType = NoFoc} ; -- NoFoc implies verb first: älskar hon oss QuestCl x cl = cl ** {foc = [] ; focType = NoFoc} ; -- NoFoc implies verb first: does she love us
QuestIAdv x iadv cl = cl ** {foc = iadv.s ; focType = FocObj} ; -- FocObj implies Foc + V + Subj: varför älskar hon oss QuestIAdv x iadv cl = cl ** {foc = iadv.s ; focType = FocObj} ; -- FocObj implies Foc + V + Subj: why does she love us
QuestVP x ip vp = let ipa = ipagr2agr ip.a in QuestVP x ip vp = let ipa = ipagr2agr ip.n in
vp ** { vp ** {
v = vp.v ! ipagr2vagr ip.a ; v = vp.v ! ipagr2vagr ip.n ;
foc = ip.s ; -- vem älskar henne foc = ip.s ! subjCase ; -- who (loves her)
focType = FocSubj ; focType = FocSubj ;
subj = [] ; subj = [] ;
adj = vp.adj ! ipa ; adj = vp.adj ! ipa ;
obj1 = vp.c1 ++ vp.obj1.p1 ! ipa ; ---- appComplCase obj1 = vp.part ++ vp.c1 ++ vp.obj1.p1 ! ipa ; ---- appComplCase
obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ipa ; False => vp.obj1.p2}) ; ---- appComplCase obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ipa ; False => vp.obj1.p2}) ; ---- appComplCase
c3 = noComplCase ; -- for one more prep to build ClSlash ---- ever needed for QCl? c3 = noComplCase ; -- for one more prep to build ClSlash ---- ever needed for QCl?
qforms = vp.qforms ! ipagr2vagr ip.a ; qforms = vp.qforms ! ipagr2vagr ip.n ;
} ; } ;
QuestSlash x ip cl = QuestSlash x ip cl =
let let
ips = cl.c3 ++ ip.s ; -- in Cl/NP, c3 is the only prep ---- appComplCase for ip ips = cl.c3 ++ ip.s ! objCase ; -- in Cl/NP, c3 is the only prep ---- appComplCase for ip
focobj = case cl.focType of { focobj = case cl.focType of {
NoFoc => <ips, [], FocObj> ; -- put ip object to focus if there is no focus yet NoFoc => <ips, [], FocObj> ; -- put ip object to focus if there is no focus yet
t => <[], ips, t> -- put ip object in situ if there already is a focus t => <[], ips, t> -- put ip object in situ if there already is a focus
@@ -311,7 +372,7 @@ lin
PresPartAP x v = { PresPartAP x v = {
s = \\a => v.v ! vPresPart a ; s = \\a => v.v ! vPresPart a ;
c1 = v.c1 ; -- tittande på henne c1 = v.c1 ; -- looking at her
c2 = v.c2 ; c2 = v.c2 ;
obj1 = noObj ; obj1 = noObj ;
} ; } ;
@@ -339,11 +400,11 @@ lin
in in
vv.p1 ++ v.adV ++ vv.p2 ++ vv.p3 ++ v.adj ! vpa ++ vv.p1 ++ v.adV ++ vv.p2 ++ vv.p3 ++ v.adj ! vpa ++
v.c1 ++ v.obj1.p1 ! vpa ++ v.c2 ++ v.obj2.p1 ! vpa ++ v.adv ++ v.ext ---- appComplCase v.c1 ++ v.obj1.p1 ! vpa ++ v.c2 ++ v.obj2.p1 ! vpa ++ v.adv ++ v.ext ---- appComplCase
++ c.s ++ ++ c.s2 ++
wv.p1 ++ w.adV ++ wv.p2 ++ wv.p3 ++ w.adj ! vpa ++ ---- appComplCase wv.p1 ++ w.adV ++ wv.p2 ++ wv.p3 ++ w.adj ! vpa ++ ---- appComplCase
w.c1 ++ w.obj1.p1 ! vpa ++ w.c2 ++ w.obj2.p1 ! vpa ++ w.adv ++ w.ext ; w.c1 ++ w.obj1.p1 ! vpa ++ w.c2 ++ w.obj2.p1 ! vpa ++ w.adv ++ w.ext ;
inf = \\a => inf = \\a =>
infVP a (lin VP v) ++ c.s ++ infVP a (lin VP w) ; infVP a (lin VP v) ++ c.s2 ++ infVP a (lin VP w) ;
c1 = [] ; ---- w.c1 ? --- the full story is to unify v and w... c1 = [] ; ---- w.c1 ? --- the full story is to unify v and w...
c2 = [] ; ---- w.c2 ? c2 = [] ; ---- w.c2 ?
} ; } ;
@@ -353,6 +414,7 @@ lin
inf = <[], vpc.inf ! defaultAgr> ; ---- agreement inf = <[], vpc.inf ! defaultAgr> ; ---- agreement
c1 = vpc.c1 ; c1 = vpc.c1 ;
c2 = vpc.c2 ; c2 = vpc.c2 ;
part = [] ;
adj = \\a => [] ; adj = \\a => [] ;
obj1 = <noObj, defaultAgr> ; obj1 = <noObj, defaultAgr> ;
obj2 = <noObj,True> ; obj2 = <noObj,True> ;
@@ -362,7 +424,7 @@ lin
} ; } ;
StartClC c x a b = { StartClC c x a b = {
s = declCl (lin Cl a) ++ c.s ++ declCl (lin Cl b) ; s = declCl (lin Cl a) ++ c.s2 ++ declCl (lin Cl b) ;
c3 = b.c3 ; ---- c3 = b.c3 ; ----
} ; } ;
@@ -386,27 +448,27 @@ lin
---- the following may become parameters for a functor ---- the following may become parameters for a functor
oper oper
vPastPart : AAgr -> VForm = \_ -> VPastPart ;
vPresPart : AAgr -> VForm = \_ -> VPresPart ;
be_V : V = lin V {v = mkVerb "be" "is" "was" "been" "being" ; c1,c2 = [] ; isAux = True ; isSubjectControl = False} ; be_V : V = lin V {v = mkVerb "be" "is" "was" "been" "being" ; p,c1,c2 = [] ; isAux = True ; isSubjectControl,isRefl = False} ;
negAdV : Pol -> Str = \p -> p.s ; negAdV : Pol -> Str = \p -> p.s ;
reflPron : Agr -> Str = \a -> case a of { reflPron : Agr => Str = table {
Ag Sg P1 => "myself" ; AgP1 Sg => "myself" ;
Ag Sg P2 => "yourself" ; AgP2 Sg => "yourself" ;
Ag Sg P3 => "herself" | "himself" | "itself" ; ---- AgP3Sg Masc => "himself" ;
Ag Pl P1 => "ourselves" ; AgP3Sg Fem => "herself" ;
Ag Pl P2 => "ourselves" ; AgP3Sg Neutr => "itself" ;
Ag Pl P3 => "yourselves" AgP1 Pl => "ourselves" ;
AgP2 Pl => "yourselves" ;
AgP3Pl => "themselves"
} ; } ;
infVP : Agr -> VP -> Str = \a,vp -> infVP : Agr -> VP -> Str = \a,vp ->
let let
a2 = case vp.obj2.p2 of {True => a ; False => vp.obj1.p2} a2 = case vp.obj2.p2 of {True => a ; False => vp.obj1.p2}
in in
vp.adV ++ vp.inf.p1 ++ vp.inf.p2 ++ vp.adV ++ vp.inf.p1 ++ vp.inf.p2 ++ vp.part ++
vp.adj ! a ++ vp.c1 ++ vp.obj1.p1 ! a ++ vp.c2 ++ vp.obj2.p1 ! a2 ++ vp.adv ++ vp.ext ; vp.adj ! a ++ vp.c1 ++ vp.obj1.p1 ! a ++ vp.c2 ++ vp.obj2.p1 ! a2 ++ vp.adv ++ vp.ext ;
qformsV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str = qformsV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str =
@@ -432,13 +494,13 @@ oper
case o of { case o of {
Act => tenseActV sta t a p agr v ; Act => tenseActV sta t a p agr v ;
Pass => tensePassV sta t a p agr v Pass => tensePassV sta t a p agr v
} } {-
| ---- leaving out variants makes compilation time go down from 900ms to 300ms. | ---- leaving out these variants makes compilation time go down from 900ms to 300ms.
---- parsing time of "she sleeps" goes down from 300ms to 60ms. 4/2/2014 ---- parsing time of "she sleeps" goes down from 300ms to 60ms. 4/2/2014
case o of { case o of {
Act => tenseActVContracted sta t a p agr v ; Act => tenseActVContracted sta t a p agr v ;
Pass => tensePassVContracted sta t a p agr v Pass => tensePassVContracted sta t a p agr v
} ; -} ;
tenseActV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tenseActV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v ->
let vt : VForm = case <t,agr> of { let vt : VForm = case <t,agr> of {
@@ -457,9 +519,9 @@ oper
} }
} ; } ;
<Pres|Past, Anter> => <have_Aux vt Pos, not_Str p, sta ++ v.v ! VPastPart> ; <Pres|Past, Anter> => <have_Aux vt Pos, not_Str p, sta ++ v.v ! VPPart> ;
<Fut|Cond, Simul> => <will_Aux vt Pos, not_Str p, sta ++ v.v ! VInf> ; <Fut|Cond, Simul> => <will_Aux vt Pos, not_Str p, sta ++ v.v ! VInf> ;
<Fut|Cond, Anter> => <will_Aux vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPastPart> <Fut|Cond, Anter> => <will_Aux vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPPart>
} ; } ;
tenseActVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tenseActVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v ->
@@ -479,31 +541,31 @@ oper
Neg => <do_Aux vt p, [], sta ++ v.v ! VInf> Neg => <do_Aux vt p, [], sta ++ v.v ! VInf>
} }
} ; } ;
<Pres|Past, Anter> => <have_AuxC vt p, [], sta ++ v.v ! VPastPart> <Pres|Past, Anter> => <have_AuxC vt p, [], sta ++ v.v ! VPPart>
| <have_AuxC vt Pos, not_Str p, sta ++ v.v ! VPastPart> ; | <have_AuxC vt Pos, not_Str p, sta ++ v.v ! VPPart> ;
<Fut|Cond, Simul> => <will_AuxC vt p, [], sta ++ v.v ! VInf> <Fut|Cond, Simul> => <will_AuxC vt p, [], sta ++ v.v ! VInf>
| <will_AuxC vt Pos, not_Str p, sta ++ v.v ! VInf> ; | <will_AuxC vt Pos, not_Str p, sta ++ v.v ! VInf> ;
<Fut|Cond, Anter> => <will_AuxC vt p, have_Aux VInf Pos, sta ++ v.v ! VPastPart> <Fut|Cond, Anter> => <will_AuxC vt p, have_Aux VInf Pos, sta ++ v.v ! VPPart>
| <will_AuxC vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPastPart> | <will_AuxC vt Pos, not_Str p ++ have_Aux VInf Pos, sta ++ v.v ! VPPart>
} ; } ;
tensePassV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tensePassV : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v ->
let let
be = be_AuxL sta t a p agr ; be = be_AuxL sta t a p agr ;
done = v.v ! VPastPart done = v.v ! VPPart
in in
<be.p1, be.p2, be.p3 ++ done> ; <be.p1, be.p2, be.p3 ++ done> ;
tensePassVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v -> tensePassVContracted : Str -> STense -> Anteriority -> Polarity -> VAgr -> V -> Str * Str * Str = \sta,t,a,p,agr,v ->
let let
be = be_AuxC sta t a p agr ; be = be_AuxC sta t a p agr ;
done = v.v ! VPastPart done = v.v ! VPPart
in in
<be.p1, be.p2, be.p3 ++ done> ; <be.p1, be.p2, be.p3 ++ done> ;
tenseInfV : Str -> Anteriority -> Polarity -> Voice -> V -> Str * Str = \sa,a,p,o,v -> tenseInfV : Str -> Anteriority -> Polarity -> Voice -> V -> Str * Str = \sa,a,p,o,v ->
case a of { case a of {
Simul => <[], sa ++ v.v ! VInf> ; -- hon vill sova Simul => <[], sa ++ v.v ! VInf> ; -- (she wants to) sleep
Anter => <have_Aux VInf Pos, sa ++ v.v ! VPastPart> -- hon vill (ha) sovit Anter => <have_Aux VInf Pos, sa ++ v.v ! VPPart> -- (she wants to) have slept
} ; } ;
----- dangerous variants for PMCFG generation - keep apart as long as possible ----- dangerous variants for PMCFG generation - keep apart as long as possible
@@ -556,7 +618,7 @@ oper
questSubordCl : QCl -> Str = \cl -> questSubordCl : QCl -> Str = \cl ->
let let
rest = cl.subj ++ cl.adV ++ cl.v.p1 ++ (cl.v.p2 | []) ++ restCl cl rest = cl.subj ++ cl.adV ++ cl.v.p1 ++ cl.v.p2 ++ restCl cl
in case cl.focType of { in case cl.focType of {
NoFoc => "if" ++ cl.foc ++ rest ; -- om she sleeps NoFoc => "if" ++ cl.foc ++ rest ; -- om she sleeps
FocObj => cl.foc ++ rest ; -- who she loves / why she sleeps FocObj => cl.foc ++ rest ; -- who she loves / why she sleeps
@@ -568,15 +630,6 @@ oper
-- this part is usually the same in all reconfigurations -- this part is usually the same in all reconfigurations
restCl : Clause -> Str = \cl -> cl.v.p3 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ++ cl.c3 ; restCl : Clause -> Str = \cl -> cl.v.p3 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ++ cl.c3 ;
agentCase : ComplCase = "by" ;
appComplCase : ComplCase -> NP -> Str = \p,np -> p ++ np.s ! Acc ;
noComplCase : ComplCase = [] ;
prepComplCase : Prep -> ComplCase = \p -> p.s ;
noObj : Agr => Str = \\_ => [] ;
addObj2VP : VerbPhrase -> (Agr => Str) -> VerbPhrase = \vp,obj -> vp ** { addObj2VP : VerbPhrase -> (Agr => Str) -> VerbPhrase = \vp,obj -> vp ** {
obj2 = <\\a => vp.obj2.p1 ! a ++ obj ! a, vp.obj2.p2> ; obj2 = <\\a => vp.obj2.p1 ! a ++ obj ! a, vp.obj2.p2> ;
@@ -617,34 +670,34 @@ lin
professor_N = {s = table {Sg => "professor" ; Pl => "professors"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; professor_N = {s = table {Sg => "professor" ; Pl => "professors"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ;
manager_N2 = {s = table {Sg => "manager" ; Pl => "managers"} ; c1 = "for" ; c2 = [] ; obj1 = \\_ => []} ; manager_N2 = {s = table {Sg => "manager" ; Pl => "managers"} ; c1 = "for" ; c2 = [] ; obj1 = \\_ => []} ;
she_NP = {s = table {Nom => "she" ; Acc => "her"} ; a = Ag Sg P3} ; she_NP = {s = table {NCase Nom => "she" ; _ => "her"} ; a = AgP3Sg Fem} ;
we_NP = {s = table {Nom => "we" ; Acc => "us"} ; a = Ag Pl P1} ; we_NP = {s = table {NCase Nom => "we" ; _ => "us"} ; a = AgP1 Pl} ;
today_Adv = {s = "today" ; isAdV = False} ; today_Adv = {s = "today" ; isAdV = False} ;
always_AdV = {s = "always" ; isAdV = True} ; always_AdV = {s = "always" ; isAdV = True} ;
who_IP = {s = "who" ; a = Sg} ; who_IP = {s = \\_ => "who" ; n = Sg} ;
PrepNP p np = {s = p.s ++ np.s ! Acc ; isAdV = False} ; PrepNP p np = {s = p.s ++ np.s ! objCase ; isAdV = False} ;
with_Prep = {s = "with"} ; with_Prep = {s = "with"} ;
and_Conj = {s = "and"} ; and_Conj = {s1 = [] ; s2 = "and" ; n = Pl} ;
why_IAdv = {s = "why"} ; why_IAdv = {s = "why"} ;
oper oper
mkV = overload { mkV = overload {
mkV : Str -> V = \s -> lin V {v = mkVerb s (s + "s") (edV s) (edV s) (ingV s) ; c1 = [] ; c2 = [] ; isAux,isSubjectControl = False} ; mkV : Str -> V = \s -> lin V {v = mkVerb s (s + "s") (edV s) (edV s) (ingV s) ; p,c1,c2 = [] ; isAux,isSubjectControl,isRefl = False} ;
mkV : Str -> Str -> Str -> V = \s,p,q -> lin V {v = mkVerb s (s + "s") (edV s) (edV s) (ingV s) ; c1 = p ; c2 = q ; isAux,isSubjectControl = False} ; mkV : Str -> Str -> Str -> V = \s,p,q -> lin V {v = mkVerb s (s + "s") (edV s) (edV s) (ingV s) ; p = [] ; c1 = p ; c2 = q ; isAux,isSubjectControl,isRefl = False} ;
mkV : Str -> Str -> Str -> Str -> Str -> V = \s,t,u,p,q -> lin V {v = mkVerb s (s + "s") t u (ingV s) ; c1 = p ; c2 = q ; isAux,isSubjectControl = False} ; mkV : Str -> Str -> Str -> Str -> Str -> V = \s,t,u,p,q -> lin V {v = mkVerb s (s + "s") t u (ingV s) ; p = [] ; c1 = p ; c2 = q ; isAux,isSubjectControl,isRefl = False} ;
} ; } ;
mkVerb : Str -> Str -> Str -> Str -> Str -> VForm => Str = \go,goes,went,gone,going -> table { mkVerb : Str -> Str -> Str -> Str -> Str -> VForm => Str = \go,goes,went,gone,going -> table {
VInf => go ; VInf => go ;
VPres => goes ; VPres => goes ;
VPast => went ; VPast => went ;
VPastPart => gone ; VPPart => gone ;
VPresPart => going VPresPart => going
} ; } ;

13
lib/src/experimental/TransEng.gf
View File

@@ -1,14 +1,17 @@
--# -path=.:../translator --# -path=.:../translator
concrete TransEng of Trans = concrete TransEng of Trans =
RGLBaseEng RGLBaseEng - [Pol]
,PredEng ,PredEng
,DictionaryEng ,DictionaryEng - [Pol]
** open Prelude in {
** {
{-
lin lin
LiftV : V -> PrV aNone ; LiftV v = v ** {v = v.s ; c1,c2 = [] ; isSubjectControl, isAux = False} ;
{-
LiftV2 : V2 -> PrV (aNP aNone) ; LiftV2 : V2 -> PrV (aNP aNone) ;
LiftVS : VS -> PrV aS ; LiftVS : VS -> PrV aS ;
LiftVQ : VQ -> PrV aQ ; LiftVQ : VQ -> PrV aQ ;