import System.Directory
import System.FilePath
import Data.List
import Data.Char(toLower)
import Data.Maybe(fromMaybe)
import Control.Monad
import qualified Data.Map as Map

import PGF2
import SusanneFormat
import Parser
import Idents

main = do
  gr <- readPGF "ParseEngAbs.pgf"
  let Just eng = Map.lookup "ParseEng" (languages gr)
  fs <- getDirectoryContents "data"
  txts <- (mapM (\f -> readFile ("data" </> f)) . filter ((/= ".") . take 1)) (sort fs)
  let ts = (map (convert gr eng) . concatMap filterTree) (readTreebank (lines (concat txts)))
  writeFile "susanne.gft" (unlines (map show ts))

filterTree w@(Word _ tag _ lemma)
  | elem tag ["YB","YBL","YBR","YF","YIL","YIR","YTL","YTR", "YO"] = []
  | otherwise                                                      = [w]
filterTree (Phrase tag mods fn idx ts)
  | tag == "O" = ts'
  | tag == "Q" = ts'
  | otherwise  = [Phrase tag mods fn idx ts']
  where
    ts' = concatMap filterTree ts

convert pgf eng t@(Phrase tag mods fn idx ts)
  | tag == "S" = case runP pS pgf eng ts of
                   Just ([],x) -> x
                   _           -> Phrase tag mods fn idx ts'
  | tag == "N" = case runP pNP pgf eng ts of
                   Just ([],x) -> x
                   _           -> Phrase tag mods fn idx ts'
  | tag == "V" = case runP (pV "V") pgf eng [t] of
                   Just ([],(_,_,_,_,x)) -> x
                   _                     -> Phrase tag mods fn idx ts'
  | tag == "P" = case runP pPP pgf eng ts of
                   Just ([],x) -> x
                   _           -> Phrase tag mods fn idx ts'
  | tag == "Po"= case runP pPP pgf eng ts of
                   Just ([],x) -> x
                   _           -> Phrase tag mods fn idx ts'
  | tag == "Fr"= case runP pRS pgf eng ts of
                   Just ([],x) -> x
                   _           -> Phrase tag mods fn idx ts'
  | otherwise  = Phrase tag mods fn idx ts'
  where
    ts' = map (convert pgf eng) ts
convert pgf eng t@(Word _ tag _ lemma)
  | take 2 tag == "NN" = case runP pN pgf eng [t] of
                           Just ([],(_,x)) -> x
                           _               -> t
  | take 1 tag == "J"  = case runP pAP pgf eng [t] of
                           Just ([],x) -> x
                           _           -> t
  | otherwise          = t

pS =
  do mplus pConj (return ())
     advs <- many pAdS
     np <- pSubject
     (t,p,vp) <- pVP
     return (foldr ($) (cidUseCl t p (cidPredVP np vp)) advs)
  `mplus`
  do mplus pConj (return ())
     (t,p,vp) <- pVP
     return (cidImpVP vp)
  `mplus`
  do mplus pConj (return ())
     advs <- many pAdS
     t1 <- match convert "EX"
     (t,p,vp) <- pVP
     return (foldr ($) (cidUseCl t p (cidExistNP t1 vp)) advs)

pSubject =
  do insideOpt convert "N:s" pNP
  `mplus`
  do insideOpt convert "N:S" pNP
  `mplus`
  do insideOpt convert "M:s" pM
  `mplus`
  do insideOpt convert "M:S" pM
  `mplus`
  do insideOpt convert "Ds:s" $ do
       det <- pDet
       return (cidDetNP (det cidNumSg))
  `mplus`
  do insideOpt convert "Dp:s" $ do
       det <- pDet
       return (cidDetNP (det cidNumPl))
  `mplus`
  do insideOpt convert "Ds:S" $ do
       det <- pDet
       return (cidDetNP (det cidNumSg))
  `mplus`
  do insideOpt convert "Dp:S" $ do
       det <- pDet
       return (cidDetNP (det cidNumPl))

pConj =
  do match convert "CC"
     return ()
  `mplus`
  do match convert "CCB"
     return ()

pAdS =
  do adv <- pVPMods
     match convert "YC"
     return (\t -> cidExtAdvS adv t)
  `mplus`
  do adv <- pVPMods
     return (\t -> cidAdvS adv t)

pVP =
  do adVs     <- many pAdV
     (t,p,voice,apect,vs) <- pV "VS"
     advs     <- many pVPMods
     s        <- insideOpt convert "F:o"
                   (opt (match convert "CST") >> pS)
     return (t,p,foldr (\adv t -> cidAdVVP adv t)
                       (foldl (\t adv -> cidAdvVP t adv)
                              (cidComplVS vs s)
                              advs)
                       adVs)
  `mplus`
  do adVs     <- many pAdV
     (t,p,voice,apect,vv) <- pV "VV"
     advs     <- many pVPMods
     (p2,voice,aspect,vp) <- inside "Ti" $ do
                               match convert "s"
                               pVPInf
     return (t,p,foldr (\adv t -> cidAdVVP adv t)
                       (foldl (\t adv -> cidAdvVP t adv)
                              (cidComplVV vv cidASimul p2 vp)
                              advs)
                       adVs)
  `mplus`
  do adVs     <- many pAdV
     (t,p,voice,apect,v2) <- pV "V2"
     o        <- pObject
     opt (match convert "YC")   -- what is this?
     advs     <- many pVPMods
     return (t,p,foldr (\adv t -> cidAdVVP adv t)
                       (foldl (\t adv -> cidAdvVP t adv)
                              (cidComplSlash (cidSlashV2a v2) o)
                              advs)
                       adVs)
  `mplus`
  do adVs    <- many pAdV
     (t,p,voice,apect,v) <- pV "V"
     advs    <- many pVPMods
     return (t,p,foldr (\adv t -> cidAdVVP adv t)
                       (foldl (\t adv -> cidAdvVP t adv)
                              (cidUseV v)
                              advs)
                       adVs)
  `mplus`
  do (t,p) <- inside "V" pCopula
     comp  <- pComp
     advs  <- many pVPMods
     return (cidTTAnt t cidASimul,p,foldl (\t adv -> cidAdvVP t adv)
                                          (cidUseComp comp)
                                          advs)

pCopula = 
  do match convert "VBZ"
     p <- pPol
     return (cidTPres,p)
  `mplus`
  do match convert "VBDZ"
     p <- pPol
     return (cidTPast,p)

pComp =
  do adv <- insideOpt convert "R:e" pAdv
     return (cidCompAdv adv)
  `mplus`
  do np <- insideOpt convert "N:e" pNP
     return (cidCompNP np)
  `mplus`
  do ap <- pAP
     return (cidCompAP ap)

pAdv =
  do lemma "RP" "Adv" "s"

data Voice  = Active | Passive
data Aspect = Simple | Progressive

pV cat =
  do inside "V" $
       do v <- pVPres cat
          return (cidTTAnt cidTPres cidASimul,cidPPos,Active,Simple,v)
       `mplus`
       do v <- do lemma "VVZi" cat "s VPres"
               `mplus`
               do lemma "VVZt" cat "s VPres"
               `mplus`
               do lemma "VVZv" cat "s VPres"
          return (cidTTAnt cidTPres cidASimul,cidPPos,Active,Simple,v)
       `mplus`
       do v <- do lemma "VVDi" cat "s VPast"
               `mplus`
               do lemma "VVDt" cat "s VPast"
               `mplus`
               do lemma "VVDv" cat "s VPast"
          return (cidTTAnt cidTPast cidASimul,cidPPos,Active,Simple,v)
       `mplus`
       do (match convert "VBM" `mplus` match convert "VBR" `mplus` match convert "VBZ") -- am,are,is
          pol <- pPol
          (voice,aspect,v) <- pVPart cat
          return (cidTTAnt cidTPres cidASimul,pol,voice,aspect,v)
       `mplus`
       do (match convert "VBDZ" `mplus` match convert "VBDR") -- was,were
          pol <- pPol
          (voice,aspect,v) <- pVPart cat
          return (cidTTAnt cidTPast cidASimul,pol,voice,aspect,v)
       `mplus`
       do match convert "VH0" -- have
          pol <- pPol
          (voice,aspect,v) <- do v <- pVPastPart cat
                                 return (Active,Simple,v)
                              `mplus`
                              do match convert "VBN" -- been
                                 pVPart cat
          return (cidTTAnt cidTPres cidAAnter,pol,voice,aspect,v)
       `mplus`
       do match convert "VH0" -- have
          return (cidTTAnt cidTPres cidAAnter,cidPPos,Active,Simple,cidhave_V2)
       `mplus`
       do match convert "VHZ" -- has
          pol <- pPol
          (voice,aspect,v) <- do v <- pVPastPart cat
                                 return (Active,Simple,v)
                              `mplus`
                              do match convert "VBN" -- been
                                 pVPart cat
          return (cidTTAnt cidTPres cidAAnter,pol,voice,aspect,v)
       `mplus`
       do match convert "VHZ" -- has
          return (cidTTAnt cidTPres cidAAnter,cidPPos,Active,Simple,cidhave_V2)
       `mplus`
       do match convert "VHD" -- had
          pol <- pPol
          (voice,aspect,v) <- do v <- pVPastPart cat
                                 return (Active,Simple,v)
                              `mplus`
                              do match convert "VBN" -- been
                                 pVPart cat
          return (cidTTAnt cidTPast cidAAnter,pol,voice,aspect,v)
       `mplus`
       do match convert "VHD" -- had
          return (cidTTAnt cidTPast cidASimul,cidPPos,Active,Simple,cidhave_V2)
       `mplus`
       do w <- word "VMo" -- will
          guard (w == "will")
          pol <- pPol
          (voice,apect,vp) <- pVInf cat
          return (cidTTAnt cidTFut cidASimul,pol,voice,apect,vp)
       `mplus`
       do mplus (match convert "VD0") (match convert "VDZ") -- do,does
          match convert "XX"
          vp <- pVPres cat
          return (cidTTAnt cidTPres cidASimul,cidPNeg,Active,Simple,vp)
       `mplus`
       do match convert "VDD" -- did
          match convert "XX"
          vp <- pVPres cat
          return (cidTTAnt cidTPast cidASimul,cidPNeg,Active,Simple,vp)


pVPInf = do
  adVs <- many pAdV
  (pol,voice,apect,vp) <- do (pol,voice,apect,v2) <- inside "Vi" $
                                                       do pol <- pPol
                                                          match convert "TO"
                                                          (voice,aspect,v) <- pVInf "V2"
                                                          return (pol,voice,aspect,v)
                             o <- pObject
                             return (pol,voice,apect,cidComplSlash (cidSlashV2a v2) o)
                          `mplus`
                          do (pol,voice,apect,v2a) <- inside "Vi" $
                                                        do pol <- pPol
                                                           match convert "TO"
                                                           (voice,aspect,v) <- pVInf "V2A"
                                                           return (pol,voice,aspect,v)
                             o        <- pObject
                             ap       <- pAP
                             return (pol,voice,apect,cidComplSlash (cidSlashV2A v2a ap) o)
  advs <- many pVPMods
  return (pol,voice,apect,
              foldr (\adv t -> cidAdVVP adv t)
                    (foldl (\t adv -> cidAdvVP t adv)
                           vp
                           advs)
                    adVs)

pVInf cat =
  do v <- pVPres cat
     return (Active,Simple,v)
  `mplus`
  do match convert "VB0" -- be
     pVPart cat
  `mplus`
  do v <- match convert "VH0" -- have
     return (Active,Simple,v)

pVPPresPart =
  insideOpt convert "Vg" $ do
    v <- pVPresPart "V"
    return (cidUseV v)

pVPart cat =
  do v <- pVPresPart cat
     return (Active,Progressive,v)
  `mplus`
  do v <- pVPastPart cat
     return (Passive,Simple,v)

pVPres cat =
  do lemma "VV0i" cat "s VInf"
  `mplus`
  do lemma "VV0t" cat "s VInf"
  `mplus`
  do lemma "VV0v" cat "s VInf"

pVPresPart cat =
  do lemma "VVGi" cat "s VPresPart"
  `mplus`
  do lemma "VVGt" cat "s VPresPart"
  `mplus`
  do lemma "VVGv" cat "s VPresPart"

pVPastPart cat =
  do lemma "VVNi" cat "s VPPart"
  `mplus`
  do lemma "VVNt" cat "s VPPart"
  `mplus`
  do lemma "VVNv" cat "s VPPart"

pPol =
  do match convert "XX"
     return cidPNeg
  `mplus`
  do return cidPPos

pAdV =
  do insideOpt convert "R:c" $
       lemma "RRR" "AdV" "s"
  `mplus`
  do insideOpt convert "R:m" $
       lemma "RRR" "AdV" "s"

pObject = 
  match convert "P:u"
  `mplus`
  insideOpt convert "N:o" pNP
  `mplus`
  match convert "N:e"
  `mplus`
  insideOpt convert "M:e" pM
  `mplus`
  do insideOpt convert "Ds:e" $ do
       det <- pDet
       return (cidDetNP (det cidNumSg))
  `mplus`
  do insideOpt convert "Dp:e" $ do
       det <- pDet
       return (cidDetNP (det cidNumPl))
  `mplus`
  do insideOpt convert "P:e" $ pPP

pVPMods =
  do insideOpt convert "N:t" pTimeNPAdv
  `mplus`
  do match convert "N:h"
  `mplus`
  do insideOpt convert "P:p" $ pPP
  `mplus`
  do insideOpt convert "P:q" $ pPP
  `mplus`
  do insideOpt convert "Pb:a" $ do
       match convert "IIb"
       np <- insideOpt convert "N" pNP
       return (cidPrepNP cidby_Prep np)
  `mplus`
  do insideOpt convert "P:t" $ pPP
  `mplus`
  do insideOpt convert "P:h" $ pPP
  `mplus`
  do insideOpt convert "P:m" $ pPP
  `mplus`
  do insideOpt convert "P:r" $ pPP
  `mplus`
  do insideOpt convert "R:p" $ pAdv
  `mplus`
  do insideOpt convert "R:q" $ pAdv
  `mplus`
  do insideOpt convert "R:a" $ pAdv
  `mplus`
  do insideOpt convert "R:t" $ pAdv
  `mplus`
  do insideOpt convert "R:h" $ pAdv
  `mplus`
  do insideOpt convert "R:m" $ pAdv
  `mplus`
  do insideOpt convert "R:c" $ pAdv
  `mplus`
  do insideOpt convert "R:r" $ pAdv
  `mplus`
  do match convert "F:p"
  `mplus`
  do match convert "F:q"
  `mplus`
  do match convert "F:a"
  `mplus`
  do match convert "F:t"
  `mplus`
  do match convert "F:h"
  `mplus`
  do match convert "F:m"
  `mplus`
  do match convert "F:r"
  `mplus`
  do match convert "W:b"
  `mplus`
  do match convert "L:b"

pPP =
  do prep <- do lemma "ICS" "Prep" "s"
             `mplus`
             do lemma "ICSk" "Prep" "s"
             `mplus`
             do lemma "ICSt" "Prep" "s"
             `mplus`
             do lemma "ICSx" "Prep" "s"
             `mplus`
             do lemma "IF" "Prep" "s"
             `mplus`
             do lemma "II" "Prep" "s"
             `mplus`
             do lemma "IIa" "Prep" "s"
             `mplus`
             do lemma "IIb" "Prep" "s"
             `mplus`
             do lemma "IIg" "Prep" "s"
             `mplus`
             do lemma "IIp" "Prep" "s"
             `mplus`
             do lemma "IIt" "Prep" "s"
             `mplus`
             do lemma "IO" "Prep" "s"
             `mplus`
             do lemma "IW" "Prep" "s"
             `mplus`
             do insideOpt convert "II=" $ do
                  w1 <- word "II21"
                  w2 <- word "II22"
                  lookupForm "Prep" "s" (unwords [w1,w2])
     np   <- do insideOpt convert "N" pNP
             `mplus`
             do (mb_num,n) <- pN
                case mb_num of
                  Just num | num == cidNumPl -> return (cidDetCN (cidDetQuant cidIndefArt num) (cidUseN n))
                  _                          -> return (cidMassNP (cidUseN n))    -- we don't know the number
     return (cidPrepNP prep np)

pNP =
  do np <- pBaseNP
     mods <- many pNPMods
     return (foldl (\t mod -> mod t)
                   np
                   mods)
  `mplus`
  do pBaseNP

pBaseNP = 
  do det         <- pDet
     (mb_num,cn) <- pCN
     case mb_num of
       Just num -> return (cidDetCN (det num) cn)
       Nothing  -> mzero    -- we don't know the number
  `mplus`
  do pn <- pName
     return (cidUsePN pn)
  `mplus`
  do (mb_num,cn) <- pCN
     case mb_num of
       Just num | num == cidNumPl -> return (cidDetCN (cidDetQuant cidIndefArt num) cn)
       _                          -> return (cidMassNP cn)    -- we don't know the number     
  `mplus`
  do match convert "PPIS1"
     return (cidUsePron cidi_Pron)
  `mplus`
  do match convert "PPY"
     return (cidUsePron cidyouSg_Pron)
  `mplus`
  do match convert "PPHS1m"
     return (cidUsePron cidhe_Pron)
  `mplus`
  do match convert "PPHS1f"
     return (cidUsePron cidshe_Pron)
  `mplus`
  do match convert "PPH1"
     return (cidUsePron cidit_Pron)
  `mplus`
  do match convert "PPIS2"
     return (cidUsePron cidwe_Pron)
  `mplus`
  do match convert "PPHS2"
     return (cidUsePron cidthey_Pron)
  `mplus`
  do match convert "Nn"

pDet =
  do match convert "DDy"
     return (\num -> if num == cidNumSg
                       then cidanySg_Det
                       else cidanyPl_Det)
  `mplus`
  do det <- lemma "DA2" "Det" "s"
     return (\num -> det)
  `mplus`
  do num0 <- pNumeral
     return (\num -> cidDetQuant cidIndefArt num0)
  `mplus`
  do q   <- pQuant
     ord <- pOrd
     return (\num -> cidDetQuantOrd q num ord)
  `mplus`
  do q      <- pQuant
     mb_num <- opt pNumeral
     return (\num -> cidDetQuant q (fromMaybe num mb_num))

pQuant =
  do match convert "AT"
     return cidDefArt
  `mplus`
  do match convert "AT1"
     return cidIndefArt
  `mplus`
  do match convert "ATn"
     return cidno_Quant
  `mplus`
  do match convert "APPGi1"
     return (cidPossPron cidi_Pron)
  `mplus`
  do match convert "APPGy"
     return (cidPossPron cidyouSg_Pron)
  `mplus`
  do match convert "APPGm"
     return (cidPossPron cidhe_Pron)
  `mplus`
  do match convert "APPGf"
     return (cidPossPron cidshe_Pron)
  `mplus`
  do match convert "APPGh1"
     return (cidPossPron cidit_Pron)
  `mplus`
  do match convert "APPGi2"
     return (cidPossPron cidwe_Pron)
  `mplus`
  do match convert "APPGh2"
     return (cidPossPron cidthey_Pron)
  `mplus`
  do lemma "DD1a" "Quant" "s True Sg"
  `mplus`
  do lemma "DD1i" "Quant" "s True Sg"
  `mplus`
  do lemma "DD2a" "Quant" "s True Pl"
  `mplus`
  do lemma "DD2i" "Quant" "s True Pl"
  `mplus`
  do lemma "DDi" "Quant" "s True Pl"
  `mplus`
  insideOpt convert "G" pGenitive

pOrd =
  do a <- lemma "JJT" "A" "s (AAdj Superl Nom)"
     return (cidOrdSuperl a)

pNumeral =
  do w <- word "MC" `mplus` word "MC1"
     cnc <- getConcr
     case parse cnc "Numeral" w of
       Right [(e,_)] -> do n <- toParseTree e
                           return (cidNumCard (cidNumNumeral n))
       _             -> mzero
  `mplus`
  do w <- word "MCn"
     cnc <- getConcr
     case parse cnc "Digits" w of
       Right [(e,_)] -> do n <- toParseTree e
                           return (cidNumCard (cidNumDigits n))
       _             -> mzero
  where
    toParseTree e = 
      case unApp e of
        Just (f,es) -> do ps <- mapM toParseTree es
                          return (App f ps)
        Nothing     -> mzero

pGenitive =
  do np <- insideOpt convert "N" pNP
     match convert "GG"
     return (cidGenNP np)

pCN =
  do pn <- mplus pName (insideOpt convert "Nn" pName)
     (mb_num,cn) <- pCN
     return (mb_num,cidNameCN pn cn)
  `mplus`
  do (mb_num_n,n) <- mplus pN (inside "N" pCN)
     (mb_num,cn) <- pCN
     case mb_num_n of
       Just num | num == cidNumPl -> return (mb_num,cidCompoundPlCN (cidUseN n) cn)
       _                          -> return (mb_num,cidCompoundSgCN (cidUseN n) cn)  -- here we don't really know the number
  `mplus`
  do ap <- pAP
     (mb_num,cn) <- pCN
     return (mb_num,cidAdjCN ap cn)
  `mplus`
  do t <- match convert "NN1u&"
     mods <- many pCNMods
     return (Just cidNumSg
            ,foldl (\t mod -> mod t)
                   t
                   mods)
  `mplus`
  do (mb_num,n) <- pN
     mods <- many pCNMods
     return (mb_num,
             foldl (\t mod -> mod t)
                   (cidUseN n)
                   mods)

pAP =
  do a <-  lemma "JJ" "A" "s (AAdj Posit Nom)"
           `mplus`
           lemma "JA" "A" "s (AAdj Posit Nom)"
           `mplus`
           lemma "JB" "A" "s (AAdj Posit Nom)"
           `mplus`
           lemma "JBo" "A" "s (AAdj Posit Nom)"
           `mplus`
           lemma "DAy" "A" "s (AAdj Posit Nom)"
           `mplus`
           lemma "DAz" "A" "s (AAdj Posit Nom)"
     return (cidPositA a)
  `mplus`
  do a <-  lemma "JJR" "A" "s (AAdj Compar Nom)"
     return (cidUseComparA a)
  `mplus`
  do vp <- match convert "Tn"
     return (cidPastPartAP vp)
  `mplus`
  do vp <- insideOpt convert "Tg" pVPPresPart
     return (cidPresPartAP vp)
  `mplus`
  do insideOpt convert "J" $ do
       adas <- many pAdA
       ap <- pAP
       mods <- many pAPMods
       return (foldl (\t ada -> cidAdAP ada t)
                     (foldl (\t mod -> cidAdvAP t mod)
                            ap
                            mods)
                     adas)

pAdA = do
  a <- lemma "RR" "A" "s AAdv"
  return (cidPositAdAAdj a)

pAPMods =
  do insideOpt convert "P" pPP

pN =
  do n <- lemma "NNn" "N" "s Sg Nom"
     return (Nothing, n)
  `mplus`
  do n <- lemma "NNu" "N" "s Sg Nom"
     return (Just cidNumPl, n)
  `mplus`
  do n <- lemma "NNux" "N" "s Sg Nom"
     return (Nothing, n)
  `mplus`
  do n <- lemma "NN1c" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NN1m" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NN1n" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NN1u" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NN1ux" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NN2" "N" "s Pl Nom"
     return (Just cidNumPl, n)
  `mplus`
  do n <- lemma "NNJ1c" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNJ1n" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNJ2" "N" "s Pl Nom"
     return (Just cidNumPl, n)
  `mplus`
  do n <- lemma "NNLc" "N" "s Sg Nom"
     return (Nothing, n)
  `mplus`
  do n <- lemma "NNL1c" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNL1cb" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNL1n" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNL2" "N" "s Pl Nom"
     return (Just cidNumPl, n)
  `mplus`
  do n <- lemma "NNS1c" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNS1n" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNS2" "N" "s Pl Nom"
     return (Just cidNumPl, n)
  `mplus`
  do n <- lemma "NNT1h" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNT1m" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNT1c" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNT2" "N" "s Pl Nom"
     return (Just cidNumPl, n)
  `mplus`
  do n <- lemma "NNUc" "N" "s Sg Nom"
     return (Nothing, n)
  `mplus`
  do n <- lemma "NNUn" "N" "s Sg Nom"
     return (Nothing, n)
  `mplus`
  do n <- lemma "NNU1c" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNU1n" "N" "s Sg Nom"
     return (Just cidNumSg, n)
  `mplus`
  do n <- lemma "NNU2" "N" "s Pl Nom"
     return (Just cidNumPl, n)
  `mplus`
  do inside "Ns" $ do
       (mb_num1,n1) <- pN
       match convert "YH"
       (mb_num2,n2) <- pN
       case mb_num1 of
         Just num | num == cidNumPl -> return (mb_num2,cidDashPlN n1 n2)
         _                          -> return (mb_num2,cidDashSgN n1 n2)  -- here we don't really know the number

pCNMods =
  do adv <- insideOpt convert "Po" $ pPP
     return (\t -> cidAdvCN t adv)
  `mplus`
  do adv <- insideOpt convert "P" $ pPP
     return (\t -> cidAdvCN t adv)
  `mplus`
  do adv <- insideOpt convert "Fn" $ do
              match convert "CST"
              s <- pS
              return (cidSubjS cidthat_Subj s)
     return (\t -> cidAdvCN t adv)
  `mplus`
  do fr <- insideOpt convert "Fr" pRS
     return (\t -> cidRelCN t fr)

pNPMods =
  do adv <- insideOpt convert "Po" $ pPP
     return (\t -> cidAdvNP t adv)
  `mplus`
  do adv <- insideOpt convert "P" $ pPP
     return (\t -> cidAdvNP t adv)
  `mplus`
  do adv <- insideOpt convert "Fn" $ do
              match convert "CST"
              s <- pS
              return (cidSubjS cidthat_Subj s)
     return (\t -> cidAdvNP t adv)
  `mplus`
  do match convert "YC"
     adv <- insideOpt convert "Po" $ pPP
     opt (match convert "YC")
     return (\t -> cidExtAdvNP t adv)
  `mplus`
  do match convert "YC"
     adv <- insideOpt convert "P" $ pPP
     opt (match convert "YC")
     return (\t -> cidExtAdvNP t adv)
  `mplus`
  do match convert "YC"
     adv <- insideOpt convert "Fn" $ do
              match convert "CST"
              s <- pS
              return (cidSubjS cidthat_Subj s)
     opt (match convert "YC")
     return (\t -> cidExtAdvNP t adv)
  `mplus`
  do match convert "YC"
     fr <- insideOpt convert "Fr" pRS
     opt (match convert "YC")
     return (\t -> cidRelNP t fr)

pName =
  do w1 <- word "NP1s"
     w2 <- word "NNL1cb"
     return (cidSymbPN (cidMkSymb (Lit (unwords [w1,w2]))))
  `mplus`
  do w1 <- word "NPM1"
     match convert "YH"
     w2 <- word "NPM1"
     return (cidSymbPN (cidMkSymb (Lit (unwords [w1,"-",w2]))))
  `mplus`
  do w1 <- msum [word "NP1c", word "NP1f", word "NP1g"
                ,word "NP1j", word "NP1m", word "NP1p"
                ,word "NP1s", word "NP1t", word "NP1x"
                ,word "NP1z", word "NP2c", word "NP2f"
                ,word "NP2g", word "NP2j", word "NP2m"
                ,word "NP2p", word "NP2s", word "NP2t"
                ,word "NP2x", word "NP2z"]
     return (cidSymbPN (cidMkSymb (Lit w1)))

pM = do
  num <- pNumeral
  mods <- many pNPMods
  return (foldl (\t mod -> mod t)
                (cidDetNP (cidDetQuant cidIndefArt num))
                mods)

pRS = 
  do rp <- pRP
     np <- pSubject
     (t,p,vp) <- pVP
     return (cidUseRCl t p (cidRelSlash rp (cidSlashVP np vp)))
  `mplus`
  do rp <- pRP
     (t,p,vp) <- pVP
     opt (match convert "YC")
     return (cidUseRCl t p (cidRelVP rp vp))
  `mplus`
  do (prep,rp) <- inside "Pq" $ do
                    prep <- lemma "II" "Prep" "s"
                    rp   <- pRP
                    return (prep,rp)
     np <- pSubject
     (t,p,vp) <- pVP
     opt (match convert "YC")
     return (cidUseRCl t p (cidRelSlash rp (cidSlashVP np (cidVPSlashPrep vp prep))))

pRP = 
  do inside "Dq" (match convert "DDQr")
     return cidIdRP

pTimeNPAdv = do
  day <- lemma "NPD1" "Weekday" "s Sg Nom"
  return (cidweekdayPunctualAdv day)