tttool-0.1: src/tttool.hs
{-# LANGUAGE CPP #-}
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as BC
import System.Environment
import System.Exit
import System.FilePath
import qualified Data.Binary.Builder as Br
import qualified Data.Binary.Get as G
import Text.Printf
import Data.Bits
import Data.List
import Data.Either
import Data.Functor
import Data.Maybe
import Data.Ord
import Control.Monad
import System.Directory
import Numeric (readHex)
import qualified Data.Map as M
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import Data.Time (getCurrentTime, formatTime)
{-
import Text.Blaze.Svg11 ((!), mkPath, rotate, l, m)
import qualified Text.Blaze.Svg11 as S
import qualified Text.Blaze.Svg11.Attributes as A
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
-}
import Types
import Constants
import GMEParser
import GMEWriter
import GMERun
import PrettyPrint
import RangeParser
import OidCode
import Utils
import TipToiYaml
import Lint
-- Main commands
dumpAudioTo :: FilePath -> FilePath -> IO ()
dumpAudioTo directory file = do
(tt,_) <- parseTipToiFile <$> B.readFile file
printf "Audio Table entries: %d\n" (length (ttAudioFiles tt))
createDirectoryIfMissing False directory
forMn_ (ttAudioFiles tt) $ \n audio -> do
let audiotype = maybe "raw" snd $ find (\(m,t) -> m `B.isPrefixOf` audio) fileMagics
let filename = printf "%s/%s_%d.%s" directory (takeBaseName file) n audiotype
if B.null audio
then do
printf "Skipping empty file %s...\n" filename
else do
B.writeFile filename audio
printf "Dumped sample %d as %s\n" n filename
dumpScripts :: Transscript -> Bool -> Maybe Int -> FilePath -> IO ()
dumpScripts t raw sel file = do
bytes <- B.readFile file
let (tt,_) = parseTipToiFile bytes
st' | Just n <- sel = filter ((== fromIntegral n) . fst) (ttScripts tt)
| otherwise = ttScripts tt
forM_ st' $ \(i, ms) -> case ms of
Nothing -> do
printf "Script for OID %d: Disabled\n" i
Just lines -> do
printf "Script for OID %d:\n" i
forM_ lines $ \line -> do
if raw then printf "%s\n" (lineHex bytes line)
else printf " %s\n" (ppLine t line)
dumpInfo :: Transscript -> FilePath -> IO ()
dumpInfo t file = do
(tt,_) <- parseTipToiFile <$> B.readFile file
let st = ttScripts tt
printf "Product ID: %d\n" (ttProductId tt)
printf "Raw XOR value: 0x%08X\n" (ttRawXor tt)
printf "Magic XOR value: 0x%02X\n" (ttAudioXor tt)
printf "Comment: %s\n" (BC.unpack (ttComment tt))
printf "Date: %s\n" (BC.unpack (ttDate tt))
printf "Number of registers: %d\n" (length (ttInitialRegs tt))
printf "Initial registers: %s\n" (show (ttInitialRegs tt))
printf "Initial sounds: %s\n" (ppPlayListList t (ttWelcome tt))
printf "Scripts for OIDs from %d to %d; %d/%d are disabled.\n"
(fst (head st)) (fst (last st))
(length (filter (isNothing . snd) st)) (length st)
printf "Audio Table entries: %d\n" (length (ttAudioFiles tt))
when (ttAudioFilesDoubles tt) $ printf "Audio table repeated twice\n"
printf "Checksum found 0x%08X, calculated 0x%08X\n" (ttChecksum tt) (ttChecksumCalc tt)
lint :: FilePath -> IO ()
lint file = do
(tt,segments) <- parseTipToiFile <$> B.readFile file
lintTipToi tt segments
play :: Transscript -> FilePath -> IO ()
play t file = do
(tt,_) <- parseTipToiFile <$> B.readFile file
playTipToi t tt
segments :: FilePath -> IO ()
segments file = do
(tt,segments) <- parseTipToiFile <$> B.readFile file
mapM_ printSegment segments
printSegment (o,l,desc) = printf "At 0x%08X Size %8d: %s\n" o l (ppDesc desc)
explain :: FilePath -> IO ()
explain file = do
bytes <- B.readFile file
let (tt,segments) = parseTipToiFile bytes
forM_ (addHoles segments) $ \e -> case e of
Left (o,l) -> do
printSegment (o,l,["-- unknown --"])
printExtract bytes o l
putStrLn ""
Right s@(o,l,_) -> do
printSegment s
printExtract bytes o l
putStrLn ""
printExtract :: B.ByteString -> Offset -> Word32 -> IO ()
printExtract b o l = do
let o1 = o .&. 0xFFFFFFF0
lim_forM_ [o1, o1+0x10 .. (o + l-1)] $ \s -> do
let s' = max o s
let d = fromIntegral s' - fromIntegral s
let l' = (min (o + l) (s + 0x10)) - s'
printf " 0x%08X: %s%s\n"
s
(replicate (d*3) ' ')
(prettyHex (extract s' l' b))
where
lim_forM_ l act
= if length l > 30
then do act (head l)
printf " (skipping %d lines)\n" (length l - 2) :: IO ()
act (last l)
else do forM_ l act
findPosition :: Integer -> FilePath -> IO ()
findPosition pos' file = do
(tt,segments) <- parseTipToiFile <$> B.readFile file
case find (\(o,l,_) -> pos >= o && pos < o + l) segments of
Just s -> do
printf "Offset 0x%08X is part of this segment:\n" pos
printSegment s
Nothing -> do
let before = filter (\(o,l,_) -> pos >= o + l) segments
after = filter (\(o,l,_) -> pos < o) segments
printBefore | null before = printf "(nothing before)\n"
| otherwise = printSegment (maximumBy (comparing (\(o,l,_) -> o+l)) before)
printAfter | null after = printf "(nothing after)\n"
| otherwise = printSegment (minimumBy (comparing (\(o,l,_) -> o)) after)
printf "Offset %08X not found. It lies between these two segments:\n" pos
printBefore
printAfter
where
pos = fromIntegral pos'
addHoles :: [Segment] -> [Either (Offset, Word32) Segment]
addHoles = go
where go [] = []
go [s] = [Right s]
go (s@(o1,l1,d2):r@((o2,_,_):_))
| o1 + l1 == o2 -- no hole
= Right s : go r
| otherwise -- a hole
= Right s : Left (o1+l1, o2 - (o1 + l1)) : go r
unknown_segments :: FilePath -> IO ()
unknown_segments file = do
bytes <- B.readFile file
let (_,segments) = parseTipToiFile bytes
let unknown_segments =
filter (\(o,l) -> not
(l == 2 && G.runGet (G.skip (fromIntegral o) >> G.getWord16le) bytes == 0)) $
lefts $ addHoles $ segments
printf "Unknown file segments: %d (%d bytes total)\n"
(length unknown_segments) (sum (map snd unknown_segments))
forM_ unknown_segments $ \(o,l) ->
printf " Offset: %08X to %08X (%d bytes)\n" o (o+l) l
withEachFile :: (FilePath -> IO ()) -> [FilePath] -> IO ()
withEachFile _ [] = main' undefined []
withEachFile a [f] = a f
withEachFile a fs = forM_ fs $ \f -> do
printf "%s:\n" f
a f
dumpGames :: Transscript -> FilePath -> IO ()
dumpGames t file = do
bytes <- B.readFile file
let (tt,_) = parseTipToiFile bytes
forMn_ (ttGames tt) $ \n g -> do
printf "Game %d:\n" n
printf "%s\n" (ppGame t g)
writeTipToi :: FilePath -> TipToiFile -> IO ()
writeTipToi out tt = do
let bytes = writeTipToiFile tt
let checksum = B.foldl' (\s b -> fromIntegral b + s) 0 bytes
B.writeFile out $ Br.toLazyByteString $
Br.fromLazyByteString bytes `Br.append` Br.putWord32le checksum
rewrite :: FilePath -> FilePath -> IO ()
rewrite inf out = do
(tt,_) <- parseTipToiFile <$> B.readFile inf
writeTipToi out tt
export :: FilePath -> FilePath -> IO ()
export inf out = do
(tt,_) <- parseTipToiFile <$> B.readFile inf
let tty = tt2ttYaml (printf "media/%s_%%s" (takeBaseName inf)) tt
writeTipToiYaml out tty
assemble :: FilePath -> FilePath -> IO ()
assemble inf out = do
(tty, codeMap) <- readTipToiYaml inf
(tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap
writeTipToiCodeYaml inf tty codeMap totalMap
writeTipToi out tt
debugGame :: ProductID -> IO TipToiFile
debugGame productID = do
-- Files orderes so that index 0 says zero, 10 is blob
files <- mapM B.readFile
[ "./Audio/digits/" ++ base ++ ".ogg"
| base <- [ "english-" ++ [n] | n <- ['0'..'9']] ++ ["blob" ]
]
now <- getCurrentTime
let date = formatTime defaultTimeLocale "%Y%m%d" now
return $ TipToiFile
{ ttProductId = productID
, ttRawXor = 0x00000039 -- from Bauernhof
, ttComment = BC.pack "created with tip-toi-reveng"
, ttDate = BC.pack date
, ttWelcome = []
, ttInitialRegs = [1]
, ttScripts = [
(oid, Just [line])
| oid <- [1..15000]
, let chars = [oid `div` 10^p `mod` 10| p <-[4,3,2,1,0]]
, let line = Line 0 [] [Play n | n <- [0..5]] ([10] ++ chars)
]
, ttGames = []
, ttAudioFiles = files
, ttAudioXor = 0xAD
, ttAudioFilesDoubles = False
, ttChecksum = 0x00
, ttChecksumCalc = 0x00
}
createDebug :: FilePath -> ProductID -> IO ()
createDebug out productID = do
tt <- debugGame productID
writeTipToi out tt
genPNGs :: DPI -> String -> IO ()
genPNGs dpi arg = do
ex <- doesFileExist arg
if ex then genPNGsForFile dpi arg
else genPNGsForCodes dpi arg
genPNGsForFile :: DPI -> FilePath -> IO ()
genPNGsForFile dpi inf = do
(tty, codeMap) <- readTipToiYaml inf
(tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap
forM_ (M.toList totalMap) $ \(s,c) -> do
let filename = printf "oid-%d-%s.png" (ttyProduct_Id tty) s
case code2RawCode c of
Nothing -> printf "Skipping %s, code %d not known." filename c
Just r -> do
printf "Writing %s.. (Code %d, raw code %d)\n" filename c r
genPNG dpi r filename
genPNGsForCodes :: DPI -> String -> IO ()
genPNGsForCodes dpi code_str = do
codes <- parseRange code_str
forM_ codes $ \c -> do
let filename = printf "oid%d.png" c
printf "Writing %s...\n" filename
genPNG dpi c filename
-- The main function
readTransscriptFile :: FilePath -> IO Transscript
readTransscriptFile transcriptfile_ = do
file <- readFile transcriptfile_
return $ M.fromList
[ (idx, string)
| l <- lines file
, (idxstr:string:_) <- return $ wordsWhen (';'==) l
, Just idx <- return $ readMaybe idxstr
]
-- Avoiding dependencies, using code from http://stackoverflow.com/a/4981265/946226
wordsWhen :: (Char -> Bool) -> String -> [String]
wordsWhen p s = case dropWhile p s of
"" -> []
s' -> w : wordsWhen p s''
where (w, s'') = break p s'
main' t ("-t":transscript:args) =
do t2 <- readTransscriptFile transscript
main' (t `M.union` t2) args
main' t ("export": inf : [] ) = main' t ("export":inf: dropExtension inf <.> "yaml":[])
main' t ("assemble": inf : [] ) = main' t ("assemble":inf: dropExtension inf <.> "gme":[])
main' t ("info": files) = withEachFile (dumpInfo t) files
main' t ("media": "-d": dir: files) = withEachFile (dumpAudioTo dir) files
main' t ("media": files) = withEachFile (dumpAudioTo "media") files
main' t ("scripts": files) = withEachFile (dumpScripts t False Nothing) files
main' t ("script": file : n:[])
| Just int <- readMaybe n = dumpScripts t False (Just int) file
main' t ("raw-scripts": files) = withEachFile (dumpScripts t True Nothing) files
main' t ("raw-script": file : n:[])
| Just int <- readMaybe n = dumpScripts t True (Just int) file
main' t ("games": files) = withEachFile (dumpGames t) files
main' t ("lint": files) = withEachFile lint files
main' t ("segments": files) = withEachFile segments files
main' t ("segment": file : n :[])
| Just int <- readMaybe n = findPosition int file
| [(int,[])] <- readHex n = findPosition int file
main' t ("holes": files) = withEachFile unknown_segments files
main' t ("explain": files) = withEachFile explain files
main' t ("play": file : []) = play t file
main' t ("rewrite": inf : out: []) = rewrite inf out
main' t ("export": inf : out: [] ) = export inf out
main' t ("assemble": inf : out: [] ) = assemble inf out
main' t ("create-debug": out : n :[])
| Just int <- readMaybe n = createDebug out int
| [(int,[])] <- readHex n = createDebug out int
main' t ("oid-code": "-d" : "600" : codes@(_:_))
= genPNGs D600 (unwords codes)
main' t ("oid-code": "-d" : "1200" : codes@(_:_))
= genPNGs D1200 (unwords codes)
main' t ("oid-code": "-d" : _) = do
putStrLn $ "The parameter to -d has to be 600 or 1200"
exitFailure
main' t ("oid-code": codes@(_:_)) = genPNGs D1200 (unwords codes)
main' _ _ = do
prg <- getProgName
putStrLn $ "Usage: " ++ prg ++ " [options] command"
putStrLn $ ""
putStrLn $ "Options:"
putStrLn $ " -t <transcriptfile>"
putStrLn $ " in the screen output, replaces media file indices by a transscript"
putStrLn $ ""
putStrLn $ "Commands:"
putStrLn $ " info <file.gme>..."
putStrLn $ " general information"
putStrLn $ " media [-d dir] <file.gme>..."
putStrLn $ " dumps all audio samples to the given directory (default: media/)"
putStrLn $ " scripts <file.gme>..."
putStrLn $ " prints the decoded scripts for each OID"
putStrLn $ " script <file.gme> <n>"
putStrLn $ " prints the decoded scripts for the given OID"
putStrLn $ " raw-scripts <file.gme>..."
putStrLn $ " prints the scripts for each OID, in their raw form"
putStrLn $ " raw-script <file.gme> <n>"
putStrLn $ " prints the scripts for the given OID, in their raw form"
putStrLn $ " games <file.gme>..."
putStrLn $ " prints the decoded games"
putStrLn $ " lint <file.gme>"
putStrLn $ " checks for errors in the file or in this program"
putStrLn $ " segments <file.gme>..."
putStrLn $ " lists all known parts of the file, with description."
putStrLn $ " segment <file.gme> <pos>"
putStrLn $ " which segment contains the given position."
putStrLn $ " holes <file.gme>..."
putStrLn $ " lists all unknown parts of the file."
putStrLn $ " explain <file.gme>..."
putStrLn $ " lists all parts of the file, with description and hexdump."
putStrLn $ " play <file.gme>"
putStrLn $ " interactively play: Enter OIDs, and see what happens."
putStrLn $ " rewrite <infile.gme> <outfile.gme>"
putStrLn $ " parses the file and serializes it again (for debugging)."
putStrLn $ " create-debug <outfile.gme> <productid>"
putStrLn $ " creates a special Debug.gme file for that productid"
putStrLn $ " export <infile.gme> [<outfile.yaml>]"
putStrLn $ " dumps the file in the human-readable yaml format"
putStrLn $ " assemble <infile.yaml> <outfile.gme>"
putStrLn $ " creates a gme file from the given source"
putStrLn $ " oid-code [-d DPI] <codes>"
putStrLn $ " creates a PNG file for each given optical code"
putStrLn $ " scale this to 10cm×10cm"
putStrLn $ " By default, it creates a 1200 dpi image. With -d 600, you"
putStrLn $ " obtain a 600 dpi image."
putStrLn $ " <codes> can be a range, e.g. 1,3,1000-1085."
putStrLn $ " The code refers to the *raw* code, not the one read by the pen."
putStrLn $ " Uses oid<code>.png as the file name."
putStrLn $ " oid-code [-d DPI] <infile.yaml>"
putStrLn $ " Like above, but creates one file for each code in the yaml file."
putStrLn $ " Uses oid-<product-id>-<scriptname or code>.png as the file name."
exitFailure
main = getArgs >>= (main' M.empty)