diff --git a/src/GMERun.hs b/src/GMERun.hs --- a/src/GMERun.hs +++ b/src/GMERun.hs @@ -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" diff --git a/src/Language.hs b/src/Language.hs --- a/src/Language.hs +++ b/src/Language.hs @@ -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 diff --git a/src/TextToSpeech.hs b/src/TextToSpeech.hs --- a/src/TextToSpeech.hs +++ b/src/TextToSpeech.hs @@ -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])] diff --git a/tttool.cabal b/tttool.cabal --- a/tttool.cabal +++ b/tttool.cabal @@ -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