tttool 1.3 → 1.4
raw patch · 10 files changed
+211/−76 lines, 10 filesdep +executable-pathdep +haskelinedep +process-extrasdep −textdep −unordered-containers
Dependencies added: executable-path, haskeline, process-extras, random
Dependencies removed: text, unordered-containers
Files
- README.md +1/−1
- src/Constants.hs +8/−0
- src/GMEParser.hs +12/−6
- src/GMERun.hs +82/−36
- src/PlaySound.hs +52/−0
- src/TextToSpeech.hs +13/−10
- src/TipToiYaml.hs +14/−7
- src/Types.hs +2/−0
- src/tttool.hs +16/−10
- tttool.cabal +11/−6
README.md view
@@ -56,7 +56,7 @@ lists all unknown parts of the file. explain <file.gme>... lists all parts of the file, with description and hexdump.- play <file.gme>+ play <file.gme or file.yaml> interactively play: Enter OIDs, and see what happens. rewrite <infile.gme> <outfile.gme> parses the file and serializes it again (for debugging).
src/Constants.hs view
@@ -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
src/GMEParser.hs view
@@ -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)
src/GMERun.hs view
@@ -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 ]
+ src/PlaySound.hs view
@@ -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
src/TextToSpeech.hs view
@@ -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?"
src/TipToiYaml.hs view
@@ -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
src/Types.hs view
@@ -104,4 +104,6 @@ deriving Show type Transscript = M.Map Word16 String+type CodeMap = M.Map String Word16+
src/tttool.hs view
@@ -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 <file.gme>..." putStrLn $ " lists all parts of the file, with description and hexdump."- putStrLn $ " play <file.gme>"+ putStrLn $ " play <file.gme or file.yaml>" putStrLn $ " interactively play: Enter OIDs, and see what happens." putStrLn $ " rewrite <infile.gme> <outfile.gme>" putStrLn $ " parses the file and serializes it again (for debugging)."
tttool.cabal view
@@ -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