MkWikt.hs

import Data.Char
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S

wiktFile = "en-fr-enwiktionary.txt"
dictFuns = "dictfuns.txt"
irregFre = "irregFre.txt"
oldFre   = "oldFre.txt"

-- AR 10/10/2013
-- extracting a lexicon from Wiktionary as presented in
--   http://en.wiktionary.org/wiki/User:Matthias_Buchmeier/download
-- downloaded from
--   https://hotfile.com/dl/248980034/2861991/dictionaries_enwiktionary_ding_dictd_20131002.tgz.html


-- abjure_V2 : V2 ;    ==>   (abjure_V, 2)

main = do
  funs <- readFile dictFuns >>= return . map (break (\c -> isDigit c || isSpace c)) . lines
  let funmap = M.fromList [(w,takeWhile (not . isSpace) c) | (w,c) <- funs]
  fverbmap <- readFile irregFre >>= return . M.fromList . map mkVerb . lines
  oldFre <- readFile oldFre >>= return . S.fromList . map (head . words) . lines
  wiks0 <- readFile wiktFile >>= return . map analyseLine . lines 
  let wiks1 = [(w1,c1,f1) | (w0,c0,f0) <- wiks0,
                            c0 /= "?",
                            not (all isSpace f0),      -- not empty string
                            let w = w0 ++ "_" ++ c0, 
                            Just cs <- [M.lookup w funmap],
                            let c1 = c0 ++ cs,
                            let w1 = w0 ++ "_" ++ c1,
                            not (S.member w1 oldFre),
                            let f1 = analyseFre fverbmap c0 (uncomment f0),
                            notElem ' ' (fst f1)       -- exclude multiwords, for sanity
                           ]
  let dict = unlines $ map convertLine $ groupEntries wiks1
--  putStrLn dict
  writeFile "NewDictFre.txt" dict

-- [sur un sofa or sur un canapé] s'allonger  ==> s'allonger
uncomment s = case break (=='[') s of
  (s1,_:s2) -> s1 ++ case break (== ']') s2 of
    (_,_:s4) -> s4
    _ -> []
  _ -> s

groupEntries = map variants . groupBy sameFun where
  sameFun (f,_,_) (g,_,_) = f == g
  variants fes@((f,c,_):_) = (f,c,[s | (_,_,s) <- fes])
  

-- abjure {v} /æbˈdʒʊɹ/ (to renounce with solemnity) :: abjurer   ==>  (abjure, V, abjurer)

analyseLine l = case words l of
  w:c:rest | head c == '{' && elem "::" rest -> 
       (fun w,cat c, takeWhile (/=',') (unwords (tail (dropWhile (/= "::") rest))))
  _ -> ([],[],[])

fun = map fc where
  fc c = if isAlphaNum c then c else '_'

cat s = case (init (tail s)) of
  "adj"  -> "A"
  "n"    -> "N"
  "v"    -> "V"
  "prop" -> "PN"
  "adv"  -> "Adv"
  "conj" -> "Conj"
  "interj" -> "Interj"
  "determiner" -> "Det"
  _ -> "?"


analyseFre vmap c s = case (c, break (=='{') s) of
  ("N", (w,"{m}")) -> (init w,["masculine"])
  ("N", (w,"{f}")) -> (init w,["feminine"])
  ("PN", (w,"{m}")) -> (init w,["masculine"])
  ("PN", (w,"{f}")) -> (init w,["feminine"])
  ("A",  (w,'{':_)) -> (init w,[])
  (_,    (w,'{':_)) -> (init w,[])
  (_,_)             -> case (c, splitAt 2 s) of
    ('V':_,  ("se", ' ':v)) -> (mkV v, ["reflV"])
    ('V':_,  ("s'",   v)) -> (mkV v, ["reflV"])
    ('V':_,  _)           -> (mkV s, [])
    _ -> (s,     [])
 where
  mkV s = case M.lookup s vmap of
    Just f -> "I." ++ f
    _ -> s

mkVerb s = case words s of
  v:_ -> (takeWhile (/='_') v, v)


convertLine (eng,cat,fps) = eng ++ " = " ++ unwords (intersperse "|" (map lin fps)) ++ " ;" where
  lin (fre,ps) = case (cat,fre,ps) of
    ('V':_,  'I':'.':_,  ["reflV"]) -> "mk" ++ cat ++ " (reflV (mkV " ++ fre ++ "))" 
    ('V':_,  'I':'.':_,  [])        -> "mk" ++ cat ++ " (mkV " ++ fre ++ ")"
    ('V':_,  _,          ["reflV"]) -> "mk" ++ cat ++ " (reflV (mkV \"" ++ fre ++ "\"))"
    ('V':_,  _,          [])        -> "mk" ++ cat ++ " (mkV \"" ++ fre ++ "\")"
    _ -> "mk" ++ cat ++ " \"" ++ fre ++ "\" " ++ unwords ps