content: -- [1416,4467,4623,4871,4561,4303,3763,3137,2501,1857,1353,952,646,483,332,200,116,89,54,41,20,22,7,2,4,5,0,3,2,1,0,0,0,0,0,1]
  -- average 5
  
  import Monad
  import Idents
  import PennFormat
  
  import PGF hiding (Tree,parse)
  import Control.Monad
  import System.IO
  import System.Process
  import Data.Maybe
  import Data.List
  import Data.IORef
  import Data.Char
  import Data.Tree
  
  test = False
  
  main = do
    pgf <- readPGF "ParseEngAbs.pgf"
    let Just language = readLanguage "ParseEng"
        morpho        = buildMorpho pgf language
    s <- readFile "wsj.02-21"
    ref <- newIORef (0,0,0)
    mapM_ (process pgf morpho ref) ((if test then take 40 else id) (parseTreebank s))
    where
      process pgf morpho ref t = do
        (cn,co,l) <- readIORef ref
        let e         = (flatten . parse penn pgf morpho . prune) t
            (cn',co') = count (cn,co) e
            l'        = l+1
        writeIORef ref (cn',co',l')
        hPutStrLn stdout (showExpr [] e)
        when test $ do
          writeFile ("tmp_tree.dot") (graphvizAbstractTree pgf (True,False) e)
          rawSystem "dot" ["-Tpdf", "tmp_tree.dot", "-otrees/tree"++showAlign l'++".pdf"]
          return ()
        hPutStrLn stderr (show ((fromIntegral cn' / fromIntegral co') * 100))
  
      count (cn,co) e = cn `seq` co `seq`
        case unApp e of
          Just (f,es) -> if f == meta
                           then foldl' count (cn,  co+1) es
                           else foldl' count (cn+1,co+1) es
          Nothing     -> (cn+1,co+1)
  
  
      showAlign n =
        replicate (5 - length s) '0' ++ s
        where
          s = show n
  
      prune (Node tag ts)
        |   tag == "S" 
         && not (null ts)
         && last ts == Node "." [Node "." []] = Node tag (init ts)
        | otherwise                           = Node tag ts
        
      flatten e =
        case unApp e of
          Just (f,es) | f == meta -> mkApp f (concatMap grab es)
                      | otherwise -> mkApp f (map flatten es)
          Nothing                 -> e
  
      grab e =
        case unApp e of
          Just (f,es) | f == meta -> concatMap grab es
                      | otherwise -> [mkApp f (map flatten es)]
          Nothing                 -> []
  
  
  penn :: Grammar String Expr
  penn =
    grammar (mkApp meta) 
     [ "ADVP":-> do adv <- cat "RB"
                    case unApp adv of
                      Just (f,[a]) | f == cidPositAdvAdj -> return (mkApp cidPositAdVAdj [a])
                      _                                  -> mzero
                 `mplus`
                 do adV <- inside "RB" (lemma "AdV" "s")
                    return (mkApp adV [])
     , "ADJP":-> do adas <- many pAdA
                    v <- inside "JJ" (lemma "V2" "s VPPart")
                    pps <- many (cat "PP")
                    let adj  = mkApp cidPastPartAP [mkApp v []]
                        ap0  = foldr (\ada ap -> mkApp cidAdAP [ada,ap]) adj adas
                        ap   = foldr (\pp ap -> mkApp cidAdvAP [ap,pp]) ap0 pps
                    return ap
                 `mplus`
                 do adas0 <- many pAdA
                    adjs  <- many1 (cat "JJ")
                    let adj  = last adjs
                        adas = adas0 ++ [mkApp cidPositAdAAdj [adj] | adj <- init adjs]
                        ap   = foldr (\ada ap -> mkApp cidAdAP [ada,ap]) (mkApp cidPositA [adj]) adas
                    return ap
     , "S"   :-> do advs <- many $ do pp <- cat "PP"
                                      inside "," word
                                      return pp
                                   `mplus`
                                   do cat "ADVP"                  
                    e0 <- do (tmp,pol,sl,e) <- pClSlash
                             guard (not sl)
                             return (mkApp cidUseCl [tmp,pol,e])
                          `mplus`
                          do s <- cat "S"
                             inside "," word
                             np <- cat "NP"
                             inside "VP" $ do
                               (t,v) <- pV "VS"
                               inside "SBAR" $ do
                                 cat "-NONE-"
                                 inside "S" $ do
                                   cat "-NONE-"
                               return (mkApp cidUseCl [mkApp cidTTAnt [ mkApp (fromMaybe meta (isVTense t)) []
                                                                      , mkApp cidASimul []
                                                                      ]
                                                      ,mkApp cidPPos []
                                                      ,mkApp cidComplPredVP [np,mkApp cidComplVS [mkApp v [],s]]
                                                      ])
                    opt (inside "." word) ""
                    return (foldr (\ad e -> mkApp cidAdvS [ad, e]) e0 advs)
                  `mplus`
                  do s1 <- cat "S"
                     opt (inside "," word) ""
                     cc <- cat "CC"
                     s2 <- cat "S"
                     return (mkApp cidConjS [cc, mkApp cidBaseS [s1,s2]])
     , "SBAR" :-> do (do cat "-NONE-"    -- missing preposition
                         return ()
                      `mplus`
                      do w <- inside "IN" word
                         guard (w == "that"))
                     cat "S"
     , "NP"  :-> do (m_cc,list_np) <- pBaseNPs
                    case m_cc of
                      Just cc -> return (mkApp cidConjNP [cc, mkListNP list_np])
                      Nothing -> if length list_np > 1
                                   then return (mkApp meta list_np)
                                   else return (head list_np)
                 `mplus`
                 do np <- cat "NP"
                    rs <- inside "SBAR" $
                            do rp <- cat "WHNP"
                               inside "S" $
                                 do (tmp,pol,sl,e) <- pClSlash
                                    guard sl
                                    return (mkApp cidUseRCl [tmp,pol,mkApp cidRelSlash [rp,e]])
                                 `mplus`
                                 do inside "NP" (cat "-NONE-")
                                    (tmp,pol,sl,vp) <- inside "VP" pVP
                                    guard (not sl)
                                    return (mkApp cidUseRCl [fromMaybe (mkApp meta []) (isVTense tmp)
                                                            ,mkApp pol []
                                                            ,mkApp cidRelVP [rp,vp]])
                    return (mkApp cidRelNP [np,rs])
                 `mplus`
                 do (m_cc,list_np) <- pNPs
                    case m_cc of
                      Just cc -> return (mkApp cidConjNP [cc, mkListNP list_np])
                      Nothing -> if length list_np > 1
                                   then return (mkApp meta list_np)
                                   else return (head list_np)
     , "VP"  :-> do (_,_,_,e) <- pVP
                    return e
     , "PP"  :-> do prep <- do cat "IN"
                            `mplus`
                            do inside "TO" word
                               return (mkApp cidto_Prep [])
                            `mplus`
                            do w1 <- inside "JJ" word
                               w2 <- inside "IN" word
                               guard (w1 == "such" && w2 == "as")
                               return (mkApp cidsuch_as_Prep [])
                    np   <- cat "NP"
                    return (mkApp cidPrepNP [prep,np])
                 `mplus`
                 do pp1 <- cat "PP"
                    inside "," word
                    conj <- cat "CC"
                    pp2 <- cat "PP"
                    opt (inside "," word) ""
                    return (mkApp cidConjAdv [conj, mkApp cidBaseAdv [pp1,pp2]])
     , "CC"  :-> do cc <- word
                    case cc of
                      "and" -> return (mkApp cidand_Conj [])
                      "&"   -> return (mkApp cidamp_Conj [])
                      "or"  -> return (mkApp cidor_Conj  [])
                      _     -> mzero
     , "DT"  :-> do (dt,b) <- pDT
                    return dt
     , "IN"  :-> do prep <- lemma "Prep" "s"
                    return (mkApp prep [])
     , "NN"  :-> do transform (concatMap splitDashN)
                    (do n <- lemma "N" "s Sg Nom"
                        (do inside "-" word
                            n2 <- lemma "N" "s Sg Nom"
                            return (mkApp cidDashCN [mkApp n [], mkApp n2 []])
                         `mplus`
                         do return (mkApp n [])))
                 `mplus`
                 do v <- lemma "V" "s VPresPart"
                    return (mkApp cidGerundN [mkApp v []])
     , "NNS" :-> do transform (concatMap splitDashN)
                    (do n <- lemma "N" "s Pl Nom"
                        return (mkApp n [])
                     `mplus`
                     do n1 <- lemma "N" "s Sg Nom"
                        inside "-" word
                        n2 <- lemma "N" "s Pl Nom"
                        return (mkApp cidDashCN [mkApp n1 [], mkApp n2 []]))
     , "PRP" :-> do p <- (lemma "Pron" "s (NCase Nom)"
                          `mplus`
                          lemma "Pron" "s NPAcc"
                          `mplus`
                          (do w <- word
                              guard (w == "I")   -- upper case word
                              return cidi_Pron))
                    return (mkApp p [])
     , "PRP$":-> do p <- lemma "Pron" "s (NCase Gen)"
                    return (mkApp cidPossPron [mkApp p []])
     , "RB"  :-> do a <- lemma "A" "s AAdv"
                    return (mkApp cidPositAdvAdj [mkApp a []])
                 `mplus`
                 do adv <- lemma "Adv" "s"
                    return (mkApp adv [])
     , "QP"  :-> do adn <- inside "IN" (lemma "AdN" "s")
                    num <- pCD
                    return (mkApp cidDetQuant [mkApp cidIndefArt [], mkApp cidNumCard [mkApp cidAdNum [mkApp adn [], num]]])
     , "WHNP":-> cat "WP"
                 `mplus`
                 cat "WDT"
                 `mplus`
                 cat "WP$"
                 `mplus`
                 do cat "-NONE-"
                    return (mkApp cidno_RP [])
                 `mplus`
                 do w <- inside "IN" word
                    guard (w == "that")
                    return (mkApp cidthat_RP [])
     , "-NONE-"
             :-> return (mkApp meta [])
     , "JJ"  :-> do a <- lemma "A" "s (AAdj Posit Nom)"
                    return (mkApp a [])
     , "JJR" :-> do a <- lemma "A" "s (AAdj Compar Nom)"
                    return (mkApp a [])
     , "JJS" :-> do a <- lemma "A" "s (AAdj Superl Nom)"
                    return (mkApp cidOrdSuperl [mkApp a []])
     , "VB"  :-> do v <- mplus (lemma "V" "s VInf")  (lemma "V2" "s VInf")
                    return (mkApp v [])
     , "VBD" :-> do v <- mplus (lemma "V" "s VPast") (lemma "V2" "s VPast")
                    return (mkApp v [])
     , "VBG" :-> do v <- mplus (lemma "V" "s VPresPart") (lemma "V2" "s VPresPart")
                    return (mkApp v [])
     , "VBN" :-> do v <- mplus (lemma "V" "s VPPart") (lemma "V2" "s VPPart")
                    return (mkApp v [])
     , "VBP" :-> do v <- mplus (lemma "V" "s VInf") (lemma "V2" "s VInf")
                    return (mkApp v [])
     , "VBZ" :-> do v <- mplus (lemma "V" "s VPres") (lemma "V2" "s VPres")
                    return (mkApp v [])
     , "PDT" :-> do pdt <- lemma "Predet" "s"
                    return (mkApp pdt [])
     , "WP"  :-> do rp <- (lemma "RP" "s (RC Masc (NCase Nom))"
                           `mplus`
                           lemma "RP" "s (RC Masc NPAcc)")
                    return (mkApp rp [])
     , "WDT" :-> do rp <- lemma "RP" "s (RC Neutr (NCase Nom))"
                    return (mkApp rp [])
     , "WP$" :-> do rp <- lemma "RP" "s (RC Masc (NCase Gen))"
                    return (mkApp rp [])
     ]
  
  data VForm a
    = VInf | VPart | VGerund | VTense a
  
  instance Functor VForm where
    fmap f VInf       = VInf
    fmap f VPart      = VPart
    fmap f VGerund    = VGerund
    fmap f (VTense t) = VTense (f t)
  
  isVInf VInf = True
  isVInf _    = False
  
  isVPart VPart = True
  isVPart _     = False
  
  isVGerund VGerund = True
  isVGerund _       = False
  
  isVTense (VTense t) = Just t
  isVTense _          = Nothing
  
  
  pVP = do
    (t,a,p,sl,e0) <- do t <- pCopula
                        p <- pPol
                        inside "VP" $ do
                          advs <- many (cat "ADVP")
                          (t',p',sl,e0) <- pVP
                          guard (isVPart t' && sl && p' == cidPPos)
                          let e1 = mkApp cidPassVPSlash [e0]
                              e2 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e1 advs
                          return (t,cidASimul,p,False,e2)
                     `mplus`
                     do t <- pCopula
                        p <- pPol
                        advs <- many (cat "ADVP")
                        e <- do e <- cat "ADJP"
                                return (mkApp cidCompAP [e])
                             `mplus`
                             do e <- cat "NP"
                                return (mkApp cidCompNP [e])
                             `mplus`
                             do e <- cat "NP"
                                return (mkApp cidCompNP [e])
                             `mplus`
                             do e <- cat "PP"
                                return (mkApp cidCompAdv [e])
                             `mplus`
                             do e <- cat "SBAR"       
                                return (mkApp cidCompS [e])
                             `mplus`
                             do e <- inside "S" $ do
                                        inside "NP" (cat "-NONE-")
                                        (tmp,pol,sl,e) <- inside "VP" pVP
                                        guard (isVInf tmp && not sl && pol == cidPPos)
                                        return e
                                return (mkApp cidCompVP [e])
                        let e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) (mkApp cidUseComp [e]) advs
                        return (t,cidASimul,p,False,e1)
                     `mplus`
                     do t <- pCopula
                        p <- pPol
                        advs <- many (cat "ADVP")
                        (tmp,pol,sl,e) <- inside "VP" pVP
                        guard (isVGerund tmp && not sl && pol == cidPPos)
                        let e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e advs
                        return (t,cidASimul,p,False,mkApp cidProgrVP [e1])
                     `mplus`
                     do t <- pCopula
                        p <- pPol
                        adv <- cat "ADVP"
                        return (t,cidASimul,p,False,mkApp cidUseComp [mkApp cidCompAdv [adv]])
                     `mplus`
                     do w <- inside "MD" word
                        t <- case w of
                               "will"  -> return cidTFut
                               "would" -> return cidTCond
                               _       -> mzero
                        p <- pPol
                        advs <- many (cat "ADVP")
                        (tmp,pol,sl,e0) <- inside "VP" pVP
                        guard (isVInf tmp && pol == cidPPos)
                        let e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (VTense t,cidASimul,p,sl,e1)
                     `mplus`
                     do t <- pHave
                        p <- pPol
                        advs   <- many (cat "ADVP")
                        (tmp,pol,sl,e0) <- inside "VP" pVP
                        guard (isVPart tmp && pol == cidPPos)
                        let e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (t,cidAAnter,p,sl,e1)
                     `mplus`
                     do t <- pDo
                        p <- pPol
                        advs <- many (cat "ADVP")
                        (tmp,p',sl,e0) <- inside "VP" $ pVP
                        guard (p' == cidPPos)
                        let e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (t,cidASimul,p,sl,e1)
                     `mplus`
                     do advs <- many (cat "ADVP")
                        inside "TO" word                        -- infinitives
                        e0 <- cat "VP"
                        let e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (VInf,cidASimul,cidPPos,False,e1)
                     `mplus`
                     do advs1 <- many (cat "ADVP")
                        (t,v) <- pV "V2"
                        pps   <- many (cat "PP")
                        let e0 = mkApp cidSlashV2a [mkApp v []]
                            e1 = foldl (\e pp -> mkApp cidAdvVPSlash [e, pp]) e0 pps
                        (sl,e2) <- (do (inside "NP" (cat "-NONE-")
                                        `mplus`
                                        inside "SBAR" (cat "-NONE-"))
                                       return (True,e1)
                                    `mplus`
                                    do np <- cat "NP"
                                       return (False,mkApp cidComplSlash [e1, np]))
                        let e3 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e2 advs1
                        return (t,cidASimul,cidPPos,sl,e3)
                     `mplus`
                     do (t,v) <- inside "MD" $
                                   (do v <- lemma "VV" "s (VVF VPres)"
                                       return (cidTPres,v)
                                    `mplus`
                                    do v <- lemma "VV" "s (VVF VPast)"
                                       return (cidTPast,v))
                        p <- pPol
                        advs <- many (cat "ADVP")
                        vp <- cat "VP"
                        let e0 = mkApp cidComplVV [mkApp v [], vp]
                            e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (VTense t,cidASimul,p,False,e1)
                     `mplus`
                     do advs <- many (cat "ADVP")
                        (t,v) <- pVV
                        vp    <- inside "S" $ do
                                    inside "NP" (cat "-NONE-")
                                    (tmp,pol,sl,e) <- inside "VP" pVP
                                    guard ((isVInf tmp || isVGerund tmp) && not sl && pol == cidPPos)
                                    return e
                        let e0 = mkApp cidComplVV [mkApp v [], vp]                          
                            e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (t,cidASimul,cidPPos,False,e1)
                     `mplus`
                     do advs <- many (cat "ADVP")
                        (t,v) <- pV "V2V"
                        inside "S" $ 
                          (do inside "NP" (cat "-NONE-")
                              (tmp,pol,sl,vp) <- inside "VP" pVP
                              guard (isVInf tmp && not sl)
                              let e0 = mkApp cidSlashV2V [mkApp v [], mkApp pol [], vp]
                                  e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                              return (t,cidASimul,cidPPos,True,e1)
                           `mplus`
                           do np <- cat "NP"
                              (tmp,pol,sl,vp) <- inside "VP" pVP
                              guard (isVInf tmp && not sl)
                              let e0 = mkApp cidComplSlash [mkApp cidSlashV2V [mkApp v [], mkApp pol [], vp], np]
                                  e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                              return (t,cidASimul,cidPPos,False,e1))
                     `mplus`
                     do advs <- many (cat "ADVP")
                        (t,v) <- pV "VA"
                        adjp  <- cat "ADJP"
                        let e0 = mkApp cidComplVA [mkApp v [], adjp]
                            e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (t,cidASimul,cidPPos,False,e1)
                     `mplus`
                     do advs <- many (cat "ADVP")
                        (t,v) <- pV "VS"
                        s     <- cat "S" `mplus` cat "SBAR"
                        let e0 = mkApp cidComplVS [mkApp v [], s]
                            e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (t,cidASimul,cidPPos,False,e1)
                     `mplus`
                     do advs <- many (cat "ADVP")
                        (t,v) <- pV "V"
                        let e0 = mkApp cidUseV [mkApp v []]
                            e1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) e0 advs
                        return (t,cidASimul,cidPPos,False,e1)
    pps <- many (cat "PP"
                 `mplus`
                 inside "ADVP" (cat "RB"))
    let tmp = fmap (\t -> mkApp cidTTAnt [mkApp t [],mkApp a []]) t
        e1  = foldl (\e pp -> mkApp (if sl then cidAdvVPSlash else cidAdvVP) [e, pp]) e0 pps
    return (tmp, p, sl, e1)
  
  pClSlash = do np <- cat "NP"
                advs <- many (cat "ADVP")
                (tmp,pol,sl,vp) <- do (tmp,pol,sl,vp) <- inside "VP" pVP
                                      return (isVTense tmp,pol,sl,vp)
                                   `mplus`
                                   do vp <- cat "VP"
                                      return (Nothing,meta,False,vp)
                let vp1 = foldr (\pp e -> mkApp cidAdVVP [pp, e]) vp advs
                return (fromMaybe (mkApp meta []) tmp
                       ,mkApp pol []
                       ,sl
                       ,mkApp (if sl then cidSlashVP else cidPredVP) [np,vp1]
                       )
  
  pV cat =
    do v <- lookup "VB" "s VInf"
       return (VInf,v)
    `mplus`
    do v <- lookup "VBP" "s VInf"
       return (VTense cidTPres,v)
    `mplus`
    do v <- lookup "VBZ" "s VPres"
       return (VTense cidTPres,v)
    `mplus`
    do v <- lookup "VBD" "s VPast"
       return (VTense cidTPast,v)
    `mplus`
    do v <- lookup "VBN" "s VPPart"
       return (VPart,v)
    `mplus`
    do v <- lookup "VBG" "s VPresPart"
       return (VGerund,v)
    where
      lookup pos fld = 
         inside pos $
           (do lemma cat fld
            `mplus`
            do w <- word
               return (mkCId ("["++w++"_"++cat++"]")))
  
  pVV =
    do v <- lookup "VB" "s (VVF VInf)"
       return (VInf,v)
    `mplus`
    do v <- lookup "VBP" "s (VVF VInf)"
       return (VTense cidTPres,v)
    `mplus`
    do v <- lookup "VBZ" "s (VVF VPres)"
       return (VTense cidTPres,v)
    `mplus`
    do v <- lookup "VBD" "s (VVF VPast)"
       return (VTense cidTPast,v)
    `mplus`
    do v <- lookup "VBN" "s (VVF VPPart)"
       return (VPart,v)
    `mplus`
    do v <- lookup "VBG" "s (VVF VPresPart)"
       return (VGerund,v)
    where
      lookup pos fld = 
         inside pos $
           (do lemma "VV" fld
            `mplus`
            do w <- word
               return (mkCId ("["++w++"_VV]")))
  
  pCopula =
    do s <- inside "VB" word
       guard (s == "be")
       return VInf
    `mplus`
    do s <- inside "VBP" word
       guard (s == "am" || s == "'m" || s == "are" || s == "'re")
       return (VTense cidTPres)
    `mplus`
    do s <- inside "VBZ" word
       guard (s == "is" || s == "'s")
       return (VTense cidTPres)
    `mplus`
    do s <- inside "VBD" word
       guard (s == "were" || s == "was")
       return (VTense cidTPast)
    `mplus`
    do s <- inside "VBN" word
       guard (s == "been")
       return VPart
    `mplus`
    do s <- inside "VBG" word
       guard (s == "being")
       return VGerund
  
  pDo =
    do s <- inside "VB" word
       guard (s == "do")
       return VInf
    `mplus`
    do s <- inside "VBP" word
       guard (s == "do")
       return (VTense cidTPres)
    `mplus`
    do s <- inside "VBZ" word
       guard (s == "does")
       return (VTense cidTPres)
    `mplus`
    do s <- inside "VBD" word
       guard (s == "did")
       return (VTense cidTPast)
  
  pHave =
    do s <- inside "VB" word
       guard (s == "have")
       return VInf
    `mplus`
    do s <- inside "VBP" word
       guard (s == "have")
       return (VTense cidTPres)
    `mplus`
    do s <- inside "VBZ" word
       guard (s == "has")
       return (VTense cidTPres)
    `mplus`
    do s <- inside "VBD" word
       guard (s == "had")
       return (VTense cidTPast)
    `mplus`
    do s <- inside "VBN" word
       guard (s == "had")
       return VPart
  
  pPol =
    do w <- inside "RB" word
       guard (w == "n't" || w == "not")
       return cidPNeg
    `mplus`
    do return cidPPos
  
  pBaseNP = 
    do np <- inside "NN" (lemma "NP" "s (NCase Nom)")
       return (mkApp np [])
    `mplus`
    do m_pdt <- opt (liftM Just (cat "PDT")) Nothing
       m_q   <- opt (liftM Just pQuant) Nothing
       m_num <- opt (liftM Just pCD   ) Nothing
       m_ord <- opt (liftM Just (cat "JJS")) Nothing
       adjs  <- many pModCN
       ns    <- many1 (mplus (cat "NN"  >>= \n -> return (n,cidNumSg)) 
                             (cat "NNS" >>= \n -> return (n,cidNumPl)))
       let (n,s) = last ns
           cn0   = foldr (\(n,s) e -> mkApp cidCompoundCN [mkApp s [], n, e])
                         (mkApp cidUseN [n])
                         (init ns)
           cn    = foldr (\adj e -> mkApp cidAdjCN [adj, e]) 
                         cn0
                         adjs
           num   = maybe (mkApp s []) (\n -> mkApp cidNumCard [n]) m_num
           
           mkDetQuant q num =
             case m_ord of
               Just ord -> mkApp cidDetQuantOrd [q,num,ord]
               Nothing  -> mkApp cidDetQuant    [q,num]
  
       e0 <- if s == cidNumSg
               then case m_q of
                      Just (q,True)  -> return (mkApp cidDetCN [mkDetQuant q num,cn])
                      Just (q,False) -> return (mkApp cidDetCN [q,cn])
                      Nothing        -> do guard (isNothing m_num)
                                           return (mkApp cidMassNP [cn])
               else case m_q of
                      Just (q,True)  -> return (mkApp cidDetCN [mkDetQuant q num,cn])
                      Just (q,False) -> return (mkApp cidDetCN [q,cn])
                      Nothing        -> return (mkApp cidDetCN [mkDetQuant (mkApp cidIndefArt []) num,cn])
       let e1 = case m_pdt of
                  Just pdt -> mkApp cidPredetNP [pdt,e0]
                  Nothing  -> e0
       return e1
    `mplus`
    do dt <- cat "QP"
       n  <- mplus (cat "NN") (cat "NNS")
       return (mkApp cidDetCN [dt,mkApp cidUseN [n]])
    `mplus`
    do m_q <- opt (liftM Just pQuant) Nothing
       ws2 <- many1 (inside "NNP" word `mplus` inside "NNPS" word)
       let e0 = mkApp cidSymbPN
                      [mkApp cidMkSymb 
                             [mkStr (unwords ws2)]]
       case m_q of
         Just (q,b) -> do guard b
                          return (mkApp cidUseQuantPN [q,e0])
         Nothing    -> return (mkApp cidUsePN      [e0])
    `mplus`
    do p <- inside "PRP" (lemma "NP" "s (NCase Nom)")
       return (mkApp p [])
    `mplus`
    do p <- cat "PRP"
       return (mkApp cidUsePron [p])
    `mplus`
    do np   <- cat "NP"
       pps  <- many1 (cat "PP")
       prns <- many  (cat "PRN")
       let e0 = foldl (\e pp -> mkApp cidAdvNP [e, pp]) np pps
           e1 = foldl (\e pn -> mkApp meta     [e, pn]) e0 prns
       return e1
    `mplus`
    do np <- cat "NP"
       inside "," word
       (t',p',sl,vp) <- inside "VP" pVP
       guard (isVPart t' && sl && p' == cidPPos)
       inside "," word
       return (mkApp meta [np, vp])
    `mplus`
    do (q,b) <- pQuant
       return (mkApp cidDetNP [if b
                                 then mkApp cidDetQuant [mkApp cidIndefArt [],mkApp cidNumSg []]
                                 else q])
    `mplus`
    do n <- pCD
       return (mkApp cidDetNP [mkApp cidDetQuant [mkApp cidIndefArt [],mkApp cidNumCard [n]]])
  
  pBaseNPs = do
    np <- pBaseNP
    (do inside "," word
        (m_cc,nps) <- pBaseNPs
        return (m_cc   ,np:nps)
     `mplus`
     do cc  <- cat "CC"
        np2 <- pBaseNP
        return (Just cc,[np,np2])
     `mplus`
     do return (Nothing,[np]))
  
  pNPs = do
    (t1,t2) <- do w <- inside "DT" word
                  case map toLower w of
                    "both"   -> return (mkApp cidand_Conj [],mkApp cidboth7and_DConj [])
                    "either" -> return (mkApp cidor_Conj [],mkApp cideither7or_DConj [])
                    _        -> mzero
               `mplus`
               do return (mkApp meta [],mkApp meta [])
    (m_cc,nps) <- pList
    return (fmap (toDConj t1 t2) m_cc,nps)
    where
      toDConj t1 t2 cc
        | cc == t1  = t2
        | otherwise = cc
  
      pList = do
        np <- cat "NP"
        (do inside "," word
            (m_cc,nps) <- pList
            return (m_cc   ,np:nps)
         `mplus`
         do cc  <- cat "CC"
            np2 <- cat "NP"
            return (Just cc,[np,np2])
         `mplus`
         do return (Nothing,[np]))
  
  mkListNP nps0 =
    foldr (\np1 np2 -> mkApp cidConsNP [np1,np2]) (mkApp cidBaseNP nps2) nps1
    where
      (nps1,nps2) = splitAt (length nps0-2) nps0
  
  pModCN =
    do v <- inside "VBN" (lemma "V2" "s VPPart")
       return (mkApp cidPastPartAP [mkApp v []])
    `mplus`
    do v <- inside "JJ" (lemma "V2" "s VPPart")
       return (mkApp cidPastPartAP [mkApp v []])
    `mplus`
    do v <- inside "JJ" (lemma "V" "s VPresPart")
       return (mkApp cidGerundAP [mkApp v []])
    `mplus`
    do a <- cat "JJ"
       return (mkApp cidPositA [a])
    `mplus`
    do a <- cat "ADJP"
       return a
  
  pCD = 
    do w0 <- inside "CD" word
       let w = filter (/=',') w0
       guard (not (null w) && all isDigit w)
       let es = [mkApp (mkCId ("D_"++[d])) [] | d <- w]
           e0 = foldr (\e1 e2 -> mkApp cidIIDig [e1,e2]) (mkApp cidIDig [last es]) (init es)
           e1 = mkApp cidNumDigits [e0]
       return e1
    `mplus`
    do w <- inside "CD" word
       e <- case map toLower w of
              "one"   -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot01 []]]]])
              "two"   -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn2 []]]]]])
              "three" -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn3 []]]]]])
              "four"  -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn4 []]]]]])
              "five"  -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn5 []]]]]])
              "six"   -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn6 []]]]]])
              "seven" -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn7 []]]]]])
              "eight" -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn8 []]]]]])
              "nine"  -> return (mkApp cidnum [mkApp cidpot2as3 [mkApp cidpot1as2 [mkApp cidpot0as1 [mkApp cidpot0 [mkApp cidn9 []]]]]])
              _       -> mzero
       return (mkApp cidNumNumeral [e])
    `mplus`
    do cat "CD"
  
  pQuant =
    inside "DT" pDT
    `mplus`
    do dt <- cat "PRP$"
       return (dt,True)
    `mplus`
    do np <- inside "NP" $ do
               np <- pBaseNP
               inside "POS" word
               return np
       return (mkApp cidGenNP [np],True)
    `mplus`
    do dt <- pMany
       return (dt,False)
  
  pDT =
    do dt <- mplus (lemma "Quant" "s False Sg")
                   (lemma "Quant" "s False Pl")
       return (mkApp dt [],True)
    `mplus`
    do dt <- lemma "Det" "s"
       return (mkApp dt [],False)
  
  pMany =
    do w <- inside "JJ" word
       guard (map toLower w == "many")
       return (mkApp cidmany_Det [])
  
  pAdA = do adv <- cat "RB"
            case unApp adv of
              Just (f,[a]) | f == cidPositAdvAdj 
                     -> return (mkApp cidPositAdAAdj [a])
              _      -> mzero
         `mplus`
         do ada <- inside "RB" (lemma "AdA" "s")
            return (mkApp ada [])
  
  splitDashN (Node w []) =
    case break (=='-') w of
      (w1,'-':w2) -> Node w1 [] : Node "-" [Node "-" []] : splitDashN (Node w2 [])
      _           -> [Node w []]
  splitDashN t = [t]
  
  meta = mkCId "?"
  