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