path: root/treebanks/talbanken/Translate.hs

{-# LANGUAGE TupleSections, TypeOperators #-}
module Translate 
        (mapp
       ,main
       ,bigTest
       ,evaluation
       ,evaluations 
       ,main2 
       ,mainTest
       ,mainT2 
       ,testa
       ) where

import MonadSP
import Idents
import Test  
import Structure
import qualified State as S
import qualified Format as Form

import Control.Arrow hiding ((<+>))
import Control.Monad
import Control.Monad.RWS hiding (gets,modify,local)
import Data.Maybe
import Data.Char
import Data.IORef
import qualified Data.Label as P 
import Data.Label.PureM hiding (local)
import Data.List
import Data.Tree
import PGF hiding (parse)
import System.IO
import System.Process

-- Test by runnig mainTest. Use testGr, otherwise very slow

type PMonad = (RWS () [String] S.State)
type Translator a = P String Expr PMonad a


test = False
usePGF = testGr --newBigGr
testGr = ("../gf/BigTest.pgf","BigTestSwe")
bigGr  = ("../gf/Big.pgf","BigSwe")
newBigGr = ("../../../robust/chunk/ExtractPGF.pgf","BigParseSwe")
lang   = fromJust $ readLanguage "BigTestSwe"
paint  = False

tb = "../Talbanken05_20060604/FPS/P.tiger.xml"
------------------------------------------------------------------------------
-- Run functions
------------------------------------------------------------------------------
mapp f    = main' f >> return ()
main      = main' "test.xml" >> return ()
bigTest   = do res <- main' "../testSuites/testShortSimpleTwo.xml" 
               writeFile "mappingShort6.txt" $ unlines (getRes res)

evaluation :: IO ()
evaluation = evaluations "EvalMappSuite2.xml" "Evalresult.txt" 

evaluations :: FilePath -> FilePath -> IO ()
evaluations test to = do 
    res <- main' test 
    writeFile to $ unlines (show (getQuote res) : getRes res)
main2      = main' "test2.xml" >> return ()
mainTest   = main' "testSimple.xml" >>= putStrLn . compareRes . getRes
mainT2     = main' "testSimple.xml" >>= putStrLn . unlines . getRes

getRes :: [(Double,String)] -> [String]
getRes = map snd
getQuote :: [(Double,String)] -> Double
getQuote = fst . last 

-- Standard main
main' :: FilePath -> IO [(Double,String)]
main' fil  = do
  pgf <- readPGF $ fst usePGF
  let Just language = readLanguage $ snd usePGF
      morpho        = buildMorpho pgf language
  s <- fmap concat $ Form.parse fil
  print $ prune $ snd $ head s
  ref  <- newIORef (0,0,0)
  mapM (process pgf morpho ref) s

  where
    process pgf morpho ref (id,t) = do
      (cn,co,l) <- readIORef ref
      let idN =  takeWhile (/='_') id 
      putStrLn idN
      let (e,trace)     = evalRWS (parse penn pgf morpho (prune t)) () S.startState
          (cn',co')     = count (cn,co) e
          l'            = l+1
      writeIORef ref  (cn',co',l')
      when test $ putStrLn $ unlines trace
      putStrLn (showExpr [] e)
      when paint $ do
        writeFile "tmp_tree.dot" 
                                   (graphvizParseTree pgf lang e) 
        rawSystem "dot" ["-Tpdf", "tmp_tree.dot"
                        , "-otrees/tree"++showAlign l'++"GFparsX.pdf"]
        return ()
      let quote = (fromIntegral cn' / fromIntegral co') * 100
      hPutStrLn stderr (show quote)
      return (quote,idN++"\t"++showExpr [] e)

    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)


    
    prune (Node tag ts)
      |   tag == "ROOT" 
       && not (null ts)
       && last ts == Node "." [Node "." []] = Node tag (init ts)
      | otherwise                           = Node tag ts

showAlign :: Show a => a -> String
showAlign n =
      replicate (5 - length s) '0' ++ s
      where
        s = show n


------------------------------------------------------------------------------
-- The grammar : Rules for converting labels
------------------------------------------------------------------------------

penn :: Grammar (RWS () [String] S.State) String Expr
penn =
  grammar (mkApp meta)
   ["ROOT" :-> do s <- inside "MS" $ cat "S"
                                     `mplus` cat "XP"
                  write "root found"
                  return s 
   
     ,"S" :-> do write "start" 
                 conj     <- maybeParse $ inside "++" pPConj
                 subj     <- maybeParse $ cat "UK"
                 (s,s2)   <- pS
                 m_voc <- maybeParse (do opt (word2 "IK") ""
                                         inside "TT" pNP)
                 opt (word2 "IP" `mplus`
                      word2 "I?" `mplus`
                      word2 "IG" `mplus`
                      word2 "IU") ""
                 S.subj =: subj
                 let pconj = fromMaybe (mkExpr cidNoPConj) conj
                     voc   = fromMaybe (mkExpr cidNoVoc) m_voc
                 return $ mkApp cidPhrUtt [pconj, s,voc]

     ,"AP" :-> do write "in AP"
                  ad <- inside "AA" pAdA
                  write ("found adA: "++show ad)
                  a  <- inside "HD" pAdj
                  write ("found adj: "++show a)
                  return $ mkApp cidAdAP [ad,a]
               <+>
               do as <- many $ inside "AA" pAdAdj
                  a2 <- inside "HD" pAdj 
                  return (foldr (\ada ap -> mkApp cidAdAP [ada,ap]) a2 as)
       
      ,"AVP" :-> --bland annat, just nu, t ex, i kontakt... 
                 do iadv <- inside "HD" pIAdv
                    adv  <- pAdv
                    return $ mkApp cidAdvIAdv [iadv, adv]
                 <+>
                 do consume
                    return (mkExpr meta)
     -- ,"CAVP" :-> coordinated AVP 
      ,"CAP" :-> conjunct cidConsAP cidBaseAP cidConjAP pAdj

      ,"NP" :-> pflatNP
                   
      ,"PP" :-> do pr     <- write "PP!" >> inside "PR" pPrep
                   write "prep found"
                   np <- pflatNP <+> inside "HD" pNP 
                         <+> cat "PA"  -- this is for deep trees
                   write "prep noun found"
                   returnApp cidPrepNP [pr,np]
      ,"VP" :-> do write "in cat VP"
                   word2 "IM"                
                   v <- pVP "IV"
                   write $ "VP returns " ++ show v
                   return v 

   -- untranslatables
      ,"XX" :-> do n     <- maybeParse pNP    
                   let e = fromMaybe (mkExpr meta) n  
                   write ("xx returns "++show e)
                   return $ mkApp meta [e]
      ,"XP" :-> do write "xp!" 
                   x <- cat "XX"
                   write "xp found noun"
                   a <- pAdv     
                   write "xp found adv "
                   opt (word2 "IP") ""
                   return $ mkApp meta [x,a]

      ,"CNP" :-> conjunct cidConsNP cidBaseNP cidConjNP pflatNP 
      ,"CPP" :-> conjunct cidConsAdv cidBaseAdv cidConjAdv (cat "PP")
      ,"CONJP" :-> conjunct meta meta meta (pflatNP <+> cat "PP" <+> pAdj)
      ,"CVP" :-> conjunct cidConsVPS cidBaseVPS cidConjVPS (cat "VP")
      ,"CS" :-> conjunct cidConsS cidBaseS cidConjS (cat "S")
      ,"CXP" :-> conjunct meta meta meta (cat "XP")  
      --,"NAC" :-> (consume >> return (mkExpr meta))

      -- labels ----
      ,"++" :-> pPConj
      ,"+A" :-> pPredet
      ,"+F" :-> cat "S"
      ,"AA" :-> pAA
      ,"AG" :-> pSpecialPP cidBy8agent_Prep
      ,"AN" :-> pAppos
      ,"AT" :-> pAdj
      ,"CA" :-> pPredet
      ,"DT" :-> pQuant <+> pIQuant <+> pPredet 
                       <+> (fst3 <$> pN2)
      ,"EF" :-> parseRelS
      ,"EO" :-> cat "VP"
      ,"ES" :-> pNP 
      ,"FO" :-> pItPron 
      ,"FS" :-> fst <$> pFS
      ,"FV" :-> msum (map pSlashVP vForms)
      ,"IV" :-> pVP "IV" 
      ,"KA" :-> cat "S"
      ,"MA" :-> inAdv
      ,"MD" :-> cat "NP" <+> cat "PP"
      ,"NA" :-> return (mkExpr cidPNeg)
      ,"OA" :-> cat "PP" <+> cat "VP"
      ,"OO" :-> cat "S"  <+> cat "VP" 
                         <+> pAdj
                         <+> cat "NP"
      ,"PL" :-> pPart "V"  -- could be all sorts of verbs
      ,"PR" :-> pPrep
      ,"RA" :-> inAdv
      ,"SP" :-> do a <- pAdj 
                        <+>
                        pAdA 
                   write ("adj return"++show a)
                   returnApp cidCompAP [a]
                <+>
                do e <- pNP
                   write ("coplua np "++show e)
                   returnApp cidCompNP [e]
                <+>
                do e <- cat "PP"
                   returnApp cidCompAdv [e]
                <+>
                do consume
                   return (mkExpr meta) --we know we are in SP, so ok to consume
      ,"SS" :-> pNP <+> pflatNP <+> cat "NP"
      ,"TA" :-> inAdv
      ,"TT" :-> pNP
      ,"UK" :-> pConj <+> pSubj
      ,"VA" :-> inAdv
      ,"VO" :-> cat "VP"
      ,"VS" :-> cat "VP"
      ,"XA" :-> cat "PP" -- så att säga
      ,"BS" :-> cat "S" 
      ,"CJ" :-> cat "S" <+> cat "PP" <+> cat "VP"   --first conjunct
                        <+> pAdj     <+> pflatNP
      ,"C+" :-> cat "S" <+> cat "PP" <+> cat "VP"   --second conjuct
                        <+> pAdj     <+> pflatNP
      ,"CC" :-> cat "S" <+> cat "PP" <+> cat "VP"   --sister conjuct
                        <+> pAdj     <+> pflatNP
      ,"HD" :-> (pCN >>= \(a,b,c) -> return (mkApp meta [a,mkExpr b]))  <+> pAdj <+> pIAdv <+> pNP
      ,"IF" :-> pVP "IV"  -- for deep trees
      ,"PA" :-> pflatNP <+> pNP  -- for deep trees
                       <+> cat "VP" <+> cat "S" 
                       <+> cat "NP" <+> cat "CNP"
       
    ,"VG" :-> cat "VP"  -- for deep trees

      -- Not translated:
      -- punctuation: I?,"IC","ID","IG","IK","IM", "IO", "IP", "IQ", "IR", "IS", "IT", "IU",
      -- punctuation: , "JC", "JG", "JR", "JT",
      --   ,"ET" :-> cat "PP"
      --   ,"DB"  
      --   ,"MS" :-> cat "S"
      --,"ST"  paragraph
      --,"PT"  cant parse 'sjálv'
      --,"XF" :-> XP
      --,"XT" -- sa kallad
      --,"XX" unclassifiable 
      --,"YY" :-> inside "YY" (lemma "ja,jo"  "") --fix!!
   ] 

cats :: [String] -> Translator Expr 
cats tags = msum [cat c | c <- tags]
objCat :: Translator ()
objCat    = msum [pCompl t | t <- vForms ]

advsCat :: Translator Expr
advsCat = pAdv


(<$>)   = liftM
a <+> b = mplus a b
infixr 2 <+>
infixr 3 <$>

clType :: CId -> CId
clType typ | typ==cidQuestVP = cidUseQCl
           | otherwise       = cidUseCl
utType :: SentenceType -> CId
utType typ | typ==Q          = cidUttQS
           | otherwise       = cidUttS

parseSCl :: Translator Expr
parseSCl = inside "S" pCl

pS :: Translator (Expr,Maybe Expr)
pS = do
  cl <- do cl <- pCl 
           write "found cl"
           utt <- gets S.sentenceType
           return $ mkApp (utType utt) [cl] 
        <+>
        do write "to imperative"
           pImp 
        <+>
        do write "to SS"
           pSS
        <+>
        do cl <- pUttAdv
           return $ mkApp cidUttAdv [cl]
  s2 <- maybeParse $ inside "+F" (optEat (cat "S") (mkExpr meta))
  let cl1   = maybe cl (\x -> mkApp meta [x]) s2 
  return (cl1,s2)


pNPCl :: Translator Expr
pNPCl = do 
 np <- parseSubject
 return $ mkApp cidUttNP [np]

pCl ::  Translator Expr
pCl = questCl <+> questVP <+> normalCl  <+> advCl <+> iadvCl <+> topCl
 where normalCl = do  -- jag äter äpplen
         S.sentenceType =: Dir
         np   <- pSubject
         write "try normalCl, found np"
         vp   <- pVP "FV"
         advs <- many advsCat
         (temp,pol) <- getTmpPol
         nptyp      <- gets S.nptype
         let e0 = foldr (\ad e -> mkApp cidAdvVP [e,ad]) vp advs
             e1 = constructCl nptyp np e0
             e2 = mkApp cidUseCl [temp,pol,e1]
         return e2
       advCl = do  -- nu äter jag äpplen
          S.sentenceType =: Top 
          write "try advCl"
          advs  <- pAdv    
          write "try advCl, found adv"
          write "will do FV"
          vp <- pVSO "FV"          
          np <- gets S.subj
          advs' <- many advsCat
          (temp,pol) <- getTmpPol
          nptyp      <- gets S.nptype
          guard $ isJust np
          let e0 = foldr (\ad e -> mkApp cidAdvVP [e,ad]) vp advs'
              cl = constructCl nptyp (fromJust np) e0
              c  = mkApp cidTopAdv [advs,cl]
              e1 = mkApp cidUseTop [temp, pol, c ]
          return e1
       iadvCl = do -- när äter jag äpplen
          S.sentenceType =: Q
          iadv   <- cats ["RA","TA","AB"]
          write "try iadvCl, found iadv"
          iquant <- gets S.iquant
          guard iquant 
          vp <- pVSO "FV"          
          np <- gets S.subj
          advs  <- many advsCat
          (temp,pol) <- getTmpPol
          nptyp      <- gets S.nptype
          guard $ isJust np
          let e0 = foldr (\ad e -> mkApp cidAdvVP [e,ad]) vp advs
              cl = constructCl nptyp (fromJust np) e0
              c  = mkApp cidQuestIAdv [iadv,cl]
              e1 = mkApp cidUseQCl [temp, pol,c ]
          return e1
       questCl = do  -- vilka äpplen är godast? / vem har du sett?
          S.sentenceType =: Q
          ip  <- inside "SP" parseIP 
          write "try questcl, found ip"
          vp <- pVSO "FV"          
          np <- gets S.subj
          guard $ isJust np
          (temp,pol) <- getTmpPol
          let quest = mkApp cidQuestSlash [ip,mkApp cidSlashVP [fromJust np,vp]]      
          return $ mkApp cidUseQCl [temp,pol,quest]
       questVP = do -- vilka får vara med 
          ip  <- inside "SS" parseIP 
          write "try questvp, found ip"
          vp <- pVP "FV"
          (temp,pol) <- getTmpPol
          let quest = mkApp cidQuestVP [ip,vp]      
          S.sentenceType =: Q
          return $ mkApp cidUseQCl [temp,pol,quest]
       topCl   = do
          S.sentenceType =: Top
          (vp,cop) <- do vp  <- pOVS "FV" Cop    
                         return (vp,True)
                      <+>
                      do vp  <- msum $ map (pOVS "FV") (Cop `delete` vForms)
                         return (vp,False)
          np  <- gets S.subj
          obj <- gets S.object
          (temp,pol) <- getTmpPol
          guard $ isJust obj
          guard $ isJust np
          let top = if cop then cidTopAP else cidTopObj
              cl = mkApp top [fromJust obj,mkApp cidSlashVP [fromJust np,vp]]
              e1 = mkApp (clType cidUseTop) [temp,pol,cl ]
          return e1 


getTmpPol :: Translator (Expr,Expr)
getTmpPol = do
  tmp <- gets S.tmp
  pol <- gets S.pol
  ant <- gets S.anter
  let temp  = maybe (mkExpr meta) (mkTmp ant) (isVTense tmp)
  return (temp,mkPol pol)
  
         

parseIP :: Translator Expr
parseIP = do p <- inside "PO" (lemma "IP" "s NPNom"
                               <+>
                               lemma "IP" "s NPAcc" )
             return (mkExpr p)

pSS :: Translator Expr
pSS =  
  do s1   <- cat "S"    -- jag går om hon kommer
     s2   <- cat "S"
     conj <- gets S.subj
     let sub = fromMaybe (mkExpr meta) conj
     return $ mkApp cidSSubjS [s1,sub,s2] 

pSubject :: Translator Expr
pSubject = cat "SS" <+> cat "FV"

pObj :: Translator ()
pObj    =  msum $ map pCompl vForms
pObject :: Translator ()
pObject = do    --a plain object
  obj <- inside "OO" (word "POXPHH" >> return (Just $ mkExpr meta))
         <+>
         do write "look for np in oo"
            liftM Just (inside "OO" pNP)
         <+>
         do write "look for np in sp"
            liftM Just (inside "SP" pNP)
         <+>
         do o <- inside "OA" (cat "PP") 
            return (Just $ mkApp meta [o]) 
         <+>  
         do det <- inside "FO" pItPron     -- funnit det attraktivt att (VP)
            a   <- pAdj
            vp  <- inside "EO" $ cat "VP" 
            return (Just $ mkApp meta [det,mkApp meta [a,vp]])
         <+>  
         do inside "IO" $ word "POXPHH"  
            return (Just $ mkExpr cidReflIdPron) -- sig
         <+>
         liftM Just (inside "ES" pNP)
  S.object =: obj


pImp :: Translator Expr
pImp = do write "in imperative"
          vp <- pVP "FV"
          write "found vp in imp"
          tmp  <- gets S.tmp
          pol  <- gets S.pol
          guard (tmp==Just VImp)
          write "vp in imp is ok"
          advs <- many pAdv
          write ("advs found: "++show advs)
          let e0 = foldr (\ad e -> mkApp cidAdvVP [e,ad]) vp advs
              imp = mkApp cidImpVP [e0] 
          return $ mkApp cidUttImpPol [mkPol pol,imp]

-- "att det inte regnar"
pUttAdv :: Translator Expr
pUttAdv = do 
 sub <- inside "UK" pSubj 
 np  <- cat "SS" <+> cat "FS" 
 typ <- gets S.nptype
 write ("SS done for UttAdv"++show np)
 write "now to pVP"
 pol <- pPol
 v   <- parseFV
 objCat
 advs <- many pAdv
 tmp  <- gets S.tmp
 ant <- gets S.anter
 vp   <- constructVP v
 let e0 = foldr (\ad e -> mkApp cidAdvVP [e,ad]) vp advs
     e1 = constructCl typ np e0
     e2 = mkApp cidUseCl [maybe (mkExpr meta) (mkTmp ant) (isVTense tmp)
                         ,mkPol pol,e1]
 return $ mkApp cidSubjS [sub,e2]

parseFV :: Translator Expr
parseFV = do
   write "In parseFV"
   write "checked word in parseFV"
   v   <- cat "FV"
   p   <- maybeParticle "FV"
   write "FV checks tmp "
   return v

parseRelS :: Translator Expr
parseRelS = do 
  old <- putStateToZero
  rcl <- pRelS
  resetState old
  return rcl


pRelS :: Translator Expr
pRelS = do
  w <- inside "S" $ inside "SS" $ word "PO" 
  guard (w =="Som" || w == "som")
  parseTheVP <+> parseTheCl
 where parseTheVP = do
         pol <- pPol
         v   <- parseFV
         pObj  
         vp <- constructVP v
         mkRelCl pol $ mkApp cidRelVP [mkExpr cidIdRP,vp]
       parseTheCl = do
         S.object =: Just (mkExpr meta)  -- to indicate that there already is an object (outside
                                         -- of the relative clause) 'pojken som jag ser'
         np  <- pSubject
         pol <- pPol 
         v   <- parseFV
         pObj
         vp <- constructVP v
         mkRelCl pol $ mkApp cidRelSlash [mkExpr cidIdRP,mkApp cidSlashVP [np,vp]]

       mkRelCl pol cl = do
         tmp  <- gets S.tmp
         ant  <- gets S.anter
         let t     = maybe (mkExpr meta) (mkTmp ant) (isVTense tmp)
         return (mkApp cidUseRCl [t,mkPol pol,cl])



constructCl :: NPType -> Expr -> Expr -> Expr
constructCl typ np vp = 
  if typ == Generic || typ == Impers
     then mkApp (toCid typ) [vp]
     else mkApp cidPredVP [np,vp]
 where toCid Generic = cidGenericCl
       toCid Impers  = cidImpersCl
       toCid _       = meta

pSpecialPP :: CId -> Translator Expr
pSpecialPP cid = 
 do pr <- inside "PR" $ optEat (lemma "Prep" "s") meta


    write "prep found"
    guard (pr==cid)
    np     <- pflatNP
    return $ mkApp cidPrepNP [mkExpr pr,np]

isVSupin :: VForm CId -> Bool
isVSupin VSupin = True
isVSupin _      = False

isVTense :: Maybe (VForm CId) -> Maybe CId 
isVTense (Just (VTense t)) = Just t
isVTense _                 = Nothing

isVTenseForm :: CId -> VForm CId -> Bool
isVTenseForm a (VTense t) = t == a 
isVTenseForm _ _          = False


vForms :: [VPForm]
vForms =  [Cop,Sup,Fut,FutKommer,VV,VA,V2A,V2,V2Pass,VS,V]
gfvForms :: [String]
gfvForms =  ["VV","VA","V2A","V2","VS","V","V3"]

pSlashVP :: VPForm ->  Translator Expr
pSlashVP form = do
 write "in pSlashVP"
 (t,v,f) <- case form of 
                  V ->  do (t,v) <- pVerb "VV" "V"
                           write "found a pVerb of type V"
                           return (t,mkExpr v,V)
                  VV -> third VV <$> pVV
                  V2 -> third V2 <$> pV2Act
                  V2A -> do (t,v) <- pVerb "VV" "V2A"
                            return (t,mkExpr v,V2A)
                  Cop -> do t <- pCopula 
                            return (t,mkExpr meta,Cop)
                  Sup -> do t <- pHave
                            return (t,mkExpr meta,Sup)
                  VA  -> do third VA <$> pVA
                  Fut -> do t <- pFuturum
                            write "found future form"
                            return (t,mkExpr meta,Fut)
                  VS  -> do (t,v) <- pVerb "VV" "VS"
                            return (t,mkExpr v,VS)
                  V2Pass    -> third V2Pass <$> (inside "VV" pExist
                                            <+> pV2Pass)
                  FutKommer -> do t <- pFuturumKommer
                                  return (t,mkExpr meta,FutKommer)
 S.tmp   =: Just t
 S.anter =: (f==Sup)
 modify S.vform  (V:)
 return v

mkTmp :: Bool -> CId -> Expr
mkTmp False = mkTmp' cidASimul 
mkTmp True  = mkTmp' cidAAnter 

mkTmp' :: CId -> CId -> Expr
mkTmp' a t | a ==cidASimul = mkApp cidTTAnt [mkExpr t,mkExpr cidASimul] 
           | a ==cidAAnter = mkApp cidTTAnt [mkExpr t,mkExpr cidAAnter] 

pVP :: String -> Translator Expr
pVP typ = do
   write $ "doing pVP "++show typ
   msum [do v <- inside typ (pSlashVP x)
            write $ "found IV "++show v
            S.sentenceType =: Dir
            localKeepPol (do
                    pCompl x 
                    write $ "pVP have succeeded to parse for typ "++show x
                    constructVP v)
        | x <- vForms]


pVSO :: String -> Translator Expr
pVSO cat = msum $ map (pVSOCat cat) vForms

pVSOCat :: String -> VPForm -> Translator Expr
pVSOCat cat typ = do
  v  <- inside cat $ pSlashVP typ 
  np <- write "looking for SS" >> parseSubject
  write ("pVSO found np "++show np)
  S.subj =: Just np 
  localKeepPol (pCompl typ >> constructVP v)

pOVS :: String -> VPForm -> Translator Expr
pOVS cat Cop = do
  write "try OVS copula"
  pObject  --huset
  write "found compl in OVS Cop" 
  v <- inside cat $ pSlashVP Cop
  advs <- many pAdv    
  np <- write "looking for SS" >> parseSubject
  write ("pOVS found np "++show np)
  advs1 <- many pAdv    
  let np1 = foldr (\ad e -> mkApp cidAdvNP [ad, e]) np (advs++advs1)
  S.subj =: Just np1
  S.sentenceType =: Top 
  constructVP v
  return v

pOVS cat typ = do --huset målar han rött
  write "try OVS"
  pObject                                      --huset
  v  <- inside cat $ pSlashVP typ              --målar
  write $ "found compl in OVS "++show typ
  np <- write "looking for SS" >> parseSubject --han
  write ("pOVS found np "++show np)
  S.subj =: Just np 
  S.sentenceType =: Top 
  localKeepPol (do pCompl typ                  --rött
                   constructVP v)
  return v


pInfVP :: Translator (Bool,Expr)
pInfVP = 
  do write "att v?"
     im <- opt (word2 "IM" >> return True) False
     write $ "infinite marker? "++ show im
     v  <- pVP "IV" <+> inside "IF" (pVP "IV")
     return (im,v)
 
constructVP :: Expr -> Translator Expr
constructVP v = do
   (vtyp,exps,bs) <- gets S.complement
   o     <- gets S.object
   styp  <- gets S.sentenceType
   advs1 <- many pAdv  
   write $ "in constructVP, will combine for " ++ show vtyp
   vp <- pComplVP vtyp styp v (exps,bs)
   write $ "in constructVP, have combined for " ++ show vtyp
   return $ foldr (\ad e -> mkApp cidAdvVP [ad, e]) vp advs1
 
pComplVP :: VPForm -> SentenceType -> Expr -> ([Maybe Expr],[Bool]) 
         -> Translator Expr
pComplVP V q vp (exps,_) = do 
  comp <- getComplement V q exps 
  (fo,adv,part,adv1) <-  case comp of
                         (fo:a:p:a1:_) -> return (fo,a,p,a1)
                         _             -> argErr "V"
  let vp0  = fromMaybe vp part 
      vp1  = mkApp cidUseV [vp0]
      vp2  = maybe vp1 (\a -> mkApp cidAdvVP [vp1,a]) adv 
      vp3  = maybe vp2 (\a -> mkApp cidAdvVP [vp2,a]) adv1
  write ("particle "++show part++" verb "++show vp)
  return $ maybe vp3 (\fob -> mkApp meta [vp3,fob]) fo

pComplVP VA q vp (exps,_) = do 
  comp <- getComplement VA q exps
  (fo,adv,a) <-  case comp of
                  (fo:a:Just aj:_) -> return (fo,a,aj)
                  _                -> argErr "VA"
  let vp1  = maybe vp (\a -> mkApp cidAdvVPSlash [vp,a]) adv 
      vp2  = if q==Dir then mkApp cidComplVA   [vp1,a]
                     else vp1
  when (q/=Dir) $ S.object =: Just a
  return $ maybe vp2 (\fob -> mkApp meta [vp2,fob]) fo

pComplVP VV q vp (exps,bs) = do
  comp <- getComplement VV q exps
  (fo,adv,iv,p) <-  case comp of
                  (fo:a:Just i:p':_) -> return (fo,a,i,p')
                  _                  -> argErr "VV"
  let vv0 = if bs==[True] then mkApp cidDropAttVV [vp] else vp
      vv1 = fromMaybe vv0 p 
      vv2  = maybe vv1 (\a -> mkApp cidAdvVP [vv1,a]) adv 
      vv3 = if q==Dir then mkApp cidComplVV [vv2,iv] else vv2
  when (q/=Dir) $ S.object =: Just iv 
  return $ maybe vv3 (\fob -> mkApp meta [vv3,fob]) fo

pComplVP V2 q vp (exps,_) = do
  comp <- getComplement V2 q exps
  (fo,adv,obj,part) <-  case comp of
                  (fo:a:o:p:[]) -> return (fo,a,o,p) 
                  _             -> argErr "V2"
  let combineVP =
          let vp0 = mkApp cidComplSlash [vp,fromJust obj]
          in  maybe vp0 (\a -> mkApp cidAdvVP [vp0,a]) adv 
      slashedVP = maybe vp (\a -> mkApp cidAdvVPSlash [vp,a]) adv 
      vp1 = if q/=Dir || isNothing obj then slashedVP else combineVP 
  return $ maybe vp1 (\fob -> mkApp meta [vp1,fob]) fo

pComplVP V2A q vp (exps,_) = do
  comp <- getComplement V2A q exps
  (fo,adv,obj,adj) <-  case comp of  
                  (fo:a:o:Just aj:p:_) -> return (fo,a,o,aj)
                  _                    -> argErr "V2A"
  let slashVP = mkApp cidSlashV2A [vp,adj]
  case obj of
    Just o  -> do
               let vp0 = maybe slashVP (\a -> mkApp cidAdvVPSlash [slashVP,a]) adv  
                   vp1 = mkApp cidComplSlash [vp0,o]
               return $ maybe vp1 (\fob -> mkApp meta [vp1,fob]) fo
    Nothing -> do let vp1 = maybe slashVP (\a -> mkApp cidAdvVPSlash [vp,a]) adv  
                  return $ maybe vp1 (\fob -> mkApp meta [vp1,fob]) fo

pComplVP V2Pass q vp (exps,_) = do
  comp <- getComplement V2Pass q exps
  (fo,adv1,agent,eo,adv2) <-  case comp of
                  (fo:a:g:e:a2:p_) -> return (fo,a,g,e,a2)
 
                  _               -> argErr "V2Pass"
  let vp' = foldr (\a vp -> mkApp cidAdvVP [vp,a]) vp 
                               $ catMaybes [adv1,agent,adv2]
      vp3 = maybe vp' (\a -> mkApp meta [a]) eo 
  return $ maybe vp3 (\fob -> mkApp meta [vp3,fob]) fo

pComplVP Sup q vp (exps,bs) = do
  comp <- getComplement Sup q exps
  (fo,adv,sup) <-  case comp of
                    (fo:a:Just s:_) -> return (fo,a,s)
                    _            -> argErr "Sup"
  pass <- gets S.passive
  let 
      vp1  = maybe sup (\a -> mkApp cidAdvVPSlash [sup,a]) adv 
      useV = if bs == [True] || not pass then cidUseV else cidPassV2
  S.anter =: True  
  S.passive =: False
  let vp2 = mkApp useV [vp1]
  return $ maybe vp2 (\fob -> mkApp meta [vp2,fob]) fo

pComplVP Cop q vp (exps,_) = do
  comp <- getComplement Cop q exps
  (adv,sp) <-  case comp of
                  (a:s:_) -> return (a,s)
                  _            -> argErr "Cop"
  write ("copula sp "++ show sp)
  case sp of
       Just o  -> do
           let cop = mkApp cidUseComp [o]
               vp1  = maybe cop (\a -> mkApp cidAdvVPSlash [cop,a]) adv 
           return vp1
       Nothing -> return $
                   maybe (mkApp meta []) (\a -> mkApp meta [a]) adv 

pComplVP Fut q vp (exps,_) = do
  comp <- getComplement Fut q exps
  (fo,adv,v) <-  case comp of
                  (fo:a:Just s:_) -> return (fo,a,s)
                  _               -> argErr "Fut"
  let vp1  = maybe v (\a -> mkApp cidAdvVPSlash [v,a]) adv 
  write ("fut compl: "++show vp1)
  return $ maybe vp1 (\fob -> mkApp meta [vp1,fob]) fo

pComplVP FutKommer q vp (exps,_) = do
  comp <- getComplement FutKommer q exps
  (fo,adv,vp0) <-  case comp of
                  (fo:a:Just s:_) -> return (fo,a,s)
                  _               -> argErr "FutKommer"
  let vp1  = maybe vp0 (\a -> mkApp cidAdvVPSlash [vp0,a]) adv 
  return $ maybe vp1 (\fob -> mkApp meta [vp1,fob]) fo
 
pComplVP VS q vp (exps,_) = do
  comp <- getComplement VS q exps
  (fo,adv,s) <-  case comp of
                  (fo:a:Just s:_) -> return (fo,a,s)
                  _               -> argErr "VS"
  let vp0 = if q==Dir then mkApp cidComplVS [vp,s] 
                      else vp
      vp1 = maybe vp0 (\a -> mkApp cidAdvVP [vp1,a]) adv
  when (q/=Dir) $ S.object =: Just s
  return $ maybe vp1 (\fob -> mkApp meta [vp1,fob]) fo

getComplement :: VPForm -> SentenceType -> [Maybe Expr] -> Translator [Maybe Expr]
getComplement v q exps = return exps

argErr :: String -> Translator a
argErr s = do
  write ("wrong number of arguments to pCompl "++ s)
  mzero

pPart :: String -> Translator Expr
pPart v = do
  p <- do write "part right!!"
          inside "AB" (lemma v "part")
       <+>
       do write "part" 
          inside "PR" (lemma v "part") 
  return (mkExpr p)


pVV :: Translator (VForm CId,Expr)
pVV = do
  (t,v) <- tryVerb "FV" cidGet_VV "VV"  
           <+>
           tryVerb "WV" cidWant_VV "VV"
           <+>
           do write "looking for can"
              tryVerb "QV" cidCan_VV "VV"
           <+>
           tryVerb "MV" cidMust_VV "VV"
           <+>
           pVerb "VV" "VV"
  write ("VV returns tense "++show t)
  return (t,mkExpr v)

pVA :: Translator (VForm CId,Expr)
pVA = do
  (t,v) <- tryVerb "BV" cidBecome_VA "VA"
           <+>
           pVerb "FV" "VA" 
  write ("VA returs tense "++show t)
  return (t,mkExpr v)


pV2Act :: Translator (VForm CId,Expr)
pV2Act = do 
  (t,v) <- do t <- pHave
              return (t,mkExpr cidHave_V2)  
           <+>
           do (t,v) <- do write "in pV2"
                          pVerb "VV" "V2"
                       <+>                   
                       do write "får är i farten"
                          tryVerb "FV" cidGet_V2 "V2"
                       <+>
                       tryVerb "GV" cidDo_V2 "V2"
                       <+>
                       tryVerb "GV" cidDo_VV "VV"
                       <+>
                       tryVerb "BV" cidBecome_V2 "V2"
              return (t,mkExpr v)
  return (t,mkApp cidSlashV2a [v]) 

pV2Pass :: Translator (VForm CId,Expr)
pV2Pass = do
  (t,v) <- pPassVerb "VV" "V2"
           <+>
           tryVerb "GV" cidDo_V2 "V2"
           <+>
           tryVerb "FV" cidGet_V2 "V2"
  return (t,mkApp cidPassV2 [mkExpr v])

pExist :: Translator (VForm CId,Expr)
pExist =
    do lemma "NP -> Cl" "s SPres Simul Pos Main"
       return (VTense cidTPres,mkExpr cidExistNP)
    <+>
    do lemma "NP -> Cl" "s SPret Simul Pos Main"
       return (VTense cidTPast,mkExpr cidExistNP)
    <+>
    do lemma "NP -> Cl" "s SPres Anter Pos Main"
        <+>
        lemma "NP -> Cl" "s SPret Anter Pos Main"
       return (VSupin,mkExpr cidExistNP)

tryVerb :: String -> CId -> String -> Translator (VForm CId,CId)
tryVerb tag cid cat =
 do t <- tense tag
    write ("tryVerb "++tag) 
    return (t,cid) 
 <+>
  do write "no tense found"
     pVerb tag cat

pVerb :: String -> String -> Translator (VForm CId, CId)
pVerb x y = write ("in pVerb "++x++" "++y) >> pVerb' "Act" x y

pPassVerb :: String -> String -> Translator (VForm CId, CId)
pPassVerb = pVerb' "Pass"

pVerb' :: String -> String -> String -> Translator (VForm CId, CId)
pVerb' act incat cat =
        do v <- (inside incat $ lemma cat $ "s (VF (VPres "++act++"))")
                <+>
                (inside incat $ lemma "V" $ "s (VF (VPres "++act++"))")
           return (VTense cidTPres,v)
        <+>
        do v <- (inside incat $ lemma cat $ "s (VF (VImper "++ act++"))")
                <+>
                (inside incat $ lemma "V" $ "s (VF (VImper "++ act++"))")
           return (VImp,v)
        <+>
        do v <- (inside incat $ lemma cat $ "s (VI (VInfin "++ act++"))")
                <+>
                (inside incat $ lemma "V" $ "s (VI (VInfin "++ act++"))")
           return (VInf,v)
        <+>
        do v <- (inside incat $ lemma cat $ "s (VF (VPret "++ act++"))")
                <+>
                (inside incat $ lemma "V" $ "s (VF (VPret "++ act++"))")
           return (VTense cidTPast,v)
        <+>
        do v <- (inside incat $ lemma cat $ "s (VI (VSupin "++ act++"))")
                <+>
                (inside incat $ lemma "V" $ "s (VI (VSupin "++ act++"))")
           return (VSupin,v)
        
maybeVerbAdv :: Translator (Maybe Expr)
maybeVerbAdv  = maybeParse pAdv  

maybeParticle :: String -> Translator (Maybe Expr)
maybeParticle = maybeParse . inside "PL" . pPart 

metaVerb :: (VForm a,CId)
metaVerb   = (VInf,meta)

pCompl :: VPForm -> Translator ()
pCompl Cop = do
  write "copula compl begins"
  pol <- pPol
  adv <- maybeParse $ pAdvMinus ["RA"]
  write $ "copula found adv"++show adv
  sp <- hasMovedObj
        <+>
        Just <$> cat "SP"
        <+>
        do write "copula looking for adv2"
           a <- pAdv
           write "copula found adv2"
           return $ Just $ mkApp cidCompAdv [a]
  S.complement =: (Cop,[adv,sp],[])
  S.pol        =: pol

pCompl Sup = do
  write "supinum compl begins"
  fo  <- maybeParse $ cat "FO"
  pol <- pPol
  adv <- maybeVerbAdv
  (t',sup,useV) <- inside "IV" $  
                    do (t,s) <- msum [pVerb "TP" v | v <- gfvForms] 
                                <+>
                                inside "TP" (consume >> return (VSupin,meta))
                                <+>
                                msum [pVerb "VVSN" v | v <- gfvForms] 
                       return (t,s,True) 
              <+>         
               do (t,s) <- msum [pPassVerb "VVSN" v | v <- gfvForms] 
                  return (t,s,False) 
  guard (isVSupin t') 
  S.passive    =: not useV
  S.pol        =: pol
  S.complement =: (Sup,[fo,adv,Just $ mkExpr sup],[useV])

pCompl V2 = do
  write "v2 compl begins"
  (pol,fo,adv,part) <- pV2Compl
  obj <- hasMovedObj 
         <+>
         inside "OO" (word "POXPHH" >> return (Just $ mkExpr meta))
         <+>
         do write "look for np in oo"
            liftM Just (inside "OO" pNP)
         <+>
         do write "look for np in sp"
            liftM Just (inside "SP" pNP)
         <+>
         do o <- inside "OA" (cat "PP") 
            return (Just $ mkApp meta [o])
         <+>  
         do det <- inside "FO" pItPron   
            a   <- pAdj
            vp  <- inside "EO" $ cat "VP" 
            return (Just $ mkApp meta [det,mkApp meta [a,vp]]) 
         <+>  
         do inside "IO" $ word "POXPHH"  
            return Nothing -- sig
         <+>
         liftM Just (inside "ES" pNP)
  write "oo ok"
  S.pol       =: pol
  S.complement =: (V2,[fo,adv,obj,part],[])

pCompl V2A = do
  write "v2a compl begins"
  (pol,fo,adv,part) <- pV2Compl
  obj <-  hasMovedObj
         <+>
          do inside "OO" $ word "POXPHH"  
             return Nothing -- sig
         <+>
          liftM Just (inside "OO" pNP)
         <+>
          liftM Just (inside "SP" pNP)
         <+>
          do o <- inside "OA" (cat "PP" <+> cat "VP")  
             return (Just $ mkApp meta [o])
         <+>  
          do inside "IO" $ word "POXPHH"  
             return Nothing -- sig
  adj <- inside "OO" pAdj
  write "oo ok"
  S.pol       =: pol
  S.complement =: (V2A,[fo,adv,obj,Just adj,part],[])

pCompl V2Pass = do
  write "v2pass compl begins"
  fo   <- maybeParse $ cat "FO"
  pol  <- pPol
  adv1 <- maybeVerbAdv
  eo   <- maybeParse $ cat "ES" 
  part <- maybeParticle "V2"   
  write ("particle: "++show part)
  ag   <- maybeParse $  inside "AG" $ pSpecialPP cidBy8agent_Prep
  adv2 <- maybeVerbAdv
  write "agent ok"
  S.pol       =: pol
  S.complement =: (V2Pass,[fo,adv1,ag,eo,adv2,part],[])

pCompl VV = do
  write "vv compl begins"
  (pol,fo,adv,part) <- pV2Compl 
  (im,iv)  <-  do write "look for infinite verb"
                  (im,v) <- inside "OO" (inside "VP" pInfVP)
                            <+>
                            (write "inf2" >> pInfVP)
                  return (im,v) 
             <+>
               do write "looking for weird verb phrase complement for vv"
                  iv <- inside "OO" (inside "NAC" $ pVP "IV")
                  return (False,iv) 
             <+>
               do write "looking for complete verb phrase complement for vv"
                  v <- inside "OA" $ cat "VP"
                  return (True,v)  
             <+>
               do write "looking for VV in VP"
                  v <- inside "VG" $ cat "VP" 
                  return (True,v) 
  write ("iv found "++show iv)
  write "iv ok"
  p <- maybeParticle "VV"
  write ("particle: "++show p)
  S.pol        =: pol
  S.complement =: (VV,[fo,adv,Just iv,p],[im])

pCompl VA = do
  write "va compl begins"
  fo    <- maybeParse $ cat "FO"
  pol   <- pPol
  adv   <- maybeVerbAdv
  a     <- inside "SP" (pAdj <+> cat "CNP")
  S.pol        =: pol
  S.complement =: (VA,[fo,adv,Just a],[])

pCompl V = do
  write "v-simple compl begins"
  pol <- pPol
  fo  <- maybeParse $ cat "FO"
  adv <- maybeVerbAdv
  p   <- maybeParticle "V"
  write ("particle: "++show p)
  adv1  <- maybeParse $ inside "OA" $ cat "PP"
  S.pol        =: pol
  S.complement =: (V,[fo,adv,p,adv1],[])

pCompl Fut = do
  write "futurum compl begins"
  fo  <- maybeParse $ cat "FO"
  pol <- pPol
  adv <- maybeVerbAdv
  iv <- pVP "IV" 
  write ("comlpfut "++show iv)
  S.pol        =: pol
  S.complement =: (Fut,[fo,adv,Just iv],[])

pCompl FutKommer = do
  write "futurum compl begins 'komma att'"
  fo  <- maybeParse $ cat "FO"
  pol <- pPol
  word2 "IM"
  adv <- maybeVerbAdv
  iv <- pVP "IV" 
  S.pol        =: pol
  S.complement =: (FutKommer,[fo,adv,Just iv],[])

pCompl VS = do
  write "VS compl "
  (pol,fo,adv,part) <- pV2Compl  
  adv  <- maybeVerbAdv
  s    <- inside "OO" $ cat "S" 
  write "s in vs ok"
  S.pol        =: pol 
  S.complement =: (VS,[fo,adv,Just s],[])

hasMovedObj :: Translator (Maybe a)
hasMovedObj = do
  moved <- isJust <$> gets S.object
  guard moved
  return Nothing 

pV2Compl :: Translator (Maybe Bool,Maybe Expr,Maybe Expr,Maybe Expr)
pV2Compl = do
  fo <- maybeParse $ cat "FO" 
  pol <- pPol
  write "oo pol ok"
  adv <- maybeVerbAdv
  part <- maybeParticle "V2"
  write ("particle: "++show part)
  return (pol,fo,adv,part)

maybeParse :: Translator a -> Translator (Maybe a)
maybeParse = flip opt Nothing . (Just <$>)  

pflatNP :: Translator Expr
pflatNP =
  do write "in NP with Adj"
     typ <- gets S.sentenceType
     m_predet     <- maybeParse $ inside "+A" pPredet
                                  <+>
                                  inside "CA" pPredet
                                  <+>
                                  inside "DT" pPredet
     m_det        <- if typ==Q then S.iquant =: True >> Just <$> inside "DT" pIQuant
                               else  maybeParse (inside "DT" pQuant)
                                    <+>
                                     maybeParse (inside "DT" pDetRefl)
     m_n2         <- maybeParse $ inside "DT" pN2 -- 'antal'
     m_a          <- maybeParse $ inside "AT" pAdj
     (noun,n,def) <- inside "HD" pCN
     m_pt         <- maybeParse $ inside "PT" consume  --'själv'
     et           <- many $ inside "ET" $ cat "PP"
     m_app        <- maybeParse $ inside "AN" pAppos
     m_relCl      <- maybeParse $ do opt (word2 "IK") ""
                                     inside "EF" parseRelS
     write "start putting together np"
     opt (word2 "IP") ""
     t <- gets S.sentenceType
     let 
         cn0 = maybe noun (\x -> mkApp meta [noun,mkExpr meta]) m_pt  -- kvinnan själv'
         cn1 = case m_a of
                   Just a  -> mkApp cidAdjCN [a,mkApp cidUseN [cn0]]
                   Nothing -> mkApp cidUseN [cn0]
         cn2 = maybe cn1 (\rs -> mkApp cidRelCN [cn1,rs]) m_relCl 

         num = mkExpr n
         d   = fromMaybe (mkApp (getCId t cidDetQuant) [mkExpr cidDefArt,num]) m_det
         cn3 = maybe cn2 (\app -> mkApp cidApposCN [cn2,app]) m_app
     np0 <- case (def,m_det) of
                (NDef,_)         -> returnApp cidDetCN [d 
                                             ,cn3]
                (NIndef,Nothing) -> if n == cidNumSg 
                            then returnApp cidMassNP [cn3]
                            else returnApp cidDetCN 
                                            [mkApp cidDetQuant 
                                            [mkExpr cidIndefArt,num],cn3]
                (NIndef,Just d)  -> returnApp cidDetCN [d,cn3]
                (NOther,_)       -> do guard (isNothing m_predet && isNothing m_det) 
                                       return noun 
     t <- gets S.sentenceType
     let np' = maybe np0 (\(n2,num,def) -> mkApp (getCId t cidDetCN)
                                                          [mkApp cidDetQuant [def,num]
                                                          ,mkApp cidComplN2 [n2,np0]]) m_n2
         np1 = maybe np' (\p -> mkApp (getCId t cidPredetNP) [p,np']) m_predet
         res = foldr (\e n -> mkApp (getCId t cidAdvNP) [n,e]) np1 et 
     write $ "will return np" ++ show res
     return res
  <+>
  do (noun,n,def) <- inside "HD" pCN
     guard $ def == NIndef && n == cidNumSg  
     num <- pNumber
     returnApp cidCNNumNP [mkApp cidUseN [noun],num]
  <+>
  do w1 <- inside "AA" $ word "ABFA"
     w2 <- inside "HD" $ word "POZP"
     guard (map toLower w1 == "hur" && map toLower w2 == "mycket")
     S.iquant =: True
     returnApp cidhow8much_IAdv []
                 

-- returns (word :: Expr, number :: CId, determined :: NounForm)
pCN :: Translator (Expr,CId,NForm)
pCN = 
     inside "VN" pNoun
     <+>
     do n <- inside "NN" (optEat pNoun metaNoun)  
        write ("pCN gives NN "++show n) >> return n
     <+>
     inside "AN" pNoun
     <+>
     do w <- inside "POCP" consume  -- varandra, reciprokt! ej i GF
        return (mkExpr meta,cidNumPl,NOther)
     <+>
     do write "test for particip"
        (part,num,def) <- inside "SP" findNParticip
        return (part,num,def)
     <+>
     do write "test for category X"
        w <- inside "PO" (lemma "PronAQ" "s (AF (APosit (Strong GPl)) Nom)")
        return (mkApp cidQuantPronAQ [mkExpr w],cidNumPl,NIndef)
     <+>
     do word "NNDD"
        return (mkExpr meta,cidNumSg,NDef)  --may be plural...
     <+>
     do write "testing last pCN"
        word "NN"
        return (mkExpr meta,cidNumSg,NIndef)
 
 
pNoun,pNounGen :: Translator (Expr,CId,NForm)
pNoun    = pNoun' "Nom"
pNounGen = pNoun' "Gen"

pNoun' :: String -> Translator (Expr,CId,NForm)
pNoun' nom = 
  do      n <- lemma "N" ("s Pl Indef "++nom)
          return (mkExpr n,cidNumPl,NIndef)
  <+> do
          n <- lemma "N" ("s Sg Indef "++nom)
          return (mkExpr n,cidNumSg,NIndef)
  <+> do
          n <- lemma "N" ("s Sg Def "++nom)
          return (mkExpr n,cidNumSg,NDef)
  <+> do
          n <- lemma "N" ("s Pl Def "++ nom)
          return (mkExpr n,cidNumPl,NDef)


metaNoun :: (Expr, CId, NForm)
metaNoun = (mkExpr meta,cidNumSg,NIndef)
data NForm = NDef | NIndef | NOther -- NOther for reciprocs etc 
  deriving (Eq,Show)

getDef :: NForm -> CId
getDef NDef = cidDefArt
getDef NIndef = cidIndefArt
getDef NOther = meta


parseSubject :: Translator Expr
parseSubject = inside "SS" (optEat pNP (mkExpr meta)) 
               <+> 
               do (n,typ) <- inside "FS" pFS
                  S.nptype =: typ
                  return n
              
pFS :: Translator (Expr,NPType)
pFS =
     do w <- inside "PO" $ lemma "VP -> Cl" "s SPres Simul Pos Main"
        write "imperson hittad!!"
        return (mkExpr w,Impers)
     <+>
     do w <- inside "PO" $ lemma "NP -> Cl" "s SPres Simul Pos Inv"
        return (mkExpr w,Exist)

pItPron :: Translator Expr
pItPron = 
 do p <- inside "POOP" $ lemma "Pron" "s Per3 NPNom"
    return $ mkExpr p
 
pPN :: Translator Expr
pPN = do n <- inside "PN" $ optEat (lemma "PN" "s Nom") cidName
         return $ mkExpr n
pNP :: Translator Expr
pNP = 
  cat "NP" 
  <+> 
  (S.sentenceType =: Dir >> cat "AP")  
  <+> 
   do write "look for name"
      name <- pPN
      S.sentenceType =: Dir
      return (mkApp cidUsePN [name])
   <+>
   do w <- inside "POTP" $ lemma "NP" "s Per3 NPNom"
      S.sentenceType =: Dir
      return (mkExpr w)
   <+>
   do
      w   <- inside "PO" $ lemma "Pron" "s Per3 NPNom" 
      write "lemma ok"
      S.sentenceType =: Dir
      return (mkApp cidUsePron [mkExpr w])
   <+>
   do w <- inside "PO" $ lemma "VP -> Cl" "s SPres Simul Pos Main"
      write "Man hittad!!"
      S.nptype         =: Generic
      S.sentenceType   =: Dir
      return (mkExpr w)
   <+>
   do det <- pQuant
      S.sentenceType =: Dir
      return (mkApp cidDetNP [det])

   <+>
   do np <- pflatNP
      S.sentenceType =: Dir
      return np
   <+>
   do write "in complicated np"
      (n,num,def) <- pCN 
      let cn   = mkApp cidUseN [n]
          nums = mkExpr num
      t <- gets S.sentenceType
      e0 <- case def of
                 NDef -> returnApp cidDetCN 
                                   [mkApp (getCId t cidDetQuant)
                                   [mkExpr cidDefArt, nums],cn]
                 NIndef -> if num==cidNumPl then return cn
                                            else return (mkApp cidMassNP [cn])
                 NOther -> return n  -- och guards!!
      S.sentenceType =: Dir
      return e0
  
pAdj :: Translator Expr
pAdj = 
  do ad <- inside "AJKP" $ optEat (lemma "A" "s (AF ACompar Nom)") meta
     return $ mkApp cidUseComparA [mkExpr ad] 
  <+>
  do ad <- findAdj
     return $ mkApp cidPositA [ad]
  <+>
  do ad <- findA2
     return $ mkApp cidUseA2 [ad]
  <+>
  do write "will check AP"
     cat "AP"
  <+>
  cat "CAP" 
  <+>
  -- this can only be used as Comp
  do a <- inside "PO" $ lemma "PronAQ" "s (AF (APosit (Strong GPl)) Nom)"
     return $ mkApp cidCompPronAQ [mkExpr a]
  <+>
  do a <- inside "TP" $ optEat findAPerfParticip meta
     return (mkApp cidVPSlashAP  [mkExpr a]) 
  
findAdj :: Translator Expr
findAdj = 
  do ad <- inside "AJ" (optEat findA meta)
           <+>
           do write "looking for particip adjective"
              inside "SP" findA
     return $ mkExpr ad
 where findA =         lemma "A" adjSN 
               <+> lemma "A" adjSU
               <+> lemma "A" adjWSg
               <+> lemma "A" adjWPl


findA2 :: Translator Expr
findA2 = 
  do ad <- inside "AJ" (lemma "A2" "s (AF (APosit (Strong (GSg Neutr))) Nom)")
           <+>
           inside "AJ" (lemma "A2" "s (AF (APosit (Strong (GSg Utr))) Nom)")
           <+>
           inside "AJ" (lemma "A2" "s (AF (APosit (Strong GPl)) Nom)")
     return $ mkExpr ad


findNParticip :: Translator (Expr,CId,NForm)
findNParticip = pNoun 


findAPerfParticip :: Translator CId
findAPerfParticip = 
 lemma "V" "s (VI (VPtPret (Strong (GSg Utr)) Nom))"
 <+>
 lemma "V" "s (VI (VPtPret (Strong (GSg Neutr)) Nom))"
 <+>
 lemma "V" "s (VI (VPtPret (Strong GPl) Nom))"
 <+>
 lemma "V2" "s (VI (VPtPret (Strong (GSg Utr)) Nom))"
 <+>
 lemma "V2" "s (VI (VPtPret (Strong (GSg Neutr)) Nom))"
 <+>
 lemma "V2" "s (VI (VPtPret (Strong GPl) Nom))"
 <+>
 lemma "VV" "s (VI (VPtPret (Strong (GSg Utr)) Nom))"
 <+>
 lemma "VV" "s (VI (VPtPret (Strong (GSg Neutr)) Nom))"
 <+>
 lemma "VV" "s (VI (VPtPret (Strong GPl) Nom))"
 <+>
 lemma "VS" "s (VI (VPtPret (Strong (GSg Utr)) Nom))"
 <+>
 lemma "VS" "s (VI (VPtPret (Strong (GSg Neutr)) Nom))"
 <+>
 lemma "VS" "s (VI (VPtPret (Strong GPl) Nom))"

pAdA :: Translator Expr
pAdA = inside "AB" $ do a <- lemma "A" "s (AF (APosit (Strong (GSg Neutr))) Nom)"
                        return (mkApp cidPositAdAAdj [mkApp a[]])
                    <+>
                     do ada <- optEat (lemma "AdA" "s") meta
                        return (mkExpr ada)

adv :: [String]
adv = ["RA","TA","MA","+A","CA","VA"]

pAdv :: Translator Expr
pAdv = pAdv' adv 

pAdvMinus,pAdv' :: [String] -> Translator Expr
pAdvMinus xs = pAdv' $ adv \\ xs

pAdv' xs = 
  msum [ inside x inAdv | x <- xs]
  <+>
  do write "looking for adv in AA1"
     inside "AA" pAA
     
inAdv :: Translator Expr
inAdv = findAdverb <+> cat "PP" <+> cat "NP" <+> cat "AVP"

pAA :: Translator Expr
pAA =     cat "PP" 
      <+> pAdvAdj 
      <+> pAdv
      <+> findAdverb
      <+> inside "S" pUttAdv
      <+> cat "AVP"

pIAdv :: Translator Expr
pIAdv =
  msum [ inside x (cat "AVP") | x <- ["RA","TA"]]
  <+>
  do write "making a question"
     a <- inside "AB" $ lemma "IAdv" "s"
     return $ mkExpr a
  

findAdverb :: Translator Expr
findAdverb = do
  a <- inside "AB" $ optEat (lemma "Adv" "s Per3") meta
  write $ "adverb found "++show a
  return (mkExpr a) 
 
pAdvAdj :: Translator Expr
pAdvAdj = do
  a <- findAdj
  return $ mkApp cidPositAdvAdj [a]
 
pAdAdj :: Translator Expr
pAdAdj = liftM (\a -> mkApp cidPositAdAAdj [a]) findAdj         

pIQuant :: Translator Expr
pIQuant = inside "PO" piq
 where piq =    
            do dt <- lemma "IQuant" "s Sg Utr" 
                     <+>
                     lemma "IQuant" "s Sg Neutr"
               write ("det: "++show dt)
               returnApp cidDetQuant [mkExpr dt,mkExpr cidNumSg] 
            <+>
            do dt <- lemma "IQuant" "s Pl Utr"
                     <+>
                     lemma "IQuant" "s Pl Neutr"
               write ("det: "++show dt)
               returnApp cidDetQuant [mkExpr dt,mkExpr cidNumPl] 

pQuant :: Translator Expr
pQuant =
  do w <- word "PODP"   -- to avoid this_Quant when it should be DefArt
     let den = map toLower w
     guard (den=="den" || den=="det")                               
     returnApp cidDetQuant [mkExpr cidDefArt,mkExpr cidNumSg]
  <+>                                                       
  inside "PO" (   --
       do dt <-   lemma "Quant" "s Per3 Sg False False Utr" 
              <+> lemma "Quant" "s Per3 Sg False False Neutr"
          write ("det: "++show dt)
          returnApp cidDetQuant [mkExpr dt,mkExpr cidNumSg] 
       <+>
       do dt <- lemma "Quant" "s Per3 Pl False False Utr"
                <+> 
                lemma "Quant" "s Per3 Pl False False Neutr"
          write ("det: "++show dt)
          returnApp cidDetQuant [mkExpr dt,mkExpr cidNumPl]) 
  <+>
  -- no case for singular
  do w <- inside "PO" $ lemma "PronAQ" "s (AF (APosit (Strong GPl)) Nom)"
     return $ mkApp cidDetQuant [mkApp cidQuantPronAQ [mkExpr w],mkExpr cidNumPl]
  <+>
  do dt <- inside "PO" $ lemma "Pron" "s Per3 (NPPoss GPl Nom)"
     return $ mkApp cidDetQuant [mkApp cidPossPron [mkExpr dt],mkExpr cidNumPl]
  <+>
  do dt <- inside "PO" $ lemma "Det" "s Per3 False Utr"
     write ("det: "++show dt)
     return $ mkExpr dt 
  <+>
  do dt <- inside "PO" $ mplus (lemma "Pron" "s Per3 (NPPoss (GSg Neutr) Nom)")
                               (lemma "Pron" "s Per3 (NPPoss (GSg Utr) Nom)")
     return $ mkApp cidDetQuant [mkApp cidPossPron [mkExpr dt],mkExpr cidNumSg]
  <+>
  do n <- pNumber 
     return $ mkApp cidDetQuant [mkExpr cidIndefArt,mkApp cidNumCard [n]]
 <+>
  do inside "EN" $ mplus (lemma "Quant" "s Per3 Sg False False Utr")
                         (lemma "Quant" "s Per3 Sg False False Neutr")
     return $ mkApp cidDetQuant [mkExpr cidIndefArt,mkExpr cidNumSg]
  <+>
  do n <- pNumber 
     return $ mkApp cidDetQuant [mkExpr cidIndefArt,mkApp cidNumCard [n]]
  <+>
  do p <- inside "POXPHHGG" $ lemma "Pron" "s Per3 (NPPoss (GSg Utr) Nom)"
     return $ mkApp cidDetQuant [mkApp cidPossPron [mkExpr p]]
  <+>
  -- genitiv nouns
  do (n,num,def) <- insideSuff "GG" pNounGen
     let dt = mkApp cidDetQuant [mkExpr (getDef def),mkExpr num] 
         np = mkApp cidDetCN [dt,mkApp cidUseN [n]]
     return $ mkApp cidDetQuant [mkApp cidGenNP [np]] 
     



pDetRefl :: Translator Expr
pDetRefl =         
  do word "POXP" 
     write "setting it to true"
     return (mkExpr cidReflIdPron) 


pN2 :: Translator (Expr,Expr,Expr)
pN2 = 
  do np <- cat "NP"
     return (np,mkExpr cidNumSg, mkExpr cidDefArt) 
  <+>
  inside "NNDD" (do n <- lemma "N2" "s Pl Def Nom"
                    return (mkExpr n,mkExpr cidNumPl,mkExpr cidDefArt)
                  <+>
                  do n <- lemma "N2" "s Sg Def Nom" 
                     return (mkExpr n,mkExpr cidNumSg,mkExpr cidDefArt) 
                  <+>
                  do n <- lemma "N2" "s Sg Indef Nom" 
                     return (mkExpr n,mkExpr cidNumSg,mkExpr cidIndefArt) 
                  <+>
                  do n <- lemma "N2" "s Pl Indef Nom"
                     return (mkExpr n,mkExpr cidNumPl,mkExpr cidIndefArt))

pAppos :: Translator Expr
pAppos = do inside "XP" consume 
            return (mkExpr meta)

pPConj :: Translator Expr
pPConj = 
  do s <- inside "++" $ lemma "PConj" "s"
     return (mkExpr s)
  <+>
  do s <- inside "++" $ lemma "Conj" "s2"
     return (mkApp cidPConjConj [mkExpr s])

pConj :: Translator Expr
pConj = 
  do word "++OC"
     return $ mkExpr cidAndConj
  <+>
  do word "++EL"
     return $ mkExpr cidOrConj
  <+>
  do s <- inside "++" $ lemma "Conj" "s2"
     return (mkExpr s)
    
pSubj :: Translator Expr
pSubj = do 
  s <- inside "UK" $ optEat (lemma "Subj" "s") meta
  return $ mkExpr s 

pCopula, pHave :: Translator (VForm CId)
pCopula  = write "copula?" >> tense "AV"
pHave    = write "have"    >> tense "HV"  

pFuturum :: Translator (VForm CId)
pFuturum = do write "futurum?"
              t <- tense "SV"
              write ("futurum: "++show t)
              if isVTenseForm cidTPres t then return (VTense cidTFut)
                                         else return (VTense cidTCond) -- ?

pFuturumKommer :: Translator (VForm CId)
pFuturumKommer = do
               t <- tense "KV"
               write ("futurum kom att: "++show t)
               return (VTense cidTFutKommer)
  
tense :: String -> Translator (VForm CId)
tense cat =
  do word $ cat++"IV"    
     return VInf
  <+>
  do word $ cat++"PK" 
     return VPart
  <+>
  do word $ cat++"PS"
     write "presens"
     return (VTense cidTPres)
  <+>
  do word $ cat++"PT"
     return (VTense cidTPast)
  <+>
  do word $ cat++"SN" 
     return VSupin
  <+>
  do word $ cat++"IP"
     return VPart    
   
pPrep :: Translator Expr
pPrep = do write "in pPrep"
           p <- inside "PR" $ optEat (lemma "Prep" "s") meta
           return $ mkExpr p

pPredet :: Translator Expr
pPredet = 
  do w <- findPredet
     return $ mkExpr w 
  <+> parsePredetAdv

 where findPredet = do w <- word "PO"
                       let wd = map toLower w
                       guard (wd /="den" && wd /="det")
                       write "in pPredet with PO"
                       wordlookup w "Predet" "s Neutr Pl"
                        <+>
                        wordlookup w "Predet" "s Utr Pl"
                        <+>
                        wordlookup w "Predet" "s Utr Sg"
                        <+>
                        wordlookup w "Predet" "s Neutr Sg"
       parsePredetAdv = inside "AB" $ do 
                          w <- lemma "Adv" "s"
                          return (mkApp cidPredetAdvF [mkExpr w])


                       


-- translate all numers to 1. could also be NumNumeral ( num (pot... n1))
pNumber :: Translator Expr
pNumber = 
  inside "RO" $ do consume
                   return $ mkApp cidNumDigits 
                          [mkApp cidIDig 
                             [mkExpr cidD_1]] 

pPol :: Translator (Maybe Bool)
pPol =
  do w  <- cat "NA"
     return (Just False)
  <+>
     return (Just True)

listOf :: Translator a -> Translator [a]
listOf f = 
  many $ do
   a <- inside "CJ" f 
   word2 "IK"
   return a

conjunct :: CId -> CId -> CId -> Translator Expr -> Translator Expr
conjunct consf basef conjf f =
  do xs   <- listOf f
     write $ "found list of " ++show xs
     x1   <- inside "CJ" f
     write $ "found first conj " ++show x1
     conj <- inside "++" pConj 
     write $ "found  conj " ++show conj 
     x2   <- inside "CJ" f
     write $ "found snd conj " ++show x2
     let compXs x y = mkApp consf [x,y]
         conjs      = foldr  compXs (mkApp basef [x1,x2]) xs
     return $ mkApp conjf [conj, conjs]


adjSN, adjSU, adjSPl, adjWPl, adjWSg :: String
adjSN = "s (AF (APosit (Strong (GSg Neutr))) Nom)"
adjSU = "s (AF (APosit (Strong (GSg Utr))) Nom)"
adjSPl = "s (AF (APosit (Strong GPl)) Nom)"
adjWPl = "s (AF (APosit (Weak Pl)) Nom)"
adjWSg = "s (AF (APosit (Weak Sg)) Nom)" 

meta :: CId
meta = mkCId "?"

mkExpr :: CId -> Expr
mkExpr x = mkApp x []

mkPol :: Maybe Bool -> Expr
mkPol (Just True)  = mkExpr cidPPos 
mkPol (Just False) = mkExpr cidPNeg 
mkPol Nothing      = mkExpr meta 


returnApp :: CId -> [Expr] -> Translator Expr
returnApp cid exs = do
  t <- gets S.sentenceType
  return $ mkApp (getCId t cid) exs 

localKeepPol :: Translator a -> Translator a
localKeepPol m = do
  (x,st) <- local m
  S.pol =: P.get S.pol st
  return x

local :: Translator a -> Translator (a,S.State)
local m = do 
  st  <- get
  x   <- m
  loc <- get
  put st
  return (x,loc)


--For embedded clauses where the state should be cleared and later reset
putStateToZero :: Translator S.State
putStateToZero = do
  st <- get
  put S.startState
  return st

resetState :: S.State -> Translator ()
resetState = put

getCId :: SentenceType -> CId -> CId
getCId Q  c | c == cidCompNP   = cidCompIP
            | c == cidCompAdv  = cidCompIAdv
            | c == cidDetCN    = cidIdetCN
            | c == cidDetQuant = cidIdetQuant
            | c == cidPrepNP   = cidPrepIP
getCId _ c = c
  
fst3 :: (a,b,c) -> a
fst3 (a,_,_) = a
third :: a -> (VForm CId,Expr) -> (VForm CId,Expr,a)
third x = uncurry (,,x)

testa :: String -> IO [(Lemma, Analysis, String)]
testa  str = do
  pgf <- readPGF "../gf/BigTest.pgf"
  let Just language = readLanguage "BigTestSwe"
      morpho        = buildMorpho pgf language
  return [(lemma,an,cat) | (lemma,an) <- lookupMorpho morpho str
         ,let cat = maybe "" (showType []) (functionType pgf lemma)]