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

more work with Old2New, soon good coverage

Browse Source
This commit is contained in:
aarne
2014-02-23 18:46:35 +00:00
parent aa912ee580
commit 62aa1d2bc7
3 changed files with 102 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
lib/src/experimental/transfer/Both.hs
View File

@@ -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

2
lib/src/experimental/transfer/New.gf
View File

@@ -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
],

101
lib/src/experimental/transfer/Old2New.hs
View File

@@ -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