diff options
Diffstat (limited to 'treebanks/talbanken/Translate.hs')
| -rw-r--r-- | treebanks/talbanken/Translate.hs | 1798 |
1 files changed, 1798 insertions, 0 deletions
diff --git a/treebanks/talbanken/Translate.hs b/treebanks/talbanken/Translate.hs new file mode 100644 index 000000000..535cf37bd --- /dev/null +++ b/treebanks/talbanken/Translate.hs @@ -0,0 +1,1798 @@ +{-# 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)] + |