{-# LANGUAGE ScopedTypeVariables #-} {- Copyright 2012 Ken Takusagawa This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . -} module Main (main) where { import System.Random(randomRIO); import Control.Monad(guard,replicateM_,mzero,MonadPlus); import System.Environment(getArgs); import Data.List(intersperse,nub); -- import Data.Char(toUpper); vowel :: [String]; vowel = flatvowel ++ (concatMap maketone flatvowel); flatvowel :: [String]; flatvowel=purevowels ++ diphthongs; purevowels :: [String]; purevowels = words "a e i o u"; diphthongs :: [String]; diphthongs = words "ai ei oi au"; maketone1 :: String -> [String]; maketone1 s = do { tone <- ['`','\'']; return $ (head s):tone:(tail s); }; maketone :: String -> [String]; maketone s = do { tone <- ["acute","grave"]; return $ "&" ++ [head s] ++ tone ++ ";" ++ (tail s); }; -- c hacek = 010C -- s hacek = 0160 -- cyrillic ts = 0426 nonstops :: [String]; nonstops = words "J S Z Č Š θ"; -- chi should be lower case stops :: [String]; stops = words "B D F G K L M N P T Ц V χ "; ess :: [String]; ess = words "sT sK sP Ξ Ψ"; --"Ch Sh Th Kh" anycons :: [String]; anycons =nonstops ++ stops ++ ess; click :: [String]; click = words "K! T! P!"; r1 :: [String]; r1 = ["R"]; nnn :: [String]; nnn = words "nD nG nK nT nZ mP" ++ (map ("r"++)nonstops); rstops :: [String]; rstops = do { c <- stops; guard (c /= "L"); return $ "r"++c; }; ncenter :: [String]; ncenter = words "nS mB nL" ++ rstops; extra :: [String]; extra=yod ++ oldenglish ++ rho ++ ["Ð"] -- "Dh" where { yod = words "Y H W ñ"; oldenglish :: [String]; oldenglish = words "Kn Gn"; rho = words "Br Dr Fr Gr Kr Pr Tr Vr Bl Fl Kl Pl Sl Vl"; }; p1 ::[String]; p1 = r1 ++ anycons ++ extra; p2 :: [String]; p2 = anycons ++ extra ++ nnn ++ ncenter; p3 :: [String]; p3 = anycons ++ click ++ nnn; consword :: [[String]]; consword = [p1,vowel,p2,vowel,p3]; allconsonants :: [String]; allconsonants = click ++ r1 ++ extra ++ nnn ++ ncenter ++ anycons; vowword :: [[String]]; vowword = [vowel,p2,vowel,p2,vowel]; randomword :: IO String; randomword = mapM randomchoose consword >>= (return . concat . intersperse " "); html :: Int -> IO (); html n = do { putStrLn "

"; replicateM_ n $ sator >>= putStr; putStrLn "

"; }; main :: IO (); main = do { args <- getArgs; case args of { [n] -> html $ read n; _ -> do { replicateM_ 30 $ randomword >>= putStrLn; mapM_ print g_; print $ sum$ map logbits $ concat g_; putStrLn $ unwords vowel; print $ length vowel; putStrLn $ unwords allconsonants; print $ length allconsonants; print $ length $ nub allconsonants; putStrLn $ table $ map (map show) g_; }; }; }; gridchoices :: Int -> Int -> Int; gridchoices i j = length $ letterchoices [i,j]; g_ :: [[Int]]; g_ = map (\x -> map (gridchoices x) [0..4]) [0..4]; logbits :: Int -> Double; logbits i = (log(fromIntegral i))/(log 2); letterchoices :: [Int] -> [String]; letterchoices i = case (mod(sum i)2) of { 1 -> vowel; _ -> concat [anycons , some (== 4) click , some (== 0) r1 , some (\x -> x<4) extra , some (\x -> x>0) nnn , some (\x -> x/=0 && x/=4) ncenter ] where { test :: (Int -> Bool) -> Bool; test p = all p i; some :: (Int -> Bool) -> [String] -> [String]; some p l = mguard (test p) l; } }; htmlmakecol :: Int -> Int -> IO String; htmlmakecol i j = randomchoose $ letterchoices [i,j]; tablecell :: String -> String; tablecell x = "" ++ x ++ ""; htmlmakerow :: Int -> IO [String]; htmlmakerow r = mapM (htmlmakecol r) [0..4]; tablerow :: [String] -> String; tablerow line = "" ++ concatMap tablecell line ++ "\n"; -- sator arepo tenet opera rotas sator :: IO String; sator = do { (s :: [[String]]) <- mapM htmlmakerow [0..4]; return $ table s; }; table :: [[String]] -> String; table s = "

\n" ++ concatMap tablerow s ++ "

\n\n"; randomchoose :: [a] -> IO a; randomchoose l = randomRIO (0,pred$length l) >>= (\i -> return (l !! i)); mguard :: (MonadPlus m) => Bool -> m a -> m a; mguard p x = if p then x else mzero; }