mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-07 10:12:51 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
172
src-3.0/GF/Text/Greek.hs
Normal file
172
src-3.0/GF/Text/Greek.hs
Normal file
@@ -0,0 +1,172 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Greek
|
||||
-- Maintainer : (Maintainer)
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:23:37 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Text.Greek (mkGreek) where
|
||||
|
||||
mkGreek :: String -> String
|
||||
mkGreek = unwords . (map mkGreekWord) . mkGravis . words
|
||||
|
||||
--- TODO : optimize character formation by factorizing the case expressions
|
||||
|
||||
type GreekChar = Char
|
||||
|
||||
mkGreekWord :: String -> [GreekChar]
|
||||
mkGreekWord = map (toEnum . mkGreekChar) . mkGreekSpec
|
||||
|
||||
mkGravis :: [String] -> [String]
|
||||
mkGravis [] = []
|
||||
mkGravis [w] = [w]
|
||||
mkGravis (w1:w2:ws)
|
||||
| stressed w2 = mkG w1 : mkGravis (w2:ws)
|
||||
| otherwise = w1 : w2 : mkGravis ws
|
||||
where
|
||||
stressed w = any (`elem` "'~`") w
|
||||
mkG :: String -> String
|
||||
mkG w = let (w1,w2) = span (/='\'') w in
|
||||
case w2 of
|
||||
'\'':v:cs | not (any isVowel cs) -> w1 ++ "`" ++ [v] ++ cs
|
||||
'\'':'!':v:cs | not (any isVowel cs) -> w1 ++ "`!" ++ [v] ++ cs
|
||||
_ -> w
|
||||
isVowel c = elem c "aehiouw"
|
||||
|
||||
mkGreekSpec :: String -> [(Char,Int)]
|
||||
mkGreekSpec str = case str of
|
||||
[] -> []
|
||||
'(' :'\'': '!' : c : cs -> (c,25) : mkGreekSpec cs
|
||||
'(' :'~' : '!' : c : cs -> (c,27) : mkGreekSpec cs
|
||||
'(' :'`' : '!' : c : cs -> (c,23) : mkGreekSpec cs
|
||||
'(' : '!' : c : cs -> (c,21) : mkGreekSpec cs
|
||||
')' :'\'': '!' : c : cs -> (c,24) : mkGreekSpec cs
|
||||
')' :'~' : '!' : c : cs -> (c,26) : mkGreekSpec cs
|
||||
')' :'`' : '!' : c : cs -> (c,22) : mkGreekSpec cs
|
||||
')' : '!' : c : cs -> (c,20) : mkGreekSpec cs
|
||||
'\'': '!' : c : cs -> (c,30) : mkGreekSpec cs
|
||||
'~' : '!' : c : cs -> (c,31) : mkGreekSpec cs
|
||||
'`' : '!' : c : cs -> (c,32) : mkGreekSpec cs
|
||||
'!' : c : cs -> (c,33) : mkGreekSpec cs
|
||||
'(' :'\'': c : cs -> (c,5) : mkGreekSpec cs
|
||||
'(' :'~' : c : cs -> (c,7) : mkGreekSpec cs
|
||||
'(' :'`' : c : cs -> (c,3) : mkGreekSpec cs
|
||||
'(' : c : cs -> (c,1) : mkGreekSpec cs
|
||||
')' :'\'': c : cs -> (c,4) : mkGreekSpec cs
|
||||
')' :'~' : c : cs -> (c,6) : mkGreekSpec cs
|
||||
')' :'`' : c : cs -> (c,2) : mkGreekSpec cs
|
||||
')' : c : cs -> (c,0) : mkGreekSpec cs
|
||||
'\'': c : cs -> (c,10) : mkGreekSpec cs
|
||||
'~' : c : cs -> (c,11) : mkGreekSpec cs
|
||||
'`' : c : cs -> (c,12) : mkGreekSpec cs
|
||||
c : cs -> (c,-1) : mkGreekSpec cs
|
||||
|
||||
mkGreekChar (c,-1) = case lookup c cc of Just c' -> c' ; _ -> fromEnum c
|
||||
where
|
||||
cc = zip "abgdezhqiklmnxoprjstyfcuw" allGreekMin
|
||||
mkGreekChar (c,n) = case (c,n) of
|
||||
('a',10) -> 0x03ac
|
||||
('a',11) -> 0x1fb6
|
||||
('a',12) -> 0x1f70
|
||||
('a',30) -> 0x1fb4
|
||||
('a',31) -> 0x1fb7
|
||||
('a',32) -> 0x1fb2
|
||||
('a',33) -> 0x1fb3
|
||||
('a',n) | n >19 -> 0x1f80 + n - 20
|
||||
('a',n) -> 0x1f00 + n
|
||||
('e',10) -> 0x03ad -- '
|
||||
-- ('e',11) -> 0x1fb6 -- ~ can't happen
|
||||
('e',12) -> 0x1f72 -- `
|
||||
('e',n) -> 0x1f10 + n
|
||||
('h',10) -> 0x03ae -- '
|
||||
('h',11) -> 0x1fc6 -- ~
|
||||
('h',12) -> 0x1f74 -- `
|
||||
|
||||
('h',30) -> 0x1fc4
|
||||
('h',31) -> 0x1fc7
|
||||
('h',32) -> 0x1fc2
|
||||
('h',33) -> 0x1fc3
|
||||
('h',n) | n >19 -> 0x1f90 + n - 20
|
||||
|
||||
('h',n) -> 0x1f20 + n
|
||||
('i',10) -> 0x03af -- '
|
||||
('i',11) -> 0x1fd6 -- ~
|
||||
('i',12) -> 0x1f76 -- `
|
||||
('i',n) -> 0x1f30 + n
|
||||
('o',10) -> 0x03cc -- '
|
||||
-- ('o',11) -> 0x1fb6 -- ~ can't happen
|
||||
('o',12) -> 0x1f78 -- `
|
||||
('o',n) -> 0x1f40 + n
|
||||
('y',10) -> 0x03cd -- '
|
||||
('y',11) -> 0x1fe6 -- ~
|
||||
('y',12) -> 0x1f7a -- `
|
||||
('y',n) -> 0x1f50 + n
|
||||
('w',10) -> 0x03ce -- '
|
||||
('w',11) -> 0x1ff6 -- ~
|
||||
('w',12) -> 0x1f7c -- `
|
||||
|
||||
('w',30) -> 0x1ff4
|
||||
('w',31) -> 0x1ff7
|
||||
('w',32) -> 0x1ff2
|
||||
('w',33) -> 0x1ff3
|
||||
('w',n) | n >19 -> 0x1fa0 + n - 20
|
||||
|
||||
('w',n) -> 0x1f60 + n
|
||||
('r',1) -> 0x1fe5
|
||||
_ -> mkGreekChar (c,-1) --- should not happen
|
||||
|
||||
allGreekMin :: [Int]
|
||||
allGreekMin = [0x03b1 .. 0x03c9]
|
||||
|
||||
|
||||
{-
|
||||
encoding of Greek writing. Those hard to guess are marked with ---
|
||||
|
||||
maj min
|
||||
A a Alpha 0391 03b1
|
||||
B b Beta 0392 03b2
|
||||
G g Gamma 0393 03b3
|
||||
D d Delta 0394 03b4
|
||||
E e Epsilon 0395 03b5
|
||||
Z z Zeta 0396 03b6
|
||||
H h Eta --- 0397 03b7
|
||||
Q q Theta --- 0398 03b8
|
||||
I i Iota 0399 03b9
|
||||
K k Kappa 039a 03ba
|
||||
L l Lambda 039b 03bb
|
||||
M m My 039c 03bc
|
||||
N n Ny 039d 03bd
|
||||
X x Xi 039e 03be
|
||||
O o Omikron 039f 03bf
|
||||
P p Pi 03a0 03c0
|
||||
R r Rho 03a1 03c1
|
||||
j Sigma --- 03c2
|
||||
S s Sigma 03a3 03c3
|
||||
T t Tau 03a4 03c4
|
||||
Y y Ypsilon 03a5 03c5
|
||||
F f Phi 03a6 03c6
|
||||
C c Khi --- 03a7 03c7
|
||||
U u Psi 03a8 03c8
|
||||
W w Omega --- 03a9 03c9
|
||||
|
||||
( spiritus asper
|
||||
) spiritus lenis
|
||||
! iota subscriptum
|
||||
|
||||
' acutus
|
||||
~ circumflexus
|
||||
` gravis
|
||||
|
||||
-}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user