tttool-0.1: src/PrettyPrint.hs
{-# LANGUAGE TypeSynonymInstances #-}
module PrettyPrint where
import qualified Data.ByteString.Lazy as B
import Text.Printf
import Data.List
import Data.Maybe
import qualified Data.Map as M
import Types
-- Pretty printing
lineHex bytes l = prettyHex $ extract (lineOffset l) (lineLength l) bytes
extract :: Offset -> Word32 -> B.ByteString -> B.ByteString
extract off len = B.take (fromIntegral len) . B.drop (fromIntegral off)
lineOffset (Line o _ _ _) = o
lineLength :: Line r -> Word32
lineLength (Line _ conds cmds audio) = fromIntegral $
2 + 8 * length conds + 2 + 7 * length cmds + 2 + 2 * length audio
ppLine :: Transscript -> Line ResReg -> String
ppLine t (Line _ cs as xs) = spaces $
map ppConditional cs ++ map (ppCommand False t xs) as
-- Varaint that does not generate invalid play commands
exportLine :: Line ResReg -> String
exportLine (Line _ cs as xs) = spaces $
map ppConditional cs ++ map (ppCommand True M.empty xs) as
-- Group consecutive runs of numbers, if they do not have a description
groupRuns :: (Eq a, Enum a) => (a -> Maybe b) -> [a] -> [Either b [a]]
groupRuns l = go
where
go [] = []
go [x] = case l x of Nothing -> [Right [x]]
Just s -> [Left s]
go (x:xs) = case l x of
Just l -> Left l : go xs
Nothing -> case go xs of
Right (y:ys):r' | succ x == y -> Right (x:y:ys) : r'
r -> Right [x] : r
ppPlayList :: Transscript -> PlayList -> String
ppPlayList t xs = "[" ++ commas (map go (groupRuns (flip M.lookup t) xs)) ++ "]"
where go (Left s) = quote s
go (Right []) = error "Empty list in groupRuns result"
go (Right l) | length l > 3 = show (head l) ++ ".." ++ show (last l)
| otherwise = commas (map show l)
ppOidList :: [OID] -> String
ppOidList xs = "[" ++ commas (map go (groupRuns (const Nothing) xs)) ++ "]"
where go (Left s) = s
go (Right []) = error "Empty list in groupRuns result"
go (Right l) | length l > 3 = show (head l) ++ ".." ++ show (last l)
| otherwise = commas (map show l)
ppPlayListList :: Transscript -> PlayListList -> String
ppPlayListList t xs = "[" ++ commas (map (ppPlayList t) xs) ++ "]"
ppConditional :: Conditional ResReg -> String
ppConditional (Cond v1 o v2) = printf "%s%s%s?" (ppTVal v1) (ppCondOp o) (ppTVal v2)
ppCondOp :: CondOp -> String
ppCondOp Eq = "=="
ppCondOp NEq = "!="
ppCondOp Lt = "< "
ppCondOp Gt = "> "
ppCondOp GEq = ">="
ppCondOp LEq = "<="
ppCondOp (Unknowncond b) = printf "?%s?" (prettyHex b)
ppTVal :: Reg r => TVal r -> String
ppTVal (Reg r) = ppReg r
ppTVal (Const n) = show n
ppResReg :: ResReg -> String
ppResReg n = "$" ++ show n
ppRegister :: Register -> String
ppRegister (RegPos n) = "$" ++ show n
ppRegister (RegName n) = "$" ++ n
class Reg a where
ppReg :: a -> String
instance Reg ResReg where ppReg = ppResReg
instance Reg Register where ppReg = ppRegister
ppArithOp :: ArithOp -> String
ppArithOp Inc = "+="
ppArithOp Dec = "-="
ppArithOp Mult = "*="
ppArithOp Div = "/="
ppArithOp Mod = "%="
ppArithOp And = "&="
ppArithOp Or = "|="
ppArithOp XOr = "^="
ppArithOp Set = ":="
ppCommand :: Reg r => Bool -> Transscript -> PlayList -> Command r -> String
ppCommand True t xs (Play n) | not (validIndex xs (fromIntegral n)) = ""
ppCommand True t xs (Random a b) | any (not . validIndex xs . fromIntegral) [b..a] = ""
ppCommand _ t xs (Play n) = printf "P(%s)" (ppPlayIndex t xs (fromIntegral n))
ppCommand _ t xs (Random a b) = printf "P(%s)" $ commas $ map (ppPlayIndex t xs . fromIntegral ) [b..a]
ppCommand _ t xs (Cancel) = printf "C"
ppCommand _ t xs (Jump v) = printf "J(%s)" (ppTVal v)
ppCommand _ t xs (NamedJump v) = printf "J(%s)" v
ppCommand _ t xs (Game b) = printf "G(%d)" b
ppCommand _ t xs (ArithOp o r n) = ppReg r ++ ppArithOp o ++ ppTVal n
ppCommand _ t xs (Neg r) = printf "Neg(%s)" (ppReg r)
ppCommand _ t xs (Unknown b r n) = printf "?(%s,%s) (%s)" (ppReg r) (ppTVal n) (prettyHex b)
validIndex :: PlayList -> Int -> Bool
validIndex xs n = n >= 0 && n < length xs
ppPlayIndex :: Transscript -> PlayList -> Int -> String
ppPlayIndex t xs n | validIndex xs n = transcribe t (xs !! n)
| otherwise = "invalid_index_" ++ show n
spaces = intercalate " "
commas = intercalate ","
quote s = printf "'%s'" s
ppGame :: Transscript -> Game -> String
ppGame t (Game6 u1 u2 plls sg1s sg2s u3 pll2s pl) =
printf (unlines [" type: 6", " u1: %d", " u2: %s",
" playlistlists: (%d)", "%s",
" subgames1: (%d)", "%s",
" subgames2: (%d)", "%s",
" u3: %s",
" playlistlists: (%d)","%s",
" playlist: %s"])
u1 (prettyHex u2)
(length plls) (indent 4 (map (ppPlayListList t) plls))
(length sg1s) (concatMap (ppSubGame t) sg1s)
(length sg2s) (concatMap (ppSubGame t) sg2s)
(prettyHex u3)
(length pll2s) (indent 4 (map (ppPlayListList t) pll2s))
(show pl)
ppGame t (Game7 u1 c u2 plls sgs u3 pll2s pll) =
printf (unlines [" type: 6", " u1: %d", " u2: %s",
" playlistlists: (%d)", "%s",
" subgames: (%d)", "%s",
" u3: %s",
" playlistlists: (%d)","%s",
" playlistlist: %s"])
u1 (prettyHex u2)
(length plls) (indent 4 (map (ppPlayListList t) plls))
(length sgs) (concatMap (ppSubGame t) sgs)
(prettyHex u3)
(length pll2s) (indent 4 (map (ppPlayListList t) pll2s))
(ppPlayListList t pll)
ppGame t (Game8 u1 c u2 plls sgs u3 pll2s oidl gidl pll1 pll2) =
printf (unlines [" type: 6", " u1: %d", " u2: %s",
" playlistlists: (%d)", "%s",
" subgames: (%d)", "%s",
" u3: %s",
" playlistlists: (%d)","%s",
" oids: %s",
" gids: %s",
" playlistlist: %s",
" playlistlist: %s"
])
u1 (prettyHex u2)
(length plls) (indent 4 (map (ppPlayListList t) plls))
(length sgs) (concatMap (ppSubGame t) sgs)
(prettyHex u3)
(length pll2s) (indent 4 (map (ppPlayListList t) pll2s))
(ppOidList oidl) (show gidl)
(ppPlayListList t pll1) (ppPlayListList t pll2)
ppGame t (UnknownGame typ u1 c u2 plls sgs u3 pll2s) =
printf (unlines [" type: %d",
" u1: %d",
" c: %d",
" u2: %s",
" playlistlists: (%d)", "%s",
" subgames: (%d)", "%s",
" u3: %s",
" playlistlists: (%d)","%s"])
typ u1 c (prettyHex u2)
(length plls) (indent 4 (map (ppPlayListList t) plls))
(length sgs) (concatMap (ppSubGame t) sgs)
(prettyHex u3)
(length pll2s) (indent 4 (map (ppPlayListList t) pll2s))
ppGame t Game253 =
printf (unlines [" type: 253"
])
ppGame t _ = "TODO"
ppSubGame :: Transscript -> SubGame -> String
ppSubGame t (SubGame u oids1 oids2 oids3 plls) = printf (unlines
[ " Subgame:"
, " u: %s"
, " oids1: %s"
, " oids2: %s"
, " oids3: %s"
, " playlistlists: (%d)" , "%s"
])
(prettyHex u)
(ppOidList oids1) (ppOidList oids2) (ppOidList oids3)
(length plls) (indent 8 (map (ppPlayListList t) plls))
indent n = intercalate "\n" . map (replicate n ' ' ++)
checkLine :: Int -> Line ResReg -> [String]
checkLine n_audio l@(Line _ _ _ xs)
| any (>= fromIntegral n_audio) xs
= return $ "Invalid audio index in line " ++ ppLine M.empty l
checkLine n_audio _ = []
prettyHex :: B.ByteString -> String
prettyHex = intercalate " " . map (printf "%02X") . B.unpack
transcribe :: Transscript -> Word16 -> String
transcribe t idx = fromMaybe (show idx) (M.lookup idx t)
ppDesc :: [String] -> String
ppDesc = intercalate "/"