tttool 1.1 → 1.3
raw patch · 4 files changed
+83/−54 lines, 4 filesdep ~bytestringdep ~filepathdep ~text
Dependency ranges changed: bytestring, filepath, text
Files
- src/GMERun.hs +57/−26
- src/Language.hs +6/−14
- src/TextToSpeech.hs +6/−9
- tttool.cabal +14/−5
src/GMERun.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE FlexibleContexts #-} module GMERun (playTipToi) where import Text.Printf import Data.Bits import Data.List import qualified Data.Map as M+import Control.Monad.State import Types import PrettyPrint@@ -11,6 +13,8 @@ type PlayState r = M.Map r Word16 +type GMEM r = StateT (PlayState r) IO+ formatState :: PlayState ResReg -> String formatState s = spaces $ map (\(k,v) -> printf "$%d=%d" k v) $@@ -21,18 +25,26 @@ playTipToi t tt = do let initialState = M.fromList $ zip [0..] (ttInitialRegs tt) printf "Initial state (not showing zero registers): %s\n" (formatState initialState)- forEachNumber initialState $ \i s -> do+ flip evalStateT initialState $ forEachNumber $ untilNothing $ \i -> do case lookup (fromIntegral i) (ttScripts tt) of- Nothing -> printf "OID %d not in main table\n" i >> return s- Just Nothing -> printf "OID %d deactivated\n" i >> return s+ Nothing -> do+ lift $ printf "OID %d not in main table\n" i+ return Nothing+ Just Nothing -> do+ lift $ printf "OID %d deactivated\n" i+ return Nothing Just (Just lines) -> do- case find (enabledLine s) lines of- Nothing -> printf "None of these lines matched!\n" >> mapM_ (putStrLn . ppLine t) lines >> return s+ code <- gets $ \s -> find (enabledLine s) lines+ case code of+ Nothing -> lift $ do+ printf "None of these lines matched!\n"+ mapM_ (putStrLn . ppLine t) lines+ return Nothing Just l -> do- printf "Executing: %s\n" (ppLine t l)- let s' = applyLine l s- printf "State now: %s\n" (formatState s')- return s'+ lift $ printf "Executing: %s\n" (ppLine t l)+ next <- applyLine l+ get >>= lift . printf "State now: %s\n" . formatState+ return next enabledLine :: Ord r => PlayState r -> Line r -> Bool enabledLine s (Line _ cond _ _) = all (condTrue s) cond@@ -51,13 +63,31 @@ value m (Reg r) = M.findWithDefault 0 r m value m (Const n) = n -applyLine :: Ord r => Line r -> PlayState r -> PlayState r-applyLine (Line _ _ act _) s = foldl' go s act+getVal :: (Ord r, MonadState (PlayState r) m) => TVal r -> m Word16+getVal v = gets $ \s -> value s v++modReg :: (Ord r, MonadState (PlayState r) m) => r -> (Word16 -> Word16) -> m ()+modReg r f = do+ x <- getVal (Reg r)+ modify $ M.insert r (f x)++applyLine :: (Ord r, MonadState (PlayState r) m) => Line r -> m (Maybe Word16)+applyLine (Line _ _ acts _) = go acts where- go s (Neg r) = M.insert r (neg (s `value` Reg r)) s- go s (ArithOp o r n) = M.insert r (applyOp o (s `value` Reg r) (s `value` n)) s- go s (Jump n) = error "Playing scripts with the J command is not yet implemented. Please file a bug."- go s _ = s+ go (Neg r : acts) = do+ modReg r neg+ go acts+ go (ArithOp o r v : acts) = do+ arg <- getVal v+ let (*) = applyOp o+ modReg r (* arg)+ go acts+ go (Jump v: _ ) = do+ n <- getVal v+ return (Just n)+ go (_: acts) = do+ go acts+ go [] = return Nothing neg 0 = 1 neg _ = 0@@ -73,16 +103,17 @@ applyOp Set = \_ v -> v +untilNothing :: Monad m => (a -> m (Maybe a)) -> a -> m ()+untilNothing f i = do+ r <- f i+ case r of Just i' -> untilNothing f i'+ Nothing -> return () -forEachNumber :: s -> (Int -> s -> IO s) -> IO ()-forEachNumber state action = go state- where- go s = do- putStrLn "Next OID touched? "- str <- getLine- case readMaybe str of- Just i -> action i s >>= go- Nothing -> do- putStrLn "Not a number, please try again"- go s+forEachNumber :: (Word16 -> StateT s IO ()) -> StateT s IO ()+forEachNumber action = forever $ do+ lift $ putStrLn "Next OID touched? "+ str <- lift $ getLine+ case readMaybe str of+ Just i -> action i+ Nothing -> lift $ putStrLn "Not a number, please try again"
src/Language.hs view
@@ -1,28 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}-module Language where+module Language where import Data.Aeson.Types-import Control.Monad-import Data.Text-+import Control.Applicative ((<$>)) -data Language = En | De | Fr+newtype Language = Language String defaultLanguage :: Language-defaultLanguage = En+defaultLanguage = Language "en" ppLang :: Language -> String-ppLang En = "en"-ppLang De = "de"-ppLang Fr = "fr"+ppLang (Language l) = l instance ToJSON Language where toJSON = toJSON . ppLang instance FromJSON Language where- parseJSON (String "en") = return En- parseJSON (String "de") = return De- parseJSON (String "fr") = return Fr- parseJSON (String s) = fail $ "Unknown language \"" ++ unpack s ++ "\"."- parseJSON _ = mzero+ parseJSON s = Language <$> parseJSON s
src/TextToSpeech.hs view
@@ -31,27 +31,24 @@ ("pico2wave", ["--wave", tmp, "--lang", l, txt]) where l = case lang of - En -> "en-GB"- De -> "de-DE"- Fr -> "fr-FR"+ Language "en" -> "en-GB"+ Language "de" -> "de-DE"+ Language "fr" -> "fr-FR"+ Language s -> s espeak :: Language -> FilePath -> String -> (String, [String]) espeak lang tmp txt = ("espeak", ["-v", l, "-w", tmp, "-s", "120", txt]) where l = case lang of - En -> "en"- De -> "de"- Fr -> "fr"+ Language s -> s espeak_contrib :: Language -> FilePath -> String -> (String, [String]) espeak_contrib lang tmp txt = ("./contrib/espeak", ["-v", l, "-w", tmp, "-s", "120", txt]) where l = case lang of - En -> "en"- De -> "de"- Fr -> "fr"+ Language s -> s engines :: Language -> FilePath -> String -> [(String, [String])]
tttool.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: tttool-version: 1.1+version: 1.3 synopsis: Working with files for the Tiptoi® pen description: The Ravensburger Tiptoi® pen is programmed via special files. Their file format has been reverse engineered; this@@ -25,6 +25,8 @@ If true then depend on time < 1.5 together with old-locale. default: False +Flag bytestring_has_builder+ default: True executable tttool main-is: tttool.hs@@ -50,19 +52,17 @@ build-depends: base == 4.5.* || == 4.6.* || == 4.7.* || == 4.8.*, binary == 0.5.* || == 0.7.*,- bytestring == 0.10.*, containers == 0.4.* || == 0.5.*, directory == 1.2.*,- filepath == 1.3.*,+ filepath == 1.3.* || == 1.4.*, template-haskell >= 2.7 && < 2.11, ghc-prim, JuicyPixels == 3.1.* || == 3.2.*, aeson == 0.7.* || == 0.8.*,- bytestring-builder >= 0.10.4.1.1, hashable == 1.2.*, mtl == 2.1.* || == 2.2.*,- text == 0.11.* || == 1.2.*,+ text >= 0.11 && < 1.3, parsec == 3.1.*, process == 1.1.* || == 1.2.*, unordered-containers == 0.2.*,@@ -73,6 +73,15 @@ build-depends: time == 1.4.*, old-locale else build-depends: time == 1.5.*++ if flag(bytestring_has_builder)+ build-depends:+ bytestring >= 0.10.4 && < 0.11+ else+ build-depends:+ bytestring >= 0.10 && < 0.10.4,+ bytestring-builder >= 0.10.4.1.1+ hs-source-dirs: src default-language: Haskell2010