diff --git a/cakyrespa.cabal b/cakyrespa.cabal --- a/cakyrespa.cabal +++ b/cakyrespa.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: cakyrespa -version: 0.0.15 +version: 0.0.22 stability: Alpha license: BSD3 license-file: LICENSE @@ -24,7 +24,7 @@ executable cakyrespa hs-source-dirs: src main-is: cakyrespa.hs - other-modules: Language.Lojban.Read + other-modules: Minde, Jimpe, Tcidu, Liste, Klesi build-depends: base >3 && <5, lojbanParser >= 0.1.5, - gluturtle >= 0.0.20, GLUT, yjsvg, yjtools >= 0.9.16 + gluturtle >= 0.0.31, GLUT, yjsvg, yjtools >= 0.9.18 ghc-options: -Wall diff --git a/src/Jimpe.hs b/src/Jimpe.hs new file mode 100644 --- /dev/null +++ b/src/Jimpe.hs @@ -0,0 +1,265 @@ +module Jimpe (jimpe) where + +import Klesi( + Minde(..), + Text(..), Selbri(..), Tag(..), Sumti(..), Mex(..), RelativeClause(..)) +import Liste(skaste) + +import Control.Applicative((<$>)) +import Data.Maybe(fromMaybe) +import Data.Tuple.Tools(uncurry3) + +-------------------------------------------------------------------------------- + +jimpe :: Text -> Minde +jimpe = flip jmi [] + +jmi :: Text -> [Sumti] -> Minde +jmi t@(Bridi (Brivla brivla) terms) args = fromMaybe (SRERA $ show t) $ + lookup brivla midste >>= \mid -> mid terms args +jmi t@(Bridi (NA (Brivla brivla)) terms) args = fromMaybe (SRERA $ show t) $ + lookup brivla narmidste >>= \mid -> mid terms args +jmi (Prenex sumste bridi) _ = MIDYSTE $ jmi bridi <$> mapM bagi sumste + where + bagi (STense "ba" pavsu'i relsu'i) = bagi pavsu'i ++ bagi relsu'i + bagi sumti = [sumti] +jmi (TagGI "ba" pavbri relbri) args = + MIDYSTE [jmi pavbri args, jmi relbri args] +jmi (MultiText texts) args = MIDYSTE $ map (($ args) . jmi) texts +jmi (Vocative "co'o") _ = COhO +jmi l _ = SRERA $ show l + +type Midytcidu = [(Tag, Sumti)] -> [Sumti] -> Maybe Minde + +midste, narmidste :: [(String, Midytcidu)] +midste = [ + ("klama", klama), + ("crakla", crakla), + ("rixykla", rixykla), + ("carna", carna), + ("clugau", clugau), + ("galfi", galfi), + ("pilno", pilno), + ("cisni", cisni), + ("cisnygau", cisnygau), + ("viska", viska), + ("rapli", rapli), + ("xruti", xruti), + ("morji", morji), + ("gasnu", gasnu), + ("rejgau", rejgau), + ("tcidu", tcidu)] +narmidste = [ + ("pilno", napilno), + ("viska", naviska)] + +apply :: Monad m => [Sumti] -> Sumti -> (Sumti -> m a) -> m a +apply args (CEhU i) cmd + | length args >= i = cmd $ args !! (i - 1) + | otherwise = fail "apply: too few args" +apply _ sumti cmd = cmd sumti + +apply2 :: Monad m => [Sumti] -> Sumti -> Sumti -> (Sumti -> Sumti -> m a) -> m a +apply2 args s1 s2 cmd = apply args s2 =<< apply args s1 (return . cmd) + +klama, crakla, rixykla, carna, clugau, galfi, pilno, cisni, cisnygau, viska, + rapli, xruti, morji, gasnu, rejgau, tcidu, napilno, naviska :: Midytcidu + +klama terms args = do + KOhA "ko" <- lookup (FA 1) terms + selkla <- lookup (FA 2) terms + apply args selkla $ \sk -> case sk of + LI (JOhI [Number x, Number y]) -> return $ KLAMA x y + _ -> return $ SRERA $ show terms ++ " " ++ show args + +crakla terms args = do + KOhA "ko" <- lookup (FA 1) terms + return . CRAKLA . fromMaybe 100 $ la'u terms args + +rixykla terms args = do + KOhA "ko" <- lookup (FA 1) terms + return . RIXYKLA . fromMaybe 100 $ la'u terms args + +carna terms args = do + KOhA "ko" <- lookup (FA 1) terms + farna <- case lookup (FA 3) terms of + Nothing -> return "zunle" + Just far -> apply args far $ \f -> case f of + LO (Brivla zp) _ -> return zp + _ -> fail "carna: bad direction" + ($ fromMaybe 90 $ la'u terms args) <$> case farna of + "zunle" -> return ZUNLE + "pritu" -> return PRITU + _ -> fail "carna: bad direction" + +la'u :: [(Tag, Sumti)] -> [Sumti] -> Maybe Double +la'u terms args = do + klani <- lookup (BAI 1 "la'u") terms + apply args klani $ \k -> case k of + LI (Number n) -> return n + _ -> fail "la'u: not number" + +clugau terms _ = do + KOhA "ko" <- lookup (FA 1) terms + case ((Time ["co'a"], KU) `elem` terms, + (Time ["co'u"], KU) `elem` terms) of + (True, False) -> return COhACLUGAU + (False, True) -> return COhUCLUGAU + _ -> fail "clugau: bad tense" + +galfi terms args = do + TUhA (KOhA "ko") <- lookup (FA 1) terms + LO (Brivla "foldi") Nothing <- lookup (FA 2) terms + terga'i <- lookup (FA 3) terms + apply args terga'i $ \skasu'i -> case skasu'i of + LO (Brivla skale'u) Nothing -> do + skari <- lookup skale'u skaste + return $ let (r, g, b) = skari in FLOSKA r g b + _ -> return $ SRERA $ "galfi: " ++ show terms ++ " " ++ show args + +pilno terms args = do + KOhA "ko" <- lookup (FA 1) terms + sp <- lookup (FA 2) terms + apply args sp $ selpli terms args . be2poi + +selpli :: [(Tag, Sumti)] -> [Sumti] -> Sumti -> Maybe Minde +selpli terms args (LO (Brivla "penbi") (Just (POI bridi))) = do + peb <- penbi args bridi + return $ if (Time ["ba"], KU) `elem` terms + then peb + else MIDYSTE [peb, PILNOLOPENBI] +selpli terms _ (LO (Brivla "penbi") Nothing) + | (Time ["ba"], KU) `elem` terms = return $ MIDYSTE [] + | otherwise = return PILNOLOPENBI +selpli _ args (LO (Brivla "burcu") (Just (POI bridi))) = burcu args bridi +selpli terms args (Relative sp r) = apply args sp $ \pb -> case pb of + LO (Brivla "penbi") _ -> selpli terms args (LO (Brivla "penbi") (Just r)) + LO (Brivla "burcu") _ -> selpli terms args (LO (Brivla "burcu") (Just r)) + _ -> fail "selpli: bad selpli" +selpli _ _ sp = return $ SRERA $ "selpli: unknown selpli " ++ show sp + +penbi :: [Sumti] -> Text -> Maybe Minde +penbi _ (Bridi (Brivla skari) []) = pebyska skari +penbi args (Bridi (Brivla "penbi") [(FA 2, skari)]) = applyLO args skari pebyska +penbi args (Bridi (ME skari) []) = applyLO args skari pebyska +penbi args (Bridi (Brivla "cisni") [(FA 2, cisnysu'i)]) = + apply args cisnysu'i $ \cs -> case cs of + LI (Number cisnyna'u) -> return $ PEBYCISNI cisnyna'u + _ -> fail "bad" +penbi _ relative = return $ SRERA $ "penbi: no such penbi" ++ show relative + +pebyska :: String -> Maybe Minde +pebyska skari = uncurry3 PEBYSKA <$> lookup skari skaste + +burcu :: [Sumti] -> Text -> Maybe Minde +burcu _ (Bridi (Brivla skari) []) = burska skari +burcu args (Bridi (ME skari) []) = applyLO args skari burska +burcu args (Bridi (SE 2 (Brivla "skari")) [(FA 1, skari)]) = + applyLO args skari burska +burcu args (Bridi (Brivla "skari") [(FA 2, skari)]) = + applyLO args skari burska +burcu _ relative = return $ SRERA $ "burcu: no such burcu" ++ show relative + +burska :: String -> Maybe Minde +burska skari = uncurry3 BURSKA <$> lookup skari skaste + +applyLO :: Monad m => [Sumti] -> Sumti -> (String -> m a) -> m a +applyLO args sumti cmd = apply args sumti $ \su'i -> case su'i of + LO (Brivla lerfu) Nothing -> cmd lerfu + _ -> fail $ "applyLO: bad sumti " ++ show su'i + +be2poi :: Sumti -> Sumti +be2poi (LO (BE selbri (SFIhO modal sumti)) Nothing) = + LO selbri $ Just $ POI $ Bridi modal [(FA 1, sumti)] +be2poi (LO (BE selbri sumti) Nothing) = + LO selbri $ Just $ POI $ Bridi selbri [(FA 2, sumti)] +be2poi sumti = sumti + +cisni terms args = do + KOhA "ko" <- lookup (FA 1) terms + csn <- lookup (FA 2) terms + apply args csn $ \c -> case c of + LI (Number n) -> return $ CISNI n + _ -> return $ SRERA $ "cisni: " ++ show terms + +cisnygau terms args = do + KOhA "ko" <- lookup (FA 1) terms + LO (Brivla "foldi") _ <- lookup (FA 2) terms + csn <- lookup (FA 3) terms + apply args csn $ \sk -> case sk of + LI (JOhI [Number x, Number y]) -> return $ CISNYGAUFOLDI x y + _ -> return $ SRERA $ show terms ++ " " ++ show args + +viska terms _ = do + KOhA "ko" <- lookup (FA 2) terms + return VISKA + +rapli terms args = do + fasnu <- lookup (FA 1) terms + namcu <- lookup (FA 2) terms + apply2 args fasnu namcu $ \fau nac -> case (fau, nac) of + (LO (NU f) _, LI (Number n)) -> + return $ MIDYSTE $ replicate (round n) (jmi f []) + _ -> return $ SRERA $ show terms + +xruti terms _ = do + KOhA "ko" <- lookup (FA 1) terms + return XRUTI + +morji terms args = do + KOhA "ko" <- lookup (FA 1) terms + GOI lerfu duhu <- lookup (FA 2) terms + apply2 args lerfu duhu $ \ler d -> case (ler, d) of + (LerfuString cmene, LO (DUhU fasnu) _) -> + return $ MORJI cmene $ jmi fasnu + _ -> return $ SRERA $ "morji: " ++ show terms + +gasnu terms args = do + KOhA "ko" <- lookup (FA 1) terms + LerfuString cmene <- lookup (FA 2) terms + return $ GASNU cmene args + +rejgau terms args = do + KOhA "ko" <- lookup (FA 1) terms + cmene <- lookup (BAI 1 "me'e") terms + setai <- lookup (BAI 2 "tai") terms + apply2 args cmene setai $ \cme st -> case (cme, st) of + (ZOI fp, LA (Right (Brivla "cakyrespa"))) -> + return $ REJGAUSETAICAK fp + (ZOI fp, LA (Left "syvygyd")) -> + return $ REJGAUSETAISVG fp + (ZOI fp, LA (Left "lojban")) -> + return $ REJGAUSETAIJBO fp + _ -> return $ SRERA $ "rejgau: " ++ show setai + +tcidu terms args = do + KOhA "ko" <- lookup (FA 1) terms + setai <- lookup (BAI 2 "tai") terms + apply args setai $ \st -> case st of + (LA (Right (Brivla "cakyrespa"))) -> do + sumti <- lookup (FA 2) terms + fps <- apply args sumti $ \smt -> case smt of + LA (Right (ME fps)) -> return fps + LAhE fps -> return fps + _ -> fail "tcidu: bad" + apply args fps $ \smt -> case smt of + ZOI fp -> return $ TCIDU fp + _ -> fail "tcidu: bad" + (LA (Left "lojban")) -> do + sumti <- lookup (FA 2) terms + fps <- apply args sumti $ \smt -> case smt of + LA (Right (ME fps)) -> return fps + LAhE fps -> return fps + _ -> fail "tcidu: bad" + apply args fps $ \smt -> case smt of + ZOI fp -> return $ TCIDUSETAIJBO fp + _ -> fail "tcidu: bad" + _ -> fail "tcidu: bad" + +napilno terms _ = do + KOhA "ko" <- lookup (FA 1) terms + return NAPILNOLOPENBI + +naviska terms _ = do + KOhA "ko" <- lookup (FA 2) terms + return NAVISKA diff --git a/src/Klesi.hs b/src/Klesi.hs new file mode 100644 --- /dev/null +++ b/src/Klesi.hs @@ -0,0 +1,88 @@ +module Klesi ( + Minde(..), + Text(..), Selbri(..), Tag(..), Sumti(..), Mex(..), RelativeClause(..) +) where + +import Language.Lojban.Parser(Free(..)) + +-------------------------------------------------------------------------------- + +data Minde + = KLAMA Double Double + | CRAKLA Double | RIXYKLA Double + | ZUNLE Double | PRITU Double + | COhACLUGAU | COhUCLUGAU + | PEBYCISNI Double | PEBYSKA Int Int Int + | BURSKA Int Int Int | FLOSKA Int Int Int + | NAPILNOLOPENBI | PILNOLOPENBI + | NAVISKA | VISKA + | CISNI Double | CISNYGAUFOLDI Double Double + | XRUTI + | MORJI String ([Sumti] -> Minde) | GASNU String [Sumti] + | REJGAUSETAIJBO FilePath | TCIDUSETAIJBO FilePath + | REJGAUSETAICAK FilePath | TCIDU FilePath + | REJGAUSETAISVG FilePath + | COhO + | MIDYSTE [Minde] + | SRERA String + +data Text + = Bridi Selbri [(Tag, Sumti)] + | Prenex [Sumti] Text + | TagGI String Text Text + | Vocative String + | Free [Free] + | MultiText [Text] + | UnknownText String + | ParseError String + deriving (Show, Eq) + +data Selbri + = Brivla String + | NA Selbri + | SE Int Selbri + | BE Selbri Sumti + | ME Sumti + | NU Text + | DUhU Text + | UnknownSelbri String + deriving (Show, Eq) + +data Tag + = FA Int + | BAI Int String + | FIhO Selbri + | Time [String] + | UnknownTag String + deriving (Show, Eq) + +data Sumti + = KU + | CEhUPre + | CEhU Int + | KOhA String + | LA (Either String Selbri) + | LE Selbri + | LO Selbri (Maybe RelativeClause) + | LI Mex + | LerfuString String + | ZOI String + | TUhA Sumti + | LAhE Sumti + | GOI Sumti Sumti + | Relative Sumti RelativeClause + | STense String Sumti Sumti + | SFIhO Selbri Sumti + | UnknownSumti String + deriving (Show, Eq) + +data Mex + = Number Double + | JOhI [Mex] + | UnknownMex String + deriving (Show, Eq) + +data RelativeClause + = POI Text + | UnknownRelativeClause String + deriving (Show, Eq) diff --git a/src/Language/Lojban/Read.hs b/src/Language/Lojban/Read.hs deleted file mode 100644 --- a/src/Language/Lojban/Read.hs +++ /dev/null @@ -1,295 +0,0 @@ -module Language.Lojban.Read ( - Lojban(..), - Selbri(..), - Sumti(..), - Tag(..), - Mex(..), - RelativeClause(..), - readLojban -) where - -import Language.Lojban.Parser hiding ( - Tag, Sumti, Selbri, KOhA, FA, Brivla, BAI, Number, LI, RelativeClause, - Time, KU, Linkargs, FIhO, NU, NA, LA, ZOI, ME, JOhI, SE, GOI, - LerfuString, Prenex) -import qualified Language.Lojban.Parser as P -import Data.Maybe -import Data.Char -import Control.Arrow - -data Lojban - = Bridi Selbri [(Tag, Sumti)] - | TenseGI String Lojban Lojban - | Vocative String - | Free [Free] - | Prenex [Sumti] Lojban - | ParseError String - | NotImplemented String - deriving (Show, Eq) - -data Selbri - = Brivla String - | Linkargs Selbri Sumti - | NU Lojban - | DUhU Lojban - | NotImplementedSelbri String - | NA Selbri - | ME Sumti - | SE Int Selbri - deriving (Show, Eq) - -data Sumti - = KOhA String - | CEhU Int - | CEhUPre - | LA (Either String Selbri) - | LE Selbri - | LO Selbri (Maybe RelativeClause) - | LI Mex - | KU - | SFIhO Selbri Sumti - | ZOI String - | TUhA Sumti - | GOI Sumti Sumti - | LerfuString String - | STense String Sumti Sumti - | NotImplementedSumti String - deriving (Show, Eq) - -data RelativeClause - = POI Lojban - | Debug String - | NotImplementedRelativeClause String - deriving (Show, Eq) - -data Mex - = Number Double - | JOhI [Mex] - | NotImplementedMex String - deriving (Show, Eq) - -data Tag - = FA Int - | FIhO Selbri - | BAI (Maybe String) String - | Time [String] - | NotImplementedTag String - deriving (Show, Eq) - -readLojban :: String -> Lojban -readLojban = processSE . either (ParseError . show) (process 1) . parse - -processSE :: Lojban -> Lojban -processSE (Bridi (NA (SE n selbri)) ss) = processSE $ - Bridi (NA selbri) $ map (first $ flipTag n) ss -processSE (Bridi (SE n selbri) ss) = processSE $ - Bridi selbri $ map (first $ flipTag n) ss -processSE l = l - -processCEhU :: Int -> [(Tag, Sumti)] -> [(Tag, Sumti)] -processCEhU n [] = [] -processCEhU n ((t, CEhUPre) : rest) = (t, CEhU n) : processCEhU (n + 1) rest -processCEhU n ((t, (LO s (Just (POI (Bridi (ME CEhUPre) ss))))) : rest) = - (t, LO s $ Just $ POI $ Bridi (ME $ CEhU n) ss) : processCEhU (n + 1) rest -processCEhU n (s : rest) = s : processCEhU n rest - -countc :: Text -> Int -countc = countCEhU 0 . (\(Bridi _ s) -> s) . process' - -countCEhU :: Int -> [(Tag, Sumti)] -> Int -countCEhU n [] = n -countCEhU n ((t, CEhUPre) : rest) = countCEhU (n + 1) rest -countCEhU n ((t, (LO s (Just (POI (Bridi (ME CEhUPre) ss))))) : rest) = - countCEhU (n + 1) rest -countCEhU n (_ : rest) = countCEhU n rest - -flipTag :: Int -> Tag -> Tag -flipTag n (FA f) - | f == 1 = FA n - | f == n = FA 1 -flipTag _ t = t - -process n s = case process' s of - Bridi selbri terms -> Bridi selbri (processCEhU n terms) - r -> r - -process' :: Text -> Lojban -process' (TopText _ _ [VocativeSumti [(_, v, _)] _ _] Nothing Nothing Nothing) = - Vocative v -process' (IText_1 _ _ _ [VocativeSumti [(_, v, _)] _ _] Nothing) = Vocative v -process' (IText_1 _ _ _ fs@(_ : _) Nothing) = Free fs -process' (IText_1 _ _ _ _ (Just t)) = process 1 t -process' (P.Prenex ss (_, "zo'u", _) _ t) = Prenex (map readSumti ss) $ process 1 t -process' (TermsBridiTail ss _ _ (SelbriTailTerms selbri ts _ _)) = - Bridi (readSelbri selbri) $ processTagSumti ss ts -process' (TermsBridiTail ss _ _ (P.Selbri selbri)) = - Bridi (readSelbri selbri) $ processTagSumti ss [] -process' (TermsBridiTail ss _ _ - (GekSentence - (STagGik - (P.Time _ [((_, tense, _), _, _)] _ _) - ((_, "gi", _), _, _)) - t ((_, "gi", _), _, _) u _ _ _)) = - TenseGI tense - (process 1 $ TermsBridiTail ss undefined undefined t) - (process (1 + - (countc $ TermsBridiTail ss undefined undefined t)) $ - TermsBridiTail ss undefined undefined u) -process' (GekSentence - (STagGik - (P.Time _ [((_, tense, _), _, _)] _ _) - ((_, "gi", _), _, _)) - t ((_, "gi", _), _, _) u _ _ _) = - TenseGI tense - (process 1 t) - (process 1 u) -process' (P.Selbri selbri) = Bridi (readSelbri selbri) [] -process' (P.SelbriTailTerms selbri ts _ _) = - Bridi (readSelbri selbri) $ processTagSumti [] ts -process' t = NotImplemented $ "process: " ++ show t - -processTagSumti :: [P.Sumti] -> [P.Sumti] -> [(Tag, Sumti)] -processTagSumti s t = let - (n, e, r) = readTagSumti 1 [] [] s - (_, _, r') = readTagSumti (if n > 1 then n else 2) e [] t in r ++ r' - -readTagSumti :: Int -> [Int] -> [(Tag, Sumti)] -> [P.Sumti] - -> (Int, [Int], [(Tag, Sumti)]) -readTagSumti n e r [] = (n, e, reverse r) -readTagSumti n e r (TagSumti t s : rest) = case readTag t of - (Just i, tag) -> readTagSumti (next i e) (i : e) ((tag, sumti) : r) rest - (_, tag) -> readTagSumti n e ((tag, sumti) : r) rest - where - sumti = readSumti s -readTagSumti n e r (s : rest) = - readTagSumti (next n e) (n : e) ((FA n, readSumti s) : r) rest - -readTag :: P.Tag -> (Maybe Int, Tag) -readTag (P.FA (_, f, _) _) = let n = fromJust $ lookup f faList in (Just n, FA n) -readTag (P.BAI _ Nothing (_, b, _) _ _) = (Nothing, BAI Nothing b) -readTag (P.BAI _ (Just (_, s, _)) (_, b, _) _ _) = (Nothing, BAI (Just s) b) -readTag (P.Time _ [((_, t, _), Nothing, Nothing)] _ _) = - (Nothing, Time [t]) -readTag (P.Time _ _ _ ts) = (Nothing, Time $ map readTime ts) -readTag t = (Nothing, NotImplementedTag $ "readTag: " ++ show t) - -readTime :: IntervalProperty -> String -readTime (ZAhO (_, z, _) _) = z -readTime ip = "readTime: " ++ show ip - -faList :: [(String, Int)] -faList = [ - ("fa", 1), - ("fe", 2), - ("fi", 3), - ("fo", 4), - ("fu", 5) - ] - -readSumti :: P.Sumti -> Sumti -readSumti (P.KOhA (_, "ce'u", _) [XINumber (_, "xi", _) _ [([], pa, [])] _]) = - CEhU $ round $ paToInt [pa] -readSumti (P.KOhA (_, "ce'u", _) []) = CEhUPre -readSumti s@(P.KOhA (_, "ce'u", _) f) = NotImplementedSumti $ show s -readSumti (P.KOhA (_, k, _) _) = KOhA k -readSumti (LALE (_, "lo", _) _ st _ _) = LO selbri relative - where (selbri, relative) = readSumtiTail st -readSumti (LALE (_, "la", _) _ st _ _) = LA $ Right selbri - where (selbri, _relative) = readSumtiTail st -readSumti (P.LA (_, "la", _) _ _ [(_, n, _)] _) = LA $ Left n -readSumti (P.LI _ _ m _ _) = LI $ readMex m -readSumti (P.KU _ _) = KU -readSumti (TagSumti (P.FIhO (_, "fi'o", _) _ selbri _ _) sumti) = - SFIhO (readSelbri selbri) (readSumti sumti) -readSumti (P.ZOI _ "zoi" ws _ _) = ZOI $ processZOI $ concat ws -readSumti (P.LAhE_NAhE (_, "tu'a", _) _ _ _ s _ _) = TUhA $ readSumti s -readSumti (P.OuterQuantifier _ s (Just (P.GOI (_, "goi", _) _ t _ _))) = - GOI (readSumti s) (readSumti t) -readSumti (P.LerfuString ls _ _) = LerfuString $ concatMap (\(_, s, _) -> s) ls -readSumti (GekSumti - (STagGik (P.Time _ [((_, pu, _), _, _)] _ _) ((_, "gi", _), _, _)) - s ((_, "gi", _), _, _) t) = STense pu (readSumti s) (readSumti t) -readSumti s = NotImplementedSumti $ "readSumti: " ++ show s - -processZOI :: String -> String -processZOI ('.' : str) = let ('.' : s) = reverse str in - dropWhile isSpace $ reverse $ dropWhile isSpace s - -readMex :: Operand -> Mex -readMex (P.Number n _ _) = readNumber n -readMex (P.JOhI (_, "jo'i", _) _ ns _ _) = JOhI $ map readMex ns -readMex o = NotImplementedMex $ "readMex: " ++ show o - -readNumber :: [Clause] -> Mex -readNumber = Number . paToInt . map (\(_, p, _) -> p) - -processKIhO :: [String] -> [String] -processKIhO = reverse . pk 3 . reverse - where - pk _ [] = [] - pk n ("ki'o" : rest) = replicate n "no" ++ pk 3 rest - pk n (pa : rest) - | n > 0 = pa : pk (n - 1) rest - | otherwise = pa : pk 2 rest - -paToInt :: [String] -> Double -paToInt ("ni'u" : pas) = - (pti $ reverse $ processKIhO pas) -paToInt pas = pti $ reverse $ processKIhO pas - -pti [] = 0 -pti (p : rest) = fromJust (lookup' p paList) + 10 * pti rest - -lookup' :: Eq a => a -> [([a], b)] -> Maybe b -lookup' _ [] = Nothing -lookup' x ((xs, y) : ys) - | x `elem` xs = Just y - | otherwise = lookup' x ys - -paList :: [([String], Double)] -paList = [ - (["no", "0"], 0), - (["pa", "1"], 1), - (["re", "2"], 2), - (["ci", "3"], 3), - (["vo", "4"], 4), - (["mu", "5"], 5), - (["xa", "6"], 6), - (["ze", "7"], 7), - (["bi", "8"], 8), - (["so", "9"], 9) - ] - -readSumtiTail :: SumtiTail -> (Selbri, Maybe RelativeClause) -readSumtiTail (SelbriRelativeClauses s Nothing) = - (readSelbri s, Nothing) -readSumtiTail (SelbriRelativeClauses s (Just r)) = - (readSelbri s, Just $ readRelativeClauses r) -readSumtiTail st = (NotImplementedSelbri $ "readSumtiTail: " ++ show st, Nothing) - -readRelativeClauses :: P.RelativeClause -> RelativeClause -readRelativeClauses (NOI (_, "poi", _) _ bridi _ _) = - POI $ process 1 bridi -readRelativeClauses r = Debug $ show r - -readSelbri :: P.Selbri -> Selbri -readSelbri (P.Brivla (_, b, _) _) = Brivla $ map toLower b -readSelbri (P.Linkargs selbri (BE (_, "be", _) _ sumti _ _ _)) = - Linkargs (readSelbri selbri) (readSumti sumti) -readSelbri (P.NU (_, "nu", _) _ _ _ bridi _ _) = NU $ process 1 bridi -readSelbri (P.NU (_, "du'u", _) _ _ _ bridi _ _) = DUhU $ process 1 bridi -readSelbri (P.NA (_, "na", _) _ s) = NA $ readSelbri s -readSelbri (P.ME (_, "me", _) _ s _ _ _ _) = ME $ readSumti s -readSelbri (P.SE (_, se, _) _ s) = SE (fromJust $ lookup se seList) $ readSelbri s -readSelbri s = NotImplementedSelbri $ "readSelbri: " ++ show s - -seList = [ - ("se", 2), - ("te", 3), - ("ve", 4), - ("xe", 5) - ] - -next :: Int -> [Int] -> Int -next n e - | (n + 1) `elem` e = next (n + 1) e - | otherwise = n + 1 diff --git a/src/Liste.hs b/src/Liste.hs new file mode 100644 --- /dev/null +++ b/src/Liste.hs @@ -0,0 +1,93 @@ +module Liste (skaste, mezofatcidu, mezosetcidu, mezopatcidu) where + +import Data.Maybe + +skaste :: [(String, (Int, Int, Int))] +skaste = [ + ("xekri", (0, 0, 0)), + ("blabi", (255, 255, 255)), + + ("xunre", (255, 0, 0)), + ("labri'o", (0, 255, 0)), -- Lime + ("crinyblabi", (0, 255, 0)), -- Lime + ("blanu", (0, 0, 255)), + + ("pelxu", (255, 255, 0)), + ("cicna", (0, 255, 255)), + ("nukni", (255, 0, 255)), + + ("rijyska", (192, 192, 192)), -- Silver + ("grusi", (128, 128, 128)), + +-- ("?", (128, 0, 0)), -- Maroon + ("alzaityska", (128, 128, 0)), -- Olive + ("crino", (0, 128, 0)), + ("zirpu", (128, 0, 128)), -- Purple +-- ("?", (0, 128, 128)), -- Teal +-- ("?", (0, 0, 128)), -- Navy + + ("bunre", (165, 42, 42)), -- Brown + ("narju", (255, 165, 0)), -- Orange + ("sloska", (255, 215, 0)), -- Gold + ("xunblabi", (255, 192, 203)) -- Pink + ] + +mezofatcidu :: String -> Int +mezofatcidu = fromJust . flip lookup mezofaliste + +mezofaliste :: [(String, Int)] +mezofaliste = [ + ("fa", 1), + ("fe", 2), + ("fi", 3), + ("fo", 4), + ("fu", 5) + ] + +mezopatcidu :: [String] -> Double +mezopatcidu ("ni'u" : pas) = - (pti $ reverse $ processKIhO pas) +mezopatcidu pas = pti $ reverse $ processKIhO pas + +pti :: [String] -> Double +pti [] = 0 +pti (p : rest) = fromJust (lookup' p mezopaliste) + 10 * pti rest + +lookup' :: Eq a => a -> [([a], b)] -> Maybe b +lookup' _ [] = Nothing +lookup' x ((xs, y) : ys) + | x `elem` xs = Just y + | otherwise = lookup' x ys + +processKIhO :: [String] -> [String] +processKIhO = reverse . pk 3 . reverse + where + pk _ [] = [] + pk n ("ki'o" : rest) = replicate n "no" ++ pk 3 rest + pk n (pa : rest) + | n > 0 = pa : pk (n - 1) rest + | otherwise = pa : pk 2 rest + +mezopaliste :: [([String], Double)] +mezopaliste = [ + (["no", "0"], 0), + (["pa", "1"], 1), + (["re", "2"], 2), + (["ci", "3"], 3), + (["vo", "4"], 4), + (["mu", "5"], 5), + (["xa", "6"], 6), + (["ze", "7"], 7), + (["bi", "8"], 8), + (["so", "9"], 9) + ] + +mezosetcidu :: String -> Int +mezosetcidu = fromJust . flip lookup mezoseliste + +mezoseliste :: [(String, Int)] +mezoseliste = [ + ("se", 2), + ("te", 3), + ("ve", 4), + ("xe", 5) + ] diff --git a/src/Minde.hs b/src/Minde.hs new file mode 100644 --- /dev/null +++ b/src/Minde.hs @@ -0,0 +1,68 @@ +module Minde (minde) where + +import Klesi(Minde(..), Sumti) + +import Text.XML.YJSVG(showSVG) +import Graphics.UI.GLUT.Turtle(setFieldSize, + Field, outputString, + Turtle, runInputs, inputs, getSVG, + goto, forward, backward, left, right, beginfill, endfill, undo, + penup, pendown, hideturtle, showturtle, shapesize, + pensize, pencolor, fillcolor, bgcolor, windowWidth, windowHeight) + +import Control.Applicative((<$>)) +import Data.IORef(IORef, readIORef) +import Data.IORef.Tools(atomicModifyIORef_) + +-------------------------------------------------------------------------------- + +vabytcidu :: Eq a => a -> IORef [(a, b)] -> IO (Maybe b) +vabytcidu cmene vanbi = lookup cmene <$> readIORef vanbi + +vabyciha :: a -> b -> IORef [(a, b)] -> IO () +vabyciha cmene fasnu vanbi = atomicModifyIORef_ vanbi ((cmene, fasnu) :) + +minde :: Field -> Turtle -> IORef [(String, [Sumti] -> Minde)] -> Minde -> IO Bool +minde _ t _ (KLAMA x y) = goto t x y >> return True +minde _ t _ (CRAKLA d) = forward t d >> return True +minde _ t _ (RIXYKLA d) = backward t d >> return True +minde _ t _ (ZUNLE d) = left t d >> return True +minde _ t _ (PRITU d) = right t d >> return True +minde _ t _ COhACLUGAU = beginfill t >> return True +minde _ t _ COhUCLUGAU = endfill t >> return True +minde _ t _ (PEBYCISNI s) = pensize t s >> return True +minde _ t _ (PEBYSKA r g b) = pencolor t (r, g, b) >> return True +minde _ t _ (BURSKA r g b) = fillcolor t (r, g, b) >> return True +minde _ t _ (FLOSKA r g b) = bgcolor t (r, g, b) >> return True +minde _ t _ NAPILNOLOPENBI = penup t >> return True +minde _ t _ PILNOLOPENBI = pendown t >> return True +minde _ t _ NAVISKA = hideturtle t >> return True +minde _ t _ VISKA = showturtle t >> return True +minde _ t _ (CISNI s) = shapesize t s s >> return True +minde f _ _ (CISNYGAUFOLDI w h) = setFieldSize f w h >> return True +minde _ t _ XRUTI = undo t >> return True +minde _ _ vanbi (MORJI cmene fasnu) = vabyciha cmene fasnu vanbi >> return True +minde f t vanbi (GASNU cmene sumti) = vabytcidu cmene vanbi >>= + minde f t vanbi . maybe (SRERA $ "not defined: " ++ cmene) ($ sumti) +minde _ t _ (REJGAUSETAICAK fp) = inputs t >>= writeFile fp . show >> return True +minde _ t _ (TCIDU fp) = readFile fp >>= runInputs t . read >> return True +minde _ t _ (REJGAUSETAISVG fp) = do + w <- windowWidth t + h <- windowHeight t + svg <- getSVG t + writeFile fp $ showSVG w h svg + return True +minde _ _ _ (REJGAUSETAIJBO _) = return True +minde _ _ _ (TCIDUSETAIJBO _) = return True +minde _ _ _ COhO = return False +minde f t vanbi (MIDYSTE cl) = mapWhile (minde f t vanbi) cl +minde f _ _ (SRERA str) = do + outputString f ".i mi na jimpe" + putStrLn $ "error: " ++ str + return True + +mapWhile :: Monad m => (a -> m Bool) -> [a] -> m Bool +mapWhile _ [] = return True +mapWhile f (x : xs) = do + b <- f x + if b then mapWhile f xs else return False diff --git a/src/Tcidu.hs b/src/Tcidu.hs new file mode 100644 --- /dev/null +++ b/src/Tcidu.hs @@ -0,0 +1,213 @@ +module Tcidu(parse) where + +import Control.Arrow(first, second) +import Data.Maybe(catMaybes) +import Data.Char(isSpace, toLower) +import qualified Language.Lojban.Parser as P( + parse, Text, Clause, + Sentence(..), Gek(..), Free(..), IntervalProperty(..), + Selbri(..), Linkargs(..), + Tag(..), Sumti(..), SumtiTail(..), RelativeClause(..), Operand(..)) +import Klesi( + Text(..), Selbri(..), Tag(..), Sumti(..), Mex(..), RelativeClause(..)) +import Liste(mezofatcidu, mezosetcidu, mezopatcidu) + +-------------------------------------------------------------------------------- + +parse :: String -> Text +parse = either (ParseError . show) (snd . process 1) . P.parse + +process :: Int -> P.Text -> (Int, Text) +process n ptext = second flipText $ proc n ptext + where + flipText (Bridi (NA (SE i selbri)) terms) = + flipText $ Bridi (NA selbri) $ flipTerms i terms + flipText (Bridi (SE i selbri) terms) = + flipText $ Bridi selbri $ flipTerms i terms + flipText text = text + flipTerms i = map $ first flipTag + where + flipTag (FA f) + | f == 1 = FA i + | f == i = FA 1 + flipTag t = t + +some :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +some _ x0 [] = (x0, []) +some f x0 (y : ys) = let + (x1, z) = f x0 y + (x', zs) = some f x1 ys in + (x', z : zs) + +proc :: Int -> P.Text -> (Int, Text) +proc n (P.TopText _ _ _ _ (Just t) _) = proc n t +proc n (P.TopText _ _ [P.VocativeSumti [(_, v, _)] _ _] _ _ _) = (n, Vocative v) +proc n (P.TopText _ _ fs@(_ : _) _ _ _) = (n, Free fs) +proc n (P.IText_1 _ _ _ _ (Just t)) = proc n t +proc n (P.IText_1 _ _ _ [P.VocativeSumti [(_, v, _)] _ _] _) = (n, Vocative v) +proc n (P.IText_1 _ _ _ fs@(_ : _) _) = (n, Free fs) +proc n (P.StatementI ptext iptexts) = + (0, MultiText $ map snd $ map (proc 1) $ ptext : ptexts) + where + ptexts = catMaybes $ map (\(_, _, t) -> t) iptexts +proc n (P.Selbri selbri) = (n, Bridi (readSelbri selbri) []) +proc n (P.SelbriTailTerms pselbri pterms _ _) = (n', Bridi selbri terms) + where selbri = readSelbri pselbri + (n', terms) = processTagSumti n [] pterms +proc n (P.TermsBridiTail pterms _ _ (P.Selbri pselbri)) = (n', Bridi selbri terms) + where selbri = readSelbri pselbri + (n', terms) = processTagSumti n pterms [] +proc n (P.TermsBridiTail pterms1 _ _ (P.SelbriTailTerms pselbri pterms2 _ _)) = + (n', Bridi selbri terms) + where selbri = readSelbri pselbri + (n', terms) = processTagSumti n pterms1 pterms2 +proc n (P.Prenex psumti (_, "zo'u", _) _ t) = (n', Prenex sumti ret) + where sumti = map readSumti psumti + (n', ret) = process n t +proc n (P.PrenexSentence psumti (_, "zo'u", _) _ t) = (n', Prenex sumti ret) + where sumti = map readSumti psumti + (n', ret) = process n t +proc n (P.TermsBridiTail ss _ _ + (P.GekSentence + (P.STagGik + (P.Time _ [((_, tense, _), _, _)] _ _) + ((_, "gi", _), _, _)) + t ((_, "gi", _), _, _) u _ _ _)) = + (n2, TagGI tense ret1 ret2) + where + (n1, ret1) = process n $ P.TermsBridiTail ss undefined undefined t + (n2, ret2) = process n1 $ P.TermsBridiTail ss undefined undefined u +proc n (P.GekSentence + (P.STagGik + (P.Time _ [((_, tense, _), _, _)] _ _) + ((_, "gi", _), _, _)) + t ((_, "gi", _), _, _) u _ _ _) = + (n, TagGI tense (snd $ process n t) (snd $ process n u)) +proc n t = (n, UnknownText $ "proc: " ++ show t) + +processTagSumti :: Int -> [P.Sumti] -> [P.Sumti] -> (Int, [(Tag, Sumti)]) +processTagSumti n = curry $ processCEhU n . uncurry pTagSumti + where + pTagSumti s t = let + (n', e, r) = readTagSumti 1 [] [] s + (_, _, r') = readTagSumti (if n' > 1 then n' else 2) e [] t in + r ++ r' + +processCEhU :: Int -> [(Tag, Sumti)] -> (Int, [(Tag, Sumti)]) +processCEhU n [] = (n, []) +processCEhU n ((t, sumti) : rest) = (n', (t, ce'u n) : terms') + where + (b, ce'u) = pCEhU sumti + (n', terms') = processCEhU (n + b) rest + +pCEhU :: Sumti -> (Int, Int -> Sumti) +pCEhU CEhUPre = (1, CEhU) +pCEhU (LO selbri (Just (POI (Bridi (ME sumti) ss)))) = let (b, s) = pCEhU sumti in + (b, \n -> LO selbri $ Just $ POI $ Bridi (ME $ s n) ss) +pCEhU (LO (BE selbri sumti) Nothing) = let (b, s) = pCEhU sumti in + (b, \n -> LO (BE selbri $ s n) Nothing) +pCEhU (SFIhO modal sumti) = + let (b, s) = pCEhU sumti in (b, SFIhO modal . s) +pCEhU (GOI sumti1 sumti2) = + let (b1, s1) = pCEhU sumti1; (b2, s2) = pCEhU sumti2 in + (b1 + b2, \n -> GOI (s1 n) (s2 $ b1 + n)) +pCEhU (LA (Right (ME sumti))) = + let (b, s) = pCEhU sumti in (b, LA . Right . ME . s) +pCEhU (Relative sumti r) = let (b, s) = pCEhU sumti in (b, flip Relative r . s) +pCEhU (LAhE sumti) = let (b, s) = pCEhU sumti in (b, LAhE . s) +pCEhU sumti = (0, const sumti) + +readTagSumti :: Int -> [Int] -> [(Tag, Sumti)] -> [P.Sumti] + -> (Int, [Int], [(Tag, Sumti)]) +readTagSumti n e r [] = (n, e, reverse r) +readTagSumti n e r (P.TagSumti t s : rest) = case readTag t of + (Just i, tag) -> readTagSumti (next i e) (i : e) ((tag, sumti) : r) rest + (_, tag) -> readTagSumti n e ((tag, sumti) : r) rest + where + sumti = readSumti s +readTagSumti n e r (s : rest) = + readTagSumti (next n e) (n : e) ((FA n, readSumti s) : r) rest + +readTag :: P.Tag -> (Maybe Int, Tag) +readTag (P.FA (_, f, _) _) = (Just $ mezofatcidu f, FA $ mezofatcidu f) +readTag (P.BAI _ Nothing (_, b, _) _ _) = (Nothing, BAI 1 b) +readTag (P.BAI _ (Just (_, s, _)) (_, b, _) _ _) = + (Nothing, BAI (mezosetcidu s) b) +readTag (P.Time _ [((_, t, _), Nothing, Nothing)] _ _) = (Nothing, Time [t]) +readTag (P.Time _ _ _ ts) = (Nothing, Time $ map readTime ts) +readTag t = (Nothing, UnknownTag $ "readTag: " ++ show t) + +readTime :: P.IntervalProperty -> String +readTime (P.ZAhO (_, z, _) _) = z +readTime ip = "readTime: " ++ show ip + +readSumti :: P.Sumti -> Sumti +readSumti (P.KOhA (_, "ce'u", _) [P.XINumber (_, "xi", _) _ [([], pa, [])] _]) = + CEhU $ round $ mezopatcidu [pa] +readSumti (P.KOhA (_, "ce'u", _) []) = CEhUPre +readSumti s@(P.KOhA (_, "ce'u", _) f) = + UnknownSumti $ show s ++ " " ++ show f +readSumti (P.KOhA (_, k, _) _) = KOhA k +readSumti (P.LALE (_, "lo", _) _ st _ _) = LO selbri relative + where (selbri, relative) = readSumtiTail st +readSumti (P.LALE (_, "la", _) _ st _ _) = LA $ Right selbri + where (selbri, _relative) = readSumtiTail st +readSumti (P.LA (_, "la", _) _ _ [(_, n, _)] _) = LA $ Left n +readSumti (P.LI _ _ m _ _) = LI $ readMex m +readSumti (P.KU _ _) = KU +readSumti (P.TagSumti (P.FIhO (_, "fi'o", _) _ selbri _ _) sumti) = + SFIhO (readSelbri selbri) (readSumti sumti) +readSumti (P.ZOI _ "zoi" ws _ _) = ZOI $ processZOI $ concat ws +readSumti (P.LAhE_NAhE (_, "tu'a", _) _ _ _ s _ _) = TUhA $ readSumti s +readSumti (P.OuterQuantifier _ s (Just (P.GOI (_, "goi", _) _ t _ _))) = + GOI (readSumti s) (readSumti t) +readSumti (P.OuterQuantifier _ s (Just r)) = + Relative (readSumti s) (readRelativeClauses r) +readSumti (P.LerfuString ls _ _) = LerfuString $ concatMap (\(_, s, _) -> s) ls +readSumti (P.GekSumti + (P.STagGik (P.Time _ [((_, pu, _), _, _)] _ _) ((_, "gi", _), _, _)) + s ((_, "gi", _), _, _) t) = STense pu (readSumti s) (readSumti t) +readSumti (P.LAhE_NAhE (_, "la'e", _) _ _ _ s _ _) = LAhE $ readSumti s +readSumti s = UnknownSumti $ "readSumti: " ++ show s + +processZOI :: String -> String +processZOI ('.' : str) = let ('.' : s) = reverse str in + dropWhile isSpace $ reverse $ dropWhile isSpace s +processZOI str = let ('.' : s) = reverse str in + dropWhile isSpace $ reverse $ dropWhile isSpace s + +readMex :: P.Operand -> Mex +readMex (P.Number n _ _) = readNumber n +readMex (P.JOhI (_, "jo'i", _) _ ns _ _) = JOhI $ map readMex ns +readMex o = UnknownMex $ "readMex: " ++ show o + +readNumber :: [P.Clause] -> Mex +readNumber = Number . mezopatcidu . map (\(_, p, _) -> p) + +readSumtiTail :: P.SumtiTail -> (Selbri, Maybe RelativeClause) +readSumtiTail (P.SelbriRelativeClauses s Nothing) = + (readSelbri s, Nothing) +readSumtiTail (P.SelbriRelativeClauses s (Just r)) = + (readSelbri s, Just $ readRelativeClauses r) +readSumtiTail st = (UnknownSelbri $ "readSumtiTail: " ++ show st, Nothing) + +readRelativeClauses :: P.RelativeClause -> RelativeClause +readRelativeClauses (P.NOI (_, "poi", _) _ bridi _ _) = + POI $ snd $ process 1 bridi +readRelativeClauses r = UnknownRelativeClause $ show r + +readSelbri :: P.Selbri -> Selbri +readSelbri (P.Brivla (_, b, _) _) = Brivla $ map toLower b +readSelbri (P.Linkargs selbri (P.BE (_, "be", _) _ sumti _ _ _)) = + BE (readSelbri selbri) (readSumti sumti) +readSelbri (P.NU (_, "nu", _) _ _ _ bridi _ _) = NU $ snd $ process 1 bridi +readSelbri (P.NU (_, "du'u", _) _ _ _ bridi _ _) = DUhU $ snd $ process 1 bridi +readSelbri (P.NA (_, "na", _) _ s) = NA $ readSelbri s +readSelbri (P.ME (_, "me", _) _ s _ _ _ _) = ME $ readSumti s +readSelbri (P.SE (_, se, _) _ s) = SE (mezosetcidu se) $ readSelbri s +readSelbri s = UnknownSelbri $ "readSelbri: " ++ show s + +next :: Int -> [Int] -> Int +next n e + | (n + 1) `elem` e = next (n + 1) e + | otherwise = n + 1 diff --git a/src/cakyrespa.hs b/src/cakyrespa.hs --- a/src/cakyrespa.hs +++ b/src/cakyrespa.hs @@ -1,379 +1,41 @@ module Main where -import Graphics.UI.GLUT hiding (R, Repeat) -import Graphics.UI.GLUT.Turtle -import Text.XML.YJSVG +import Minde(minde) +import Jimpe(jimpe) +import Tcidu(parse) +import Klesi(Text(ParseError), Minde(REJGAUSETAIJBO, TCIDUSETAIJBO)) -import Language.Lojban.Read +import Graphics.UI.GLUT(mainLoop) +import Graphics.UI.GLUT.Turtle( + initialize, openField, prompt, oninputtext, + newTurtle, notundo, shape, shapesize) +import Data.IORef(newIORef, readIORef) +import Data.IORef.Tools(atomicModifyIORef_) -import System.Environment -import System.IO.Unsafe -import Data.Maybe -import Data.IORef -import Data.IORef.Tools -import Control.Applicative -import Control.Monad +-------------------------------------------------------------------------------- + main :: IO () main = do - prgName <- getProgName - rawArgs <- getArgs - _args <- initialize prgName rawArgs + _args <- initialize f <- openField "cakyrespa" 640 480 - prompt f ".i " t <- newTurtle f --- pencolor t ((255, 255, 255) :: (Int, Int, Int)) --- fillcolor t ((255, 255, 255) :: (Int, Int, Int)) + env <- newIORef [] + cmds <- newIORef [] + prompt f ".i " shape t "turtle" shapesize t 3 3 - oninputtext f (processInput f t . cmd) + notundo t + oninputtext f $ \cmd -> do + let p = parse cmd + j = jimpe p + case (p, j) of + (_, REJGAUSETAIJBO fp) -> + writeFile fp . unlines . reverse =<< readIORef cmds + (_, TCIDUSETAIJBO fp) -> + readFile fp >>= minde f t env . jimpe . parse + >> return () + (ParseError _, _) -> return () + _ -> atomicModifyIORef_ cmds ((".i" ++ cmd) :) + minde f t env j mainLoop - -cmd :: String -> Command -cmd = flip pcmd [] . readLojban - -pcmd :: Lojban -> [Argument] -> Command -pcmd p = case p of - Vocative "co'o" -> const COhO - TenseGI "ba" b c -> \args -> Commands (pcmd b args) (pcmd c args) - Prenex ss b -> const $ CommandList $ do - rss <- mapM sumtiToArgument ss - return $ pcmd b rss - b@(Bridi (Brivla "gasnu") s) -> - \args -> fromMaybe (Unknown b) $ readGasnu s args - b@(Bridi (Brivla "morji") s) -> const $ fromMaybe (Unknown b) $ readMorji s - b@(Bridi (Brivla "klama") s) -> const $ fromMaybe (Unknown b) $ readKlama s - b@(Bridi (Brivla "galfi") s) -> const $ fromMaybe (Unknown b) $ readGalfi s - b@(Bridi (Brivla "tcidu") s) -> const $ fromMaybe (Unknown b) $ readTcidu s - b@(Bridi (Brivla "rejgau") s) -> const $ fromMaybe (Unknown b) $ readRejgau s - b@(Bridi (Brivla "viska") s) -> const $ fromMaybe (Unknown b) $ readViska s - b@(Bridi (NA (Brivla "viska")) s) -> const $ fromMaybe (Unknown b) $ readNAViska s - b@(Bridi (Brivla "cisni") s) -> const $ fromMaybe (Unknown b) $ readCisni s - b@(Bridi (Brivla "xruti") s) -> const $ fromMaybe (Unknown b) $ readXruti s - b@(Bridi (Brivla "rapli") s) -> const $ fromMaybe (Unknown b) $ readRapli s - b@(Bridi (Brivla "carna") s) -> fromMaybe (const $ Unknown b) $ readCarna s - b@(Bridi (Brivla "crakla") s) -> fromMaybe (const $ Unknown b) $ readCrakla s - b@(Bridi (Brivla "rixykla") s) -> const $ fromMaybe (Unknown b) $ readRixykla s - b@(Bridi (Brivla "pilno") s) -> - fromMaybe (const $ Unknown b) $ readBAPilno s - b@(Bridi (NA (Brivla "pilno")) s) -> const $ fromMaybe (Unknown b) $ readNAPilno s - b@(Bridi (Brivla "clugau") s) -> const $ fromMaybe (Unknown b) $ readClugau s - r -> const $ Unknown r - -updateReaders :: (Lojban -> Maybe Command) -> Lojban -> Maybe ([Argument] -> Command) -updateReaders reader text = do - c <- reader text - return $ const c - -readGasnu s a = do - KOhA "ko" <- lookup (FA 1) s - LerfuString cmene <- lookup (FA 2) s - return $ GASNU cmene a - -readMorji s = do - KOhA "ko" <- lookup (FA 1) s - GOI (LerfuString cmene) (LO (DUhU fasnu) _) <- lookup (FA 2) s - return $ MORJI cmene $ pcmd fasnu - -readKlama s = do - KOhA "ko" <- lookup (FA 1) s - LI (JOhI [Number x, Number y]) <- lookup (FA 2 ) s - return $ KLAMA x y - -readGalfi s = do - TUhA (KOhA "ko") <- lookup (FA 1) s - LO (Brivla "foldi") Nothing <- lookup (FA 2) s - LO (Brivla skari) Nothing <- lookup (FA 3) s - clr <- lookup skari skaste - return $ let (r, g, b) = clr in FLOSKA r g b - -readTcidu s = do - KOhA "ko" <- lookup (FA 1) s - LA (Right (ME (ZOI fp))) <- lookup (FA 2) s - return $ READFILE fp - -readRejgau s = do - KOhA "ko" <- lookup (FA 1) s - ZOI fp <- lookup (BAI Nothing "me'e") s - tai <- lookup (BAI (Just "se") "tai") s - case tai of - LA (Right (Brivla "cakyrespa")) -> return $ SAVEASCAK fp - LA (Left "syvygyd") -> return $ SAVEASSVG fp - s -> error $ show s - -readViska :: [(Tag, Sumti)] -> Maybe Command -readViska s = do - KOhA "ko" <- lookup (FA 2) s - return VISKA - -readNAViska :: [(Tag, Sumti)] -> Maybe Command -readNAViska s = do - KOhA "ko" <- lookup (FA 2) s - return NAVISKA - -readNAPilno :: [(Tag, Sumti)] -> Maybe Command -readNAPilno s = do - KOhA "ko" <- lookup (FA 1) s - return NAPILNOLOPENBI - -readCisni :: [(Tag, Sumti)] -> Maybe Command -readCisni s = do - LI (Number n) <- lookup (FA 1) s - KOhA "ko" <- lookup (FA 2) s - return $ CISNI n - -readXruti :: [(Tag, Sumti)] -> Maybe Command -readXruti s = do - KOhA "ko" <- lookup (FA 1) s - return $ XRUTI - -readRapli :: [(Tag, Sumti)] -> Maybe Command -readRapli s = do - LO (NU p) _ <- lookup (FA 1) s - LI (Number n) <- lookup (FA 2) s - return $ Repeat (round n) (pcmd p []) - -readClugau :: [(Tag, Sumti)] -> Maybe Command -readClugau s = do - KOhA "ko" <- lookup (FA 1) s - case ((Time ["co'a"], KU) `elem` s, (Time ["co'u"], KU) `elem` s) of - (True, False) -> return COhACLUGAU - (False, True) -> return COhUCLUGAU - _ -> fail "bad" - -readBAPilno :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) -readBAPilno s = do - cm <- readPilno s - if (Time ["ba"], KU) `elem` s then return cm - else return $ \args -> Commands (cm args) PILNOLOPENBI - -readPilno :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) -readPilno s = do - KOhA "ko" <- lookup (FA 1) s - selpli <- lookup (FA 2) s - case selpli of - LO (Brivla "penbi") (Just (POI (Bridi (Brivla "cisni") [ - (FA 1, LI (Number size))]))) -> - return $ const $ PEBYCISNI size - LO (Linkargs (Brivla "penbi") (SFIhO (Brivla "cisni") (LI - (Number size)))) _ -> return $ const $ PEBYCISNI size - LO (Brivla "penbi") (Just (POI (Bridi (Brivla skari) []))) -> do - (r, g, b) <- lookup skari skaste - return $ const $ PEBYSKA r g b - LO (Linkargs (Brivla "penbi") (LO (Brivla skari) _)) _ -> do - (r, g, b) <- lookup skari skaste - return $ const $ PEBYSKA r g b - LO (Brivla "penbi") (Just (POI (Bridi (ME me) []))) -> do - case me of - LO (Brivla skari) _ -> do - (r, g, b) <- lookup skari skaste - return $ const $ PEBYSKA r g b - CEhU i -> return $ \args -> - fromMaybe (ErrorC "bad args") $ do - skari <- getALO args i - pebska <- mapM colorNameToPEBYSKA skari - return $ CommandList pebska - LO (Brivla "burcu") (Just (POI (Bridi (Brivla skari) []))) -> do - (r, g, b) <- lookup skari skaste - return $ const $ BURSKA r g b - LO (Linkargs (Brivla "burcu") (SFIhO (Brivla "skari") (LO - (Brivla skari) _))) _ -> do - (r, g, b) <- lookup skari skaste - return $ const $ BURSKA r g b - LO (Brivla "penbi") Nothing -> return $ const PILNOLOPENBI - _ -> return $ const $ UnknownSelpli selpli - - -colorNameToPEBYSKA :: String -> Maybe Command -colorNameToPEBYSKA skari = do - (r, g, b) <- lookup skari skaste - return $ PEBYSKA r g b - -skaste :: [(String, (Int, Int, Int))] -skaste = [ - ("xekri", (0, 0, 0)), - ("blabi", (255, 255, 255)), - - ("xunre", (255, 0, 0)), - ("labri'o", (0, 255, 0)), -- Lime - ("crinyblabi", (0, 255, 0)), -- Lime - ("blanu", (0, 0, 255)), - - ("pelxu", (255, 255, 0)), - ("cicna", (0, 255, 255)), - ("nukni", (255, 0, 255)), - - ("rijyska", (192, 192, 192)), -- Silver - ("grusi", (128, 128, 128)), - --- ("?", (128, 0, 0)), -- Maroon - ("alzaityska", (128, 128, 0)), -- Olive - ("crino", (0, 128, 0)), - ("zirpu", (128, 0, 128)), -- Purple --- ("?", (0, 128, 128)), -- Teal --- ("?", (0, 0, 128)), -- Navy - - ("bunre", (165, 42, 42)), -- Brown - ("narju", (255, 165, 0)), -- Orange - ("sloska", (255, 215, 0)), -- Gold - ("xunblabi", (255, 192, 203)) -- Pink - ] - -readLAhU2 :: [(Tag, Sumti)] -> Maybe (Either Double Int) -readLAhU2 s = do - lahu <- lookup (BAI Nothing "la'u") s - case lahu of - LI (Number d) -> return $ Left d - CEhU i -> return $ Right i - _ -> fail "bad" - -readCrakla :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) -readCrakla s = do - KOhA "ko" <- lookup (FA 1) s - return $ case readLAhU2 s of - Just (Left d) -> const $ CRAKLA d - Just (Right i) -> \args -> if length args < i - then ErrorC $ "too few args " ++ show i ++ " for " ++ - show (length args) - else case args !! (i - 1) of - ADouble d -> CRAKLA d - _ -> ErrorC "bad argument" - _ -> const $ CRAKLA 100 --- return $ const $ CRAKLA $ maybe 100 (\(Left d) -> d) $ readLAhU2 s - -readRixykla :: [(Tag, Sumti)] -> Maybe Command -readRixykla s = do - KOhA "ko" <- lookup (FA 1) s - return $ RIXYKLA $ maybe 100 (\(Left d) -> d) $ readLAhU2 s - -readCarna :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) -readCarna s = do - KOhA "ko" <- lookup (FA 1) s - LO (Brivla lr) _ <- return $ --- let LO (Brivla lr) _ = - fromMaybe (LO (Brivla "zunle") Nothing) $ lookup (FA 3) s --- d = maybe 90 (\(Left d) -> d) $ readLAhU2 s - let d = fromMaybe (Left 90) $ readLAhU2 s - case lr of - "zunle" -> return $ flip (either $ const . ZUNLE) d $ \i args -> - maybe (ErrorC "bad args") ZUNLE $ getDouble args i - "pritu" -> return $ flip (either $ const . PRITU) d $ \i args -> - maybe (ErrorC "bad args") PRITU $ getDouble args i - _ -> fail "bad" - -getDouble :: [Argument] -> Int -> Maybe Double -getDouble args i = do - when (length args < i) $ fail "bad" - ADouble d <- return $ args !! (i - 1) - return d - -getALO :: [Argument] -> Int -> Maybe [String] -getALO args i = do - when (length args < i) $ fail "bad" - ALO s <- return $ args !! (i - 1) - return [s] - -data Argument - = ADouble Double - | AInt Int - | ACommand Command - | ALO String - | ACons Argument Argument --- deriving Show - -sumtiToArgument (LI (Number n)) = [ADouble n] -sumtiToArgument (LO (Brivla s) _) = [ALO s] -sumtiToArgument (STense "ba" s_ t_) = - sumtiToArgument s_ ++ - sumtiToArgument t_ -sumtiToArgument s = error $ "sumtiToArgument :" ++ show s - -data Command - = KLAMA Double Double - | CRAKLA Double | RIXYKLA Double - | ZUNLE Double | PRITU Double - | PEBYCISNI Double - | PEBYSKA Int Int Int - | BURSKA Int Int Int - | FLOSKA Int Int Int - | COhACLUGAU - | COhUCLUGAU - | Commands Command Command - | CommandList [Command] - | Repeat Int Command - | XRUTI - | CISNI Double - | NAPILNOLOPENBI - | PILNOLOPENBI - | NAVISKA - | VISKA - | SAVEASSVG FilePath - | SAVEASCAK FilePath - | READFILE FilePath - | MORJI String ([Argument] -> Command) - | GASNU String [Argument] - | COhO | Unknown Lojban | ParseErrorC | UnknownSelpli Sumti - | ErrorC String --- deriving Show - -type Table = [(String, [Argument] -> Command)] -theTable :: IORef Table -theTable = unsafePerformIO $ newIORef [] -morji :: String -> ([Argument] -> Command) -> IO () -morji cmene fasnu = atomicModifyIORef_ theTable ((cmene, fasnu) :) -tcidu :: String -> IO (Maybe ([Argument] -> Command)) -tcidu cmene = lookup cmene <$> readIORef theTable - -data LR = L | R | BadLR deriving Show - -processInput :: Field -> Turtle -> Command -> IO Bool -processInput _ t (KLAMA x y) = goto t x y >> return True -processInput _ t (CRAKLA d) = forward t d >> return True -processInput _ t (RIXYKLA d) = backward t d >> return True -processInput _ t (ZUNLE d) = left t d >> return True -processInput _ t (PRITU d) = right t d >> return True -processInput _ t (PEBYCISNI s) = pensize t s >> return True -processInput _ t (PEBYSKA r g b) = pencolor t (r, g, b) >> return True -processInput _ t (BURSKA r g b) = fillcolor t (r, g, b) >> return True -processInput _ t (FLOSKA r g b) = bgcolor t (r, g, b) >> return True -processInput _ t COhACLUGAU = beginfill t >> return True -processInput _ t COhUCLUGAU = endfill t >> return True -processInput _ t XRUTI = undo t >> return True -processInput _ t (CISNI s) = shapesize t s s >> return True -processInput _ t NAPILNOLOPENBI = penup t >> return True -processInput _ t PILNOLOPENBI = pendown t >> return True -processInput _ t NAVISKA = hideturtle t >> return True -processInput _ t VISKA = showturtle t >> return True -processInput _ _ COhO = return False -processInput f t (Commands c d) = processInput f t c >> processInput f t d -processInput f t (CommandList cl) = - mapM_ (processInput f t) cl >> return True -processInput f t (Repeat n c) = sequence_ (replicate n (processInput f t c)) >> - return True -processInput f t (MORJI cmene fasnu) = morji cmene fasnu >> return True -processInput f t (GASNU cmene sumti) = do - mfasnu <- tcidu cmene - flip (maybe $ processInput f t $ ErrorC $ "not defined: " ++ cmene) mfasnu $ - \fasnu -> processInput f t $ fasnu sumti -processInput _ t (SAVEASSVG fp) = do - w <- windowWidth t - h <- windowHeight t - svg <- getSVG t - writeFile fp $ showSVG w h svg - return True -processInput _ t (SAVEASCAK fp) = inputs t >>= writeFile fp . show >> return True -processInput _ t (READFILE fp) = readFile fp >>= runInputs t . read >> return True -processInput f _ (Unknown u) = do - outputString f ".i mi na jimpe" - putStr "Unknown " >> print u - return True -processInput f _ (UnknownSelpli us) = do - outputString f ".i mi na djuno lo bi'unai selpli" - putStr "Unknown " >> print us - return True -processInput f _ ParseErrorC = do - outputString f ".i di'u na drani fo lo gerna" - return True -processInput f _ (ErrorC str) = do - putStrLn $ "error: " ++ str - return True