path: root/treebanks/PennTreebank/translate.hs

-- [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 "?"