diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + in the screen output, replaces media file indices by a transscript + + Commands: + info ... + general information + media [-d dir] ... + dumps all audio samples to the given directory (default: media/) + scripts ... + prints the decoded scripts for each OID + script + prints the decoded scripts for the given OID + raw-scripts ... + prints the scripts for each OID, in their raw form + raw-script + prints the scripts for the given OID, in their raw form + games ... + prints the decoded games + lint + checks for errors in the file or in this program + segments ... + lists all known parts of the file, with description. + segment + which segment contains the given position. + holes ... + lists all unknown parts of the file. + explain ... + lists all parts of the file, with description and hexdump. + play + interactively play: Enter OIDs, and see what happens. + rewrite + parses the file and serializes it again (for debugging). + create-debug + creates a special Debug.gme file for that productid + export [] + dumps the file in the human-readable yaml format + assemble + creates a gme file from the given source + oid-code [-d DPI] + 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. + 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.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. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Constants.hs @@ -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 + diff --git a/src/Cypher.hs b/src/Cypher.hs new file mode 100644 --- /dev/null +++ b/src/Cypher.hs @@ -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 + diff --git a/src/GMEParser.hs b/src/GMEParser.hs new file mode 100644 --- /dev/null +++ b/src/GMEParser.hs @@ -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 + + diff --git a/src/GMERun.hs b/src/GMERun.hs new file mode 100644 --- /dev/null +++ b/src/GMERun.hs @@ -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 + diff --git a/src/GMEWriter.hs b/src/GMEWriter.hs new file mode 100644 --- /dev/null +++ b/src/GMEWriter.hs @@ -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) diff --git a/src/Lint.hs b/src/Lint.hs new file mode 100644 --- /dev/null +++ b/src/Lint.hs @@ -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 + + + + diff --git a/src/OidCode.hs b/src/OidCode.hs new file mode 100644 --- /dev/null +++ b/src/OidCode.hs @@ -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) + diff --git a/src/OneLineParser.hs b/src/OneLineParser.hs new file mode 100644 --- /dev/null +++ b/src/OneLineParser.hs @@ -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 diff --git a/src/PrettyPrint.hs b/src/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/PrettyPrint.hs @@ -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 "/" diff --git a/src/RangeParser.hs b/src/RangeParser.hs new file mode 100644 --- /dev/null +++ b/src/RangeParser.hs @@ -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] + ] diff --git a/src/TipToiYaml.hs b/src/TipToiYaml.hs new file mode 100644 --- /dev/null +++ b/src/TipToiYaml.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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 + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 diff --git a/src/tttool.hs b/src/tttool.hs new file mode 100644 --- /dev/null +++ b/src/tttool.hs @@ -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 " + putStrLn $ " in the screen output, replaces media file indices by a transscript" + putStrLn $ "" + putStrLn $ "Commands:" + putStrLn $ " info ..." + putStrLn $ " general information" + putStrLn $ " media [-d dir] ..." + putStrLn $ " dumps all audio samples to the given directory (default: media/)" + putStrLn $ " scripts ..." + putStrLn $ " prints the decoded scripts for each OID" + putStrLn $ " script " + putStrLn $ " prints the decoded scripts for the given OID" + putStrLn $ " raw-scripts ..." + putStrLn $ " prints the scripts for each OID, in their raw form" + putStrLn $ " raw-script " + putStrLn $ " prints the scripts for the given OID, in their raw form" + putStrLn $ " games ..." + putStrLn $ " prints the decoded games" + putStrLn $ " lint " + putStrLn $ " checks for errors in the file or in this program" + putStrLn $ " segments ..." + putStrLn $ " lists all known parts of the file, with description." + putStrLn $ " segment " + putStrLn $ " which segment contains the given position." + putStrLn $ " holes ..." + putStrLn $ " lists all unknown parts of the file." + putStrLn $ " explain ..." + putStrLn $ " lists all parts of the file, with description and hexdump." + putStrLn $ " play " + putStrLn $ " interactively play: Enter OIDs, and see what happens." + putStrLn $ " rewrite " + putStrLn $ " parses the file and serializes it again (for debugging)." + putStrLn $ " create-debug " + putStrLn $ " creates a special Debug.gme file for that productid" + putStrLn $ " export []" + putStrLn $ " dumps the file in the human-readable yaml format" + putStrLn $ " assemble " + putStrLn $ " creates a gme file from the given source" + putStrLn $ " oid-code [-d DPI] " + 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 $ " 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.png as the file name." + putStrLn $ " oid-code [-d DPI] " + putStrLn $ " Like above, but creates one file for each code in the yaml file." + putStrLn $ " Uses oid--.png as the file name." + exitFailure + +main = getArgs >>= (main' M.empty) + diff --git a/tttool.cabal b/tttool.cabal new file mode 100644 --- /dev/null +++ b/tttool.cabal @@ -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