mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-17 00:39:32 -06:00
1799 lines
56 KiB
Haskell
1799 lines
56 KiB
Haskell
{-# 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)]
|
|
|