tttool (empty) → 0.1
raw patch · 18 files changed
+2463/−0 lines, 18 filesdep +JuicyPixelsdep +aesondep +basesetup-changed
Dependencies added: JuicyPixels, aeson, base, binary, bytestring, containers, directory, filepath, ghc-prim, mtl, old-locale, parsec, text, time, yaml
Files
- LICENSE +20/−0
- README.md +183/−0
- Setup.hs +2/−0
- src/Constants.hs +40/−0
- src/Cypher.hs +15/−0
- src/GMEParser.hs +364/−0
- src/GMERun.hs +88/−0
- src/GMEWriter.hs +225/−0
- src/Lint.hs +48/−0
- src/OidCode.hs +147/−0
- src/OneLineParser.hs +31/−0
- src/PrettyPrint.hs +225/−0
- src/RangeParser.hs +28/−0
- src/TipToiYaml.hs +430/−0
- src/Types.hs +102/−0
- src/Utils.hs +17/−0
- src/tttool.hs +424/−0
- tttool.cabal +74/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Joachim Breitner++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,183 @@+Das tttool hat jetzt eine deutsche Webseite für Anwender: http://tttool.entropia.de/++tip-toi-reveng+==============+++The goal of this project is to understand the file and paper format for the+Ravensburger TipToi pen. The ultimate goal is that everyone can create their+own books, with their own sounds.++The current status is that we understood most of the file format (see the+[GME file format specification](GME-Format.md)). We provide a tool that allows+you to dissect these files.++The tool can also be used to generate completely new files from scratch; see+below for details.++If you want to learn more, here are some relevant links:+ * Discussion about Tip-Toi: http://www.quadrierer.de/geekythinking/blog/?itemid=368 (German)+ * Discussion about Tip-Toi and the related TING pen, including discussion on how to print your own books: http://www.mikrocontroller.net/topic/214479 (German)++The tttool tool+---------------++Use the tool `tttool.hs` to investigate the gme files and build new ones. It+supports various subcommands:++ Usage: tttool [options] command++ Options:+ -t <transcriptfile>+ in the screen output, replaces media file indices by a transscript++ Commands:+ info <file.gme>...+ general information+ media [-d dir] <file.gme>...+ dumps all audio samples to the given directory (default: media/)+ scripts <file.gme>...+ prints the decoded scripts for each OID+ script <file.gme> <n>+ prints the decoded scripts for the given OID+ raw-scripts <file.gme>...+ prints the scripts for each OID, in their raw form+ raw-script <file.gme> <n>+ prints the scripts for the given OID, in their raw form+ games <file.gme>...+ prints the decoded games+ lint <file.gme>+ checks for errors in the file or in this program+ segments <file.gme>...+ lists all known parts of the file, with description.+ segment <file.gme> <pos>+ which segment contains the given position.+ holes <file.gme>...+ lists all unknown parts of the file.+ explain <file.gme>...+ lists all parts of the file, with description and hexdump.+ play <file.gme>+ interactively play: Enter OIDs, and see what happens.+ rewrite <infile.gme> <outfile.gme>+ parses the file and serializes it again (for debugging).+ create-debug <outfile.gme> <productid>+ creates a special Debug.gme file for that productid+ export <infile.gme> [<outfile.yaml>]+ dumps the file in the human-readable yaml format+ assemble <infile.yaml> <outfile.gme>+ creates a gme file from the given source+ oid-code [-d DPI] <codes>+ creates a PNG file for each given optical code+ scale this to 10cm×10cm+ By default, it creates a 1200 dpi image. With -d 600, you+ obtain a 600 dpi image.+ <codes> can be a range, e.g. 1,3,1000-1085.+ The code refers to the *raw* code, not the one read by the pen.+ Uses oid<code>.png as the file name.+++A transscript is simply a `;`-separated table of OIDs and some text, see for example [`transcript/WWW_Bauernhof.csv`](transcript/WWW_Bauernhof.csv).+++Installation+------------++This program is written in Haskell and can be installed on Windows, MacOS or Linux.++For Windows users, we create zipfile containing `tttool`, you can find them in+the [releases section](https://github.com/entropia/tip-toi-reveng/releases) of+the github project.++Otherwise, installation from source is not difficult either:++ 1. First install the *Haskell platform*, see http://www.haskell.org/platform/+ for details for your system. Users of Debian or Ubuntu simply run `apt-get+ install haskell-platform`.++ 2. Install the dependencies. The Haskell platform comes with a tool called+ `cabal`, and you should run the two commands++ cabal update+ cabal install --dependencies-only++ 3. Now you can build the program using++ cabal install --bindir=.++ 4. At this point, `tttool` should be ready to go. If you run++ ./tttool++ you should see the list of commands shown above.++If you have any problems, you can [report an issue via GitHub](https://github.com/entropia/tip-toi-reveng/issues).++Building your own gme files+---------------------------++Once you have installed `tttool`, you can create your own `.gme` files. The+process is as follows++ 1. Record the audio samples you want to include, as Ogg Vorbis files, mono, 22050Hz. I use++ arecord -r 22050 foo.wav+ oggenc foo.wav+ rm foo.wav++ 2. Write a `my-book.yaml` file containing some general information, and especially+ the scripts (i.e. what to do) for each OIDs (i.e. the various fields of a+ book). You can use the [example.yaml](example.yaml) file as a starting+ point; it contains more information in its comments.++ 3. Run `./tttool assemble my-book.yaml`, and make sure it reports no error, i.e.+ finishes silently.++ 4. Copy the now generated `my-book.gme` to your TipToi pen and enjoy!++If you need to find out what OID code corresponds to what part of the book, you+can generate a debug gme file using `./tttool create-debug` and load that on+your pen. It will then read out the codes, as a sequence of english digits.++We are also collecting template files, where the OIDs are commented; these can+be found in the `./templates` directory. Please improve and contribute!++Again, please let us know if you have problems, but also tell us what fun things you did if you succeded.++Printing your own books+-----------------------++With the code in this repository, you can create GME files. This is even more+fun if you can also create your own books! „Pronwan“ found out how that works,+as you can see in [this video demonstration](http://youtu.be/KC97F4PfNhk). He+also published 30 minute [video tutorial](http://youtu.be/4AjvjFM8GzM) (in+German).++Press Review+------------++ * [tiptoi hacking](https://blogs.fsfe.org/guido/2014/05/tiptoi-hacking-und-systemanforderungen/) by Guido Arnold+ * [TipToi Hacking](http://www.nerd.junetz.de/blogbox/index.php?/archives/1377-TipToi-Hacking.html) and [TipToi Hacking II](http://www.nerd.junetz.de/blogbox/index.php?/archives/1378-TipToi-Hacking-II.html) by Mr. Blog+ * [Various posts](https://www.joachim-breitner.de/blog/tag/Tiptoi) by Joachim “nomeata” Breitner (the main author of `tttool`)++TODO+----++ * What are all the header fields? (See [wip/Header.md](wip/Header.md))+ * Finish decoding the games. (See [wip/games.txt](wip/games.txt))+ * What is the purpose of the additional script table?++Other resources in this repository+----------------------------------++ * [`oid-decoder.html`](http://htmlpreview.github.io/?https://github.com/entropia/tip-toi-reveng/blob/master/oid-decoder.html) allows you to manually decode an OID image.+ * `scripts/updates.sh` downloads all gme files from the Ravensburger server.+ * `gameanalyse.c` and `libtiptoi.c` is an alternative tool to investigate gme+ files. It can also [replace audio files in gme files](Audio/README.md);+ compile and run it for diagnostic output.+ * `Audio/` contains some audio files, such as digits read out.+ * `docs/` collects information about TipToi found elsewhere.+ * `matlab/` contains scripts to analyse gme files in Matlab+ * `wip/` (work in progess) contains notes about the parts of the gme files that are not+ fully understood yet.++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Constants.hs view
@@ -0,0 +1,40 @@+module Constants where++import qualified Data.Map as M+import qualified Data.ByteString.Lazy.Char8 as BC++import Types++arithOpCode :: ArithOp -> [Word8]+arithOpCode Inc = [0xF0, 0xFF]+arithOpCode Dec = [0xF1, 0xFF]+arithOpCode Mult = [0xF2, 0xFF]+arithOpCode Div = [0xF3, 0xFF]+arithOpCode Mod = [0xF4, 0xFF]+arithOpCode And = [0xF5, 0xFF]+arithOpCode Or = [0xF6, 0xFF]+arithOpCode XOr = [0xF7, 0xFF]+-- Neg is unary, hence a Command+arithOpCode Set = [0xF9, 0xFF]+++fileMagics :: [(BC.ByteString, String)]+fileMagics =+ [ (BC.pack "RIFF", "wav")+ , (BC.pack "OggS", "ogg")+ , (BC.pack "fLaC", "flac")+ , (BC.pack "ID3", "mp3")]+++knownCodes :: [Word16]+knownCodes = [4716, 4717, 4718, 4719, 4720, 4721, 4722, 4723, 4724, 4725, 4726, 4727, 4728, 4729, 4730, 4731, 4732, 4733, 4734, 4735, 4736, 4737, 4738, 4739, 4740, 4741, 4742, 4743, 4744, 4745, 4746, 4747, 4748, 4749, 4750, 4751, 4752, 4753, 4754, 4755, 4756, 4757, 4758, 4759, 4760, 4761, 4762, 4763, 4764, 4765, 4766, 4767, 4768, 4769, 4770, 4771, 4772, 4773, 4774, 4775, 4776, 4777, 4778, 4779, 4780, 4781, 4782, 4783, 4784, 4785, 4786, 4787, 4788, 4789, 4790, 4791, 4792, 4793, 4794, 4795, 4796, 4797, 4798, 4799, 4800, 4801, 4802, 4803, 4804, 4805, 4806, 4807, 4808, 4809, 4810, 4811, 4812, 4813, 4814, 4815]+--knownCodes = [8066..8081]++knownRawCodes :: [Word16]+knownRawCodes = [0, 1, 2, 3, 8, 9, 10, 11, 13, 14, 16, 17, 18, 19, 24, 25, 26, 27, 29, 30, 31, 32, 33, 34, 35, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 61, 62, 63, 64, 65, 66, 67, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121]++code2RawCode :: Word16 -> Maybe Word16+code2RawCode =+ let m = M.fromList (zip knownCodes knownRawCodes)+ in \c -> M.lookup c m+
+ src/Cypher.hs view
@@ -0,0 +1,15 @@+module Cypher (cypher) where++import Data.Bits+import qualified Data.ByteString.Lazy as B++import Types++cypher :: Word8 -> B.ByteString -> B.ByteString+cypher x = B.map go+ where go 0 = 0+ go 255 = 255+ go n | n == x = n+ | n == xor x 255 = n+ | otherwise = xor x n+
+ src/GMEParser.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GMEParser (parseTipToiFile) where++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Get as G+import Text.Printf+import Data.List+import Data.Functor+import Control.Applicative (Applicative)+import Data.Maybe+import Control.Monad+import Control.Monad.Writer.Strict+import Control.Monad.State.Strict+import Control.Monad.Reader+import Control.Monad.RWS.Strict+import Control.Exception+import Control.Arrow++import Types+import Constants+import Cypher++-- Reverse Engineering Monad++newtype SGet a = SGet (RWS B.ByteString [Segment] Word32 a)+ deriving (Functor, Applicative, Monad)++liftGet :: G.Get a -> SGet a+liftGet act = SGet $ do+ offset <- get+ bytes <- ask+ when (offset > fromIntegral (B.length bytes)) $ do+ fail $ printf "Trying to read from offset 0x%08X, which is after the end of the file!" offset+ let (a, _, i) = G.runGetState act (B.drop (fromIntegral offset) bytes) 0+ put (offset + fromIntegral i)+ return $ a++jumpTo :: Offset -> SGet ()+jumpTo offset = SGet (put offset)++lookAhead :: SGet a -> SGet a+lookAhead (SGet act) = SGet $ do+ oldOffset <- get+ a <- act+ put oldOffset+ return a++getAt :: Offset -> (SGet a) -> SGet a+getAt offset act = lookAhead (jumpTo offset >> act)++getSeg :: String -> SGet a -> SGet a+getSeg desc (SGet act) = addStack desc $ SGet $ do+ offset <- get+ a <- censor (map addDesc) act+ newOffset <- get+ tell [(offset, newOffset - offset, [desc])]+ return a+ where addDesc (o,l,d) = (o,l,desc : d)++addStack :: String -> SGet a -> SGet a+addStack desc (SGet act1) = SGet $ rws $ \r s ->+ mapException annotate (runRWS act1 r s)+ where+ annotate (ErrorCall s) = ErrorCall (s ++ "\n when reading segment " ++ desc)++getSegAt :: Offset -> String -> SGet a -> SGet a+getSegAt offset desc act = getAt offset $ getSeg desc act++indirection :: String -> SGet a -> SGet a+indirection desc act = do+ position <- bytesRead+ offset <- getWord32+ l <- getLength+ when (offset > l) $ do+ fail $ printf "Trying to read from offset 0x%08X, mentioned at 0x%08X, which is after the end of the file!" offset position+ getSegAt offset desc act++indirectBS :: String -> SGet B.ByteString+indirectBS desc = do+ offset <- getWord32+ length <- getWord32+ getSegAt offset desc (getBS length)++maybeIndirection :: String -> SGet a -> SGet (Maybe a)+maybeIndirection desc act = do+ offset <- getWord32+ if offset == 0xFFFFFFFF+ then return Nothing+ else Just <$> getSegAt offset desc act++getLength :: SGet Word32+getLength = fromIntegral . B.length <$> getAllBytes++getAllBytes :: SGet B.ByteString+getAllBytes = SGet ask++runSGet :: SGet a -> B.ByteString -> (a, Segments)+runSGet (SGet act) bytes =+ second (sort . ((fromIntegral (B.length bytes), 0, ["End of file"]):)) $+ evalRWS act bytes 0++getWord8 = liftGet G.getWord8+getWord16 = liftGet G.getWord16le+getWord32 = liftGet G.getWord32le+getBS :: Word32 -> SGet B.ByteString+getBS n = liftGet $ G.getLazyByteString (fromIntegral n)++bytesRead = SGet get++getArray :: Integral a => SGet a -> SGet b -> SGet [b]+getArray g1 g2 = do+ n <- g1+ replicateM (fromIntegral n) g2++getArrayN :: Integral a => SGet a -> (Int -> SGet b) -> SGet [b]+getArrayN g1 g2 = do+ n <- g1+ mapM g2 [0.. fromIntegral n - 1]++indirections :: Integral a => SGet a -> String -> SGet b -> SGet [b]+indirections g1 prefix g2 =+ getArrayN g1 (\n -> indirection (prefix ++ show n) g2)++-- Parsers++getScripts :: SGet [(Word16, Maybe [Line ResReg])]+getScripts = do+ last_code <- getWord16+ 0 <- getWord16+ first_code <- getWord16+ 0 <- getWord16++ forM [first_code .. last_code] $ \oid -> do+ l <- maybeIndirection (show oid) $ getScript+ return (oid,l)++getScript :: SGet [Line ResReg]+getScript = indirections getWord16 "Line " lineParser++getTVal :: SGet (TVal ResReg)+getTVal = do+ t <- getWord8+ case t of+ 0 -> Reg <$> getWord16+ 1 -> Const <$> getWord16+ _ -> fail $ "Unknown value tag " ++ show t++lineParser :: SGet (Line ResReg)+lineParser = begin+ where+ -- Find the occurrence of a header+ begin = do+ offset <- bytesRead++ -- Conditionals+ conds <- getArray getWord16 $ do+ v1 <- getTVal+ bytecode <- getBS 2+ let op = fromMaybe (Unknowncond bytecode) $+ lookup bytecode conditionals+ v2 <- getTVal+ return $ Cond v1 op v2++ -- Actions+ cmds <- getArray getWord16 $ do+ r <- getWord16+ bytecode <- getBS 2+ case lookup bytecode actions of+ Just p -> p r+ Nothing -> do+ n <- getTVal+ return $ Unknown bytecode r n++ -- Audio links+ xs <- getArray getWord16 getWord16+ return $ Line offset conds cmds xs++ expectWord8 n = do+ n' <- getWord8+ when (n /= n') $ do+ b <- bytesRead+ fail $ printf "At position 0x%08X, expected %d/%02X, got %d/%02X" (b-1) n n n' n'++ conditionals =+ [ (B.pack [0xF9,0xFF], Eq)+ , (B.pack [0xFA,0xFF], Gt)+ , (B.pack [0xFB,0xFF], Lt)+ , (B.pack [0xFD,0xFF], GEq)+ , (B.pack [0xFE,0xFF], LEq)+ , (B.pack [0xFF,0xFF], NEq)+ ]++ actions =+ [ (B.pack [0xE8,0xFF], \r -> do+ unless (r == 0) $ fail "Non-zero register for Play command"+ Const n <- getTVal+ return (Play n))+ , (B.pack [0x00,0xFC], \r -> do+ unless (r == 0) $ fail "Non-zero register for Random command"+ Const n <- getTVal+ return (Random (lowbyte n) (highbyte n)))+ , (B.pack [0xFF,0xFA], \r -> do+ unless (r == 0) $ fail "Non-zero register for Cancel command"+ Const 0xFFFF <- getTVal+ return Cancel)+ , (B.pack [0xFF,0xF8], \r -> do+ unless (r == 0) $ fail "Non-zero register for Jump command"+ v <- getTVal+ return (Jump v))+ , (B.pack [0x00,0xFD], \r -> do+ unless (r == 0) $ fail "Non-zero register for Game command"+ Const a <- getTVal+ return (Game a))+ , (B.pack [0xF8,0xFF], \r -> do+ _ <- getTVal+ return (Neg r))+ ] ++ + [ (B.pack (arithOpCode o), \r -> do+ n <- getTVal+ return (ArithOp o r n))+ | o <- [minBound..maxBound]+ ]++lowbyte, highbyte :: Word16 -> Word8+lowbyte n = fromIntegral (n `mod` 2^8)+highbyte n = fromIntegral (n `div` 2^8)++getAudios :: SGet ([B.ByteString], Bool, Word8)+getAudios = do+ until <- lookAhead getWord32+ x <- lookAhead $ jumpTo until >> getXor+ offset <- bytesRead+ let n_entries = fromIntegral ((until - offset) `div` 8)+ at_doubled <- lookAhead $ do+ half1 <- getBS (n_entries * 8 `div` 2)+ half2 <- getBS (n_entries * 8 `div` 2)+ return $ half1 == half2+ let n_entries' | at_doubled = n_entries `div` 2+ | otherwise = n_entries+ decoded <- forM [0..n_entries'-1] $ \n -> do+ cypher x <$> indirectBS (show n)+ -- Fix segment+ when at_doubled $ lookAhead $ getSeg "Audio table copy" $+ replicateM_ (fromIntegral n_entries') (getWord32 >> getWord32)++ return (decoded, at_doubled, x)++getXor :: SGet Word8+getXor = do+ present <- getBS 4+ -- Brute force, but that's ok here+ case [ n | n <- [0..0xFF]+ , cypher n present `elem` map fst fileMagics ] of+ [] -> fail "Could not find magic hash"+ (x:_) -> return x++getChecksum :: SGet Word32+getChecksum = do+ l <- getLength+ getSegAt (l-4) "Checksum" $ getWord32++calcChecksum :: SGet Word32+calcChecksum = do+ l <- getLength+ bs <- getAt 0 $ getBS (fromIntegral l - 4)+ return $ B.foldl' (\s b -> fromIntegral b + s) 0 bs++getPlayList :: SGet PlayList+getPlayList = getArray getWord16 getWord16++getOidList :: SGet [OID]+getOidList = getArray getWord16 getWord16++getGidList :: SGet [OID]+getGidList = getArray getWord16 getWord16++getPlayListList :: SGet PlayListList+getPlayListList = indirections getWord16 "" getPlayList++getSubGame :: SGet SubGame+getSubGame = do+ u <- getBS 20+ oid1s <- getOidList+ oid2s <- getOidList+ oid3s <- getOidList+ plls <- indirections (return 9) "playlistlist " getPlayListList+ return (SubGame u oid1s oid2s oid3s plls)++getGame :: SGet Game+getGame = do+ t <- getWord16+ case t of+ 6 -> do+ b <- getWord16+ u1 <- getWord16+ c <- getWord16+ u2 <- getBS 18+ plls <- indirections (return 7) "playlistlistA-" getPlayListList+ sg1s <- indirections (return b) "subgameA-" getSubGame+ sg2s <- indirections (return c) "subgameB-" getSubGame+ u3 <- getBS 20+ pll2s <- indirections (return 10) "playlistlistB-" getPlayListList+ pl <- indirection "playlist" getPlayList++ return (Game6 u1 u2 plls sg1s sg2s u3 pll2s pl)+ 7 -> do+ (u1,c,u2,plls, sgs, u3, pll2s) <- common+ pll <- indirection "playlistlist" getPlayListList+ return (Game7 u1 c u2 plls sgs u3 pll2s pll)+ 8 -> do+ (u1,c,u2,plls, sgs, u3, pll2s) <- common+ oidl <- indirection "oidlist" getOidList+ gidl <- indirection "gidlist" getGidList+ pll1 <- indirection "playlistlist1" getPlayListList+ pll2 <- indirection "playlistlist2" getPlayListList+ return (Game8 u1 c u2 plls sgs u3 pll2s oidl gidl pll1 pll2)++ 253 -> do+ return Game253++ _ -> do+ (u1,c,u2,plls, sgs, u3, pll2s) <- common+ return (UnknownGame t u1 c u2 plls sgs u3 pll2s)+ where+ common = do -- the common header of a non-type-6-game+ b <- getWord16+ u1 <- getWord16+ c <- getWord16+ u2 <- getBS 10+ plls <- indirections (return 5) "playlistlistA-" getPlayListList+ sgs <- indirections (return b) "subgame-" getSubGame+ u3 <- getBS 20+ pll2s <- indirections (return 10) "playlistlistB-" getPlayListList+ return (u1, c, u2, plls, sgs, u3, pll2s)+++getInitialRegs :: SGet [Word16]+getInitialRegs = getArray getWord16 getWord16++getTipToiFile :: SGet TipToiFile+getTipToiFile = getSegAt 0x00 "Header" $ do+ scripts <- indirection "Scripts" getScripts+ (at, at_doubled, xor) <- indirection "Media" getAudios+ _ <- getWord32 -- Usually 0x0000238b+ _ <- indirection "Additional script" getScript+ games <- indirection "Games" $ indirections getWord32 "" getGame+ id <- getWord32+ regs <- indirection "Initial registers" getInitialRegs+ raw_xor <- getWord32+ (comment,date) <- do+ l <- getWord8+ c <- getBS (fromIntegral l)+ d <- getBS 8+ return (c,d)+ checksum <- getChecksum+ checksumCalc <- calcChecksum+ ipll <- getSegAt 0x71 "After header" $ indirection "initial play lists" $ getPlayListList+ return (TipToiFile id raw_xor comment date regs ipll scripts games at at_doubled xor checksum checksumCalc)++parseTipToiFile :: B.ByteString -> (TipToiFile, Segments)+parseTipToiFile = runSGet getTipToiFile++
+ src/GMERun.hs view
@@ -0,0 +1,88 @@+module GMERun (playTipToi) where++import Text.Printf+import Data.Bits+import Data.List+import qualified Data.Map as M++import Types+import PrettyPrint+import Utils++type PlayState r = M.Map r Word16++formatState :: PlayState ResReg -> String+formatState s = spaces $+ map (\(k,v) -> printf "$%d=%d" k v) $+ filter (\(k,v) -> k == 0 || v /= 0) $+ M.toAscList s++playTipToi :: Transscript -> TipToiFile -> IO ()+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+ 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+ 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+ Just l -> do+ printf "Executing: %s\n" (ppLine t l)+ let s' = applyLine l s+ printf "State now: %s\n" (formatState s')+ return s'++enabledLine :: Ord r => PlayState r -> Line r -> Bool+enabledLine s (Line _ cond _ _) = all (condTrue s) cond++condTrue :: Ord r => PlayState r -> Conditional r -> Bool+condTrue s (Cond v1 o v2) = value s v1 =?= value s v2+ where+ (=?=) = case o of+ Eq -> (==)+ NEq -> (/=)+ Lt -> (<)+ GEq -> (>=)+ _ -> \_ _ -> False++value :: Ord r => PlayState r -> TVal r -> Word16+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+ 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++ neg 0 = 1+ neg _ = 0++ applyOp Inc = (+)+ applyOp Dec = (-)+ applyOp Mult = (*)+ applyOp Div = div+ applyOp Mod = mod+ applyOp And = (.&.)+ applyOp Or = (.|.)+ applyOp XOr = xor+ applyOp Set = \_ v -> v++++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+
+ src/GMEWriter.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE RankNTypes, RecursiveDo, RecordWildCards, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}++module GMEWriter (writeTipToiFile) where++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Builder as Br+import Text.Printf+import Control.Monad+import Control.Applicative (Applicative)+import qualified Data.Map as M+import Control.Monad.Writer.Strict+import Control.Monad.State.Strict++import Types+import Constants+import Cypher+++-- Assembling .gme files++-- Assembly monad+-- We need a data structure that we can extract its length from before we know its values+-- So we will use a lazy pair of length (Int) and builder++newtype SPutM a = SPutM (StateT Word32 (Writer Br.Builder) a)+ deriving (Functor, Applicative, Monad, MonadFix)+type SPut = SPutM ()++putWord8 :: Word8 -> SPut+putWord8 w = SPutM (tell (Br.singleton w) >> modify (+1))++putWord16 :: Word16 -> SPut+putWord16 w = SPutM (tell (Br.putWord16le w) >> modify (+2))++putWord32 :: Word32 -> SPut+putWord32 w = SPutM (tell (Br.putWord32le w) >> modify (+4))++putBS :: B.ByteString -> SPut+putBS bs = SPutM (tell (Br.fromLazyByteString bs) >> modify (+ fromIntegral (B.length bs)))++putArray :: Integral n => (n -> SPut) -> [SPut] -> SPut+putArray h xs = do+ h (fromIntegral (length xs))+ sequence_ xs++data FunSplit m where+ FunSplit :: forall m a . (a -> m ()) -> m a -> FunSplit m+++mapFstMapSnd :: forall m. MonadFix m => [FunSplit m] -> m ()+mapFstMapSnd xs = go xs (return ())+ where+ go :: [FunSplit m] -> m b -> m b+ go [] cont = cont+ go (FunSplit f s:xs) cont = mdo+ f v+ (v,vs) <- go xs $ do+ vs <- cont+ v <- s+ return (v,vs)+ return vs++offsetsAndThen :: [SPut] -> SPut+offsetsAndThen = mapFstMapSnd . map go+ where go x = FunSplit putWord32 (getAddress x)++putOffsets :: Integral n => (n -> SPut) -> [SPut] -> SPut+putOffsets h xs = mdo+ h (fromIntegral (length xs))+ offsetsAndThen xs++seek :: Word32 -> SPut+seek to = SPutM $ do+ now <- get+ when (now > to) $ do+ fail $ printf "Cannot seek to 0x%08X, already at 0x%08X" to now+ tell $ (Br.fromLazyByteString (B.replicate (fromIntegral (to-now)) 0))+ modify (+ (to-now))++-- Puts something, returning the offset to the beginning of it.+getAddress :: SPut -> SPutM Word32+getAddress (SPutM what) = SPutM $ do+ a <- get+ what+ return a++runSPut :: SPut -> B.ByteString+--runSPut (SPutM act) = Br.toLazyByteString $ evalState (execWriterT act) 0+runSPut (SPutM act) = Br.toLazyByteString $ execWriter (evalStateT act 0)+++putTipToiFile :: TipToiFile -> SPut+putTipToiFile (TipToiFile {..}) = mdo+ putWord32 sto+ putWord32 mft+ putWord32 0x238b+ putWord32 ast -- Additional script table+ putWord32 gto -- Game table offset+ putWord32 ttProductId+ putWord32 iro+ putWord32 ttRawXor+ putWord8 $ fromIntegral (B.length ttComment)+ putBS ttComment+ putBS ttDate+ seek 0x0071 -- Just to be safe+ putWord32 ipllo+ seek 0x0200 -- Just to be safe+ sto <- getAddress $ putScriptTable ttScripts+ ast <- getAddress $ putWord16 0x00 -- For now, no additional script table+ gto <- getAddress $ putGameTable+ iro <- getAddress $ putInitialRegs ttInitialRegs+ mft <- getAddress $ putAudioTable ttAudioXor ttAudioFiles+ ipllo <- getAddress $ putOffsets putWord16 $ map putPlayList ttWelcome+ return ()++putGameTable :: SPut+putGameTable = mdo+ putWord32 1 -- Hardcoded empty+ putWord32 offset+ offset <- getAddress $ do+ putWord16 253+ putWord16 0+ return ()+++putScriptTable :: [(Word16, Maybe [Line ResReg])] -> SPut+putScriptTable [] = error "Cannot create file with an empty script table"+putScriptTable scripts = mdo+ putWord32 (fromIntegral last)+ putWord32 (fromIntegral first)+ mapFstMapSnd (map go [first .. last])+ return ()+ where+ go i = case M.lookup i m of+ Just (Just l) -> FunSplit putWord32 (getAddress $ putLines l)+ _ -> FunSplit (\_ -> putWord32 0xFFFFFFFF) (return ())+ m = M.fromList scripts+ first = fst (M.findMin m)+ last = fst (M.findMax m)++putInitialRegs :: [Word16] -> SPut+putInitialRegs = putArray putWord16 . map putWord16++putLines :: [Line ResReg] -> SPut+putLines = putOffsets putWord16 . map putLine++putLine :: Line ResReg -> SPut+putLine (Line _ conds acts idx) = do+ putArray putWord16 $ map putCond conds+ putArray putWord16 $ map putCommand acts+ putPlayList idx++putPlayList :: PlayList -> SPut+putPlayList = putArray putWord16 . map putWord16++putCond :: Conditional ResReg -> SPut+putCond (Cond v1 o v2) = do+ putTVal v1+ putCondOp o+ putTVal v2++putTVal :: TVal ResReg -> SPut+putTVal (Reg n) = do+ putWord8 0+ putWord16 n+putTVal (Const n) = do+ putWord8 1+ putWord16 n++putCondOp :: CondOp -> SPut+putCondOp Eq = mapM_ putWord8 [0xF9, 0xFF]+putCondOp Gt = mapM_ putWord8 [0xFA, 0xFF]+putCondOp Lt = mapM_ putWord8 [0xFB, 0xFF]+putCondOp GEq = mapM_ putWord8 [0xFD, 0xFF]+putCondOp LEq = mapM_ putWord8 [0xFE, 0xFF]+putCondOp NEq = mapM_ putWord8 [0xFF, 0xFF]+putCondOp (Unknowncond b) = putBS b+++putCommand :: Command ResReg -> SPut+putCommand (ArithOp o r v) = do+ putWord16 r+ mapM_ putWord8 $ arithOpCode o+ putTVal v+putCommand (Neg r) = do+ putWord16 r+ mapM_ putWord8 [0xF8, 0xFF]+ putTVal (Const 0)+putCommand (Play n) = do+ putWord16 0+ mapM_ putWord8 [0xE8, 0xFF]+ putTVal (Const (fromIntegral n))+putCommand (Random a b) = do+ putWord16 0+ mapM_ putWord8 [0x00, 0xFC]+ putTVal (Const (lowhigh a b))+putCommand (Game n) = do+ putWord16 0+ mapM_ putWord8 [0x00, 0xFD]+ putTVal (Const n)+putCommand Cancel = do+ putWord16 0+ mapM_ putWord8 [0xFF, 0xFA]+ putTVal (Const 0xFFFF)+putCommand (Jump v) = do+ putWord16 0+ mapM_ putWord8 [0xFF, 0xF8]+ putTVal v+putCommand (NamedJump s) = error "putCommand: Unresolved NamedJump"+putCommand (Unknown b r v) = do+ putWord16 r+ putBS b+ putTVal v++putAudioTable :: Word8 -> [B.ByteString] -> SPut+putAudioTable x as = mapFstMapSnd+ [ FunSplit (\o -> putWord32 o >> putWord32 (fromIntegral (B.length a)))+ (getAddress (putBS (cypher x a)))+ | a <- as ]++lowhigh :: Word8 -> Word8 -> Word16+lowhigh a b = fromIntegral a + fromIntegral b * 2^8++writeTipToiFile :: TipToiFile -> B.ByteString+writeTipToiFile tt = runSPut (putTipToiFile tt)
+ src/Lint.hs view
@@ -0,0 +1,48 @@+module Lint (lintTipToi) where++import Text.Printf+import Data.Maybe+import Control.Monad+import qualified Data.Map as M++import Types+import PrettyPrint++lintTipToi :: TipToiFile -> Segments -> IO ()+lintTipToi tt segments = do+ let hyps = [ (hyp1, "play indicies are correct")+ , (hyp2 (fromIntegral (length (ttAudioFiles tt))),+ "media indicies are correct")+ ]+ forM_ hyps $ \(hyp, desc) -> do+ let wrong = filter (not . hyp) (concat (mapMaybe snd (ttScripts tt)))+ if null wrong+ then printf "All lines do satisfy hypothesis \"%s\"!\n" desc+ else do+ printf "These lines do not satisfy hypothesis \"%s\":\n" desc+ forM_ wrong $ \line -> do+ printf " %s\n" (ppLine M.empty line)++ let overlapping_segments =+ filter (\((o1,l1,_),(o2,l2,_)) -> o1+l1 > o2) $+ zip segments (tail segments)+ unless (null overlapping_segments) $ do+ printf "Overlapping segments: %d\n"+ (length overlapping_segments)+ forM_ overlapping_segments $ \((o1,l1,d1),(o2,l2,d2)) ->+ printf " Offset %08X Size %d (%s) overlaps Offset %08X Size %d (%s) by %d\n"+ o1 l1 (ppDesc d1) o2 l2 (ppDesc d2) (o1 + l1 - o2)+ where+ hyp1 :: Line ResReg -> Bool+ hyp1 (Line _ _ as mi) = all ok as+ where ok (Play n) = 0 <= n && n < fromIntegral (length mi)+ ok (Random a b) = 0 <= a && a < fromIntegral (length mi) &&+ 0 <= b && b < fromIntegral (length mi)+ ok _ = True++ hyp2 :: Word16 -> Line ResReg -> Bool+ hyp2 n (Line _ _ _ mi) = all (<= n) mi++++
+ src/OidCode.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE BangPatterns #-}++module OidCode where++import Data.Word+import Data.Bits+import Data.Functor+import Control.Monad+import Control.Monad.Writer.Strict+import Codec.Picture+import Codec.Picture.Types+import Control.Monad.ST+import Control.Applicative++-- Image generation++checksum :: Word16 -> Word16+checksum dec = c3+ where+ c1 = (((dec >> 2) ^ (dec >> 8) ^ (dec >> 12) ^ (dec >> 14)) & 0x01) << 1+ c2 = c1 .|. (((dec) ^ (dec >> 4) ^ (dec >> 6) ^ (dec >> 10)) & 0x01)+ c3 = c2 ^ 0x02++ (>>) = shiftR+ (<<) = shiftL+ (^) = xor+ (&) = (.&.)+++{-+oidSVG :: Int -> S.Svg+oidSVG code | code >= 4^8 = error $ printf "Code %d too large to draw" code+oidSVG code = S.docTypeSvg ! A.version (S.toValue "1.1")+ ! A.width (S.toValue "1mm")+ ! A.height (S.toValue "1mm")+ ! A.viewbox (S.toValue "0 0 48 48") $ do+ S.defs pattern+ S.rect ! A.width (S.toValue "48") ! A.height (S.toValue "48")+ ! A.fill (S.toValue $ "url(#"++patid++")")+ where+ quart 8 = checksum code+ quart n = (code `div` 4^n) `mod` 4+ patid = "pat-" ++ show code++ pattern = S.pattern ! A.width (S.toValue "48")+ ! A.height (S.toValue "48")+ ! A.id_ (S.toValue patid)+ ! A.patternunits (S.toValue "userSpaceOnUse") $ S.g (f (0,0))+ f = mconcat $ map position $+ zip (flip (,) <$> [3,2,1] <*> [3,2,1])+ [ value (quart n) | n <- [0..8] ] +++ [ (p, plain) | p <- [(0,0), (1,0), (2,0), (3,0), (0,1), (0,3) ] ] +++ [ ((0,2), special) ]++ -- pixel = S.rect ! A.width (S.toValue "2") ! A.height (S.toValue "2") ! pos (7,7)+ pixel (x,y) = S.path ! A.d path+ where path = mkPath $ do+ S.m (x+5) (y+5)+ S.hr 2+ S.vr 2+ S.hr (-2)+ S.z++ plain = pixel+ value 0 = at (2,2) plain+ value 1 = at (-2,2) plain+ value 2 = at (-2,-2) plain+ value 3 = at (2,-2) plain+ special = at (3,0) plain++ position ((n,m), p) = at (n*12, m*12) p++ -- Drawing combinators+ at (x, y) f = f . ((+x) *** (+y))++genSVGs :: String -> IO ()+genSVGs code_str = do+ codes <- parseRange code_str+ forM_ codes $ \c -> do+ let filename = printf "oid%d.svg" c+ printf "Writing %s...\n" filename+ genSVG c filename++genSVG :: Int -> FilePath -> IO ()+genSVG code filename = B.writeFile filename (renderSvg (oidSVG code))+-}++data DPI = D1200 | D600++imageFromBlackPixels :: Int -> Int -> [(Int, Int)] -> Image PixelYA8+imageFromBlackPixels width height pixels = runST $ do + i <- createMutableImage width height background+ forM_ pixels $ \(x,y) -> do+ writePixel i x y black+ freezeImage i+ where+ black = PixelYA8 minBound maxBound+ background = PixelYA8 maxBound minBound++oidImage :: DPI -> Word16 -> Image PixelYA8+oidImage dpi code =+ imageFromBlackPixels+ (width *4*dotsPerPoint)+ (height*4*dotsPerPoint)+ (tile f)+ where+ width = 100 -- in mm+ height = 100 -- in mm+ !dotsPerPoint | D1200 <- dpi = 12+ | D600 <- dpi = 6+++ quart 8 = checksum code+ quart n = (code `div` 4^n) `mod` 4++ f = mconcat $ map position $+ zip (flip (,) <$> [3,2,1] <*> [3,2,1])+ [ value (quart n) | n <- [0..8] ] +++ [ (p, plain) | p <- [(0,0), (1,0), (2,0), (3,0), (0,1), (0,3) ] ] +++ [ ((0,2), special) ]++ plain | D1200 <- dpi = [ (5,5), (5,6), (6,5), (6,6) ]+ | D600 <- dpi = [ (3,3) ]++ s | D1200 <- dpi = 2+ | D600 <- dpi = 1+ ss | D1200 <- dpi = 3+ | D600 <- dpi = 2+ value 0 = at ( s, s) plain+ value 1 = at (-s, s) plain+ value 2 = at (-s,-s) plain+ value 3 = at ( s,-s) plain+ special = at (ss,0) plain++ position ((n,m), p) = at (n*dotsPerPoint, m*dotsPerPoint) p++ -- Drawing combinators++ at (x, y) = map (\(x', y') -> (x + x', y + y'))+ tile f = concat [ at (x*4*dotsPerPoint, y*4*dotsPerPoint) f+ | x <- [0..width-1], y <- [0..height-1]]++++genPNG :: DPI -> Word16 -> FilePath -> IO ()+genPNG dpi code filename = writePng filename (oidImage dpi code)+
+ src/OneLineParser.hs view
@@ -0,0 +1,31 @@+module OneLineParser (parseOneLine) where++import System.Exit+import Text.Parsec hiding (Line, lookAhead, spaces)+import Text.Parsec.String+import Text.Parsec.Error+import qualified Text.Parsec as P++-- Parser utilities+-- | A nicer way to print an error message++printLineParserErrorMessage :: String -> ParseError -> IO a+printLineParserErrorMessage input err = do+ putStrLn (lineParserErrorMessage input err)+ exitFailure++lineParserErrorMessage :: String -> ParseError -> String+lineParserErrorMessage input err =+ "In " ++ sourceName pos ++ " column " ++ show (sourceColumn pos) ++ ":\n" +++ input ++ "\n" +++ replicate (sourceColumn pos - 1) ' ' ++ "↑" +++ showErrorMessages "or" "unknown parse err" "expecting"+ "unexpected" "end of input"+ (errorMessages err)+ where pos = errorPos err++parseOneLine :: Parser a -> String -> String -> IO a+parseOneLine p name input =+ case P.parse p name input of+ Left e -> printLineParserErrorMessage input e+ Right l -> return l
+ src/PrettyPrint.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE TypeSynonymInstances #-}+module PrettyPrint where++import qualified Data.ByteString.Lazy as B+import Text.Printf+import Data.List+import Data.Maybe+import qualified Data.Map as M++import Types++-- Pretty printing++lineHex bytes l = prettyHex $ extract (lineOffset l) (lineLength l) bytes++extract :: Offset -> Word32 -> B.ByteString -> B.ByteString+extract off len = B.take (fromIntegral len) . B.drop (fromIntegral off)++lineOffset (Line o _ _ _) = o++lineLength :: Line r -> Word32+lineLength (Line _ conds cmds audio) = fromIntegral $+ 2 + 8 * length conds + 2 + 7 * length cmds + 2 + 2 * length audio++ppLine :: Transscript -> Line ResReg -> String+ppLine t (Line _ cs as xs) = spaces $+ map ppConditional cs ++ map (ppCommand False t xs) as++-- Varaint that does not generate invalid play commands+exportLine :: Line ResReg -> String+exportLine (Line _ cs as xs) = spaces $+ map ppConditional cs ++ map (ppCommand True M.empty xs) as++-- Group consecutive runs of numbers, if they do not have a description+groupRuns :: (Eq a, Enum a) => (a -> Maybe b) -> [a] -> [Either b [a]]+groupRuns l = go+ where+ go [] = []+ go [x] = case l x of Nothing -> [Right [x]]+ Just s -> [Left s]+ go (x:xs) = case l x of+ Just l -> Left l : go xs+ Nothing -> case go xs of+ Right (y:ys):r' | succ x == y -> Right (x:y:ys) : r'+ r -> Right [x] : r++ppPlayList :: Transscript -> PlayList -> String+ppPlayList t xs = "[" ++ commas (map go (groupRuns (flip M.lookup t) xs)) ++ "]"+ where go (Left s) = quote s+ go (Right []) = error "Empty list in groupRuns result"+ go (Right l) | length l > 3 = show (head l) ++ ".." ++ show (last l)+ | otherwise = commas (map show l)++ppOidList :: [OID] -> String+ppOidList xs = "[" ++ commas (map go (groupRuns (const Nothing) xs)) ++ "]"+ where go (Left s) = s+ go (Right []) = error "Empty list in groupRuns result"+ go (Right l) | length l > 3 = show (head l) ++ ".." ++ show (last l)+ | otherwise = commas (map show l)++ppPlayListList :: Transscript -> PlayListList -> String+ppPlayListList t xs = "[" ++ commas (map (ppPlayList t) xs) ++ "]"++ppConditional :: Conditional ResReg -> String+ppConditional (Cond v1 o v2) = printf "%s%s%s?" (ppTVal v1) (ppCondOp o) (ppTVal v2)++ppCondOp :: CondOp -> String+ppCondOp Eq = "=="+ppCondOp NEq = "!="+ppCondOp Lt = "< "+ppCondOp Gt = "> "+ppCondOp GEq = ">="+ppCondOp LEq = "<="+ppCondOp (Unknowncond b) = printf "?%s?" (prettyHex b)++ppTVal :: Reg r => TVal r -> String+ppTVal (Reg r) = ppReg r+ppTVal (Const n) = show n+++ppResReg :: ResReg -> String+ppResReg n = "$" ++ show n++ppRegister :: Register -> String+ppRegister (RegPos n) = "$" ++ show n+ppRegister (RegName n) = "$" ++ n++class Reg a where+ ppReg :: a -> String++instance Reg ResReg where ppReg = ppResReg+instance Reg Register where ppReg = ppRegister++ppArithOp :: ArithOp -> String+ppArithOp Inc = "+="+ppArithOp Dec = "-="+ppArithOp Mult = "*="+ppArithOp Div = "/="+ppArithOp Mod = "%="+ppArithOp And = "&="+ppArithOp Or = "|="+ppArithOp XOr = "^="+ppArithOp Set = ":="++ppCommand :: Reg r => Bool -> Transscript -> PlayList -> Command r -> String+ppCommand True t xs (Play n) | not (validIndex xs (fromIntegral n)) = ""+ppCommand True t xs (Random a b) | any (not . validIndex xs . fromIntegral) [b..a] = ""++ppCommand _ t xs (Play n) = printf "P(%s)" (ppPlayIndex t xs (fromIntegral n))+ppCommand _ t xs (Random a b) = printf "P(%s)" $ commas $ map (ppPlayIndex t xs . fromIntegral ) [b..a]+ppCommand _ t xs (Cancel) = printf "C"+ppCommand _ t xs (Jump v) = printf "J(%s)" (ppTVal v)+ppCommand _ t xs (NamedJump v) = printf "J(%s)" v+ppCommand _ t xs (Game b) = printf "G(%d)" b+ppCommand _ t xs (ArithOp o r n) = ppReg r ++ ppArithOp o ++ ppTVal n+ppCommand _ t xs (Neg r) = printf "Neg(%s)" (ppReg r)+ppCommand _ t xs (Unknown b r n) = printf "?(%s,%s) (%s)" (ppReg r) (ppTVal n) (prettyHex b)++validIndex :: PlayList -> Int -> Bool+validIndex xs n = n >= 0 && n < length xs++ppPlayIndex :: Transscript -> PlayList -> Int -> String+ppPlayIndex t xs n | validIndex xs n = transcribe t (xs !! n)+ | otherwise = "invalid_index_" ++ show n++spaces = intercalate " "+commas = intercalate ","+quote s = printf "'%s'" s++ppGame :: Transscript -> Game -> String+ppGame t (Game6 u1 u2 plls sg1s sg2s u3 pll2s pl) =+ printf (unlines [" type: 6", " u1: %d", " u2: %s",+ " playlistlists: (%d)", "%s",+ " subgames1: (%d)", "%s",+ " subgames2: (%d)", "%s",+ " u3: %s",+ " playlistlists: (%d)","%s",+ " playlist: %s"])+ u1 (prettyHex u2)+ (length plls) (indent 4 (map (ppPlayListList t) plls))+ (length sg1s) (concatMap (ppSubGame t) sg1s)+ (length sg2s) (concatMap (ppSubGame t) sg2s)+ (prettyHex u3)+ (length pll2s) (indent 4 (map (ppPlayListList t) pll2s))+ (show pl)+ppGame t (Game7 u1 c u2 plls sgs u3 pll2s pll) =+ printf (unlines [" type: 6", " u1: %d", " u2: %s",+ " playlistlists: (%d)", "%s",+ " subgames: (%d)", "%s",+ " u3: %s",+ " playlistlists: (%d)","%s",+ " playlistlist: %s"])+ u1 (prettyHex u2)+ (length plls) (indent 4 (map (ppPlayListList t) plls))+ (length sgs) (concatMap (ppSubGame t) sgs)+ (prettyHex u3)+ (length pll2s) (indent 4 (map (ppPlayListList t) pll2s))+ (ppPlayListList t pll)+ppGame t (Game8 u1 c u2 plls sgs u3 pll2s oidl gidl pll1 pll2) =+ printf (unlines [" type: 6", " u1: %d", " u2: %s",+ " playlistlists: (%d)", "%s",+ " subgames: (%d)", "%s",+ " u3: %s",+ " playlistlists: (%d)","%s",+ " oids: %s",+ " gids: %s",+ " playlistlist: %s",+ " playlistlist: %s"+ ])+ u1 (prettyHex u2)+ (length plls) (indent 4 (map (ppPlayListList t) plls))+ (length sgs) (concatMap (ppSubGame t) sgs)+ (prettyHex u3)+ (length pll2s) (indent 4 (map (ppPlayListList t) pll2s))+ (ppOidList oidl) (show gidl)+ (ppPlayListList t pll1) (ppPlayListList t pll2)+ppGame t (UnknownGame typ u1 c u2 plls sgs u3 pll2s) =+ printf (unlines [" type: %d",+ " u1: %d",+ " c: %d",+ " u2: %s",+ " playlistlists: (%d)", "%s",+ " subgames: (%d)", "%s",+ " u3: %s",+ " playlistlists: (%d)","%s"])+ typ u1 c (prettyHex u2)+ (length plls) (indent 4 (map (ppPlayListList t) plls))+ (length sgs) (concatMap (ppSubGame t) sgs)+ (prettyHex u3)+ (length pll2s) (indent 4 (map (ppPlayListList t) pll2s))+ppGame t Game253 =+ printf (unlines [" type: 253"+ ])+ppGame t _ = "TODO"++ppSubGame :: Transscript -> SubGame -> String+ppSubGame t (SubGame u oids1 oids2 oids3 plls) = printf (unlines+ [ " Subgame:"+ , " u: %s"+ , " oids1: %s"+ , " oids2: %s"+ , " oids3: %s"+ , " playlistlists: (%d)" , "%s"+ ])+ (prettyHex u)+ (ppOidList oids1) (ppOidList oids2) (ppOidList oids3)+ (length plls) (indent 8 (map (ppPlayListList t) plls))++indent n = intercalate "\n" . map (replicate n ' ' ++)++checkLine :: Int -> Line ResReg -> [String]+checkLine n_audio l@(Line _ _ _ xs)+ | any (>= fromIntegral n_audio) xs+ = return $ "Invalid audio index in line " ++ ppLine M.empty l+checkLine n_audio _ = []+++prettyHex :: B.ByteString -> String+prettyHex = intercalate " " . map (printf "%02X") . B.unpack++transcribe :: Transscript -> Word16 -> String+transcribe t idx = fromMaybe (show idx) (M.lookup idx t)++ppDesc :: [String] -> String+ppDesc = intercalate "/"
+ src/RangeParser.hs view
@@ -0,0 +1,28 @@+module RangeParser (parseRange) where++import Text.Printf+import Data.Functor+import Control.Monad+import Text.Parsec hiding (Line, lookAhead, spaces)+import Text.Parsec.String+import qualified Text.Parsec as P++import Types+import OneLineParser++parseRange :: String -> IO [Word16]+parseRange = parseOneLine rangeParser "command line"++rangeParser :: Parser [Word16]+rangeParser = concat <$> oneRangeParser `sepBy1` many1 (P.char ' ' <|> P.char ',')++oneRangeParser = do+ n <- read `fmap` many1 digit <?> "Number"+ skipMany (char ' ')+ choice+ [ do char '-'+ n' <- read `fmap` many1 digit <?> "Number"+ unless (n' > n) $ fail $ printf "%d is not larger than %d" n' n+ return [n..n']+ , return [n]+ ]
+ src/TipToiYaml.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE RecordWildCards, DeriveGeneric, CPP #-}++module TipToiYaml+ ( tt2ttYaml, ttYaml2tt+ , readTipToiYaml, writeTipToiYaml,writeTipToiCodeYaml+ , ttyProduct_Id+ )+where++import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as BC+import qualified Data.ByteString.Char8 as SBC+import System.Exit+import System.FilePath+import Text.Printf+import Data.Char+import Data.Either+import Data.Functor+import Data.Maybe+import Control.Monad+import System.Directory+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad.Writer.Strict+#if MIN_VERSION_time(1,5,0)+import Data.Time.Format (defaultTimeLocale)+#else+import System.Locale (defaultTimeLocale)+#endif+import Data.Time (getCurrentTime, formatTime)+import Data.Yaml hiding ((.=), Parser)+import Data.Aeson.Types hiding ((.=), Parser)+import Text.Parsec hiding (Line, lookAhead, spaces)+import Text.Parsec.String+import qualified Text.Parsec as P+import qualified Text.Parsec.Token as P+import Text.Parsec.Language (emptyDef)+import GHC.Generics+import qualified Data.Foldable as F+import Control.Arrow+import Control.Applicative ((<*>), (<*))++import Types+import Constants+import PrettyPrint+import OneLineParser+import Utils++type CodeMap = M.Map String Word16++data TipToiYAML = TipToiYAML+ { ttyScripts :: M.Map String [String]+ , ttyComment :: Maybe String+ , ttyMedia_Path :: Maybe String+ , ttyInit :: Maybe String+ , ttyWelcome :: Maybe String+ , ttyProduct_Id :: Word32+ , ttyScriptCodes :: Maybe CodeMap+ }+ deriving Generic++data TipToiCodesYAML = TipToiCodesYAML+ { ttcScriptCodes :: CodeMap+ }+ deriving Generic++options = defaultOptions { fieldLabelModifier = map fix . map toLower . drop 3 }+ where fix '_' = '-'+ fix c = c++instance FromJSON TipToiYAML where+ parseJSON = genericParseJSON $ options+instance ToJSON TipToiYAML where+ toJSON = genericToJSON $ options+instance FromJSON TipToiCodesYAML where+ parseJSON = genericParseJSON $ options+instance ToJSON TipToiCodesYAML where+ toJSON = genericToJSON $ options+++tt2ttYaml :: String -> TipToiFile -> TipToiYAML+tt2ttYaml path (TipToiFile {..}) = TipToiYAML+ { ttyProduct_Id = ttProductId+ , ttyInit = Just $ spaces $ [ ppCommand True M.empty [] (ArithOp Set (RegPos r) (Const n))+ | (r,n) <- zip [0..] ttInitialRegs , n /= 0]+ , ttyWelcome = Just $ commas $ map show $ concat ttWelcome+ , ttyComment = Just $ BC.unpack ttComment+ , ttyScripts = M.fromList+ [ (show oid, map exportLine ls) | (oid, Just ls) <- ttScripts]+ , ttyMedia_Path = Just path+ , ttyScriptCodes = Nothing+ }+++mergeOnlyEqual :: String -> Word16 -> Word16 -> Word16+mergeOnlyEqual _ c1 c2 | c1 == c2 = c1+mergeOnlyEqual s c1 c2 = error $+ printf "The .yaml file specifies code %d for script \"%s\",\+ \but the .codes.yamls file specifies %d. Please fix this!" c2 s c1++scriptCodes :: [String] -> CodeMap -> Either String (String -> Word16, CodeMap)+scriptCodes [] codeMap = Right (error "scriptCodes []", codeMap)+scriptCodes codes codeMap+ | null strs = Right (readCode, codeMap)+ | length strs > length availableCodes = Left "Too many codes used"+ | null nums = Right (lookupCode, totalMap)+ | otherwise = Left "Cannot mix numbers and names in scripts."+ where+ (strs, nums) = partitionEithers $ map f codes+ newStrs = filter (`M.notMember` codeMap) strs+ usedCodes = S.fromList $ M.elems codeMap++ availableCodes = filter (`S.notMember` usedCodes) knownCodes++ f s = case readMaybe s of+ Nothing -> Left s + Just n -> Right (n::Word16)+ newAssignments = M.fromList (zip newStrs availableCodes)+ totalMap = M.unionWithKey (\_ _ _ -> error "scriptCodes: conflict!") codeMap newAssignments++ readCode s = case readMaybe s of+ Nothing -> error $ printf "Cannot jump to named script \"%s\" in a yaml with numbered scripts." s+ Just c -> c+ lookupCode s = case M.lookup s totalMap of+ Nothing -> error $ printf "Cannot jump to unknown script \"%s\"." s+ Just c -> c++resolveRegs :: (M.Map Register Word16, [(t0, Maybe [Line Register])]) -> (M.Map ResReg Word16, [(t0, Maybe [Line ResReg])])+resolveRegs x = everywhere x+ where+ -- Could use generics somehow+ regs = S.fromList $+ M.keys (fst x) ++ concatMap (maybe [] (concatMap F.toList) . snd) (snd x)+ -- Could use generics somehow+ everywhere = M.mapKeys resolve *** map (second (fmap (map (fmap resolve))))+++ regNums = S.fromList [ n | RegPos n <- S.toList regs ]+ regNames = [ n | RegName n <- S.toList regs ]+ mapping = M.fromList $ zip regNames [n | n <- [0..], n `S.notMember` regNums]+ resolve (RegPos n) = n+ resolve (RegName n) = fromMaybe (error "resolveRegs broken") (M.lookup n mapping)++resolveJumps :: (String -> Word16) -> [(a, Maybe [Line b])] -> [(a, Maybe [Line b])]+resolveJumps m = everywhere+ where + everywhere = map (second (fmap (map resolveLine)))+ resolveLine (Line o cond cmds acts) = (Line o cond (map resolve cmds) acts)+ resolve (NamedJump n) = Jump (Const (m n))+ resolve c = c+++ttYaml2tt :: FilePath -> TipToiYAML -> CodeMap -> IO (TipToiFile, CodeMap)+ttYaml2tt dir (TipToiYAML {..}) extCodeMap = do+ now <- getCurrentTime+ let date = formatTime defaultTimeLocale "%Y%m%d" now++ let codeMap = M.unionWithKey mergeOnlyEqual+ extCodeMap+ (fromMaybe M.empty ttyScriptCodes)++ (scriptMap, totalMap) <- case scriptCodes (M.keys ttyScripts) codeMap of+ Left e -> fail e+ Right f -> return f++ let m = M.mapKeys scriptMap ttyScripts+ first = fst (M.findMin m)+ last = fst (M.findMax m)++ welcome_names <- parseOneLine parseWelcome "welcome" (fromMaybe "" ttyWelcome)++ (prescripts, filenames) <- liftM unzip $ forM [first .. last] $ \oid -> do+ case M.lookup oid m of+ Nothing -> return (\_ -> (oid, Nothing), [])+ Just raw_lines -> do+ (lines, filenames) <- liftM unzip $ forMn raw_lines $ \i raw_line -> do+ let d = printf "Line %d of OID %d" i oid+ (l,s) <- parseOneLine parseLine d raw_line+ return (\f -> l (map f s), s)+ return (\f -> (oid, Just (map ($ f) lines)), concat filenames)++ let filenames' = S.toList $ S.fromList $ welcome_names ++ concat filenames+ let filename_lookup = (M.fromList (zip filenames' [0..]) M.!)++ let welcome = [map filename_lookup welcome_names]++ preInitRegs <- M.fromList <$> parseOneLine parseInitRegs "init" (fromMaybe "" ttyInit)++ -- resolve registers+ let (initRegs, scripts) = resolveRegs (preInitRegs, map ($ filename_lookup) prescripts)++ -- resolve named jumps+ let scripts' = resolveJumps scriptMap scripts++ let maxReg = maximum $ 0:+ [ r+ | (_, Just ls) <- scripts'+ , Line _ cs as _ <- ls+ , r <- concatMap F.toList cs ++ concatMap F.toList as ]++++ files <- forM filenames' $ \fn -> do+ let paths = [ combine dir relpath+ | ext <- map snd fileMagics+ , let pat = fromMaybe "%s" ttyMedia_Path+ , let relpath = printf pat fn <.> ext+ ]+ ex <- filterM doesFileExist paths+ case ex of+ [] -> do+ putStrLn "Could not find any of these files:"+ mapM_ putStrLn paths+ exitFailure+ [f] -> B.readFile f+ _ -> do+ putStrLn "Multiple matching files found:"+ mapM_ putStrLn ex+ exitFailure++ return $ (TipToiFile+ { ttProductId = ttyProduct_Id+ , ttRawXor = 0x00000039 -- from Bauernhof+ , ttComment = BC.pack (fromMaybe "created with tip-toi-reveng" ttyComment)+ , ttDate = BC.pack date+ , ttWelcome = welcome+ , ttInitialRegs = [fromMaybe 0 (M.lookup r initRegs) | r <- [0..maxReg]]+ , ttScripts = scripts'+ , ttGames = []+ , ttAudioFiles = files+ , ttAudioXor = 0xAD+ , ttAudioFilesDoubles = False+ , ttChecksum = 0x00+ , ttChecksumCalc = 0x00+ }, totalMap)+++lexer = P.makeTokenParser $+ emptyDef+ { P.reservedOpNames = words ":= == /= < >="+ , P.opLetter = oneOf ":!#%&*+./<=>?@\\^|-~" -- Removed $, used for registers+ }++parseLine :: Parser ([Word16] -> Line Register, [String])+parseLine = do+ conds <- many (P.try parseCond)+ (acts, filenames) <- parseCommands 0+ eof+ return (Line 0 conds acts, filenames)++descP d p = p <?> d++parseCond :: Parser (Conditional Register)+parseCond = descP "Conditional" $ do+ v1 <- parseTVal+ op <- parseCondOp+ v2 <- parseTVal+ P.lexeme lexer (char '?')+ return (Cond v1 op v2)++parseWord16 :: Parser Word16+parseWord16 = fromIntegral <$> P.natural lexer++parseReg :: Parser Register+parseReg = P.lexeme lexer $ char '$' >> (RegPos <$> parseWord16 <|> RegName <$> many1 (alphaNum <|> char '_'))++parseTVal :: Parser (TVal Register)+parseTVal = (Reg <$> parseReg <|> Const <$> parseWord16) <?> "Value"++parseCondOp :: Parser CondOp+parseCondOp = choice+ [ P.reservedOp lexer "==" >> return Eq+ , P.reservedOp lexer "<" >> return Lt+ , P.reservedOp lexer ">" >> return Gt+ , P.reservedOp lexer ">=" >> return GEq+ , P.reservedOp lexer "<=" >> return LEq+ , P.reservedOp lexer "/=" >> return NEq+ , P.reservedOp lexer "!=" >> return NEq+ ]++parseInitRegs :: Parser [(Register, Word16)]+parseInitRegs = many $ do+ r <- parseReg+ P.reservedOp lexer ":="+ v <- parseWord16+ return (r,v)++parseWelcome :: Parser [String]+parseWelcome = P.commaSep lexer $ parseAudioRef++parseAudioRef :: Parser String+parseAudioRef = P.lexeme lexer $ many1 (alphaNum <|> char '_')++parseScriptRef :: Parser String+parseScriptRef = P.lexeme lexer $ many1 (alphaNum <|> char '_')++parsePrettyHex :: Parser B.ByteString+parsePrettyHex = B.pack <$> many1 (P.lexeme lexer nibble)+ where+ nibble = fromIntegral <$> number 16 hexDigit+ number base baseDigit+ = do{ digits <- many1 baseDigit+ ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+ ; seq n (return n)+ }+++parseCommands :: Int -> Parser ([Command Register], [String])+parseCommands i =+ choice+ [ eof >> return ([],[])+ , descP "Register action" $+ do r <- parseReg+ op <- choice [ P.reservedOp lexer ":=" >> return Set+ , P.reservedOp lexer "+=" >> return Inc+ , P.reservedOp lexer "-=" >> return Dec+ , P.reservedOp lexer "%=" >> return Mod+ , P.reservedOp lexer "/=" >> return Div+ , P.reservedOp lexer "*=" >> return Mult+ , P.reservedOp lexer "&=" >> return And+ , P.reservedOp lexer "|=" >> return Or+ , P.reservedOp lexer "^=" >> return XOr+ ]+ v <- parseTVal+ (cmds, filenames) <- parseCommands i+ return (ArithOp op r v : cmds, filenames)++ , descP "Negation" $+ do P.lexeme lexer $ string "Neg"+ r <- P.parens lexer $ parseReg+ (cmds, filenames) <- parseCommands i+ return (Neg r : cmds, filenames)++ , descP "Unknown action" $+ do P.lexeme lexer $ char '?'+ (r,v) <- P.parens lexer $+ (,) <$> parseReg <* P.comma lexer <*> parseTVal+ h <- P.parens lexer parsePrettyHex+ (cmds, filenames) <- parseCommands i+ return (Unknown h r v : cmds, filenames)++ , descP "Play action" $+ do char 'P'+ fns <- P.parens lexer $ P.commaSep1 lexer parseAudioRef+ let n = length fns+ (cmds, filenames) <- parseCommands (i+n)+ let c = case fns of+ [fn] -> Play (fromIntegral i)+ _ -> Random (fromIntegral (i + n - 1)) (fromIntegral i)+ return (c : cmds, fns ++ filenames)+ , descP "Cancel" $+ do P.lexeme lexer $ char 'C'+ (cmds, filenames) <- parseCommands i+ return (Cancel : cmds, filenames)+ , descP "Jump action" $+ do P.lexeme lexer $ char 'J'+ cmd <- P.parens lexer $ choice+ [ Jump <$> parseTVal+ , NamedJump <$> parseScriptRef+ ]+ (cmds, filenames) <- parseCommands i+ return (cmd : cmds, filenames)+ , descP "Start Game" $+ do P.lexeme lexer $ char 'G'+ n <- P.parens lexer $ parseWord16+ (cmds, filenames) <- parseCommands i+ return (Game n : cmds, filenames)+ ]+++++encodeFileCommented :: ToJSON a => FilePath -> String -> a -> IO ()+encodeFileCommented fn c v = do+ SBC.writeFile fn $ SBC.pack c <> encode v++readTipToiYaml :: FilePath -> IO (TipToiYAML, CodeMap)+readTipToiYaml inf = do+ etty <- decodeFileEither inf+ tty <- case etty of+ Left e -> print e >> exitFailure+ Right tty -> return tty++ ex <- doesFileExist infCodes+ codeMap <-+ if ex+ then do+ ettcy <- decodeFileEither infCodes+ case ettcy of+ Left e -> print e >> exitFailure+ Right ttcy -> return (ttcScriptCodes ttcy)+ else return M.empty+ return (tty, codeMap)+ where+ infCodes = codeFileName inf++writeTipToiYaml :: FilePath -> TipToiYAML -> IO ()+writeTipToiYaml out tty = encodeFile out tty++writeTipToiCodeYaml :: FilePath -> TipToiYAML -> CodeMap -> CodeMap -> IO ()+writeTipToiCodeYaml inf tty oldMap totalMap = do+ let newCodeMap = totalMap M.\\ fromMaybe M.empty (ttyScriptCodes tty)++ ex <- doesFileExist infCodes++ if M.null newCodeMap+ then when ex $ removeFile infCodes+ else when (newCodeMap /= oldMap) $ encodeFileCommented infCodes codesComment (TipToiCodesYAML { ttcScriptCodes = newCodeMap })+ where+ infCodes = codeFileName inf++codesComment :: String+codesComment = unlines $ map ("# " ++)+ [ "This file contains a mapping from script names to oid codes."+ , "This way the existing scripts are always assigned to the the"+ , "same codes, even if you add further scripts."+ , ""+ , "You can copy the contents of this file into the main .yaml file,"+ , "if you want to have both together."+ , ""+ , "If you delete this file, the next run of \"ttool assemble\" might"+ , "use different codes for your scripts, and you might have to re-"+ , "create the images for your product."+ ]++codeFileName :: FilePath -> FilePath+codeFileName fn = base <.> "codes" <.> ext+ where+ base = dropExtension fn+ ext = takeExtension fn
+ src/Types.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable #-}++module Types+ ( module Types, Word8, Word16, Word32 )+where++import qualified Data.ByteString.Lazy as B+import Data.Word+import qualified Data.Map as M+import Data.Foldable (Foldable)++-- Main data types++type Offset = Word32+type Segment = (Offset, Word32, [String])+type Segments = [Segment]++data Register = RegPos Word16 | RegName String+ deriving (Show, Eq, Ord)++type ResReg = Word16++data TVal r+ = Reg r+ | Const Word16+ deriving (Eq, Functor, Foldable)++data Conditional r = Cond (TVal r) CondOp (TVal r)+ deriving (Eq, Functor, Foldable)++data CondOp+ = Eq+ | Gt+ | Lt+ | GEq+ | LEq+ | NEq+ | Unknowncond B.ByteString+ deriving (Eq)++data ArithOp+ = Inc | Dec | Mult | Div | Mod | And | Or | XOr | Set+ deriving (Eq, Bounded, Enum)++data Command r+ = Play Word16+ | Random Word8 Word8+ | Cancel+ | Game Word16+ | ArithOp ArithOp r (TVal r)+ | Neg r+ | Unknown B.ByteString r (TVal r)+ | Jump (TVal r)+ | NamedJump String -- Only in YAML files, never read from GMEs+ deriving (Eq, Functor, Foldable)++type PlayList = [Word16]++data Line r = Line Offset [Conditional r] [Command r] PlayList+ deriving (Functor, Foldable)++type ProductID = Word32++data TipToiFile = TipToiFile+ { ttProductId :: ProductID+ , ttRawXor :: Word32+ , ttComment :: B.ByteString+ , ttDate :: B.ByteString+ , ttInitialRegs :: [Word16]+ , ttWelcome :: [PlayList]+ , ttScripts :: [(Word16, Maybe [Line ResReg])]+ , ttGames :: [Game]+ , ttAudioFiles :: [B.ByteString]+ , ttAudioFilesDoubles :: Bool+ , ttAudioXor :: Word8+ , ttChecksum :: Word32+ , ttChecksumCalc :: Word32+ }++type PlayListList = [PlayList]+type GameId = Word16++data Game+ = Game6 Word16 B.ByteString [PlayListList] [SubGame] [SubGame] B.ByteString [PlayListList] PlayList+ | Game7 Word16 Word16 B.ByteString [PlayListList] [SubGame] B.ByteString [PlayListList] PlayListList+ | Game8 Word16 Word16 B.ByteString [PlayListList] [SubGame] B.ByteString [PlayListList] [OID] [GameId] PlayListList PlayListList+ | Game9+ | Game10+ | Game16+ | Game253+ | UnknownGame Word16 Word16 Word16 B.ByteString [PlayListList] [SubGame] B.ByteString [PlayListList]+ deriving Show+++type OID = Word16++data SubGame+ = SubGame B.ByteString [OID] [OID] [OID] [PlayListList]+ deriving Show++type Transscript = M.Map Word16 String+
+ src/Utils.hs view
@@ -0,0 +1,17 @@+module Utils where++import Control.Monad++-- Utilities++readMaybe :: (Read a) => String -> Maybe a+readMaybe s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing+++forMn :: Monad m => [a] -> (Int -> a -> m b) -> m [b]+forMn l f = forM (zip l [0..]) $ \(x,n) -> f n x++forMn_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()+forMn_ l f = forM_ (zip l [0..]) $ \(x,n) -> f n x
+ src/tttool.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE CPP #-}++import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as BC+import System.Environment+import System.Exit+import System.FilePath+import qualified Data.Binary.Builder as Br+import qualified Data.Binary.Get as G+import Text.Printf+import Data.Bits+import Data.List+import Data.Either+import Data.Functor+import Data.Maybe+import Data.Ord+import Control.Monad+import System.Directory+import Numeric (readHex)+import qualified Data.Map as M++#if MIN_VERSION_time(1,5,0)+import Data.Time.Format (defaultTimeLocale)+#else+import System.Locale (defaultTimeLocale)+#endif+import Data.Time (getCurrentTime, formatTime)+{-+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 Types+import Constants+import GMEParser+import GMEWriter+import GMERun+import PrettyPrint+import RangeParser+import OidCode+import Utils+import TipToiYaml+import Lint+++-- Main commands++dumpAudioTo :: FilePath -> FilePath -> IO ()+dumpAudioTo directory file = do+ (tt,_) <- parseTipToiFile <$> B.readFile file++ printf "Audio Table entries: %d\n" (length (ttAudioFiles tt))++ createDirectoryIfMissing False directory+ forMn_ (ttAudioFiles tt) $ \n audio -> do+ let audiotype = maybe "raw" snd $ find (\(m,t) -> m `B.isPrefixOf` audio) fileMagics+ let filename = printf "%s/%s_%d.%s" directory (takeBaseName file) n audiotype+ if B.null audio+ then do+ printf "Skipping empty file %s...\n" filename+ else do+ B.writeFile filename audio+ printf "Dumped sample %d as %s\n" n filename++dumpScripts :: Transscript -> Bool -> Maybe Int -> FilePath -> IO ()+dumpScripts t raw sel file = do+ bytes <- B.readFile file+ let (tt,_) = parseTipToiFile bytes+ st' | Just n <- sel = filter ((== fromIntegral n) . fst) (ttScripts tt)+ | otherwise = ttScripts tt++ forM_ st' $ \(i, ms) -> case ms of+ Nothing -> do+ printf "Script for OID %d: Disabled\n" i+ Just lines -> do+ printf "Script for OID %d:\n" i+ forM_ lines $ \line -> do+ if raw then printf "%s\n" (lineHex bytes line)+ else printf " %s\n" (ppLine t line)+++dumpInfo :: Transscript -> FilePath -> IO ()+dumpInfo t file = do+ (tt,_) <- parseTipToiFile <$> B.readFile file+ let st = ttScripts tt++ printf "Product ID: %d\n" (ttProductId tt)+ printf "Raw XOR value: 0x%08X\n" (ttRawXor tt)+ printf "Magic XOR value: 0x%02X\n" (ttAudioXor tt)+ printf "Comment: %s\n" (BC.unpack (ttComment tt))+ printf "Date: %s\n" (BC.unpack (ttDate tt))+ printf "Number of registers: %d\n" (length (ttInitialRegs tt))+ printf "Initial registers: %s\n" (show (ttInitialRegs tt))+ printf "Initial sounds: %s\n" (ppPlayListList t (ttWelcome tt))+ printf "Scripts for OIDs from %d to %d; %d/%d are disabled.\n"+ (fst (head st)) (fst (last st))+ (length (filter (isNothing . snd) st)) (length st)+ printf "Audio Table entries: %d\n" (length (ttAudioFiles tt))+ when (ttAudioFilesDoubles tt) $ printf "Audio table repeated twice\n"+ printf "Checksum found 0x%08X, calculated 0x%08X\n" (ttChecksum tt) (ttChecksumCalc tt)++lint :: FilePath -> IO ()+lint file = do+ (tt,segments) <- parseTipToiFile <$> B.readFile file+ lintTipToi tt segments++play :: Transscript -> FilePath -> IO ()+play t file = do+ (tt,_) <- parseTipToiFile <$> B.readFile file+ playTipToi t tt++segments :: FilePath -> IO ()+segments file = do+ (tt,segments) <- parseTipToiFile <$> B.readFile file+ mapM_ printSegment segments++printSegment (o,l,desc) = printf "At 0x%08X Size %8d: %s\n" o l (ppDesc desc)++explain :: FilePath -> IO ()+explain file = do+ bytes <- B.readFile file+ let (tt,segments) = parseTipToiFile bytes+ forM_ (addHoles segments) $ \e -> case e of+ Left (o,l) -> do+ printSegment (o,l,["-- unknown --"])+ printExtract bytes o l+ putStrLn ""+ Right s@(o,l,_) -> do+ printSegment s+ printExtract bytes o l+ putStrLn ""++printExtract :: B.ByteString -> Offset -> Word32 -> IO ()+printExtract b o l = do+ let o1 = o .&. 0xFFFFFFF0+ lim_forM_ [o1, o1+0x10 .. (o + l-1)] $ \s -> do+ let s' = max o s+ let d = fromIntegral s' - fromIntegral s+ let l' = (min (o + l) (s + 0x10)) - s'+ printf " 0x%08X: %s%s\n"+ s+ (replicate (d*3) ' ')+ (prettyHex (extract s' l' b))+ where+ lim_forM_ l act+ = if length l > 30+ then do act (head l)+ printf " (skipping %d lines)\n" (length l - 2) :: IO ()+ act (last l)+ else do forM_ l act++findPosition :: Integer -> FilePath -> IO ()+findPosition pos' file = do+ (tt,segments) <- parseTipToiFile <$> B.readFile file+ case find (\(o,l,_) -> pos >= o && pos < o + l) segments of+ Just s -> do+ printf "Offset 0x%08X is part of this segment:\n" pos+ printSegment s+ Nothing -> do+ let before = filter (\(o,l,_) -> pos >= o + l) segments+ after = filter (\(o,l,_) -> pos < o) segments+ printBefore | null before = printf "(nothing before)\n"+ | otherwise = printSegment (maximumBy (comparing (\(o,l,_) -> o+l)) before)+ printAfter | null after = printf "(nothing after)\n"+ | otherwise = printSegment (minimumBy (comparing (\(o,l,_) -> o)) after)+ printf "Offset %08X not found. It lies between these two segments:\n" pos+ printBefore+ printAfter++ where+ pos = fromIntegral pos'+++addHoles :: [Segment] -> [Either (Offset, Word32) Segment]+addHoles = go+ where go [] = []+ go [s] = [Right s]+ go (s@(o1,l1,d2):r@((o2,_,_):_))+ | o1 + l1 == o2 -- no hole+ = Right s : go r+ | otherwise -- a hole+ = Right s : Left (o1+l1, o2 - (o1 + l1)) : go r++unknown_segments :: FilePath -> IO ()+unknown_segments file = do+ bytes <- B.readFile file+ let (_,segments) = parseTipToiFile bytes+ let unknown_segments =+ filter (\(o,l) -> not+ (l == 2 && G.runGet (G.skip (fromIntegral o) >> G.getWord16le) bytes == 0)) $+ lefts $ addHoles $ segments+ printf "Unknown file segments: %d (%d bytes total)\n"+ (length unknown_segments) (sum (map snd unknown_segments))+ forM_ unknown_segments $ \(o,l) ->+ printf " Offset: %08X to %08X (%d bytes)\n" o (o+l) l+++withEachFile :: (FilePath -> IO ()) -> [FilePath] -> IO ()+withEachFile _ [] = main' undefined []+withEachFile a [f] = a f +withEachFile a fs = forM_ fs $ \f -> do + printf "%s:\n" f + a f+++dumpGames :: Transscript -> FilePath -> IO ()+dumpGames t file = do+ bytes <- B.readFile file+ let (tt,_) = parseTipToiFile bytes+ forMn_ (ttGames tt) $ \n g -> do+ printf "Game %d:\n" n+ printf "%s\n" (ppGame t g)++writeTipToi :: FilePath -> TipToiFile -> IO ()+writeTipToi out tt = do+ let bytes = writeTipToiFile tt+ let checksum = B.foldl' (\s b -> fromIntegral b + s) 0 bytes+ B.writeFile out $ Br.toLazyByteString $+ Br.fromLazyByteString bytes `Br.append` Br.putWord32le checksum++rewrite :: FilePath -> FilePath -> IO ()+rewrite inf out = do+ (tt,_) <- parseTipToiFile <$> B.readFile inf+ writeTipToi out tt++export :: FilePath -> FilePath -> IO ()+export inf out = do+ (tt,_) <- parseTipToiFile <$> B.readFile inf+ let tty = tt2ttYaml (printf "media/%s_%%s" (takeBaseName inf)) tt+ writeTipToiYaml out tty+++assemble :: FilePath -> FilePath -> IO ()+assemble inf out = do+ (tty, codeMap) <- readTipToiYaml inf+ (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap+ writeTipToiCodeYaml inf tty codeMap totalMap+ writeTipToi out tt+++++debugGame :: ProductID -> IO TipToiFile+debugGame productID = do+ -- Files orderes so that index 0 says zero, 10 is blob+ files <- mapM B.readFile+ [ "./Audio/digits/" ++ base ++ ".ogg"+ | base <- [ "english-" ++ [n] | n <- ['0'..'9']] ++ ["blob" ]+ ]+ now <- getCurrentTime+ let date = formatTime defaultTimeLocale "%Y%m%d" now+ return $ TipToiFile+ { ttProductId = productID+ , ttRawXor = 0x00000039 -- from Bauernhof+ , ttComment = BC.pack "created with tip-toi-reveng"+ , ttDate = BC.pack date+ , ttWelcome = []+ , ttInitialRegs = [1]+ , ttScripts = [+ (oid, Just [line])+ | oid <- [1..15000]+ , let chars = [oid `div` 10^p `mod` 10| p <-[4,3,2,1,0]]+ , let line = Line 0 [] [Play n | n <- [0..5]] ([10] ++ chars)+ ]+ , ttGames = []+ , ttAudioFiles = files+ , ttAudioXor = 0xAD+ , ttAudioFilesDoubles = False+ , ttChecksum = 0x00+ , ttChecksumCalc = 0x00+ }+++createDebug :: FilePath -> ProductID -> IO ()+createDebug out productID = do+ tt <- debugGame productID+ writeTipToi out tt++genPNGs :: DPI -> String -> IO ()+genPNGs dpi arg = do+ ex <- doesFileExist arg+ if ex then genPNGsForFile dpi arg+ else genPNGsForCodes dpi arg++genPNGsForFile :: DPI -> FilePath -> IO ()+genPNGsForFile dpi inf = do+ (tty, codeMap) <- readTipToiYaml inf+ (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap+ forM_ (M.toList totalMap) $ \(s,c) -> do+ let filename = printf "oid-%d-%s.png" (ttyProduct_Id tty) s+ case code2RawCode c of+ Nothing -> printf "Skipping %s, code %d not known." filename c+ Just r -> do+ printf "Writing %s.. (Code %d, raw code %d)\n" filename c r+ genPNG dpi r filename++genPNGsForCodes :: DPI -> String -> IO ()+genPNGsForCodes dpi code_str = do+ codes <- parseRange code_str+ forM_ codes $ \c -> do+ let filename = printf "oid%d.png" c+ printf "Writing %s...\n" filename+ genPNG dpi c filename+++-- The main function+++readTransscriptFile :: FilePath -> IO Transscript+readTransscriptFile transcriptfile_ = do+ file <- readFile transcriptfile_+ return $ M.fromList+ [ (idx, string)+ | l <- lines file+ , (idxstr:string:_) <- return $ wordsWhen (';'==) l+ , Just idx <- return $ readMaybe idxstr+ ]++-- Avoiding dependencies, using code from http://stackoverflow.com/a/4981265/946226+wordsWhen :: (Char -> Bool) -> String -> [String]+wordsWhen p s = case dropWhile p s of+ "" -> []+ s' -> w : wordsWhen p s''+ where (w, s'') = break p s'++main' t ("-t":transscript:args) =+ do t2 <- readTransscriptFile transscript+ main' (t `M.union` t2) args++main' t ("export": inf : [] ) = main' t ("export":inf: dropExtension inf <.> "yaml":[])+main' t ("assemble": inf : [] ) = main' t ("assemble":inf: dropExtension inf <.> "gme":[])++main' t ("info": files) = withEachFile (dumpInfo t) files+main' t ("media": "-d": dir: files) = withEachFile (dumpAudioTo dir) files+main' t ("media": files) = withEachFile (dumpAudioTo "media") files+main' t ("scripts": files) = withEachFile (dumpScripts t False Nothing) files+main' t ("script": file : n:[])+ | Just int <- readMaybe n = dumpScripts t False (Just int) file+main' t ("raw-scripts": files) = withEachFile (dumpScripts t True Nothing) files+main' t ("raw-script": file : n:[])+ | Just int <- readMaybe n = dumpScripts t True (Just int) file+main' t ("games": files) = withEachFile (dumpGames t) files+main' t ("lint": files) = withEachFile lint files+main' t ("segments": files) = withEachFile segments files+main' t ("segment": file : n :[])+ | Just int <- readMaybe n = findPosition int file+ | [(int,[])] <- readHex n = findPosition int file+main' t ("holes": files) = withEachFile unknown_segments files+main' t ("explain": files) = withEachFile explain files+main' t ("play": file : []) = play t file+main' t ("rewrite": inf : out: []) = rewrite inf out+main' t ("export": inf : out: [] ) = export inf out+main' t ("assemble": inf : out: [] ) = assemble inf out+main' t ("create-debug": out : n :[])+ | Just int <- readMaybe n = createDebug out int+ | [(int,[])] <- readHex n = createDebug out int+main' t ("oid-code": "-d" : "600" : codes@(_:_))+ = genPNGs D600 (unwords codes)+main' t ("oid-code": "-d" : "1200" : codes@(_:_))+ = genPNGs D1200 (unwords codes)+main' t ("oid-code": "-d" : _) = do+ putStrLn $ "The parameter to -d has to be 600 or 1200"+ exitFailure+main' t ("oid-code": codes@(_:_)) = genPNGs D1200 (unwords codes)+main' _ _ = do+ prg <- getProgName+ putStrLn $ "Usage: " ++ prg ++ " [options] command"+ putStrLn $ ""+ putStrLn $ "Options:"+ putStrLn $ " -t <transcriptfile>"+ putStrLn $ " in the screen output, replaces media file indices by a transscript"+ putStrLn $ ""+ putStrLn $ "Commands:"+ putStrLn $ " info <file.gme>..."+ putStrLn $ " general information"+ putStrLn $ " media [-d dir] <file.gme>..."+ putStrLn $ " dumps all audio samples to the given directory (default: media/)"+ putStrLn $ " scripts <file.gme>..."+ putStrLn $ " prints the decoded scripts for each OID"+ putStrLn $ " script <file.gme> <n>"+ putStrLn $ " prints the decoded scripts for the given OID"+ putStrLn $ " raw-scripts <file.gme>..."+ putStrLn $ " prints the scripts for each OID, in their raw form"+ putStrLn $ " raw-script <file.gme> <n>"+ putStrLn $ " prints the scripts for the given OID, in their raw form"+ putStrLn $ " games <file.gme>..."+ putStrLn $ " prints the decoded games"+ putStrLn $ " lint <file.gme>"+ putStrLn $ " checks for errors in the file or in this program"+ putStrLn $ " segments <file.gme>..."+ putStrLn $ " lists all known parts of the file, with description."+ putStrLn $ " segment <file.gme> <pos>"+ putStrLn $ " which segment contains the given position."+ putStrLn $ " holes <file.gme>..."+ 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 $ " interactively play: Enter OIDs, and see what happens."+ putStrLn $ " rewrite <infile.gme> <outfile.gme>"+ putStrLn $ " parses the file and serializes it again (for debugging)."+ putStrLn $ " create-debug <outfile.gme> <productid>"+ putStrLn $ " creates a special Debug.gme file for that productid"+ putStrLn $ " export <infile.gme> [<outfile.yaml>]"+ putStrLn $ " dumps the file in the human-readable yaml format"+ putStrLn $ " assemble <infile.yaml> <outfile.gme>"+ putStrLn $ " creates a gme file from the given source"+ putStrLn $ " oid-code [-d DPI] <codes>"+ putStrLn $ " creates a PNG file for each given optical code"+ putStrLn $ " scale this to 10cm×10cm"+ putStrLn $ " By default, it creates a 1200 dpi image. With -d 600, you"+ putStrLn $ " obtain a 600 dpi image."+ putStrLn $ " <codes> can be a range, e.g. 1,3,1000-1085."+ putStrLn $ " The code refers to the *raw* code, not the one read by the pen."+ putStrLn $ " Uses oid<code>.png as the file name."+ putStrLn $ " oid-code [-d DPI] <infile.yaml>"+ putStrLn $ " Like above, but creates one file for each code in the yaml file."+ putStrLn $ " Uses oid-<product-id>-<scriptname or code>.png as the file name."+ exitFailure++main = getArgs >>= (main' M.empty)+
+ tttool.cabal view
@@ -0,0 +1,74 @@+-- Initial tttool.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: tttool+version: 0.1+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+ is a tool to analyse and create such files.+category: Reverse Engineering+homepage: https://github.com/entropia/tip-toi-reveng+license: MIT+license-file: LICENSE+author: Joachim Breitner+maintainer: mail@joachim-breitner.de+copyright: 2013-2014 Joachim Breitner+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++flag old-locale+ description:+ If false then depend on time >= 1.5.+ .+ If true then depend on time < 1.5 together with old-locale.+ default: False+++executable tttool+ main-is: tttool.hs+ other-modules:+ Constants,+ Cypher,+ GMEParser,+ GMERun,+ GMEWriter,+ Lint,+ OidCode,+ OneLineParser,+ PrettyPrint,+ RangeParser,+ TipToiYaml,+ Types,+ Utils+ + 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.*,+ ghc-prim,++ JuicyPixels == 3.1.* || == 3.2.*,+ aeson == 0.7.* || == 0.8.*,+ mtl == 2.1.* || == 2.2.*,+ text == 0.11.* || == 1.2.*,+ parsec == 3.1.*,+ yaml == 0.8.*++ if flag(old-locale)+ build-depends: time == 1.4.*, old-locale+ else+ build-depends: time == 1.5.*++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -fwarn-unused-imports++source-repository head+ type: git+ location: https://github.com/entropia/tip-toi-reveng