cakyrespa 0.0.14 → 0.0.15
raw patch · 3 files changed
+222/−71 lines, 3 filesdep +yjtoolsdep ~gluturtle
Dependencies added: yjtools
Dependency ranges changed: gluturtle
Files
- cakyrespa.cabal +2/−2
- src/Language/Lojban/Read.hs +63/−20
- src/cakyrespa.hs +157/−49
cakyrespa.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: cakyrespa-version: 0.0.14+version: 0.0.15 stability: Alpha license: BSD3 license-file: LICENSE@@ -26,5 +26,5 @@ main-is: cakyrespa.hs other-modules: Language.Lojban.Read build-depends: base >3 && <5, lojbanParser >= 0.1.5,- gluturtle >= 0.0.18, GLUT, yjsvg+ gluturtle >= 0.0.20, GLUT, yjsvg, yjtools >= 0.9.16 ghc-options: -Wall
src/Language/Lojban/Read.hs view
@@ -10,7 +10,8 @@ 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)+ 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@@ -21,6 +22,7 @@ | TenseGI String Lojban Lojban | Vocative String | Free [Free]+ | Prenex [Sumti] Lojban | ParseError String | NotImplemented String deriving (Show, Eq)@@ -29,6 +31,7 @@ = Brivla String | Linkargs Selbri Sumti | NU Lojban+ | DUhU Lojban | NotImplementedSelbri String | NA Selbri | ME Sumti@@ -37,6 +40,8 @@ data Sumti = KOhA String+ | CEhU Int+ | CEhUPre | LA (Either String Selbri) | LE Selbri | LO Selbri (Maybe RelativeClause)@@ -45,6 +50,9 @@ | SFIhO Selbri Sumti | ZOI String | TUhA Sumti+ | GOI Sumti Sumti+ | LerfuString String+ | STense String Sumti Sumti | NotImplementedSumti String deriving (Show, Eq) @@ -69,7 +77,7 @@ deriving (Show, Eq) readLojban :: String -> Lojban-readLojban = processSE . either (ParseError . show) process . parse+readLojban = processSE . either (ParseError . show) (process 1) . parse processSE :: Lojban -> Lojban processSE (Bridi (NA (SE n selbri)) ss) = processSE $@@ -78,43 +86,67 @@ 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 :: Text -> Lojban-process (TopText _ _ [VocativeSumti [(_, v, _)] _ _] Nothing Nothing Nothing) =+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 t-process (TermsBridiTail ss _ _ (SelbriTailTerms selbri ts _ _)) =+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)) =+process' (TermsBridiTail ss _ _ (P.Selbri selbri)) = Bridi (readSelbri selbri) $ processTagSumti ss []-process (TermsBridiTail ss _ _+process' (TermsBridiTail ss _ _ (GekSentence (STagGik (P.Time _ [((_, tense, _), _, _)] _ _) ((_, "gi", _), _, _)) t ((_, "gi", _), _, _) u _ _ _)) = TenseGI tense- (process $ TermsBridiTail ss undefined undefined t)- (process $ TermsBridiTail ss undefined undefined u)-process (GekSentence+ (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 $ t)- (process $ u)-process (P.Selbri selbri) = Bridi (readSelbri selbri) []-process (P.SelbriTailTerms selbri ts _ _) =+ (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+process' t = NotImplemented $ "process: " ++ show t processTagSumti :: [P.Sumti] -> [P.Sumti] -> [(Tag, Sumti)] processTagSumti s t = let@@ -155,6 +187,10 @@ ] 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@@ -167,6 +203,12 @@ 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@@ -226,14 +268,15 @@ readRelativeClauses :: P.RelativeClause -> RelativeClause readRelativeClauses (NOI (_, "poi", _) _ bridi _ _) =- POI $ process 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 bridi+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
src/cakyrespa.hs view
@@ -7,7 +7,12 @@ import Language.Lojban.Read 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@@ -25,29 +30,51 @@ mainLoop cmd :: String -> Command-cmd = pcmd . readLojban+cmd = flip pcmd [] . readLojban +pcmd :: Lojban -> [Argument] -> Command pcmd p = case p of- (Vocative "co'o") -> COhO- (TenseGI "ba" b c) -> Commands (pcmd b) (pcmd c)- b@(Bridi (Brivla "klama") s) -> fromMaybe (Unknown b) $ readKlama s- b@(Bridi (Brivla "galfi") s) -> fromMaybe (Unknown b) $ readGalfi s- b@(Bridi (Brivla "tcidu") s) -> fromMaybe (Unknown b) $ readTcidu s- b@(Bridi (Brivla "rejgau") s) -> fromMaybe (Unknown b) $ readRejgau s- b@(Bridi (Brivla "viska") s) -> fromMaybe (Unknown b) $ readViska s- b@(Bridi (NA (Brivla "viska")) s) -> fromMaybe (Unknown b) $ readNAViska s- b@(Bridi (Brivla "cisni") s) -> fromMaybe (Unknown b) $ readCisni s- b@(Bridi (Brivla "xruti") s) -> fromMaybe (Unknown b) $ readXruti s- b@(Bridi (Brivla "rapli") s) -> fromMaybe (Unknown b) $ readRapli s- b@(Bridi (Brivla "carna") s) -> fromMaybe (Unknown b) $ readCarna s- b@(Bridi (Brivla "crakla") s) -> fromMaybe (Unknown b) $ readCrakla s- b@(Bridi (Brivla "rixykla") s) -> fromMaybe (Unknown b) $ readRixykla s+ 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 (Unknown b) $ readBAPilno s- b@(Bridi (NA (Brivla "pilno")) s) -> fromMaybe (Unknown b) $ readNAPilno s- b@(Bridi (Brivla "clugau") s) -> fromMaybe (Unknown b) $ readClugau s- r -> Unknown r+ 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@@ -104,7 +131,7 @@ readRapli s = do LO (NU p) _ <- lookup (FA 1) s LI (Number n) <- lookup (FA 2) s- return $ Repeat (round n) (pcmd p)+ return $ Repeat (round n) (pcmd p []) readClugau :: [(Tag, Sumti)] -> Maybe Command readClugau s = do@@ -114,37 +141,54 @@ (False, True) -> return COhUCLUGAU _ -> fail "bad" -readBAPilno :: [(Tag, Sumti)] -> Maybe Command+readBAPilno :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) readBAPilno s = do cm <- readPilno s if (Time ["ba"], KU) `elem` s then return cm- else return $ Commands cm PILNOLOPENBI+ else return $ \args -> Commands (cm args) PILNOLOPENBI -readPilno :: [(Tag, Sumti)] -> Maybe Command+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 $ PEBYCISNI size+ (FA 1, LI (Number size))]))) ->+ return $ const $ PEBYCISNI size LO (Linkargs (Brivla "penbi") (SFIhO (Brivla "cisni") (LI- (Number size)))) _ -> return $ PEBYCISNI size+ (Number size)))) _ -> return $ const $ PEBYCISNI size LO (Brivla "penbi") (Just (POI (Bridi (Brivla skari) []))) -> do (r, g, b) <- lookup skari skaste- return $ PEBYSKA r g b+ return $ const $ PEBYSKA r g b LO (Linkargs (Brivla "penbi") (LO (Brivla skari) _)) _ -> do (r, g, b) <- lookup skari skaste- return $ PEBYSKA r g b+ 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 $ BURSKA r g b+ return $ const $ BURSKA r g b LO (Linkargs (Brivla "burcu") (SFIhO (Brivla "skari") (LO (Brivla skari) _))) _ -> do (r, g, b) <- lookup skari skaste- return $ BURSKA r g b- LO (Brivla "penbi") Nothing -> return PILNOLOPENBI- _ -> return $ UnknownSelpli selpli+ 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)),@@ -175,32 +219,75 @@ ("xunblabi", (255, 192, 203)) -- Pink ] -readLAhU2 :: [(Tag, Sumti)] -> Maybe Double+readLAhU2 :: [(Tag, Sumti)] -> Maybe (Either Double Int) readLAhU2 s = do- LI (Number d) <- lookup (BAI Nothing "la'u") s- return d+ 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 Command+readCrakla :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) readCrakla s = do KOhA "ko" <- lookup (FA 1) s- return $ CRAKLA $ fromMaybe 100 $ readLAhU2 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 $ fromMaybe 100 $ readLAhU2 s+ return $ RIXYKLA $ maybe 100 (\(Left d) -> d) $ readLAhU2 s -readCarna :: [(Tag, Sumti)] -> Maybe Command+readCarna :: [(Tag, Sumti)] -> Maybe ([Argument] -> Command) readCarna s = do KOhA "ko" <- lookup (FA 1) s- let LO (Brivla lr) _ =+ LO (Brivla lr) _ <- return $+-- let LO (Brivla lr) _ = fromMaybe (LO (Brivla "zunle") Nothing) $ lookup (FA 3) s- d = fromMaybe 90 $ readLAhU2 s+-- d = maybe 90 (\(Left d) -> d) $ readLAhU2 s+ let d = fromMaybe (Left 90) $ readLAhU2 s case lr of- "zunle" -> return $ ZUNLE d- "pritu" -> return $ PRITU d+ "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@@ -212,6 +299,7 @@ | COhACLUGAU | COhUCLUGAU | Commands Command Command+ | CommandList [Command] | Repeat Int Command | XRUTI | CISNI Double@@ -222,10 +310,20 @@ | SAVEASSVG FilePath | SAVEASCAK FilePath | READFILE FilePath- | COhO | Unknown Lojban | ParseErrorC- | UnknownSelpli Sumti- deriving Show+ | 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@@ -248,8 +346,15 @@ 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@@ -258,14 +363,17 @@ 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 _ u@(Unknown _) = do+processInput f _ (Unknown u) = do outputString f ".i mi na jimpe"- print u+ putStr "Unknown " >> print u return True-processInput f _ u@(UnknownSelpli _) = do+processInput f _ (UnknownSelpli us) = do outputString f ".i mi na djuno lo bi'unai selpli"- print u+ 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