forked from GitHub/gf-core
369 lines
10 KiB
Haskell
369 lines
10 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Thai
|
|
-- Maintainer : (Maintainer)
|
|
-- Stability : (experimental)
|
|
-- Portability : (portable)
|
|
--
|
|
--
|
|
-- Thai transliteration and other alphabet information.
|
|
-----------------------------------------------------------------------------
|
|
|
|
-- AR 27/12/2006. Execute test2 to see the transliteration table.
|
|
|
|
module GF.Text.Thai (
|
|
mkThai,mkThaiWord,mkThaiPron,mkThaiFake,thaiFile,thaiPronFile,thaiFakeFile
|
|
) where
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Char
|
|
|
|
-- for testing
|
|
import GF.Text.UTF8
|
|
import Data.List
|
|
|
|
import Debug.Trace
|
|
|
|
|
|
mkThai :: String -> String
|
|
mkThai = concat . map mkThaiWord . words
|
|
mkThaiPron = unwords . map mkPronSyllable . words
|
|
mkThaiFake = unwords . map (fakeEnglish . mkPronSyllable) . words
|
|
|
|
|
|
type ThaiChar = Char
|
|
|
|
mkThaiWord :: String -> [ThaiChar]
|
|
mkThaiWord = map (toEnum . mkThaiChar) . unchar . snd . pronAndOrth
|
|
|
|
mkThaiChar :: String -> Int
|
|
mkThaiChar c = maybe 0 id $ Map.lookup c thaiMap
|
|
|
|
thaiMap :: Map.Map String Int
|
|
thaiMap = Map.fromList $ zip allThaiTrans allThaiCodes
|
|
|
|
-- convert all string literals in a text
|
|
|
|
thaiStrings :: String -> String
|
|
thaiStrings = convStrings mkThai
|
|
|
|
thaiPronStrings :: String -> String
|
|
thaiPronStrings = convStrings mkThaiPron
|
|
|
|
convStrings conv s = case s of
|
|
'"':cs -> let (t,_:r) = span (/='"') cs in
|
|
'"': conv t ++ "\"" ++ convStrings conv r
|
|
c:cs -> c : convStrings conv cs
|
|
_ -> s
|
|
|
|
|
|
-- each character is either [letter] or [letter+nonletter]
|
|
|
|
unchar :: String -> [String]
|
|
unchar s = case s of
|
|
c:d:cs
|
|
| isAlpha d -> [c] : unchar (d:cs)
|
|
| d == '?' -> unchar cs -- use "o?" to represent implicit 'o'
|
|
| otherwise -> [c,d] : unchar cs
|
|
[_] -> [s]
|
|
_ -> []
|
|
|
|
-- you can prefix transliteration by irregular phonology in []
|
|
|
|
pronAndOrth :: String -> (Maybe String, String)
|
|
pronAndOrth s = case s of
|
|
'[':cs -> case span (/=']') cs of
|
|
(p,_:o) -> (Just p,o)
|
|
_ -> (Nothing,s)
|
|
_ -> (Nothing,s)
|
|
|
|
allThaiTrans :: [String]
|
|
allThaiTrans = words $
|
|
"- k k1 - k2 - k3 g c c1 c2 s' c3 y' d' t' " ++
|
|
"t1 t2 t3 n' d t t4 t5 t6 n b p p1 f p2 f' " ++
|
|
"p3 m y r - l - w s- s. s h l' O h' - " ++
|
|
"a. a a: a+ i i: v v: u u: - - - - - - " ++
|
|
"e e' o: a% a& L R S T1 T2 T3 T4 K - - - " ++
|
|
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 - - - - - - "
|
|
|
|
allThaiCodes :: [Int]
|
|
allThaiCodes = [0x0e00 .. 0x0e7f]
|
|
|
|
|
|
---------------------
|
|
-- heuristic pronunciation of codes
|
|
---------------------
|
|
|
|
-- fake English for TTS, a la Teach Yourself Thai
|
|
|
|
fakeEnglish :: String -> String
|
|
fakeEnglish s = case s of
|
|
'a':'a':cs -> "ah" ++ fakeEnglish cs
|
|
'a':'y':cs -> "ai" ++ fakeEnglish cs
|
|
'a' :cs -> "ah" ++ fakeEnglish cs
|
|
'c':'h':cs -> "ch" ++ fakeEnglish cs
|
|
'c' :cs -> "j" ++ fakeEnglish cs
|
|
'e':'e':cs -> "aih" ++ fakeEnglish cs
|
|
'g' :cs -> "ng" ++ fakeEnglish cs
|
|
'i':'i':cs -> "ee" ++ fakeEnglish cs
|
|
'k':'h':cs -> "k" ++ fakeEnglish cs
|
|
'k' :cs -> "g" ++ fakeEnglish cs
|
|
'O':'O':cs -> "or" ++ fakeEnglish cs
|
|
'O' :cs -> "or" ++ fakeEnglish cs
|
|
'o':'o':cs -> "or" ++ fakeEnglish cs
|
|
'p':'h':cs -> "p" ++ fakeEnglish cs
|
|
'p' :cs -> "b" ++ fakeEnglish cs
|
|
't':'h':cs -> "t" ++ fakeEnglish cs
|
|
't' :cs -> "d" ++ fakeEnglish cs
|
|
'u':'u':cs -> "oo" ++ fakeEnglish cs
|
|
'u' :cs -> "oo" ++ fakeEnglish cs
|
|
'v':'v':cs -> "eu" ++ fakeEnglish cs
|
|
'v' :cs -> "eu" ++ fakeEnglish cs
|
|
'\228':'\228':cs -> "air" ++ fakeEnglish cs
|
|
'\228' :cs -> "a" ++ fakeEnglish cs
|
|
'\246':'\246':cs -> "er" ++ fakeEnglish cs
|
|
'\246' :cs -> "er" ++ fakeEnglish cs
|
|
c:cs | isTone c -> fakeEnglish cs
|
|
c:cs -> c : fakeEnglish cs
|
|
_ -> s
|
|
where
|
|
isTone = flip elem "'`^~"
|
|
|
|
|
|
-- this works for one syllable
|
|
|
|
mkPronSyllable s = case fst $ pronAndOrth s of
|
|
Just p -> p
|
|
_ -> pronSyllable $ getSyllable $ map mkThaiChar $ unchar s
|
|
|
|
data Syllable = Syll {
|
|
initv :: [Int],
|
|
initc :: [Int],
|
|
midv :: [Int],
|
|
finalc :: [Int],
|
|
finalv :: [Int],
|
|
tone :: [Int],
|
|
shorten :: Bool,
|
|
kill :: Bool
|
|
}
|
|
deriving Show
|
|
|
|
data Tone = TMid | TLow | THigh | TRise | TFall
|
|
deriving Show
|
|
|
|
data CClass = CLow | CMid | CHigh
|
|
deriving Show
|
|
|
|
pronSyllable :: Syllable -> String
|
|
pronSyllable s =
|
|
initCons ++ tonem ++ vowel ++ finalCons
|
|
where
|
|
|
|
vowel = case (initv s, midv s, finalv s, finalc s, shorten s, tone s) of
|
|
([0x0e40],[0x0e35],_,[0x0e22],_,_) -> "ia" -- e-i:y
|
|
([0x0e40],[0x0e2d,0x0e35],_,_,_,_) -> "va" -- e-i:O
|
|
([0x0e40],[0x0e30,0x0e35],_,[0x0e22],_,_) -> "ia" -- e-i:ya.
|
|
([0x0e40],[0x0e30,0x0e2d],_,_,_,_) -> "\246" -- e-Oa.
|
|
([0x0e40],[0x0e30,0x0e32],_,_,_,_) -> "O" -- e-a:a. -- open o
|
|
([0x0e40],[0x0e2d],_,_,_,_) -> "\246\246" -- e-O
|
|
([0x0e40],[0x0e34],_,_,_,_) -> "\246\246" -- e-i
|
|
([0x0e40],[0x0e30],_,_,_,_) -> "e" -- e-a.
|
|
([0x0e40],[0x0e32],_,_,_,_) -> "aw" -- e-a:
|
|
([0x0e40],[],[],[0x0e22],_,_) -> "\246\246y" -- e-y
|
|
([0x0e40],[],[],_,True,_) -> "e"
|
|
|
|
([0x0e41],[0x0e30],_,_,_,_) -> "\228" -- ä-a.
|
|
([0x0e41],[],[],_,True,_) -> "\228"
|
|
|
|
([0x0e42],[0x0e30],_,_,_,_) -> "o" -- o:-a.
|
|
|
|
([],[0x0e2d],_,[0x0e22],_,_) -> "OOy" -- Oy
|
|
([],[0x0e2d],_,_,_,_) -> "OO" -- O
|
|
|
|
([],[],[],_,_,_) -> "o"
|
|
|
|
(i,m,f,_,_,_) -> concatMap pronThaiChar (reverse $ f ++ m ++ i) ----
|
|
|
|
initCons = concatMap pronThaiChar $ case (reverse $ initc s) of
|
|
0x0e2b:cs@(_:_) -> cs -- high h
|
|
0x0e2d:cs@(_:_) -> cs -- O
|
|
cs -> cs
|
|
|
|
finalCons =
|
|
let (c,cs) = splitAt 1 $ finalc s
|
|
in
|
|
case c of
|
|
[] -> []
|
|
[0x0e22] -> [] --- y
|
|
[k] -> concatMap pronThaiChar (reverse cs) ++ finalThai k
|
|
|
|
iclass = case take 1 (reverse $ initc s) of
|
|
[c] -> classThai c
|
|
[] -> CMid -- O
|
|
|
|
isLong = not (shorten s) && case vowel of
|
|
_:_:_ -> True ----
|
|
_ -> False
|
|
|
|
isLive = case finalCons of
|
|
c | elem c ["n","m","g"] -> True
|
|
"" -> isLong
|
|
_ -> False
|
|
|
|
tonem = case (iclass,isLive,isLong,tone s) of
|
|
(_,_,_, [0x0e4a]) -> tHigh
|
|
(_,_,_, [0x0e4b]) -> tRise
|
|
(CLow,_,_,[0x0e49]) -> tRise
|
|
(_,_,_, [0x0e49]) -> tFall
|
|
(CLow,_,_,[0x0e48]) -> tFall
|
|
(_, _,_,[0x0e48]) -> tLow
|
|
(CHigh,True,_,_) -> tRise
|
|
(_, True,_,_) -> tMid
|
|
(CLow,False,False,_) -> tHigh
|
|
(CLow,False,_,_) -> tFall
|
|
_ -> tLow
|
|
|
|
(tMid,tHigh,tLow,tRise,tFall) = ("-","'","`","~","^")
|
|
|
|
isVowel c = 0x0e30 <= c && c <= 0x0e44 ----
|
|
isCons c = 0x0e01 <= c && c <= 0x0e2f ----
|
|
isTone c = 0x0e48 <= c && c <= 0x0e4b
|
|
|
|
getSyllable :: [Int] -> Syllable
|
|
getSyllable = foldl get (Syll [] [] [] [] [] [] False False) where
|
|
get syll c = case c of
|
|
0x0e47 -> syll {shorten = True}
|
|
0x0e4c -> syll {kill = True, finalc = tail (finalc syll)} --- always last
|
|
0x0e2d
|
|
| null (initc syll) -> syll {initc = [c]} -- "O"
|
|
| otherwise -> syll {midv = c : midv syll}
|
|
_
|
|
| isVowel c -> if null (initc syll)
|
|
then syll {initv = c : initv syll}
|
|
else syll {midv = c : midv syll}
|
|
| isCons c -> if null (initc syll) ||
|
|
(null (midv syll) && isCluster (initc syll) c)
|
|
then syll {initc = c : initc syll}
|
|
else syll {finalc = c : finalc syll}
|
|
| isTone c -> syll {tone = [c]}
|
|
_ -> syll ---- check this
|
|
|
|
isCluster s c = length s == 1 && (c == 0x0e23 || s == [0x0e2b])
|
|
|
|
-- to test
|
|
|
|
test1 = testThai "k2wa:mrak"
|
|
test2 = putStrLn $ thaiTable
|
|
test3 = do
|
|
writeFile "thai.txt" "Thai Character Coding in GF\nAR 2007\n"
|
|
appendFile "thai.txt" thaiTable
|
|
test4 = do
|
|
writeFile "alphthai.txt" "Thai Characters by Pronunciation\nAR 2007\n"
|
|
appendFile "alphthai.txt" thaiTableAlph
|
|
|
|
|
|
testThai :: String -> IO ()
|
|
testThai s = do
|
|
putStrLn $ encodeUTF8 $ mkThai s
|
|
putStrLn $ unwords $ map mkPronSyllable $ words s
|
|
|
|
testSyllable s =
|
|
let y = getSyllable $ map mkThaiChar $ unchar s
|
|
in
|
|
putStrLn $ pronSyllable $ trace (show y) y
|
|
|
|
thaiFile :: FilePath -> Maybe FilePath -> IO ()
|
|
thaiFile f mo = do
|
|
s <- readFile f
|
|
let put = maybe putStr writeFile mo
|
|
put $ encodeUTF8 $ thaiStrings s
|
|
|
|
thaiPronFile :: FilePath -> Maybe FilePath -> IO ()
|
|
thaiPronFile f mo = do
|
|
s <- readFile f
|
|
let put = maybe putStr writeFile mo
|
|
put $ encodeUTF8 $ thaiPronStrings s
|
|
|
|
thaiFakeFile :: FilePath -> Maybe FilePath -> IO ()
|
|
thaiFakeFile f mo = do
|
|
s <- readFile f
|
|
let put = maybe putStr writeFile mo
|
|
put $ encodeUTF8 $ (convStrings mkThaiFake) s
|
|
|
|
finalThai c = maybe "" return (Map.lookup c thaiFinalMap)
|
|
thaiFinalMap = Map.fromList $ zip allThaiCodes finals
|
|
|
|
classThai c = maybe CLow readClass (Map.lookup c thaiClassMap)
|
|
thaiClassMap = Map.fromList $ zip allThaiCodes heights
|
|
|
|
readClass s = case s of
|
|
'L' -> CLow
|
|
'M' -> CMid
|
|
'H' -> CHigh
|
|
|
|
|
|
thaiTable :: String
|
|
thaiTable = unlines $ ("\n|| hex | thai | trans | pron | fin | class |" ) : [
|
|
"| " ++
|
|
hex c ++ " | " ++
|
|
encodeUTF8 (showThai s) ++ " | " ++
|
|
s ++ " | " ++
|
|
pronThai s ++ " | " ++
|
|
[f] ++ " | " ++
|
|
[q] ++ " | "
|
|
|
|
|
(c,q,f,s) <- zip4 allThaiCodes heights finals allThaiTrans
|
|
]
|
|
|
|
thaiTableAlph :: String
|
|
thaiTableAlph = unlines $ ("\n|| pron | thai | trans |" ) : [
|
|
"| " ++ a ++
|
|
" | " ++ unwords (map (encodeUTF8 . showThai) ss) ++
|
|
" | " ++ unwords ss ++
|
|
" |"
|
|
|
|
|
(a,ss) <- allProns
|
|
]
|
|
where
|
|
prons = sort $ nub
|
|
[p | s <- allThaiTrans, let p = pronThai s, not (null p),isAlpha (head p)]
|
|
allProns =
|
|
[(a,[s | s <- allThaiTrans, pronThai s == a]) | a <- prons]
|
|
|
|
showThai s = case s of
|
|
"-" -> "-"
|
|
--- v:_ | elem v "ivu" -> map (toEnum . mkThaiChar) ["O",s]
|
|
_ -> [toEnum $ mkThaiChar s]
|
|
|
|
|
|
pronThaiChar = pronThai . recodeThai
|
|
|
|
recodeThai c = allThaiTrans !! (c - 0x0e00)
|
|
|
|
pronThai s = case s of
|
|
[c,p]
|
|
| c == 'N' && isDigit p -> [p]
|
|
| c == 'T' && isDigit p -> ['\'',p]
|
|
| isDigit p -> c:"h"
|
|
| p==':' -> c:[c]
|
|
| elem p "%&" -> c:"y"
|
|
| p=='+' -> c:"m"
|
|
| s == "e'" -> "\228\228"
|
|
| otherwise -> [c]
|
|
"O" -> "O"
|
|
"e" -> "ee"
|
|
[c] | isUpper c -> ""
|
|
_ -> s
|
|
|
|
hex = map hx . reverse . digs where
|
|
digs 0 = [0]
|
|
digs n = n `mod` 16 : digs (n `div` 16)
|
|
hx d = "0123456789ABCDEF" !! d
|
|
|
|
heights :: String
|
|
finals :: String
|
|
heights =
|
|
" MHHLLLLMHLLLLMMHLLLMMHLLLMMHHLLLLLL-L-LHHHHLML" ++ replicate 99 ' '
|
|
finals =
|
|
" kkkkkkgt-tt-ntttttntttttnpp--pppmyn-n-wttt-n--" ++ replicate 99 ' '
|