diff --git a/library/Octane/Main.hs b/library/Octane/Main.hs --- a/library/Octane/Main.hs +++ b/library/Octane/Main.hs @@ -3,7 +3,7 @@ import qualified Control.DeepSeq as DeepSeq import qualified Control.Monad as Monad import qualified Control.Newtype as Newtype -import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.Aeson as Aeson import qualified Data.Binary as Binary import qualified Data.Binary.Get as Binary import qualified Data.ByteString as BS @@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Function ((&)) import qualified Data.Map as Map +import qualified Data.Maybe as Maybe import qualified Data.Text as Text import qualified Octane.Parser as Parser import qualified Octane.Type as Type @@ -28,33 +29,48 @@ -> IO () debug (file,contents,result) = case result of - Left (offset,message) -> - IO.hPutStrLn - IO.stderr - (file ++ " @ byte " ++ show offset ++ " - " ++ message) + Left (offset,message) -> error + ( file + ++ " @ byte " + ++ show offset + ++ ": " + ++ message + ) Right replay -> do - DeepSeq.deepseq replay (IO.hPutStrLn IO.stderr "evaluated replay") let inputSize = contents & BS.length & fromIntegral - let outputSize = replay & Binary.encode & BSL.length - Monad.when (inputSize /= outputSize) $ - do IO.hPutStrLn - IO.stderr - ("input size (" ++ - show inputSize ++ - ") not equal to output size (" ++ - show outputSize ++ ")!") - let config = - Aeson.defConfig - { Aeson.confCompare = compare - } - putStrLn "{\"meta\":\n" - replay & Aeson.encodePretty' config & BSL8.putStrLn + let outputSize = replay + & Binary.encode + & BSL.length + & DeepSeq.deepseq replay + Monad.when (inputSize /= outputSize) (IO.hPutStrLn IO.stderr + ( "input size " + ++ show inputSize + ++ " not equal to output size " + ++ show outputSize + )) - putStrLn ",\"frames\":\n" let frames = Parser.parseFrames replay - DeepSeq.deepseq frames (IO.hPutStrLn IO.stderr "evaluated frames") - let expectedFrames = replay & Type.replayProperties & Newtype.unpack & Map.lookup ("NumFrames" & Text.pack & Newtype.pack) - let actualFrames = frames & length & fromIntegral & Newtype.pack & Type.IntProperty (Newtype.pack 4) & Just - Monad.when (expectedFrames /= actualFrames) $ IO.hPutStrLn IO.stderr ("expected " ++ show expectedFrames ++ " frames but found " ++ show actualFrames ++ " frames!") - frames & Aeson.encodePretty' config & BSL8.putStrLn + let expectedFrames = replay + & Type.replayProperties + & Newtype.unpack + & Map.lookup ("NumFrames" & Text.pack & Newtype.pack) + & Maybe.fromMaybe (Type.IntProperty (Newtype.pack 4) (Newtype.pack 0)) + let actualFrames = frames + & length + & fromIntegral + & Newtype.pack + & Type.IntProperty (Newtype.pack 4) + & DeepSeq.deepseq frames + Monad.when (expectedFrames /= actualFrames) (error + ( "expected " + ++ show expectedFrames + ++ " frames but found " + ++ show actualFrames + ++ " frames" + )) + + putStr "{\"meta\":" + replay & Aeson.encode & BSL8.putStrLn + putStr ",\"frames\":" + frames & Aeson.encode & BSL8.putStrLn putStrLn "}" diff --git a/library/Octane/Parser.hs b/library/Octane/Parser.hs --- a/library/Octane/Parser.hs +++ b/library/Octane/Parser.hs @@ -14,44 +14,59 @@ import qualified Data.Bits as Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.Int as Int import qualified Data.IntMap.Strict as IntMap -import qualified Data.List as List import qualified Data.Map.Strict as Map -import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Data.Word as Word -import qualified Debug.Trace as Trace import qualified GHC.Generics as Generics +import qualified Octane.Parser.ClassPropertyMap as CPM import qualified Octane.Type as Type -import qualified Text.Regex as Regex +import qualified Text.Printf as Printf parseFrames :: Type.Replay -> [Frame] parseFrames replay = let - get = replay & extractContext & getFrames & Bits.runBitGet + numFrames = replay + & Type.replayProperties + & Newtype.unpack + & Map.lookup ("NumFrames" & Text.pack & Newtype.pack) + & (\ property -> case property of + Just (Type.IntProperty _ x) -> x & Newtype.unpack & fromIntegral + _ -> 0) + get = replay & extractContext & getFrames numFrames & Bits.runBitGet stream = replay & Type.replayStream & Newtype.unpack & BSL.fromStrict (_context, frames) = Binary.runGet get stream in frames -getFrames :: Context -> Bits.BitGet (Context, [Frame]) -getFrames context = do - maybeFrame <- getMaybeFrame context - case maybeFrame of - Nothing -> return (context, []) - Just (newContext, frame) -> do - (newerContext, frames) <- getFrames newContext - return (newerContext, (frame : frames)) +getFrames :: Int -> Context -> Bits.BitGet (Context, [Frame]) +getFrames numFrames context = do + if numFrames < 1 + then return (context, []) + else do + isEmpty <- Bits.isEmpty + if isEmpty + then return (context, []) + else do + maybeFrame <- getMaybeFrame context + case maybeFrame of + Nothing -> return (context, []) + Just (newContext, frame) -> do + (newerContext, frames) <- getFrames (numFrames - 1) newContext + return (newerContext, (frame : frames)) getMaybeFrame :: Context -> Bits.BitGet (Maybe (Context, Frame)) getMaybeFrame context = do time <- getFloat32 delta <- getFloat32 if time == 0 && delta == 0 - then return Nothing - else do - (newContext, frame) <- getFrame context time delta - return (Just (newContext, frame)) + then return Nothing + else if time < 0.001 || delta < 0.001 + then error ("parsing previous frame probably failed. time: " ++ show time ++ ", delta: " ++ show delta) + else do + (newContext, frame) <- getFrame context time delta + return (Just (newContext, frame)) getFrame :: Context -> Time -> Delta -> Bits.BitGet (Context, Frame) getFrame context time delta = do @@ -84,7 +99,7 @@ getReplication :: Context -> Bits.BitGet (Context, Replication) getReplication context = do - actorId <- getInt maxChannels + actorId <- getActorId isOpen <- Bits.getBool let go = if isOpen @@ -108,11 +123,14 @@ -> Bits.BitGet (Context, Replication) getNewReplication context actorId = do unknownFlag <- Bits.getBool + if unknownFlag + then error "the unknown flag in a new replication is true! what does it mean?" + else return () objectId <- getInt32 let objectName = case context & contextObjectMap & IntMap.lookup objectId of Nothing -> error ("could not find object name for id " ++ show objectId) Just x -> x - let (classId,className) = case getClass context objectId of + let (classId,className) = case CPM.getClass (contextObjectMap context) CPM.archetypeMap (contextClassMap context) objectId of Nothing -> error ("could not find class for object id " ++ show objectId) Just x -> x classInit <- getClassInit className @@ -191,20 +209,15 @@ getProp context thing = do let classId = thing & thingClassId let props = case context & contextClassPropertyMap & IntMap.lookup classId of - Nothing -> - Trace.trace (context & contextObjectMap & IntMap.toAscList & map (\ (k, v) -> "\t" ++ show k ++ "\t=> " ++ show v) & ("OBJECTS:" :) & unlines) $ - Trace.trace (context & contextArchetypeMap & Map.toList & map (\ (k, v) -> "\t" ++ show k ++ "\t=> " ++ show v) & ("ARCHETYPES:" :) & unlines) $ - Trace.trace (context & contextClassMap & Map.toList & map (\ (k, v) -> "\t" ++ show k ++ "\t=> " ++ show v) & ("CLASSES:" :) & unlines) $ - Trace.trace (context & contextClassPropertyMap & IntMap.toAscList & map (\ (k1, v1) -> "\t" ++ show k1 ++ "\t=>\n" ++ (v1 & IntMap.toAscList & map (\ (k2, v2) -> "\t\t" ++ show k2 ++ "\t=>" ++ show v2) & unlines)) & ("CLASS PROPERTIES:" :) & unlines) $ - error ("could not find property map for class id " ++ show classId) + Nothing -> error ("could not find property map for class id " ++ show classId) Just x -> x - let maxId = props & IntMap.keys & maximum + let maxId = props & IntMap.keys & (0 :) & maximum pid <- getInt maxId - let propName = case props & IntMap.lookup pid of + let name = case props & IntMap.lookup pid of Nothing -> error ("could not find property name for property id " ++ show pid) Just x -> x - value <- getPropValue propName - return (Prop { propId = pid, propValue = value }) + value <- getPropValue name + return (Prop { propName = name, propValue = value }) getPropValue :: Text.Text -> Bits.BitGet PropValue getPropValue name = case Text.unpack name of @@ -235,9 +248,6 @@ _ | Set.member name propsWithByte -> do int <- getInt8 return (PByte int) - _ | Set.member name propsWithUniqueId -> do - (systemId, remoteId, localId) <- getUniqueId - return (PUniqueId systemId remoteId localId) _ | Set.member name propsWithCamSettings -> do fov <- getFloat32 height <- getFloat32 @@ -252,11 +262,25 @@ _ | Set.member name propsWithFloat -> do float <- getFloat32 return (PFloat float) + "Engine.PlayerReplicationInfo:UniqueId" -> do + (systemId, remoteId, localId) <- getUniqueId + return (PUniqueId systemId remoteId localId) + "TAGame.PRI_TA:PartyLeader" -> do + systemId <- getSystemId + if systemId == 0 + then do + let remoteId = SplitscreenId Nothing + let localId = Nothing + return (PUniqueId systemId remoteId localId) + else do + remoteId <- getRemoteId systemId + localId <- getLocalId + return (PUniqueId systemId remoteId localId) "ProjectX.GRI_X:Reservations" -> do -- I think this is the connection order. The first player to connect - -- gets number 0, and it goes up from there. The maximum is 8, which + -- gets number 0, and it goes up from there. The maximum is 7, which -- would be a full 4x4 game. - number <- getInt 8 + number <- getInt7 (systemId, remoteId, localId) <- getUniqueId playerName <- if systemId == 0 then return Nothing else do string <- getString @@ -317,13 +341,26 @@ return (PMusicStinger flag cue trigger) "TAGame.Car_TA:ReplicatedDemolish" -> do hasAtk <- Bits.getBool - atk <- if hasAtk then fmap Just getInt32 else return Nothing + atk <- getInt32 hasVic <- Bits.getBool - vic <- if hasVic then fmap Just getInt32 else return Nothing + vic <- getInt32 vec1 <- getVector vec2 <- getVector - return (PDemolish hasAtk atk hasVic vic vec1 vec2) - -- TODO: Parse other prop types. + return (PDemolish hasAtk (Just atk) hasVic (Just vic) vec1 vec2) + "TAGame.GameEvent_SoccarPrivate_TA:MatchSettings" -> do + mutators <- getString + joinableBy <- getInt32 + maxPlayers <- getInt32 + gameName <- getString + password <- getString + flag <- Bits.getBool + return (PPrivateMatchSettings mutators joinableBy maxPlayers gameName password flag) + "Engine.Actor:RelativeRotation" -> do + vector <- getFloatVector + return (PRelativeRotation vector) + "TAGame.GameEvent_TA:GameMode" -> do + mode <- Bits.getWord8 2 + return (PGameMode mode) _ -> fail ("don't know how to read property " ++ show name) getFloat32 :: Bits.BitGet Float @@ -331,7 +368,6 @@ bytes <- Bits.getByteString 4 bytes & byteStringToFloat & return --- TODO: This has a lot of overlap with PCString. getString :: Bits.BitGet Text.Text getString = do rawSize <- getInt32 @@ -347,20 +383,50 @@ getUniqueId :: Bits.BitGet (SystemId, RemoteId, LocalId) getUniqueId = do + systemId <- getSystemId + remoteId <- getRemoteId systemId + localId <- getLocalId + return (systemId, remoteId, localId) + +getSystemId :: Bits.BitGet SystemId +getSystemId = do byte <- Bits.getWord8 8 - let systemId = Type.reverseBits byte - case systemId of - 0 -> error "don't know how to parse splitscreen ids" - 1 -> do - remoteId <- Bits.getByteString 8 - localId <- Bits.getWord8 8 - return (systemId, SteamId remoteId, localId) - 2 -> do - remoteId <- Bits.getByteString 32 - localId <- Bits.getWord8 8 - return (systemId, PlayStationId remoteId, localId) - _ -> error ("unknown system id " ++ show systemId) + byte & Type.reverseBits & return +getRemoteId :: SystemId -> Bits.BitGet RemoteId +getRemoteId systemId = case systemId of + 0 -> do + remoteId <- Bits.getByteString 3 + if BS.all (\ byte -> byte == 0) remoteId + then 0 & Just & SplitscreenId & return + else error ("unexpected splitscreen id " ++ show remoteId) + 1 -> do + bytes <- Bits.getByteString 8 + let remoteId = Binary.runGet + Binary.getWord64le + (bytes & BS.map Type.reverseBits & BSL.fromStrict) + remoteId & SteamId & return + 2 -> do + bytes <- Bits.getByteString 32 + let remoteId = bytes + & BS.map Type.reverseBits + & BS.unpack + & concatMap (\ b -> Printf.printf "%02x" b) + & Text.pack + remoteId & PlayStationId & return + 4 -> do + bytes <- Bits.getByteString 8 + let remoteId = Binary.runGet + Binary.getWord64le + (bytes & BS.map Type.reverseBits & BSL.fromStrict) + remoteId & XboxId & return + _ -> error ("unknown system id " ++ show systemId) + +getLocalId :: Bits.BitGet LocalId +getLocalId = do + localId <- Bits.getWord8 8 + localId & Just & return + propsWithRigidBodyState :: Set.Set Text.Text propsWithRigidBodyState = [ "TAGame.RBActor_TA:ReplicatedRBState" @@ -369,6 +435,7 @@ propsWithFlaggedInt :: Set.Set Text.Text propsWithFlaggedInt = [ "Engine.GameReplicationInfo:GameClass" + , "Engine.Actor:ReplicatedCollisionType" , "Engine.Pawn:PlayerReplicationInfo" , "Engine.PlayerReplicationInfo:Team" , "TAGame.Ball_TA:GameEvent" @@ -381,20 +448,36 @@ , "TAGame.PRI_TA:PersistentCamera" , "TAGame.PRI_TA:ReplicatedGameEvent" , "TAGame.Team_TA:GameEvent" + , "TAGame.Team_TA:LogoData" ] & map Text.pack & Set.fromList propsWithString :: Set.Set Text.Text propsWithString = [ "Engine.GameReplicationInfo:ServerName" , "Engine.PlayerReplicationInfo:PlayerName" + , "Engine.PlayerReplicationInfo:RemoteUserData" + , "TAGame.GRI_TA:NewDedicatedServerIP" + , "TAGame.Team_TA:CustomTeamName" ] & map Text.pack & Set.fromList propsWithBoolean :: Set.Set Text.Text propsWithBoolean = [ "Engine.Actor:bBlockActors" , "Engine.Actor:bCollideActors" + , "Engine.Actor:bHardAttach" , "Engine.Actor:bHidden" + , "Engine.Actor:bProjTarget" + , "Engine.Actor:bTearOff" + , "Engine.GameReplicationInfo:bMatchIsOver" + , "Engine.Pawn:bCanSwatTurn" + , "Engine.Pawn:bRootMotionFromInterpCurve" + , "Engine.Pawn:bSimulateGravity" + , "Engine.PlayerReplicationInfo:bBot" + , "Engine.PlayerReplicationInfo:bIsSpectator" + , "Engine.PlayerReplicationInfo:bOnlySpectator" + , "Engine.PlayerReplicationInfo:bOutOfLives" , "Engine.PlayerReplicationInfo:bReadyToPlay" + , "Engine.PlayerReplicationInfo:bWaitingPlayer" , "ProjectX.GRI_X:bGameStarted" , "TAGame.CameraSettingsActor_TA:bUsingBehindView" , "TAGame.CameraSettingsActor_TA:bUsingSecondaryCamera" @@ -403,9 +486,13 @@ , "TAGame.GameEvent_Soccar_TA:bOverTime" , "TAGame.GameEvent_TA:bHasLeaveMatchPenalty" , "TAGame.GameEvent_Team_TA:bDisableMutingOtherTeam" + , "TAGame.PRI_TA:bIsInSplitScreen" + , "TAGame.PRI_TA:bMatchMVP" , "TAGame.PRI_TA:bOnlineLoadoutSet" + , "TAGame.PRI_TA:bReady" , "TAGame.PRI_TA:bUsingBehindView" , "TAGame.PRI_TA:bUsingSecondaryCamera" + , "TAGame.RBActor_TA:bFrozen" , "TAGame.RBActor_TA:bReplayActor" , "TAGame.Vehicle_TA:bDriving" , "TAGame.Vehicle_TA:bReplicatedHandbrake" @@ -421,6 +508,7 @@ [ "Engine.PlayerReplicationInfo:PlayerID" , "Engine.PlayerReplicationInfo:Score" , "Engine.TeamInfo:Score" + , "ProjectX.GRI_X:ReplicatedGameMutatorIndex" , "ProjectX.GRI_X:ReplicatedGamePlaylist" , "TAGame.CrowdActor_TA:ReplicatedCountDownNumber" , "TAGame.GameEvent_Soccar_TA:RoundNum" @@ -454,12 +542,6 @@ , "TAGame.Vehicle_TA:ReplicatedThrottle" ] & map Text.pack & Set.fromList -propsWithUniqueId :: Set.Set Text.Text -propsWithUniqueId = - [ "Engine.PlayerReplicationInfo:UniqueId" - , "TAGame.PRI_TA:PartyLeader" - ] & map Text.pack & Set.fromList - propsWithCamSettings :: Set.Set Text.Text propsWithCamSettings = [ "TAGame.CameraSettingsActor_TA:ProfileSettings" @@ -474,6 +556,10 @@ propsWithFloat :: Set.Set Text.Text propsWithFloat = [ "Engine.Actor:DrawScale" + , "TAGame.Ball_TA:ReplicatedAddedCarBounceScale" + , "TAGame.Ball_TA:ReplicatedBallMaxLinearSpeedScale" + , "TAGame.Ball_TA:ReplicatedBallScale" + , "TAGame.Ball_TA:ReplicatedWorldBounceScale" , "TAGame.CarComponent_FlipCar_TA:FlipCarTime" , "TAGame.CrowdActor_TA:ModifiedNoise" ] & map Text.pack & Set.fromList @@ -484,24 +570,20 @@ -- is 0, the second is 1, and so on. -- - 0 "Someone" -- - 1 "Someone (1)" -type LocalId = Word.Word8 +type LocalId = Maybe Word.Word8 data RemoteId - = SteamId !BS.ByteString -- TODO: This is an integer. - | PlayStationId !BS.ByteString -- TODO: I think this is a string? + = SteamId !Word.Word64 + | PlayStationId !Text.Text + | SplitscreenId !(Maybe Int) + | XboxId !Word.Word64 deriving (Eq, Generics.Generic, Show) instance DeepSeq.NFData RemoteId - --- TODO: This is a dumb instance. It's only necessary because there's no ToJSON --- instance for ByteString. -instance Aeson.ToJSON RemoteId where - toJSON remoteId = case remoteId of - SteamId bytes -> bytes & show & Aeson.toJSON - PlayStationId bytes -> bytes & show & Aeson.toJSON +instance Aeson.ToJSON RemoteId data Prop = Prop - { propId :: !Int + { propName :: !Text.Text , propValue :: !PropValue } deriving (Eq, Generics.Generic, Show) @@ -529,11 +611,14 @@ | PTeamPaint !Int !Int !Int !Int !Int | PLocation !(Vector Int) | PPickup !Bool !(Maybe Int) !Bool - | PEnum !Word.Word16 -- TODO: This isn't the right data type. + | PEnum !Word.Word16 | PExplosion !Bool !(Maybe Int) !(Vector Int) | PMusicStinger !Bool !Int !Int | PFloat !Float | PDemolish !Bool !(Maybe Int) !Bool !(Maybe Int) !(Vector Int) !(Vector Int) + | PPrivateMatchSettings !Text.Text !Int !Int !Text.Text !Text.Text !Bool + | PRelativeRotation !(Vector Float) + | PGameMode !Word.Word8 deriving (Eq, Generics.Generic, Show) instance DeepSeq.NFData PropValue @@ -600,11 +685,11 @@ instance (DeepSeq.NFData a) => DeepSeq.NFData (Vector a) instance (Aeson.ToJSON a) => Aeson.ToJSON (Vector a) where - toJSON = - Aeson.genericToJSON - Aeson.defaultOptions - { Aeson.fieldLabelModifier = drop 6 - } + toJSON vector = Aeson.toJSON + [ vectorX vector + , vectorY vector + , vectorZ vector + ] data ClassInit = ClassInit { classInitLocation :: !(Maybe (Vector Int)) @@ -616,7 +701,7 @@ toJSON = Aeson.genericToJSON Aeson.defaultOptions - { Aeson.fieldLabelModifier = drop 6 + { Aeson.fieldLabelModifier = drop 9 } -- { class stream id => { property stream id => name } } @@ -625,9 +710,6 @@ -- { stream id => object name } type ObjectMap = IntMap.IntMap Text.Text --- { archetype (object) name => class name } -type ArchetypeMap = Map.Map Text.Text Text.Text - -- { class name => class id } type ClassMap = Map.Map Text.Text Int @@ -635,123 +717,18 @@ { contextObjectMap :: !ObjectMap , contextClassPropertyMap :: !ClassPropertyMap , contextThings :: !(IntMap.IntMap Thing) - , contextArchetypeMap :: !ArchetypeMap , contextClassMap :: !ClassMap } deriving (Show) -buildObjectMap :: Type.Replay -> ObjectMap -buildObjectMap replay = - replay & Type.replayObjects & Newtype.unpack & map Newtype.unpack & - zip [0 ..] & - IntMap.fromAscList - -buildArchetypeMap :: Type.Replay -> ArchetypeMap -buildArchetypeMap replay - = replay - & Type.replayObjects - & Newtype.unpack - & map Newtype.unpack - & map (\ archetype -> let - k = archetype - v = archetypeToClass archetype - in (k, v)) - & Map.fromList - & Map.union specialArchetypes - -specialArchetypes :: ArchetypeMap -specialArchetypes = - [ ("GameInfo_Soccar.GameInfo.GameInfo_Soccar:GameReplicationInfoArchetype", "GRI") - ] & map (\ (k, v) -> (Text.pack k, Text.pack v)) & Map.fromList - -buildClassMap :: Type.Replay -> ClassMap -buildClassMap replay - = replay - & Type.replayObjects - & Newtype.unpack - & map Newtype.unpack - & zip [0 ..] - & filter (\ (_, objectName) -> - not (Text.isInfixOf (Text.pack ":") objectName)) - & map (\ (objectId, objectName) -> let - k = archetypeToClass objectName - v = objectId - in (k, v)) - & reverse - & Map.fromList - -getClass :: Context -> Int -> Maybe (Int, Text.Text) -getClass context objectId = let - objectMap = contextObjectMap context - archetypeMap = contextArchetypeMap context - classMap = contextClassMap context - in case IntMap.lookup objectId objectMap of - Nothing -> Nothing - Just archetypeName -> case Map.lookup archetypeName archetypeMap of - Nothing -> Nothing - Just className -> case Map.lookup className classMap of - Nothing -> Nothing - Just classId -> Just (classId, className) - -archetypeToClass :: Text.Text -> Text.Text -archetypeToClass text - = text - & Text.splitOn (Text.pack ".") - & last - & Text.splitOn (Text.pack ":") - & last - & Text.unpack - & substitute "_?[0-9]+$" "" - & substitute "^Default__" "" - & substitute "_TA$" "" - & substitute "_Default$" "" - & substitute "Archetype$" "" - & Text.pack - -substitute :: String -> String -> String -> String -substitute pattern replacement input = - Regex.subRegex (Regex.mkRegex pattern) input replacement - extractContext :: Type.Replay -> Context extractContext replay = Context - { contextObjectMap = buildObjectMap replay - , contextClassPropertyMap = buildClassPropertyMap replay + { contextObjectMap = CPM.getPropertyMap replay + , contextClassPropertyMap = CPM.getClassPropertyMap replay , contextThings = IntMap.empty - , contextArchetypeMap = buildArchetypeMap replay - , contextClassMap = buildClassMap replay + , contextClassMap = CPM.getActorMap replay } -classesWithLocation :: Set.Set Text.Text -classesWithLocation = - [ "Ball" - , "CameraSettingsActor" - , "Car" - , "CarComponent_Boost" - , "CarComponent_Dodge" - , "CarComponent_DoubleJump" - , "CarComponent_FlipCar" - , "CarComponent_Jump" - , "GRI" - , "GameEvent_Season" - , "GameEvent_Soccar" - , "GameEvent_SoccarPrivate" - , "GameEvent_SoccarSplitscreen" - , "GameReplicationInfo" - , "PRI" - , "Team" - , "Team_Soccar" - ] & map Text.pack & Set.fromList - -classesWithRotation :: Set.Set Text.Text -classesWithRotation = - [ "Ball" - , "Car_Season" - , "Car" - ] & map Text.pack & Set.fromList - -maxVectorValue :: Int -maxVectorValue = 19 - byteStringToFloat :: BS.ByteString -> Float byteStringToFloat bytes = Binary.runGet IEEE754.getFloat32le @@ -759,7 +736,7 @@ getVector :: Bits.BitGet (Vector Int) getVector = do - numBits <- getInt maxVectorValue + numBits <- getNumVectorBits let bias = Bits.shiftL 1 (numBits + 1) let maxBits = numBits + 2 let maxValue = 2 ^ maxBits @@ -832,13 +809,13 @@ getClassInit :: Text.Text -> Bits.BitGet ClassInit getClassInit className = do location <- - if Set.member className classesWithLocation + if Set.member className CPM.classesWithLocation then do vector <- getVector return (Just vector) else return Nothing rotation <- - if Set.member className classesWithRotation + if Set.member className CPM.classesWithRotation then do vector <- getVectorBytewise return (Just vector) @@ -849,11 +826,6 @@ , classInitRotation = rotation } -maxChannels - :: (Integral a) - => a -maxChannels = 1024 - bitSize :: (Integral a) => a -> a @@ -886,51 +858,26 @@ go 0 0 getInt32 :: Bits.BitGet Int -getInt32 = getInt (2 ^ (32 :: Int)) +getInt32 = do + bytes <- Bits.getByteString 4 + let word = Binary.runGet + Binary.getWord32le + (bytes & BSL.fromStrict & BSL.map Type.reverseBits) + word & fromIntegral & (\ x -> x :: Int.Int32) & fromIntegral & return getInt8 :: Bits.BitGet Int -getInt8 = getInt (2 ^ (8 :: Int)) +getInt8 = do + byte <- Bits.getByteString 1 + let word = Binary.runGet + Binary.getWord8 + (byte & BSL.fromStrict & BSL.map Type.reverseBits) + word & fromIntegral & (\ x -> x :: Int.Int8) & fromIntegral & return --- builds a map from property ids in the stream to property names -buildPropertyMap :: Type.Replay -> IntMap.IntMap Text.Text -buildPropertyMap replay - = replay - & Type.replayObjects - & Newtype.unpack - & map Newtype.unpack - & zip [0 ..] - & IntMap.fromDistinctAscList +getActorId :: Bits.BitGet Int +getActorId = getInt 1024 -buildClassPropertyMap :: Type.Replay -> IntMap.IntMap (IntMap.IntMap Text.Text) -buildClassPropertyMap replay = let - propertyMap = buildPropertyMap replay - g x items = case items of - [] -> IntMap.empty - _ -> case dropWhile (\ (_, cacheId, _, _) -> cacheId /= x) items of - [] -> g (x - 1) items - (_, _, parentCacheId, properties) : others -> IntMap.union - properties - (g parentCacheId others) - f x items = case items of - (classId, _cacheId, parentCacheId, properties) : others -> IntMap.insert - classId - (IntMap.union - properties - (g parentCacheId others)) - x - [] -> x - in replay - & Type.replayCacheItems - & Newtype.unpack - & map (\ item -> - ( item & Type.cacheItemClassId & Newtype.unpack & fromIntegral - , item & Type.cacheItemCacheId & Newtype.unpack & fromIntegral & (\ x -> x :: Int) - , item & Type.cacheItemParentCacheId & Newtype.unpack & fromIntegral - , item & Type.cacheItemCacheProperties & Newtype.unpack & map (\ x -> - ( x & Type.cachePropertyStreamId & Newtype.unpack & fromIntegral - , x & Type.cachePropertyObjectId & Newtype.unpack & fromIntegral & flip IntMap.lookup propertyMap & Maybe.fromJust - )) & IntMap.fromList - )) - & reverse - & List.tails - & foldl f IntMap.empty +getNumVectorBits :: Bits.BitGet Int +getNumVectorBits = getInt 19 + +getInt7 :: Bits.BitGet Int +getInt7 = getInt 7 diff --git a/library/Octane/Parser/ClassPropertyMap.hs b/library/Octane/Parser/ClassPropertyMap.hs new file mode 100644 --- /dev/null +++ b/library/Octane/Parser/ClassPropertyMap.hs @@ -0,0 +1,308 @@ +module Octane.Parser.ClassPropertyMap where + +import Data.Function ((&)) +import Debug.Trace + +import qualified Control.Newtype as Newtype +import qualified Data.Char as Char +import qualified Data.IntMap.Strict as IntMap +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Octane.Type as Type + +-- | The class property map is a map from class IDs in the stream to a map from +-- | property IDs in the stream to property names. +getClassPropertyMap :: Type.Replay -> IntMap.IntMap (IntMap.IntMap Text.Text) +getClassPropertyMap replay = let + basicClassPropertyMap = getBasicClassPropertyMap replay + classMap = getClassMap replay + in replay + & getClassIds + & map (\ classId -> let + ownProperties = case IntMap.lookup classId basicClassPropertyMap of + Nothing -> IntMap.empty + Just x -> x + parentProperties = case IntMap.lookup classId classMap of + Nothing -> IntMap.empty + Just parentClassIds -> parentClassIds + & map (\ parentClassId -> + case IntMap.lookup parentClassId basicClassPropertyMap of + Nothing -> IntMap.empty + Just x -> x) + & IntMap.unions + properties = IntMap.union ownProperties parentProperties + in (classId, properties)) + & IntMap.fromList + +-- | The class cache is a list of 3-tuples where the first element is a class +-- | ID, the second is its cache ID, and the third is its parent's cache ID. +getClassCache :: Type.Replay -> [(Int, Int, Int)] +getClassCache replay = replay + & Type.replayCacheItems + & Newtype.unpack + & map (\ x -> + ( x & Type.cacheItemClassId & Newtype.unpack & fromIntegral + , x & Type.cacheItemCacheId & Newtype.unpack & fromIntegral + , x & Type.cacheItemParentCacheId & Newtype.unpack & fromIntegral + )) + +-- | The class IDs in a replay. Comes from the class cache. +getClassIds :: Type.Replay -> [Int] +getClassIds replay = replay + & getClassCache + & map (\ (x, _, _) -> x) + +-- | Gets the parent class ID for the given parent cache ID. This is necessary +-- | because there is not always a class with the given cache ID in the cache. +-- | When that happens, the parent cache ID is decremented and tried again. +getParentClassId :: Int -> [(Int, Int, Int)] -> Maybe Int +getParentClassId parentCacheId xs = + case dropWhile (\ (_, cacheId, _) -> cacheId /= parentCacheId) xs of + [] -> if parentCacheId <= 0 + then Nothing + else getParentClassId (parentCacheId - 1) xs + (parentClassId, _, _) : _ -> Just parentClassId + +-- | The basic class map is a naive mapping from class ID to its parent class +-- | ID. It's naive because it only maps the class ID to its immediate parent. +-- | It does not chase the inheritance all the way down. +getBasicClassMap :: Type.Replay -> IntMap.IntMap Int +getBasicClassMap replay = replay + & getClassCache + & reverse + & List.tails + & Maybe.mapMaybe (\ xs -> case xs of + [] -> Nothing + (classId, _, parentCacheId) : ys -> do + parentClassId <- getParentClassId parentCacheId ys + return (classId, parentClassId)) + & IntMap.fromList + +-- | Given a naive mapping from class ID to its parent class ID, return all of +-- | the parent IDs for a given class. +getParentClassIds :: Int -> IntMap.IntMap Int -> [Int] +getParentClassIds classId basicClassMap = + case IntMap.lookup classId basicClassMap of + Nothing -> [] + Just parentClassId -> parentClassId : getParentClassIds parentClassId basicClassMap + +-- | The class map is a mapping from a class ID to all of its parent class IDs. +getClassMap :: Type.Replay -> IntMap.IntMap [Int] +getClassMap replay = let + basicClassMap = getBasicClassMap replay + in replay + & getClassIds + & map (\ classId -> + ( classId + , getParentClassIds classId basicClassMap + )) + & IntMap.fromList + +-- | The property map is a mapping from property IDs to property names. +getPropertyMap :: Type.Replay -> IntMap.IntMap Text.Text +getPropertyMap replay = replay + & Type.replayObjects + & Newtype.unpack + & map Newtype.unpack + & zip [0 ..] + & IntMap.fromList + +-- | The basic class property map is a naive mapping from class IDs to a +-- | mapping from property IDs to property names. It's naive because it does +-- | not include the properties from the class's parents. +getBasicClassPropertyMap :: Type.Replay -> IntMap.IntMap (IntMap.IntMap Text.Text) +getBasicClassPropertyMap replay = let + propertyMap = getPropertyMap replay + in replay + & Type.replayCacheItems + & Newtype.unpack + & map (\ x -> let + classId = x & Type.cacheItemClassId & Newtype.unpack & fromIntegral + properties = x + & Type.cacheItemCacheProperties + & Newtype.unpack + & Maybe.mapMaybe (\ y -> let + streamId = y & Type.cachePropertyStreamId & Newtype.unpack & fromIntegral + propertyId = y & Type.cachePropertyObjectId & Newtype.unpack & fromIntegral + in case IntMap.lookup propertyId propertyMap of + Nothing -> Nothing + Just name -> Just (streamId, name)) + & IntMap.fromList + in (classId, properties)) + & IntMap.fromList + +-- | The actor map is a mapping from class names to their IDs. +getActorMap :: Type.Replay -> Map.Map Text.Text Int +getActorMap replay = replay + & Type.replayActors + & Newtype.unpack + & map (\ x -> let + className = x & Type.actorName & Newtype.unpack + classId = x & Type.actorStreamId & Newtype.unpack & fromIntegral + in (className, classId)) + & Map.fromList + +-- | Gets the class ID and name for a given property ID. +getClass + :: IntMap.IntMap Text.Text -- ^ Property ID to property name + -> Map.Map Text.Text Text.Text -- ^ Property name to class name + -> Map.Map Text.Text Int -- ^ Class name to class ID + -> Int -- ^ property ID + -> Maybe (Int, Text.Text) -- ^ Maybe class ID and class name +getClass propertyIdsToNames propertyNamesToClassNames classNamesToIds propertyId = + case IntMap.lookup propertyId propertyIdsToNames of + Nothing -> trace ("could not find property name for property id " ++ show propertyId) Nothing + Just rawPropertyName -> let + -- There are a large number of properties that end in numbers that + -- should all be treated the same. Instead of explicitly mapping + -- each of them, we can remove the numbers and treat them the same. + propertyName = rawPropertyName & Text.dropWhileEnd Char.isDigit + in case Map.lookup propertyName propertyNamesToClassNames of + Nothing -> trace ("could not find class name for property name " ++ show propertyName) $ trace (classNamesToIds & Map.toList & map (\ (k, v) -> " " ++ show v ++ " => " ++ show k) & unlines) $ Nothing + Just className -> case Map.lookup className classNamesToIds of + Nothing -> trace ("could not find class id for class name " ++ show className) Nothing + Just classId -> Just (classId, className) + +-- | The archetype maps is a mapping from object names to their class names. +archetypeMap :: Map.Map Text.Text Text.Text +archetypeMap = + -- We start by mapping class names to object names of that class. This + -- allows us to avoid repeating the class name a bunch. + [ ( "TAGame.Ball_TA" + , [ "Archetypes.Ball.Ball_Default" + , "Archetypes.Ball.Ball_Basketball" + , "Archetypes.Ball.Ball_Puck" + ]) + , ( "TAGame.CameraSettingsActor_TA" + , [ "TAGame.CameraSettingsActor_TA:PRI" + , "TAGame.Default__CameraSettingsActor_TA" + ]) + , ( "TAGame.CarComponent_Boost_TA" + , [ "Archetypes.CarComponents.CarComponent_Boost" + ]) + , ( "TAGame.CarComponent_Dodge_TA" + , [ "Archetypes.CarComponents.CarComponent_Dodge" + ]) + , ( "TAGame.CarComponent_DoubleJump_TA" + , [ "Archetypes.CarComponents.CarComponent_DoubleJump" + ]) + , ( "TAGame.CarComponent_FlipCar_TA" + , [ "Archetypes.CarComponents.CarComponent_FlipCar" + ]) + , ( "TAGame.CarComponent_Jump_TA" + , [ "Archetypes.CarComponents.CarComponent_Jump" + ]) + , ( "TAGame.Car_Season_TA" + , [ "Archetypes.GameEvent.GameEvent_Season:CarArchetype" + ]) + , ( "TAGame.Car_TA" + , [ "Archetypes.Car.Car_Default" + ]) + , ( "TAGame.GameEvent_Season_TA" + , [ "Archetypes.GameEvent.GameEvent_Season" + ]) + , ( "TAGame.GameEvent_SoccarPrivate_TA" + , [ "Archetypes.GameEvent.GameEvent_SoccarPrivate" + ]) + , ( "TAGame.GameEvent_SoccarSplitscreen_TA" + , [ "Archetypes.GameEvent.GameEvent_SoccarSplitscreen" + ]) + , ( "TAGame.GameEvent_Soccar_TA" + , [ "Archetypes.GameEvent.GameEvent_Soccar" + , "Archetypes.GameEvent.GameEvent_Basketball" + ]) + , ( "TAGame.GRI_TA" + , [ "GameInfo_Basketball.GameInfo.GameInfo_Basketball:GameReplicationInfoArchetype" + , "GameInfo_Season.GameInfo.GameInfo_Season:GameReplicationInfoArchetype" + , "GameInfo_Soccar.GameInfo.GameInfo_Soccar:GameReplicationInfoArchetype" + ]) + , ( "TAGame.PRI_TA" + , [ "TAGame.Default__PRI_TA" + ]) + , ( "TAGame.Team_TA" + , [ "Archetypes.Teams.Team" + ]) + -- These ones are special. They have specific names for each level. + , ( "TAGame.VehiclePickup_Boost_TA" + , levels & Set.toList & map (\ level -> level ++ ".TheWorld:PersistentLevel.VehiclePickup_Boost_TA_") + ) + , ( "TAGame.CrowdActor_TA" + , levels & Set.toList & map (\ level -> level ++ ".TheWorld:PersistentLevel.CrowdActor_TA_") + ) + , ( "TAGame.CrowdManager_TA" + , levels & Set.toList & map (\ level -> level ++ ".TheWorld:PersistentLevel.CrowdManager_TA_") + ) + ] + & concatMap (\ (v, ks) -> ks & map (\ k -> (k, v))) + & map (\ (k, v) -> (Text.pack k, Text.pack v)) + & Map.fromList + +-- | These are the levels that we know about. The capitalization of these +-- | drives me nuts. +levels :: Set.Set String +levels = + [ "EuroStadium_Rainy_P" + , "HoopsStadium_P" + , "Park_Night_P" + , "Park_Rainy_P" + , "Stadium_p" + , "TrainStation_Night_P" + , "TrainStation_P" + , "Trainstation_Night_P" + , "UtopiaStadium_Dusk_P" + , "UtopiaStadium_Dusk_p" + , "UtopiaStadium_P" + , "Utopiastadium_p" + , "Wasteland_P" + , "Wasteland_p" + , "eurostad_oob_audio_map" + , "eurostadium_p" + , "eurostadium_rainy_audio" + , "hoopsstadium_sfx" + , "labs_doublegoal_p" + , "labs_underpass_p" + , "labs_utopia_p" + , "park_night_sfx" + , "park_p" + , "park_rainy_sfx" + , "park_sfx" + , "stadium_oob_audio_map" + , "stadium_p" + , "stadium_winter_p" + , "trainstation_p" + , "utopiastadium_p" + , "utopiastadium_sfx" + , "wasteland_sfx" + ] & Set.fromList + +-- | These classes have an initial location vector. +classesWithLocation :: Set.Set Text.Text +classesWithLocation = + [ "TAGame.Ball_TA" + , "TAGame.CameraSettingsActor_TA" + , "TAGame.CarComponent_Boost_TA" + , "TAGame.CarComponent_Dodge_TA" + , "TAGame.CarComponent_DoubleJump_TA" + , "TAGame.CarComponent_FlipCar_TA" + , "TAGame.CarComponent_Jump_TA" + , "TAGame.Car_Season_TA" + , "TAGame.Car_TA" + , "TAGame.GRI_TA" + , "TAGame.GameEvent_Season_TA" + , "TAGame.GameEvent_SoccarPrivate_TA" + , "TAGame.GameEvent_SoccarSplitscreen_TA" + , "TAGame.GameEvent_Soccar_TA" + , "TAGame.PRI_TA" + , "TAGame.Team_TA" + ] & map Text.pack & Set.fromList + +-- | These classes have an initial rotation vector. +classesWithRotation :: Set.Set Text.Text +classesWithRotation = + [ "TAGame.Ball_TA" + , "TAGame.Car_Season_TA" + , "TAGame.Car_TA" + ] & map Text.pack & Set.fromList diff --git a/library/Octane/Type/Primitive/PCString.hs b/library/Octane/Type/Primitive/PCString.hs --- a/library/Octane/Type/Primitive/PCString.hs +++ b/library/Octane/Type/Primitive/PCString.hs @@ -25,7 +25,26 @@ instance Binary.Binary PCString where get = do - (Word32LE.Word32LE size) <- Binary.get + (Word32LE.Word32LE rawSize) <- Binary.get + -- In some tiny percentage of replays, this nonsensical string size + -- shows up. As far as I can tell the next 3 bytes are always null. And + -- the actual string is "None", which is 5 bytes including the null + -- terminator. + -- + -- These annoying replays come from around 2015-10-25 to 2015-11-01. + size <- if rawSize == 0x05000000 + then do + bytes <- Binary.getByteString 3 + if BS.all (== 0) bytes + then return 5 + else error + ( "read special size " + ++ show rawSize + ++ " but next 3 bytes were " + ++ show bytes + ++ " instead of all null" + ) + else return rawSize string <- if size == 0 then fail ("invalid PCString size " ++ show size) diff --git a/library/Octane/Type/Primitive/Word32LE.hs b/library/Octane/Type/Primitive/Word32LE.hs --- a/library/Octane/Type/Primitive/Word32LE.hs +++ b/library/Octane/Type/Primitive/Word32LE.hs @@ -9,12 +9,12 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import Data.Function ((&)) -import qualified Data.Word as Word +import qualified Data.Int as Int import qualified GHC.Generics as Generics -- | A 32-bit little-endian integer. newtype Word32LE = - Word32LE Word.Word32 + Word32LE Int.Int32 deriving (Eq,Generics.Generic,Show) instance Binary.Binary Word32LE where diff --git a/library/Octane/Type/Primitive/Word64LE.hs b/library/Octane/Type/Primitive/Word64LE.hs --- a/library/Octane/Type/Primitive/Word64LE.hs +++ b/library/Octane/Type/Primitive/Word64LE.hs @@ -9,12 +9,12 @@ import qualified Data.Binary.Get as Binary import qualified Data.Binary.Put as Binary import Data.Function ((&)) -import qualified Data.Word as Word +import qualified Data.Int as Int import qualified GHC.Generics as Generics -- | A 64-bit little-endian integer. newtype Word64LE = - Word64LE Word.Word64 + Word64LE Int.Int64 deriving (Eq,Generics.Generic,Show) instance Binary.Binary Word64LE where diff --git a/library/Octane/Type/Property.hs b/library/Octane/Type/Property.hs --- a/library/Octane/Type/Property.hs +++ b/library/Octane/Type/Property.hs @@ -54,8 +54,11 @@ _ | kind == byteProperty -> do size <- Binary.get key <- Binary.get - value <- Binary.get - (key, value) & ByteProperty size & return + if key == "OnlinePlatform_Steam" + then ("OnlinePlatform", key) & ByteProperty size & return + else do + value <- Binary.get + (key, value) & ByteProperty size & return _ | kind == floatProperty -> do size <- Binary.get value <- diff --git a/octane.cabal b/octane.cabal --- a/octane.cabal +++ b/octane.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: octane -version: 0.5.1 +version: 0.5.2 synopsis: Parse Rocket League replays. description: Octane parses Rocket League replays. category: Game @@ -31,7 +31,6 @@ ghc-options: -Wall build-depends: aeson >=0.9 && <0.12 - , aeson-pretty ==0.7.* , autoexporter ==0.2.* , base >=4.8 && <4.10 , binary >=0.7 && <0.9 @@ -41,12 +40,12 @@ , data-binary-ieee754 ==0.4.* , deepseq ==1.4.* , newtype-generics ==0.4.* - , regex-compat ==0.95.* , text ==1.2.* exposed-modules: Octane Octane.Main Octane.Parser + Octane.Parser.ClassPropertyMap Octane.Type Octane.Type.Actor Octane.Type.CacheItem diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -36,7 +36,6 @@ library: dependencies: - aeson >=0.9 && <0.12 - - aeson-pretty ==0.7.* - autoexporter ==0.2.* - base >=4.8 && <4.10 - binary >=0.7 && <0.9 @@ -46,7 +45,6 @@ - data-binary-ieee754 ==0.4.* - deepseq ==1.4.* - newtype-generics ==0.4.* - - regex-compat ==0.95.* - text ==1.2.* other-modules: Paths_octane source-dirs: library @@ -71,4 +69,4 @@ - -with-rtsopts=-N main: TestSuite.hs source-dirs: test-suite -version: '0.5.1' +version: '0.5.2'