Founding the newly structured GF2.0 cvs archive.

1 files changed, 158 insertions, 0 deletions

diff --git a/src/GF/Text/Greek.hs b/src/GF/Text/Greek.hs
new file mode 100644
index 000000000..8cbba8c54
--- /dev/null
+++ b/src/GF/Text/Greek.hs
@@ -0,0 +1,158 @@
+module Greek 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
+
+-}
+
+
+
+
+