octane 0.5.1 → 0.5.2
raw patch · 9 files changed
+567/−277 lines, 9 filesdep −aeson-prettydep −regex-compat
Dependencies removed: aeson-pretty, regex-compat
Files
- library/Octane/Main.hs +42/−26
- library/Octane/Parser.hs +185/−238
- library/Octane/Parser/ClassPropertyMap.hs +308/−0
- library/Octane/Type/Primitive/PCString.hs +20/−1
- library/Octane/Type/Primitive/Word32LE.hs +2/−2
- library/Octane/Type/Primitive/Word64LE.hs +2/−2
- library/Octane/Type/Property.hs +5/−2
- octane.cabal +2/−3
- package.yaml +1/−3
library/Octane/Main.hs view
@@ -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 "}"
library/Octane/Parser.hs view
@@ -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
+ library/Octane/Parser/ClassPropertyMap.hs view
@@ -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
library/Octane/Type/Primitive/PCString.hs view
@@ -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)
library/Octane/Type/Primitive/Word32LE.hs view
@@ -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
library/Octane/Type/Primitive/Word64LE.hs view
@@ -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
library/Octane/Type/Property.hs view
@@ -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 <-
octane.cabal view
@@ -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
package.yaml view
@@ -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'