content: {-# OPTIONS_GHC -fglasgow-exts #-}
  
  module Old2New (transfer) where
  import PGF hiding (Tree)
  import qualified PGF
  import PGF.Data
  
  import Both
  
  
  transfer :: PGF.Tree -> PGF.Tree
  transfer = gf . onPhr . fg
  
  {-
  transfer t = case unAppForm t of
    (EMeta m, es) -> foldl EApp (EMeta m) (map transfer es)
    _ -> gf $ on $ fg t
  -}
  
  onPhr :: Tree GPhr_ -> Tree GPhr_
  onPhr = on
  
  on :: forall a . Tree a -> Tree a
  on t = case t of
  
  ----  GEMeta m ts -> GEMeta m (map on ts)
  
   
  -- Utt
    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)
    GUttQS qs -> GUttPrS (GUseQCl_none (onQS2QCl qs))
    GUttS s -> GUttPrS (onS s)
    GUttVP s -> error "GUttPrVPI (GInfVP_none (onVP GTPres ant pol vp))"
  
  -- RS
    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)
    GUseRCl (GTTAnt t a) p (GRelCl cl) -> GRelCl_none (onCl t a p cl)
    GPastPartRS _ _ _ -> error "PastPartRS : Ant -> Pol -> VPSlash -> RS"
    GPresPartRS _ _ _ -> error "PresPartRS : Ant -> Pol -> VPSlash -> RS"
  
  -- NP
  
  -- Adv
    GComparAdvAdjS cadv a s -> error "GComparAdvAdjS cadv a (onS s)"
    GSubjS subj s -> error "AdvSubjS subj s"
  
  -- AP
  ---- SentAP : AP -> SC -> AP
  
    _ -> composOp on 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 (GListS lists) -> GUseCl_none (GUseClC_none (mkClC conj [onS2Cl s | s <- lists]))
    GPredVPS np vps -> GUseCl_none (GPredVP_none (on np) (onVPS2VP vps))
  
  mkClC conj cls = foldr GContClC_none (GStartClC_none conj cl1 cl2) cls2
    where 
      (cls2,[cl1,cl2]) = splitAt (length cls - 2) cls
  
  onVPS2VP :: Tree GVPS_ -> Tree GPrVP_none_
  onVPS2VP vps = case vps of
    GMkVPS (GTTAnt t a) p vp -> onVP t a p vp
    GConjVPS conj (GListVPS vs) -> GUseVPC_none (mkVPC conj [onVPS2VP v | v <- vs])
  
  mkVPC conj cls = foldr GContVPC_none (GStartVPC_none conj cl1 cl2) cls2
    where 
      (cls2,[cl1,cl2]) = splitAt (length cls - 2) cls
  
  
  onCl :: GTense -> GAnt -> GPol -> Tree GCl_ -> Tree GPrCl_none_
  onCl t a p cl = case cl of
    GPredVP np vp -> let (advs,vp0) = getAdvs vp in appAdvCl advs (GPredVP_none (on 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)
    GExtAdvVP vp1 adv -> let (advs,vp2) = getAdvs vp1 in (advs ++ [GLiftAdv adv],vp2) ---- as a variant
  
    _ -> ([],vp)
  
  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)
    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 (on ap))
      GCompAdv adv -> GUseAdv_none a t p (GLiftAdv (on adv))
      GCompCN  cn  -> GUseCN_none a t p (GLiftCN (on cn))
      GCompNP  np  -> GUseNP_none a t p (on 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)) -- !!
    GComplSlashPartLast vps np -> GComplV2_none (onVPSlash t a p vps) np ---- as a variant
    GComplVPIVV vv vpi -> GComplVV_none (GUseV_v a t p (GLiftVV vv)) (GInfVP_none (onVPI2VP vpi))
    GPassVPSlash vps -> onVPSlashPass t a p vps
    GPassAgentVPSlash vps np -> onVPSlashPassAgent t a p vps np
  ---- ProgrVP : VP -> VP ;
  ---- ReflVP : VPSlash -> VP ;
  ---- SelfAdVVP : VP -> VP ;
  ---- SelfAdvVP : VP -> VP ;
  
  onVPI2VP :: Tree GVPI_ -> Tree GPrVP_none_
  onVPI2VP vpi = case vpi of
    GMkVPI vp -> onVP GTPres GASimul GPPos vp
    GConjVPI conj (GListVPI vs) -> GUseVPC_none (mkVPC conj [onVPI2VP v | v <- vs])
  
  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)) -- !!
  ---  GSlashSlashV2V vv ant pol vps -> GComplVV_np (GUseV_np_v a t p (GLiftV2V vv)) (GInfVP_np (onVPSlash GTPres ant pol vps))
    GSlashVPIV2V v2v pol vpi -> GSlashV2V_none (GUseV_np_v a t p (GLiftV2V v2v)) (GInfVP_none (onVPI2VP vpi)) 
  
  onVPSlashPass :: GTense -> GAnt -> GPol -> Tree GVPSlash_ -> Tree GPrVP_none_
  onVPSlashPass t a p vps = case vps of
    GSlashV2a v2 -> GPassUseV_none a t p (GLiftV2 v2)
    GSlashV2S v2s s -> GComplVS_none (GPassUseV_s a t p (GLiftV2S v2s)) (onS2Cl s)
    GSlashV2Q v2q q -> GComplVQ_none (GPassUseV_q a t p (GLiftV2Q v2q)) (onQS2QCl q)
  ----  GSlashV2A v2a ap -> (GPassUseV_np_a a t p (GLiftV2A v2a)) (GLiftAP ap)
  ----  GSlashV2V v2v ant pol vp -> (GPassUseV_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)) -- !!
  
  onVPSlashPassAgent :: GTense -> GAnt -> GPol -> Tree GVPSlash_ -> GNP -> Tree GPrVP_none_
  onVPSlashPassAgent t a p vps np = case vps of
    GSlashV2a v2 -> GAgentPassUseV_none a t p (GLiftV2 v2) np
    GSlashV2S v2s s -> GComplVS_none (GAgentPassUseV_s a t p (GLiftV2S v2s) np) (onS2Cl s)
  
  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)
    GSlashPrep cl prep -> GAdvCl_np (GLiftPrep prep) (onCl t a p cl)
  ---- GSlashVS np vs sslash -> 
  ---- GAdvSlash cls adv -> GAdvCl_none (GLiftAdv adv) (onClSlash t a p cls)
  
  ---- UseSlash : Temp -> Pol -> ClSlash -> SSlash ;
  
  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 
  
  