diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -56,7 +56,7 @@ lists all unknown parts of the file. explain ... lists all parts of the file, with description and hexdump. - play + play interactively play: Enter OIDs, and see what happens. rewrite parses the file and serializes it again (for debugging). diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -16,10 +16,18 @@ -- Neg is unary, hence a Command arithOpCode Set = [0xF9, 0xFF] +knownRawXOR :: Word32 +knownRawXOR = 0x00000039 -- from Bauernhof +knownXOR :: Word8 +knownXOR = 0xAD + fileMagics :: [(BC.ByteString, String)] fileMagics = [ (BC.pack "RIFF", "wav") , (BC.pack "OggS", "ogg") , (BC.pack "fLaC", "flac") , (BC.pack "ID3", "mp3")] + +maxCommentLength :: Int +maxCommentLength = 49 diff --git a/src/GMEParser.hs b/src/GMEParser.hs --- a/src/GMEParser.hs +++ b/src/GMEParser.hs @@ -238,10 +238,12 @@ binary <- getSegAt offset (BC.unpack desc) (getBS length) return (desc, binary) -getAudios :: SGet ([B.ByteString], Bool, Word8) -getAudios = do +getAudios :: Word32 -> SGet ([B.ByteString], Bool, Word8) +getAudios rawXor = do until <- lookAhead getWord32 - x <- lookAhead $ jumpTo until >> getXor + x <- case () of + () | rawXor == knownRawXOR -> return knownXOR + | otherwise -> lookAhead $ jumpTo until >> getXor offset <- bytesRead let n_entries = fromIntegral ((until - offset) `div` 8) at_doubled <- lookAhead $ do @@ -263,7 +265,10 @@ present <- getBS 4 -- Brute force, but that's ok here case [ n | n <- [0..0xFF] - , cypher n present `elem` map fst fileMagics ] of + , let c = cypher n present + , (magic,_) <- fileMagics + , magic `B.isPrefixOf` c + ] of [] -> fail "Could not find magic hash" (x:_) -> return x @@ -356,13 +361,14 @@ getTipToiFile :: SGet TipToiFile getTipToiFile = getSegAt 0x00 "Header" $ do ttScripts <- indirection "Scripts" getScripts - (ttAudioFiles, ttAudioFilesDoubles, ttAudioXor) <- indirection "Media" getAudios + ttRawXor <- getAt 0x001C getWord32 + (ttAudioFiles, ttAudioFilesDoubles, ttAudioXor) <- indirection "Media" (getAudios ttRawXor) _ <- getWord32 -- Usually 0x0000238b _ <- indirection "Additional script" getScript ttGames <- indirection "Games" $ indirections getWord32 "" getGame ttProductId <- getWord32 ttInitialRegs <- indirection "Initial registers" getInitialRegs - ttRawXor <- getWord32 + _ <- getWord32 -- raw Xor (ttComment, ttDate) <- do l <- getWord8 c <- getBS (fromIntegral l) diff --git a/src/GMERun.hs b/src/GMERun.hs --- a/src/GMERun.hs +++ b/src/GMERun.hs @@ -1,19 +1,28 @@ {-# LANGUAGE FlexibleContexts #-} -module GMERun (playTipToi) where +module GMERun (playTipToi, execOID) where import Text.Printf import Data.Bits import Data.List import qualified Data.Map as M -import Control.Monad.State +import Control.Monad.State.Strict +import Control.Monad.Reader +import System.Console.Haskeline +import System.Directory +import System.FilePath +import System.Random +import Data.Foldable (for_) +import Data.Char import Types import PrettyPrint import Utils +import PlaySound type PlayState r = M.Map r Word16 -type GMEM r = StateT (PlayState r) IO +type GMEM r = + ReaderT (CodeMap, Transscript, TipToiFile) (StateT (PlayState r) IO) formatState :: PlayState ResReg -> String formatState s = spaces $ @@ -21,31 +30,44 @@ filter (\(k,v) -> k == 0 || v /= 0) $ M.toAscList s -playTipToi :: Transscript -> TipToiFile -> IO () -playTipToi t tt = do +playTipToi :: CodeMap -> Transscript -> TipToiFile -> IO () +playTipToi cm t tt = do let initialState = M.fromList $ zip [0..] (ttInitialRegs tt) printf "Initial state (not showing zero registers): %s\n" (formatState initialState) - flip evalStateT initialState $ forEachNumber $ untilNothing $ \i -> do - case lookup (fromIntegral i) (ttScripts tt) of - 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 - 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 - lift $ printf "Executing: %s\n" (ppLine t l) - next <- applyLine l - get >>= lift . printf "State now: %s\n" . formatState - return next + dir <- getAppUserDataDirectory "tttool" + createDirectoryIfMissing True dir + let history_file = dir "play_history" + let completion = completeFromList $ + M.keys cm ++ [show n | (n, Just _) <- ttScripts tt, n `notElem` M.elems cm] + let haskeline_settings = completion `setComplete` defaultSettings { historyFile = Just history_file } + + flip evalStateT initialState $ flip runReaderT (cm,t,tt) $ do + mapM_ playTTAudio $ concat $ ttWelcome tt + runInputT haskeline_settings $ nextOID $ \i -> do + execOID i + s <- get + liftIO $ printf "State now: %s\n" $ formatState s + +execOID :: Word16 -> GMEM Word16 () +execOID i = do + (cm,t,tt) <- ask + case lookup (fromIntegral i) (ttScripts tt) of + Nothing -> do + liftIO $ printf "OID %d not in main table\n" i + Just Nothing -> do + liftIO $ printf "OID %d deactivated\n" i + Just (Just lines) -> do + code <- gets $ \s -> find (enabledLine s) lines + case code of + Nothing -> liftIO $ do + printf "None of these lines matched!\n" + mapM_ (putStrLn . ppLine t) lines + + Just l -> do + liftIO $ printf "Executing: %s\n" (ppLine t l) + applyLine l + enabledLine :: Ord r => PlayState r -> Line r -> Bool enabledLine s (Line _ cond _ _) = all (condTrue s) cond @@ -71,8 +93,15 @@ 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 +playTTAudio :: Word16 -> GMEM r () +playTTAudio i = do + (_,_,tt) <- ask + liftIO $ printf "Playing audio sample %d\n" i + let bs = ttAudioFiles tt !! fromIntegral i + liftIO $ playSound bs + +applyLine :: Line Word16 -> GMEM Word16 () +applyLine (Line _ _ acts playlist) = go acts where go (Neg r : acts) = do modReg r neg @@ -84,10 +113,17 @@ go acts go (Jump v: _ ) = do n <- getVal v - return (Just n) + execOID n + go (Play n: acts) = do + playTTAudio (playlist !! fromIntegral n) + go acts + go (Random a b: acts) = do + pick <- liftIO $ randomRIO (b,a) + playTTAudio (playlist !! fromIntegral pick) + go acts go (_: acts) = do go acts - go [] = return Nothing + go [] = return () neg 0 = 1 neg _ = 0 @@ -109,11 +145,21 @@ case r of Just i' -> untilNothing f i' Nothing -> return () -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" +nextOID :: (Word16 -> GMEM r ()) -> InputT (GMEM r) () +nextOID action = go + where + go = do + (cm,t,tt) <- lift ask + mstr <- getInputLine "Next OID touched? " + for_ mstr $ \str -> do + let str' = dropWhile isSpace $ reverse $ dropWhile isSpace $ reverse $ str + case () of () | Just i <- readMaybe str' -> lift $ action i + | str' == "" -> return () + | Just i <- M.lookup str' cm -> lift $ action i + | otherwise -> liftIO $ putStrLn "Please enter a number (OID) or name of a script." + go + +completeFromList :: Monad m => [[Char]] -> CompletionFunc m +completeFromList xs = completeWord Nothing " " $ \p -> return + [simpleCompletion x | x <- xs, p `isPrefixOf` x ] diff --git a/src/PlaySound.hs b/src/PlaySound.hs new file mode 100644 --- /dev/null +++ b/src/PlaySound.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +module PlaySound (playSound) where + +import System.Process +import System.Exit +import Control.Monad +import Control.Exception +import System.IO.Error +import System.IO +import System.Directory +import System.FilePath +import qualified Data.ByteString.Lazy as B +import System.Environment.Executable + + +players :: FilePath -> FilePath -> [(FilePath, [String])] +players myDir fn = + [ ("sox", ["-q", fn, "-d"]) + , (myDir "contrib" "playmus", [fn]) + ] + +playSound :: B.ByteString -> IO () +playSound content = do + dir <- getTemporaryDirectory + (tmp, h) <- openTempFile dir "tttool-audio.tmp" + B.hPutStr h content + hClose h + + (myDir,_) <- splitExecutablePath + + tryPrograms (players myDir tmp) $ do + putStrLn "Could not play audio file." + putStrLn "Do you have \"sox\" installed?" + + removeFile tmp + +tryPrograms [] e = e +tryPrograms ((c,args):es) e = do + -- Missing programs cause exceptions on Windows, but error 127 on Linux. + -- Try to handle both here. + r <- tryJust (guard . isDoesNotExistError) $ do + ph <- runProcess c args Nothing Nothing Nothing Nothing Nothing + ret <- waitForProcess ph + if ret == ExitSuccess then return True + else if ret == ExitFailure 127 then return False + else do + putStrLn $ "Failed to execute \"" ++ c ++ "\" (" ++ show ret ++ ")" + exitFailure + case r of + Right True -> return () + _ -> tryPrograms es e diff --git a/src/TextToSpeech.hs b/src/TextToSpeech.hs --- a/src/TextToSpeech.hs +++ b/src/TextToSpeech.hs @@ -14,6 +14,7 @@ import System.IO.Error import System.Environment import System.Info (os) +import System.Environment.Executable import Language @@ -40,22 +41,22 @@ espeak lang tmp txt = ("espeak", ["-v", l, "-w", tmp, "-s", "120", txt]) where - l = case lang of + l = case lang of Language s -> s -espeak_contrib :: Language -> FilePath -> String -> (String, [String]) -espeak_contrib lang tmp txt = - ("./contrib/espeak", ["-v", l, "-w", tmp, "-s", "120", txt]) +espeak_contrib :: FilePath -> Language -> FilePath -> String -> (String, [String]) +espeak_contrib myDir lang tmp txt = + (myDir "contrib" "espeak", ["-v", l, "-w", tmp, "-s", "120", txt]) where - l = case lang of + l = case lang of Language s -> s -engines :: Language -> FilePath -> String -> [(String, [String])] -engines l ft txt = +engines :: FilePath -> Language -> FilePath -> String -> [(String, [String])] +engines myDir l ft txt = [ pico l ft txt , espeak l ft txt - , espeak_contrib l ft txt + , espeak_contrib myDir l ft txt ] oggenc :: FilePath -> FilePath -> (String, [String]) @@ -68,7 +69,7 @@ encoders from to = [ oggenc from to , oggenc_contrib from to - ] + ] tryPrograms [] e = e tryPrograms ((c,args):es) e = do @@ -100,7 +101,9 @@ (tmp,h) <- openTempFile (takeDirectory fn) (takeBaseName fn <.> "wav") hClose h - tryPrograms (engines lang tmp txt) $ do + (myDir,_) <- splitExecutablePath + + tryPrograms (engines myDir lang tmp txt) $ do putStrLn "No suitable text-to-speech-engine found." putStrLn "Do you have libttspico-utils or espeak installed?" diff --git a/src/TipToiYaml.hs b/src/TipToiYaml.hs --- a/src/TipToiYaml.hs +++ b/src/TipToiYaml.hs @@ -17,6 +17,7 @@ import Data.Char import Data.Either import Data.Functor +import Data.Version import Data.Maybe import Control.Monad import System.Directory @@ -52,7 +53,7 @@ import OneLineParser import Utils -type CodeMap = M.Map String Word16 +import Paths_tttool data TipToiYAML = TipToiYAML { ttyScripts :: M.Map String [String] @@ -212,9 +213,7 @@ extCodeMap (fromMaybe M.empty ttyScriptCodes) - (scriptMap, totalMap) <- case scriptCodes (M.keys ttyScripts) codeMap of - Left e -> fail e - Right f -> return f + (scriptMap, totalMap) <- either fail return $ scriptCodes (M.keys ttyScripts) codeMap let m = M.mapKeys scriptMap ttyScripts first = fst (M.findMin m) @@ -278,17 +277,25 @@ mapM_ putStrLn ex exitFailure + comment <- case ttyComment of + Nothing -> return $ BC.pack $ "created with tttool version " ++ showVersion version + Just c | length c > maxCommentLength -> do + printf "Comment is %d characters too long; the maximum is %d." + (length c - maxCommentLength) maxCommentLength + exitFailure + | otherwise -> return $ BC.pack c + return $ (TipToiFile { ttProductId = ttyProduct_Id - , ttRawXor = 0x00000039 -- from Bauernhof - , ttComment = BC.pack (fromMaybe "created with tip-toi-reveng" ttyComment) + , ttRawXor = knownRawXOR + , ttComment = comment , ttDate = BC.pack date , ttWelcome = welcome , ttInitialRegs = [fromMaybe 0 (M.lookup r initRegs) | r <- [0..maxReg]] , ttScripts = scripts' , ttGames = [] , ttAudioFiles = files - , ttAudioXor = 0xAD + , ttAudioXor = knownXOR , ttAudioFilesDoubles = False , ttChecksum = 0x00 , ttChecksumCalc = 0x00 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -104,4 +104,6 @@ deriving Show type Transscript = M.Map Word16 String +type CodeMap = M.Map String Word16 + diff --git a/src/tttool.hs b/src/tttool.hs --- a/src/tttool.hs +++ b/src/tttool.hs @@ -19,13 +19,7 @@ import Numeric (readHex) import qualified Data.Map as M import Data.Foldable (for_) - -{- -import Text.Blaze.Svg11 ((!), mkPath, rotate, l, m) -import qualified Text.Blaze.Svg11 as S -import qualified Text.Blaze.Svg11.Attributes as A -import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) --} +import Data.Version import Types import Constants @@ -40,7 +34,9 @@ import TipToiYaml import Lint +import Paths_tttool + -- Main commands dumpAudioTo :: FilePath -> FilePath -> IO () @@ -133,8 +129,16 @@ play :: Transscript -> FilePath -> IO () play t file = do - (tt,_) <- parseTipToiFile <$> B.readFile file - playTipToi t tt + (cm,tt) <- + if ".yaml" `isSuffixOf` file + then do + (tty, extraCodeMap) <- readTipToiYaml file + (tt, codeMap) <- ttYaml2tt (takeDirectory file) tty extraCodeMap + return (codeMap, tt) + else do + (tt,_) <- parseTipToiFile <$> B.readFile file + return (M.empty, tt) + playTipToi cm t tt segments :: FilePath -> IO () segments file = do @@ -374,6 +378,8 @@ main' t ("raw-oid-code": codes@(_:_)) = genPNGsForRawCodes D1200 (unwords codes) main' _ _ = do prg <- getProgName + putStrLn $ "This is the Tiptoi toolkit, version " ++ showVersion version + putStrLn $ "" putStrLn $ "Usage: " ++ prg ++ " [options] command" putStrLn $ "" putStrLn $ "Options:" @@ -407,7 +413,7 @@ putStrLn $ " lists all unknown parts of the file." putStrLn $ " explain ..." putStrLn $ " lists all parts of the file, with description and hexdump." - putStrLn $ " play " + putStrLn $ " play " putStrLn $ " interactively play: Enter OIDs, and see what happens." putStrLn $ " rewrite " putStrLn $ " parses the file and serializes it again (for debugging)." 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.3 +version: 1.4 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 @@ -13,7 +13,7 @@ license-file: LICENSE author: Joachim Breitner maintainer: mail@joachim-breitner.de -copyright: 2013-2014 Joachim Breitner +copyright: 2013-2015 Joachim Breitner build-type: Simple extra-source-files: README.md cabal-version: >=1.10 @@ -41,6 +41,7 @@ Language, OidCode, OneLineParser, + PlaySound, PrettyPrint, RangeParser, TipToiYaml, @@ -48,26 +49,30 @@ KnownCodes, Types, Utils - + build-depends: base == 4.5.* || == 4.6.* || == 4.7.* || == 4.8.*, binary == 0.5.* || == 0.7.*, containers == 0.4.* || == 0.5.*, directory == 1.2.*, + executable-path == 0.0.*, filepath == 1.3.* || == 1.4.*, template-haskell >= 2.7 && < 2.11, - ghc-prim, JuicyPixels == 3.1.* || == 3.2.*, aeson == 0.7.* || == 0.8.*, hashable == 1.2.*, + haskeline == 0.7.*, mtl == 2.1.* || == 2.2.*, - text >= 0.11 && < 1.3, parsec == 3.1.*, process == 1.1.* || == 1.2.*, - unordered-containers == 0.2.*, + process-extras >= 0.2 && < 0.4, + random == 1.0.*, vector == 0.10.*, yaml == 0.8.* + + if impl(ghc < 7.5) + build-depends: ghc-prim if flag(old-locale) build-depends: time == 1.4.*, old-locale