GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-03 00:02:50 -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

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