An experimental, likely insultling, katakana/hiragana orthography for Lojban

PonjoLojbo.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
import qualified Data.Map as Map
import Data.Maybe

import Text.Parsec
import System.Console.CmdArgs

type Map = Map.Map

dakuten  = '\xFF9E'
dakuten' = '\x3099'

handakuten  = '\xFF9F'
handakuten' = '\x309A'

chooonpu = '\x30FC'

stop = '\x3002'

comma = '\x3001'

interpunct = '\x00B7'

-- There are actually 198, but 200 is easier to write
type Hyakuyonjuuon = Map Char (Map String String)

headerHor = ["-", "a", "i", "u", "e", "o", "y", "ai", "ei", "oi", "au"]
headerVer = "-iupbfvtdszcjkgxmnlr"

row' :: (String -> String) -> [String] -> Map String String
row' f = Map.fromList . zip
    headerHor
    . map f

row :: [Char] -> (String -> String) -> [Char] -> Map String String
row [ic, uc] = flip $ flip row' . (\[a, i, y, e, o] -> 
    [[y], [a], [i], [y,uc], [e], [o], [y,chooonpu]
    , [a,ic], [e,ic], [o,ic], [a,uc]
    ])

dd (root:rest) = root:dakuten:rest
d' (root:rest) = root:dakuten':rest

hh (root:rest) = root:handakuten:rest
h' (root:rest) = root:handakuten':rest

showHyakuyonjuuon kana = concatMap ('\t':) headerHor
    : [ rid : (showLine $ fromJust $ Map.lookup rid kana) | rid <- headerVer ]
  where showLine l = concatMap ('\t':)
            [ fromJust $ Map.lookup cid l | cid <- headerHor ]

hiragana = Map.fromList
    [ '-' >< row' id ["", "あ", "い", "う", "え", "お"
        , [chooonpu], "あぃ", "えぃ", "おぃ", "あぅ"]
    , 'i' >< row' id ["", "や", "ゆぃ", "ゆぅ", "ゆぇ", "よ"
        , 'ゆ':[chooonpu], "やぃ", "ゆぇぃ", "よぃ", "やぅ"]
    , 'u' >< row' id ["", "わ", "ゐ", "ゐぅ", "ゑ", "を"
        , 'ゐ':[chooonpu], "わぃ", "ゑぃ", "をぃ", "わぅ"]
    , 'p' >< kRow h' x
    , 'b' >< kRow d' x
    , 'f' >< kRow hh m
    , 'v' >< kRow dd m
    , 't' >< kRow id t
    , 'd' >< kRow d' t
    , 's' >< kRow id s
    , 'z' >< kRow d' s
    , 'c' >< kRow hh s
    , 'j' >< kRow hh t
    , 'k' >< kRow id k
    , 'g' >< kRow d' k
    , 'x' >< kRow id x
    , 'm' >< kRow id m
    , 'n' >< kRow id n
    , 'r' >< kRow id r
    , 'l' >< kRow dd r
    ]
  where kRow = row "ぃぅ"
        k = "かきくけこ"
        s = "さしすせそ"
        t = "たちつてと"
        n = "なにぬねの"
        x = "はひふへほ"
        m = "まみむめも"
        r = "らりるれろ"

katakana = Map.fromList
    [ '-' >< row' id ["", "ア", "イ", "ウ", "エ", "オ"
        , [chooonpu], "アィ", "エィ", "オィ", "アゥ"]
    , 'i' >< row' id ["", "ヤ", "ユィ", "ユゥ", "ユェ", "ヨ"
        , 'ユ':[chooonpu], "ヤィ", "ユェィ", "ヨィ", "ヤゥ"]
    , 'u' >< row' id ["", "ワ", "ヰ", "ヰゥ", "ヱ", "ヲ"
        , 'ヰ':[chooonpu], "ワィ", "ヱィ", "ヲィ", "ワゥ"]
    , 'p' >< kRow h' x
    , 'b' >< kRow d' x
    , 'f' >< kRow hh m
    , 'v' >< kRow dd m
    , 't' >< kRow id t
    , 'd' >< kRow d' t
    , 's' >< kRow id s
    , 'z' >< kRow d' s
    , 'c' >< kRow hh s
    , 'j' >< kRow hh t
    , 'k' >< kRow id k
    , 'g' >< kRow d' k
    , 'x' >< kRow id x
    , 'm' >< kRow id m
    , 'n' >< kRow id n
    , 'r' >< kRow id r
    , 'l' >< kRow dd r
    ]
  where kRow = row "ィゥ"
        k = "カキクケコ"
        s = "サシスセソ"
        t = "タチツテト"
        n = "ナニヌネノ"
        x = "ハヒフヘホ"
        m = "マミムメモ"
        r = "ラリルレロ"


