diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2013 Joel Taylor + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haxparse.cabal b/haxparse.cabal new file mode 100644 --- /dev/null +++ b/haxparse.cabal @@ -0,0 +1,67 @@ +-- Initial haxparse.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: haxparse +version: 0.1.0.0 +synopsis: Readable HaxBall replays +description: Provides an interface for parsing HaxBall replays. +homepage: https://github.com/joelteon/haxparse +license: MIT +license-file: LICENSE +author: Joel Taylor +maintainer: me@joelt.io +category: Data +build-type: Simple +cabal-version: >=1.8 + +source-repository head + type: git + location: https://github.com/joelteon/haxparse.git + +library + exposed-modules: HaxParse.AST + HaxParse.AST.TH + HaxParse.Parser + build-depends: base == 4.6.*, + binary == 0.7.*, + bytestring == 0.10.*, + containers == 0.5.*, + data-binary-ieee754 == 0.4.*, + data-default == 0.5.*, + lens == 3.9.*, + optparse-applicative == 0.5.*, + mtl == 2.1.*, + parsec == 3.1.*, + split == 0.2.*, + template-haskell == 2.8.*, + transformers == 0.3.*, + utf8-string == 0.3.*, + zlib == 0.5.* + hs-source-dirs: src + extensions: FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell + +executable haxparse + main-is: Main.hs + other-modules: HaxParse.AST.TH + HaxParse.AST + HaxParse.Options + HaxParse.Output.Plain + HaxParse.Output + HaxParse.Parser + hs-source-dirs: src + build-depends: base == 4.6.*, + binary == 0.7.*, + bytestring == 0.10.*, + containers == 0.5.*, + data-binary-ieee754 == 0.4.*, + data-default == 0.5.*, + lens == 3.9.*, + optparse-applicative == 0.5.*, + mtl == 2.1.*, + parsec == 3.1.*, + split == 0.2.*, + template-haskell == 2.8.*, + transformers == 0.3.*, + utf8-string == 0.3.*, + zlib == 0.5.* + extensions: FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell diff --git a/src/HaxParse/AST.hs b/src/HaxParse/AST.hs new file mode 100644 --- /dev/null +++ b/src/HaxParse/AST.hs @@ -0,0 +1,98 @@ +module HaxParse.AST where + +import Data.ByteString.Lazy +import Data.IntMap +import Data.Word +import HaxParse.AST.TH + +data Move = Nop | Move [Direction] | Kick | MoveKick [Direction] deriving Show + +data Direction = Up | Left | Down | Right deriving Show + +data Action = Action { actPlayerId :: Key + , actFrameCount :: Word32 + , actEvent :: Event + } deriving Show + +data Side = Red | Blue | Spec deriving Show + +data Event = NewPlayer { npId :: Key + , npName :: ByteString + , npAdmin :: Bool + , npCountry :: ByteString + } + | Departure { dId :: Word32 + , kicked :: Bool + , banned :: Bool + , reason :: Maybe ByteString + } + | ChangeAvatar ByteString + | Chat ByteString + | StartMatch + | StopMatch + | TeamChange Word32 Side + | DiscMove Move + | PingBroadcast [(Word32, Word8)] + | TimeUpdate deriving (Show) + +makeIsFns ''Event + +data Stadium = Classic | Easy | Small | Big + | Rounded | Hockey | BigHockey | BigEasy + | BigRounded | Huge | Custom + deriving (Bounded, Eq, Enum, Ord, Show) + +data Color = Color String deriving Show + +data Mask = Mask [String] deriving Show + +data Disc = Disc { discId :: Word32 + , pos :: (Double, Double) + , speed :: (Double, Double) + , radius :: Double + , bCoefficient :: Double + , invMass :: Double + , damping :: Double + , color :: Color + , mask :: Mask + , group :: Mask + } deriving (Show) + +data Room = Room { roomName :: ByteString + , locked :: Bool + , scoreLimit :: Word8 + , timeLimit :: Word8 + , rules :: Word32 + , kickoffTaken :: Bool + , kickoffSide :: Side + , ballCoords :: (Double, Double) + , redScore :: Word32 + , blueScore :: Word32 + , timer :: Double + , pauseTimer :: Word8 + , stadium :: Stadium + } deriving (Show) + +data Player = Player { name :: ByteString + , initial :: Bool + , admin :: Bool + , team :: Side + , number :: Word8 + , avatar :: ByteString + , input :: Word32 + , autoKick :: Bool + , desync :: Bool + , country :: ByteString + , handicap :: Word16 + , pDiscId :: Word32 + } deriving (Show) + +data Replay = Replay { version :: Word32 + , frameCount :: Word32 + , firstFrame :: Word32 + , room :: Room + , inProgress :: Bool + , discs :: [Disc] + , players :: IntMap Player + , events :: [Action] + } deriving Show diff --git a/src/HaxParse/AST/TH.hs b/src/HaxParse/AST/TH.hs new file mode 100644 --- /dev/null +++ b/src/HaxParse/AST/TH.hs @@ -0,0 +1,18 @@ +module HaxParse.AST.TH where + +import Language.Haskell.TH.Syntax + +makeIsFns :: Name -> Q [Dec] +makeIsFns name = do inf <- reify name + case inf of TyConI (DataD _ _ _ recs _) -> fmap concat $ mapM makeIsFn recs + x -> error $ "Expected a datatype, got " ++ show x + +makeIsFn :: Con -> Q [Dec] +makeIsFn (RecC con _) = do s <- sig + return [ SigD (mkName $ "is" ++ nameBase con) s + , FunD (mkName $ "is" ++ nameBase con) [matchClause, noMatchClause] ] + where sig = [t|$(return . ConT $ mkName "Event") -> Bool|] + matchClause = Clause [RecP con []] (NormalB (ConE $ mkName "True")) [] + noMatchClause = Clause [WildP] (NormalB (ConE $ mkName "False")) [] +makeIsFn (NormalC con _) = makeIsFn (RecC con []) +makeIsFn x = error $ "Unhandled variant " ++ show x diff --git a/src/HaxParse/Options.hs b/src/HaxParse/Options.hs new file mode 100644 --- /dev/null +++ b/src/HaxParse/Options.hs @@ -0,0 +1,103 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HaxParse.Options ( + OutputType(..), + Opts(..), + TimeFormat(..), + fullOpts +) where + +import Data.Char +import Data.List.Split +import HaxParse.AST hiding (Left, Right) +import Options.Applicative + +data OutputType = Plain | JSON deriving Show + +data TimeFormat = Frame | Second | Both deriving Show + +type EventFilter = Action -> Bool + +instance Show EventFilter where show _ = "(filter)" + +data Opts = Opts { outputType :: OutputType + , showRoom :: Bool + , showDiscs :: Bool + , showPlayers :: Bool + , showEvents :: Bool + , timeFormat :: TimeFormat + , file :: FilePath + , eventTypes :: [EventFilter] + } deriving Show + +outputTypeReader :: String -> Either ParseError OutputType +outputTypeReader s + | map toLower s == "json" = Right JSON + | map toLower s == "plain" = Right Plain + | otherwise = Left . ErrorMsg $ "unknown output type " ++ s + +eventTypeReader :: String -> Either ParseError [EventFilter] +eventTypeReader evs = sequence . map (fmap (. actEvent) . eventTypeReaderSingle . trim) $ splitOn "," evs + where trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +eventTypeReaderSingle :: String -> Either ParseError (Event -> Bool) +eventTypeReaderSingle s + | map toLower s `elem` ["new-player", "np"] = Right isNewPlayer + | map toLower s `elem` ["departure", "d"] = Right isDeparture + | map toLower s `elem` ["change-avatar", "ca"] = Right isChangeAvatar + | map toLower s `elem` ["chat", "c"] = Right isChat + | map toLower s `elem` ["start-match", "start"] = Right isStartMatch + | map toLower s `elem` ["stop-match", "stop"] = Right isStopMatch + | map toLower s `elem` ["team-change", "tc"] = Right isTeamChange + | map toLower s `elem` ["disc-move", "m"] = Right isDiscMove + | map toLower s `elem` ["ping-broadcast", "p"] = Right isPingBroadcast + | map toLower s `elem` ["time-update", "t"] = Right isTimeUpdate + | otherwise = Left . ErrorMsg $ "unknown event type " ++ s + +timeFormatReader :: String -> Either ParseError TimeFormat +timeFormatReader x + | map toLower x == "frame" = Right Frame + | map toLower x == "second" = Right Second + | map toLower x == "both" = Right Both + | otherwise = Left . ErrorMsg $ "unknown time format " ++ x + +opts :: Parser Opts +opts = Opts <$> nullOption ( long "output-type" + <> short 'o' + <> metavar "TYPE" + <> help "Set output type: one of plain [default], json" + <> reader outputTypeReader + <> value Plain ) + <*> switch ( long "show-room" + <> short 'r' + <> help "Dump room information" + <> value False ) + <*> switch ( long "show-discs" + <> short 'd' + <> help "Dump disc information" + <> value False ) + <*> switch ( long "show-players" + <> short 'p' + <> help "Dump player information" + <> value False ) + <*> switch ( long "show-events" + <> short 'e' + <> help "Dump event information" + <> value False ) + <*> nullOption ( long "time-format" + <> short 't' + <> metavar "FORMAT" + <> help "Change timestamp format: frame, second, or both" + <> reader timeFormatReader + <> value Frame ) + <*> argument str (metavar "FILE") + <*> nullOption ( long "event-types" + <> short 'f' + <> metavar "TYPE" + <> help "Filter events by type: new-player (np), departure (d), change-avatar (ca), chat (c), start-match (start), stop-match (stop), team-change (tc), disc-move (m), ping-broadcast (p), time-update (t). This option implies --show-events." + <> reader eventTypeReader + <> value [] ) + +fullOpts :: ParserInfo Opts +fullOpts = info (helper <*> opts) + (fullDesc <> progDesc "Parse .hbr files.") diff --git a/src/HaxParse/Output.hs b/src/HaxParse/Output.hs new file mode 100644 --- /dev/null +++ b/src/HaxParse/Output.hs @@ -0,0 +1,11 @@ +module HaxParse.Output ( + outputWith +) where + +import HaxParse.AST +import qualified HaxParse.Output.Plain as Plain +import HaxParse.Options + +outputWith :: Opts -> Replay -> IO () +outputWith opts x = case outputType opts of JSON -> error "no JSON renderer yet" + _ -> Plain.render opts x diff --git a/src/HaxParse/Output/Plain.hs b/src/HaxParse/Output/Plain.hs new file mode 100644 --- /dev/null +++ b/src/HaxParse/Output/Plain.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module HaxParse.Output.Plain ( + render +) where + +import Control.Monad.Reader +import Data.ByteString.Lazy.UTF8 (toString) +import qualified Data.IntMap as I +import HaxParse.AST +import HaxParse.Options hiding (showRoom) +import qualified HaxParse.Options as O +import Prelude hiding (Left, Right) +import System.IO +import Text.Printf + +type RenderState = ReaderT (Opts, I.IntMap Player) IO + +render :: Opts -> Replay -> IO () +render o re = do + hSetEncoding stdout utf8 + printf "HBRP version %d.\n" (version re) + let fullSec = fromIntegral (frameCount re) / 60 :: Double + minutes = floor (fullSec / 60) :: Integer + seconds = fullSec - fromIntegral (minutes * 60) + printf "Length: %d frames (%d:%.3f).\n" (frameCount re) minutes seconds + printf "First frame: %d.\n" (firstFrame re) + when (O.showRoom o) $ showRoom $ room re + printf "The game is %sin progress.\n" $ if inProgress re then "" :: String + else "not " + when (showDiscs o) $ if null $ discs re + then putStrLn "Discs: none." + else putStrLn "Discs:" >> mapM_ showDisc (discs re) + when (showPlayers o) $ do putStrLn "Players:" + mapM_ showPlayer . I.toList $ players re + when (showEvents o) $ do putStrLn "Events:" + let filteredEvents = if null (eventTypes o) + then events re + else filter (\ev -> any ($ ev) (eventTypes o)) (events re) + forM_ filteredEvents $ \f -> runReaderT (showAction f) (o, players re) + +showRoom :: Room -> IO () +showRoom r = do + printf "Room name: %s.\n" (toString $ roomName r) + printf "The room is %slocked.\n" $ if locked r then "" :: String else "not " + printf "Score limit: %d.\nTime limit: %d min.\n" (scoreLimit r) (timeLimit r) + printf "Rules? %d.\n" (rules r) + printf "The kickoff has %sbeen taken%s.\n" + (if kickoffTaken r then "" :: String else "not ") + (if kickoffTaken r then " by " ++ show (kickoffSide r) else "") + uncurry (printf "The ball is at (%.3f,%.3f).\n") (ballCoords r) + printf "Score: Red %d - %d Blue.\n" (redScore r) (blueScore r) + printf "Current timer: %.3f%s.\n" + (timer r) + (if pauseTimer r > 0 then printf " (unpaused in %d sec)" (pauseTimer r) + else "" :: String) + showStadium $ stadium r + +showStadium :: Stadium -> IO () +showStadium s = printf "Current stadium: %s.\n" (show s) + +showDisc :: Disc -> IO () +showDisc = undefined + +showPlayer :: (I.Key, Player) -> IO () +showPlayer (k, p) = do + printf "#%d %s%s\n" k (toString $ name p) (if admin p then " (admin)" :: String else "") + unless (initial p) $ printf " This player joined the room during the replay.\n" + printf " Team: %s\n" (show $ team p) + printf " Number: %d\n" (number p) + printf " Avatar: %s\n" (toString $ avatar p) + printf " Input: %d\n" (input p) + printf " Banned: %s\n" (show $ autoKick p) + printf " Desynced: %s\n" (show $ desync p) + printf " Country: %s\n" (toString $ country p) + printf " Handicap: %d\n" (handicap p) + printf " Disc ID: %s\n" (if pDiscId p + 1 == 0 then "(none)" else show (pDiscId p)) + +showAction :: Action -> RenderState () +showAction (Action p fc ev) = do + (o,ps) <- ask + e <- showEv ev (ps I.! p) + let prelude = case timeFormat o of + Frame -> printf "frame %05d" fc + Second -> printf "(%02d:%06.3f)" minutes seconds + Both -> printf "frame %05d (%02d:%06.3f)" fc minutes seconds + sec :: Double + sec = fromIntegral fc / 60 + minutes :: Integer + minutes = floor (sec / 60) + seconds :: Double + seconds = sec - (fromIntegral minutes * 60) + liftIO $ printf "%s: %s\n" (prelude :: String) e + +showEv :: Event -> Player -> RenderState String +showEv (PingBroadcast ps) _ = return $ printf "ping update: %s" $ show ps +showEv (Chat bs) p = return $ printf "%s: \"%s\"" (toString $ name p) (toString bs) +showEv StartMatch p = return $ printf "%s starts match" (toString $ name p) +showEv (DiscMove ds) p = return $ printf "%s %s" (toString $ name p) (showMoves ds) +showEv (NewPlayer _ n _ c) _ = return $ printf "new player joins: %s (from %s)" (toString n) (toString c) +showEv (ChangeAvatar s) p = return $ printf "%s changes avatar to \"%s\"" (toString $ name p) (toString s) +showEv (Departure d k b r) p = do ps <- asks snd + let n = toString . name $ ps I.! fromIntegral d + if | b -> return $ printf "%s bans %s (%s)" n (toString $ name p) (maybe "no reason" toString r) + | k -> return $ printf "%s kicks %s (%s)" n (toString $ name p) (maybe "no reason" toString r) + | otherwise -> return $ printf "%s leaves" n +showEv StopMatch p = return $ printf "%s stops match" (toString $ name p) +showEv (TeamChange m t) p = do ps <- asks snd + let n = toString . name $ ps I.! fromIntegral m + return $ printf "%s moves %s to %s" (toString $ name p) n (show t) +showEv x _ = error $ show x + +showMoves :: Move -> String +showMoves Kick = "kicks" +showMoves Nop = "stops moving" +showMoves (Move ms) = printf "moves %s" $ join (map showDir ms) +showMoves (MoveKick ms) = printf "moves %s and kicks" $ join (map showDir ms) + +showDir :: Direction -> String +showDir Left = "←" +showDir Up = "↑" +showDir Right = "→" +showDir Down = "↓" diff --git a/src/HaxParse/Parser.hs b/src/HaxParse/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HaxParse/Parser.hs @@ -0,0 +1,309 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module HaxParse.Parser where + +import Codec.Compression.Zlib +import Control.Applicative ((<$>), (<*>), pure) +import Control.Lens hiding (Action) +import Control.Monad +import Data.Binary +import Data.Binary.Get +import Data.Binary.IEEE754 +import Data.Bits +import qualified Data.ByteString.Lazy.Char8 as C +import Data.Char +import Data.Default +import qualified Data.IntMap as I +import Data.Monoid +import HaxParse.AST +import Numeric +import Prelude hiding (Left, Right) +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.Error +import Text.Parsec.Prim + +data ParserState = ParserState { _frame :: Word32 + , _curDiscId :: Word32 + , _playerList :: I.IntMap Player + } + +instance Default ParserState where def = ParserState 0 0 mempty + +makeLenses ''ParserState + +type Parser = Parsec C.ByteString ParserState + +instance (Monad m) => Stream C.ByteString m Char where + uncons = return . C.uncons + +parseFromFile :: Parser a -> FilePath -> IO (Either ParseError a) +parseFromFile p fname = do inp <- C.readFile fname + return (runP p def fname inp) + +parseFile :: FilePath -> IO (Either ParseError Replay) +parseFile m = parseFromFile haxParser m + +haxParser :: Parser Replay +haxParser = do vers <- int32 + header <- count 4 anyChar + when (header /= "HBRP") . fail $ "Did not find correct HBR header. Expected HBRP, found " ++ show header + framecount <- int32 + setInput . decompress =<< getInput + firstframe <- int32 + r <- room_ + prog <- bool + d <- if prog then discs_ else pure [] + players_ + count 14 $ char '\NUL' + ev <- many event + plist <- fmap (^. playerList) getState + return Replay { version = vers + , frameCount = framecount + , firstFrame = firstframe + , room = r + , inProgress = prog + , discs = d + , players = plist + , events = ev + } + +room_ :: Parser Room +room_ = do roomname <- str + l <- bool + scorelimit <- int8 + timelimit <- int8 + r <- int32 + kotaken <- bool + koside <- side + ballx <- double + bally <- double + redscore <- int32 + bluescore <- int32 + time <- double + pausetimer <- int8 + st <- stadium_ + return Room { roomName = roomname + , locked = l + , scoreLimit = scorelimit + , timeLimit = timelimit + , rules = r + , kickoffTaken = kotaken + , kickoffSide = koside + , ballCoords = (ballx, bally) + , redScore = redscore + , blueScore = bluescore + , timer = time + , pauseTimer = pausetimer + , stadium = st + } + + +int64 :: Parser Word64 +int64 = do s <- count 8 anyChar + return $ runGet getWord64be $ C.pack s + +double :: Parser Double +double = do s <- count 8 anyChar + return $ runGet getFloat64be $ C.pack s + +int32 :: Parser Word32 +int32 = do s <- count 4 anyChar + return $ runGet getWord32be $ C.pack s + +int16 :: Parser Word16 +int16 = do s <- count 2 anyChar + return $ runGet getWord16be $ C.pack s + +int8 :: Parser Word8 +int8 = fromIntegral . ord <$> anyChar + +str :: Parser C.ByteString +str = do len <- int16 + C.pack <$> count (fromIntegral len) anyChar + +bool :: Parser Bool +bool = do m <- ord <$> anyChar + case m of 0 -> return False + 1 -> return True + x -> fail $ "Unexpected value for boolean: " ++ show x + +side :: Parser Side +side = do s <- int8 + case s of 1 -> return Red + 2 -> return Blue + _ -> return Spec + +stadium_ :: Parser Stadium +stadium_ = do st <- int8 + if st < 255 then return $ [minBound..maxBound] !! fromIntegral st + else fail $ "Custom stadiums not handled yet!" + +discs_ :: Parser [Disc] +discs_ = do s <- int32 + count (fromIntegral s) disc + +disc :: Parser Disc +disc = do discid <- view curDiscId <$> getState + modifyState (curDiscId +~ 1) + posx <- double + posy <- double + speedx <- double + speedy <- double + r <- double + bco <- double + im <- double + damp <- double + col <- Color . flip showHex "" <$> int32 + m <- mask_ + g <- mask_ + return Disc { discId = discid + , pos = (posx, posy) + , speed = (speedx, speedy) + , radius = r + , bCoefficient = bco + , invMass = im + , damping = damp + , color = col + , mask = m + , group = g + } + +mask_ :: Parser Mask +mask_ = do start <- int32 + if start + 1 == 0 then pure $ Mask ["all"] + else return . Mask $ go start [] + where go 0 ms = ms + go m xs | m .&. 32 /= 0 = go (m .&. (complement 32)) ("wall":xs) + | m .&. 16 /= 0 = go (m .&. (complement 16)) ("blueKO":xs) + | m .&. 8 /= 0 = go (m .&. (complement 8)) ("redKO":xs) + | m .&. 4 /= 0 = go (m .&. (complement 4)) ("blue":xs) + | m .&. 2 /= 0 = go (m .&. (complement 2)) ("red":xs) + | m .&. 1 /= 0 = go (m .&. (complement 1)) ("ball":xs) + | otherwise = fail $ "Heh??? " ++ show m + +players_ :: Parser () +players_ = do p <- int32 + void $ count (fromIntegral p) player + +player :: Parser () +player = do pid <- fromIntegral <$> int32 + uname <- str + a <- bool + t <- side + n <- int8 + av <- str + inp <- int32 + ak <- bool + d <- bool + ct <- str + h <- int16 + did <- int32 + let p = Player { name = uname + , initial = True + , admin = a + , team = t + , number = n + , avatar = av + , input = inp + , autoKick = ak + , desync = d + , country = ct + , handicap = h + , pDiscId = did + } + modifyState (playerList %~ I.insert pid p) + +event :: Parser Action +event = do timeUpdate <- bool "is it a time update?" + when timeUpdate $ do frames <- int32 + modifyState (frame +~ frames) + fc <- view frame <$> getState + pid <- fromIntegral <$> int32 + evty <- int8 + result <- case evty of 0 -> newPlayer + 1 -> departure + 2 -> Chat <$> str + 4 -> pure StartMatch + 5 -> pure StopMatch + 6 -> discMove + 7 -> TeamChange <$> int32 <*> side + 10 -> ChangeAvatar <$> str + 15 -> pingBroadcast + x -> fail $ "heh non-exhaustive match for " ++ show x + return $ Action pid fc result + +departure :: Parser Event +departure = do p <- int16 + k <- bool + r <- if k then Just <$> str else pure Nothing + b <- bool + return Departure { dId = fromIntegral p + , kicked = k + , banned = b + , reason = r } + +newPlayer :: Parser Event +newPlayer = do i <- fromIntegral <$> int32 + n <- str + ai <- bool + ct <- str + let p = Player { name = n + , initial = False + , admin = ai + , team = Spec + , number = 0 + , avatar = "" + , input = 0 + , autoKick = False + , desync = False + , country = ct + , handicap = 0 + , pDiscId = -1 + } + modifyState (playerList %~ I.insert i p) + return $ NewPlayer { npId = i + , npName = n + , npAdmin = ai + , npCountry = ct + } + +pingBroadcast :: Parser Event +pingBroadcast = do p <- int8 + PingBroadcast . zip [0..] . map (*4) <$> count (fromIntegral p) int8 + +discMove :: Parser Event +discMove = do m <- int8 + return . DiscMove $ [ Nop + , Move [Up] + , Move [Down] + , Move [Up, Down] + , Move [Left] + , Move [Up, Left] + , Move [Down, Left] + , Move [Up, Down, Left] + , Move [Right] + , Move [Up, Right] + , Move [Down, Right] + , Move [Up, Down, Right] + , Move [Left, Right] + , Move [Up, Left, Right] + , Move [Down, Left, Right] + , Move [Up, Down, Left, Right] + , Kick + , MoveKick [Up] + , MoveKick [Down] + , MoveKick [Up, Down] + , MoveKick [Left] + , MoveKick [Up, Left] + , MoveKick [Down, Left] + , MoveKick [Up, Down, Left] + , MoveKick [Right] + , MoveKick [Up, Right] + , MoveKick [Down, Right] + , MoveKick [Up, Down, Right] + , MoveKick [Left, Right] + , MoveKick [Up, Left, Right] + , MoveKick [Down, Left, Right] + , MoveKick [Up, Down, Left, Right]] !! fromIntegral m diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,15 @@ +import qualified Data.ByteString.Lazy as LB +import HaxParse.Parser +import HaxParse.Options +import HaxParse.Output +import Options.Applicative +import System.Exit +import System.IO + +main :: IO () +main = do opts <- execParser fullOpts + res <- parseFile $ file opts + let newOpts = if null (eventTypes opts) then opts else opts { showEvents = True } + case res of Left m -> do hPutStrLn stderr $ "Parsing failed: " ++ show m + exitFailure + Right s -> outputWith newOpts s