more work with Old2New, soon good coverage

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

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

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_
+onVPSlash :: GTense -> GAnt -> GPol -> Tree GVPSlash_ -> Tree GPrVP_np_
-onVPS t a p vps = case vps of
+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