From cf576d245d9456a2de3776f2ada5409a7da51ebd Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 3 Feb 2014 14:04:04 +0000 Subject: [PATCH] PredicationEng now almost a functor with Swe ; details to be fixed on e.g. aux/non-aux V distinction --- lib/src/experimental/Predication.gf | 9 +- lib/src/experimental/PredicationEng.gf | 624 ++++++++++++++----------- lib/src/experimental/PredicationSwe.gf | 161 +++---- 3 files changed, 451 insertions(+), 343 deletions(-) diff --git a/lib/src/experimental/Predication.gf b/lib/src/experimental/Predication.gf index 9d3f76b61..3744d3d37 100644 --- a/lib/src/experimental/Predication.gf +++ b/lib/src/experimental/Predication.gf @@ -16,7 +16,6 @@ cat QCl Arg ; NP ; Adv ; - AdV ; S ; Utt ; AP Arg ; @@ -67,18 +66,20 @@ fun UseCl : Cl aNone -> S ; UseQCl : QCl aNone -> S ; -- deprecate QS + + UseAdvCl : Adv -> Cl aNone -> S ; -- lift adv to front UttS : S -> Utt ; -- when to add adverbs ---- AdvVP : Adv -> (a : Arg) -> VP a -> VP a ; ---- these create many ambiguities ----- AdVVP : AdV -> (a : Arg) -> VP a -> VP a ; ---- "hon tvingar oss att sova idag": 196 parses, 13s. With AdvVP restricted to top level: 32 parses, 7s ---- with AdvCl, just 16 parses, 0.2 s AdvCl : Adv -> (a : Arg) -> Cl a -> Cl a ; - AdVCl : AdV -> (a : Arg) -> Cl a -> Cl a ; + + AdvQCl : Adv -> (a : Arg) -> QCl a -> QCl a ; -- participles as adjectives @@ -132,7 +133,7 @@ fun we_NP : NP ; today_Adv : Adv ; - always_AdV : AdV ; + always_AdV : Adv ; who_IP : IP ; with_Prep : Prep ; diff --git a/lib/src/experimental/PredicationEng.gf b/lib/src/experimental/PredicationEng.gf index adf3cce7d..43d2849a3 100644 --- a/lib/src/experimental/PredicationEng.gf +++ b/lib/src/experimental/PredicationEng.gf @@ -1,386 +1,490 @@ concrete PredicationEng of Predication = open Prelude in { +-- English predication, based on Swedish +-- two principles: +-- - 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? + param Agr = Sg | Pl ; Case = Nom | Acc ; - Tense = Pres | Past ; + STense = Pres | Past | Perf | Fut ; + Anteriority = Simul | Anter ; Polarity = Pos | Neg ; + VForm = VInf | VPres | VPast | VPastPart | VPresPart ; + Voice = Act | Pass ; + + FocusType = NoFoc | FocSubj | FocObj ; -- sover hon/om hon sover, vem älskar hon/vem hon älskar, vem sover/vem som sover + + +oper + defaultAgr = Sg ; + ComplCase = Str ; -- preposition lincat Arg = {s : Str} ; V = { - v : Tense => Agr => Str ; - c1 : Str ; - c2 : Str + v : VForm => Str ; + c1 : ComplCase ; + c2 : ComplCase ; + isSubjectControl : Bool ; } ; VP = { - v : Agr => Str * Str ; - inf : Str ; - c1 : Str ; - c2 : Str ; - adj,obj1,obj2 : Agr => Str ; + v : Str * Str * Str ; -- ska,ha,sovit + inf : Str * Str ; -- ha,sovit + c1 : ComplCase ; + c2 : ComplCase ; + adj : Agr => Str ; + obj1 : (Agr => Str) * Agr ; + obj2 : (Agr => Str) * Bool ; -- subject control = True adv : Str ; adV : Str ; ext : Str } ; - Cl = { - v : Str * Str ; - inf : Str ; +oper Clause = { + v : Str * Str * Str ; + inf : Str * Str ; adj,obj1,obj2 : Str ; adv : Str ; adV : Str ; ext : Str ; subj : Str ; - c3 : Str + c3 : ComplCase -- for a slashed adjunct, not belonging to the verb valency } ; - QCl = { - v : Str * Str ; - inf : Str ; - adj,obj1,obj2 : Str ; - adv : Str ; - adV : Str ; - ext : Str ; - subj : Str ; - c3 : Str ; +lincat + Cl = Clause ; + + QCl = Clause ** { foc : Str ; -- the focal position at the beginning, e.g. *vem* älskar hon - hasFoc : Bool ; --- if already filled, then use other place: vem älskar *vem* + focType : FocusType ; --- if already filled, then use other place: vem älskar *vem* } ; VPC = { v : Agr => Str ; inf : Agr => Str ; - c1 : Str ; - c2 : Str + c1 : ComplCase ; + c2 : ComplCase } ; - Temp = {s : Str ; t : Tense} ; - Pol = {s : Str ; p : Polarity} ; + ClC = { + s : Str ; + c3 : ComplCase ; + } ; + + Tense = {s : Str ; t : STense} ; + Ant = {s : Str ; a : Anteriority} ; + Pol = {s : Str ; p : Polarity} ; + NP = {s : Case => Str ; a : Agr} ; - Adv = {s : Str} ; - AdV = {s : Str} ; + Adv = {s : Str ; isAdV : Bool} ; S = {s : Str} ; Utt = {s : Str} ; - AP = {s : Str ; c1 : Str ; c2 : Str ; obj1 : Agr => Str} ; + AP = { + s : Agr => Str ; + c1, c2 : ComplCase ; + obj1 : + Agr => Str + } ; + CN = { + s : Agr => Str ; + c1, c2 : ComplCase ; + obj1 : + Agr => Str + } ; IP = {s : Str ; a : Agr} ; Prep = {s : Str} ; Conj = {s : Str} ; + IAdv = {s : Str} ; lin - aNone, aS, aV = {s = []} ; + aNone, aS, aV, aA, aQ, aN = {s = []} ; aNP a = a ; - TPres = {s = [] ; t = Pres} ; - TPast = {s = [] ; t = Past} ; + TPres = {s = [] ; t = Pres} ; + TPast = {s = [] ; t = Past} ; + TFut = {s = [] ; t = Fut} ; + TCond = {s = [] ; t = Perf} ; + ASimul = {s = [] ; a = Simul} ; + AAnter = {s = [] ; a = Anter} ; + PPos = {s = [] ; p = Pos} ; PNeg = {s = [] ; p = Neg} ; - UseV t p _ v = { - v = \\a => ; ---- always with "do" - inf = t.s ++ p.s ++ neg p.p ++ aux t.t ++ v.v ! Pres ! Pl ; + UseV a t p _ v = { + v = tenseV (a.s ++ t.s) t.t a.a Act v ; + inf = tenseInfV a.s a.a Act v ; c1 = v.c1 ; c2 = v.c2 ; - adj,obj1,obj2 = \\a => [] ; - adv,adV = [] ; + adj = noObj ; + obj1 = ; ---- not used, just default value + obj2 = ; + adV = p.s ++ neg p.p ; + adv = [] ; ext = [] ; } ; - UseAP t p _ ap = { - v = \\a => ; ---- always with "do" - inf = t.s ++ p.s ++ neg p.p ++ aux t.t ++ "be" ; + PassUseV a t p _ v = { + v = tenseV (a.s ++ t.s) t.t a.a Pass v ; + inf = tenseInfV a.s a.a Pass v ; + c1 = v.c1 ; + c2 = v.c2 ; + adj = noObj ; + obj1 = ; ---- not used, just default value + obj2 = ; -- becomes subject control even if object control otherwise "*she was promised by us to love ourselves" + adV = p.s ++ neg p.p ; + adv = [] ; + ext = [] ; + } ; + + AgentPassUseV a t p _ v np = { + v = tenseV (a.s ++ t.s) t.t a.a Pass v ; + inf = tenseInfV a.s a.a Pass v ; + c1 = v.c1 ; + c2 = v.c2 ; + adj = \\a => [] ; + obj1 = ; + obj2 = ; + adV = p.s ++ neg p.p ; + adv = appComplCase agentCase np ; ---- add a specific field for agent? + ext = [] ; + } ; + + UseAP a t p _ ap = { + v = tenseV (a.s ++ t.s) t.t a.a Act be_V ; + inf = tenseInfV a.s a.a Act be_V ; c1 = ap.c1 ; c2 = ap.c2 ; - adj = \\_ => ap.s ; - obj1 = ap.obj1 ; - obj2 = \\a => [] ; - adv,adV = [] ; + adj = \\a => ap.s ! a ; + obj1 = ; + obj2 = ; --- there are no A3's + adV = p.s ++ neg p.p ; + adv = [] ; ext = [] ; } ; - SlashVNP x vp np = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = \\a => np.s ! Acc ; - obj2 = vp.obj2 ; - adv = vp.adv ; - adV = vp.adV ; - ext = vp.ext ; + SlashV2 x vp np = vp ** { + obj1 : (Agr => Str) * Agr = <\\a => np.s ! Acc, np.a> -- np.a for object control ---- Acc to be abstracted } ; - SlashVNP2 x vp np = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = \\a => np.s ! Acc ; - adv = vp.adv ; - adV = vp.adV ; - ext = vp.ext ; + 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 ! a ++ ap.obj1 ! a) ; ---- adjForm + + ComplVN x vp cn = addObj2VP vp (\\a => cn.s ! 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 ! a ++ ap.obj1 ! a) ; ---- adjForm + + SlashV2N x vp cn = addObj2VP vp (\\a => cn.s ! 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 } ; - ComplVS x vp cl = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = vp.obj2 ; - adV = vp.adV ; - adv = vp.adv ; - ext = declCl (lin Cl cl) ; + ReflVP2 x vp = vp ** { + obj2 : (Agr => Str) * Bool = <\\a => reflPron a, vp.obj2.p2> ; --- subj/obj control doesn't matter any more } ; - ComplVV x vp vpo = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = \\a => infVP a vpo ; - adV = vp.adV ; - adv = vp.adv ; - ext = vp.ext ; - } ; - - SlashV2S x vp cl = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = vp.obj2 ; - adV = vp.adV ; - adv = vp.adv ; - ext = declCl (lin Cl cl) ; - } ; - - SlashV2V x vp vpo = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = \\a => infVP a vpo ; - adV = vp.adV ; - adv = vp.adv ; - ext = vp.ext ; - } ; - - AdvVP adv _ vp = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = vp.obj2 ; - adV = vp.adV ; - adv = vp.adv ++ adv.s ; - ext = vp.ext ; - } ; - - AdVVP adv _ vp = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = vp.obj2 ; - adV = vp.adV ++ adv.s ; - adv = vp.adv ; - ext = vp.ext ; - } ; - - ReflVP x vp = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = \\a => reflPron a ; - obj2 = vp.obj2 ; - adV = vp.adV ; - adv = vp.adv ; - ext = vp.ext ; - } ; - - ReflVP2 x vp = { - v = vp.v ; - inf = vp.inf ; - c1 = vp.c1 ; - c2 = vp.c2 ; - adj = vp.adj ; - obj1 = vp.obj1 ; - obj2 = \\a => reflPron a ; - adV = vp.adV ; - adv = vp.adv ; - ext = vp.ext ; - } ; - - PredVP x np vp = { + PredVP x np vp = vp ** { subj = np.s ! Nom ; - v = vp.v ! np.a ; - inf = vp.inf ; adj = vp.adj ! np.a ; - obj1 = vp.c1 ++ vp.obj1 ! np.a ; - obj2 = vp.c2 ++ vp.obj2 ! np.a ; - adV = vp.adV ; - adv = vp.adv ; - ext = vp.ext ; - c3 = [] ; -- for one more prep to build ClSlash + obj1 = vp.c1 ++ vp.obj1.p1 ! np.a ; ---- 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 } ; - PrepCl p x cl = { - subj = cl.subj ; - v = cl.v ; - inf = cl.inf ; - adj = cl.adj ; - obj1 = cl.obj1 ; - obj2 = cl.obj2 ; - adV = cl.adV ; - adv = cl.adv ; - ext = cl.ext ; - c3 = p.s ; -- for one more prep to build ClSlash + 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 } ; - QuestCl x cl = cl ** {foc = [] ; hasFoc = False} ; -- verb first: älskar hon oss +-- QCl ::= Cl by just adding focus field + QuestCl x cl = cl ** {foc = [] ; focType = NoFoc} ; -- NoFoc implies verb first: älskar hon oss - QuestVP x ip vp = { + QuestIAdv x iadv cl = cl ** {foc = iadv.s ; focType = FocObj} ; -- FocObj implies Foc + V + Subj: varför älskar hon oss + + QuestVP x ip vp = vp ** { foc = ip.s ; -- vem älskar henne - hasFoc = True ; + focType = FocSubj ; subj = [] ; - v = vp.v ! ip.a ; - inf = vp.inf ; adj = vp.adj ! ip.a ; - obj1 = vp.c1 ++ vp.obj1 ! ip.a ; - obj2 = vp.c2 ++ vp.obj2 ! ip.a ; - adV = vp.adV ; - adv = vp.adv ; - ext = vp.ext ; - c3 = [] ; -- for one more prep to build ClSlash + obj1 = vp.c1 ++ vp.obj1.p1 ! ip.a ; ---- appComplCase + obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ip.a ; False => vp.obj1.p2}) ; ---- appComplCase + c3 = noComplCase ; -- for one more prep to build ClSlash ---- ever needed for QCl? } ; - QuestSlash x ip cl = + QuestSlash x ip cl = let - ips = cl.c3 ++ ip.s ; ---- c3? - focobj = case cl.hasFoc of { - True => <[],ips> ; - False => + ips = cl.c3 ++ ip.s ; -- in Cl/NP, c3 is the only prep ---- appComplCase for ip + focobj = case cl.focType of { + NoFoc => ; -- 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 { - foc = focobj.p1 ; - hasFoc = True ; - subj = cl.subj ; - v = cl.v ; - inf = cl.inf ; - adj = cl.adj ; - obj1 = cl.obj1 ++ focobj.p2 ; - obj2 = cl.obj2 ; ---- slash to this part? - adV = cl.adV ; - adv = cl.adv ; - ext = cl.ext ; - c3 = [] ; - } ; + 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} ; UseQCl cl = {s = questCl cl} ; + UseAdvCl adv cl = {s = adv.s ++ declInvCl cl} ; + UttS s = s ; - StartVPC c x v w = { - v = \\a => - (v.v ! a).p1 ++ v.adV ++ (v.v ! a).p2 ++ v.adj ! a ++ v.c1 ++ v.obj1 ! a ++ v.c2 ++ v.obj2 ! a ++ v.adv ++ v.ext - ++ c.s ++ - (w.v ! a).p1 ++ w.adV ++ (w.v ! a).p2 ++ w.adj ! a ++ w.c1 ++ w.obj1 ! a ++ w.c2 ++ w.obj2 ! a ++ 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 ; + 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 ; } ; - UseVPC x vpc = { - v = \\a => ; ---- there is no uniform tense - inf = vpc.inf ! Sg ; ---- agreement + 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 => + v.v.p1 ++ v.adV ++ v.v.p2 ++ v.v.p3 ++ v.adj ! a ++ + v.c1 ++ v.obj1.p1 ! a ++ v.c2 ++ v.obj2.p1 ! a ++ v.adv ++ v.ext ---- appComplCase + ++ c.s ++ + w.v.p1 ++ w.adV ++ w.v.p2 ++ w.v.p3 ++ w.adj ! a ++ ---- appComplCase + w.c1 ++ w.obj1.p1 ! a ++ w.c2 ++ w.obj2.p1 ! a ++ 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 = <[], [], vpc.v ! defaultAgr> ; ---- agreement + inf = <[], vpc.inf ! defaultAgr> ; ---- agreement c1 = vpc.c1 ; c2 = vpc.c2 ; - adj,obj1,obj2 = \\a => [] ; + adj = \\a => [] ; + obj1 = ; + obj2 = ; adv,adV = [] ; ext = [] ; } ; + StartClC c x a b = { + s = declCl (lin Cl a) ++ c.s ++ declCl (lin Cl b) ; + c3 = b.c3 ; ---- + } ; - sleep_V = mkV "sleep" ; + UseClC x cl = { + subj = [] ; + v = <[],[],cl.s> ; ---- + inf = <[],[]> ; + adj = [] ; + obj1 = [] ; + obj2 = [] ; + adV = [] ; + adv = [] ; + ext = [] ; + c3 = cl.c3 ; + } ; + + + + + +---- the following may become parameters for a functor + +oper + vPastPart : Agr -> VForm = \_ -> VPastPart ; + vPresPart : Agr -> VForm = \_ -> VPresPart ; + + be_V : V = lin V {v = mkVerb "be" "is" "was" "been" "being" ; c1,c2 = [] ; isAux = True ; isSubjectControl = False} ; + + neg : Polarity -> Str = \p -> case p of {Pos => [] ; Neg => "not"} ; + + reflPron : Agr -> Str = \a -> case a of {Sg => "herself" ; Pl => "us"} ; + + infVP : Agr -> VP -> Str = \a,vp -> + let + a2 = case vp.obj2.p2 of {True => a ; False => vp.obj1.p2} + in + vp.adV ++ (vp.inf.p1 | []) ++ vp.inf.p2 ++ ---- *hon tvingar oss att sovit + vp.adj ! a ++ vp.c1 ++ vp.obj1.p1 ! a ++ vp.c2 ++ vp.obj2.p1 ! a2 ++ vp.adv ++ vp.ext ; + + tenseV : Str -> STense -> Anteriority -> Voice -> V -> Str * Str * Str = \sta,t,a,o,v -> case o of { --- sta dummy s field of Ant and Tense + Act => tenseActV sta t a v ; + Pass => tensePassV sta t a v + } ; + tenseActV : Str -> STense -> Anteriority -> V -> Str * Str * Str = \sta,t,a,v -> case of { --- sta dummy s field of Ant and Tense + => ; + => ; + => ; + => ; + => ; + => ; + => ; + => + } ; + tensePassV : Str -> STense -> Anteriority -> V -> Str * Str * Str = \sta,t,a,v -> + let + be = tenseActV sta t a be_V ; + done = v.v ! VPastPart + in + ; + + tenseInfV : Str -> Anteriority -> Voice -> V -> Str * Str = \sa,a,o,v -> + case a of { + Simul => <[], sa ++ v.v ! VInf> ; -- hon vill sova + Anter => -- hon vill (ha) sovit + } ; + + + declCl : Clause -> Str = \cl -> cl.subj ++ cl.v.p1 ++ cl.adV ++ cl.v.p2 ++ restCl cl ; + declSubordCl : Clause -> Str = declCl ; + declInvCl : Clause -> Str = declCl ; + + questCl : QCl -> Str = \cl -> cl.foc ++ cl.v.p1 ++ cl.subj ++ cl.adV ++ cl.v.p2 ++ restCl cl ; + + questSubordCl : QCl -> Str = \cl -> + let + rest = cl.subj ++ cl.adV ++ cl.v.p1 ++ (cl.v.p2 | []) ++ restCl cl + in case cl.focType of { + NoFoc => "if" ++ cl.foc ++ rest ; -- om hon sover + FocObj => cl.foc ++ rest ; -- vem älskar hon / varför hon sover + FocSubj => cl.foc ++ "som" ++ rest -- vem som älskar henne + } ; + + that_Compl : Str = "that" | [] ; + + -- 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 ; + + 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 : VP -> (Agr => Str) -> VP = \vp,obj -> vp ** { + obj2 = <\\a => vp.obj2.p1 ! a ++ obj ! a, vp.obj2.p2> ; + } ; + + addExtVP : VP -> Str -> VP = \vp,ext -> vp ** { + ext = ext ; + } ; + + + + +---- the lexicon is just for testing: use standard Eng lexicon and morphology instead + +lin + sleep_V = mkV "sleep" "slept" "slept" [] [] ; walk_V = mkV "walk" ; love_V2 = mkV "love" ; look_V2 = mkV "look" "at" [] ; believe_VS = mkV "believe" ; - tell_V2S = mkV "tell" ; + tell_V2S = mkV "tell" "told" "told" [] [] ; prefer_V3 = mkV "prefer" [] "to" ; want_VV = mkV "want" [] "to" ; force_V2V = mkV "force" [] "to" ; +--- promise_V2V = mkV "promise" [] "to" ** {isSubjectControl = True} ; + wonder_VQ = mkV "wonder" ; + become_VA = mkV "become" "became" "become" [] [] ; + become_VN = mkV "become" "became" "become" [] [] ; + make_V2A = mkV "make" "made" "made" [] [] ; + promote_V2N = mkV "promote" [] "to" ; + ask_V2Q = mkV "ask" ; - old_A = {s = "old" ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; - married_A2 = {s = "married" ; c1 = "to" ; c2 = [] ; obj1 = \\_ => []} ; - eager_AV = {s = "eager" ; c1 = [] ; c2 = "to" ; obj1 = \\_ => []} ; - easy_A2V = {s = "easy" ; c1 = "for" ; c2 = "to" ; obj1 = \\_ => []} ; + old_A = {s = \\_ => "old" ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; + married_A2 = {s = \\_ => "married" ; c1 = "to" ; c2 = [] ; obj1 = \\_ => []} ; + eager_AV = {s = \\_ => "eager" ; c1 = [] ; c2 = "to" ; obj1 = \\_ => []} ; + easy_A2V = {s = \\_ => "easy" ; c1 = "for" ; c2 = "to" ; obj1 = \\_ => []} ; + + professor_N = {s = table {Sg => "professor" ; Pl => "professors"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; + manager_N2 = {s = table {Sg => "manager" ; Pl => "managers"} ; c1 = "for" ; c2 = [] ; obj1 = \\_ => []} ; she_NP = {s = table {Nom => "she" ; Acc => "her"} ; a = Sg} ; we_NP = {s = table {Nom => "we" ; Acc => "us"} ; a = Pl} ; - today_Adv = {s = "today"} ; - always_AdV = {s = "always"} ; + today_Adv = {s = "today" ; isAdV = False} ; + always_AdV = {s = "always" ; isAdV = True} ; who_IP = {s = "who" ; a = Sg} ; - PrepNP p np = {s = p.s ++ np.s ! Acc} ; + PrepNP p np = {s = p.s ++ np.s ! Acc ; isAdV = False} ; with_Prep = {s = "with"} ; and_Conj = {s = "and"} ; + why_IAdv = {s = "why"} ; + oper mkV = overload { - mkV : Str -> V = \s -> lin V {v = \\_,_ => s ; c1 = [] ; c2 = []} ; - mkV : Str -> Str -> Str -> V = \s,p,q -> lin V {v = \\_,_ => s ; c1 = p ; c2 = q} ; + mkV : Str -> V = \s -> lin V {v = mkVerb s (s + "s") (edV s) (edV s) (ingV s) ; c1 = [] ; c2 = [] ; isAux,isSubjectControl = 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 -> 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} ; } ; - do_Aux : Tense -> Agr -> Str = \t,a -> case of { - => "does" ; - => "do" ; - => "did" + mkVerb : Str -> Str -> Str -> Str -> Str -> VForm => Str = \go,goes,went,gone,going -> table { + VInf => go ; + VPres => goes ; + VPast => went ; + VPastPart => gone ; + VPresPart => going } ; - be_Aux : Tense -> Agr -> Str = \t,a -> case of { - => "is" ; - => "are" ; - => "was" ; - => "were" - } ; + edV : Str -> Str = \s -> case s of {us + "e" => us ; _ => s} + "ed" ; + ingV : Str -> Str = \s -> case s of {us + "e" => us ; _ => s} + "ing" ; - neg : Polarity -> Str = \p -> case p of {Pos => [] ; Neg => "not"} ; + do_V : V = lin V {v = mkVerb "do" "does" "did" "done" "doing" ; c1,c2 = [] ; isAux = True ; isSubjectControl = False} ; - aux : Tense -> Str = \t -> case t of {Pres => [] ; Past => "have"} ; + have_V : V = lin V {v = mkVerb "have" "has" "had" "had" "having" ; c1,c2 = [] ; isAux = True ; isSubjectControl = False} ; - reflPron : Agr -> Str = \a -> case a of {Sg => "herself" ; Pl => "ourselves"} ; + will_V : V = lin V {v = mkVerb "will" "will" "would" "would" "will" ; c1,c2 = [] ; isAux = True ; isSubjectControl = False} ; - infVP : Agr -> VP -> Str = \a,vp -> vp.adV ++ vp.inf ++ vp.adj ! a ++ vp.c1 ++ vp.obj1 ! a ++ vp.c2 ++ vp.obj2 ! a ++ vp.adv ++ vp.ext ; - declCl : Cl -> Str = \cl ->cl.subj ++ cl.v.p1 ++ cl.adV ++ cl.v.p2 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ; - - questCl : QCl -> Str = \cl -> cl.foc ++ cl.v.p1 ++ cl.subj ++ cl.adV ++ cl.v.p2 ++ cl.adj ++ cl.obj1 ++ cl.obj2 ++ cl.adv ++ cl.ext ; } \ No newline at end of file diff --git a/lib/src/experimental/PredicationSwe.gf b/lib/src/experimental/PredicationSwe.gf index d06ea647c..e299a293b 100644 --- a/lib/src/experimental/PredicationSwe.gf +++ b/lib/src/experimental/PredicationSwe.gf @@ -82,8 +82,7 @@ lincat Pol = {s : Str ; p : Polarity} ; NP = {s : Case => Str ; a : Agr} ; - Adv = {s : Str} ; - AdV = {s : Str} ; + Adv = {s : Str ; isAdV : Bool} ; S = {s : Str} ; Utt = {s : Str} ; AP = { @@ -254,13 +253,13 @@ lin UseCl cl = {s = declCl cl} ; UseQCl cl = {s = questCl cl} ; + UseAdvCl adv cl = {s = adv.s ++ declInvCl cl} ; + UttS s = s ; - AdvCl a x cl = cl ** {adv = cl.adv ++ a.s} ; - - AdVCl a x cl = cl ** {adV = cl.adV ++ a.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 = { @@ -327,79 +326,10 @@ lin c3 = cl.c3 ; } ; ----- the lexicon is just for testing: use standard Swe lexicon and morphology instead - - sleep_V = mkV "sova" "sover" "sov" "sovit" "soven" "sovna" ; - walk_V = mkV "gå" "går" "gick" "gått" "gången" "gångna" ; - love_V2 = mkV "älska" "älskar" "älskade" "älskat" "älskad" "älskade" ; - look_V2 = mkV "titta" "tittar" "tittade" "tittat" "tittad" "tittade" "på" [] ; - believe_VS = mkV "tro" "tror" "trodde" "trott" "trodd" "trodda" ; - tell_V2S = mkV "berätta" "berättar" "berättade" "berättat" "berättad" "berättade" "för" [] ; - prefer_V3 = mkV "föredra" "föredrar" "föredrog" "föredragit" "föredragen" "föredragna" [] "framför" ; - want_VV = mkV "vilja" "vill" "ville" "velat" "velad" "velade" ; - force_V2V = let tvinga : V = mkV "tvinga" "tvingar" "tvingade" "tvingat" "tvingad" "tvingade" in - {v = tvinga.v ; c1 = [] ; c2 = "att" ; isSubjectControl = False} ; - promise_V2V = mkV "lova" "lovar" "lovade" "lovat" "lovad" "lovade" [] "att" ; - wonder_VQ = mkV "undra" "undrar" "undrade" "undrat" "undrad" "undrade" ; - become_VA = mkV "bli" "blir" "blev" "blivit" "bliven" "blivna" ; - become_VN = mkV "bli" "blir" "blev" "blivit" "bliven" "blivna" ; - make_V2A = let gora : V = mkV "göra" "gör" "gjorde" "gjort" "gjord" "gjorda" in - {v = table {TV Pass VPres => "görs" ; f => gora.v ! f} ; c1 = [] ; c2 = [] ; isSubjectControl = False} ; - promote_V2N = let befordra : V = mkV "befordra" "befordrar" "befordrade" "befordrat" "befordrad" "befordrade" - in {v = befordra.v ; c1 = [] ; c2 = "till" ; isSubjectControl = False} ; ---- ? de befordrade dem till chefer för sig/dem - ask_V2Q = mkV "fråga" "frågar" "frågade" "frågat" "frågad" "frågade" ; - - old_A = {s = table {Sg => "gammal" ; Pl => "gamla"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; - married_A2 = {s = table {Sg => "gift" ; Pl => "gifta"} ; c1 = "med" ; c2 = [] ; obj1 = \\_ => []} ; - eager_AV = {s = table {Sg => "ivrig" ; Pl => "ivriga"} ; c1 = [] ; c2 = "att" ; obj1 = \\_ => []} ; - easy_A2V = {s = table {Sg => "lätt" ; Pl => "lätta"} ; c1 = "för" ; c2 = "att" ; obj1 = \\_ => []} ; - professor_N = {s = table {Sg => "professor" ; Pl => "professorer"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; - manager_N2 = {s = table {Sg => "chef" ; Pl => "chefer"} ; c1 = "för" ; c2 = [] ; obj1 = \\_ => []} ; - - she_NP = {s = table {Nom => "hon" ; Acc => "henne"} ; a = Sg} ; - we_NP = {s = table {Nom => "vi" ; Acc => "oss"} ; a = Pl} ; - - today_Adv = {s = "idag"} ; - always_AdV = {s = "alltid"} ; - - who_IP = {s = "vem" ; a = Sg} ; - - PrepNP p np = {s = p.s ++ np.s ! Acc} ; - - with_Prep = {s = "med"} ; - - and_Conj = {s = "och"} ; - - why_IAdv = {s = "varför"} ; - -oper - mkV = overload { - mkV : (x,y,z,u,v,w : Str) -> V = \x,y,z,u,v,w -> - lin V { - v = table { - TV Act VInf => x ; TV Act VPres => y ; TV Act VPret => z ; TV Act VSup => u ; - TV Pass VInf => x + "s" ; TV Pass VPres => init y + "s" ; TV Pass VPret => z + "s" ; TV Pass VSup => u + "s" ; - PastPart Sg => v ; PastPart Pl => w ; PresPart => x + "nde" - } ; - c1 = [] ; c2 = [] ; isSubjectControl = True} ; - mkV : (x,y,z,u,v,w : Str) -> Str -> Str -> V = \x,y,z,u,v,w,p,q -> - lin V { - v = table { - TV Act VInf => x ; TV Act VPres => y ; TV Act VPret => z ; TV Act VSup => u ; - TV Pass VInf => x + "s" ; TV Pass VPres => init y + "s" ; TV Pass VPret => z + "s" ; TV Pass VSup => u + "s" ; - PastPart Sg => v ; PastPart Pl => w ; PresPart => x + "nde" - } ; - c1 = p ; c2 = q ; isSubjectControl = True} ; - } ; - - be_V : V = mkV "vara" "är" "var" "varit" "varen" "varna" ; - - have_V : V = mkV "ha" "har" "hade" "haft" "havd" "havda" ; - - shall_V : V = mkV "skola" "ska" "skulle" "skolat" "skolad" "skolade" ; - ---- the following may become parameters for a functor +oper + be_V : V = mkV "vara" "är" "var" "varit" "varen" "varna" ; neg : Polarity -> Str = \p -> case p of {Pos => [] ; Neg => "inte"} ; @@ -417,8 +347,8 @@ oper => ; => ; => ; - => <[], have_V.v ! TV Act VPres, sta ++ v.v ! TV o VSup> ; - => <[], have_V.v ! TV Act VPret, sta ++ v.v ! TV o VSup> ; + => ; + => ; => ; => } ; @@ -469,4 +399,77 @@ oper } ; + + + +---- the lexicon is just for testing: use standard Swe lexicon and morphology instead +lin + sleep_V = mkV "sova" "sover" "sov" "sovit" "soven" "sovna" ; + walk_V = mkV "gå" "går" "gick" "gått" "gången" "gångna" ; + love_V2 = mkV "älska" "älskar" "älskade" "älskat" "älskad" "älskade" ; + look_V2 = mkV "titta" "tittar" "tittade" "tittat" "tittad" "tittade" "på" [] ; + believe_VS = mkV "tro" "tror" "trodde" "trott" "trodd" "trodda" ; + tell_V2S = mkV "berätta" "berättar" "berättade" "berättat" "berättad" "berättade" "för" [] ; + prefer_V3 = mkV "föredra" "föredrar" "föredrog" "föredragit" "föredragen" "föredragna" [] "framför" ; + want_VV = mkV "vilja" "vill" "ville" "velat" "velad" "velade" ; + force_V2V = let tvinga : V = mkV "tvinga" "tvingar" "tvingade" "tvingat" "tvingad" "tvingade" in + {v = tvinga.v ; c1 = [] ; c2 = "att" ; isSubjectControl = False} ; + promise_V2V = mkV "lova" "lovar" "lovade" "lovat" "lovad" "lovade" [] "att" ; + wonder_VQ = mkV "undra" "undrar" "undrade" "undrat" "undrad" "undrade" ; + become_VA = mkV "bli" "blir" "blev" "blivit" "bliven" "blivna" ; + become_VN = mkV "bli" "blir" "blev" "blivit" "bliven" "blivna" ; + make_V2A = let gora : V = mkV "göra" "gör" "gjorde" "gjort" "gjord" "gjorda" in + {v = table {TV Pass VPres => "görs" ; f => gora.v ! f} ; c1 = [] ; c2 = [] ; isSubjectControl = False} ; + promote_V2N = let befordra : V = mkV "befordra" "befordrar" "befordrade" "befordrat" "befordrad" "befordrade" + in {v = befordra.v ; c1 = [] ; c2 = "till" ; isSubjectControl = False} ; ---- ? de befordrade dem till chefer för sig/dem + ask_V2Q = mkV "fråga" "frågar" "frågade" "frågat" "frågad" "frågade" ; + + old_A = {s = table {Sg => "gammal" ; Pl => "gamla"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; + married_A2 = {s = table {Sg => "gift" ; Pl => "gifta"} ; c1 = "med" ; c2 = [] ; obj1 = \\_ => []} ; + eager_AV = {s = table {Sg => "ivrig" ; Pl => "ivriga"} ; c1 = [] ; c2 = "att" ; obj1 = \\_ => []} ; + easy_A2V = {s = table {Sg => "lätt" ; Pl => "lätta"} ; c1 = "för" ; c2 = "att" ; obj1 = \\_ => []} ; + professor_N = {s = table {Sg => "professor" ; Pl => "professorer"} ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ; + manager_N2 = {s = table {Sg => "chef" ; Pl => "chefer"} ; c1 = "för" ; c2 = [] ; obj1 = \\_ => []} ; + + she_NP = {s = table {Nom => "hon" ; Acc => "henne"} ; a = Sg} ; + we_NP = {s = table {Nom => "vi" ; Acc => "oss"} ; a = Pl} ; + + today_Adv = {s = "idag" ; isAdV = False} ; + always_AdV = {s = "alltid" ; isAdV = True} ; + + who_IP = {s = "vem" ; a = Sg} ; + + PrepNP p np = {s = p.s ++ np.s ! Acc ; isAdV = False} ; + + with_Prep = {s = "med"} ; + + and_Conj = {s = "och"} ; + + why_IAdv = {s = "varför"} ; + +oper + mkV = overload { + mkV : (x,y,z,u,v,w : Str) -> V = \x,y,z,u,v,w -> + lin V { + v = table { + TV Act VInf => x ; TV Act VPres => y ; TV Act VPret => z ; TV Act VSup => u ; + TV Pass VInf => x + "s" ; TV Pass VPres => init y + "s" ; TV Pass VPret => z + "s" ; TV Pass VSup => u + "s" ; + PastPart Sg => v ; PastPart Pl => w ; PresPart => x + "nde" + } ; + c1 = [] ; c2 = [] ; isSubjectControl = True} ; + mkV : (x,y,z,u,v,w : Str) -> Str -> Str -> V = \x,y,z,u,v,w,p,q -> + lin V { + v = table { + TV Act VInf => x ; TV Act VPres => y ; TV Act VPret => z ; TV Act VSup => u ; + TV Pass VInf => x + "s" ; TV Pass VPres => init y + "s" ; TV Pass VPret => z + "s" ; TV Pass VSup => u + "s" ; + PastPart Sg => v ; PastPart Pl => w ; PresPart => x + "nde" + } ; + c1 = p ; c2 = q ; isSubjectControl = True} ; + } ; + + + have_V : V = mkV "ha" "har" "hade" "haft" "havd" "havda" ; + + shall_V : V = mkV "skola" "ska" "skulle" "skolat" "skolad" "skolade" ; + } \ No newline at end of file