tttool 1.5.1 → 1.6
raw patch · 16 files changed
+2155/−811 lines, 16 filesdep +HPDFdep +optparse-applicativedep +splitdep ~JuicyPixelsdep ~basedep ~time
Dependencies added: HPDF, optparse-applicative, split, spool, zlib
Dependency ranges changed: JuicyPixels, base, time
Files
- README.md +35/−55
- src/Commands.hs +341/−0
- src/GMEParser.hs +86/−48
- src/GMEWriter.hs +155/−11
- src/Lint.hs +11/−1
- src/OidCode.hs +75/−147
- src/OidTable.hs +156/−0
- src/OneLineParser.hs +8/−6
- src/PrettyPrint.hs +154/−72
- src/RangeParser.hs +2/−2
- src/TipToiYaml.hs +588/−65
- src/TipToiYamlAux.hs +11/−0
- src/Types.hs +168/−7
- src/Utils.hs +13/−2
- src/tttool.hs +336/−390
- tttool.cabal +16/−5
README.md view
@@ -20,67 +20,47 @@ The tttool tool --------------- -Use the tool `tttool.hs` to investigate the gme files and build new ones. It+Use the tool `tttool` to investigate the gme files and build new ones. It supports various subcommands: - Usage: tttool [options] command+ GME creation commands:+ assemble creates a gme file from the given source - Options:- -t <transcriptfile>- in the screen output, replaces media file indices by a transscript+ OID code creation commands: - 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- binaries [-d dir] <file.gme>...- dumps all binaries to the given directory (default: binaries/)- 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 or file.yaml>- interactively play: Enter OIDs, and see what happens.- rewrite <infile.gme> <outfile.gme>- parses the file and serializes it again (for debugging).- 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 code- scale this to 10cm×10cm- By default, it creates a 1200 dpi image. With -d 600, you- obtain a 600 dpi image. With -d 600d resp. 1200d you can double the- size of the pixel.- <codes> can be a range, e.g. 1,3,1000-1085.- Uses oid-<code>.png as the file name.- oid-code [-d DPI] <infile.yaml>- Like above, but creates one file for each code in the yaml file.- Uses oid-<product-id>-<scriptname or code>.png as the file name.- raw-oid-code [-d DPI] <raw codes>- creates a PNG file with the given "raw code". Usually not needed.- Uses oid-raw-<code>.png as the file name.+ oid-table creates a PDF file with all codes in the yaml file+ oid-codes creates PNG files for every OID in the yaml file.+ oid-code creates PNG files for each given code(s) -A transscript is simply a `;`-separated table of OIDs and some text, see for example [`transcript/WWW_Bauernhof.csv`](transcript/WWW_Bauernhof.csv).+ GME analysis commands:+ info Print general information about a GME file+ export dumps the file in the human-readable yaml format+ scripts prints the decoded scripts for each OID+ script prints the decoded scripts for a specific OID+ 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 prints the decoded scripts for a specific OID+ explain print a hexdump of a GME file with descriptions+ holes lists all unknown parts of the file.+ rewrite parses the file and reads it again (for debugging) + GME extraction commands:+ media dumps all audio samples+ binaries dumps all binaries++ Simulation commands:+ play interactively play a GME file++Run++ ./tttool --help++to learn about global options (e.g. DPI settings), and++ ./tttool command --help++for the options of the individual command. Installation ------------
+ src/Commands.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE CPP, RecordWildCards, TupleSections #-}+module Commands where++import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as BC+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 qualified Data.Map as M+import Data.Foldable (for_)++import Types+import Constants+import KnownCodes+import GMEParser+import GMEWriter+import GMERun+import PrettyPrint+import OidCode+import OidTable+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++dumpBinariesTo :: FilePath -> FilePath -> IO ()+dumpBinariesTo directory file = do+ (TipToiFile {..},_) <- parseTipToiFile <$> B.readFile file++ let binaries =+ map (1,) ttBinaries1 +++ map (2,) ttBinaries2 +++ map (3,) ttBinaries3 +++ map (4,) ttBinaries4++ printf "Binary Table entries: %d\n" (length binaries)++ createDirectoryIfMissing False directory+ forM_ binaries $ \(n,(desc,binary)) -> do+ let filename = printf "%s/%d_%s" directory (n::Int) (BC.unpack desc)+ if B.null binary+ then do+ printf "Skipping empty file %s...\n" filename+ else do+ B.writeFile filename binary+ printf "Dumped binary %s from block %d as %s\n" (BC.unpack desc) n filename++dumpScripts :: Conf -> Bool -> Maybe Int -> FilePath -> IO ()+dumpScripts conf raw sel file = do+ t <- readTransscriptFile (cTransscriptFile conf)+ 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 :: Conf -> FilePath -> IO ()+dumpInfo conf file = do+ t <- readTransscriptFile (cTransscriptFile conf)+ (TipToiFile {..},_) <- parseTipToiFile <$> B.readFile file+ let st = ttScripts++ printf "Product ID: %d\n" ttProductId+ printf "Raw XOR value: 0x%08X\n" ttRawXor+ printf "Magic XOR value: 0x%02X\n" ttAudioXor+ printf "Comment: %s\n" (BC.unpack ttComment)+ printf "Date: %s\n" (BC.unpack ttDate)+ printf "Number of registers: %d\n" (length ttInitialRegs)+ printf "Initial registers: %s\n" (show ttInitialRegs)+ printf "Initial sounds: %s\n" (ppPlayListList t ttWelcome)+ 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)+ when ttAudioFilesDoubles $ printf "Audio table repeated twice\n"+ printf "Binary tables entries: %d/%d/%d/%d\n"+ (length ttBinaries1)+ (length ttBinaries2)+ (length ttBinaries3)+ (length ttBinaries4)+ for_ ttSpecialOIDs $ \(oid1, oid2) ->+ printf "Speical OIDs: %d, %d\n" oid1 oid2+ printf "Checksum found 0x%08X, calculated 0x%08X\n" ttChecksum ttChecksumCalc++lint :: FilePath -> IO ()+lint file = do+ (tt,segments) <- parseTipToiFile <$> B.readFile file+ lintTipToi tt segments++play :: Conf -> FilePath -> IO ()+play conf file = do+ t <- readTransscriptFile (cTransscriptFile conf)+ (cm,tt) <-+ if ".yaml" `isSuffixOf` file+ then do+ (tty, extraCodeMap) <- readTipToiYaml file+ (tt, codeMap) <- ttYaml2tt (takeDirectory file) tty extraCodeMap+ return (codeMap, tt)+ else do+ (tt,_) <- parseTipToiFile <$> B.readFile file+ return (M.empty, tt)+ playTipToi cm t tt++segments :: FilePath -> IO ()+segments file = do+ (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 ss@((o,l,_):_) -> do+ mapM_ printSegment ss+ printExtract bytes o l+ putStrLn ""++printExtract :: B.ByteString -> Offset -> Word32 -> IO ()+printExtract b o 0 = return ()+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'+++-- returns a list of segments in case of overlap+addHoles :: [Segment] -> [Either (Offset, Word32) [Segment]]+addHoles = go 0+ where go at [] = []+ go at ss@((o,l,d):_)+ | at /= o -- a hole+ = Left (at, o-at) : go o ss+ | otherwise -- no hole+ = let (this, others) = span (\(o',l',_) -> o == o' && l == l') ss+ in Right this : go (o + l) others++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 _ [] = error "withEachFile []"+withEachFile a [f] = a f +withEachFile a fs = forM_ fs $ \f -> do + printf "%s:\n" f + a f+++dumpGames :: Conf -> FilePath -> IO ()+dumpGames conf file = do+ t <- readTransscriptFile (cTransscriptFile conf)+ 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+ ex <- doesFileExist out+ if ex+ then printf "File \"%s\" does already exist. Please remove it first\nif you want to export \"%s\" again.\n" out inf >> exitFailure+ else writeTipToiYaml out tty+++assemble :: FilePath -> FilePath -> IO ()+assemble inf out = do+ (tty, codeMap) <- readTipToiYaml inf+ (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap+ warnTipToi tt+ writeTipToiCodeYaml inf tty codeMap totalMap+ writeTipToi out tt++genOidTable :: Conf -> FilePath -> FilePath -> IO ()+genOidTable conf inf out = do+ (tty, codeMap) <- readTipToiYaml inf+ (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap+ let codes = ("START", fromIntegral (ttProductId tt)) : M.toList totalMap+ let pdfFile = oidTable conf inf codes+ B.writeFile out pdfFile++genPNGsForFile :: Conf -> FilePath -> IO ()+genPNGsForFile conf inf = do+ (tty, codeMap) <- readTipToiYaml inf+ (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap+ let codes = ("START", fromIntegral (ttProductId tt)) : M.toList totalMap+ forM_ codes $ \(s,c) -> do+ genPNG conf c $ printf "oid-%d-%s.png" (ttProductId tt) s++genPNG :: Conf -> Word16 -> String -> IO ()+genPNG conf c filename =+ case code2RawCode c of+ Nothing -> printf "Skipping %s, code %d not known.\n" filename c+ Just r -> do+ printf "Writing %s.. (Code %d, raw code %d)\n" filename c r+ genRawPNG' conf r filename++genPNGsForCodes :: Bool -> Conf -> [Word16] -> IO ()+genPNGsForCodes False conf codes =+ forM_ codes $ \c -> do+ genPNG conf c $ printf "oid-%d.png" c+genPNGsForCodes True conf codes =+ forM_ codes $ \r -> do+ let filename = printf "oid-raw-%d.png" r+ printf "Writing %s... (raw code %d)\n" filename r+ genRawPNG' conf r filename++genRawPNG' :: Conf -> Word16 -> FilePath -> IO ()+genRawPNG' conf =+ genRawPNG w h (cDPI conf) (cPixelSize conf)+ where+ (w,h) = cCodeDimPixels conf++cCodeDimPixels :: Conf -> (Int, Int)+cCodeDimPixels conf = (w',h')+ where+ (w,h) = cCodeDim conf+ -- (Roughly) 25mm per inch+ w' = (w * cDPI conf) `div` 25+ h' = (h * cDPI conf) `div` 25++readTransscriptFile :: Maybe FilePath -> IO Transscript+readTransscriptFile Nothing = return M.empty+readTransscriptFile (Just 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'+
src/GMEParser.hs view
@@ -17,6 +17,7 @@ import Control.Monad.RWS.Strict import Control.Exception import Control.Arrow+import Debug.Trace import Types import Constants@@ -193,7 +194,15 @@ ] actions =- [ (B.pack [0xE8,0xFF], \r -> do+ [ (B.pack [0xE0,0xFF], \r -> do+ unless (r == 0) $ fail "Non-zero register for RandomVariant command"+ Const 0x0000 <- getTVal+ return RandomVariant)+ , (B.pack [0xE1,0xFF], \r -> do+ unless (r == 0) $ fail "Non-zero register for PlayAllVariant command"+ Const 0x0000 <- getTVal+ return PlayAllVariant)+ , (B.pack [0xE8,0xFF], \r -> do unless (r == 0) $ fail "Non-zero register for Play command" Const n <- getTVal return (Play n))@@ -201,6 +210,10 @@ unless (r == 0) $ fail "Non-zero register for Random command" Const n <- getTVal return (Random (lowbyte n) (highbyte n)))+ , (B.pack [0x00,0xFB], \r -> do+ unless (r == 0) $ fail "Non-zero register for PlayAll command"+ Const n <- getTVal+ return (PlayAll (lowbyte n) (highbyte n))) , (B.pack [0xFF,0xFA], \r -> do unless (r == 0) $ fail "Non-zero register for Cancel command" Const 0xFFFF <- getTVal@@ -216,7 +229,10 @@ , (B.pack [0xF8,0xFF], \r -> do _ <- getTVal return (Neg r))- ] ++ + , (B.pack [0x00,0xFF], \r -> do+ v <- getTVal+ return (Timer r v))+ ] ++ [ (B.pack (arithOpCode o), \r -> do n <- getTVal return (ArithOp o r n))@@ -286,12 +302,15 @@ getPlayList :: SGet PlayList getPlayList = getArray getWord16 getWord16 +getGameIdList :: SGet [GameId]+getGameIdList = getArray getWord16 (subtract 1 <$> getWord16)++getGameIdListList :: SGet [[GameId]]+getGameIdListList = indirections getWord16 "" getGameIdList+ getOidList :: SGet [OID] getOidList = getArray getWord16 getWord16 -getGidList :: SGet [OID]-getGidList = getArray getWord16 getWord16- getPlayListList :: SGet PlayListList getPlayListList = indirections getWord16 "" getPlayList @@ -304,52 +323,71 @@ 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)+ gGameType <- getWord16+ getRealGame gGameType - 253 -> do- return Game253+getRealGame :: Word16 -> SGet Game+getRealGame 253 = return Game253+getRealGame gGameType = do+ gSubgameCount <- getWord16+ gRounds <- getWord16+ gUnknownC <- getIf (/=6) getWord16+ gBonusSubgameCount <- getIf (==6) getWord16+ gBonusRounds <- getIf (==6) getWord16+ gBonusTarget <- getIf (==6) getWord16+ gUnknownI <- getIf (==6) getWord16+ gEarlyRounds <- getWord16+ gUnknownQ <- getIf (==6) getWord16+ gRepeatLastMedia <- getWord16+ gUnknownX <- getWord16+ gUnknownW <- getWord16+ gUnknownV <- getWord16+ gStartPlayList <- indirection "startplaylist" getPlayListList+ gRoundEndPlayList <- indirection "roundendplaylist" getPlayListList+ gFinishPlayList <- indirection "finishplaylist" getPlayListList+ gRoundStartPlayList <- indirection "roundstartplaylist" getPlayListList+ gLaterRoundStartPlayList <- indirection "laterroundstartplaylist" getPlayListList+ gRoundStartPlayList2 <- getIf (==6) $ indirection "roundendplaylist2" getPlayListList+ gLaterRoundStartPlayList2 <- getIf (==6) $ indirection "laterroundstartplaylist2" getPlayListList+ let subgameCount | gGameType == 6 = gSubgameCount + gBonusSubgameCount+ | otherwise = gSubgameCount+ gSubgames <- indirections (return subgameCount) "subgame-" getSubGame+ gTargetScores <- if gGameType == 6 then replicateM 2 getWord16+ else replicateM 10 getWord16+ gBonusTargetScores <- getIf (==6) $ replicateM 8 getWord16+ let fplCount | gGameType == 6 = 2+ | otherwise = 10+ gFinishPlayLists <- indirections (return fplCount) "finishplaylist-" getPlayListList+ gBonusFinishPlayLists <- getIf (==6) $ indirections (return 8) "bonus finishplaylist-" getPlayListList+ gBonusSubgameIds <- getIf (==6) $ indirection "subgameidlist" getGameIdList+ gSubgameGroups <- getIf (==7) $ indirection "subgamegroups" getGameIdListList+ gGameSelectOIDs <- getIf (==8) $ indirection "gameSelectOids" getOidList+ gGameSelect <- getIf (==8) $ indirection "gameSelect" getGameIdList+ gGameSelectErrors1 <- getIf (==8) $ indirection "gameSelectErrors1" getPlayListList+ gGameSelectErrors2 <- getIf (==8) $ indirection "gameSelectErrors2" getPlayListList+ gExtraOIDs <- getIf (==16) $ indirection "extra oids" getOidList+ gExtraPlayLists <- case gGameType of+ 9 -> indirections (return 75) "playlist-" getPlayListList+ 10 -> indirections (return 1) "playlist-" getPlayListList+ 16 -> indirections (return 3) "playlist-" getPlayListList+ _ -> return $ error $ "error in gExtraPlayLists" - _ -> 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)+ case gGameType of+ 6 -> return $ Game6 {..}+ 7 -> return $ Game7 {..}+ 8 -> return $ Game8 {..}+ 9 -> return $ Game9 {..}+ 10 -> return $ Game10 {..}+ 16 -> return $ Game16 {..}+ 253 -> return Game253+ _ -> return $ CommonGame {..}+ where+ getIf :: (Word16 -> Bool) -> SGet a -> SGet a+ getIf p a | p gGameType = a+ | otherwise = return (error "getIf used wrongly") getInitialRegs :: SGet [Word16]@@ -380,7 +418,7 @@ jumpTo 0x0090 ttBinaries1 <- fromMaybe [] <$> maybeIndirection "Binaries 1" getBinaries- ttSpecialOIDs <- maybeIndirection "specials symbols" getSpecials+ ttSpecialOIDs <- maybeIndirection "special symbols" getSpecials ttBinaries2 <- fromMaybe [] <$> maybeIndirection "Binaries 1" getBinaries jumpTo 0x00A0
src/GMEWriter.hs view
@@ -8,8 +8,9 @@ import Control.Monad import Control.Applicative (Applicative) import qualified Data.Map as M-import Control.Monad.Writer.Strict-import Control.Monad.State.Strict+import Control.Monad.Writer.Lazy+import Control.Monad.State.Lazy+import Debug.Trace import Types import Constants@@ -107,22 +108,149 @@ seek 0x0200 -- Just to be safe sto <- getAddress $ putScriptTable ttScripts ast <- getAddress $ putWord16 0x00 -- For now, no additional script table- gto <- getAddress $ putGameTable+ gto <- getAddress $ putGameTable ttGames iro <- getAddress $ putInitialRegs ttInitialRegs mft <- getAddress $ putAudioTable ttAudioXor ttAudioFiles- ipllo <- getAddress $ putOffsets putWord16 $ map putPlayList ttWelcome+ ipllo <- getAddress $ putPlayListList ttWelcome return () -putGameTable :: SPut-putGameTable = mdo- putWord32 1 -- Hardcoded empty- putWord32 offset- offset <- getAddress $ do- putWord16 253- putWord16 0+putGameTable :: [Game] -> SPut+putGameTable games = putOffsets putWord32 $ map putGame games++putGame :: Game -> SPut+putGame (Game6 {..}) = mdo+ putWord16 6+ putWord16 (fromIntegral (length gSubgames) - gBonusSubgameCount)+ putWord16 gRounds+ putWord16 gBonusSubgameCount+ putWord16 gBonusRounds+ putWord16 gBonusTarget+ putWord16 gUnknownI+ putWord16 gEarlyRounds+ putWord16 gUnknownQ+ putWord16 gRepeatLastMedia+ putWord16 gUnknownX+ putWord16 gUnknownW+ putWord16 gUnknownV+ putWord32 spl+ putWord32 repl+ putWord32 fpl+ putWord32 rspl+ putWord32 lrspl+ putWord32 rspl2+ putWord32 lrspl2+ mapM_ putWord32 sgo+ mapM_ putWord16 gTargetScores+ mapM_ putWord16 gBonusTargetScores+ mapM_ putWord32 fpll+ mapM_ putWord32 fpll2+ putWord32 gilo+++ spl <- getAddress $ putPlayListList gStartPlayList+ repl <- getAddress $ putPlayListList gRoundEndPlayList+ fpl <- getAddress $ putPlayListList gFinishPlayList+ rspl <- getAddress $ putPlayListList gRoundStartPlayList+ lrspl <- getAddress $ putPlayListList gLaterRoundStartPlayList+ rspl2 <- getAddress $ putPlayListList gRoundStartPlayList2+ lrspl2 <- getAddress $ putPlayListList gLaterRoundStartPlayList2+ fpll <- mapM (getAddress . putPlayListList) gFinishPlayLists+ fpll2 <- mapM (getAddress . putPlayListList) gBonusFinishPlayLists++ sgo <- mapM (getAddress . putSubGame) gSubgames++ gilo <- getAddress $ putGameIdList gBonusSubgameIds+ return () +putGame (Game253) = mdo+ putWord16 253 +putGame g = mdo+ putWord16 (gameType g)+ putWord16 (fromIntegral $ length (gSubgames g))+ putWord16 (gRounds g)+ putWord16 (gUnknownC g)+ putWord16 (gEarlyRounds g)+ putWord16 (gRepeatLastMedia g)+ putWord16 (gUnknownX g)+ putWord16 (gUnknownW g)+ putWord16 (gUnknownV g)+ putWord32 spl+ putWord32 repl+ putWord32 fpl+ putWord32 rspl+ putWord32 lrspl+ mapM_ putWord32 sgo+ mapM_ putWord16 (gTargetScores g)+ mapM_ putWord32 fpll++ case g of+ Game7 {..} -> mdo+ putWord32 sggo+ sggo <- getAddress $ do+ putOffsets putWord16 $ map putGameIdList gSubgameGroups+ return ()+ Game8 {..} -> mdo+ putWord32 gso+ putWord32 gs+ putWord32 gse1+ putWord32 gse2++ gso <- getAddress $ putOidList gGameSelectOIDs+ gs <- getAddress $ putArray putWord16 $ map putWord16 gGameSelect+ gse1 <- getAddress $ putPlayListList gGameSelectErrors1+ gse2 <- getAddress $ putPlayListList gGameSelectErrors2++ return ()+ Game9 {..} -> mdo+ mapM_ putWord32 epll+ epll <- mapM (getAddress . putPlayListList) gExtraPlayLists+ return ()+ Game10 {..} -> mdo+ mapM_ putWord32 epll+ epll <- mapM (getAddress . putPlayListList) gExtraPlayLists+ return ()+ Game16 {..} -> mdo+ putWord32 eoids+ mapM_ putWord32 epll+ eoids <- getAddress $ putOidList gExtraOIDs+ epll <- mapM (getAddress . putPlayListList) gExtraPlayLists+ return ()+ _ -> return ()++ spl <- getAddress $ putPlayListList $ gStartPlayList g+ repl <- getAddress $ putPlayListList $ gRoundEndPlayList g+ fpl <- getAddress $ putPlayListList $ gFinishPlayList g+ rspl <- getAddress $ putPlayListList $ gRoundStartPlayList g+ lrspl <- getAddress $ putPlayListList $ gLaterRoundStartPlayList g+ fpll <- mapM (getAddress . putPlayListList) (gFinishPlayLists g)++ sgo <- mapM (getAddress . putSubGame) (gSubgames g)+ return ()++++putPlayListList :: [PlayList] -> SPut+putPlayListList playlistlist = do+ putOffsets putWord16 $ map putPlayList playlistlist++putGameIdList :: [GameId] -> SPut+putGameIdList = putArray putWord16 . map (putWord16 . (+1))++putOidList :: [GameId] -> SPut+putOidList = putArray putWord16 . map putWord16++putSubGame :: SubGame -> SPut+putSubGame (SubGame {..}) = mdo+ putBS sgUnknown+ putArray putWord16 $ map putWord16 sgOids1+ putArray putWord16 $ map putWord16 sgOids2+ putArray putWord16 $ map putWord16 sgOids3+ mapM_ putWord32 pll + pll <- mapM (getAddress . putPlayListList) sgPlaylist+ return ()+ putScriptTable :: [(Word16, Maybe [Line ResReg])] -> SPut putScriptTable [] = error "Cannot create file with an empty script table" putScriptTable scripts = mdo@@ -186,6 +314,14 @@ putWord16 r mapM_ putWord8 [0xF8, 0xFF] putTVal (Const 0)+putCommand RandomVariant = do+ putWord16 0+ mapM_ putWord8 [0xE0, 0xFF]+ putTVal (Const 0)+putCommand PlayAllVariant = do+ putWord16 0+ mapM_ putWord8 [0xE1, 0xFF]+ putTVal (Const 0) putCommand (Play n) = do putWord16 0 mapM_ putWord8 [0xE8, 0xFF]@@ -194,6 +330,10 @@ putWord16 0 mapM_ putWord8 [0x00, 0xFC] putTVal (Const (lowhigh a b))+putCommand (PlayAll a b) = do+ putWord16 0+ mapM_ putWord8 [0x00, 0xFB]+ putTVal (Const (lowhigh a b)) putCommand (Game n) = do putWord16 0 mapM_ putWord8 [0x00, 0xFD]@@ -205,6 +345,10 @@ putCommand (Jump v) = do putWord16 0 mapM_ putWord8 [0xFF, 0xF8]+ putTVal v+putCommand (Timer r v) = do+ putWord16 r+ mapM_ putWord8 [0x00, 0xFF] putTVal v putCommand (NamedJump s) = error "putCommand: Unresolved NamedJump" putCommand (Unknown b r v) = do
src/Lint.hs view
@@ -1,4 +1,4 @@-module Lint (lintTipToi) where+module Lint (lintTipToi, warnTipToi) where import Text.Printf import Data.Maybe@@ -50,3 +50,13 @@ = printf " Offset %08X Size %d (%s) overlaps Offset %08X Size %d (%s) by %d\n" o1 l1 (ppDesc d1) o2 l2 (ppDesc d2) overlap where overlap = o1 + l1 - o2++warnTipToi :: TipToiFile -> IO ()+warnTipToi tt = do+ sequence_+ [ printf "[Script %d line %d] Warning: More than 8 commands per line may cause problems\n"+ c n+ | (c, Just lines) <- ttScripts tt+ , (n,Line _ _ cmds _) <- zip [(1::Int)..] lines+ , length cmds > 8+ ]
src/OidCode.hs view
@@ -1,17 +1,22 @@-{-# LANGUAGE BangPatterns, TupleSections #-}+{-# LANGUAGE BangPatterns, TupleSections, FlexibleContexts #-} -module OidCode (genRawPNG, DPI(..), PixelSize(..)) where+module OidCode (genRawPixels, genRawPNG, DPI(..), PixelSize(..)) where import Data.Word import Data.Bits import Data.Functor+import qualified Data.ByteString.Lazy as B+import Data.Monoid import Control.Monad-import Control.Monad.Writer.Strict import Codec.Picture import Codec.Picture.Types+import Codec.Picture.Metadata import Control.Monad.ST import Control.Applicative+import Data.Vector.Storable.ByteString +import Utils+ -- Image generation checksum :: Word16 -> Word16@@ -27,173 +32,96 @@ (&) = (.&.) -{--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-data PixelSize = SinglePixel | DoublePixel+type DPI = Int+type PixelSize = Int -imageFromBlackPixels :: Int -> Int -> [(Int, Int)] -> Image PixelYA8+imageFromBlackPixels :: ColorConvertible PixelYA8 p => Int -> Int -> [(Int, Int)] -> Image p 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+ black = promotePixel $ PixelYA8 minBound maxBound+ background = promotePixel $ PixelYA8 maxBound minBound -oidImage :: DPI -> PixelSize -> Word16 -> Image PixelYA8-oidImage dpi ps code =- imageFromBlackPixels- (width *4*dotsPerPoint)- (height*4*dotsPerPoint)- (tile f)+-- | Renders a single OID Image, returns its dimensions and the black pixels therein+singeOidImage :: DPI -> PixelSize -> Word16 -> ((Int, Int), [(Int, Int)])+singeOidImage dpi ps code = ((width, height), pixels) where- width = 100 -- in mm- height = 100 -- in mm- !dotsPerPoint | D1200 <- dpi = 12- | D600 <- dpi = 6+ spacePerPoint = dpi `div2` 100+ width = 4*spacePerPoint+ height = 4*spacePerPoint + pixels = mconcat $ map position $+ zip (flip (,) <$> [3,2,1] <*> [3,2,1])+ [ value (quart n) | n <- [0..8] ] +++ [ (p, centeredDot) | p <- [(0,0), (1,0), (2,0), (3,0), (0,1), (0,3) ] ] +++ [ ((0,2), special) ] + 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, SinglePixel <- ps = coordsOfDots- [ " "- , " "- , " "- , " "- , " "- , " ** "- , " ** "- , " "- , " "- , " "- , " "- , " "- ]- | D1200 <- dpi, DoublePixel <- ps = coordsOfDots- [ " "- , " "- , " "- , " "- , " **** "- , " **** "- , " **** "- , " **** "- , " "- , " "- , " "- , " "- ]- | D600 <- dpi, SinglePixel <- ps = coordsOfDots- [ " "- , " "- , " * "- , " "- , " "- , " "- ]- | D600 <- dpi, DoublePixel <- ps = coordsOfDots- [ " "- , " "- , " ** "- , " ** "- , " "- , " "- ]+ dot = [(x,y) | x <- [1..ps], y <- [1..ps]] + centeredDot | xshift < 0 || yshift < 0 = error "Dots too large. Try a smaller pixel size"+ | otherwise = at (xshift, yshift) dot+ where xshift = (spacePerPoint - ps) `div` 2 - 1+ yshift = (spacePerPoint - ps) `div` 2 - 1 - 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+ -- | how many pixels to shift dots horizontally+ s = dpi `div2` 600+ -- | how many pixels to shift the special dot horizontally+ ss = dpi `div2` 400 - position ((n,m), p) = at (n*dotsPerPoint, m*dotsPerPoint) p+ value 0 = at ( s, s) centeredDot+ value 1 = at (-s, s) centeredDot+ value 2 = at (-s,-s) centeredDot+ value 3 = at ( s,-s) centeredDot+ special = at (ss,0) centeredDot - coordsOfDots :: [String] -> [(Int, Int)]- coordsOfDots rows =- [ (x,y)- | (row, y) <- zip rows [0..]- , (c, x) <- zip row [0..]- , c == '*'- ]+ position ((n,m), p) = at (n*spacePerPoint, m*spacePerPoint) 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]] + -- integer division rounded up+ x `div2` y = ((x-1) `div` y) + 1 +oidImage :: ColorConvertible PixelYA8 p => Int -> Int -> DPI -> PixelSize -> Word16 -> Image p+oidImage w h dpi ps code =+ imageFromBlackPixels w h tiledPixels+ where+ ((cw,ch), pixels) = singeOidImage dpi ps code -genRawPNG :: DPI -> PixelSize -> Word16 -> FilePath -> IO ()-genRawPNG dpi ps code filename = writePng filename (oidImage dpi ps code)+ tiledPixels =+ [ (x',y')+ | (x,y) <- pixels+ , x' <- [x,x + cw..w-1]+ , y' <- [y,y + ch..h-1]+ ] +-- Width and height in pixels+genRawPixels :: Int -> Int -> DPI -> PixelSize -> Word16 -> B.ByteString+genRawPixels w h dpi ps code =+ -- All very shaky here, but it seems to work+ B.fromStrict $+ vectorToByteString $+ imageData $+ (oidImage w h dpi ps code :: Image PixelRGB8)+++genRawPNG :: Int -> Int -> DPI -> PixelSize -> Word16 -> FilePath -> IO ()+genRawPNG w h dpi ps code filename =+ B.writeFile filename $+ encodePngWithMetadata metadata $+ (oidImage w h dpi ps code :: Image PixelYA8)+ where+ metadata = mconcat+ [ singleton DpiX (fromIntegral dpi)+ , singleton DpiY (fromIntegral dpi)+ , singleton Title $ "Tiptoi OID Code " ++ show code+ , singleton Software $ "tttool " ++ tttoolVersion+ ]
+ src/OidTable.hs view
@@ -0,0 +1,156 @@+module OidTable where++import Data.Word+import qualified Data.ByteString.Lazy as LB+import Graphics.PDF+import Control.Monad hiding (forM_)+import Data.Foldable (forM_)+import Data.List.Split+import Text.Printf+import Control.Arrow ((***))+import Codec.Compression.Zlib++import OidCode+import KnownCodes+import Utils+import Types+++-- IO technically unnecessary: https://github.com/alpheccar/HPDF/issues/7++oidTable :: Conf -> String -> [(String, Word16)] -> LB.ByteString+oidTable conf title entries | entriesPerPage < 1 = error "OID codes too large to fit on a single page"+ | otherwise = pdfByteString docInfo a4rect $ do+ -- Replace codes by images+ entries' <- forM entries $ \(d,rc) ->+ case code2RawCode rc of+ Nothing -> return (d, Nothing)+ Just c -> do+ image <- createPDFRawImageFromByteString imageWidthPx imageHeightPx False FlateDecode $+ compressWith defaultCompressParams { compressLevel = defaultCompression } $+ genRawPixels imageWidthPx imageHeightPx (cDPI conf) (cPixelSize conf) $+ c+ return (d, Just image)++ let chunks = chunksOf entriesPerPage entries'+ let totalPages = length chunks++ forM_ (zip [1::Int ..] chunks) $ \(pageNum, thisPage) -> do+ page <- addPage Nothing++ drawWithPage page $ do+ displayFormattedText titleRect NormalParagraph titleFont $ do+ setJustification Centered+ paragraph $ txt title++ displayFormattedText footerRect NormalParagraph footerFont $ do+ setJustification LeftJustification+ paragraph $ txt $ "Created by tttool-" ++ tttoolVersion++ displayFormattedText footerRect NormalParagraph footerFont $ do+ setJustification RightJustification+ paragraph $ txt $ printf "%d/%d" pageNum totalPages++ forM_ (zip thisPage positions) $ \((e,mbi),p) -> do+ withNewContext $ do+ applyMatrix $ translate p+ forM_ mbi $ \i -> withNewContext $ do+ applyMatrix $ translate (0 :+ (-imageHeight))+ applyMatrix $ scale (1/px) (1/px)+ drawXObject i+ withNewContext $ do+ applyMatrix $ translate (0 :+ (-imageHeight - subtitleSep))+ let fontRect = Rectangle (0 :+ (-subtitleHeight)) (imageWidth :+ 0)+ addShape fontRect+ setAsClipPath+ displayFormattedText fontRect NormalParagraph bodyFont $ do+ paragraph $ txt e+ where+ docInfo = standardDocInfo+ { author=toPDFString $ "tttool-" ++ tttoolVersion+ , compressed = False+ }++ -- Configure-dependent dimensions (all in pt)+ (imageWidth,imageHeight) = (*mm) *** (*mm) $ fromIntegral *** fromIntegral $cCodeDim conf++ -- Static dimensions (all in pt)++ -- Page paddings+ padTop, padLeft, padBot, padRight :: Double+ padTop = 1*cm+ padBot = 1*cm+ padLeft = 2*cm+ padRight = 2*cm++ titleHeight = 1*cm+ titleSep = 0.5*cm+ footerHeight = 0.5*cm+ footerSep = 0.5*cm++ imageSepH = 0.4*cm+ imageSepV = 0.2*cm++ subtitleHeight = 0.4*cm+ subtitleSep = 0.2*cm++ -- Derived dimensions (all in pt)+ titleRect = Rectangle+ (padLeft :+ (a4h - padTop - titleHeight))+ ((a4w - padRight) :+ (a4h - padTop))+ titleFont = Font (PDFFont Helvetica 12) black black++ footerRect = Rectangle+ (padLeft :+ padBot)+ ((a4w - padRight) :+ (padBot + footerHeight))+ footerFont = Font (PDFFont Helvetica 8) black black++ bodyFont = Font (PDFFont Helvetica 8) black black++ bodyWidth = a4w - padLeft - padRight+ bodyHeight = a4h - padTop - titleHeight - titleSep - footerSep - footerHeight - padBot++ positions = map (+(padLeft :+ (padBot + footerHeight + footerSep))) $+ calcPositions bodyWidth bodyHeight+ imageWidth (imageHeight + subtitleSep + subtitleHeight)+ imageSepH imageSepV+ entriesPerPage = length positions+++ -- Derived dimensions (all in pixels)+ imageWidthPx = floor (imageWidth * px)+ imageHeightPx = floor (imageHeight * px)++ -- config-dependent conversion factors+ px :: Double+ px = fromIntegral (cDPI conf) / 72+++calcPositions+ :: Double -- ^ total width+ -> Double -- ^ total height+ -> Double -- ^ entry width+ -> Double -- ^ entry height+ -> Double -- ^ pad width+ -> Double -- ^ pad height+ -> [Point]+calcPositions tw th ew eh pw ph = [ x :+ (th - y) | y <- ys , x <- xs]+ where+ xs = [0,ew+pw..tw-ew]+ ys = [0,eh+ph..th-eh]++-- Conversation factor+cm :: Double+cm = 28.3465++mm :: Double+mm = 2.83465++-- A4 dimensions+a4w, a4h :: Double+a4w = 595+a4h = 842++a4rect :: PDFRect+a4rect = PDFRect 0 0 595 842+
src/OneLineParser.hs view
@@ -1,4 +1,4 @@-module OneLineParser (parseOneLine) where+module OneLineParser (parseOneLine, parseOneLinePure) where import System.Exit import Text.Parsec hiding (Line, lookAhead, spaces)@@ -9,10 +9,6 @@ -- 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 =@@ -26,6 +22,12 @@ parseOneLine :: Parser a -> String -> String -> IO a parseOneLine p name input =+ case parseOneLinePure p name input of+ Left e -> putStrLn e >> exitFailure+ Right l -> return l++parseOneLinePure :: Parser a -> String -> String -> Either String a+parseOneLinePure p name input = case P.parse p name input of- Left e -> printLineParserErrorMessage input e+ Left e -> Left $ lineParserErrorMessage input e Right l -> return l
src/PrettyPrint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, RecordWildCards #-} module PrettyPrint where import qualified Data.ByteString.Lazy as B@@ -32,7 +32,7 @@ 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 :: (Eq a, Bounded a, Enum a) => (a -> Maybe b) -> [a] -> [Either b [a]] groupRuns l = go where go [] = []@@ -41,8 +41,10 @@ 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+ Right (y:ys):r'+ | x /= maxBound+ , 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)) ++ "]"@@ -103,19 +105,29 @@ 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 True t xs p+ | any (not . validIndex xs) (indices p) = "" -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 (Play n) = printf "P(%s)" $ ppPlayIndex t xs (fromIntegral n)+ppCommand _ t xs (Random a b) = printf "P(%s)" $ ppPlayRange t xs [b..a]+ppCommand _ t xs (PlayAll a b) = printf "PA(%s)" $ ppPlayRange t xs [b..a]+ppCommand _ t xs PlayAllVariant = printf "PA*(%s)" $ ppPlayAll t xs+ppCommand _ t xs RandomVariant = printf "P*(%s)" $ ppPlayAll t xs+ppCommand _ t xs Cancel = printf "C" ppCommand _ t xs (Jump v) = printf "J(%s)" (ppTVal v)+ppCommand _ t xs (Timer r v) = printf "T(%s,%s)" (ppReg r) (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) +indices :: Command r -> [Int]+indices (Play n) = [fromIntegral n]+indices (Random a b) = map fromIntegral [b..a]+indices (PlayAll a b) = map fromIntegral [b..a]+indices _ = []+ validIndex :: PlayList -> Int -> Bool validIndex xs n = n >= 0 && n < length xs @@ -123,89 +135,159 @@ ppPlayIndex t xs n | validIndex xs n = transcribe t (xs !! n) | otherwise = "invalid_index_" ++ show n +ppPlayRange :: Transscript -> PlayList -> [Word8] -> String+ppPlayRange t xs = commas . map (ppPlayIndex t xs . fromIntegral)++ppPlayAll :: Transscript -> PlayList -> String+ppPlayAll t = commas . map (transcribe t)+ 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",+ppCommonGame :: Transscript -> Game -> String+ppCommonGame t g =+ printf (unlines [" type: %d",+ " rounds: %d",+ " unknown (c): %d",+ " early rounds: %d",+ " repeat last media OID: %d",+ " unknown (x): %d",+ " unknown (w): %d",+ " unknown (v): %d",+ " start play list: %s",+ " round end play list: %s",+ " finish play list: %s",+ " round start play list: %s",+ " later round start play list: %s", " subgames: (%d)", "%s",- " u3: %s",- " playlistlists: (%d)","%s",- " oids: %s",- " gids: %s",- " playlistlist: %s",- " playlistlist: %s"+ " target scores: (%d) %s",+ " finish play lists: (%d)", "%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",+ (gameType g)+ (gRounds g)+ (gUnknownC g)+ (gEarlyRounds g)+ (gRepeatLastMedia g)+ (gUnknownX g) (gUnknownW g) (gUnknownV g)+ (ppPlayListList t (gStartPlayList g))+ (ppPlayListList t (gRoundEndPlayList g))+ (ppPlayListList t (gFinishPlayList g))+ (ppPlayListList t (gRoundStartPlayList g))+ (ppPlayListList t (gLaterRoundStartPlayList g))+ (length (gSubgames g)) (ppSubGames t (gSubgames g))+ (length (gTargetScores g)) (show (gTargetScores g))+ (length (gFinishPlayLists g))(indent 4 (map (ppPlayListList t) (gFinishPlayLists g)))++ppGame :: Transscript -> Game -> String+ppGame t g@(CommonGame {..}) =+ ppCommonGame t g++ppGame t (Game6 {..}) =+ printf (unlines [" type: 6",+ " rounds: %d",+ " bonus rounds: %d",+ " rounds target: %d",+ " unknown (i): %d",+ " early rounds: %d",+ " unknown (q): %d",+ " repeat last media OID: %d",+ " unknown (x): %d",+ " unknown (w): %d",+ " unknown (v): %d",+ " start play list: %s",+ " round end play list: %s",+ " finish play list: %s",+ " round start play list: %s",+ " later round start play list: %s",+ " round start play list 2: %s",+ " later round start play list 2: %s",+ " bonus subgame count: %d", " 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))+ " target scores: (%d) %s",+ " bonus target scores: (%d) %s",+ " finish play lists: (%d)", "%s",+ " bonus finish play lists: (%d)", "%s",+ " bonus subgame ids: %s"+ ])+ gRounds+ gBonusRounds+ gBonusTarget+ gUnknownI+ gEarlyRounds+ gUnknownQ+ gRepeatLastMedia+ gUnknownX gUnknownW gUnknownV+ (ppPlayListList t gStartPlayList)+ (ppPlayListList t gRoundEndPlayList)+ (ppPlayListList t gFinishPlayList)+ (ppPlayListList t gRoundStartPlayList)+ (ppPlayListList t gLaterRoundStartPlayList)+ (ppPlayListList t gRoundStartPlayList2)+ (ppPlayListList t gLaterRoundStartPlayList2)+ gBonusSubgameCount+ (length gSubgames) (ppSubGames t gSubgames)+ (length gTargetScores) (show gTargetScores)+ (length gBonusTargetScores) (show gBonusTargetScores)+ (length gFinishPlayLists) (indent 4 (map (ppPlayListList t) gFinishPlayLists))+ (length gBonusFinishPlayLists) (indent 4 (map (ppPlayListList t) gBonusFinishPlayLists))+ (show gBonusSubgameIds)++ppGame t g@(Game7 {..}) = (ppCommonGame t g ++) $+ printf (unlines [ " subgame groups: %s"+ ])+ (show gSubgameGroups)++ppGame t g@(Game8 {..}) = (ppCommonGame t g ++) $+ printf (unlines [" game select OIDs: %s",+ " game select games: %s",+ " game select errors 1: %s",+ " game select errors 2: %s"+ ])+ (show gGameSelectOIDs)+ (show gGameSelect)+ (ppPlayListList t gGameSelectErrors1)+ (ppPlayListList t gGameSelectErrors2)++ppGame t g@(Game9 {..}) = (ppCommonGame t g ++) $+ printf (unlines [" extra play lists (%d):","%s"+ ])+ (length gExtraPlayLists) (indent 4 (map (ppPlayListList t) gExtraPlayLists))++ppGame t g@(Game10 {..}) = (ppCommonGame t g ++) $+ printf (unlines [" extra play lists (%d):","%s"+ ])+ (length gExtraPlayLists) (indent 4 (map (ppPlayListList t) gExtraPlayLists))++ppGame t g@(Game16 {..}) = (ppCommonGame t g ++) $+ printf (unlines [" extra OIDs (%d): %s",+ " extra play lists (%d):","%s"+ ])+ (length gExtraOIDs) (show gExtraOIDs)+ (length gExtraPlayLists) (indent 4 (map (ppPlayListList t) gExtraPlayLists))+ 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:"+ppSubGames :: Transscript -> [SubGame] -> String+ppSubGames t = concatMap (uncurry (ppSubGame t)) . zip [0..]++ppSubGame :: Transscript -> Int -> SubGame -> String+ppSubGame t n (SubGame u oids1 oids2 oids3 plls) = printf (unlines+ [ " Subgame %d:" , " u: %s" , " oids1: %s" , " oids2: %s" , " oids3: %s"- , " playlistlists: (%d)" , "%s"+ , " playlist: (%d)" , "%s" ])+ n (prettyHex u) (ppOidList oids1) (ppOidList oids2) (ppOidList oids3) (length plls) (indent 8 (map (ppPlayListList t) plls)) +indent :: Int -> [String] -> String indent n = intercalate "\n" . map (replicate n ' ' ++) checkLine :: Int -> Line ResReg -> [String]
src/RangeParser.hs view
@@ -10,8 +10,8 @@ import Types import OneLineParser -parseRange :: String -> IO [Word16]-parseRange = parseOneLine rangeParser "command line"+parseRange :: String -> Either String [Word16]+parseRange = parseOneLinePure rangeParser "command line" rangeParser :: Parser [Word16] rangeParser = concat <$> oneRangeParser `sepBy1` many1 (P.char ' ' <|> P.char ',')
src/TipToiYaml.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveGeneric, CPP, TupleSections #-}+{-# LANGUAGE RecordWildCards, DeriveGeneric, CPP, TupleSections, TemplateHaskell #-} module TipToiYaml ( tt2ttYaml, ttYaml2tt@@ -17,7 +17,6 @@ import Data.Char import Data.Either import Data.Functor-import Data.Version import Data.Maybe import Control.Monad import System.Directory@@ -33,6 +32,7 @@ import Data.Time (getCurrentTime, formatTime) import Data.Yaml hiding ((.=), Parser) import Data.Aeson.Types hiding ((.=), Parser)+import Data.Aeson.TH import Text.Parsec hiding (Line, lookAhead, spaces) import Text.Parsec.String import qualified Text.Parsec as P@@ -41,8 +41,9 @@ import GHC.Generics import qualified Data.Foldable as F import qualified Data.Traversable as T+import Data.Traversable (for, traverse) import Control.Arrow-import Control.Applicative ((<*>), (<*))+import Control.Applicative (Applicative(..), (<*>), (<*)) import TextToSpeech import Language@@ -52,8 +53,7 @@ import PrettyPrint import OneLineParser import Utils--import Paths_tttool+import TipToiYamlAux data TipToiYAML = TipToiYAML { ttyScripts :: M.Map String [String]@@ -65,6 +65,7 @@ , ttyScriptCodes :: Maybe CodeMap , ttySpeak :: Maybe SpeakSpecs , ttyLanguage :: Maybe Language+ , ttyGames :: Maybe [GameYaml] } deriving Generic @@ -82,11 +83,11 @@ parseJSON v = do m <- parseJSON v l <- T.traverse parseJSON $ M.lookup "language" m- m' <- T.traverse parseJSON $ M.delete "language" m + m' <- T.traverse parseJSON $ M.delete "language" m return $ SpeakSpec l m' instance ToJSON SpeakSpec where- toJSON (SpeakSpec (Just l) m) = toJSON $ M.insert "language" (ppLang l) m + toJSON (SpeakSpec (Just l) m) = toJSON $ M.insert "language" (ppLang l) m toJSON (SpeakSpec Nothing m) = toJSON $ m toSpeakMap :: Language -> Maybe SpeakSpecs -> M.Map String (Language, String)@@ -96,10 +97,10 @@ go (SpeakSpec ml m) = M.map ((l',)) m where l' = fromMaybe l ml e = error "Conflicting definitions in section \"speak\""- -newtype SpeakSpecs = SpeakSpecs [SpeakSpec] +newtype SpeakSpecs = SpeakSpecs [SpeakSpec]+ instance FromJSON SpeakSpecs where parseJSON (Array a) = SpeakSpecs <$> mapM parseJSON (V.toList a) parseJSON v = SpeakSpecs . (:[]) <$> parseJSON v@@ -108,23 +109,179 @@ toJSON (SpeakSpecs [x]) = toJSON x toJSON (SpeakSpecs l) = Array $ V.fromList $ map toJSON $ l -options = defaultOptions { fieldLabelModifier = map fix . map toLower . drop 3 }+type PlayListListYaml = String++type OIDListYaml = String++data GameYaml = CommonGameYaml+ { gyGameType :: Word16+ , gyRounds :: Word16+ , gyUnknownC :: Word16+ , gyEarlyRounds :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ }+ | Game6Yaml+ { gyRounds :: Word16+ , gyBonusSubgameCount :: Word16+ , gyBonusRounds :: Word16+ , gyBonusTarget :: Word16+ , gyUnknownI :: Word16+ , gyEarlyRounds :: Word16+ , gyUnknownQ :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gyRoundStartPlayList2 :: PlayListListYaml+ , gyLaterRoundStartPlayList2 :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyBonusTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ , gyBonusFinishPlayLists :: [PlayListListYaml]+ , gyBonusSubgameIds :: [Word16]+ }+ | Game7Yaml+ { gyRounds :: Word16+ , gyUnknownC :: Word16+ , gyEarlyRounds :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ , gySubgameGroups :: [[GameId]]+ }+ | Game8Yaml+ { gyRounds :: Word16+ , gyUnknownC :: Word16+ , gyEarlyRounds :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ , gyGameSelectOIDs :: OIDListYaml+ , gyGameSelect :: [Word16]+ , gyGameSelectErrors1 :: PlayListListYaml+ , gyGameSelectErrors2 :: PlayListListYaml+ }+ | Game9Yaml+ { gyRounds :: Word16+ , gyUnknownC :: Word16+ , gyEarlyRounds :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ , gyExtraPlayLists :: [PlayListListYaml]+ }+ | Game10Yaml+ { gyRounds :: Word16+ , gyUnknownC :: Word16+ , gyEarlyRounds :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ , gyExtraPlayLists :: [PlayListListYaml]+ }+ | Game16Yaml+ { gyRounds :: Word16+ , gyUnknownC :: Word16+ , gyEarlyRounds :: Word16+ , gyRepeatLastMedia :: Word16+ , gyUnknownX :: Word16+ , gyUnknownW :: Word16+ , gyUnknownV :: Word16+ , gyStartPlayList :: PlayListListYaml+ , gyRoundEndPlayList :: PlayListListYaml+ , gyFinishPlayList :: PlayListListYaml+ , gyRoundStartPlayList :: PlayListListYaml+ , gyLaterRoundStartPlayList :: PlayListListYaml+ , gySubgames :: [SubGameYaml]+ , gyTargetScores :: [Word16]+ , gyFinishPlayLists :: [PlayListListYaml]+ , gyExtraOIDs :: OIDListYaml+ , gyExtraPlayLists :: [PlayListListYaml]+ }+ | Game253Yaml++data SubGameYaml = SubGameYaml+ { sgUnknown :: String+ , sgOids1 :: OIDListYaml+ , sgOids2 :: OIDListYaml+ , sgOids3 :: OIDListYaml+ , sgPlaylist :: [PlayListListYaml]+ }+++$(deriveJSON gameYamlOptions ''GameYaml)+$(deriveJSON gameYamlOptions ''SubGameYaml)++tipToiYamlOptions = defaultOptions { fieldLabelModifier = map fix . map toLower . drop 3 } where fix '_' = '-' fix c = c instance FromJSON TipToiYAML where- parseJSON = genericParseJSON $ options+ parseJSON = genericParseJSON tipToiYamlOptions instance ToJSON TipToiYAML where- toJSON = genericToJSON options+ toJSON = genericToJSON tipToiYamlOptions #if MIN_VERSION_aeson(0,10,0)- toEncoding = genericToEncoding options+ toEncoding = genericToEncoding tipToiYamlOptions #endif instance FromJSON TipToiCodesYAML where- parseJSON = genericParseJSON $ options+ parseJSON = genericParseJSON tipToiYamlOptions instance ToJSON TipToiCodesYAML where- toJSON = genericToJSON options+ toJSON = genericToJSON tipToiYamlOptions #if MIN_VERSION_aeson(0,10,0)- toEncoding = genericToEncoding options+ toEncoding = genericToEncoding tipToiYamlOptions #endif @@ -133,7 +290,7 @@ { 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+ , ttyWelcome = Just $ playListList2Yaml ttWelcome , ttyComment = Just $ BC.unpack ttComment , ttyScripts = M.fromList [ (show oid, map exportLine ls) | (oid, Just ls) <- ttScripts]@@ -141,9 +298,325 @@ , ttyScriptCodes = Nothing , ttySpeak = Nothing , ttyLanguage = Nothing+ , ttyGames = list2Maybe $ map game2gameYaml ttGames } +list2Maybe [] = Nothing+list2Maybe xs = Just xs +playListList2Yaml :: PlayListList -> PlayListListYaml+playListList2Yaml = commas . map show . concat++oidList2Yaml :: [OID] -> OIDListYaml+oidList2Yaml = unwords . map show++subGame2Yaml :: SubGame -> SubGameYaml+subGame2Yaml (SubGame u o1 o2 o3 pl) = SubGameYaml+ { sgUnknown = prettyHex u+ , sgOids1 = oidList2Yaml o1+ , sgOids2 = oidList2Yaml o2+ , sgOids3 = oidList2Yaml o3+ , sgPlaylist = map playListList2Yaml pl+ }++game2gameYaml :: Game -> GameYaml+game2gameYaml CommonGame {..} = CommonGameYaml+ { gyGameType = gGameType+ , gyRounds = gRounds+ , gyUnknownC = gUnknownC+ , gyEarlyRounds = gEarlyRounds+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ }+game2gameYaml Game6 {..} = Game6Yaml+ { gyRounds = gRounds+ , gyBonusSubgameCount = gBonusSubgameCount+ , gyBonusRounds = gBonusRounds+ , gyBonusTarget = gBonusTarget+ , gyUnknownI = gUnknownI+ , gyEarlyRounds = gEarlyRounds+ , gyUnknownQ = gUnknownQ+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gyRoundStartPlayList2 = playListList2Yaml gRoundStartPlayList2+ , gyLaterRoundStartPlayList2 = playListList2Yaml gLaterRoundStartPlayList2+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyBonusTargetScores = gBonusTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ , gyBonusFinishPlayLists = map playListList2Yaml gBonusFinishPlayLists+ , gyBonusSubgameIds = gBonusSubgameIds+ }+game2gameYaml Game7 {..} = Game7Yaml+ { gyRounds = gRounds+ , gyUnknownC = gUnknownC+ , gyEarlyRounds = gEarlyRounds+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ , gySubgameGroups = gSubgameGroups+ }+game2gameYaml Game8 {..} = Game8Yaml+ { gyRounds = gRounds+ , gyUnknownC = gUnknownC+ , gyEarlyRounds = gEarlyRounds+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ , gyGameSelectOIDs = oidList2Yaml gGameSelectOIDs+ , gyGameSelect = gGameSelect+ , gyGameSelectErrors1 = playListList2Yaml gGameSelectErrors1+ , gyGameSelectErrors2 = playListList2Yaml gGameSelectErrors2+ }+game2gameYaml Game9 {..} = Game9Yaml+ { gyRounds = gRounds+ , gyUnknownC = gUnknownC+ , gyEarlyRounds = gEarlyRounds+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ , gyExtraPlayLists = map playListList2Yaml gExtraPlayLists+ }+game2gameYaml Game10 {..} = Game10Yaml+ { gyRounds = gRounds+ , gyUnknownC = gUnknownC+ , gyEarlyRounds = gEarlyRounds+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ , gyExtraPlayLists = map playListList2Yaml gExtraPlayLists+ }+game2gameYaml Game16 {..} = Game16Yaml+ { gyRounds = gRounds+ , gyUnknownC = gUnknownC+ , gyEarlyRounds = gEarlyRounds+ , gyRepeatLastMedia = gRepeatLastMedia+ , gyUnknownX = gUnknownX+ , gyUnknownW = gUnknownW+ , gyUnknownV = gUnknownV+ , gyStartPlayList = playListList2Yaml gStartPlayList+ , gyRoundEndPlayList = playListList2Yaml gRoundEndPlayList+ , gyFinishPlayList = playListList2Yaml gFinishPlayList+ , gyRoundStartPlayList = playListList2Yaml gRoundStartPlayList+ , gyLaterRoundStartPlayList = playListList2Yaml gLaterRoundStartPlayList+ , gySubgames = map subGame2Yaml gSubgames+ , gyTargetScores = gTargetScores+ , gyFinishPlayLists = map playListList2Yaml gFinishPlayLists+ , gyExtraOIDs = oidList2Yaml gExtraOIDs+ , gyExtraPlayLists = map playListList2Yaml gExtraPlayLists+ }+game2gameYaml Game253 = Game253Yaml++playListListFromYaml :: PlayListListYaml -> WithFileNames PlayListList+playListListFromYaml =+ fmap listify .+ traverse recordFilename .+ either error id .+ parseOneLinePure parsePlayList "playlist"+ where listify [] = []+ listify x = [x]++oidListFromYaml :: OIDListYaml -> [OID]+oidListFromYaml = map read . words++subGameFromYaml :: SubGameYaml -> WithFileNames SubGame+subGameFromYaml (SubGameYaml u o1 o2 o3 pl) = (\x -> SubGame+ { sgUnknown = either error id $ parseOneLinePure parsePrettyHex "unknown" u+ , sgOids1 = oidListFromYaml o1+ , sgOids2 = oidListFromYaml o2+ , sgOids3 = oidListFromYaml o3+ , sgPlaylist = x+ }) <$> traverse playListListFromYaml pl+++gameYaml2Game :: GameYaml -> WithFileNames Game+gameYaml2Game CommonGameYaml {..} = pure CommonGame+ <*> pure gyGameType+ <*> pure gyRounds+ <*> pure gyUnknownC+ <*> pure gyEarlyRounds+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+gameYaml2Game Game6Yaml {..} = pure Game6+ <*> pure gyRounds+ <*> pure gyBonusSubgameCount+ <*> pure gyBonusRounds+ <*> pure gyBonusTarget+ <*> pure gyUnknownI+ <*> pure gyEarlyRounds+ <*> pure gyUnknownQ+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> playListListFromYaml gyRoundStartPlayList2+ <*> playListListFromYaml gyLaterRoundStartPlayList2+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> pure gyBonusTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+ <*> traverse playListListFromYaml gyBonusFinishPlayLists+ <*> pure gyBonusSubgameIds+gameYaml2Game Game7Yaml {..} = pure Game7+ <*> pure gyRounds+ <*> pure gyUnknownC+ <*> pure gyEarlyRounds+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+ <*> pure gySubgameGroups+gameYaml2Game Game8Yaml {..} = pure Game8+ <*> pure gyRounds+ <*> pure gyUnknownC+ <*> pure gyEarlyRounds+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+ <*> pure (oidListFromYaml gyGameSelectOIDs)+ <*> pure gyGameSelect+ <*> playListListFromYaml gyGameSelectErrors1+ <*> playListListFromYaml gyGameSelectErrors2+gameYaml2Game Game9Yaml {..} = pure Game9+ <*> pure gyRounds+ <*> pure gyUnknownC+ <*> pure gyEarlyRounds+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+ <*> traverse playListListFromYaml gyExtraPlayLists+gameYaml2Game Game10Yaml {..} = pure Game10+ <*> pure gyRounds+ <*> pure gyUnknownC+ <*> pure gyEarlyRounds+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+ <*> traverse playListListFromYaml gyExtraPlayLists+gameYaml2Game Game16Yaml {..} = pure Game16+ <*> pure gyRounds+ <*> pure gyUnknownC+ <*> pure gyEarlyRounds+ <*> pure gyRepeatLastMedia+ <*> pure gyUnknownX+ <*> pure gyUnknownW+ <*> pure gyUnknownV+ <*> playListListFromYaml gyStartPlayList+ <*> playListListFromYaml gyRoundEndPlayList+ <*> playListListFromYaml gyFinishPlayList+ <*> playListListFromYaml gyRoundStartPlayList+ <*> playListListFromYaml gyLaterRoundStartPlayList+ <*> traverse subGameFromYaml gySubgames+ <*> pure gyTargetScores+ <*> traverse playListListFromYaml gyFinishPlayLists+ <*> pure (oidListFromYaml gyExtraOIDs)+ <*> traverse playListListFromYaml gyExtraPlayLists+gameYaml2Game Game253Yaml = pure Game253++ mergeOnlyEqual :: String -> Word16 -> Word16 -> Word16 mergeOnlyEqual _ c1 c2 | c1 == c2 = c1 mergeOnlyEqual s c1 c2 = error $@@ -167,32 +640,32 @@ usedCodes = S.fromList $ M.elems codeMap f s = case readMaybe s of- Nothing -> Left s + Nothing -> Left s Just n -> Right (n::Word16) --- The following logic (for objectCodes) tries to use different object codes --- for different projects, as far as possible. This makes the detection of not +-- The following logic (for objectCodes) tries to use different object codes+-- for different projects, as far as possible. This makes the detection of not -- having activated a book/product more robust. --- We could theoretically set: +-- We could theoretically set: -- objectCodeOffsetMax = lastObjectCode - firstObjectCode.--- This would assign perfectly usable object codes, and would minimize the --- probability of object code collisions between products, but sometimes --- object codes would wrap around from 14999 to 1000 even for small projects +-- This would assign perfectly usable object codes, and would minimize the+-- probability of object code collisions between products, but sometimes+-- object codes would wrap around from 14999 to 1000 even for small projects -- which may be undesirable. We arbitrarily do not use the last 999 possible -- offsets to avoid a wrap around in object codes for projects with <= 1000--- object codes. This does not impose any limit on the number of object codes +-- object codes. This does not impose any limit on the number of object codes -- per project. Every project can always use all 14000 object codes. objectCodeOffsetMax = lastObjectCode - firstObjectCode - 999 --- Distribute the used object codes for different projects across the whole --- range of usable object codes. We do this by multiplying the productId with --- the golden ratio to achive a maximum distance between different projects, +-- Distribute the used object codes for different projects across the whole+-- range of usable object codes. We do this by multiplying the productId with+-- the golden ratio to achive a maximum distance between different projects, -- independent of the total number of different projects. -- 8035 = (14999-1000-999+1)*((sqrt(5)-1)/2) objectCodeOffset = toWord16(rem (productId * 8035) (toWord32(objectCodeOffsetMax) + 1)) --- objectCodes always contains _all_ possible object codes [firstObjectCode..lastObjectCode], +-- objectCodes always contains _all_ possible object codes [firstObjectCode..lastObjectCode], -- starting at firstObjectCode+objectCodeOffset and then wrapping around. objectCodes = [firstObjectCode + objectCodeOffset .. lastObjectCode] ++ [firstObjectCode .. firstObjectCode + objectCodeOffset - 1] @@ -217,7 +690,9 @@ 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 ::+ (M.Map Register Word16, [(a, Maybe [Line Register])]) ->+ (M.Map ResReg Word16, [(a, Maybe [Line ResReg])]) resolveRegs x = everywhere x where -- Could use generics somehow@@ -235,13 +710,34 @@ resolveJumps :: (String -> Word16) -> [(a, Maybe [Line b])] -> [(a, Maybe [Line b])] resolveJumps m = everywhere- where + 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 +newtype WithFileNames a = WithFileNames+ { runWithFileNames :: ((String -> Word16) -> a, [String] -> [String])+ } +instance Functor WithFileNames where+ fmap f (WithFileNames (r,fns)) = WithFileNames (f . r, fns)++instance Applicative WithFileNames where+ pure x = WithFileNames (const x, id)+ WithFileNames (r1,fns1) <*> WithFileNames (r2,fns2)+ = WithFileNames (\m -> r1 m (r2 m),fns1 . fns2)++recordFilename :: String -> WithFileNames Word16+recordFilename fn = WithFileNames (($ fn), (fn :))++resolveFileNames :: WithFileNames a -> (a, [String])+resolveFileNames (WithFileNames (r,fns)) = (r filename_lookup, filenames)+ where+ filenames = S.toList $ S.fromList $ fns []+ filename_lookup = (M.fromList (zip filenames [0..]) M.!)++ ttYaml2tt :: FilePath -> TipToiYAML -> CodeMap -> IO (TipToiFile, CodeMap) ttYaml2tt dir (TipToiYAML {..}) extCodeMap = do now <- getCurrentTime@@ -257,27 +753,28 @@ first = fst (M.findMin m) last = fst (M.findMax m) - welcome_names <- parseOneLine parseWelcome "welcome" (fromMaybe "" ttyWelcome)+ welcome_names <- parseOneLine parsePlayList "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]+ let ((prescripts, welcome, games), filenames) = resolveFileNames $+ (,,) <$>+ for [first ..last] (\oid ->+ (oid ,) <$>+ for (M.lookup oid m) (\raw_lines ->+ forAn raw_lines (\i raw_line ->+ let d = printf "Line %d of OID %d" i oid+ (l,s) = either error id $ parseOneLinePure parseLine d raw_line+ in l <$> traverse recordFilename s+ )+ )+ ) <*>+ traverse recordFilename welcome_names <*>+ traverse gameYaml2Game (fromMaybe [] ttyGames) preInitRegs <- M.fromList <$> parseOneLine parseInitRegs "init" (fromMaybe "" ttyInit) -- resolve registers- let (initRegs, scripts) = resolveRegs (preInitRegs, map ($ filename_lookup) prescripts)+ let (initRegs, scripts) = resolveRegs (preInitRegs, prescripts) -- resolve named jumps let scripts' = resolveJumps scriptMap scripts@@ -289,14 +786,19 @@ , r <- concatMap F.toList cs ++ concatMap F.toList as ] let ttySpeakMap = toSpeakMap (fromMaybe defaultLanguage ttyLanguage) ttySpeak- + -- Generate text-to-spech files forM (M.elems ttySpeakMap) $ \(lang, txt) -> textToSpeech lang txt - files <- forM filenames' $ \fn -> case M.lookup fn ttySpeakMap of+ -- Check which files do not exist+++ -- Not very nice, better to use something like Control.Applicative.Error if+ -- it were in base, and not fixed to String.+ files_with_errors <- forM filenames $ \fn -> case M.lookup fn ttySpeakMap of Just (lang, txt) -> do- B.readFile (ttsFileName lang txt)+ Right <$> B.readFile (ttsFileName lang txt) Nothing -> do let paths = [ combine dir relpath | ext <- map snd fileMagics@@ -306,17 +808,21 @@ ex <- filterM doesFileExist paths case ex of [] -> do- putStrLn "Could not find any of these files:"- mapM_ putStrLn paths- exitFailure- [f] -> B.readFile f+ return $ Left $ unlines $+ "Could not find any of these files:" :+ paths+ [f] -> Right <$> B.readFile f _ -> do- putStrLn "Multiple matching files found:"- mapM_ putStrLn ex- exitFailure+ return $ Left $ unlines $+ "Multiple matching files found:" :+ paths + files <- case partitionEithers files_with_errors of+ ([],files) -> return files+ (errors, _) -> putStr (unlines errors) >> exitFailure+ comment <- case ttyComment of- Nothing -> return $ BC.pack $ "created with tttool version " ++ showVersion version+ Nothing -> return $ BC.pack $ "created with tttool version " ++ tttoolVersion Just c | length c > maxCommentLength -> do printf "Comment is %d characters too long; the maximum is %d." (length c - maxCommentLength) maxCommentLength@@ -328,10 +834,10 @@ , ttRawXor = knownRawXOR , ttComment = comment , ttDate = BC.pack date- , ttWelcome = welcome+ , ttWelcome = [welcome] , ttInitialRegs = [fromMaybe 0 (M.lookup r initRegs) | r <- [0..maxReg]] , ttScripts = scripts'- , ttGames = []+ , ttGames = games , ttAudioFiles = files , ttAudioXor = knownXOR , ttAudioFilesDoubles = False@@ -395,8 +901,8 @@ v <- parseWord16 return (r,v) -parseWelcome :: Parser [String]-parseWelcome = P.commaSep lexer $ parseAudioRef+parsePlayList :: Parser [String]+parsePlayList = P.commaSep lexer $ parseAudioRef parseAudioRef :: Parser String parseAudioRef = P.lexeme lexer $ many1 (alphaNum <|> char '_')@@ -450,13 +956,20 @@ return (Unknown h r v : cmds, filenames) , descP "Play action" $- do char 'P'+ do (withA, withStar) <- P.lexeme lexer $ do+ char 'P'+ withA <- optionBool (char 'A')+ withStar <- optionBool (char '*')+ return (withA, withStar) fns <- P.parens lexer $ P.commaSep1 lexer parseAudioRef let n = length fns+ let c = case (withA, withStar, fns) of+ (False, False, [fn]) -> Play (fromIntegral i)+ (False, False, _) -> Random (fromIntegral (i + n - 1)) (fromIntegral i)+ (True, False, _) -> PlayAll (fromIntegral (i + n - 1)) (fromIntegral i)+ (False, True, _) -> RandomVariant+ (True, True, _) -> PlayAllVariant (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'@@ -470,6 +983,12 @@ ] (cmds, filenames) <- parseCommands i return (cmd : cmds, filenames)+ , descP "Timer action" $+ do P.lexeme lexer $ char 'T'+ (r,v) <- P.parens lexer $+ (,) <$> parseReg <* P.comma lexer <*> parseTVal+ (cmds, filenames) <- parseCommands i+ return (Timer r v : cmds, filenames) , descP "Start Game" $ do P.lexeme lexer $ char 'G' n <- P.parens lexer $ parseWord16@@ -478,6 +997,8 @@ ] +optionBool :: Stream s m t => ParsecT s u m a -> ParsecT s u m Bool+optionBool p = option False (const True <$> p) encodeFileCommented :: ToJSON a => FilePath -> String -> a -> IO ()@@ -541,6 +1062,7 @@ base = dropExtension fn ext = takeExtension fn +-- | Unused debugGame :: ProductID -> IO TipToiYAML debugGame productID = do return $ TipToiYAML@@ -558,6 +1080,7 @@ , let line = ppLine t $ Line 0 [] [Play n | n <- [0..5]] ([10] ++ chars) ] , ttyLanguage = Nothing+ , ttyGames = Nothing } where t= M.fromList $
+ src/TipToiYamlAux.hs view
@@ -0,0 +1,11 @@+module TipToiYamlAux where++import Data.Aeson.Types+import Data.Char++gameYamlOptions = defaultOptions+ { fieldLabelModifier = map fix . map toLower . drop 2+ , allNullaryToStringTag = True+ }+ where fix '_' = '-'+ fix c = c
src/Types.hs view
@@ -45,6 +45,9 @@ data Command r = Play Word16 | Random Word8 Word8+ | PlayAll Word8 Word8+ | PlayAllVariant+ | RandomVariant | Cancel | Game Word16 | ArithOp ArithOp r (TVal r)@@ -52,6 +55,7 @@ | Unknown B.ByteString r (TVal r) | Jump (TVal r) | NamedJump String -- Only in YAML files, never read from GMEs+ | Timer r (TVal r) deriving (Eq, Functor, Foldable) type PlayList = [Word16]@@ -85,25 +89,182 @@ 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+data Game =+ CommonGame+ { gGameType :: Word16+ , gRounds :: Word16+ , gUnknownC :: Word16+ , gEarlyRounds :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ }+ | Game6+ { gRounds :: Word16+ , gBonusSubgameCount :: Word16+ , gBonusRounds :: Word16+ , gBonusTarget :: Word16+ , gUnknownI :: Word16+ , gEarlyRounds :: Word16+ , gUnknownQ :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gRoundStartPlayList2 :: PlayListList+ , gLaterRoundStartPlayList2 :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gBonusTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ , gBonusFinishPlayLists :: [PlayListList]+ , gBonusSubgameIds :: [Word16]+ }+ | Game7+ { gRounds :: Word16+ , gUnknownC :: Word16+ , gEarlyRounds :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ , gSubgameGroups :: [[GameId]]+ }+ | Game8+ { gRounds :: Word16+ , gUnknownC :: Word16+ , gEarlyRounds :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ , gGameSelectOIDs :: [Word16]+ , gGameSelect :: [Word16]+ , gGameSelectErrors1 :: PlayListList+ , gGameSelectErrors2 :: PlayListList+ } | Game9+ { gRounds :: Word16+ , gUnknownC :: Word16+ , gEarlyRounds :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ , gExtraPlayLists :: [PlayListList]+ } | Game10+ { gRounds :: Word16+ , gUnknownC :: Word16+ , gEarlyRounds :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ , gExtraPlayLists :: [PlayListList]+ } | Game16+ { gRounds :: Word16+ , gUnknownC :: Word16+ , gEarlyRounds :: Word16+ , gRepeatLastMedia :: Word16+ , gUnknownX :: Word16+ , gUnknownW :: Word16+ , gUnknownV :: Word16+ , gStartPlayList :: PlayListList+ , gRoundEndPlayList :: PlayListList+ , gFinishPlayList :: PlayListList+ , gRoundStartPlayList :: PlayListList+ , gLaterRoundStartPlayList :: PlayListList+ , gSubgames :: [SubGame]+ , gTargetScores :: [Word16]+ , gFinishPlayLists :: [PlayListList]+ , gExtraOIDs :: [Word16]+ , gExtraPlayLists :: [PlayListList]+ } | Game253- | UnknownGame Word16 Word16 Word16 B.ByteString [PlayListList] [SubGame] B.ByteString [PlayListList] deriving Show +gameType :: Game -> Word16+gameType (CommonGame {gGameType = gGameType }) = gGameType+gameType Game6 {} = 6+gameType Game7 {} = 7+gameType Game8 {} = 8+gameType Game9 {} = 9+gameType Game10 {} = 10+gameType Game16 {} = 16+gameType Game253 {} = 253+ type OID = Word16 -data SubGame- = SubGame B.ByteString [OID] [OID] [OID] [PlayListList]+data SubGame = SubGame+ { sgUnknown :: B.ByteString+ , sgOids1 :: [OID]+ , sgOids2 :: [OID]+ , sgOids3 :: [OID]+ , sgPlaylist :: [PlayListList]+ } deriving Show + type Transscript = M.Map Word16 String type CodeMap = M.Map String Word16 ++-- Command options++data Conf = Conf+ { cTransscriptFile :: Maybe FilePath+ , cCodeDim :: (Int, Int)+ , cDPI :: Int+ , cPixelSize :: Int+ }+ deriving Show
src/Utils.hs view
@@ -1,10 +1,18 @@ module Utils where -import Control.Monad+import Control.Applicative+import Control.Monad (forM, forM_)+import Data.Traversable (for) +import Paths_tttool+import Data.Version++tttoolVersion :: String+tttoolVersion = showVersion version+ -- Utilities -readMaybe :: (Read a) => String -> Maybe a+readMaybe :: Read a => String -> Maybe a readMaybe s = case reads s of [(x, "")] -> Just x _ -> Nothing@@ -12,6 +20,9 @@ forMn :: Monad m => [a] -> (Int -> a -> m b) -> m [b] forMn l f = forM (zip l [0..]) $ \(x,n) -> f n x++forAn :: Applicative m => [a] -> (Int -> a -> m b) -> m [b]+forAn l f = for (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
@@ -1,450 +1,396 @@-{-# LANGUAGE CPP, RecordWildCards, TupleSections #-}+import Options.Applicative -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-import Data.Foldable (for_)-import Data.Version+import Numeric+import Data.List (intercalate)+import Options.Applicative.Help.Chunk+import Data.Monoid import Types-import Constants-import KnownCodes-import GMEParser-import GMEWriter-import GMERun-import PrettyPrint import RangeParser-import OidCode+import Commands import Utils-import TipToiYaml-import Lint -import Paths_tttool+-- Parameter parsing +optionParser :: ParserInfo (IO ())+optionParser =+ info (helper <*> (conf <**> cmd)) $ mconcat+ [ progDesc $ "tttool-" ++ tttoolVersion ++ " -- The swiss army knife for the Tiptoi hacker"+ , footerDoc foot+ , fullDesc+ ]+ where+ foot = unChunk $ vsepChunks+ [ paragraph "Please run \"tttool COMMAND --help\" for information on the particular command."+ ] --- Main commands+ conf = pure Conf+ <*> transscript+ <*> codeDim+ <*> dpi+ <*> pixelSize -dumpAudioTo :: FilePath -> FilePath -> IO ()-dumpAudioTo directory file = do- (tt,_) <- parseTipToiFile <$> B.readFile file+ transscript = optional $ strOption $ mconcat+ [ long "transscript"+ , short 't'+ , metavar "FILE"+ , help "Mapping from media file indices to plaintext. This should be a ';'-separated file, with OID codes in the first column and plain text in the second"+ ] - printf "Audio Table entries: %d\n" (length (ttAudioFiles tt))+ dpi = option auto $ mconcat+ [ long "dpi"+ , metavar "DPI"+ , value 1200+ , showDefault+ , help "Use this resolution in dpi when creating OID codes"+ ] - 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+ pixelSize = option auto $ mconcat+ [ long "pixel-size"+ , metavar "N"+ , value 2+ , showDefault+ , help "Use this many pixels (squared) per dot in when creating OID codes."+ ] -dumpBinariesTo :: FilePath -> FilePath -> IO ()-dumpBinariesTo directory file = do- (TipToiFile {..},_) <- parseTipToiFile <$> B.readFile file+ codeDim = option parseCodeDim $ mconcat+ [ long "code-dim"+ , metavar "W[xH]"+ , value (30,30)+ , showDefaultWith showCodeDim+ , help "Generate OID codes of this size, in millimeters"+ ] - let binaries =- map (1,) ttBinaries1 ++- map (2,) ttBinaries2 ++- map (3,) ttBinaries3 ++- map (4,) ttBinaries4+ showCodeDim (x,y) | x == y = show x+ | otherwise = show x ++ "x" ++ show y - printf "Binary Table entries: %d\n" (length binaries)+ parseCodeDim :: ReadM (Int, Int)+ parseCodeDim = eitherReader go+ where+ go input = case reads input of+ [(x,"")] -> return (x,x)+ [(x,'x':rest)] -> case reads rest of+ [(y,[])] -> return (x,y)+ _ -> Left $ "Cannot parse dimensions " ++ input+ _ -> Left $ "Cannot parse dimensions " ++ input - createDirectoryIfMissing False directory- forM_ binaries $ \(n,(desc,binary)) -> do- let filename = printf "%s/%d_%s" directory (n::Int) (BC.unpack desc)- if B.null binary- then do- printf "Skipping empty file %s...\n" filename- else do- B.writeFile filename binary- printf "Dumped binary %s from block %d as %s\n" (BC.unpack desc) n filename+ cmd = hsubparser $ mconcat+ [ cmdSep "GME creation commands:"+ , assembleCmd+ , cmdSep "" -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+ , cmdSep "OID code creation commands:"+ , oidTableCmd+ , oidCodesCmd+ , oidCodeCmd+ , cmdSep "" - 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)+ , cmdSep "GME analysis commands:"+ , infoCmd+ , exportCmd+ , scriptsCmd+ , scriptCmd+ , gamesCmd+ , lintCmd+ , segmentsCmd+ , segmentCmd+ , explainCmd+ , holesCmd+ , rewriteCmd+ , cmdSep "" + , cmdSep "GME extraction commands:"+ , mediaCmd+ , binariesCmd+ , cmdSep "" -dumpInfo :: Transscript -> FilePath -> IO ()-dumpInfo t file = do- (TipToiFile {..},_) <- parseTipToiFile <$> B.readFile file- let st = ttScripts+ , cmdSep "Simulation commands:"+ , playCmd+ ] - printf "Product ID: %d\n" ttProductId- printf "Raw XOR value: 0x%08X\n" ttRawXor- printf "Magic XOR value: 0x%02X\n" ttAudioXor- printf "Comment: %s\n" (BC.unpack ttComment)- printf "Date: %s\n" (BC.unpack ttDate)- printf "Number of registers: %d\n" (length ttInitialRegs)- printf "Initial registers: %s\n" (show ttInitialRegs)- printf "Initial sounds: %s\n" (ppPlayListList t ttWelcome)- 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)- when ttAudioFilesDoubles $ printf "Audio table repeated twice\n"- printf "Binary tables entries: %d/%d/%d/%d\n"- (length ttBinaries1)- (length ttBinaries2)- (length ttBinaries3)- (length ttBinaries4)- for_ ttSpecialOIDs $ \(oid1, oid2) ->- printf "Speical OIDs: %d, %d\n" oid1 oid2- printf "Checksum found 0x%08X, calculated 0x%08X\n" ttChecksum ttChecksumCalc+only :: (Eq a, Show a) => [a] -> ReadM a -> ReadM a+only valid r = do+ x <- r+ if x `elem` valid then return x+ else readerError msg+ where msg = "Sorry, supported values are only: " ++ intercalate ", " (map show valid) -lint :: FilePath -> IO ()-lint file = do- (tt,segments) <- parseTipToiFile <$> B.readFile file- lintTipToi tt segments+cmdSep :: String -> Mod CommandFields a+cmdSep s = command s $ info empty mempty -play :: Transscript -> FilePath -> IO ()-play t file = do- (cm,tt) <-- if ".yaml" `isSuffixOf` file- then do- (tty, extraCodeMap) <- readTipToiYaml file- (tt, codeMap) <- ttYaml2tt (takeDirectory file) tty extraCodeMap- return (codeMap, tt)- else do- (tt,_) <- parseTipToiFile <$> B.readFile file- return (M.empty, tt)- playTipToi cm t tt -segments :: FilePath -> IO ()-segments file = do- (tt,segments) <- parseTipToiFile <$> B.readFile file- mapM_ printSegment segments+-- Common option Parsers -printSegment (o,l,desc) = printf "At 0x%08X Size %8d: %s\n" o l (ppDesc desc)+gmeFileParser :: Parser FilePath+gmeFileParser = strArgument $ mconcat+ [ metavar "GME"+ , help "GME file to read"+ ] -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 ss@((o,l,_):_) -> do- mapM_ printSegment ss- printExtract bytes o l- putStrLn ""+yamlFileParser :: Parser FilePath+yamlFileParser = strArgument $ mconcat+ [ metavar "YAML"+ , help "Yaml file to read"+ ] -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))+rawSwitchParser :: Parser Bool+rawSwitchParser = switch $ mconcat+ [ long "raw"+ , help "print the scripts in their raw form"+ ]++-- Individual commands++infoCmd :: Mod CommandFields (Conf -> IO ())+infoCmd =+ command "info" $+ info parser $+ progDesc "Print general information about a GME file" 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+ parser = flip dumpInfo <$> gmeFileParser -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'+mediaCmd :: Mod CommandFields (Conf -> IO ())+mediaCmd =+ command "media" $+ info parser $+ progDesc "dumps all audio samples"+ where+ parser = const <$> (dumpAudioTo <$> mediaDirParser <*> gmeFileParser) + mediaDirParser :: Parser FilePath+ mediaDirParser = strOption $ mconcat+ [ long "dir"+ , short 'd'+ , metavar "DIR"+ , help "Media output directory"+ , value "media"+ , showDefault+ ] --- returns a list of segments in case of overlap-addHoles :: [Segment] -> [Either (Offset, Word32) [Segment]]-addHoles = go 0- where go at [] = []- go at ss@((o,l,d):_)- | at /= o -- a hole- = Left (at, o-at) : go o ss- | otherwise -- no hole- = let (this, others) = span (\(o',l',_) -> o == o' && l == l') ss- in Right this : go (o + l) others+scriptsCmd :: Mod CommandFields (Conf -> IO ())+scriptsCmd =+ command "scripts" $+ info parser $+ progDesc "prints the decoded scripts for each OID"+ where+ parser = (\r f c -> dumpScripts c r Nothing f)+ <$> rawSwitchParser+ <*> gmeFileParser -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 +scriptCmd :: Mod CommandFields (Conf -> IO ())+scriptCmd =+ command "script" $+ info parser $+ progDesc "prints the decoded scripts for a specific OID"+ where+ parser = (\r f n c -> dumpScripts c r (Just n) f)+ <$> rawSwitchParser+ <*> gmeFileParser+ <*> scriptParser -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+ scriptParser = argument auto $ mconcat+ [ metavar "OID"+ , help "OID to look up"+ ] +binariesCmd :: Mod CommandFields (Conf -> IO ())+binariesCmd =+ command "binaries" $+ info parser $+ progDesc "dumps all binaries"+ where+ parser = const <$> (dumpBinariesTo <$> binariesDirParser <*> gmeFileParser) -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)+ binariesDirParser :: Parser FilePath+ binariesDirParser = strOption $ mconcat+ [ long "dir"+ , short 'd'+ , metavar "DIR"+ , help "Binaries output directory"+ , value "binaries"+ , showDefault+ ] -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+gamesCmd :: Mod CommandFields (Conf -> IO ())+gamesCmd =+ command "games" $+ info parser $+ progDesc "prints the decoded games"+ where+ parser = flip dumpGames <$> gmeFileParser -rewrite :: FilePath -> FilePath -> IO ()-rewrite inf out = do- (tt,_) <- parseTipToiFile <$> B.readFile inf- writeTipToi out tt+lintCmd :: Mod CommandFields (Conf -> IO ())+lintCmd =+ command "lint" $+ info parser $+ progDesc "checks for errors in the file or in this program"+ where+ parser = const <$> (lint <$> gmeFileParser) -export :: FilePath -> FilePath -> IO ()-export inf out = do- (tt,_) <- parseTipToiFile <$> B.readFile inf- let tty = tt2ttYaml (printf "media/%s_%%s" (takeBaseName inf)) tt- ex <- doesFileExist out- if ex- then printf "File \"%s\" does already exist. Please remove it first\nif you want to export \"%s\" again.\n" out inf >> exitFailure- else writeTipToiYaml out tty+segmentsCmd :: Mod CommandFields (Conf -> IO ())+segmentsCmd =+ command "segments" $+ info parser $+ progDesc "lists all known parts of the file, with description."+ where+ parser = const <$> (segments <$> gmeFileParser) -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+segmentCmd :: Mod CommandFields (Conf -> IO ())+segmentCmd =+ command "segment" $+ info parser $+ progDesc "prints the decoded scripts for a specific OID"+ where+ parser = (\f n c -> findPosition n f)+ <$> gmeFileParser+ <*> offsetParser + offsetParser = argument hexReadM $ mconcat+ [ metavar "POS"+ , help "offset into the file to look up, in bytes"+ ] -genPNGs :: DPI -> PixelSize -> String -> IO ()-genPNGs dpi ps arg = do- ex <- doesFileExist arg- if ex then genPNGsForFile dpi ps arg- else genPNGsForCodes dpi ps arg+ hexReadM :: ReadM Integer+ hexReadM = eitherReader go+ where go n | Just int <- readMaybe n = return int+ | [(int,[])] <- readHex n = return int+ | otherwise = Left $ "Cannot parse offset " ++ n -genPNGsForFile :: DPI -> PixelSize -> FilePath -> IO ()-genPNGsForFile dpi ps inf = do- (tty, codeMap) <- readTipToiYaml inf- (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap- let codes = ("START", fromIntegral (ttProductId tt)) : M.toList totalMap- forM_ codes $ \(s,c) -> do- genPNG dpi ps c $ printf "oid-%d-%s.png" (ttProductId tt) s+holesCmd :: Mod CommandFields (Conf -> IO ())+holesCmd =+ command "holes" $+ info parser $+ progDesc "lists all unknown parts of the file."+ where+ parser = const <$> (unknown_segments <$> gmeFileParser) -genPNGsForCodes :: DPI -> PixelSize -> String -> IO ()-genPNGsForCodes dpi ps code_str = do- codes <- parseRange code_str- forM_ codes $ \c -> do- genPNG dpi ps c $ printf "oid-%d.png" c+explainCmd :: Mod CommandFields (Conf -> IO ())+explainCmd =+ command "explain" $+ info parser $+ progDesc "print a hexdump of a GME file with descriptions"+ where+ parser = const <$> (explain <$> gmeFileParser) -genPNG :: DPI -> PixelSize -> Word16 -> String -> IO ()-genPNG dpi ps c filename =- case code2RawCode c of- Nothing -> printf "Skipping %s, code %d not known.\n" filename c- Just r -> do- printf "Writing %s.. (Code %d, raw code %d)\n" filename c r- genRawPNG dpi ps r filename+playCmd :: Mod CommandFields (Conf -> IO ())+playCmd =+ command "play" $+ info parser $+ progDesc "interactively play a GME file"+ where+ parser = flip play <$> gmeFileParser -genPNGsForRawCodes :: DPI -> PixelSize -> String -> IO ()-genPNGsForRawCodes dpi ps code_str = do- codes <- parseRange code_str- forM_ codes $ \r -> do- let filename = printf "oid-raw-%d.png" r- printf "Writing %s... (raw code %d)\n" filename r- genRawPNG dpi ps r filename+rewriteCmd :: Mod CommandFields (Conf -> IO ())+rewriteCmd =+ command "rewrite" $+ info parser $+ progDesc "parses the file and reads it again (for debugging)"+ where+ parser = const <$> (rewrite <$> gmeFileParser <*> outFileParser) + outFileParser :: Parser FilePath+ outFileParser = strArgument $ mconcat+ [ metavar "OUT"+ , help "GME file to write"+ ] --- The main function+twoFiles :: String -> (FilePath -> FilePath -> a) -> (FilePath -> Maybe FilePath -> a)+twoFiles suffix go inFile (Just outFile) = go inFile outFile+twoFiles suffix go inFile Nothing = go inFile outFile+ where outFile = dropExtension inFile <.> suffix -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+exportCmd :: Mod CommandFields (Conf -> IO ())+exportCmd =+ command "export" $+ info parser $+ progDesc "dumps the file in the human-readable yaml format"+ where+ parser = const <$> (twoFiles "yaml" export <$> gmeFileParser <*> outFileParser)++ outFileParser :: Parser (Maybe FilePath)+ outFileParser = optional $ strArgument $ mconcat+ [ metavar "OUT"+ , help "YAML file to write" ] --- 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'+assembleCmd :: Mod CommandFields (Conf -> IO ())+assembleCmd =+ command "assemble" $+ info parser $+ progDesc "creates a gme file from the given source"+ where+ parser = const <$> (twoFiles "gme" assemble <$> yamlFileParser <*> outFileParser) -main' t ("-t":transscript:args) =- do t2 <- readTransscriptFile transscript- main' (t `M.union` t2) args+ outFileParser :: Parser (Maybe FilePath)+ outFileParser = optional $ strArgument $ mconcat+ [ metavar "OUT"+ , help "GME file to write"+ ] -main' t ("export": inf : [] ) = main' t ("export":inf: dropExtension inf <.> "yaml":[])-main' t ("assemble": inf : [] ) = main' t ("assemble":inf: dropExtension inf <.> "gme":[])+oidTableCmd :: Mod CommandFields (Conf -> IO ())+oidTableCmd =+ command "oid-table" $+ info parser $+ progDesc "creates a PDF file with all codes in the yaml file"+ where+ parser = (\a b conf -> twoFiles "pdf" (genOidTable conf) a b) <$> yamlFileParser <*> outFileParser -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 ("binaries": "-d": dir: files) = withEachFile (dumpBinariesTo dir) files-main' t ("binaries": files) = withEachFile (dumpBinariesTo "binaries") files-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 ("oid-code": "-d" : "600" : codes@(_:_))- = genPNGs D600 SinglePixel (unwords codes)-main' t ("oid-code": "-d" : "1200" : codes@(_:_))- = genPNGs D1200 SinglePixel (unwords codes)-main' t ("oid-code": "-d" : "600d" : codes@(_:_))- = genPNGs D600 DoublePixel (unwords codes)-main' t ("oid-code": "-d" : "1200d" : codes@(_:_))- = genPNGs D1200 DoublePixel (unwords codes)-main' t ("oid-code": "-d" : _) = do- putStrLn $ "The parameter to -d has to be 600, 1200, 600d or 1200d"- exitFailure-main' t ("oid-code": codes@(_:_)) = genPNGs D1200 SinglePixel (unwords codes)-main' t ("raw-oid-code": "-d" : "600" : codes@(_:_))- = genPNGsForRawCodes D600 SinglePixel (unwords codes)-main' t ("raw-oid-code": "-d" : "1200" : codes@(_:_))- = genPNGsForRawCodes D1200 SinglePixel (unwords codes)-main' t ("raw-oid-code": "-d" : "600d" : codes@(_:_))- = genPNGsForRawCodes D600 DoublePixel (unwords codes)-main' t ("raw-oid-code": "-d" : "1200d" : codes@(_:_))- = genPNGsForRawCodes D1200 DoublePixel (unwords codes)-main' t ("raw-oid-code": "-d" : _) = do- putStrLn $ "The parameter to -d has to be 600, 1200, 600d or 1200d"- exitFailure-main' t ("raw-oid-code": codes@(_:_)) = genPNGsForRawCodes D1200 SinglePixel (unwords codes)-main' _ _ = do- prg <- getProgName- putStrLn $ "This is the Tiptoi toolkit, version " ++ showVersion version- putStrLn $ ""- 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 $ " binaries [-d dir] <file.gme>..."- putStrLn $ " dumps all binaries to the given directory (default: binaries/)"- 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 or file.yaml>"- putStrLn $ " interactively play: Enter OIDs, and see what happens."- putStrLn $ " rewrite <infile.gme> <outfile.gme>"- putStrLn $ " parses the file and serializes it again (for debugging)."- 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 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. With -d 600d resp. 1200d you can"- putStrLn $ " double the size of the pixel."- putStrLn $ " <codes> can be a range, e.g. 1,3,1000-1085."- 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."- putStrLn $ " raw-oid-code [-d DPI] <raw codes>"- putStrLn $ " creates a PNG file with the given \"raw code\". Usually not needed."- putStrLn $ " Uses oid-raw-<code>.png as the file name."- exitFailure+ outFileParser :: Parser (Maybe FilePath)+ outFileParser = optional $ strArgument $ mconcat+ [ metavar "OUT"+ , help "PDF file to write"+ ] -main = getArgs >>= (main' M.empty)+oidCodesCmd :: Mod CommandFields (Conf -> IO ())+oidCodesCmd =+ command "oid-codes" $+ info parser $+ progDesc "creates PNG files for every OID in the yaml file." <>+ footerDoc foot+ where+ foot = unChunk $ vsepChunks+ [ paragraph "Uses oid-<code>.png as the file name."+ , paragraph "Use the global options to configure size, resolution and blackness of the code (see ./tttool --help)."+ , paragraph $ "Note that it used to work to call \"tttool oid-code foo.yaml\". " +++ "Please use \"tttool oid-codes\" for that now."+ ]+ parser = flip genPNGsForFile <$> yamlFileParser +oidCodeCmd :: Mod CommandFields (Conf -> IO ())+oidCodeCmd =+ command "oid-code" $+ info parser $+ progDesc "creates PNG files for each given code(s)" <>+ footerDoc foot+ where+ foot = unChunk $ vsepChunks+ [ paragraph "Uses oid-<code>.png as the file name."+ , paragraph "Use the global options to configure size, resolution and blackness of the code (see ./tttool --help)."+ , paragraph $ "Note that it used to work to call \"tttool oid-code foo.yaml\". " +++ "Please use \"tttool oid-codes\" for that now."+ ]++ parser =(\raw range c -> genPNGsForCodes raw c range) <$> rawCodeSwitchParser <*> codeRangeParser++ codeRangeParser :: Parser [Word16]+ codeRangeParser = argument (eitherReader parseRange) $ mconcat+ [ metavar "RANGE"+ , help "OID range, for example e.g. 1,3,1000-1085."+ ]++ rawCodeSwitchParser :: Parser Bool+ rawCodeSwitchParser = switch $ mconcat+ [ long "raw"+ , help "take the given codes as \"raw codes\" (rarely needed)"+ ]++main :: IO ()+main = do+ act <- customExecParser (prefs showHelpOnError) optionParser+ act
tttool.cabal view
@@ -1,5 +1,5 @@ name: tttool-version: 1.5.1+version: 1.6 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@@ -37,18 +37,21 @@ Lint, Language, OidCode,+ OidTable, OneLineParser, PlaySound, PrettyPrint, RangeParser, TipToiYaml,+ TipToiYamlAux, TextToSpeech, KnownCodes, Types,+ Commands, Utils build-depends:- base == 4.5.* || == 4.6.* || == 4.7.* || == 4.8.*,+ base >= 4.5 && < 4.10, binary == 0.5.* || == 0.7.*, containers == 0.4.* || == 0.5.*, directory == 1.2.*,@@ -56,7 +59,7 @@ filepath == 1.3.* || == 1.4.*, template-haskell >= 2.7 && < 2.11, - JuicyPixels == 3.1.* || == 3.2.*,+ JuicyPixels >= 3.2.5 && < 3.3, aeson >= 0.7 && < 0.11, hashable == 1.2.*, haskeline == 0.7.*,@@ -65,15 +68,22 @@ process >= 1.1 && < 1.5, random >= 1.0 && < 1.2, vector >= 0.10 && < 0.12,- yaml == 0.8.*+ yaml == 0.8.*,+ HPDF >= 1.4.10 && < 1.5,+ split == 0.2.*,+ optparse-applicative == 0.12.*,+ spool == 0.1.*,+ zlib >= 0.5 && < 0.7 if impl(ghc < 7.5) build-depends: ghc-prim + ghc-options: -fcontext-stack=42+ if flag(old-locale) build-depends: time == 1.4.*, old-locale else- build-depends: time == 1.5.*+ build-depends: time >= 1.5 && < 1.7 if flag(bytestring_has_builder) build-depends:@@ -88,6 +98,7 @@ default-language: Haskell2010 ghc-options: -fwarn-unused-imports+ -fwarn-incomplete-patterns -rtsopts -with-rtsopts=-K100M