From 62aa1d2bc76ebe1ecb5011e45f550511ef0dd766 Mon Sep 17 00:00:00 2001 From: aarne Date: Sun, 23 Feb 2014 18:46:35 +0000 Subject: [PATCH] more work with Old2New, soon good coverage --- lib/src/experimental/transfer/Both.hs | 5 ++ lib/src/experimental/transfer/New.gf | 2 +- lib/src/experimental/transfer/Old2New.hs | 101 +++++++++++++++++++++-- 3 files changed, 102 insertions(+), 6 deletions(-) diff --git a/lib/src/experimental/transfer/Both.hs b/lib/src/experimental/transfer/Both.hs index 5c9c8d96b..25369156a 100644 --- a/lib/src/experimental/transfer/Both.hs +++ b/lib/src/experimental/transfer/Both.hs @@ -429,6 +429,7 @@ data Tree :: * -> * where GPresPartAP_np :: GPrV_np -> Tree GPrAP_np_ GComplAdv_none :: GPrAdv_np -> GNP -> Tree GPrAdv_none_ GLiftAdV :: GAdV -> Tree GPrAdv_none_ + GLiftAdv :: GAdv -> Tree GPrAdv_none_ GLiftPrep :: GPrep -> Tree GPrAdv_np_ GLiftCN :: GCN -> Tree GPrCN_none_ GLiftN2 :: GN2 -> Tree GPrCN_np_ @@ -786,6 +787,7 @@ instance Eq (Tree a) where (GPresPartAP_np x1,GPresPartAP_np y1) -> and [ x1 == y1 ] (GComplAdv_none x1 x2,GComplAdv_none y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GLiftAdV x1,GLiftAdV y1) -> and [ x1 == y1 ] + (GLiftAdv x1,GLiftAdv y1) -> and [ x1 == y1 ] (GLiftPrep x1,GLiftPrep y1) -> and [ x1 == y1 ] (GLiftCN x1,GLiftCN y1) -> and [ x1 == y1 ] (GLiftN2 x1,GLiftN2 y1) -> and [ x1 == y1 ] @@ -1618,11 +1620,13 @@ instance Gf GPrAP_np where instance Gf GPrAdv_none where gf (GComplAdv_none x1 x2) = mkApp (mkCId "ComplAdv_none") [gf x1, gf x2] gf (GLiftAdV x1) = mkApp (mkCId "LiftAdV") [gf x1] + gf (GLiftAdv x1) = mkApp (mkCId "LiftAdv") [gf x1] fg t = case unApp t of Just (i,[x1,x2]) | i == mkCId "ComplAdv_none" -> GComplAdv_none (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "LiftAdV" -> GLiftAdV (fg x1) + Just (i,[x1]) | i == mkCId "LiftAdv" -> GLiftAdv (fg x1) _ -> error ("no PrAdv_none " ++ show t) @@ -2826,6 +2830,7 @@ instance Compos Tree where GPresPartAP_np x1 -> r GPresPartAP_np `a` f x1 GComplAdv_none x1 x2 -> r GComplAdv_none `a` f x1 `a` f x2 GLiftAdV x1 -> r GLiftAdV `a` f x1 + GLiftAdv x1 -> r GLiftAdv `a` f x1 GLiftPrep x1 -> r GLiftPrep `a` f x1 GLiftCN x1 -> r GLiftCN `a` f x1 GLiftN2 x1 -> r GLiftN2 `a` f x1 diff --git a/lib/src/experimental/transfer/New.gf b/lib/src/experimental/transfer/New.gf index 36896ac32..6e4094c57 100644 --- a/lib/src/experimental/transfer/New.gf +++ b/lib/src/experimental/transfer/New.gf @@ -8,7 +8,7 @@ abstract New = NDPred - [Pol,Tense], NDLift [LiftV,LiftV2,LiftVS,LiftVQ,LiftVA,LiftVN,LiftVV, LiftV3,LiftV2S,LiftV2Q,LiftV2A,LiftV2N,LiftV2V, - LiftAP,LiftA2,LiftCN,LiftN2,LiftAdV,LiftPrep, + LiftAP,LiftA2,LiftCN,LiftN2,LiftAdv,LiftAdV,LiftPrep, AppAPCN ], diff --git a/lib/src/experimental/transfer/Old2New.hs b/lib/src/experimental/transfer/Old2New.hs index e80502c54..e733c4885 100644 --- a/lib/src/experimental/transfer/Old2New.hs +++ b/lib/src/experimental/transfer/Old2New.hs @@ -2,31 +2,122 @@ module Old2New where import Both -onUtt :: Tree GUtt_ -> Tree GUtt_ + +onUtt :: Tree a -> Tree a ----GUtt_ -> Tree GUtt_ onUtt t = case t of GUttS s -> GUttPrS (onS s) + GUttQS qs -> GUttPrS (GUseQCl_none (onQS2QCl qs)) + GUttImpPl pol (GImpVP vp) -> GPrImpPl (onVP GTPres GASimul pol vp) + GUttImpPol pol (GImpVP vp) -> GPrImpSg (onVP GTPres GASimul pol vp) ---- + GUttImpSg pol (GImpVP vp) -> GPrImpSg (onVP GTPres GASimul pol vp) + GUttNP np -> GUttNP (onNP np) + GUttCN cn -> GUttCN (onCN cn) + _ -> t ---- composOp onUtt t + +onS :: Tree GS_ -> Tree GPrS_ onS s = case s of GUseCl (GTTAnt t a) p cl -> GUseCl_none (onCl t a p cl) + GAdvS adv s -> error "AdvS" + GExtAdvS adv s -> error "ExtAdvS" + GRelS s rs -> error "RelS" + GSSubjS s subj s2 -> error "SSubjS" + GConjS conj lists -> error "ConjS" + GPredVPS np vps -> error "PredVPS" +onCl :: GTense -> GAnt -> GPol -> Tree GCl_ -> Tree GPrCl_none_ onCl t a p cl = case cl of - GPredVP np vp -> GPredVP_none np (onVP t a p vp) + GPredVP np vp -> let (advs,vp0) = getAdvs vp in appAdvCl advs (GPredVP_none np (onVP t a p vp0)) --- + ---- ExistNP : NP -> Cl ; + ---- PredSCVP : SC -> VP -> Cl ; + ---- PredVPosv : NP -> VP -> Cl ; + ---- PredVPovs : NP -> VP -> Cl ; + +-- adverbs in New are attached to Cl, in Old to VP. New makes no distinction between Adv and AdV +getAdvs :: GVP -> ([GPrAdv_none],GVP) +getAdvs vp = case vp of + GAdvVP vp1 adv -> let (advs,vp2) = getAdvs vp1 in (advs ++ [GLiftAdv adv],vp2) + GAdVVP adv vp1 -> let (advs,vp2) = getAdvs vp1 in (advs ++ [GLiftAdV adv],vp2) + +appAdvCl :: [GPrAdv_none] -> GPrCl_none -> GPrCl_none +appAdvCl advs cl = foldr GAdvCl_none cl advs + +onQCl :: GTense -> GAnt -> GPol -> Tree GQCl_ -> Tree GPrQCl_none_ +onQCl t a p qcl = case qcl of + GQuestVP ip vp -> GQuestVP_none ip (onVP t a p vp) + GQuestSlash ip cls -> GQuestSlash_none ip (GQuestCl_np (onClSlash t a p cls)) + GQuestCl cl -> GQuestCl_none (onCl t a p cl) + GQuestIAdv iadv cl -> GQuestIAdv_none iadv (onCl t a p cl) + GQuestIComp icomp np -> GQuestIComp_none a t p icomp np + GQuestQVP ip qvp -> error "QuestQVP" onVP :: GTense -> GAnt -> GPol -> Tree GVP_ -> Tree GPrVP_none_ onVP t a p vp = case vp of GUseV v -> GUseV_none a t p (GLiftV v) GComplVS vs s -> GComplVS_none (GUseV_s a t p (GLiftVS vs)) (onS2Cl s) - GComplSlash vps np -> GComplV2_none (onVPS t a p vps) np + GComplVQ vq q -> GComplVQ_none (GUseV_q a t p (GLiftVQ vq)) (onQS2QCl q) + GComplVA va ap -> GComplVA_none (GUseV_a a t p (GLiftVA va)) (GLiftAP ap) + GComplVV vv ant pol vp -> GComplVV_none (GUseV_v a t p (GLiftVV vv)) (GInfVP_none (onVP GTPres ant pol vp)) -- !! + GComplSlash vps np -> GComplV2_none (onVPSlash t a p vps) np + GUseComp comp -> case comp of + GCompAP ap -> GUseAP_none a t p (GLiftAP ap) + GCompAdv adv -> GUseAdv_none a t p (GLiftAdv adv) + GCompCN cn -> GUseCN_none a t p (GLiftCN cn) + GCompNP np -> GUseNP_none a t p np + GCompS s -> GUseS_none a t p (onS2Cl s) + GCompQS qs -> GUseQ_none a t p (onQS2QCl qs) + GCompVP ant pol vp -> GUseVP_none a t p (GInfVP_none (onVP GTPres ant pol vp)) -- !! +---- ComplSlashPartLast : VPSlash -> NP -> VP ; +---- ComplVPIVV : VV -> VPI -> VP ; +---- ExtAdvVP : VP -> Adv -> VP ; +---- PassAgentVPSlash : VPSlash -> NP -> VP ; +---- PassVPSlash : VPSlash -> VP ; +---- ProgrVP : VP -> VP ; +---- ReflVP : VPSlash -> VP ; +---- SelfAdVVP : VP -> VP ; +---- SelfAdvVP : VP -> VP ; -onVPS :: GTense -> GAnt -> GPol -> Tree GVPSlash_ -> Tree GPrVP_np_ -onVPS t a p vps = case vps of +onVPSlash :: GTense -> GAnt -> GPol -> Tree GVPSlash_ -> Tree GPrVP_np_ +onVPSlash t a p vps = case vps of GSlashV2a v2 -> GUseV_np a t p (GLiftV2 v2) + GSlashV2S v2s s -> GSlashV2S_none (GUseV_np_s a t p (GLiftV2S v2s)) (onS2Cl s) + GSlashV2Q v2q q -> GSlashV2Q_none (GUseV_np_q a t p (GLiftV2Q v2q)) (onQS2QCl q) + GSlashV2A v2a ap -> GSlashV2A_none (GUseV_np_a a t p (GLiftV2A v2a)) (GLiftAP ap) + GSlashV2V v2v ant pol vp -> GSlashV2V_none (GUseV_np_v a t p (GLiftV2V v2v)) (GInfVP_none (onVP GTPres ant pol vp)) -- !! + + GSlashVV vv vps -> GComplVV_np (GUseV_v a t p (GLiftVV vv)) (GInfVP_np (onVPSlash GTPres GASimul GPPos vps)) -- !! + +onClSlash :: GTense -> GAnt -> GPol -> Tree GClSlash_ -> Tree GPrCl_np_ +onClSlash t a p cls = case cls of + GSlashVP np vps -> GPredVP_np np (onVPSlash t a p vps) onS2Cl :: Tree GS_ -> Tree GPrCl_none_ onS2Cl s = case s of GUseCl (GTTAnt t a) p cl -> onCl t a p cl +onQS2QCl :: Tree GQS_ -> Tree GPrQCl_none_ +onQS2QCl s = case s of + GUseQCl (GTTAnt t a) p qcl -> onQCl t a p qcl + +onRS :: Tree GRS_ -> Tree GRS_ +onRS rs = case rs of + GUseRCl (GTTAnt t a) p (GRelVP rp vp) -> GRelVP_none rp (onVP t a p vp) + GUseRCl (GTTAnt t a) p (GRelSlash rp cls) -> GRelSlash_none rp (onClSlash t a p cls) + + + + +onNP :: Tree GNP_ -> Tree GNP_ +onNP np = case np of + GRelNP np rs -> GRelNP (onNP np) (onRS rs) + _ -> np ----composOp onNP np + +onCN :: Tree GCN_ -> Tree GCN_ +onCN cn = case cn of + GRelCN cn rs -> GRelCN (onCN cn) (onRS rs) + _ -> cn ----composOp onCN cn + old2new :: Tree a -> Tree a old2new t = case t of