octane-0.5.2: library/Octane/Parser.hs
{-# LANGUAGE DeriveGeneric #-}
module Octane.Parser where
import Data.Function ((&))
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Newtype as Newtype
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Binary.Bits.Get as Bits
import qualified Data.Binary.IEEE754 as IEEE754
import qualified Data.Binary.Get as Binary
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.Map.Strict as Map
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 GHC.Generics as Generics
import qualified Octane.Parser.ClassPropertyMap as CPM
import qualified Octane.Type as Type
import qualified Text.Printf as Printf
parseFrames :: Type.Replay -> [Frame]
parseFrames replay = let
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 :: 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 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
(newContext, replications) <- getReplications context
let frame =
Frame
{ frameTime = time
, frameDelta = delta
, frameReplications = replications
}
return (newContext, frame)
getReplications :: Context -> Bits.BitGet (Context, [Replication])
getReplications context = do
maybeReplication <- getMaybeReplication context
case maybeReplication of
Nothing -> return (context, [])
Just (newContext, replication) -> do
(newerContext, replications) <- getReplications newContext
return (newerContext, replication : replications)
getMaybeReplication :: Context -> Bits.BitGet (Maybe (Context, Replication))
getMaybeReplication context = do
hasReplication <- Bits.getBool
if not hasReplication
then return Nothing
else do
(newContext,replication) <- getReplication context
return (Just (newContext, replication))
getReplication :: Context -> Bits.BitGet (Context, Replication)
getReplication context = do
actorId <- getActorId
isOpen <- Bits.getBool
let go =
if isOpen
then getOpenReplication
else getClosedReplication
go context actorId
getOpenReplication :: Context
-> ActorId
-> Bits.BitGet (Context, Replication)
getOpenReplication context actorId = do
isNew <- Bits.getBool
let go =
if isNew
then getNewReplication
else getExistingReplication
go context actorId
getNewReplication :: Context
-> ActorId
-> 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 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
let thing = Thing
{ thingFlag = unknownFlag
, thingObjectId = objectId
, thingObjectName = objectName
, thingClassId = classId
, thingClassName = className
, thingClassInit = classInit
}
let things = contextThings context
let newThings = IntMap.insert actorId thing things
let newContext = context { contextThings = newThings }
return
( newContext
, Replication
{ replicationActorId = actorId
, replicationIsOpen = True
, replicationIsNew = Just True
, replicationClassInit = Just classInit
, replicationProps = []
})
getExistingReplication :: Context
-> ActorId
-> Bits.BitGet (Context, Replication)
getExistingReplication context actorId = do
let thing = case context & contextThings & IntMap.lookup actorId of
Nothing -> error ("could not find thing for actor id " ++ show actorId)
Just x -> x
props <- getProps context thing
return (context, Replication
{ replicationActorId = actorId
, replicationIsOpen = True
, replicationIsNew = Just False
, replicationClassInit = Nothing
, replicationProps = props
})
getClosedReplication :: Context
-> ActorId
-> Bits.BitGet (Context, Replication)
getClosedReplication context actorId = do
let newThings = context & contextThings & IntMap.delete actorId
let newContext = context { contextThings = newThings }
return
( newContext
, Replication
{ replicationActorId = actorId
, replicationIsOpen = False
, replicationIsNew = Nothing
, replicationClassInit = Nothing
, replicationProps = []
})
getProps :: Context -> Thing -> Bits.BitGet [Prop]
getProps context thing = do
maybeProp <- getMaybeProp context thing
case maybeProp of
Nothing -> return []
Just prop -> do
props <- getProps context thing
return (prop : props)
getMaybeProp :: Context -> Thing -> Bits.BitGet (Maybe Prop)
getMaybeProp context thing = do
hasProp <- Bits.getBool
if hasProp
then do
prop <- getProp context thing
return (Just prop)
else return Nothing
getProp :: Context -> Thing -> Bits.BitGet Prop
getProp context thing = do
let classId = thing & thingClassId
let props = case context & contextClassPropertyMap & IntMap.lookup classId of
Nothing -> error ("could not find property map for class id " ++ show classId)
Just x -> x
let maxId = props & IntMap.keys & (0 :) & maximum
pid <- getInt maxId
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 name
return (Prop { propName = name, propValue = value })
getPropValue :: Text.Text -> Bits.BitGet PropValue
getPropValue name = case Text.unpack name of
_ | Set.member name propsWithRigidBodyState -> do
flag <- Bits.getBool
position <- getVector
rotation <- getFloatVector
x <- if flag then return Nothing else fmap Just getVector
y <- if flag then return Nothing else fmap Just getVector
return (PRigidBodyState flag position rotation x y)
_ | Set.member name propsWithFlaggedInt -> do
flag <- Bits.getBool
int <- getInt32
return (PFlaggedInt flag (fromIntegral int))
_ | Set.member name propsWithString -> do
string <- getString
return (PString string)
_ | Set.member name propsWithBoolean -> do
bool <- Bits.getBool
return (PBoolean bool)
_ | Set.member name propsWithQWord -> do
x <- getInt32
y <- getInt32
return (PQWord x y)
_ | Set.member name propsWithInt -> do
int <- getInt32
return (PInt int)
_ | Set.member name propsWithByte -> do
int <- getInt8
return (PByte int)
_ | Set.member name propsWithCamSettings -> do
fov <- getFloat32
height <- getFloat32
pitch <- getFloat32
dist <- getFloat32
stiff <- getFloat32
swiv <- getFloat32
return (PCamSettings fov height pitch dist stiff swiv)
_ | Set.member name propsWithLocation -> do
vector <- getVector
return (PLocation vector)
_ | 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 7, which
-- would be a full 4x4 game.
number <- getInt7
(systemId, remoteId, localId) <- getUniqueId
playerName <- if systemId == 0 then return Nothing else do
string <- getString
return (Just string)
-- No idea what these two flags are. Might be for bots?
a <- Bits.getBool
b <- Bits.getBool
return (PReservation number systemId remoteId localId playerName a b)
"TAGame.PRI_TA:ClientLoadoutOnline" -> do
version <- getInt32
x <- getInt32
y <- getInt32
z <- if version >= 12
then do
value <- getInt8
return (Just value)
else return Nothing
return (PLoadoutOnline version x y z)
"TAGame.PRI_TA:ClientLoadout" -> do
version <- getInt8
a <- getInt32
b <- getInt32
c <- getInt32
d <- getInt32
e <- getInt32
f <- getInt32
g <- getInt32
h <- if version > 10
then do
value <- getInt32
return (Just value)
else return Nothing
return (PLoadout version a b c d e f g h)
"TAGame.Car_TA:TeamPaint" -> do
team <- getInt8
teamColor <- getInt8
customColor <- getInt8
teamFinish <- getInt32
customFinish <- getInt32
return (PTeamPaint team teamColor customColor teamFinish customFinish)
"TAGame.VehiclePickup_TA:ReplicatedPickupData" -> do
instigator <- Bits.getBool
instigatorId <- if instigator then fmap Just getInt32 else return Nothing
pickedUp <- Bits.getBool
return (PPickup instigator instigatorId pickedUp)
"Engine.Actor:Role" -> do
x <- Bits.getWord16be 11
return (PEnum x)
"TAGame.Ball_TA:ReplicatedExplosionData" -> do
noGoal <- Bits.getBool
a <- if noGoal then return Nothing else fmap Just getInt32
b <- getVector
return (PExplosion noGoal a b)
"TAGame.GameEvent_Soccar_TA:ReplicatedMusicStinger" -> do
flag <- Bits.getBool
cue <- getInt32
trigger <- getInt8
return (PMusicStinger flag cue trigger)
"TAGame.Car_TA:ReplicatedDemolish" -> do
hasAtk <- Bits.getBool
atk <- getInt32
hasVic <- Bits.getBool
vic <- getInt32
vec1 <- getVector
vec2 <- getVector
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
getFloat32 = do
bytes <- Bits.getByteString 4
bytes & byteStringToFloat & return
getString :: Bits.BitGet Text.Text
getString = do
rawSize <- getInt32
rawText <- if rawSize < 0
then do
let size = -2 * rawSize
bytes <- Bits.getByteString size
bytes & BS.map Type.reverseBits & Encoding.decodeUtf16LE & return
else do
bytes <- Bits.getByteString rawSize
bytes & BS.map Type.reverseBits & Encoding.decodeLatin1 & return
rawText & Text.dropEnd 1 & return
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
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"
] & map Text.pack & Set.fromList
propsWithFlaggedInt :: Set.Set Text.Text
propsWithFlaggedInt =
[ "Engine.GameReplicationInfo:GameClass"
, "Engine.Actor:ReplicatedCollisionType"
, "Engine.Pawn:PlayerReplicationInfo"
, "Engine.PlayerReplicationInfo:Team"
, "TAGame.Ball_TA:GameEvent"
, "TAGame.CameraSettingsActor_TA:PRI"
, "TAGame.CarComponent_TA:Vehicle"
, "TAGame.CrowdActor_TA:GameEvent"
, "TAGame.CrowdActor_TA:ReplicatedOneShotSound"
, "TAGame.CrowdManager_TA:GameEvent"
, "TAGame.CrowdManager_TA:ReplicatedGlobalOneShotSound"
, "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"
, "TAGame.CarComponent_FlipCar_TA:bFlipRight"
, "TAGame.GameEvent_Soccar_TA:bBallHasBeenHit"
, "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"
] & map Text.pack & Set.fromList
propsWithQWord :: Set.Set Text.Text
propsWithQWord =
[ "ProjectX.GRI_X:GameServerID"
] & map Text.pack & Set.fromList
propsWithInt :: Set.Set Text.Text
propsWithInt =
[ "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"
, "TAGame.GameEvent_Soccar_TA:SecondsRemaining"
, "TAGame.GameEvent_TA:BotSkill"
, "TAGame.GameEvent_TA:ReplicatedGameStateTimeRemaining"
, "TAGame.GameEvent_TA:ReplicatedStateName"
, "TAGame.GameEvent_Team_TA:MaxTeamSize"
, "TAGame.PRI_TA:MatchAssists"
, "TAGame.PRI_TA:MatchGoals"
, "TAGame.PRI_TA:MatchSaves"
, "TAGame.PRI_TA:MatchScore"
, "TAGame.PRI_TA:MatchShots"
, "TAGame.PRI_TA:Title"
, "TAGame.PRI_TA:TotalXP"
] & map Text.pack & Set.fromList
propsWithByte :: Set.Set Text.Text
propsWithByte =
[ "Engine.PlayerReplicationInfo:Ping"
, "TAGame.Ball_TA:HitTeamNum"
, "TAGame.CameraSettingsActor_TA:CameraPitch"
, "TAGame.CameraSettingsActor_TA:CameraYaw"
, "TAGame.CarComponent_Boost_TA:ReplicatedBoostAmount"
, "TAGame.CarComponent_TA:ReplicatedActive"
, "TAGame.GameEvent_Soccar_TA:ReplicatedScoredOnTeam"
, "TAGame.GameEvent_TA:ReplicatedStateIndex"
, "TAGame.PRI_TA:CameraPitch"
, "TAGame.PRI_TA:CameraYaw"
, "TAGame.Vehicle_TA:ReplicatedSteer"
, "TAGame.Vehicle_TA:ReplicatedThrottle"
] & map Text.pack & Set.fromList
propsWithCamSettings :: Set.Set Text.Text
propsWithCamSettings =
[ "TAGame.CameraSettingsActor_TA:ProfileSettings"
, "TAGame.PRI_TA:CameraSettings"
] & map Text.pack & Set.fromList
propsWithLocation :: Set.Set Text.Text
propsWithLocation =
[ "TAGame.CarComponent_Dodge_TA:DodgeTorque"
] & map Text.pack & Set.fromList
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
type SystemId = Word.Word8
-- This is the number associated with a splitscreen player. So the first player
-- is 0, the second is 1, and so on.
-- - 0 "Someone"
-- - 1 "Someone (1)"
type LocalId = Maybe Word.Word8
data RemoteId
= SteamId !Word.Word64
| PlayStationId !Text.Text
| SplitscreenId !(Maybe Int)
| XboxId !Word.Word64
deriving (Eq, Generics.Generic, Show)
instance DeepSeq.NFData RemoteId
instance Aeson.ToJSON RemoteId
data Prop = Prop
{ propName :: !Text.Text
, propValue :: !PropValue
} deriving (Eq, Generics.Generic, Show)
instance DeepSeq.NFData Prop
instance Aeson.ToJSON Prop where
toJSON =
Aeson.genericToJSON
Aeson.defaultOptions
{ Aeson.fieldLabelModifier = drop 4
}
data PropValue
= PRigidBodyState !Bool !(Vector Int) !(Vector Float) !(Maybe (Vector Int)) !(Maybe (Vector Int))
| PFlaggedInt !Bool !Int
| PString !Text.Text
| PBoolean !Bool
| PQWord Int !Int
| PReservation !Int !SystemId !RemoteId !LocalId !(Maybe Text.Text) !Bool !Bool
| PInt !Int
| PByte !Int
| PUniqueId !SystemId !RemoteId !LocalId
| PLoadoutOnline !Int !Int !Int !(Maybe Int)
| PLoadout !Int !Int !Int !Int !Int !Int !Int !Int !(Maybe Int)
| PCamSettings !Float !Float !Float !Float !Float !Float
| PTeamPaint !Int !Int !Int !Int !Int
| PLocation !(Vector Int)
| PPickup !Bool !(Maybe Int) !Bool
| 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
instance Aeson.ToJSON PropValue where
toJSON =
Aeson.genericToJSON
Aeson.defaultOptions
{ Aeson.fieldLabelModifier = drop 9
}
-- | A frame in the net stream. Each frame has the time since the beginning of
-- | the match, the time since the last frame, and a list of replications.
data Frame = Frame
{ frameTime :: !Float
, frameDelta :: !Float
, frameReplications :: ![Replication]
} deriving (Eq,Generics.Generic,Show)
instance DeepSeq.NFData Frame
instance Aeson.ToJSON Frame where
toJSON =
Aeson.genericToJSON
Aeson.defaultOptions
{ Aeson.fieldLabelModifier = drop 5
}
-- | Replication information about an actor in the net stream.
data Replication = Replication
{ replicationActorId :: !Int
, replicationIsOpen :: !Bool
, replicationIsNew :: !(Maybe Bool)
, replicationClassInit :: !(Maybe ClassInit)
, replicationProps :: ![Prop]
} deriving (Eq,Generics.Generic,Show)
instance DeepSeq.NFData Replication
instance Aeson.ToJSON Replication where
toJSON =
Aeson.genericToJSON
Aeson.defaultOptions
{ Aeson.fieldLabelModifier = drop 11
}
data Thing = Thing
{ thingFlag :: !Bool
, thingObjectId :: !Int
, thingObjectName :: !Text.Text
, thingClassId :: !Int
, thingClassName :: !Text.Text
, thingClassInit :: !ClassInit
} deriving (Show)
type Time = Float
type Delta = Float
type ActorId = Int
data Vector a = Vector
{ vectorX :: !a
, vectorY :: !a
, vectorZ :: !a
} deriving (Eq, Generics.Generic, Show)
instance (DeepSeq.NFData a) => DeepSeq.NFData (Vector a)
instance (Aeson.ToJSON a) => Aeson.ToJSON (Vector a) where
toJSON vector = Aeson.toJSON
[ vectorX vector
, vectorY vector
, vectorZ vector
]
data ClassInit = ClassInit
{ classInitLocation :: !(Maybe (Vector Int))
, classInitRotation :: !(Maybe (Vector Int))
} deriving (Eq, Generics.Generic, Show)
instance DeepSeq.NFData ClassInit
instance Aeson.ToJSON ClassInit where
toJSON =
Aeson.genericToJSON
Aeson.defaultOptions
{ Aeson.fieldLabelModifier = drop 9
}
-- { class stream id => { property stream id => name } }
type ClassPropertyMap = IntMap.IntMap (IntMap.IntMap Text.Text)
-- { stream id => object name }
type ObjectMap = IntMap.IntMap Text.Text
-- { class name => class id }
type ClassMap = Map.Map Text.Text Int
data Context = Context
{ contextObjectMap :: !ObjectMap
, contextClassPropertyMap :: !ClassPropertyMap
, contextThings :: !(IntMap.IntMap Thing)
, contextClassMap :: !ClassMap
} deriving (Show)
extractContext :: Type.Replay -> Context
extractContext replay =
Context
{ contextObjectMap = CPM.getPropertyMap replay
, contextClassPropertyMap = CPM.getClassPropertyMap replay
, contextThings = IntMap.empty
, contextClassMap = CPM.getActorMap replay
}
byteStringToFloat :: BS.ByteString -> Float
byteStringToFloat bytes = Binary.runGet
IEEE754.getFloat32le
(bytes & BSL.fromStrict & BSL.map Type.reverseBits)
getVector :: Bits.BitGet (Vector Int)
getVector = do
numBits <- getNumVectorBits
let bias = Bits.shiftL 1 (numBits + 1)
let maxBits = numBits + 2
let maxValue = 2 ^ maxBits
dx <- getInt maxValue
dy <- getInt maxValue
dz <- getInt maxValue
return
Vector
{ vectorX = dx - bias
, vectorY = dy - bias
, vectorZ = dz - bias
}
getVectorBytewise
:: Bits.BitGet (Vector Int)
getVectorBytewise = do
hasX <- Bits.getBool
x <-
if hasX
then do
word <- Bits.getWord8 8
word & Type.reverseBits & fromIntegral & return
else return 0
hasY <- Bits.getBool
y <-
if hasY
then do
word <- Bits.getWord8 8
word & Type.reverseBits & fromIntegral & return
else return 0
hasZ <- Bits.getBool
z <-
if hasZ
then do
word <- Bits.getWord8 8
word & Type.reverseBits & fromIntegral & return
else return 0
return
Vector
{ vectorX = x
, vectorY = y
, vectorZ = z
}
getFloatVector :: Bits.BitGet (Vector Float)
getFloatVector = do
let maxValue = 1
let numBits = 16
x <- getFloat maxValue numBits
y <- getFloat maxValue numBits
z <- getFloat maxValue numBits
return Vector { vectorX = x, vectorY = y, vectorZ = z }
getFloat :: Int -> Int -> Bits.BitGet Float
getFloat maxValue numBits = do
let maxBitValue = (Bits.shiftL 1 (numBits - 1)) - 1
let bias = Bits.shiftL 1 (numBits - 1)
let serIntMax = Bits.shiftL 1 numBits
delta <- getInt serIntMax
let unscaledValue = delta - bias
if maxValue > maxBitValue
then do
let invScale = fromIntegral maxValue / fromIntegral maxBitValue
return (fromIntegral unscaledValue * invScale)
else do
let scale = fromIntegral maxBitValue / fromIntegral maxValue
let invScale = 1.0 / scale
return (fromIntegral unscaledValue * invScale)
getClassInit :: Text.Text -> Bits.BitGet ClassInit
getClassInit className = do
location <-
if Set.member className CPM.classesWithLocation
then do
vector <- getVector
return (Just vector)
else return Nothing
rotation <-
if Set.member className CPM.classesWithRotation
then do
vector <- getVectorBytewise
return (Just vector)
else return Nothing
return
ClassInit
{ classInitLocation = location
, classInitRotation = rotation
}
bitSize
:: (Integral a)
=> a -> a
bitSize x = x & fromIntegral & logBase (2 :: Double) & ceiling
-- Reads an integer bitwise. The bits of the integer are backwards, so the
-- least significant bit is first. The argument is the maximum value this
-- integer can have. Bits will be read until the next bit would be greater than
-- the maximum value, or the number of bits necessary to reach the maximum
-- value has been reached, whichever comes first.
--
-- For example, if the maximum value is 4 and "11" has been read already,
-- nothing more will be read because another "1" would put the value over the
-- maximum.
getInt
:: Int -> Bits.BitGet Int
getInt maxValue = do
let maxBits = bitSize maxValue
go i value = do
let x = Bits.shiftL 1 i
if i < maxBits && value + x <= maxValue
then do
bit <- Bits.getBool
let newValue =
if bit
then value + x
else value
go (i + 1) newValue
else return value
go 0 0
getInt32 :: Bits.BitGet 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 = 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
getActorId :: Bits.BitGet Int
getActorId = getInt 1024
getNumVectorBits :: Bits.BitGet Int
getNumVectorBits = getInt 19
getInt7 :: Bits.BitGet Int
getInt7 = getInt 7