GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 19:22:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

PredicationEng now almost a functor with Swe ; details to be fixed on e.g. aux/non-aux V distinction

Browse Source
This commit is contained in:
aarne
2014-02-03 14:04:04 +00:00
parent a81d7db70b
commit cf576d245d
3 changed files with 451 additions and 343 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
lib/src/experimental/Predication.gf
View File

@@ -16,7 +16,6 @@ cat
QCl Arg ; QCl Arg ;
NP ; NP ;
Adv ; Adv ;
AdV ;
S ; S ;
Utt ; Utt ;
AP Arg ; AP Arg ;
@@ -67,18 +66,20 @@ fun
UseCl : Cl aNone -> S ; UseCl : Cl aNone -> S ;
UseQCl : QCl aNone -> S ; -- deprecate QS UseQCl : QCl aNone -> S ; -- deprecate QS
UseAdvCl : Adv -> Cl aNone -> S ; -- lift adv to front
UttS : S -> Utt ; UttS : S -> Utt ;
-- when to add adverbs -- when to add adverbs
---- AdvVP : Adv -> (a : Arg) -> VP a -> VP a ; ---- these create many ambiguities ---- 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 ---- "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 ---- with AdvCl, just 16 parses, 0.2 s
AdvCl : Adv -> (a : Arg) -> Cl a -> Cl a ; 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 -- participles as adjectives
@@ -132,7 +133,7 @@ fun
we_NP : NP ; we_NP : NP ;
today_Adv : Adv ; today_Adv : Adv ;
always_AdV : AdV ; always_AdV : Adv ;
who_IP : IP ; who_IP : IP ;
with_Prep : Prep ; with_Prep : Prep ;

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

