tttool-1.0: src/tttool.hs
{-# LANGUAGE CPP, RecordWildCards, TupleSections #-}
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 Text.Blaze.Svg11 ((!), mkPath, rotate, l, m)
import qualified Text.Blaze.Svg11 as S
import qualified Text.Blaze.Svg11.Attributes as A
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
-}
import Types
import Constants
import KnownCodes
import GMEParser
import GMEWriter
import GMERun
import PrettyPrint
import RangeParser
import OidCode
import Utils
import TipToiYaml
import Lint
-- Main commands
dumpAudioTo :: FilePath -> FilePath -> IO ()
dumpAudioTo directory file = do
(tt,_) <- parseTipToiFile <$> B.readFile file
printf "Audio Table entries: %d\n" (length (ttAudioFiles tt))
createDirectoryIfMissing False directory
forMn_ (ttAudioFiles tt) $ \n audio -> do
let audiotype = maybe "raw" snd $ find (\(m,t) -> m `B.isPrefixOf` audio) fileMagics
let filename = printf "%s/%s_%d.%s" directory (takeBaseName file) n audiotype
if B.null audio
then do
printf "Skipping empty file %s...\n" filename
else do
B.writeFile filename audio
printf "Dumped sample %d as %s\n" n filename
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 :: Transscript -> Bool -> Maybe Int -> FilePath -> IO ()
dumpScripts t raw sel file = do
bytes <- B.readFile file
let (tt,_) = parseTipToiFile bytes
st' | Just n <- sel = filter ((== fromIntegral n) . fst) (ttScripts tt)
| otherwise = ttScripts tt
forM_ st' $ \(i, ms) -> case ms of
Nothing -> do
printf "Script for OID %d: Disabled\n" i
Just lines -> do
printf "Script for OID %d:\n" i
forM_ lines $ \line -> do
if raw then printf "%s\n" (lineHex bytes line)
else printf " %s\n" (ppLine t line)
dumpInfo :: Transscript -> FilePath -> IO ()
dumpInfo t file = do
(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 :: Transscript -> FilePath -> IO ()
play t file = do
(tt,_) <- parseTipToiFile <$> B.readFile file
playTipToi t tt
segments :: FilePath -> IO ()
segments file = do
(tt,segments) <- parseTipToiFile <$> B.readFile file
mapM_ printSegment segments
printSegment (o,l,desc) = printf "At 0x%08X Size %8d: %s\n" o l (ppDesc desc)
explain :: FilePath -> IO ()
explain file = do
bytes <- B.readFile file
let (tt,segments) = parseTipToiFile bytes
forM_ (addHoles segments) $ \e -> case e of
Left (o,l) -> do
printSegment (o,l,["-- unknown --"])
printExtract bytes o l
putStrLn ""
Right s@(o,l,_) -> do
printSegment s
printExtract bytes o l
putStrLn ""
printExtract :: B.ByteString -> Offset -> Word32 -> IO ()
printExtract b o l = do
let o1 = o .&. 0xFFFFFFF0
lim_forM_ [o1, o1+0x10 .. (o + l-1)] $ \s -> do
let s' = max o s
let d = fromIntegral s' - fromIntegral s
let l' = (min (o + l) (s + 0x10)) - s'
printf " 0x%08X: %s%s\n"
s
(replicate (d*3) ' ')
(prettyHex (extract s' l' b))
where
lim_forM_ l act
= if length l > 30
then do act (head l)
printf " (skipping %d lines)\n" (length l - 2) :: IO ()
act (last l)
else do forM_ l act
findPosition :: Integer -> FilePath -> IO ()
findPosition pos' file = do
(tt,segments) <- parseTipToiFile <$> B.readFile file
case find (\(o,l,_) -> pos >= o && pos < o + l) segments of
Just s -> do
printf "Offset 0x%08X is part of this segment:\n" pos
printSegment s
Nothing -> do
let before = filter (\(o,l,_) -> pos >= o + l) segments
after = filter (\(o,l,_) -> pos < o) segments
printBefore | null before = printf "(nothing before)\n"
| otherwise = printSegment (maximumBy (comparing (\(o,l,_) -> o+l)) before)
printAfter | null after = printf "(nothing after)\n"
| otherwise = printSegment (minimumBy (comparing (\(o,l,_) -> o)) after)
printf "Offset %08X not found. It lies between these two segments:\n" pos
printBefore
printAfter
where
pos = fromIntegral pos'
addHoles :: [Segment] -> [Either (Offset, Word32) Segment]
addHoles = go
where go [] = []
go [s] = [Right s]
go (s@(o1,l1,d2):r@((o2,_,_):_))
| o1 + l1 == o2 -- no hole
= Right s : go r
| otherwise -- a hole
= Right s : Left (o1+l1, o2 - (o1 + l1)) : go r
unknown_segments :: FilePath -> IO ()
unknown_segments file = do
bytes <- B.readFile file
let (_,segments) = parseTipToiFile bytes
let unknown_segments =
filter (\(o,l) -> not
(l == 2 && G.runGet (G.skip (fromIntegral o) >> G.getWord16le) bytes == 0)) $
lefts $ addHoles $ segments
printf "Unknown file segments: %d (%d bytes total)\n"
(length unknown_segments) (sum (map snd unknown_segments))
forM_ unknown_segments $ \(o,l) ->
printf " Offset: %08X to %08X (%d bytes)\n" o (o+l) l
withEachFile :: (FilePath -> IO ()) -> [FilePath] -> IO ()
withEachFile _ [] = main' undefined []
withEachFile a [f] = a f
withEachFile a fs = forM_ fs $ \f -> do
printf "%s:\n" f
a f
dumpGames :: Transscript -> FilePath -> IO ()
dumpGames t file = do
bytes <- B.readFile file
let (tt,_) = parseTipToiFile bytes
forMn_ (ttGames tt) $ \n g -> do
printf "Game %d:\n" n
printf "%s\n" (ppGame t g)
writeTipToi :: FilePath -> TipToiFile -> IO ()
writeTipToi out tt = do
let bytes = writeTipToiFile tt
let checksum = B.foldl' (\s b -> fromIntegral b + s) 0 bytes
B.writeFile out $ Br.toLazyByteString $
Br.fromLazyByteString bytes `Br.append` Br.putWord32le checksum
rewrite :: FilePath -> FilePath -> IO ()
rewrite inf out = do
(tt,_) <- parseTipToiFile <$> B.readFile inf
writeTipToi out tt
export :: FilePath -> FilePath -> IO ()
export inf out = do
(tt,_) <- parseTipToiFile <$> B.readFile inf
let tty = tt2ttYaml (printf "media/%s_%%s" (takeBaseName inf)) tt
writeTipToiYaml out tty
assemble :: FilePath -> FilePath -> IO ()
assemble inf out = do
(tty, codeMap) <- readTipToiYaml inf
(tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap
writeTipToiCodeYaml inf tty codeMap totalMap
writeTipToi out tt
genPNGs :: DPI -> String -> IO ()
genPNGs dpi arg = do
ex <- doesFileExist arg
if ex then genPNGsForFile dpi arg
else genPNGsForCodes dpi arg
genPNGsForFile :: DPI -> FilePath -> IO ()
genPNGsForFile dpi inf = do
(tty, codeMap) <- readTipToiYaml inf
(tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap
let codes = ("START", fromIntegral (ttProductId tt)) : M.toList totalMap
forM_ codes $ \(s,c) -> do
genPNG dpi c $ printf "oid-%d-%s.png" (ttProductId tt) s
genPNGsForCodes :: DPI -> String -> IO ()
genPNGsForCodes dpi code_str = do
codes <- parseRange code_str
forM_ codes $ \c -> do
genPNG dpi c $ printf "oid-%d.png" c
genPNG :: DPI -> Word16 -> String -> IO ()
genPNG dpi 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 r filename
genPNGsForRawCodes :: DPI -> String -> IO ()
genPNGsForRawCodes dpi 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 r filename
-- The main function
readTransscriptFile :: FilePath -> IO Transscript
readTransscriptFile transcriptfile_ = do
file <- readFile transcriptfile_
return $ M.fromList
[ (idx, string)
| l <- lines file
, (idxstr:string:_) <- return $ wordsWhen (';'==) l
, Just idx <- return $ readMaybe idxstr
]
-- Avoiding dependencies, using code from http://stackoverflow.com/a/4981265/946226
wordsWhen :: (Char -> Bool) -> String -> [String]
wordsWhen p s = case dropWhile p s of
"" -> []
s' -> w : wordsWhen p s''
where (w, s'') = break p s'
main' t ("-t":transscript:args) =
do t2 <- readTransscriptFile transscript
main' (t `M.union` t2) args
main' t ("export": inf : [] ) = main' t ("export":inf: dropExtension inf <.> "yaml":[])
main' t ("assemble": inf : [] ) = main' t ("assemble":inf: dropExtension inf <.> "gme":[])
main' t ("info": files) = withEachFile (dumpInfo t) files
main' t ("media": "-d": dir: files) = withEachFile (dumpAudioTo dir) files
main' t ("media": files) = withEachFile (dumpAudioTo "media") files
main' t ("scripts": files) = withEachFile (dumpScripts t False Nothing) files
main' t ("script": file : n:[])
| Just int <- readMaybe n = dumpScripts t False (Just int) file
main' t ("raw-scripts": files) = withEachFile (dumpScripts t True Nothing) files
main' t ("raw-script": file : n:[])
| Just int <- readMaybe n = dumpScripts t True (Just int) file
main' t ("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 (unwords codes)
main' t ("oid-code": "-d" : "1200" : codes@(_:_))
= genPNGs D1200 (unwords codes)
main' t ("oid-code": "-d" : _) = do
putStrLn $ "The parameter to -d has to be 600 or 1200"
exitFailure
main' t ("oid-code": codes@(_:_)) = genPNGs D1200 (unwords codes)
main' t ("raw-oid-code": "-d" : "600" : codes@(_:_))
= genPNGsForRawCodes D600 (unwords codes)
main' t ("raw-oid-code": "-d" : "1200" : codes@(_:_))
= genPNGsForRawCodes D1200 (unwords codes)
main' t ("raw-oid-code": "-d" : _) = do
putStrLn $ "The parameter to -d has to be 600 or 1200"
exitFailure
main' t ("raw-oid-code": codes@(_:_)) = genPNGsForRawCodes D1200 (unwords codes)
main' _ _ = do
prg <- getProgName
putStrLn $ "Usage: " ++ prg ++ " [options] command"
putStrLn $ ""
putStrLn $ "Options:"
putStrLn $ " -t <transcriptfile>"
putStrLn $ " in the screen output, replaces media file indices by a transscript"
putStrLn $ ""
putStrLn $ "Commands:"
putStrLn $ " info <file.gme>..."
putStrLn $ " general information"
putStrLn $ " media [-d dir] <file.gme>..."
putStrLn $ " dumps all audio samples to the given directory (default: media/)"
putStrLn $ " scripts <file.gme>..."
putStrLn $ " prints the decoded scripts for each OID"
putStrLn $ " script <file.gme> <n>"
putStrLn $ " prints the decoded scripts for the given OID"
putStrLn $ " raw-scripts <file.gme>..."
putStrLn $ " prints the scripts for each OID, in their raw form"
putStrLn $ " raw-script <file.gme> <n>"
putStrLn $ " prints the scripts for the given OID, in their raw form"
putStrLn $ " 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>"
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."
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
main = getArgs >>= (main' M.empty)