{-# 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)]