@@ -1,386 +1,490 @@
concrete PredicationEng of Predication = open Prelude in { 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 param
Agr = Sg | Pl ; Agr = Sg | Pl ;
Case = Nom | Acc ; Case = Nom | Acc ;
Tense = Pres | Past ; STense = Pres | Past | Perf | Fut ;
Anteriority = Simul | Anter ;
Polarity = Pos | Neg ; 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 lincat
Arg = {s : Str} ; Arg = {s : Str} ;
V = { V = {
v : Tense => Agr => Str ; v : VForm => Str ;
c1 : Str ; c1 : ComplCase ;
c2 : Str c2 : ComplCase ;
isSubjectControl : Bool ;
} ; } ;
VP = { VP = {
v : Agr => Str * Str ; v : Str * Str * Str ; -- ska,ha,sovit
inf : Str ; inf : Str * Str ; -- ha,sovit
c1 : Str ; c1 : ComplCase ;
c2 : Str ; c2 : ComplCase ;
adj,obj1,obj2 : Agr => Str ; adj : Agr => Str ;
obj1 : (Agr => Str) * Agr ;
obj2 : (Agr => Str) * Bool ; -- subject control = True
adv : Str ; adv : Str ;
adV : Str ; adV : Str ;
ext : Str ext : Str
} ; } ;
Cl = { oper Clause = {
v : Str * Str ; v : Str * Str * Str ;
inf : Str ; inf : Str * Str ;
adj,obj1,obj2 : Str ; adj,obj1,obj2 : Str ;
adv : Str ; adv : Str ;
adV : Str ; adV : Str ;
ext : Str ; ext : Str ;
subj : Str ; subj : Str ;
c3 : Str c3 : ComplCase -- for a slashed adjunct, not belonging to the verb valency
} ; } ;
QCl = { lincat
v : Str * Str ; Cl = Clause ;
inf : Str ;
adj,obj1,obj2 : Str ; QCl = Clause ** {
adv : Str ;
adV : Str ;
ext : Str ;
subj : Str ;
c3 : Str ;
foc : Str ; -- the focal position at the beginning, e.g. *vem* älskar hon 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 = { VPC = {
v : Agr => Str ; v : Agr => Str ;
inf : Agr => Str ; inf : Agr => Str ;
c1 : Str ; c1 : ComplCase ;
c2 : Str c2 : ComplCase
} ; } ;
Temp = {s : Str ; t : Tense} ; ClC = {
Pol = {s : Str ; p : Polarity} ; 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} ; NP = {s : Case => Str ; a : Agr} ;
Adv = {s : Str} ; Adv = {s : Str ; isAdV : Bool} ;
AdV = {s : Str} ;
S = {s : Str} ; S = {s : Str} ;
Utt = {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} ; IP = {s : Str ; a : Agr} ;
Prep = {s : Str} ; Prep = {s : Str} ;
Conj = {s : Str} ; Conj = {s : Str} ;
IAdv = {s : Str} ;
lin lin
aNone, aS, aV = {s = []} ; aNone, aS, aV, aA, aQ, aN = {s = []} ;
aNP a = a ; aNP a = a ;
TPres = {s = [] ; t = Pres} ; TPres = {s = [] ; t = Pres} ;
TPast = {s = [] ; t = Past} ; TPast = {s = [] ; t = Past} ;
TFut = {s = [] ; t = Fut} ;
TCond = {s = [] ; t = Perf} ;
ASimul = {s = [] ; a = Simul} ;
AAnter = {s = [] ; a = Anter} ;
PPos = {s = [] ; p = Pos} ; PPos = {s = [] ; p = Pos} ;
PNeg = {s = [] ; p = Neg} ; PNeg = {s = [] ; p = Neg} ;
UseV t p _ v = { UseV a t p _ v = {
v = \\a => <t.s ++ p.s ++ do_Aux t.t a, p.s ++ neg p.p ++ v.v ! Pres ! Pl> ; ---- always with "do" v = tenseV (a.s ++ t.s) t.t a.a Act v ;
inf = t.s ++ p.s ++ neg p.p ++ aux t.t ++ v.v ! Pres ! Pl ; inf = tenseInfV a.s a.a Act v ;
c1 = v.c1 ; c1 = v.c1 ;
c2 = v.c2 ; c2 = v.c2 ;
adj,obj1,obj2 = \\a => [] ; adj = noObj ;
adv,adV = [] ; obj1 = <noObj, defaultAgr> ; ---- not used, just default value
obj2 = <noObj, v.isSubjectControl> ;
adV = p.s ++ neg p.p ;
adv = [] ;
ext = [] ; ext = [] ;
} ; } ;
UseAP t p _ ap = { PassUseV a t p _ v = {
v = \\a => <t.s ++ be_Aux t.t a, p.s ++ neg p.p> ; ---- always with "do" v = tenseV (a.s ++ t.s) t.t a.a Pass v ;
inf = t.s ++ p.s ++ neg p.p ++ aux t.t ++ "be" ; inf = tenseInfV a.s a.a 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 = 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 = <noObj, defaultAgr> ;
obj2 = <noObj, True> ;
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 ; c1 = ap.c1 ;
c2 = ap.c2 ; c2 = ap.c2 ;
adj = \\_ => ap.s ; adj = \\a => ap.s ! a ;
obj1 = ap.obj1 ; obj1 = <ap.obj1, defaultAgr> ;
obj2 = \\a => [] ; obj2 = <noObj, True> ; --- there are no A3's
adv,adV = [] ; adV = p.s ++ neg p.p ;
adv = [] ;
ext = [] ; ext = [] ;
} ; } ;
SlashVNP x vp np = { SlashV2 x vp np = vp ** {
v = vp.v ; obj1 : (Agr => Str) * Agr = <\\a => np.s ! Acc, np.a> -- np.a for object control ---- Acc to be abstracted
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 ;
} ; } ;
SlashVNP2 x vp np = { SlashV3 x vp np = addObj2VP vp (\\a => np.s ! Acc) ; -- control is preserved ---- Acc to be abstracted
v = vp.v ;
inf = vp.inf ; ComplVS x vp cl = addExtVP vp (that_Compl ++ declSubordCl (lin Cl cl)) ; ---- sentence form
c1 = vp.c1 ;
c2 = vp.c2 ; ComplVQ x vp qcl = addExtVP vp (questSubordCl qcl) ; ---- question form
adj = vp.adj ;
obj1 = vp.obj1 ; ComplVV x vp vpo = addObj2VP vp (\\a => infVP a vpo) ; ---- infForm
obj2 = \\a => np.s ! Acc ;
adv = vp.adv ; ComplVA x vp ap = addObj2VP vp (\\a => ap.s ! a ++ ap.obj1 ! a) ; ---- adjForm
adV = vp.adV ;
ext = vp.ext ; 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 = { ReflVP2 x vp = vp ** {
v = vp.v ; obj2 : (Agr => Str) * Bool = <\\a => reflPron a, vp.obj2.p2> ; --- subj/obj control doesn't matter any more
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) ;
} ; } ;
ComplVV x vp vpo = { PredVP x np vp = vp ** {
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 = {
subj = np.s ! Nom ; subj = np.s ! Nom ;
v = vp.v ! np.a ;
inf = vp.inf ;
adj = vp.adj ! np.a ; adj = vp.adj ! np.a ;
obj1 = vp.c1 ++ vp.obj1 ! np.a ; obj1 = vp.c1 ++ vp.obj1.p1 ! np.a ; ---- apply complCase
obj2 = vp.c2 ++ vp.obj2 ! np.a ; obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => np.a ; False => vp.obj1.p2}) ; ---- apply complCase
adV = vp.adV ; c3 = noComplCase ; -- for one more prep to build ClSlash
adv = vp.adv ;
ext = vp.ext ;
c3 = [] ; -- for one more prep to build ClSlash
} ; } ;
PrepCl p x cl = { PrepCl p x cl = cl ** { -- Cl/NP ::= Cl PP/NP
subj = cl.subj ; c3 = prepComplCase p ;
v = cl.v ; } ;
inf = cl.inf ;
adj = cl.adj ; SlashClNP x cl np = cl ** { -- Cl ::= Cl/NP NP
obj1 = cl.obj1 ; adv = cl.adv ++ appComplCase cl.c3 np ; ---- again, adv just added
obj2 = cl.obj2 ; c3 = noComplCase ; -- complCase has been consumed
adV = cl.adV ;
adv = cl.adv ;
ext = cl.ext ;
c3 = p.s ; -- for one more prep to build ClSlash
} ; } ;
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 foc = ip.s ; -- vem älskar henne
hasFoc = True ; focType = FocSubj ;
subj = [] ; subj = [] ;
v = vp.v ! ip.a ;
inf = vp.inf ;
adj = vp.adj ! ip.a ; adj = vp.adj ! ip.a ;
obj1 = vp.c1 ++ vp.obj1 ! ip.a ; obj1 = vp.c1 ++ vp.obj1.p1 ! ip.a ; ---- appComplCase
obj2 = vp.c2 ++ vp.obj2 ! ip.a ; obj2 = vp.c2 ++ vp.obj2.p1 ! (case vp.obj2.p2 of {True => ip.a ; False => vp.obj1.p2}) ; ---- appComplCase
adV = vp.adV ; c3 = noComplCase ; -- for one more prep to build ClSlash ---- ever needed for QCl?
adv = vp.adv ;
ext = vp.ext ;
c3 = [] ; -- for one more prep to build ClSlash
} ; } ;
QuestSlash x ip cl = QuestSlash x ip cl =
let let
ips = cl.c3 ++ ip.s ; ---- c3? ips = cl.c3 ++ ip.s ; -- in Cl/NP, c3 is the only prep ---- appComplCase for ip
focobj = case cl.hasFoc of { focobj = case cl.focType of {
True => <[],ips> ; NoFoc => <ips, [], FocObj> ; -- put ip object to focus if there is no focus yet
False => <ips,[]> t => <[], ips, t> -- put ip object in situ if there already is a focus
} ; } ;
in { in cl ** {
foc = focobj.p1 ; foc = focobj.p1 ;
hasFoc = True ; focType = focobj.p3 ;
subj = cl.subj ; subj = cl.subj ;
v = cl.v ; obj1 = cl.obj1 ++ focobj.p2 ; ---- just add to a field?
inf = cl.inf ; c3 = noComplCase ;
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 = [] ;
} ;
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} ;
UttS s = s ; UttS s = s ;
StartVPC c x v w = { 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}} ;
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 AdvQCl a x cl = cl ** {adv = cl.adv ++ a.s} ;
++ 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 => PresPartAP x v = {
infVP a (lin VP v) ++ c.s ++ infVP a (lin VP w) ; s = \\a => v.v ! vPresPart a ;
c1 = w.c1 ; --- the full story is to unify v and w... c1 = v.c1 ; -- tittande på henne
c2 = w.c2 ; c2 = v.c2 ;
obj1 = noObj ;
} ; } ;
UseVPC x vpc = { PastPartAP x v = {
v = \\a => <do_Aux Pres a, vpc.v ! a> ; ---- there is no uniform tense s = \\a => v.v ! vPastPart a ;
inf = vpc.inf ! Sg ; ---- agreement 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 ; c1 = vpc.c1 ;
c2 = vpc.c2 ; c2 = vpc.c2 ;
adj,obj1,obj2 = \\a => [] ; adj = \\a => [] ;
obj1 = <noObj, defaultAgr> ;
obj2 = <noObj,True> ;
adv,adV = [] ; adv,adV = [] ;
ext = [] ; 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 <t,a> of { --- sta dummy s field of Ant and Tense
<Pres,Simul> => <sta ++ v.v ! VPres, [], []> ;
<Past,Simul> => <sta ++ v.v ! VPast, [], []> ;
<Fut, Simul> => <will_V.v ! VPres, [], sta ++ v.v ! VInf> ;
<Cond,Simul> => <will_V.v ! VPast, [], sta ++ v.v ! VInf> ;
<Pres,Anter> => <have_V.v ! VPres, [], sta ++ v.v ! VPastPart> ;
<Past,Anter> => <have_V.v ! VPast, [], sta ++ v.v ! VPastPart> ;
<Fut, Anter> => <will_V.v ! VPres, have_V.v ! VInf, sta ++ v.v ! VPastPart> ;
<Cond,Anter> => <will_V.v ! VPast, have_V.v ! VInf, sta ++ v.v ! VPastPart>
} ;
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
<be.p1, be.p2, be.p3 ++ done> ;
tenseInfV : Str -> Anteriority -> Voice -> V -> Str * Str = \sa,a,o,v ->
case a of {
Simul => <[], sa ++ v.v ! VInf> ; -- hon vill sova
Anter => <have_V.v ! VInf, sa ++ v.v ! VPastPart> -- 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" ; walk_V = mkV "walk" ;
love_V2 = mkV "love" ; love_V2 = mkV "love" ;
look_V2 = mkV "look" "at" [] ; look_V2 = mkV "look" "at" [] ;
believe_VS = mkV "believe" ; believe_VS = mkV "believe" ;
tell_V2S = mkV "tell" ; tell_V2S = mkV "tell" "told" "told" [] [] ;
prefer_V3 = mkV "prefer" [] "to" ; prefer_V3 = mkV "prefer" [] "to" ;
want_VV = mkV "want" [] "to" ; want_VV = mkV "want" [] "to" ;
force_V2V = mkV "force" [] "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 = \\_ => []} ; old_A = {s = \\_ => "old" ; c1 = [] ; c2 = [] ; obj1 = \\_ => []} ;
married_A2 = {s = "married" ; c1 = "to" ; c2 = [] ; obj1 = \\_ => []} ; married_A2 = {s = \\_ => "married" ; c1 = "to" ; c2 = [] ; obj1 = \\_ => []} ;
eager_AV = {s = "eager" ; c1 = [] ; c2 = "to" ; obj1 = \\_ => []} ; eager_AV = {s = \\_ => "eager" ; c1 = [] ; c2 = "to" ; obj1 = \\_ => []} ;
easy_A2V = {s = "easy" ; c1 = "for" ; 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} ; she_NP = {s = table {Nom => "she" ; Acc => "her"} ; a = Sg} ;
we_NP = {s = table {Nom => "we" ; Acc => "us"} ; a = Pl} ; we_NP = {s = table {Nom => "we" ; Acc => "us"} ; a = Pl} ;
today_Adv = {s = "today"} ; today_Adv = {s = "today" ; isAdV = False} ;
always_AdV = {s = "always"} ; always_AdV = {s = "always" ; isAdV = True} ;
who_IP = {s = "who" ; a = Sg} ; 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"} ; with_Prep = {s = "with"} ;
and_Conj = {s = "and"} ; and_Conj = {s = "and"} ;
why_IAdv = {s = "why"} ;
oper oper
mkV = overload { mkV = overload {
mkV : Str -> V = \s -> lin V {v = \\_,_ => s ; c1 = [] ; c2 = []} ; 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 = \\_,_ => s ; c1 = p ; c2 = q} ; 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 <t,a> of { mkVerb : Str -> Str -> Str -> Str -> Str -> VForm => Str = \go,goes,went,gone,going -> table {
<Pres,Sg> => "does" ; VInf => go ;
<Pres,Pl> => "do" ; VPres => goes ;
<Past,_> => "did" VPast => went ;
VPastPart => gone ;
VPresPart => going
} ; } ;
be_Aux : Tense -> Agr -> Str = \t,a -> case <t,a> of { edV : Str -> Str = \s -> case s of {us + "e" => us ; _ => s} + "ed" ;
<Pres,Sg> => "is" ; ingV : Str -> Str = \s -> case s of {us + "e" => us ; _ => s} + "ing" ;
<Pres,Pl> => "are" ;
<Past,Sg> => "was" ;
<Past,Pl> => "were"
} ;
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 ;
} }

161
lib/src/experimental/PredicationSwe.gf
View File

@@ -82,8 +82,7 @@ lincat
Pol = {s : Str ; p : Polarity} ; Pol = {s : Str ; p : Polarity} ;
NP = {s : Case => Str ; a : Agr} ; NP = {s : Case => Str ; a : Agr} ;
Adv = {s : Str} ; Adv = {s : Str ; isAdV : Bool} ;
AdV = {s : Str} ;
S = {s : Str} ; S = {s : Str} ;
Utt = {s : Str} ; Utt = {s : Str} ;
AP = { AP = {
@@ -254,13 +253,13 @@ lin
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} ;
UttS s = s ; UttS s = 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}} ;
AdVCl a x cl = cl ** {adV = cl.adV ++ a.s} ;
AdvQCl a x cl = cl ** {adv = cl.adv ++ a.s} ;
PresPartAP x v = { PresPartAP x v = {
@@ -327,79 +326,10 @@ lin
c3 = cl.c3 ; 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 ---- 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"} ; neg : Polarity -> Str = \p -> case p of {Pos => [] ; Neg => "inte"} ;
@@ -417,8 +347,8 @@ oper
<Past,Simul> => <sta ++ v.v ! TV o VPret, [], []> ; <Past,Simul> => <sta ++ v.v ! TV o VPret, [], []> ;
<Fut, Simul> => <shall_V.v ! TV Act VPres, [], sta ++ v.v ! TV o VInf> ; <Fut, Simul> => <shall_V.v ! TV Act VPres, [], sta ++ v.v ! TV o VInf> ;
<Cond,Simul> => <shall_V.v ! TV Act VPret, [], sta ++ v.v ! TV o VInf> ; <Cond,Simul> => <shall_V.v ! TV Act VPret, [], sta ++ v.v ! TV o VInf> ;
<Pres,Anter> => <[], have_V.v ! TV Act VPres, sta ++ v.v ! TV o VSup> ; <Pres,Anter> => <have_V.v ! TV Act VPres, [], sta ++ v.v ! TV o VSup> ;
<Past,Anter> => <[], have_V.v ! TV Act VPret, sta ++ v.v ! TV o VSup> ; <Past,Anter> => <have_V.v ! TV Act VPret, [], sta ++ v.v ! TV o VSup> ;
<Fut, Anter> => <shall_V.v ! TV Act VPres, have_V.v ! TV Act VInf, sta ++ v.v ! TV o VSup> ; <Fut, Anter> => <shall_V.v ! TV Act VPres, have_V.v ! TV Act VInf, sta ++ v.v ! TV o VSup> ;
<Cond,Anter> => <shall_V.v ! TV Act VPret, have_V.v ! TV Act VInf, sta ++ v.v ! TV o VSup> <Cond,Anter> => <shall_V.v ! TV Act VPret, have_V.v ! TV Act VInf, 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" ;
} }