forked from GitHub/gf-rgl
198 lines
6.7 KiB
Haskell
198 lines
6.7 KiB
Haskell
module Main where
|
|
|
|
import PGF
|
|
|
|
import qualified Data.Map as M
|
|
import Data.Char
|
|
import Data.List
|
|
import System.Environment (getArgs)
|
|
|
|
-- AR 2020-02-28
|
|
|
|
-- making a word list purely morphological, i.e.
|
|
-- - functions are 1-to-1 with lemgrams, i.e.
|
|
-- - no sense distinctions
|
|
-- - no subcategorizations
|
|
-- - no variants
|
|
-- - functionname = baseform_category, with exceptions
|
|
-- - variant inflection tables: lie_1_V, lie_2_V
|
|
-- - words that have non-ident characters: 'bird\'s-eye_A'
|
|
|
|
-- example:
|
|
-- gf -make ../english/DictEng.gf
|
|
-- runghc MkMorphodict.hs pgf MorphoDictEng.config DictEngAbs.pgf MorphoDictEng
|
|
-- 64923 -> 56599 functions
|
|
|
|
usage = "runghc MkMorphodict (raw|pgf) <configfile> <datafile> <outfile>"
|
|
|
|
main = do
|
|
xx <- getArgs
|
|
if length xx /= 4
|
|
then putStrLn usage
|
|
else do
|
|
let mode:configfile:datafile:outfile:_ = xx
|
|
config <- readFile configfile >>= return . mkConfig
|
|
|
|
rawdata <- case mode of
|
|
"pgf" -> pgfFile2rawData config datafile
|
|
"raw" -> readFile datafile >>= return . map getRawData . filter (not . null) . lines
|
|
rawdata2gf config rawdata outfile
|
|
|
|
|
|
rawdata2gf config rawdata outfile = do
|
|
|
|
let env = MDEnv rawdata config
|
|
let (absrules,cncrules) = mkMorphoDict env
|
|
|
|
absheader <- readFile (outfile ++ "Abs.header")
|
|
cncheader <- readFile (outfile ++ ".header")
|
|
|
|
writeFile (outfile ++ "Abs.gf") absheader
|
|
appendFile (outfile ++ "Abs.gf") $ unlines $ sort absrules
|
|
appendFile (outfile ++ "Abs.gf") "}"
|
|
|
|
writeFile (outfile ++ ".gf") cncheader
|
|
appendFile (outfile ++ ".gf") $ unlines $ sort cncrules
|
|
appendFile (outfile ++ ".gf") "}"
|
|
|
|
-- one way to get raw data from a dictionary pgf
|
|
-- another way, more controllod, is to write a wrapper grammar with a function, for each category, to generate a RawData entry
|
|
pgfFile2rawData config pgffile = do
|
|
pgf <- readPGF pgffile
|
|
|
|
let cats = nub [c | (c,(_,_,_)) <- M.assocs config]
|
|
let lang:_ = languages pgf
|
|
|
|
return [
|
|
(cat, map snd lin) |
|
|
cat <- cats,
|
|
f <- functionsByCat pgf (mkCId cat),
|
|
lin <- tabularLinearizes pgf lang (mkApp f [])
|
|
]
|
|
|
|
type Cat = String
|
|
type Fun = String
|
|
type Oper = String
|
|
type Config = M.Map Cat (Cat,Oper,([Int],[Int])) -- lin word_Cat = Oper str_i1 str_i2 ... str_in featj1 ... featjn ;
|
|
|
|
data MDEnv = MDEnv {
|
|
rawdata :: [RawData],
|
|
config :: Config
|
|
}
|
|
|
|
mkConfig :: String -> Config -- N : N mkN 0 2 4 6 # 9
|
|
mkConfig ls = M.fromList [(c,i) | Left (c,i) <- map mkOne (lines ls)]
|
|
where
|
|
mkOne s = case words s of
|
|
"--":_ -> Right s
|
|
cat:":":tcat:oper:ints -> Left (cat,(tcat,oper,mkArgs ints))
|
|
_ -> Right s
|
|
mkArgs ints = case break (=="#") ints of
|
|
(ss,[]) -> (map read ss, [])
|
|
(ss,_:fs) -> (map read ss, map read fs)
|
|
|
|
getRawData s = case words s of
|
|
c:cs -> (c,cs)
|
|
|
|
type RawData = (String,[String]) -- old cat name, forms and features
|
|
type RawRule = (([String],Cat), (Oper, ([String],[String]))) -- parts of fun name, new category, oper, arguments
|
|
type RuleData = ((Fun, Cat), (Oper, ([String],[String]))) -- final fun name, cat, oper, args
|
|
|
|
mkMorphoDict :: MDEnv -> ([String],[String]) -- fun rules, lin rules
|
|
mkMorphoDict env =
|
|
unzip $
|
|
map splitRule $
|
|
---- findCompounds $ -- let us not care about compounds for the time being, but include them if they are given
|
|
nameFunctions $
|
|
mergeRules $
|
|
findRules $
|
|
rawdata env
|
|
where
|
|
splitRule ((fun,cat),(oper,(forms,feats))) =
|
|
(unwords ["fun",fun,":",cat,";"], unwords ["lin",fun,"=", unwords (oper : map quote forms ++ feats),";"])
|
|
|
|
cats = nub [c | (c,(_,_,_)) <- M.assocs (config env)]
|
|
|
|
findRules :: [RawData] -> [RawRule]
|
|
findRules raws = [
|
|
(([lemma],newcat),(oper, appSig sig args)) |
|
|
(oldcat,args) <- raws,
|
|
Just (newcat, oper, sig) <- [M.lookup oldcat (config env)],
|
|
let lemma = args !! head (fst sig)
|
|
]
|
|
|
|
appSig (ints,feats) args = ([args !! i | i <- ints], [args !! i | i <- feats])
|
|
|
|
mergeRules :: [RawRule] -> [RawRule]
|
|
mergeRules = map head . groupBy (\x y -> snd x == snd y) . sortOn snd
|
|
|
|
nameFunctions :: [RawRule] -> [RuleData]
|
|
nameFunctions = expandNames . sortOn fst
|
|
|
|
expandNames :: [RawRule] -> [RuleData]
|
|
expandNames fls = case fls of
|
|
(f@(w,c),l) : fls2 -> case span ((==f) . fst) fls2 of
|
|
([],_) -> ((mkFun (w ++ [c]),c),l) : expandNames fls2
|
|
(fls1,fls3) -> renames ((f,l):fls1) ++ expandNames fls3
|
|
_ -> []
|
|
|
|
renames :: [RawRule] -> [RuleData]
|
|
--- renames fls = [((mkFun (f ++ [show i,c]),c),l) | (i,((f,c),l)) <- zip [1..] fls] -- disambiguate with int
|
|
renames fls = [((mkFun (f ++ fs ++ [c]),c),l) | (i,(((f,c),l),fs)) <- zip [1..] (zip fls (minimize fls))] -- disambiguate with different forms
|
|
|
|
minimize :: [RawRule] -> [[String]]
|
|
minimize fls = shrink [ws ++ fs | (_,(_,(_:ws,fs))) <- fls]
|
|
|
|
shrink fls = case fls of
|
|
fl@(_:_):_ | all ((==head fl) . head) fls -> shrink (map tail fls)
|
|
fl@(_:_):_ | all ((==last fl) . last) fls -> shrink (map init fls)
|
|
_ -> shrinkMore fls
|
|
|
|
shrinkMore fls = case fls of
|
|
_ | length (nub (map init fls)) == length fls -> shrinkMore (map init fls)
|
|
_ | length (nub (map tail fls)) == length fls -> shrinkMore (map tail fls)
|
|
_ -> fls
|
|
|
|
|
|
mkFun = showCId . mkCId . concat . intersperse "_"
|
|
|
|
quote s = "\"" ++ s ++ "\""
|
|
|
|
|
|
|
|
|
|
{- ---- let us ignore this
|
|
findCompounds :: [RuleData] -> [RuleData]
|
|
findCompounds = getCompounds . sortOn cat_orthrevforms
|
|
|
|
cat_orthrevforms (_,(cat,_:forms)) = (cat,[map (!!i) fss | let fss = map reverse forms, i <- [0..minimum (map length fss) - 1]])
|
|
|
|
cat_revforms (_,(cat,_:forms)) = (cat,map reverse forms)
|
|
revstem = head . snd . cat_revforms
|
|
wforms (_,(_,_:forms)) = forms
|
|
|
|
getCompounds :: [RuleData] -> [RuleData]
|
|
getCompounds fls = case fls of
|
|
fl : fls1 | length (revstem fl) < 2 -> markWith fl [] : getCompounds fls1
|
|
fl : fls2 -> case span (\x -> and [isPrefixOf (reverse w) (reverse w1) | (w,w1) <- zip (wforms fl) (wforms x)]) fls2 of
|
|
([],_:_) -> markWith fl [] : getCompounds fls2
|
|
(fls1,fls3) -> markWith fl [] : map (markCompound fl) fls1 ++ getCompounds fls3
|
|
_ -> []
|
|
|
|
markCompound fl fl1 =
|
|
case and [isPrefixWord (reverse w) (reverse w1) | (w,w1) <- zip (wforms fl) (wforms fl1)] of
|
|
True -> markWith fl1 [";","--","compound",(fst fl)]
|
|
False -> markWith fl1 [";","--","notcompound",(fst fl)]
|
|
|
|
markWith (f,(c,op:ws)) xs = (f,(c,op : map quote ws ++ xs)) ---- TODO only quote string args, not features
|
|
|
|
isPrefixWord x xy =
|
|
length suff > 1 && ---- compound first part must be at least two letters long
|
|
any (\c -> elem c "-0123456789aeiouyåäö") suff && ---- must contain a vowel or a digit
|
|
isPrefixOf x xy ---- and of course be a prefix
|
|
where
|
|
suff = drop (length x) xy
|
|
-}
|
|
|
|
|