translate' :: Hyakuyonjuuon -> Char -> String -> Maybe String
translate' kana r c = Map.lookup r kana >>= Map.lookup c

translate :: Hyakuyonjuuon -> Char -> String -> String
translate = ((.).(.).(.)) fromJust translate'

-- A really simple transcriber; does not validate morphology
consonentP :: Stream s m Char => ParsecT s u m Char
consonentP = oneOf $ drop 3 headerVer

vowelAtomP :: Stream s m Char => ParsecT s u m Char
vowelAtomP = oneOf "aiueoy"

hP :: Stream s m Char => ParsecT s u m Char
hP = oneOf "\'`"

vowelP :: Stream s m Char => ParsecT s u m String
vowelP = try diphthong <|> fmap (:[]) vowelAtomP
  where diphthong = choice $ map string ["ai", "ei", "oi", "au"]

fullVowelP :: Stream s m Char => ParsecT s u m [String]
fullVowelP = vowelP `sepBy1` hP

transcribeVowels :: Hyakuyonjuuon -> [String] -> String
transcribeVowels kana = concatMap (translate kana '-')

tryVowelP :: Stream s m Char => Hyakuyonjuuon -> Char -> ParsecT s u m String
tryVowelP kana c = do
    vs <- fullVowelP
    return $ translate kana c (head vs) 
        ++ concatMap (translate kana '-') (tail vs)

tsIUP :: Stream s m Char => Hyakuyonjuuon -> ParsecT s u m String
tsIUP kana = do
    iu <- oneOf "iu"
    choice
        [ do
            vs <- fullVowelP
            return $ translate kana iu (head vs) 
                ++ transcribeVowels kana  (tail vs)
        , return (translate kana '-' [iu])
        ]

tsConsonentP :: Stream s m Char => Hyakuyonjuuon -> ParsecT s u m String
tsConsonentP kana = do
    c <- consonentP
    let nv = translate kana c "-"
    choice 
        [ try $ tryIUP nv
        , tsVowelP' kana c
        , return nv
        ]
  where tryIUP :: Stream s m Char => String -> ParsecT s u m String
        tryIUP nv = do
            iu <- oneOf "iu"
            vs <- fullVowelP
            return $ nv
                ++ translate kana iu (head vs) 
                ++ transcribeVowels kana (tail vs)
--
-- We assume we have done an i-u check before reaching this
tsVowelP' :: Stream s m Char => Hyakuyonjuuon -> Char -> ParsecT s u m String
tsVowelP' kana c = do
    vs <- fullVowelP
    if vs `elem` [["ai"], ["ei"], ["oi"], ["ou"]]
      then choice
        [ do 
            let [v, iu] = head vs
            vs <- fullVowelP
            return $ translate kana c [v]
                ++ translate kana iu (head vs)
                ++ transcribeVowels kana (tail vs)
        , return $ translate kana c $ head vs
        ]
      else return $ translate kana c (head vs)
        ++ transcribeVowels kana (tail vs)

tsVowelP :: Stream s m Char => Hyakuyonjuuon -> ParsecT s u m String
tsVowelP = flip tsVowelP' '-'

specialP :: Stream s m Char => ParsecT s u m String
specialP = fmap (:[]) $ choice
    [ char '.' >> return stop
    , char ';' >> return comma
    , char ',' >> return interpunct
    ]

transcribeP :: Stream s m Char => Hyakuyonjuuon -> ParsecT s u m String
transcribeP kana = fmap concat $ many $ spaces >> choice
    [ specialP
    , tsConsonentP kana 
    , tsIUP kana
    , tsVowelP kana
    ]

(.:) = (.).(.)

transcribe kana str = case parse (transcribeP kana) "" str of
    Left err -> show err
    Right res -> res

data Args = Args
    { katakanaA :: Bool
    , chartA    :: Bool
    }
  deriving (Show, Data, Typeable)

argAs = Args
    { katakanaA = False
        &= name "katakana"
        &= help "Display in katakana instead of hiragana"
    , chartA = False
        &= name "chart"
        &= help "Display full translation chart and quit"
    }
    &= program "PonjoLojbo"
    &= versionArg[ignore]
    &= summary 
        "A translator from standard Lojban orthography to Zearen's kana scheme"

main = do
    args' <- cmdArgs argAs
    let kana = if katakanaA args' then katakana else hiragana
    if chartA args'
      then mapM_ putStrLn $ showHyakuyonjuuon kana
      else getLine >>= putStrLn . transcribe kana 

a >< b = (a, b)