gf-3.6: treebanks/susanne/convert.hs
import System.Directory
import System.FilePath
import Data.List
import Data.Char(toLower)
import Control.Monad
import qualified Data.Map as Map
import PGF (readPGF, readLanguage, buildMorpho, lookupMorpho, mkCId, functionType, unType)
import SusanneFormat
import Parser
import Idents
Just eng = readLanguage "DictEng"
main = do
gr <- readPGF "DictEngAbs.pgf"
let morpho = buildMorpho gr eng
fs <- getDirectoryContents "data"
txts <- (mapM (\f -> readFile ("data" </> f)) . filter ((/= ".") . take 1)) (sort fs)
--let ts' = readTreebank (lines (concat txts))
--writeFile "text" (unlines (map show ts'))
let (ts',rs') = combineRes (convert gr morpho) (readTreebank (lines (concat txts)))
let rm = Map.fromListWith (++) rs'
writeFile "susanne.gft" (unlines (map show ts'))
writeFile "rules" (unlines (concat [unwords ("-":cat:"->":cats) : map (\t -> " "++show t) rs'' | (cat :-> cats,rs'') <- Map.toList rm]))
data Rule = Tag :-> [Tag]
deriving (Eq,Ord)
convert pgf morpho w@(Word _ tag _ lemma)
| elem tag ["YB","YBL","YBR","YF","YIL","YIR","YTL","YTR", "YO"] = ([],[])
{- | tag == "NN1c" = convertLemma pgf morpho (mkCId "N") "s Sg Nom" w
| tag == "NN1n" = convertLemma pgf morpho (mkCId "N") "s Sg Nom" w
| tag == "NN2" = convertLemma pgf morpho (mkCId "N") "s Pl Nom" w
| tag == "JJ" = convertLemma pgf morpho (mkCId "A") "s (AAdj Posit Nom)" w
| tag == "JB" = convertLemma pgf morpho (mkCId "A") "s (AAdj Posit Nom)" w
| tag == "JBo" = convertLemma pgf morpho (mkCId "A") "s (AAdj Posit Nom)" w
| tag == "AT" = convertLemma pgf morpho (mkCId "Quant") "s False Sg" w
| tag == "VVDi" = convertLemma pgf morpho (mkCId "V") "s VPast" w
| tag == "VVDt" = convertLemma pgf morpho (mkCId "V2") "s VPast" w
| tag == "VVDv" = convertLemma pgf morpho (mkCId "V") "s VPast" w
| tag == "VVZi" = convertLemma pgf morpho (mkCId "V") "s VPres" w
| tag == "VVZt" = convertLemma pgf morpho (mkCId "V2") "s VPres" w
| tag == "VVZv" = convertLemma pgf morpho (mkCId "V") "s VPres" w
| tag == "PPHS2"= convertLemma pgf morpho (mkCId "Pron") "s (NCase Nom)" w
| tag == "PPHO2"= convertLemma pgf morpho (mkCId "Pron") "s NPAcc" w
| tag == "RR" = convertLemma pgf morpho (mkCId "Adv") "s" w
| tag == "II" = convertLemma pgf morpho (mkCId "Prep") "s" w
| tag == "IO" = convertLemma pgf morpho (mkCId "Prep") "s" w-}
| otherwise = ([w],[])
convert pgf morpho t@(Phrase tag mods fn idx ts)
| tag == "O" = (ts',rs')
| tag == "Q" = (ts',rs')
| tag == "S" = case runP pS pgf morpho ts' of
Just ([],x) -> ([x], rs')
_ -> ([Phrase tag mods fn idx ts'], (r,[t]) : rs')
| otherwise = ([Phrase tag mods fn idx ts'], (r,[t]) : rs')
where
(ts',rs') = combineRes (convert pgf morpho) ts
r = tag :-> map getTag ts
isExtra (Word _ "YIL" _ _) = True
isExtra (Word _ "YIR" _ _) = True
isExtra (Word _ "YTL" _ _) = True
isExtra (Word _ "YTR" _ _) = True
isExtra _ = False
getTag (Phrase tag mods fn idx ts) = tag++if null fn then "" else ":"++fn
getTag (Word _ tag _ _) = tag
convertLemma pgf morpho cat an0 w@(Word _ tag form _) =
case [f | (f,an) <- lookupMorpho morpho (map toLower form), hasCat pgf f cat, an == an0] of
[f] -> ([App f []], [])
_ -> ([w],[])
where
hasCat pgf f cat =
case functionType pgf f of
Just ty -> case unType ty of
(_,cat1,_) -> cat1 == cat
Nothing -> False
combineRes f ts = (ts',rs')
where
(x,y) = unzip (map f ts)
ts' = concat x
rs' = concat y
pS =
do mplus pConj (return ())
advs <- many pAdS
np <- pSubject
(t,p,vp) <- pVP
return (foldr ($) (App cidUseCl [t,p,App cidPredVP [np, vp]]) advs)
`mplus`
do mplus pConj (return ())
(t,p,vp) <- pVP
return (App cidImpVP [vp])
`mplus`
do mplus pConj (return ())
advs <- many pAdS
t1 <- match "EX"
(t,p,vp) <- pVP
return (foldr ($) (App cidUseCl [t,p,App cidExistNP [t1,vp]]) advs)
pSubject =
do insideOpt "N:s" pNP
`mplus`
do insideOpt "N:S" pNP
`mplus`
do match "M:s"
`mplus`
do match "M:S"
`mplus`
do match "D:s"
`mplus`
do match "D:S"
pConj =
do match "CC"
return ()
`mplus`
do match "CCB"
return ()
pAdS =
do adv <- pAdv
match "YC"
return (\t -> App cidExtAdvS [adv,t])
`mplus`
do adv <- pAdv
return (\t -> App cidAdvS [adv,t])
pVP =
do adVs <- many pAdV
(t,p,vs) <- pV "VS"
advs <- many pAdv
s <- insideOpt "F:o"
(opt (match "CST") >> pS)
return (t,p,foldr (\adv t -> App cidAdVVP [adv,t])
(foldl (\t adv -> App cidAdvVP [t, adv])
(App cidComplVS [vs, s])
advs)
adVs)
`mplus`
do adVs <- many pAdV
(t,p,vv) <- pV "VV"
advs <- many pAdv
vp <- match "Ti"
return (t,p,foldr (\adv t -> App cidAdVVP [adv,t])
(foldl (\t adv -> App cidAdvVP [t, adv])
(App cidComplVV [vv, vp])
advs)
adVs)
`mplus`
do adVs <- many pAdV
(t,p,v2) <- pV "V2"
o <- pObject
opt (match "YC") -- what is this?
advs <- many pAdv
return (t,p,foldr (\adv t -> App cidAdVVP [adv,t])
(foldl (\t adv -> App cidAdvVP [t, adv])
(App cidComplSlash [App cidSlashV2a [v2],o])
advs)
adVs)
`mplus`
do adVs <- many pAdV
(t,p,v) <- pV "V"
advs <- many pAdv
return (t,p,foldr (\adv t -> App cidAdVVP [adv,t])
(foldl (\t adv -> App cidAdvVP [t, adv])
(App cidUseV [v])
advs)
adVs)
pV cat =
do inside "V" $
do v <- lemma "VVDv" (mkCId cat) "s VPast"
return (App cidTTAnt [App cidTPast [],App cidASimul []],App cidPPos [],v)
`mplus`
do v <- lemma "VVDt" (mkCId cat) "s VPast"
return (App cidTTAnt [App cidTPast [],App cidASimul []],App cidPPos [],v)
`mplus`
do v <- lemma "VVZv" (mkCId cat) "s VPres"
return (App cidTTAnt [App cidTPres [],App cidASimul []],App cidPPos [],v)
`mplus`
do match "VHD"
match "VHD"
v <- lemma "VVNv" (mkCId cat) "s VPPart"
return (App cidTTAnt [App cidTPres [],App cidAAnter []],App cidPPos [],v)
`mplus`
do v <- match "V"
return (App (mkCId "XXX") [],App (mkCId "XXX") [],v)
pAdV =
do insideOpt "R:c" $
lemma "RRR" (mkCId "AdV") "s"
`mplus`
do match "R:m"
pObject =
match "P:u"
`mplus`
insideOpt "N:o" pNP
`mplus`
match "N:e"
`mplus`
match "M:e"
`mplus`
match "D:e"
`mplus`
match "P:e"
pAdv =
do match "N:t"
`mplus`
do match "N:h"
`mplus`
do match "P:p"
`mplus`
do match "P:q"
`mplus`
do match "P:a"
`mplus`
do match "P:t"
`mplus`
do match "P:h"
`mplus`
do match "P:m"
`mplus`
do match "P:r"
`mplus`
do match "R:p"
`mplus`
do match "R:q"
`mplus`
do match "R:a"
`mplus`
do match "R:t"
`mplus`
do match "R:h"
`mplus`
do match "R:m"
`mplus`
do match "R:c"
`mplus`
do match "R:r"
`mplus`
do match "F:p"
`mplus`
do match "F:q"
`mplus`
do match "F:a"
`mplus`
do match "F:t"
`mplus`
do match "F:h"
`mplus`
do match "F:m"
`mplus`
do match "F:r"
`mplus`
do match "W:b"
`mplus`
do match "L:b"
pNP = do
q <- pQuant
(n,cn) <- pCN
return (App cidDetCN [App cidDetQuant [q,n],cn])
pQuant =
do lemma "AT" (mkCId "Quant") "s False Sg"
`mplus`
do match "AT1"
return (App cidIndefArt [])
pCN =
do np <- insideOpt "N" pNP
(n,cn) <- pCN
return (n,App (mkCId "Appos") [np,cn])
`mplus`
do a <- lemma "JJ" (mkCId "A") "s (AAdj Posit Nom)"
(n,cn) <- pCN
return (n,App cidAdjCN [App cidPositA [a],cn])
`mplus`
do (num,n) <- pN
advs <- many pPo
return (num,
foldl (\t adv -> App cidAdvCN [t, adv])
(App cidUseN [n])
advs)
pN =
do n <- lemma "NN1c" (mkCId "N") "s Sg Nom"
return (App cidNumSg [], n)
`mplus`
do n <- lemma "NN1n" (mkCId "N") "s Sg Nom"
return (App cidNumSg [], n)
pPo =
insideOpt "Po" $ do
p <- match "IO"
np <- insideOpt "N" pNP
return (App cidPrepNP [p,np])