diff --git a/benchmark/Main.hs b/benchmark/Main.hs deleted file mode 100644 --- a/benchmark/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main - ( main - ) where - -import qualified Criterion.Main as Criterion -import qualified OctaneBench - -main :: IO () -main = Criterion.defaultMain bench - -bench :: [Criterion.Benchmark] -bench = [OctaneBench.bench] diff --git a/benchmark/OctaneBench.hs b/benchmark/OctaneBench.hs deleted file mode 100644 --- a/benchmark/OctaneBench.hs +++ /dev/null @@ -1,8 +0,0 @@ -module OctaneBench - ( bench - ) where - -import qualified Criterion - -bench :: Criterion.Benchmark -bench = Criterion.bgroup "Octane" [] diff --git a/data/classes-with-location.json b/data/classes-with-location.json deleted file mode 100644 --- a/data/classes-with-location.json +++ /dev/null @@ -1,30 +0,0 @@ -[ - "TAGame.Ball_TA", - "TAGame.CameraSettingsActor_TA", - "TAGame.Car_Season_TA", - "TAGame.Car_TA", - "TAGame.CarComponent_Boost_TA", - "TAGame.CarComponent_Dodge_TA", - "TAGame.CarComponent_DoubleJump_TA", - "TAGame.CarComponent_FlipCar_TA", - "TAGame.CarComponent_Jump_TA", - "TAGame.GameEvent_Season_TA", - "TAGame.GameEvent_Soccar_TA", - "TAGame.GameEvent_SoccarPrivate_TA", - "TAGame.GameEvent_SoccarSplitscreen_TA", - "TAGame.GRI_TA", - "TAGame.PRI_TA", - "TAGame.SpecialPickup_BallCarSpring_TA", - "TAGame.SpecialPickup_BallFreeze_TA", - "TAGame.SpecialPickup_BallGravity_TA", - "TAGame.SpecialPickup_BallGravity_TA", - "TAGame.SpecialPickup_BallLasso_TA", - "TAGame.SpecialPickup_BallVelcro_TA", - "TAGame.SpecialPickup_Batarang_TA", - "TAGame.SpecialPickup_BoostOverride_TA", - "TAGame.SpecialPickup_GrapplingHook_TA", - "TAGame.SpecialPickup_HitForce_TA", - "TAGame.SpecialPickup_Swapper_TA", - "TAGame.SpecialPickup_Tornado_TA", - "TAGame.Team_Soccar_TA" -] diff --git a/data/classes-with-rotation.json b/data/classes-with-rotation.json deleted file mode 100644 --- a/data/classes-with-rotation.json +++ /dev/null @@ -1,5 +0,0 @@ -[ - "TAGame.Ball_TA", - "TAGame.Car_Season_TA", - "TAGame.Car_TA" -] diff --git a/data/classes.json b/data/classes.json deleted file mode 100644 --- a/data/classes.json +++ /dev/null @@ -1,50 +0,0 @@ -{ - "Archetypes.Ball.Ball_Basketball": "TAGame.Ball_TA", - "Archetypes.Ball.Ball_Default": "TAGame.Ball_TA", - "Archetypes.Ball.Ball_Puck": "TAGame.Ball_TA", - "Archetypes.Ball.CubeBall": "TAGame.Ball_TA", - "Archetypes.Car.Car_Default": "TAGame.Car_TA", - "Archetypes.CarComponents.CarComponent_Boost": "TAGame.CarComponent_Boost_TA", - "Archetypes.CarComponents.CarComponent_Dodge": "TAGame.CarComponent_Dodge_TA", - "Archetypes.CarComponents.CarComponent_DoubleJump": "TAGame.CarComponent_DoubleJump_TA", - "Archetypes.CarComponents.CarComponent_FlipCar": "TAGame.CarComponent_FlipCar_TA", - "Archetypes.CarComponents.CarComponent_Jump": "TAGame.CarComponent_Jump_TA", - "Archetypes.GameEvent.GameEvent_Basketball": "TAGame.GameEvent_Soccar_TA", - "Archetypes.GameEvent.GameEvent_BasketballPrivate": "TAGame.GameEvent_SoccarPrivate_TA", - "Archetypes.GameEvent.GameEvent_BasketballSplitscreen": "TAGame.GameEvent_SoccarSplitscreen_TA", - "Archetypes.GameEvent.GameEvent_HockeyPrivate": "TAGame.GameEvent_SoccarPrivate_TA", - "Archetypes.GameEvent.GameEvent_HockeySplitscreen": "TAGame.GameEvent_SoccarSplitscreen_TA", - "Archetypes.GameEvent.GameEvent_Items": "TAGame.GameEvent_Soccar_TA", - "Archetypes.GameEvent.GameEvent_Season:CarArchetype": "TAGame.Car_TA", - "Archetypes.GameEvent.GameEvent_Season": "TAGame.GameEvent_Season_TA", - "Archetypes.GameEvent.GameEvent_Soccar": "TAGame.GameEvent_Soccar_TA", - "Archetypes.GameEvent.GameEvent_SoccarPrivate": "TAGame.GameEvent_SoccarPrivate_TA", - "Archetypes.GameEvent.GameEvent_SoccarSplitscreen": "TAGame.GameEvent_SoccarSplitscreen_TA", - "Archetypes.SpecialPickups.SpecialPickup_BallFreeze": "TAGame.SpecialPickup_BallFreeze_TA", - "Archetypes.SpecialPickups.SpecialPickup_BallGrapplingHook": "TAGame.SpecialPickup_GrapplingHook_TA", - "Archetypes.SpecialPickups.SpecialPickup_BallLasso": "TAGame.SpecialPickup_BallLasso_TA", - "Archetypes.SpecialPickups.SpecialPickup_BallSpring": "TAGame.SpecialPickup_BallCarSpring_TA", - "Archetypes.SpecialPickups.SpecialPickup_BallVelcro": "TAGame.SpecialPickup_BallVelcro_TA", - "Archetypes.SpecialPickups.SpecialPickup_Batarang": "TAGame.SpecialPickup_Batarang_TA", - "Archetypes.SpecialPickups.SpecialPickup_BoostOverride": "TAGame.SpecialPickup_BoostOverride_TA", - "Archetypes.SpecialPickups.SpecialPickup_CarSpring": "TAGame.SpecialPickup_BallCarSpring_TA", - "Archetypes.SpecialPickups.SpecialPickup_GravityWell": "TAGame.SpecialPickup_BallGravity_TA", - "Archetypes.SpecialPickups.SpecialPickup_StrongHit": "TAGame.SpecialPickup_HitForce_TA", - "Archetypes.SpecialPickups.SpecialPickup_Swapper": "TAGame.SpecialPickup_Swapper_TA", - "Archetypes.SpecialPickups.SpecialPickup_Tornado": "TAGame.SpecialPickup_Tornado_TA", - "Archetypes.Teams.Team0": "TAGame.Team_Soccar_TA", - "Archetypes.Teams.Team1": "TAGame.Team_Soccar_TA", - "GameInfo_Basketball.GameInfo.GameInfo_Basketball:GameReplicationInfoArchetype": "TAGame.GRI_TA", - "Gameinfo_Hockey.GameInfo.Gameinfo_Hockey:GameReplicationInfoArchetype": "TAGame.GRI_TA", - "GameInfo_Items.GameInfo.GameInfo_Items:GameReplicationInfoArchetype": "TAGame.GRI_TA", - "GameInfo_Season.GameInfo.GameInfo_Season:GameReplicationInfoArchetype": "TAGame.GRI_TA", - "GameInfo_Soccar.GameInfo.GameInfo_Soccar:GameReplicationInfoArchetype": "TAGame.GRI_TA", - "TAGame.CameraSettingsActor_TA:PRI": "TAGame.CameraSettingsActor_TA", - "TAGame.Default__CameraSettingsActor_TA": "TAGame.CameraSettingsActor_TA", - "TAGame.Default__PRI_TA": "TAGame.PRI_TA", - "TAGame.Default__VoteActor_TA": "TAGame.VoteActor_TA", - "TheWorld:PersistentLevel.CrowdActor_TA": "TAGame.CrowdActor_TA", - "TheWorld:PersistentLevel.CrowdManager_TA": "TAGame.CrowdManager_TA", - "TheWorld:PersistentLevel.InMapScoreboard_TA": "TAGame.InMapScoreboard_TA", - "TheWorld:PersistentLevel.VehiclePickup_Boost_TA": "TAGame.VehiclePickup_Boost_TA" -} diff --git a/data/parent-classes.json b/data/parent-classes.json deleted file mode 100644 --- a/data/parent-classes.json +++ /dev/null @@ -1,11 +0,0 @@ -{ - "TAGame.CarComponent_Boost_TA": "TAGame.CarComponent_TA", - "TAGame.CarComponent_Dodge_TA": "TAGame.CarComponent_TA", - "TAGame.CarComponent_DoubleJump_TA": "TAGame.CarComponent_TA", - "TAGame.CarComponent_FlipCar_TA": "TAGame.CarComponent_TA", - "TAGame.CarComponent_Jump_TA": "TAGame.CarComponent_TA", - "TAGame.SpecialPickup_BallGravity_TA": "TAGame.SpecialPickup_TA", - "TAGame.SpecialPickup_BallVelcro_TA": "TAGame.SpecialPickup_TA", - "TAGame.SpecialPickup_TA": "TAGame.CarComponent_TA", - "TAGame.SpecialPickup_Tornado_TA": "TAGame.SpecialPickup_TA" -} diff --git a/data/properties.json b/data/properties.json deleted file mode 100644 --- a/data/properties.json +++ /dev/null @@ -1,149 +0,0 @@ -{ - "Engine.Actor:bBlockActors": "boolean", - "Engine.Actor:bCollideActors": "boolean", - "Engine.Actor:bCollideWorld": "boolean", - "Engine.Actor:bHardAttach": "boolean", - "Engine.Actor:bHidden": "boolean", - "Engine.Actor:bNetOwner": "boolean", - "Engine.Actor:bProjTarget": "boolean", - "Engine.Actor:bTearOff": "boolean", - "Engine.Actor:DrawScale": "float", - "Engine.Actor:Owner": "flagged_int", - "Engine.Actor:RelativeLocation": "location", - "Engine.Actor:RelativeRotation": "relative_rotation", - "Engine.Actor:ReplicatedCollisionType": "flagged_int", - "Engine.Actor:Role": "enum", - "Engine.GameReplicationInfo:bMatchIsOver": "boolean", - "Engine.GameReplicationInfo:GameClass": "flagged_int", - "Engine.GameReplicationInfo:ServerName": "string", - "Engine.Pawn:bCanSwatTurn": "boolean", - "Engine.Pawn:bRootMotionFromInterpCurve": "boolean", - "Engine.Pawn:bSimulateGravity": "boolean", - "Engine.Pawn:PlayerReplicationInfo": "flagged_int", - "Engine.PlayerReplicationInfo:bAdmin": "boolean", - "Engine.PlayerReplicationInfo:bBot": "boolean", - "Engine.PlayerReplicationInfo:bFromPreviousLevel": "boolean", - "Engine.PlayerReplicationInfo:bIsSpectator": "boolean", - "Engine.PlayerReplicationInfo:bOnlySpectator": "boolean", - "Engine.PlayerReplicationInfo:bOutOfLives": "boolean", - "Engine.PlayerReplicationInfo:bReadyToPlay": "boolean", - "Engine.PlayerReplicationInfo:bWaitingPlayer": "boolean", - "Engine.PlayerReplicationInfo:Ping": "byte", - "Engine.PlayerReplicationInfo:PlayerID": "int", - "Engine.PlayerReplicationInfo:PlayerName": "string", - "Engine.PlayerReplicationInfo:RemoteUserData": "string", - "Engine.PlayerReplicationInfo:Score": "int", - "Engine.PlayerReplicationInfo:Team": "flagged_int", - "Engine.PlayerReplicationInfo:UniqueId": "unique_id", - "Engine.TeamInfo:Score": "int", - "Engine.TeamInfo:TeamIndex": "flagged_int", - "ProjectX.GRI_X:bGameStarted": "boolean", - "ProjectX.GRI_X:GameServerID": "qword", - "ProjectX.GRI_X:ReplicatedGameMutatorIndex": "int", - "ProjectX.GRI_X:ReplicatedGamePlaylist": "int", - "ProjectX.GRI_X:Reservations": "reservation", - "TAGame.Ball_TA:GameEvent": "flagged_int", - "TAGame.Ball_TA:HitTeamNum": "byte", - "TAGame.Ball_TA:ReplicatedAddedCarBounceScale": "float", - "TAGame.Ball_TA:ReplicatedBallMaxLinearSpeedScale": "float", - "TAGame.Ball_TA:ReplicatedBallScale": "float", - "TAGame.Ball_TA:ReplicatedExplosionData": "explosion", - "TAGame.Ball_TA:ReplicatedWorldBounceScale": "float", - "TAGame.CameraSettingsActor_TA:bUsingBehindView": "boolean", - "TAGame.CameraSettingsActor_TA:bUsingSecondaryCamera": "boolean", - "TAGame.CameraSettingsActor_TA:CameraPitch": "byte", - "TAGame.CameraSettingsActor_TA:CameraYaw": "byte", - "TAGame.CameraSettingsActor_TA:PRI": "flagged_int", - "TAGame.CameraSettingsActor_TA:ProfileSettings": "cam_settings", - "TAGame.Car_TA:AddedBallForceMultiplier": "float", - "TAGame.Car_TA:AddedCarForceMultiplier": "float", - "TAGame.Car_TA:AttachedPickup": "flagged_int", - "TAGame.Car_TA:ReplicatedDemolish": "demolish", - "TAGame.Car_TA:TeamPaint": "team_paint", - "TAGame.CarComponent_Boost_TA:bNoBoost": "boolean", - "TAGame.CarComponent_Boost_TA:BoostModifier": "float", - "TAGame.CarComponent_Boost_TA:bUnlimitedBoost": "boolean", - "TAGame.CarComponent_Boost_TA:RechargeDelay": "float", - "TAGame.CarComponent_Boost_TA:RechargeRate": "float", - "TAGame.CarComponent_Boost_TA:ReplicatedBoostAmount": "byte", - "TAGame.CarComponent_Boost_TA:UnlimitedBoostRefCount": "int", - "TAGame.CarComponent_Dodge_TA:DodgeTorque": "location", - "TAGame.CarComponent_FlipCar_TA:bFlipRight": "boolean", - "TAGame.CarComponent_FlipCar_TA:FlipCarTime": "float", - "TAGame.CarComponent_TA:ReplicatedActive": "byte", - "TAGame.CarComponent_TA:ReplicatedActivityTime": "float", - "TAGame.CarComponent_TA:Vehicle": "flagged_int", - "TAGame.CrowdActor_TA:GameEvent": "flagged_int", - "TAGame.CrowdActor_TA:ModifiedNoise": "float", - "TAGame.CrowdActor_TA:ReplicatedCountDownNumber": "int", - "TAGame.CrowdActor_TA:ReplicatedOneShotSound": "flagged_int", - "TAGame.CrowdActor_TA:ReplicatedRoundCountDownNumber": "int", - "TAGame.CrowdManager_TA:GameEvent": "flagged_int", - "TAGame.CrowdManager_TA:ReplicatedGlobalOneShotSound": "flagged_int", - "TAGame.GameEvent_Soccar_TA:bBallHasBeenHit": "boolean", - "TAGame.GameEvent_Soccar_TA:bOverTime": "boolean", - "TAGame.GameEvent_Soccar_TA:ReplicatedMusicStinger": "music_stinger", - "TAGame.GameEvent_Soccar_TA:ReplicatedScoredOnTeam": "byte", - "TAGame.GameEvent_Soccar_TA:RoundNum": "int", - "TAGame.GameEvent_Soccar_TA:SecondsRemaining": "int", - "TAGame.GameEvent_Soccar_TA:SubRulesArchetype": "flagged_int", - "TAGame.GameEvent_SoccarPrivate_TA:MatchSettings": "private_match_settings", - "TAGame.GameEvent_TA:bCanVoteToForfeit": "boolean", - "TAGame.GameEvent_TA:bHasLeaveMatchPenalty": "boolean", - "TAGame.GameEvent_TA:BotSkill": "int", - "TAGame.GameEvent_TA:GameMode": "game_mode", - "TAGame.GameEvent_TA:MatchTypeClass": "flagged_int", - "TAGame.GameEvent_TA:ReplicatedGameStateTimeRemaining": "int", - "TAGame.GameEvent_TA:ReplicatedStateIndex": "byte", - "TAGame.GameEvent_TA:ReplicatedStateName": "int", - "TAGame.GameEvent_Team_TA:bDisableMutingOtherTeam": "boolean", - "TAGame.GameEvent_Team_TA:MaxTeamSize": "int", - "TAGame.GRI_TA:NewDedicatedServerIP": "string", - "TAGame.PRI_TA:bIsInSplitScreen": "boolean", - "TAGame.PRI_TA:bMatchMVP": "boolean", - "TAGame.PRI_TA:bOnlineLoadoutSet": "boolean", - "TAGame.PRI_TA:bOnlineLoadoutsSet": "boolean", - "TAGame.PRI_TA:bReady": "boolean", - "TAGame.PRI_TA:bUsingBehindView": "boolean", - "TAGame.PRI_TA:bUsingFreecam": "boolean", - "TAGame.PRI_TA:bUsingSecondaryCamera": "boolean", - "TAGame.PRI_TA:bVoteToForfeitDisabled": "boolean", - "TAGame.PRI_TA:CameraPitch": "byte", - "TAGame.PRI_TA:CameraSettings": "cam_settings", - "TAGame.PRI_TA:CameraYaw": "byte", - "TAGame.PRI_TA:ClientLoadout": "loadout", - "TAGame.PRI_TA:ClientLoadoutOnline": "loadout_online", - "TAGame.PRI_TA:ClientLoadouts": "loadouts", - "TAGame.PRI_TA:ClientLoadoutsOnline": "loadouts_online", - "TAGame.PRI_TA:MatchAssists": "int", - "TAGame.PRI_TA:MatchGoals": "int", - "TAGame.PRI_TA:MatchSaves": "int", - "TAGame.PRI_TA:MatchScore": "int", - "TAGame.PRI_TA:MatchShots": "int", - "TAGame.PRI_TA:PartyLeader": "party_leader", - "TAGame.PRI_TA:PawnType": "byte", - "TAGame.PRI_TA:PersistentCamera": "flagged_int", - "TAGame.PRI_TA:ReplicatedGameEvent": "flagged_int", - "TAGame.PRI_TA:Title": "int", - "TAGame.PRI_TA:TotalXP": "int", - "TAGame.RBActor_TA:bFrozen": "boolean", - "TAGame.RBActor_TA:bIgnoreSyncing": "boolean", - "TAGame.RBActor_TA:bReplayActor": "boolean", - "TAGame.RBActor_TA:ReplicatedRBState": "rigid_body_state", - "TAGame.RBActor_TA:WeldedInfo": "welded_info", - "TAGame.SpecialPickup_BallFreeze_TA:RepOrigSpeed": "float", - "TAGame.SpecialPickup_BallVelcro_TA:AttachTime": "float", - "TAGame.SpecialPickup_BallVelcro_TA:bBroken": "boolean", - "TAGame.SpecialPickup_BallVelcro_TA:bHit": "boolean", - "TAGame.SpecialPickup_BallVelcro_TA:BreakTime": "float", - "TAGame.SpecialPickup_Targeted_TA:Targeted": "flagged_int", - "TAGame.Team_Soccar_TA:GameScore": "int", - "TAGame.Team_TA:CustomTeamName": "string", - "TAGame.Team_TA:GameEvent": "flagged_int", - "TAGame.Team_TA:LogoData": "flagged_int", - "TAGame.Vehicle_TA:bDriving": "boolean", - "TAGame.Vehicle_TA:bReplicatedHandbrake": "boolean", - "TAGame.Vehicle_TA:ReplicatedSteer": "byte", - "TAGame.Vehicle_TA:ReplicatedThrottle": "byte", - "TAGame.VehiclePickup_TA:ReplicatedPickupData": "pickup" -} diff --git a/library/Octane/Data.hs b/library/Octane/Data.hs --- a/library/Octane/Data.hs +++ b/library/Octane/Data.hs @@ -4,55 +4,13 @@ import qualified Data.Bimap as Bimap import qualified Data.FileEmbed as FileEmbed -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set import qualified Data.Text as StrictText import qualified Octane.Utility.Embed as Embed --- | A map from object names to their class names. -classes :: Map.Map StrictText.Text StrictText.Text -classes = Embed.decodeMap $(FileEmbed.embedFile "data/classes.json") - --- | A set of classes that have an initial location vector. -classesWithLocation :: Set.Set StrictText.Text -classesWithLocation = - Embed.decodeSet $(FileEmbed.embedFile "data/classes-with-location.json") - --- | A set of classes that have an initial rotation vector. -classesWithRotation :: Set.Set StrictText.Text -classesWithRotation = - Embed.decodeSet $(FileEmbed.embedFile "data/classes-with-rotation.json") - -- | A one-to-one mapping between game mode IDs and their names. gameModes :: Bimap.Bimap Int StrictText.Text gameModes = Embed.decodeBimap $(FileEmbed.embedFile "data/game-modes.json") -latestMajorVersion - :: (Num a) - => a -latestMajorVersion = 868 - -latestMinorVersion - :: (Num a) - => a -latestMinorVersion = 12 - -maxActorId - :: (Num a) - => a -maxActorId = 1024 - --- | A mapping between classes and their parent classes. Note that not every --- class is present in this map. Only classes that are sometimes misrepresented --- in the class property map are in this mapping. See #37 for details. -parentClasses :: Map.Map StrictText.Text StrictText.Text -parentClasses = - Embed.decodeMap $(FileEmbed.embedFile "data/parent-classes.json") - -- | A one-to-one mapping between product IDs and their names. products :: Bimap.Bimap Word StrictText.Text products = Embed.decodeBimap $(FileEmbed.embedFile "data/products.json") - --- | A mapping between property names and their serialized type. -properties :: Map.Map StrictText.Text StrictText.Text -properties = Embed.decodeMap $(FileEmbed.embedFile "data/properties.json") diff --git a/library/Octane/Type.hs b/library/Octane/Type.hs --- a/library/Octane/Type.hs +++ b/library/Octane/Type.hs @@ -1,8 +1,5 @@ module Octane.Type ( module Octane.Type.Boolean - , module Octane.Type.CacheItem - , module Octane.Type.CacheProperty - , module Octane.Type.ClassItem , module Octane.Type.CompressedWord , module Octane.Type.Dictionary , module Octane.Type.Float32 @@ -10,20 +7,12 @@ , module Octane.Type.Initialization , module Octane.Type.Int32 , module Octane.Type.Int8 - , module Octane.Type.KeyFrame , module Octane.Type.List - , module Octane.Type.Mark - , module Octane.Type.Message - , module Octane.Type.OptimizedReplay , module Octane.Type.Property - , module Octane.Type.RawReplay , module Octane.Type.RemoteId , module Octane.Type.Replay - , module Octane.Type.ReplayWithFrames - , module Octane.Type.ReplayWithoutFrames , module Octane.Type.Replication , module Octane.Type.State - , module Octane.Type.Stream , module Octane.Type.Text , module Octane.Type.Value , module Octane.Type.Vector @@ -34,9 +23,6 @@ ) where import Octane.Type.Boolean -import Octane.Type.CacheItem -import Octane.Type.CacheProperty -import Octane.Type.ClassItem import Octane.Type.CompressedWord import Octane.Type.Dictionary import Octane.Type.Float32 @@ -44,20 +30,12 @@ import Octane.Type.Initialization import Octane.Type.Int32 import Octane.Type.Int8 -import Octane.Type.KeyFrame import Octane.Type.List -import Octane.Type.Mark -import Octane.Type.Message -import Octane.Type.OptimizedReplay import Octane.Type.Property -import Octane.Type.RawReplay import Octane.Type.RemoteId import Octane.Type.Replay -import Octane.Type.ReplayWithFrames -import Octane.Type.ReplayWithoutFrames import Octane.Type.Replication import Octane.Type.State -import Octane.Type.Stream import Octane.Type.Text import Octane.Type.Value import Octane.Type.Vector diff --git a/library/Octane/Type/Boolean.hs b/library/Octane/Type/Boolean.hs --- a/library/Octane/Type/Boolean.hs +++ b/library/Octane/Type/Boolean.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -13,42 +12,16 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -- | A boolean value. newtype Boolean = Boolean { booleanUnpack :: Bool - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''Boolean) - --- | Stored in the last bit of a byte. Decoding will fail if the byte is --- anything other than @0b00000000@ or @0b00000001@. -instance Binary.Binary Boolean where - get = do - value <- Binary.getWord8 - case value of - 0 -> pure (Boolean False) - 1 -> pure (Boolean True) - _ -> fail ("Unexpected Boolean value " ++ show value) - put boolean = boolean & #unpack & fromEnum & fromIntegral & Binary.putWord8 - --- | Stored as a bit. -instance BinaryBit.BinaryBit Boolean where - getBits _ = do - value <- BinaryBit.getBool - value & Boolean & pure - putBits _ boolean = boolean & #unpack & BinaryBit.putBool - -instance DeepSeq.NFData Boolean -- | Encoded directly as a JSON boolean. instance Aeson.ToJSON Boolean where diff --git a/library/Octane/Type/CacheItem.hs b/library/Octane/Type/CacheItem.hs deleted file mode 100644 --- a/library/Octane/Type/CacheItem.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.CacheItem - ( CacheItem(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.CacheProperty as CacheProperty -import qualified Octane.Type.List as List -import qualified Octane.Type.Word32 as Word32 - --- | An item in the class net cache map. -data CacheItem = CacheItem - { cacheItemClassId :: Word32.Word32 - -- ^ The class ID. - , cacheItemParentCacheId :: Word32.Word32 - -- ^ The cache ID of the parent class. - , cacheItemCacheId :: Word32.Word32 - -- ^ The cache ID of the class. - , cacheItemProperties :: List.List CacheProperty.CacheProperty - -- ^ The properties that belong to this class. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''CacheItem) - --- | Fields are stored one after the other in order. -instance Binary.Binary CacheItem where - get = CacheItem <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get - put cacheItem = do - cacheItem & #classId & Binary.put - cacheItem & #parentCacheId & Binary.put - cacheItem & #cacheId & Binary.put - cacheItem & #properties & Binary.put - -instance DeepSeq.NFData CacheItem diff --git a/library/Octane/Type/CacheProperty.hs b/library/Octane/Type/CacheProperty.hs deleted file mode 100644 --- a/library/Octane/Type/CacheProperty.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.CacheProperty - ( CacheProperty(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Word32 as Word32 - --- | A property on an item in the class net cache map. -data CacheProperty = CacheProperty - { cachePropertyObjectId :: Word32.Word32 - -- ^ The object's ID. - , cachePropertyStreamId :: Word32.Word32 - -- ^ The object's ID in the network stream. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''CacheProperty) - --- | Fields are stored one after the other in order. -instance Binary.Binary CacheProperty where - get = CacheProperty <$> Binary.get <*> Binary.get - put cacheProperty = do - cacheProperty & #objectId & Binary.put - cacheProperty & #streamId & Binary.put - -instance DeepSeq.NFData CacheProperty diff --git a/library/Octane/Type/ClassItem.hs b/library/Octane/Type/ClassItem.hs deleted file mode 100644 --- a/library/Octane/Type/ClassItem.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.ClassItem - ( ClassItem(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Word32 as Word32 - --- | A class (like @Core.Object@) and it's associated ID in the net stream --- (like @0@). -data ClassItem = ClassItem - { classItemName :: Text.Text - -- ^ The class's name. - , classItemStreamId :: Word32.Word32 - -- ^ The class's ID in the network stream. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''ClassItem) - --- | Fields are stored one after the other in order. -instance Binary.Binary ClassItem where - get = ClassItem <$> Binary.get <*> Binary.get - put classItem = do - classItem & #name & Binary.put - classItem & #streamId & Binary.put - -instance DeepSeq.NFData ClassItem diff --git a/library/Octane/Type/CompressedWord.hs b/library/Octane/Type/CompressedWord.hs --- a/library/Octane/Type/CompressedWord.hs +++ b/library/Octane/Type/CompressedWord.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -18,16 +17,9 @@ import Data.Aeson ((.=)) import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Bits as Bits import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Data as Data -import qualified Octane.Type.Boolean as Boolean -- | A compressed, unsigned integer. When serialized, the least significant bit -- is first. Bits are serialized until the next bit would be greater than the @@ -36,44 +28,10 @@ data CompressedWord = CompressedWord { compressedWordLimit :: Word , compressedWordValue :: Word - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Ord, Show) $(OverloadedRecords.overloadedRecord Default.def ''CompressedWord) --- | Abuses the first argument to 'BinaryBit.getBits' as the maximum value. -instance BinaryBit.BinaryBit CompressedWord where - getBits n = do - let limit = fromIntegral n - value <- getStep limit (bitSize limit) 0 0 - pure (CompressedWord limit value) - putBits _ compressedWord = do - let limit = compressedWord & #limit - let value = compressedWord & #value - if value > limit - then fail ("value " ++ show value ++ " > limit " ++ show limit) - else pure () - let maxBits = bitSize limit - let go position soFar = do - if position < maxBits - then do - let x = Bits.shiftL 1 position - if maxBits > 1 && position == maxBits - 1 && soFar + x > limit - then do - pure () - else do - let bit = position & Bits.testBit value - bit & Boolean.Boolean & BinaryBit.putBits 0 - let delta = - if bit - then x - else 0 - go (position + 1) (soFar + delta) - else do - pure () - go 0 0 - -instance DeepSeq.NFData CompressedWord - -- | Encoded as an object. instance Aeson.ToJSON CompressedWord where toJSON compressedWord = @@ -86,25 +44,3 @@ :: (Integral a) => CompressedWord -> a fromCompressedWord compressedWord = compressedWord & #value & fromIntegral - -bitSize - :: (Integral a, Integral b) - => a -> b -bitSize x = do - let n = x & max 1 & fromIntegral & logBase (2 :: Double) & ceiling & max 1 - if x < Data.maxActorId && x == 2 ^ n - then n + 1 - else n - -getStep :: Word -> Word -> Word -> Word -> BinaryBit.BitGet Word -getStep limit maxBits position value = do - let x = Bits.shiftL 1 (fromIntegral position) - if position < maxBits && value + x <= limit - then do - (bit :: Boolean.Boolean) <- BinaryBit.getBits 0 - let newValue = - if #unpack bit - then value + x - else value - getStep limit maxBits (position + 1) newValue - else pure value diff --git a/library/Octane/Type/Dictionary.hs b/library/Octane/Type/Dictionary.hs --- a/library/Octane/Type/Dictionary.hs +++ b/library/Octane/Type/Dictionary.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,48 +13,19 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Exts as Exts -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text -- | A mapping between text and arbitrary values. newtype Dictionary a = Dictionary { dictionaryUnpack :: (Map.Map Text.Text a) - } deriving (Eq, Generics.Generic) + } deriving (Eq) $(OverloadedRecords.overloadedRecord Default.def ''Dictionary) --- | Elements are stored with the key first, then the value. The dictionary --- ends when a key is @"None"@. -instance (Binary.Binary a) => - Binary.Binary (Dictionary a) where - get = do - element <- getElement - if Map.null element - then element & Dictionary & pure - else do - Dictionary elements <- Binary.get - elements & Map.union element & Dictionary & pure - put dictionary = do - dictionary & #unpack & Map.assocs & mapM_ putElement - noneKey & Binary.put - --- | Allows creating 'Dictionary' values with 'Exts.fromList'. Also allows --- 'Dictionary' literals with the @OverloadedLists@ extension. -instance Exts.IsList (Dictionary a) where - type Item (Dictionary a) = (Text.Text, a) - fromList items = Dictionary (Map.fromList items) - toList dictionary = Map.toList (#unpack dictionary) - -instance (DeepSeq.NFData a) => - DeepSeq.NFData (Dictionary a) - -- | Shown as @fromList [("key","value")]@. instance (Show a) => Show (Dictionary a) where @@ -65,24 +35,3 @@ instance (Aeson.ToJSON a) => Aeson.ToJSON (Dictionary a) where toJSON dictionary = dictionary & #unpack & Map.mapKeys #unpack & Aeson.toJSON - -getElement - :: (Binary.Binary a) - => Binary.Get (Map.Map Text.Text a) -getElement = do - key <- Binary.get - if key == noneKey - then pure Map.empty - else do - value <- Binary.get - value & Map.singleton key & pure - -putElement - :: (Binary.Binary a) - => (Text.Text, a) -> Binary.Put -putElement (key, value) = do - Binary.put key - Binary.put value - -noneKey :: Text.Text -noneKey = "None" diff --git a/library/Octane/Type/Float32.hs b/library/Octane/Type/Float32.hs --- a/library/Octane/Type/Float32.hs +++ b/library/Octane/Type/Float32.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -14,48 +13,16 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.IEEE754 as IEEE754 -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Utility.Endian as Endian -- | A 32-bit float. newtype Float32 = Float32 { float32Unpack :: Float - } deriving (Eq, Fractional, Generics.Generic, Num, Ord) + } deriving (Eq, Fractional, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Float32) - --- | Little-endian. -instance Binary.Binary Float32 where - get = do - value <- IEEE754.getFloat32le - value & Float32 & pure - put float32 = float32 & #unpack & IEEE754.putFloat32le - --- | Little-endian with the bits in each byte reversed. -instance BinaryBit.BinaryBit Float32 where - getBits _ = do - bytes <- BinaryBit.getByteString 4 - bytes & LazyBytes.fromStrict & Endian.reverseBitsInLazyBytes & - Binary.runGet Binary.get & - pure - putBits _ float32 = - float32 & Binary.put & Binary.runPut & Endian.reverseBitsInLazyBytes & - LazyBytes.toStrict & - BinaryBit.putByteString - -instance DeepSeq.NFData Float32 -- | Shown as @12.34@. instance Show Float32 where diff --git a/library/Octane/Type/Frame.hs b/library/Octane/Type/Frame.hs --- a/library/Octane/Type/Frame.hs +++ b/library/Octane/Type/Frame.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -16,13 +15,11 @@ import Data.Aeson ((.=)) import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Float32 as Float32 import qualified Octane.Type.Replication as Replication import qualified Octane.Type.State as State @@ -42,11 +39,9 @@ -- ^ The time between the last frame and this one. , frameReplications :: [Replication.Replication] -- ^ A list of all the replications in this frame. - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''Frame) - -instance DeepSeq.NFData Frame instance Aeson.ToJSON Frame where toJSON frame = diff --git a/library/Octane/Type/Initialization.hs b/library/Octane/Type/Initialization.hs --- a/library/Octane/Type/Initialization.hs +++ b/library/Octane/Type/Initialization.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -10,19 +9,10 @@ module Octane.Type.Initialization ( Initialization(..) - , getInitialization - , putInitialization ) where -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified Data.Set as Set -import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics -import qualified Octane.Data as Data import qualified Octane.Type.Int8 as Int8 import qualified Octane.Type.Vector as Vector @@ -35,34 +25,6 @@ -- ^ The instance's initial position. , initializationRotation :: Maybe (Vector.Vector Int8.Int8) -- ^ The instance's initial rotation. - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''Initialization) - -instance DeepSeq.NFData Initialization - --- | Gets the 'Initialization' for a given class. -getInitialization :: StrictText.Text -> BinaryBit.BitGet Initialization -getInitialization className = do - location <- - if Set.member className Data.classesWithLocation - then fmap Just Vector.getIntVector - else pure Nothing - rotation <- - if Set.member className Data.classesWithRotation - then fmap Just Vector.getInt8Vector - else pure Nothing - pure - Initialization - {initializationLocation = location, initializationRotation = rotation} - --- | Puts the 'Initialization'. Note that unlike 'getInitialization', this does --- not require the class name. -putInitialization :: Initialization -> BinaryBit.BitPut () -putInitialization initialization = do - case #location initialization of - Nothing -> pure () - Just x -> Vector.putIntVector x - case #rotation initialization of - Nothing -> pure () - Just x -> Vector.putInt8Vector x diff --git a/library/Octane/Type/Int32.hs b/library/Octane/Type/Int32.hs --- a/library/Octane/Type/Int32.hs +++ b/library/Octane/Type/Int32.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,50 +15,17 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.Int as Int import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Utility.Endian as Endian -- | A 32-bit signed integer. newtype Int32 = Int32 { int32Unpack :: Int.Int32 - } deriving (Enum, Eq, Generics.Generic, Num, Ord) + } deriving (Enum, Eq, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Int32) - --- | Little-endian. -instance Binary.Binary Int32 where - get = do - value <- Binary.getInt32le - pure (Int32 value) - put int32 = do - let value = #unpack int32 - Binary.putInt32le value - --- | Little-endian with the bits in each byte reversed. -instance BinaryBit.BinaryBit Int32 where - getBits _ = do - bytes <- BinaryBit.getByteString 4 - bytes & LazyBytes.fromStrict & Endian.reverseBitsInLazyBytes & - Binary.runGet Binary.get & - pure - putBits _ int32 = - int32 & Binary.put & Binary.runPut & Endian.reverseBitsInLazyBytes & - LazyBytes.toStrict & - BinaryBit.putByteString - -instance DeepSeq.NFData Int32 -- | Shown as @1234@. instance Show Int32 where diff --git a/library/Octane/Type/Int8.hs b/library/Octane/Type/Int8.hs --- a/library/Octane/Type/Int8.hs +++ b/library/Octane/Type/Int8.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,49 +15,17 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.Int as Int import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Utility.Endian as Endian -- | A 8-bit signed integer. newtype Int8 = Int8 { int8Unpack :: Int.Int8 - } deriving (Eq, Generics.Generic, Num, Ord) + } deriving (Eq, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Int8) - -instance Binary.Binary Int8 where - get = do - value <- Binary.getInt8 - pure (Int8 value) - put int8 = do - let value = #unpack int8 - Binary.putInt8 value - --- | Stored with the bits reversed. -instance BinaryBit.BinaryBit Int8 where - getBits _ = do - bytes <- BinaryBit.getByteString 1 - bytes & LazyBytes.fromStrict & Endian.reverseBitsInLazyBytes & - Binary.runGet Binary.get & - pure - putBits _ int8 = - int8 & Binary.put & Binary.runPut & Endian.reverseBitsInLazyBytes & - LazyBytes.toStrict & - BinaryBit.putByteString - -instance DeepSeq.NFData Int8 -- | Shown as @1234@. instance Show Int8 where diff --git a/library/Octane/Type/KeyFrame.hs b/library/Octane/Type/KeyFrame.hs deleted file mode 100644 --- a/library/Octane/Type/KeyFrame.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.KeyFrame - ( KeyFrame(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Float32 as Float32 -import qualified Octane.Type.Word32 as Word32 - --- | A key frame. -data KeyFrame = KeyFrame - { keyFrameTime :: Float32.Float32 - -- ^ When this key frame occurred. - , keyFrameFrame :: Word32.Word32 - -- ^ Which frame this key frame corresponds to. - , keyFramePosition :: Word32.Word32 - -- ^ The bit position of the start of this key frame in the network stream. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''KeyFrame) - --- | Stored with the fields one after the other in order. -instance Binary.Binary KeyFrame where - get = KeyFrame <$> Binary.get <*> Binary.get <*> Binary.get - put keyFrame = do - keyFrame & #time & Binary.put - keyFrame & #frame & Binary.put - keyFrame & #position & Binary.put - -instance DeepSeq.NFData KeyFrame diff --git a/library/Octane/Type/List.hs b/library/Octane/Type/List.hs --- a/library/Octane/Type/List.hs +++ b/library/Octane/Type/List.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -13,43 +12,16 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq -import qualified Control.Monad as Monad import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Exts as Exts -import qualified GHC.Generics as Generics -import qualified Octane.Type.Word32 as Word32 -- | A list of values. newtype List a = List { listUnpack :: [a] - } deriving (Eq, Generics.Generic, Ord) + } deriving (Eq, Ord) $(OverloadedRecords.overloadedRecord Default.def ''List) - --- | Prefixed with the number of elements in the list. -instance (Binary.Binary a) => - Binary.Binary (List a) where - get = do - size <- Binary.get - elements <- Monad.replicateM (Word32.fromWord32 size) Binary.get - elements & List & pure - put list = do - list & #unpack & length & fromIntegral & Word32.Word32 & Binary.put - list & #unpack & mapM_ Binary.put - --- | Allows creating 'List' values with 'Exts.fromList'. Also allows 'List' --- literals with the @OverloadedLists@ extension. -instance Exts.IsList (List a) where - type Item (List a) = a - fromList items = List items - toList list = #unpack list - -instance (DeepSeq.NFData a) => - DeepSeq.NFData (List a) instance (Show a) => Show (List a) where diff --git a/library/Octane/Type/Mark.hs b/library/Octane/Type/Mark.hs deleted file mode 100644 --- a/library/Octane/Type/Mark.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.Mark - ( Mark(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Word32 as Word32 - --- | A tick mark on the replay. Both goals and saves make tick marks. -data Mark = Mark - { markLabel :: Text.Text - -- ^ The description of the tick mark. Typically something like - -- @"Team0Goal"@ or @"Team1Save"@ or @"User"@. - , markFrame :: Word32.Word32 - -- ^ Which frame this tick mark corresponds to. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''Mark) - --- | Fields are stored one after the other in order. -instance Binary.Binary Mark where - get = Mark <$> Binary.get <*> Binary.get - put mark = do - mark & #label & Binary.put - mark & #frame & Binary.put - -instance DeepSeq.NFData Mark diff --git a/library/Octane/Type/Message.hs b/library/Octane/Type/Message.hs deleted file mode 100644 --- a/library/Octane/Type/Message.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.Message - ( Message(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Word32 as Word32 - --- | A debugging message. Replays do not have any of these anymore. -data Message = Message - { messageFrame :: Word32.Word32 - -- ^ The frame this message corresponds to. - , messageName :: Text.Text - -- ^ The primary player name. - , messageContent :: Text.Text - -- ^ The actual content of the message. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''Message) - --- | Fields stored in order, one after the other. -instance Binary.Binary Message where - get = Message <$> Binary.get <*> Binary.get <*> Binary.get - put message = do - message & #frame & Binary.put - message & #name & Binary.put - message & #content & Binary.put - -instance DeepSeq.NFData Message diff --git a/library/Octane/Type/OptimizedReplay.hs b/library/Octane/Type/OptimizedReplay.hs deleted file mode 100644 --- a/library/Octane/Type/OptimizedReplay.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.OptimizedReplay - ( OptimizedReplay(..) - , fromReplayWithFrames - , toReplayWithFrames - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.CacheItem as CacheItem -import qualified Octane.Type.ClassItem as ClassItem -import qualified Octane.Type.Dictionary as Dictionary -import qualified Octane.Type.Frame as Frame -import qualified Octane.Type.KeyFrame as KeyFrame -import qualified Octane.Type.List as List -import qualified Octane.Type.Mark as Mark -import qualified Octane.Type.Message as Message -import qualified Octane.Type.Property as Property -import qualified Octane.Type.ReplayWithFrames as ReplayWithFrames -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Word32 as Word32 -import qualified Octane.Utility.Optimizer as Optimizer - --- | A fully-processed replay with optimized frames. That means any unnecessary --- replications have been removed. --- --- See 'Octane.Type.Replay.Replay'. -data OptimizedReplay = OptimizedReplay - { optimizedReplayVersion1 :: Word32.Word32 - , optimizedReplayVersion2 :: Word32.Word32 - , optimizedReplayLabel :: Text.Text - , optimizedReplayProperties :: Dictionary.Dictionary Property.Property - , optimizedReplayLevels :: List.List Text.Text - , optimizedReplayKeyFrames :: List.List KeyFrame.KeyFrame - , optimizedReplayFrames :: [Frame.Frame] - , optimizedReplayMessages :: List.List Message.Message - , optimizedReplayMarks :: List.List Mark.Mark - , optimizedReplayPackages :: List.List Text.Text - , optimizedReplayObjects :: List.List Text.Text - , optimizedReplayNames :: List.List Text.Text - , optimizedReplayClasses :: List.List ClassItem.ClassItem - , optimizedReplayCache :: List.List CacheItem.CacheItem - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''OptimizedReplay) - -instance Binary.Binary OptimizedReplay where - get = do - replayWithFrames <- Binary.get - fromReplayWithFrames replayWithFrames - put replay = do - replayWithFrames <- toReplayWithFrames replay - Binary.put replayWithFrames - -instance DeepSeq.NFData OptimizedReplay - --- | Converts a 'ReplayWithFrames.ReplayWithFrames' into an 'OptimizedReplay'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -fromReplayWithFrames - :: (Monad m) - => ReplayWithFrames.ReplayWithFrames -> m OptimizedReplay -fromReplayWithFrames replayWithFrames = do - let frames = replayWithFrames & #frames & Optimizer.optimizeFrames - pure - (OptimizedReplay - (#version1 replayWithFrames) - (#version2 replayWithFrames) - (#label replayWithFrames) - (#properties replayWithFrames) - (#levels replayWithFrames) - (#keyFrames replayWithFrames) - frames - (#messages replayWithFrames) - (#marks replayWithFrames) - (#packages replayWithFrames) - (#objects replayWithFrames) - (#names replayWithFrames) - (#classes replayWithFrames) - (#cache replayWithFrames)) - --- | Converts an 'OptimizedReplay' into a 'ReplayWithFrames.ReplayWithFrames'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -toReplayWithFrames - :: (Monad m) - => OptimizedReplay -> m ReplayWithFrames.ReplayWithFrames -toReplayWithFrames optimizedReplay = do - pure - (ReplayWithFrames.ReplayWithFrames - (#version1 optimizedReplay) - (#version2 optimizedReplay) - (#label optimizedReplay) - (#properties optimizedReplay) - (#levels optimizedReplay) - (#keyFrames optimizedReplay) - (#frames optimizedReplay) - (#messages optimizedReplay) - (#marks optimizedReplay) - (#packages optimizedReplay) - (#objects optimizedReplay) - (#names optimizedReplay) - (#classes optimizedReplay) - (#cache optimizedReplay)) 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -24,11 +23,7 @@ import Octane.Type.Property.QWordProperty import Octane.Type.Property.StrProperty -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified GHC.Generics as Generics -import qualified Octane.Type.Text as Text -- | A metadata property. All properties have a size, but only some actually -- use it. The value stored in the property can be an array, a boolean, and @@ -42,74 +37,7 @@ | PropertyName NameProperty | PropertyQWord QWordProperty | PropertyStr StrProperty - deriving (Eq, Generics.Generic, Show) - --- | Stored with the size first, then the value. -instance Binary.Binary Property where - get = do - kind <- Binary.get - case kind of - _ - | kind == arrayProperty -> do - array <- Binary.get - pure (PropertyArray array) - _ - | kind == boolProperty -> do - bool <- Binary.get - pure (PropertyBool bool) - _ - | kind == byteProperty -> do - byte <- Binary.get - pure (PropertyByte byte) - _ - | kind == floatProperty -> do - float <- Binary.get - pure (PropertyFloat float) - _ - | kind == intProperty -> do - int <- Binary.get - pure (PropertyInt int) - _ - | kind == nameProperty -> do - name <- Binary.get - pure (PropertyName name) - _ - | kind == qWordProperty -> do - qWord <- Binary.get - pure (PropertyQWord qWord) - _ - | kind == strProperty -> do - str <- Binary.get - pure (PropertyStr str) - _ -> fail ("unknown property type " ++ show (#unpack kind)) - put property = - case property of - PropertyArray array -> do - Binary.put arrayProperty - Binary.put array - PropertyBool bool -> do - Binary.put boolProperty - Binary.put bool - PropertyByte byte -> do - Binary.put byteProperty - Binary.put byte - PropertyFloat float -> do - Binary.put floatProperty - Binary.put float - PropertyInt int -> do - Binary.put intProperty - Binary.put int - PropertyName name -> do - Binary.put nameProperty - Binary.put name - PropertyQWord qWord -> do - Binary.put qWordProperty - Binary.put qWord - PropertyStr str -> do - Binary.put strProperty - Binary.put str - -instance DeepSeq.NFData Property + deriving (Eq, Show) instance Aeson.ToJSON Property where toJSON property = @@ -122,27 +50,3 @@ PropertyName x -> Aeson.toJSON x PropertyQWord x -> Aeson.toJSON x PropertyStr x -> Aeson.toJSON x - -arrayProperty :: Text.Text -arrayProperty = "ArrayProperty" - -boolProperty :: Text.Text -boolProperty = "BoolProperty" - -byteProperty :: Text.Text -byteProperty = "ByteProperty" - -floatProperty :: Text.Text -floatProperty = "FloatProperty" - -intProperty :: Text.Text -intProperty = "IntProperty" - -nameProperty :: Text.Text -nameProperty = "NameProperty" - -qWordProperty :: Text.Text -qWordProperty = "QWordProperty" - -strProperty :: Text.Text -strProperty = "StrProperty" diff --git a/library/Octane/Type/Property/ArrayProperty.hs b/library/Octane/Type/Property/ArrayProperty.hs --- a/library/Octane/Type/Property/ArrayProperty.hs +++ b/library/Octane/Type/Property/ArrayProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,14 +13,10 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Dictionary as Dictionary import qualified Octane.Type.List as List import qualified Octane.Type.Text as Text @@ -30,22 +25,9 @@ data ArrayProperty a = ArrayProperty { arrayPropertySize :: Word64.Word64 , arrayPropertyContent :: List.List (Dictionary.Dictionary a) - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''ArrayProperty) - -instance (Binary.Binary a) => - Binary.Binary (ArrayProperty a) where - get = do - size <- Binary.get - content <- Binary.get - pure (ArrayProperty size content) - put array = do - array & #size & Binary.put - array & #content & Binary.put - -instance (DeepSeq.NFData a) => - DeepSeq.NFData (ArrayProperty a) instance (Aeson.ToJSON a) => Aeson.ToJSON (ArrayProperty a) where diff --git a/library/Octane/Type/Property/BoolProperty.hs b/library/Octane/Type/Property/BoolProperty.hs --- a/library/Octane/Type/Property/BoolProperty.hs +++ b/library/Octane/Type/Property/BoolProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,14 +13,10 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 @@ -29,20 +24,9 @@ data BoolProperty = BoolProperty { boolPropertySize :: Word64.Word64 , boolPropertyContent :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''BoolProperty) - -instance Binary.Binary BoolProperty where - get = do - size <- Binary.get - content <- Binary.get - pure (BoolProperty size content) - put bool = do - bool & #size & Binary.put - bool & #content & Binary.put - -instance DeepSeq.NFData BoolProperty instance Aeson.ToJSON BoolProperty where toJSON bool = diff --git a/library/Octane/Type/Property/ByteProperty.hs b/library/Octane/Type/Property/ByteProperty.hs --- a/library/Octane/Type/Property/ByteProperty.hs +++ b/library/Octane/Type/Property/ByteProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,14 +13,10 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 @@ -29,26 +24,9 @@ { bytePropertySize :: Word64.Word64 , bytePropertyKey :: Text.Text , bytePropertyValue :: Text.Text - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''ByteProperty) - -instance Binary.Binary ByteProperty where - get = do - size <- Binary.get - key <- Binary.get - if key == "OnlinePlatform_Steam" - then do - pure (ByteProperty size "OnlinePlatform" key) - else do - value <- Binary.get - pure (ByteProperty size key value) - put byte = do - byte & #size & Binary.put - byte & #key & Binary.put - byte & #value & Binary.put - -instance DeepSeq.NFData ByteProperty instance Aeson.ToJSON ByteProperty where toJSON byte = diff --git a/library/Octane/Type/Property/FloatProperty.hs b/library/Octane/Type/Property/FloatProperty.hs --- a/library/Octane/Type/Property/FloatProperty.hs +++ b/library/Octane/Type/Property/FloatProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,14 +13,10 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Float32 as Float32 import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 @@ -29,23 +24,9 @@ data FloatProperty = FloatProperty { floatPropertySize :: Word64.Word64 , floatPropertyContent :: Float32.Float32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''FloatProperty) - -instance Binary.Binary FloatProperty where - get = do - size <- Binary.get - content <- - case #unpack size of - 4 -> Binary.get - x -> fail ("unknown FloatProperty size " ++ show x) - pure (FloatProperty size content) - put float = do - float & #size & Binary.put - float & #content & Binary.put - -instance DeepSeq.NFData FloatProperty instance Aeson.ToJSON FloatProperty where toJSON float = diff --git a/library/Octane/Type/Property/IntProperty.hs b/library/Octane/Type/Property/IntProperty.hs --- a/library/Octane/Type/Property/IntProperty.hs +++ b/library/Octane/Type/Property/IntProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,14 +13,10 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Int32 as Int32 import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 @@ -29,23 +24,9 @@ data IntProperty = IntProperty { intPropertySize :: Word64.Word64 , intPropertyContent :: Int32.Int32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''IntProperty) - -instance Binary.Binary IntProperty where - get = do - size <- Binary.get - content <- - case #unpack size of - 4 -> Binary.get - x -> fail ("unknown IntProperty size " ++ show x) - pure (IntProperty size content) - put int = do - int & #size & Binary.put - int & #content & Binary.put - -instance DeepSeq.NFData IntProperty instance Aeson.ToJSON IntProperty where toJSON int = diff --git a/library/Octane/Type/Property/NameProperty.hs b/library/Octane/Type/Property/NameProperty.hs --- a/library/Octane/Type/Property/NameProperty.hs +++ b/library/Octane/Type/Property/NameProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,34 +13,19 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 data NameProperty = NameProperty { namePropertySize :: Word64.Word64 , namePropertyContent :: Text.Text - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''NameProperty) - -instance Binary.Binary NameProperty where - get = do - size <- Binary.get - content <- Binary.get - pure (NameProperty size content) - put name = do - name & #size & Binary.put - name & #content & Binary.put - -instance DeepSeq.NFData NameProperty instance Aeson.ToJSON NameProperty where toJSON name = diff --git a/library/Octane/Type/Property/QWordProperty.hs b/library/Octane/Type/Property/QWordProperty.hs --- a/library/Octane/Type/Property/QWordProperty.hs +++ b/library/Octane/Type/Property/QWordProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,37 +13,19 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 data QWordProperty = QWordProperty { qWordPropertySize :: Word64.Word64 , qWordPropertyContent :: Word64.Word64 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''QWordProperty) - -instance Binary.Binary QWordProperty where - get = do - size <- Binary.get - content <- - case #unpack size of - 8 -> Binary.get - x -> fail ("unknown QWordProperty size " ++ show x) - pure (QWordProperty size content) - put qWord = do - qWord & #size & Binary.put - qWord & #content & Binary.put - -instance DeepSeq.NFData QWordProperty instance Aeson.ToJSON QWordProperty where toJSON qWord = diff --git a/library/Octane/Type/Property/StrProperty.hs b/library/Octane/Type/Property/StrProperty.hs --- a/library/Octane/Type/Property/StrProperty.hs +++ b/library/Octane/Type/Property/StrProperty.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,34 +13,19 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text import qualified Octane.Type.Word64 as Word64 data StrProperty = StrProperty { strPropertySize :: Word64.Word64 , strPropertyContent :: Text.Text - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''StrProperty) - -instance Binary.Binary StrProperty where - get = do - size <- Binary.get - content <- Binary.get - pure (StrProperty size content) - put str = do - str & #size & Binary.put - str & #content & Binary.put - -instance DeepSeq.NFData StrProperty instance Aeson.ToJSON StrProperty where toJSON x = diff --git a/library/Octane/Type/RawReplay.hs b/library/Octane/Type/RawReplay.hs deleted file mode 100644 --- a/library/Octane/Type/RawReplay.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.RawReplay - ( RawReplay(..) - , newRawReplay - ) where - -import qualified Control.DeepSeq as DeepSeq -import qualified Control.Monad as Monad -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Utility.CRC as CRC -import qualified Octane.Type.Word32 as Word32 -import qualified Text.Printf as Printf - --- | A raw, unprocessed replay. Only enough parsing is done to make sure that --- the CRCs are valid. --- --- See 'Octane.Type.ReplayWithoutFrames.ReplayWithoutFrames'. -data RawReplay = RawReplay - { rawReplayHeaderSize :: Word32.Word32 - -- ^ The byte size of the first section. - , rawReplayHeaderCRC :: Word32.Word32 - -- ^ The CRC of the first section. - , rawReplayHeader :: LazyBytes.ByteString - -- ^ The first section. - , rawReplayContentSize :: Word32.Word32 - -- ^ The byte size of the second section. - , rawReplayContentCRC :: Word32.Word32 - -- ^ The CRC of the second section. - , rawReplayContent :: LazyBytes.ByteString - -- ^ The second section. - , rawReplayFooter :: LazyBytes.ByteString - -- ^ Arbitrary data after the second section. In replays generated by - -- Rocket League, this is always empty. However it is not technically - -- invalid to put something here. - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''RawReplay) - --- | Decoding will fail if the CRCs don't match, but it is possible to encode --- invalid replays. That means @decode (encode rawReplay)@ can fail. -instance Binary.Binary RawReplay where - get = do - headerSize <- Binary.get - headerCRC <- Binary.get - header <- Binary.getLazyByteString (Word32.fromWord32 headerSize) - checkCRC headerCRC header - contentSize <- Binary.get - contentCRC <- Binary.get - content <- Binary.getLazyByteString (Word32.fromWord32 contentSize) - checkCRC contentCRC content - footer <- Binary.getRemainingLazyByteString - pure - (RawReplay - headerSize - headerCRC - header - contentSize - contentCRC - content - footer) - put replay = do - Binary.put (#headerSize replay) - Binary.put (#headerCRC replay) - Binary.putLazyByteString (#header replay) - Binary.put (#contentSize replay) - Binary.put (#contentCRC replay) - Binary.putLazyByteString (#content replay) - Binary.putLazyByteString (#footer replay) - -instance DeepSeq.NFData RawReplay - --- | Creates a new 'RawReplay'. You should prefer this over directly using the --- constructor so that the sizes and CRCs are set correctly. -newRawReplay - :: LazyBytes.ByteString -- ^ The header. - -> LazyBytes.ByteString -- ^ The content. - -> LazyBytes.ByteString -- ^ The footer. - -> RawReplay -newRawReplay header content footer = do - let headerSize = Word32.toWord32 (LazyBytes.length header) - let headerCRC = Word32.Word32 (CRC.crc32 header) - let contentSize = Word32.toWord32 (LazyBytes.length content) - let contentCRC = Word32.Word32 (CRC.crc32 content) - RawReplay headerSize headerCRC header contentSize contentCRC content footer - -checkCRC - :: (Monad m) - => Word32.Word32 -> LazyBytes.ByteString -> m () -checkCRC (Word32.Word32 expected) bytes = do - let actual = CRC.crc32 bytes - Monad.when - (actual /= expected) - (do let message = - Printf.printf - "CRC 0x%08x does not equal expected value 0x%08x" - actual - expected - fail message) diff --git a/library/Octane/Type/RemoteId.hs b/library/Octane/Type/RemoteId.hs --- a/library/Octane/Type/RemoteId.hs +++ b/library/Octane/Type/RemoteId.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} module Octane.Type.RemoteId @@ -14,9 +13,7 @@ import Octane.Type.RemoteId.SteamId import Octane.Type.RemoteId.XboxId -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified GHC.Generics as Generics -- | A player's canonical remote ID. This is the best way to uniquely identify -- players @@ -25,9 +22,7 @@ | RemoteSplitscreenId SplitscreenId | RemoteSteamId SteamId | RemoteXboxId XboxId - deriving (Eq, Generics.Generic, Show) - -instance DeepSeq.NFData RemoteId + deriving (Eq, Show) instance Aeson.ToJSON RemoteId where toJSON remoteId = diff --git a/library/Octane/Type/RemoteId/PlayStationId.hs b/library/Octane/Type/RemoteId/PlayStationId.hs --- a/library/Octane/Type/RemoteId/PlayStationId.hs +++ b/library/Octane/Type/RemoteId/PlayStationId.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -16,51 +15,20 @@ import Data.Aeson ((.=)) import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified Data.Text.Encoding as Encoding -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text -import qualified Octane.Utility.Endian as Endian import qualified Text.Printf as Printf data PlayStationId = PlayStationId { playStationIdName :: Text.Text , playStationIdUnknown :: LazyBytes.ByteString - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''PlayStationId) - --- | Each part is stored as exactly 16 bits. -instance BinaryBit.BinaryBit PlayStationId where - getBits _ = do - nameBytes <- BinaryBit.getByteString 16 - let name = - nameBytes & Endian.reverseBitsInStrictBytes & Encoding.decodeLatin1 & - StrictText.dropWhileEnd (== '\0') & - Text.Text - unknownBytes <- BinaryBit.getByteString 16 - let unknown = - unknownBytes & Endian.reverseBitsInStrictBytes & LazyBytes.fromStrict - pure (PlayStationId name unknown) - putBits _ playStationId = do - playStationId & #name & #unpack & StrictText.justifyLeft 16 '\x00' & - StrictText.take 16 & - Text.encodeLatin1 & - Endian.reverseBitsInStrictBytes & - BinaryBit.putByteString - playStationId & #unknown & LazyBytes.toStrict & - Endian.reverseBitsInStrictBytes & - BinaryBit.putByteString - -instance DeepSeq.NFData PlayStationId instance Aeson.ToJSON PlayStationId where toJSON playStationId = diff --git a/library/Octane/Type/RemoteId/SplitscreenId.hs b/library/Octane/Type/RemoteId/SplitscreenId.hs --- a/library/Octane/Type/RemoteId/SplitscreenId.hs +++ b/library/Octane/Type/RemoteId/SplitscreenId.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,35 +13,16 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics newtype SplitscreenId = SplitscreenId { splitscreenIdUnpack :: Maybe Int - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''SplitscreenId) - --- | Stored as a bare byte string. -instance BinaryBit.BinaryBit SplitscreenId where - getBits _ = do - bytes <- BinaryBit.getByteString 3 - case bytes of - "\x00\x00\x00" -> do - pure (SplitscreenId (Just 0)) - _ -> do - fail ("Unexpected SplitscreenId value " ++ show bytes) - putBits _ _splitscreenId = do - BinaryBit.putByteString "\x00\x00\x00" - -instance DeepSeq.NFData SplitscreenId instance Aeson.ToJSON SplitscreenId where toJSON splitscreenId = diff --git a/library/Octane/Type/RemoteId/SteamId.hs b/library/Octane/Type/RemoteId/SteamId.hs --- a/library/Octane/Type/RemoteId/SteamId.hs +++ b/library/Octane/Type/RemoteId/SteamId.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -13,31 +12,18 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary.Bits as BinaryBit import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Word64 as Word64 newtype SteamId = SteamId { steamIdUnpack :: Word64.Word64 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''SteamId) - --- | Stored as a plain 'Word64.Word64'. -instance BinaryBit.BinaryBit SteamId where - getBits _ = do - steamId <- BinaryBit.getBits 0 - pure (SteamId steamId) - putBits _ steamId = steamId & #unpack & BinaryBit.putBits 0 - -instance DeepSeq.NFData SteamId instance Aeson.ToJSON SteamId where toJSON steamId = diff --git a/library/Octane/Type/RemoteId/XboxId.hs b/library/Octane/Type/RemoteId/XboxId.hs --- a/library/Octane/Type/RemoteId/XboxId.hs +++ b/library/Octane/Type/RemoteId/XboxId.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -13,31 +12,18 @@ ) where import Data.Aeson ((.=)) -import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary.Bits as BinaryBit import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Word64 as Word64 newtype XboxId = XboxId { xboxIdUnpack :: Word64.Word64 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''XboxId) - --- | Stored as a plain 'Word64.Word64'. -instance BinaryBit.BinaryBit XboxId where - getBits _ = do - xboxId <- BinaryBit.getBits 0 - pure (XboxId xboxId) - putBits _ xboxId = xboxId & #unpack & BinaryBit.putBits 0 - -instance DeepSeq.NFData XboxId instance Aeson.ToJSON XboxId where toJSON xboxId = diff --git a/library/Octane/Type/Replay.hs b/library/Octane/Type/Replay.hs --- a/library/Octane/Type/Replay.hs +++ b/library/Octane/Type/Replay.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,43 +10,47 @@ module Octane.Type.Replay ( Replay(..) - , fromOptimizedReplay - , toOptimizedReplay ) where import Data.Aeson ((.=)) import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Binary as Binary +import qualified Data.Bits as Bits +import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified Data.Set as Set import qualified Data.Text as StrictText -import qualified Data.Tuple as Tuple +import qualified Data.Text.Encoding as Encoding import qualified Data.Version as Version -import qualified GHC.Generics as Generics -import qualified Octane.Data as Data -import qualified Octane.Type.CacheItem as CacheItem -import qualified Octane.Type.CacheProperty as CacheProperty -import qualified Octane.Type.ClassItem as ClassItem +import qualified Octane.Type.Boolean as Boolean +import qualified Octane.Type.CompressedWord as CompressedWord import qualified Octane.Type.Dictionary as Dictionary +import qualified Octane.Type.Float32 as Float32 import qualified Octane.Type.Frame as Frame -import qualified Octane.Type.KeyFrame as KeyFrame +import qualified Octane.Type.Initialization as Initialization +import qualified Octane.Type.Int32 as Int32 +import qualified Octane.Type.Int8 as Int8 import qualified Octane.Type.List as List -import qualified Octane.Type.Mark as Mark -import qualified Octane.Type.Message as Message -import qualified Octane.Type.OptimizedReplay as OptimizedReplay import qualified Octane.Type.Property as Property +import qualified Octane.Type.RemoteId as RemoteId +import qualified Octane.Type.Replication as Replication +import qualified Octane.Type.State as State import qualified Octane.Type.Text as Text +import qualified Octane.Type.Value as Value +import qualified Octane.Type.Vector as Vector +import qualified Octane.Type.Word16 as Word16 import qualified Octane.Type.Word32 as Word32 +import qualified Octane.Type.Word64 as Word64 +import qualified Octane.Type.Word8 as Word8 +import qualified Octane.Utility.Endian as Endian +import qualified Octane.Utility.Optimizer as Optimizer +import qualified Rattletrap --- | A fully-processed, optimized replay. This is the nicest format for humans --- to work with. It can be converted all the way back down to a --- 'Octane.Type.RawReplay.RawReplay' for serialization. +-- | A fully-processed, optimized replay. data Replay = Replay { replayVersion :: Version.Version , replayMetadata :: Map.Map StrictText.Text Property.Property @@ -95,19 +98,16 @@ , replayTickMarks :: Map.Map StrictText.Text StrictText.Text , replayPackages :: [StrictText.Text] , replayFrames :: [Frame.Frame] - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''Replay) instance Binary.Binary Replay where get = do - optimizedReplay <- Binary.get - fromOptimizedReplay optimizedReplay - put replay = do - optimizedReplay <- toOptimizedReplay replay - Binary.put optimizedReplay - -instance DeepSeq.NFData Replay + rawReplay <- Rattletrap.getReplay + let replay = fromRawReplay rawReplay + pure replay + put = undefined instance Aeson.ToJSON Replay where toJSON replay = @@ -121,147 +121,491 @@ , "Frames" .= #frames replay ] --- | Converts an 'OptimizedReplay.OptimizedReplay' into a 'Replay'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -fromOptimizedReplay - :: (Monad m) - => OptimizedReplay.OptimizedReplay -> m Replay -fromOptimizedReplay optimizedReplay = do - pure - Replay - { replayVersion = - [#version1 optimizedReplay, #version2 optimizedReplay] & - map Word32.fromWord32 & +fromRawReplay :: Rattletrap.Replay -> Replay +fromRawReplay replay = + let header = replay & Rattletrap.replayHeader & Rattletrap.sectionBody + fromWord32 x = x & Rattletrap.word32Value & fromIntegral + content = replay & Rattletrap.replayContent & Rattletrap.sectionBody + version = Version.makeVersion - , replayMetadata = - optimizedReplay & #properties & #unpack & Map.mapKeys #unpack - , replayLevels = optimizedReplay & #levels & #unpack & map #unpack - , replayMessages = - optimizedReplay & #messages & #unpack & + [ header & Rattletrap.headerEngineVersion & fromWord32 + , header & Rattletrap.headerLicenseeVersion & fromWord32 + ] + metadata = + header & Rattletrap.headerProperties & Rattletrap.dictionaryValue & + Maybe.mapMaybe + (\(key, maybeValue) -> + case maybeValue of + Nothing -> Nothing + Just value -> + Just + ( key & Rattletrap.textToString & StrictText.pack + , toProperty value)) & + Map.fromList + levels = + content & Rattletrap.contentLevels & Rattletrap.listValue & + map Rattletrap.textToString & + map StrictText.pack + messages = + content & Rattletrap.contentMessages & Rattletrap.listValue & map - (\message -> do - let key = message & #frame & #unpack & show & StrictText.pack - let value = message & #content & #unpack - (key, value)) & + (\message -> + ( message & Rattletrap.messageFrame & Rattletrap.word32Value & show & + StrictText.pack + , message & Rattletrap.messageValue & Rattletrap.textToString & + StrictText.pack)) & Map.fromList - , replayTickMarks = - optimizedReplay & #marks & #unpack & + tickMarks = + content & Rattletrap.contentMarks & Rattletrap.listValue & map - (\mark -> do - let key = mark & #frame & #unpack & show & StrictText.pack - let value = mark & #label & #unpack - (key, value)) & + (\mark -> + ( mark & Rattletrap.markFrame & Rattletrap.word32Value & show & + StrictText.pack + , mark & Rattletrap.markValue & Rattletrap.textToString & + StrictText.pack)) & Map.fromList - , replayPackages = optimizedReplay & #packages & #unpack & map #unpack - , replayFrames = optimizedReplay & #frames - } + packages = + content & Rattletrap.contentPackages & Rattletrap.listValue & + map Rattletrap.textToString & + map StrictText.pack + (frames, _actorMap) = + content & Rattletrap.contentFrames & zip [0 ..] & + foldl + (\(fs, m) f -> + let (f', m') = toFrame m f + in (f' : fs, m')) + ([], Map.empty) + in Replay + { replayVersion = version + , replayMetadata = metadata + , replayLevels = levels + , replayMessages = messages + , replayTickMarks = tickMarks + , replayPackages = packages + , replayFrames = frames & reverse & Optimizer.optimizeFrames + } --- | Converts a 'Replay' into an 'OptimizedReplay.OptimizedReplay'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -toOptimizedReplay - :: (Monad m) - => Replay -> m OptimizedReplay.OptimizedReplay -toOptimizedReplay replay - -- Key frames aren't important for replays. Mark the first frame as a key - -- frame and the rest as regular frames. - = do - let frames = - replay & #frames & zip [0 :: Int ..] & - map (\(index, frame) -> frame {Frame.frameIsKeyFrame = index == 0}) - -- The actors are a list of all classes, objects, and properties used in the - -- replay. An actor's position in this list is their ID, not their stream ID. - let classNames = - frames & concatMap #replications & map #className & ("Core.Object" :) & - Set.fromList - let objectNames = - frames & concatMap #replications & map #objectName & Set.fromList - let propertyNames = - frames & concatMap #replications & map #properties & concatMap Map.keys & - Set.fromList - let actors = - classNames & Set.union objectNames & Set.union propertyNames & - Set.toAscList & - map Text.Text & - List.List - -- The class items are a list of class names to their stream IDs. - let classItems = - classNames & Set.toAscList & map Text.Text & zip [0 ..] & - map (\(streamId, name) -> do ClassItem.ClassItem name streamId) & - List.List - -- The cache items are a list of classes together with their cache IDs, - -- parent cache IDs, and a list of their property IDs to stream IDs. - let classesToId = - classItems & #unpack & map (\x -> (#name x, #streamId x)) & Map.fromList - let actorsToId = actors & #unpack & zip [0 ..] & map Tuple.swap & Map.fromList - let propertiesByClass = - frames & concatMap #replications & - concatMap - (\replication -> - zip - (replication & #className & Text.Text & repeat) - (replication & #properties & Map.keys & map Text.Text)) & - Set.fromList & - Set.toAscList & - zip [0 ..] & - map - (\(streamId, (className, propertyName)) -> do - let propertyId = - actorsToId & Map.lookup propertyName & Maybe.fromJust - let cacheProperty = CacheProperty.CacheProperty propertyId streamId - let cacheProperties = [cacheProperty] - (className, cacheProperties)) & - Map.fromListWith (++) - let cacheItems = - classItems & #unpack & zip [0 ..] & - map - (\(cacheId, classItem) -> do - let className = #name classItem - let classId = classesToId & Map.lookup className & Maybe.fromJust - let parentCacheId = 0 -- cacheId - let properties = - propertiesByClass & Map.findWithDefault [] className & - List.List - CacheItem.CacheItem classId parentCacheId cacheId properties) & - List.List - pure - OptimizedReplay.OptimizedReplay - { OptimizedReplay.optimizedReplayVersion1 = Data.latestMajorVersion - , OptimizedReplay.optimizedReplayVersion2 = Data.latestMinorVersion - , OptimizedReplay.optimizedReplayLabel = "TAGame.Replay_Soccar_TA" - , OptimizedReplay.optimizedReplayProperties = - replay & #metadata & Map.mapKeys Text.Text & Dictionary.Dictionary - , OptimizedReplay.optimizedReplayLevels = - replay & #levels & map Text.Text & List.List - , OptimizedReplay.optimizedReplayKeyFrames = - frames & filter #isKeyFrame & - map - (\frame -> - KeyFrame.KeyFrame - (#time frame) - (frame & #number & Word32.toWord32) - 0) & - List.List - , OptimizedReplay.optimizedReplayFrames = frames - , OptimizedReplay.optimizedReplayMessages = - replay & #messages & Map.toList & - map - (\(key, value) -> do - let frame = key & StrictText.unpack & read & Word32.Word32 - let content = value & Text.Text - Message.Message frame "" content) & - List.List - , OptimizedReplay.optimizedReplayMarks = - replay & #tickMarks & Map.toList & - map - (\(key, value) -> do - let label = value & Text.Text - let frame = key & StrictText.unpack & read & Word32.Word32 - Mark.Mark label frame) & - List.List - , OptimizedReplay.optimizedReplayPackages = - replay & #packages & map Text.Text & List.List - , OptimizedReplay.optimizedReplayObjects = actors - , OptimizedReplay.optimizedReplayNames = List.List [] -- TODO - , OptimizedReplay.optimizedReplayClasses = classItems - , OptimizedReplay.optimizedReplayCache = cacheItems - } +toProperty :: Rattletrap.Property -> Property.Property +toProperty property = + let size = + property & Rattletrap.propertySize & Rattletrap.word64Value & + Word64.Word64 + in case Rattletrap.propertyValue property of + Rattletrap.ArrayProperty x -> + let content = + x & Rattletrap.listValue & + map + (\y -> + y & Rattletrap.dictionaryValue & + Maybe.mapMaybe + (\(k, mv) -> + case mv of + Nothing -> Nothing + Just v -> Just (toText k, toProperty v)) & + Map.fromList & + Dictionary.Dictionary) & + List.List + in Property.PropertyArray (Property.ArrayProperty size content) + Rattletrap.BoolProperty x -> + let content = x & Rattletrap.word8Value & (/= 0) & Boolean.Boolean + in Property.PropertyBool (Property.BoolProperty size content) + Rattletrap.ByteProperty k mv -> + let (key, value) = + case mv of + Nothing -> ("OnlinePlatform", toText k) + Just v -> (toText k, toText v) + in Property.PropertyByte (Property.ByteProperty size key value) + Rattletrap.FloatProperty x -> + let content = toFloat32 x + in Property.PropertyFloat (Property.FloatProperty size content) + Rattletrap.IntProperty x -> + let content = x & Rattletrap.int32Value & Int32.Int32 + in Property.PropertyInt (Property.IntProperty size content) + Rattletrap.NameProperty x -> + let content = toText x + in Property.PropertyName (Property.NameProperty size content) + Rattletrap.QWordProperty x -> + let content = x & Rattletrap.word64Value & Word64.Word64 + in Property.PropertyQWord (Property.QWordProperty size content) + Rattletrap.StrProperty x -> + let content = toText x + in Property.PropertyStr (Property.StrProperty size content) + +toText :: Rattletrap.Text -> Text.Text +toText text = text & Rattletrap.textToString & StrictText.pack & Text.Text + +type ActorMap = Map.Map CompressedWord.CompressedWord (StrictText.Text, StrictText.Text) + +toFrame :: ActorMap -> (Word, Rattletrap.Frame) -> (Frame.Frame, ActorMap) +toFrame actorMap (number, frame) = + let (replications, newActorMap) = + frame & Rattletrap.frameReplications & + foldl + (\(rs, m) r -> + let (r', m') = toReplication m r + in (r' : rs, m')) + ([], actorMap) + newFrame = + Frame.Frame + { Frame.frameNumber = number + , Frame.frameIsKeyFrame = number == 0 + , Frame.frameTime = frame & Rattletrap.frameTime & toFloat32 + , Frame.frameDelta = frame & Rattletrap.frameDelta & toFloat32 + , Frame.frameReplications = reverse replications + } + in (newFrame, newActorMap) + +toFloat32 :: Rattletrap.Float32 -> Float32.Float32 +toFloat32 float32 = float32 & Rattletrap.float32Value & Float32.Float32 + +toReplication :: ActorMap + -> Rattletrap.Replication + -> (Replication.Replication, ActorMap) +toReplication actorMap replication = + let actorId = replication & Rattletrap.replicationActorId & toCompressedWord + replicationValue = Rattletrap.replicationValue replication + maybeNames = + case replicationValue of + Rattletrap.SpawnedReplicationValue spawned -> + Just + ( spawned & Rattletrap.spawnedReplication_objectName & + Rattletrap.textToString & + StrictText.pack + , spawned & Rattletrap.spawnedReplication_className & + Rattletrap.textToString & + StrictText.pack) + _ -> Nothing + newActorMap = + case maybeNames of + Nothing -> actorMap + Just names -> Map.insert actorId names actorMap + objectName = + newActorMap & Map.lookup actorId & fmap fst & Maybe.fromMaybe "unknown" + className = + newActorMap & Map.lookup actorId & fmap snd & Maybe.fromMaybe "unknown" + newReplication = + Replication.Replication + { Replication.replicationActorId = actorId + , Replication.replicationObjectName = objectName + , Replication.replicationClassName = className + , Replication.replicationState = + case replicationValue of + Rattletrap.SpawnedReplicationValue _ -> State.Opening + Rattletrap.UpdatedReplicationValue _ -> State.Existing + Rattletrap.DestroyedReplicationValue _ -> State.Closing + , Replication.replicationInitialization = + case replicationValue of + Rattletrap.SpawnedReplicationValue value -> + Just + Initialization.Initialization + { Initialization.initializationLocation = + value & Rattletrap.spawnedReplicationInitialization & + Rattletrap.initializationLocation & + fmap toIntVector + , Initialization.initializationRotation = + value & Rattletrap.spawnedReplicationInitialization & + Rattletrap.initializationRotation & + fmap toInt8Vector + } + _ -> Nothing + , Replication.replicationProperties = + case replicationValue of + Rattletrap.UpdatedReplicationValue updated -> + updated & Rattletrap.updatedReplicationAttributes & map toValue & + Map.fromList + _ -> Map.empty + } + in (newReplication, newActorMap) + +toValue :: Rattletrap.Attribute -> (StrictText.Text, Value.Value) +toValue attribute = + let key = + attribute & Rattletrap.attribute_name & Rattletrap.textToString & + StrictText.pack + value = + case Rattletrap.attributeValue attribute of + Rattletrap.BooleanAttributeValue x -> + Value.ValueBoolean + (Value.BooleanValue + (Boolean.Boolean (Rattletrap.booleanAttributeValue x))) + Rattletrap.ByteAttributeValue x -> + Value.ValueByte + (Value.ByteValue + (Word8.Word8 + (Rattletrap.word8Value (Rattletrap.byteAttributeValue x)))) + Rattletrap.CamSettingsAttributeValue x -> + Value.ValueCamSettings + (Value.CamSettingsValue + (toFloat32 (Rattletrap.camSettingsAttributeFov x)) + (toFloat32 (Rattletrap.camSettingsAttributeHeight x)) + (toFloat32 (Rattletrap.camSettingsAttributeAngle x)) + (toFloat32 (Rattletrap.camSettingsAttributeDistance x)) + (toFloat32 (Rattletrap.camSettingsAttributeStiffness x)) + (toFloat32 (Rattletrap.camSettingsAttributeSwivelSpeed x))) + Rattletrap.ClubColorsAttributeValue x -> + Value.ValueClubColors + (Value.ClubColorsValue + (Boolean.Boolean (Rattletrap.clubColorsAttributeBlueFlag x)) + (toWord8 (Rattletrap.clubColorsAttributeBlueColor x)) + (Boolean.Boolean (Rattletrap.clubColorsAttributeOrangeFlag x)) + (toWord8 (Rattletrap.clubColorsAttributeOrangeColor x))) + Rattletrap.DemolishAttributeValue x -> + Value.ValueDemolish + (Value.DemolishValue + (Boolean.Boolean (Rattletrap.demolishAttributeAttackerFlag x)) + (toWord32 (Rattletrap.demolishAttributeAttackerActorId x)) + (Boolean.Boolean (Rattletrap.demolishAttributeVictimFlag x)) + (toWord32 (Rattletrap.demolishAttributeVictimActorId x)) + (toIntVector (Rattletrap.demolishAttributeAttackerVelocity x)) + (toIntVector (Rattletrap.demolishAttributeVictimVelocity x))) + Rattletrap.EnumAttributeValue x -> + Value.ValueEnum + (Value.EnumValue + (Word16.Word16 (Rattletrap.enumAttributeValue x)) + (Boolean.Boolean False)) + Rattletrap.ExplosionAttributeValue x -> + Value.ValueExplosion + (Value.ExplosionValue + (Boolean.Boolean False) + (Just (toInt32 (Rattletrap.explosionAttributeActorId x))) + (toIntVector (Rattletrap.explosionAttributeLocation x))) + Rattletrap.FlaggedIntAttributeValue x -> + Value.ValueFlaggedInt + (Value.FlaggedIntValue + (Boolean.Boolean (Rattletrap.flaggedIntAttributeFlag x)) + (toInt32 (Rattletrap.flaggedIntAttributeInt x))) + Rattletrap.FloatAttributeValue x -> + Value.ValueFloat + (Value.FloatValue (toFloat32 (Rattletrap.floatAttributeValue x))) + Rattletrap.GameModeAttributeValue x -> + Value.ValueGameMode + (Value.GameModeValue + (Word8.Word8 (Rattletrap.gameModeAttributeWord x))) + Rattletrap.IntAttributeValue x -> + Value.ValueInt + (Value.IntValue (toInt32 (Rattletrap.intAttributeValue x))) + Rattletrap.LoadoutAttributeValue x -> Value.ValueLoadout (toLoadout x) + Rattletrap.LoadoutOnlineAttributeValue x -> + Value.ValueLoadoutOnline (toLoadoutOnline x) + Rattletrap.LoadoutsAttributeValue x -> + Value.ValueLoadouts + (Value.LoadoutsValue + (toLoadout (Rattletrap.loadoutsAttributeBlue x)) + (toLoadout (Rattletrap.loadoutsAttributeOrange x))) + Rattletrap.LoadoutsOnlineAttributeValue x -> + Value.ValueLoadoutsOnline + (Value.LoadoutsOnlineValue + (toLoadoutOnline (Rattletrap.loadoutsOnlineAttributeBlue x)) + (toLoadoutOnline (Rattletrap.loadoutsOnlineAttributeOrange x)) + (Boolean.Boolean (Rattletrap.loadoutsOnlineAttributeUnknown1 x)) + (Boolean.Boolean (Rattletrap.loadoutsOnlineAttributeUnknown2 x))) + Rattletrap.LocationAttributeValue x -> + Value.ValueLocation + (Value.LocationValue + (toIntVector (Rattletrap.locationAttributeValue x))) + Rattletrap.MusicStingerAttributeValue x -> + Value.ValueMusicStinger + (Value.MusicStingerValue + (Boolean.Boolean (Rattletrap.musicStingerAttributeFlag x)) + (toWord32 (Rattletrap.musicStingerAttributeCue x)) + (toWord8 (Rattletrap.musicStingerAttributeTrigger x))) + Rattletrap.PartyLeaderAttributeValue x -> + Value.ValueUniqueId + (Value.UniqueIdValue + (toWord8 (Rattletrap.partyLeaderAttributeSystemId x)) + (maybe + (RemoteId.RemoteSplitscreenId + (RemoteId.SplitscreenId Nothing)) + (\(r, _) -> toRemoteId r) + (Rattletrap.partyLeaderAttributeId x)) + (fmap (toWord8 . snd) (Rattletrap.partyLeaderAttributeId x))) + Rattletrap.PickupAttributeValue x -> + Value.ValuePickup + (Value.PickupValue + (Boolean.Boolean + (maybe + False + (const True) + (Rattletrap.pickupAttributeInstigatorId x))) + (fmap toWord32 (Rattletrap.pickupAttributeInstigatorId x)) + (Boolean.Boolean (Rattletrap.pickupAttributePickedUp x))) + Rattletrap.PrivateMatchSettingsAttributeValue x -> + Value.ValuePrivateMatchSettings + (Value.PrivateMatchSettingsValue + (toText (Rattletrap.privateMatchSettingsAttributeMutators x)) + (toWord32 + (Rattletrap.privateMatchSettingsAttributeJoinableBy x)) + (toWord32 + (Rattletrap.privateMatchSettingsAttributeMaxPlayers x)) + (toText (Rattletrap.privateMatchSettingsAttributeGameName x)) + (toText (Rattletrap.privateMatchSettingsAttributePassword x)) + (Boolean.Boolean + (Rattletrap.privateMatchSettingsAttributeFlag x))) + Rattletrap.QWordAttributeValue x -> + Value.ValueQWord + (Value.QWordValue (toWord64 (Rattletrap.qWordAttributeValue x))) + Rattletrap.ReservationAttributeValue x -> + Value.ValueReservation + (Value.ReservationValue + (toCompressedWord (Rattletrap.reservationAttributeNumber x)) + (toWord8 + (Rattletrap.uniqueIdAttributeSystemId + (Rattletrap.reservationAttributeUniqueId x))) + (toRemoteId + (Rattletrap.uniqueIdAttributeRemoteId + (Rattletrap.reservationAttributeUniqueId x))) + (Just + (toWord8 + (Rattletrap.uniqueIdAttributeLocalId + (Rattletrap.reservationAttributeUniqueId x)))) + (fmap toText (Rattletrap.reservationAttributeName x)) + (Boolean.Boolean (Rattletrap.reservationAttributeUnknown1 x)) + (Boolean.Boolean (Rattletrap.reservationAttributeUnknown2 x))) + Rattletrap.RigidBodyStateAttributeValue x -> + Value.ValueRigidBodyState + (Value.RigidBodyStateValue + (Boolean.Boolean (Rattletrap.rigidBodyStateAttributeSleeping x)) + (toIntVector (Rattletrap.rigidBodyStateAttributeLocation x)) + (toFloatVector (Rattletrap.rigidBodyStateAttributeRotation x)) + (fmap + toIntVector + (Rattletrap.rigidBodyStateAttributeLinearVelocity x)) + (fmap + toIntVector + (Rattletrap.rigidBodyStateAttributeAngularVelocity x))) + Rattletrap.StringAttributeValue x -> + Value.ValueString + (Value.StringValue (toText (Rattletrap.stringAttributeValue x))) + Rattletrap.TeamPaintAttributeValue x -> + Value.ValueTeamPaint + (Value.TeamPaintValue + (toWord8 (Rattletrap.teamPaintAttributeTeam x)) + (toWord8 (Rattletrap.teamPaintAttributePrimaryColor x)) + (toWord8 (Rattletrap.teamPaintAttributeAccentColor x)) + (toWord32 (Rattletrap.teamPaintAttributePrimaryFinish x)) + (toWord32 (Rattletrap.teamPaintAttributeAccentFinish x))) + Rattletrap.UniqueIdAttributeValue x -> + Value.ValueUniqueId + (Value.UniqueIdValue + (toWord8 (Rattletrap.uniqueIdAttributeSystemId x)) + (toRemoteId (Rattletrap.uniqueIdAttributeRemoteId x)) + (Just (toWord8 (Rattletrap.uniqueIdAttributeLocalId x)))) + Rattletrap.WeldedInfoAttributeValue x -> + Value.ValueWeldedInfo + (Value.WeldedInfoValue + (Boolean.Boolean (Rattletrap.weldedInfoAttributeActive x)) + (toInt32 (Rattletrap.weldedInfoAttributeActorId x)) + (toIntVector (Rattletrap.weldedInfoAttributeOffset x)) + (toFloat32 (Rattletrap.weldedInfoAttributeMass x)) + (toInt8Vector (Rattletrap.weldedInfoAttributeRotation x))) + in (key, value) + +toLoadout :: Rattletrap.LoadoutAttribute -> Value.LoadoutValue +toLoadout x = + Value.LoadoutValue + (toWord8 (Rattletrap.loadoutAttributeVersion x)) + (toWord32 (Rattletrap.loadoutAttributeBody x)) + (toWord32 (Rattletrap.loadoutAttributeDecal x)) + (toWord32 (Rattletrap.loadoutAttributeWheels x)) + (toWord32 (Rattletrap.loadoutAttributeRocketTrail x)) + (toWord32 (Rattletrap.loadoutAttributeAntenna x)) + (toWord32 (Rattletrap.loadoutAttributeTopper x)) + (toWord32 (Rattletrap.loadoutAttributeUnknown1 x)) + (fmap toWord32 (Rattletrap.loadoutAttributeUnknown2 x)) + +toLoadoutOnline :: Rattletrap.LoadoutOnlineAttribute -> Value.LoadoutOnlineValue +toLoadoutOnline x = + Value.LoadoutOnlineValue + (map + (map (\(k, v) -> (toWord32 k, toCompressedWord v))) + (Rattletrap.loadoutAttributeValue x)) + +toRemoteId :: Rattletrap.RemoteId -> RemoteId.RemoteId +toRemoteId remoteId = + case remoteId of + Rattletrap.PlayStationId x -> + let (a, b) = splitAt 16 x + in RemoteId.RemotePlayStationId + (RemoteId.PlayStationId + (a & LazyBytes.pack & LazyBytes.toStrict & + Endian.reverseBitsInStrictBytes & + Encoding.decodeLatin1 & + StrictText.dropWhileEnd (== '\0') & + Text.Text) + (LazyBytes.pack b)) + Rattletrap.SplitscreenId _ -> + RemoteId.RemoteSplitscreenId (RemoteId.SplitscreenId (Just 0)) + Rattletrap.SteamId x -> + RemoteId.RemoteSteamId (RemoteId.SteamId (toWord64 x)) + Rattletrap.XboxId x -> RemoteId.RemoteXboxId (RemoteId.XboxId (toWord64 x)) + +toCompressedWord :: Rattletrap.CompressedWord -> CompressedWord.CompressedWord +toCompressedWord compressedWord = + CompressedWord.CompressedWord + { CompressedWord.compressedWordLimit = + compressedWord & Rattletrap.compressedWordLimit + , CompressedWord.compressedWordValue = + compressedWord & Rattletrap.compressedWordValue + } + +toIntVector :: Rattletrap.Vector -> Vector.Vector Int +toIntVector vector = + let numBits = + vector & Rattletrap.vectorBitSize & Rattletrap.compressedWordValue & + fromIntegral + bias = Bits.shiftL 1 (numBits + 1) + dx = + vector & Rattletrap.vectorDx & Rattletrap.compressedWordValue & + fromIntegral + dy = + vector & Rattletrap.vectorDy & Rattletrap.compressedWordValue & + fromIntegral + dz = + vector & Rattletrap.vectorDz & Rattletrap.compressedWordValue & + fromIntegral + x = dx - bias + y = dy - bias + z = dz - bias + in Vector.Vector x y z + +toInt8Vector :: Rattletrap.Int8Vector -> Vector.Vector Int8.Int8 +toInt8Vector vector = + let convert a = a & fmap Rattletrap.int8Value & Maybe.fromMaybe 0 & Int8.Int8 + x = vector & Rattletrap.int8VectorX & convert + y = vector & Rattletrap.int8VectorY & convert + z = vector & Rattletrap.int8VectorZ & convert + in Vector.Vector x y z + +toWord32 :: Rattletrap.Word32 -> Word32.Word32 +toWord32 word32 = Word32.Word32 (Rattletrap.word32Value word32) + +toInt32 :: Rattletrap.Int32 -> Int32.Int32 +toInt32 int32 = Int32.Int32 (Rattletrap.int32Value int32) + +toWord8 :: Rattletrap.Word8 -> Word8.Word8 +toWord8 word8 = Word8.Word8 (Rattletrap.word8Value word8) + +toWord64 :: Rattletrap.Word64 -> Word64.Word64 +toWord64 word64 = Word64.Word64 (Rattletrap.word64Value word64) + +toFloatVector :: Rattletrap.CompressedWordVector -> Vector.Vector Float +toFloatVector vector = + Vector.Vector + (toFloat (Rattletrap.compressedWordVectorX vector)) + (toFloat (Rattletrap.compressedWordVectorY vector)) + (toFloat (Rattletrap.compressedWordVectorZ vector)) + +toFloat :: Rattletrap.CompressedWord -> Float +toFloat compressedWord = + let serIntMax = Rattletrap.compressedWordLimit compressedWord + numBits = ceiling (log (fromIntegral serIntMax :: Float) / log 2) + bias = Bits.shiftL 1 (numBits - 1) + delta = fromIntegral (Rattletrap.compressedWordValue compressedWord) + unscaledValue = (delta :: Int) - bias + maxBitValue = (Bits.shiftL 1 (numBits - 1)) - 1 + maxValue = 1 :: Int + invScale = + if maxValue > maxBitValue + then fromIntegral maxValue / fromIntegral maxBitValue + else 1 / (fromIntegral maxBitValue / fromIntegral maxValue) + in fromIntegral unscaledValue * invScale diff --git a/library/Octane/Type/ReplayWithFrames.hs b/library/Octane/Type/ReplayWithFrames.hs deleted file mode 100644 --- a/library/Octane/Type/ReplayWithFrames.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.ReplayWithFrames - ( ReplayWithFrames(..) - , fromReplayWithoutFrames - , toReplayWithoutFrames - ) where - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.CacheItem as CacheItem -import qualified Octane.Type.ClassItem as ClassItem -import qualified Octane.Type.Dictionary as Dictionary -import qualified Octane.Type.Frame as Frame -import qualified Octane.Type.KeyFrame as KeyFrame -import qualified Octane.Type.List as List -import qualified Octane.Type.Mark as Mark -import qualified Octane.Type.Message as Message -import qualified Octane.Type.Property as Property -import qualified Octane.Type.ReplayWithoutFrames as Replay -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Word32 as Word32 -import qualified Octane.Utility.Generator as Generator -import qualified Octane.Utility.Parser as Parser - --- | A fully-processed replay. This has all of the frames from the network --- stream as well as all of the metadata. --- --- See 'Octane.Type.OptimizedReplay.OptimizedReplay'. -data ReplayWithFrames = ReplayWithFrames - { replayWithFramesVersion1 :: Word32.Word32 - , replayWithFramesVersion2 :: Word32.Word32 - , replayWithFramesLabel :: Text.Text - , replayWithFramesProperties :: Dictionary.Dictionary Property.Property - , replayWithFramesLevels :: List.List Text.Text - , replayWithFramesKeyFrames :: List.List KeyFrame.KeyFrame - , replayWithFramesFrames :: [Frame.Frame] - , replayWithFramesMessages :: List.List Message.Message - , replayWithFramesMarks :: List.List Mark.Mark - , replayWithFramesPackages :: List.List Text.Text - , replayWithFramesObjects :: List.List Text.Text - , replayWithFramesNames :: List.List Text.Text - , replayWithFramesClasses :: List.List ClassItem.ClassItem - , replayWithFramesCache :: List.List CacheItem.CacheItem - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''ReplayWithFrames) - -instance Binary.Binary ReplayWithFrames where - get = do - replayWithoutFrames <- Binary.get - fromReplayWithoutFrames replayWithoutFrames - put replay = do - replayWithoutFrames <- toReplayWithoutFrames replay - Binary.put replayWithoutFrames - -instance DeepSeq.NFData ReplayWithFrames - --- | Converts a 'ReplayWithoutFrames.ReplayWithoutFrames' into a 'ReplayWithFrames'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -fromReplayWithoutFrames - :: (Monad m) - => Replay.ReplayWithoutFrames -> m ReplayWithFrames -fromReplayWithoutFrames replayWithoutFrames = do - pure - (ReplayWithFrames - (#version1 replayWithoutFrames) - (#version2 replayWithoutFrames) - (#label replayWithoutFrames) - (#properties replayWithoutFrames) - (#levels replayWithoutFrames) - (#keyFrames replayWithoutFrames) - (Parser.parseStream replayWithoutFrames) - (#messages replayWithoutFrames) - (#marks replayWithoutFrames) - (#packages replayWithoutFrames) - (#objects replayWithoutFrames) - (#names replayWithoutFrames) - (#classes replayWithoutFrames) - (#cache replayWithoutFrames)) - --- | Converts a 'ReplayWithFrames' into a 'Replay.ReplayWithoutFrames'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -toReplayWithoutFrames - :: (Monad m) - => ReplayWithFrames -> m Replay.ReplayWithoutFrames -toReplayWithoutFrames replayWithFrames = do - let stream = - Generator.generateStream - (#frames replayWithFrames) - (#objects replayWithFrames) - (#names replayWithFrames) - (#classes replayWithFrames) - (#cache replayWithFrames) - pure - (Replay.ReplayWithoutFrames - (#version1 replayWithFrames) - (#version2 replayWithFrames) - (#label replayWithFrames) - (#properties replayWithFrames) - (#levels replayWithFrames) - (#keyFrames replayWithFrames) - stream - (#messages replayWithFrames) - (#marks replayWithFrames) - (#packages replayWithFrames) - (#objects replayWithFrames) - (#names replayWithFrames) - (#classes replayWithFrames) - (#cache replayWithFrames)) diff --git a/library/Octane/Type/ReplayWithoutFrames.hs b/library/Octane/Type/ReplayWithoutFrames.hs deleted file mode 100644 --- a/library/Octane/Type/ReplayWithoutFrames.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.ReplayWithoutFrames - ( ReplayWithoutFrames(..) - , fromRawReplay - , toRawReplay - ) where - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.CacheItem as CacheItem -import qualified Octane.Type.ClassItem as ClassItem -import qualified Octane.Type.Dictionary as Dictionary -import qualified Octane.Type.KeyFrame as KeyFrame -import qualified Octane.Type.List as List -import qualified Octane.Type.Mark as Mark -import qualified Octane.Type.Message as Message -import qualified Octane.Type.Property as Property -import qualified Octane.Type.RawReplay as RawReplay -import qualified Octane.Type.Stream as Stream -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Word32 as Word32 - --- | A partially-processed replay. This has parsed all of the high-level --- metadata, but it has not parsed any of the network stream. --- --- See 'Octane.Type.ReplayWithFrames.ReplayWithFrames'. -data ReplayWithoutFrames = ReplayWithoutFrames - { replayWithoutFramesVersion1 :: Word32.Word32 - , replayWithoutFramesVersion2 :: Word32.Word32 - , replayWithoutFramesLabel :: Text.Text - , replayWithoutFramesProperties :: Dictionary.Dictionary Property.Property - , replayWithoutFramesLevels :: List.List Text.Text - , replayWithoutFramesKeyFrames :: List.List KeyFrame.KeyFrame - , replayWithoutFramesStream :: Stream.Stream - , replayWithoutFramesMessages :: List.List Message.Message - , replayWithoutFramesMarks :: List.List Mark.Mark - , replayWithoutFramesPackages :: List.List Text.Text - , replayWithoutFramesObjects :: List.List Text.Text - , replayWithoutFramesNames :: List.List Text.Text - , replayWithoutFramesClasses :: List.List ClassItem.ClassItem - , replayWithoutFramesCache :: List.List CacheItem.CacheItem - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''ReplayWithoutFrames) - -instance Binary.Binary ReplayWithoutFrames where - get = do - rawReplay <- Binary.get - fromRawReplay rawReplay - put replayWithoutFrames = do - rawReplay <- toRawReplay replayWithoutFrames - Binary.put rawReplay - -instance DeepSeq.NFData ReplayWithoutFrames - --- | Converts a 'RawReplay.RawReplay' into a 'ReplayWithoutFrames'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -fromRawReplay - :: (Monad m) - => RawReplay.RawReplay -> m ReplayWithoutFrames -fromRawReplay rawReplay = do - let header = #header rawReplay - let content = #content rawReplay - let get = do - version1 <- Binary.get - version2 <- Binary.get - label <- Binary.get - properties <- Binary.get - levels <- Binary.get - keyFrames <- Binary.get - stream <- Binary.get - messages <- Binary.get - marks <- Binary.get - packages <- Binary.get - objects <- Binary.get - names <- Binary.get - classes <- Binary.get - cache <- Binary.get - pure - (ReplayWithoutFrames - version1 - version2 - label - properties - levels - keyFrames - stream - messages - marks - packages - objects - names - classes - cache) - let bytes = LazyBytes.append header content - pure (Binary.runGet get bytes) - --- | Converts a 'ReplayWithoutFrames' into a 'RawReplay.RawReplay'. --- Operates in a 'Monad' so that it can 'fail' somewhat gracefully. -toRawReplay - :: (Monad m) - => ReplayWithoutFrames -> m RawReplay.RawReplay -toRawReplay replay = do - let header = - Binary.runPut - (do Binary.put (#version1 replay) - Binary.put (#version2 replay) - Binary.put (#label replay) - Binary.put (#properties replay)) - let content = - Binary.runPut - (do Binary.put (#levels replay) - Binary.put (#keyFrames replay) - Binary.put (#stream replay) - Binary.put (#messages replay) - Binary.put (#marks replay) - Binary.put (#packages replay) - Binary.put (#objects replay) - Binary.put (#names replay) - Binary.put (#classes replay) - Binary.put (#cache replay)) - let footer = LazyBytes.empty - pure (RawReplay.newRawReplay header content footer) diff --git a/library/Octane/Type/Replication.hs b/library/Octane/Type/Replication.hs --- a/library/Octane/Type/Replication.hs +++ b/library/Octane/Type/Replication.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,12 +10,10 @@ ( Replication(..) ) where -import qualified Control.DeepSeq as DeepSeq import qualified Data.Default.Class as Default import qualified Data.Map.Strict as Map import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.CompressedWord as CompressedWord import qualified Octane.Type.Initialization as Initialization import qualified Octane.Type.State as State @@ -40,8 +37,6 @@ -- exist for new actors. , replicationProperties :: Map.Map StrictText.Text Value.Value -- ^ The property updates associated with this actor's replication. - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''Replication) - -instance DeepSeq.NFData Replication diff --git a/library/Octane/Type/State.hs b/library/Octane/Type/State.hs --- a/library/Octane/Type/State.hs +++ b/library/Octane/Type/State.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Octane.Type.State ( State(..) , isOpening @@ -7,9 +5,6 @@ , isClosing ) where -import qualified Control.DeepSeq as DeepSeq -import qualified GHC.Generics as Generics - -- | The state of an actor in a replication. data State = Opening @@ -18,9 +13,7 @@ -- ^ We have seen this actor before. | Closing -- ^ This actor is going away. - deriving (Eq, Generics.Generic, Show) - -instance DeepSeq.NFData State + deriving (Eq, Show) isOpening :: State -> Bool isOpening state = state == Opening diff --git a/library/Octane/Type/Stream.hs b/library/Octane/Type/Stream.hs deleted file mode 100644 --- a/library/Octane/Type/Stream.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.Stream - ( Stream(..) - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Word32 as Word32 -import qualified Octane.Utility.Endian as Endian -import qualified Text.Printf as Printf - --- | A stream of bits. -newtype Stream = Stream - { streamUnpack :: LazyBytes.ByteString - } deriving (Eq, Generics.Generic) - -$(OverloadedRecords.overloadedRecord Default.def ''Stream) - --- | Prefixed by a length in bytes. Each byte is reversed such that --- @0b01234567@ is actually @0b76543210@. -instance Binary.Binary Stream where - get = do - size <- Binary.get - content <- size & Word32.fromWord32 & Binary.getLazyByteString - content & Endian.reverseBitsInLazyBytes & Stream & pure - put stream = do - let content = #unpack stream - content & LazyBytes.length & Word32.toWord32 & Binary.put - content & Endian.reverseBitsInLazyBytes & Binary.putLazyByteString - -instance DeepSeq.NFData Stream - --- | Doesn't show the actual bytes to avoid dumping tons of text. -instance Show Stream where - show stream = do - let size = stream & #unpack & LazyBytes.length - let s = - if size == 1 - then "" - else "s" - Printf.printf "Stream {unpack = \"%d byte%s\"}" size s diff --git a/library/Octane/Type/Text.hs b/library/Octane/Type/Text.hs --- a/library/Octane/Type/Text.hs +++ b/library/Octane/Type/Text.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,59 +14,25 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Char8 as StrictBytes -import qualified Data.Char as Char import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.String as String import qualified Data.Text as StrictText -import qualified Data.Text.Encoding as Encoding -import qualified GHC.Generics as Generics -import qualified Octane.Type.Int32 as Int32 -import qualified Octane.Utility.Endian as Endian -- | A thin wrapper around 'StrictText.Text'. newtype Text = Text { textUnpack :: StrictText.Text - } deriving (Eq, Generics.Generic, Ord) + } deriving (Eq, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Text) --- | Text is both length-prefixed and null-terminated. -instance Binary.Binary Text where - get = getText Binary.get Binary.getByteString id - put text = putText Binary.put Binary.putByteString id text - --- | Both length-prefixed and null-terminated. The bits in each byte are --- reversed. -instance BinaryBit.BinaryBit Text where - getBits _ = - getText - (BinaryBit.getBits 32) - BinaryBit.getByteString - Endian.reverseBitsInStrictBytes - putBits _ text = - putText - (BinaryBit.putBits 32) - BinaryBit.putByteString - Endian.reverseBitsInStrictBytes - text - -- | Allows you to write 'Text' as string literals with @OverloadedStrings@. -- Also allows using the 'String.fromString' helper function. instance String.IsString Text where fromString string = Text (StrictText.pack string) -instance DeepSeq.NFData Text - -- | Shown as a string literal, like @"this"@. instance Show Text where show text = show (#unpack text) @@ -75,58 +40,6 @@ -- | Encoded directly as a JSON string. instance Aeson.ToJSON Text where toJSON text = text & #unpack & Aeson.toJSON - -getText - :: (Monad m) - => (m Int32.Int32) - -> (Int -> m StrictBytes.ByteString) - -> (StrictBytes.ByteString -> StrictBytes.ByteString) - -> m Text -getText getInt getBytes convertBytes = do - (Int32.Int32 rawSize) <- getInt - (size, decode) - -- 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. - <- - if rawSize == 0x05000000 - then do - bytes <- getBytes 3 - if StrictBytes.all (== '\0') bytes - then pure (5, Encoding.decodeLatin1) - else fail - ("Unexpected Text bytes " ++ - show bytes ++ " after size " ++ show rawSize) - else if rawSize < 0 - then pure (-2 * fromIntegral rawSize, Encoding.decodeUtf16LE) - else pure (fromIntegral rawSize, Encoding.decodeLatin1) - bytes <- getBytes size - let rawText = bytes & convertBytes & decode - case StrictText.splitAt (StrictText.length rawText - 1) rawText of - (text, "") -> text & Text & pure - (text, "\0") -> text & Text & pure - _ -> fail ("Unexpected Text value " ++ show rawText) - -putText - :: (Monad m) - => (Int32.Int32 -> m ()) - -> (StrictBytes.ByteString -> m ()) - -> (StrictBytes.ByteString -> StrictBytes.ByteString) - -> Text - -> m () -putText putInt putBytes convertBytes text = do - let fullText = text & #unpack & flip StrictText.snoc '\NUL' - let size = fullText & StrictText.length & fromIntegral - if StrictText.all Char.isLatin1 fullText - then do - size & Int32.Int32 & putInt - fullText & encodeLatin1 & convertBytes & putBytes - else do - size & negate & Int32.Int32 & putInt - fullText & Encoding.encodeUtf16LE & convertBytes & putBytes -- | Encodes text as Latin-1. Note that this isn't really safe if the text has -- characters that can't be encoded in Latin-1. diff --git a/library/Octane/Type/Value.hs b/library/Octane/Type/Value.hs --- a/library/Octane/Type/Value.hs +++ b/library/Octane/Type/Value.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} module Octane.Type.Value @@ -6,6 +5,7 @@ , module Octane.Type.Value.BooleanValue , module Octane.Type.Value.ByteValue , module Octane.Type.Value.CamSettingsValue + , module Octane.Type.Value.ClubColorsValue , module Octane.Type.Value.DemolishValue , module Octane.Type.Value.EnumValue , module Octane.Type.Value.ExplosionValue @@ -22,7 +22,6 @@ , module Octane.Type.Value.PickupValue , module Octane.Type.Value.PrivateMatchSettingsValue , module Octane.Type.Value.QWordValue - , module Octane.Type.Value.RelativeRotationValue , module Octane.Type.Value.ReservationValue , module Octane.Type.Value.RigidBodyStateValue , module Octane.Type.Value.StringValue @@ -34,6 +33,7 @@ import Octane.Type.Value.BooleanValue import Octane.Type.Value.ByteValue import Octane.Type.Value.CamSettingsValue +import Octane.Type.Value.ClubColorsValue import Octane.Type.Value.DemolishValue import Octane.Type.Value.EnumValue import Octane.Type.Value.ExplosionValue @@ -42,15 +42,14 @@ import Octane.Type.Value.GameModeValue import Octane.Type.Value.IntValue import Octane.Type.Value.LoadoutOnlineValue +import Octane.Type.Value.LoadoutValue import Octane.Type.Value.LoadoutsOnlineValue import Octane.Type.Value.LoadoutsValue -import Octane.Type.Value.LoadoutValue import Octane.Type.Value.LocationValue import Octane.Type.Value.MusicStingerValue import Octane.Type.Value.PickupValue import Octane.Type.Value.PrivateMatchSettingsValue import Octane.Type.Value.QWordValue -import Octane.Type.Value.RelativeRotationValue import Octane.Type.Value.ReservationValue import Octane.Type.Value.RigidBodyStateValue import Octane.Type.Value.StringValue @@ -58,15 +57,14 @@ import Octane.Type.Value.UniqueIdValue import Octane.Type.Value.WeldedInfoValue -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified GHC.Generics as Generics -- | A replicated property's value. data Value = ValueBoolean BooleanValue | ValueByte ByteValue | ValueCamSettings CamSettingsValue + | ValueClubColors ClubColorsValue | ValueDemolish DemolishValue | ValueEnum EnumValue | ValueExplosion ExplosionValue @@ -83,16 +81,13 @@ | ValuePickup PickupValue | ValuePrivateMatchSettings PrivateMatchSettingsValue | ValueQWord QWordValue - | ValueRelativeRotation RelativeRotationValue | ValueReservation ReservationValue | ValueRigidBodyState RigidBodyStateValue | ValueString StringValue | ValueTeamPaint TeamPaintValue | ValueUniqueId UniqueIdValue | ValueWeldedInfo WeldedInfoValue - deriving (Eq, Generics.Generic, Show) - -instance DeepSeq.NFData Value + deriving (Eq, Show) instance Aeson.ToJSON Value where toJSON value = @@ -100,6 +95,7 @@ ValueBoolean x -> Aeson.toJSON x ValueByte x -> Aeson.toJSON x ValueCamSettings x -> Aeson.toJSON x + ValueClubColors x -> Aeson.toJSON x ValueDemolish x -> Aeson.toJSON x ValueEnum x -> Aeson.toJSON x ValueExplosion x -> Aeson.toJSON x @@ -116,7 +112,6 @@ ValuePickup x -> Aeson.toJSON x ValuePrivateMatchSettings x -> Aeson.toJSON x ValueQWord x -> Aeson.toJSON x - ValueRelativeRotation x -> Aeson.toJSON x ValueReservation x -> Aeson.toJSON x ValueRigidBodyState x -> Aeson.toJSON x ValueString x -> Aeson.toJSON x diff --git a/library/Octane/Type/Value/BooleanValue.hs b/library/Octane/Type/Value/BooleanValue.hs --- a/library/Octane/Type/Value/BooleanValue.hs +++ b/library/Octane/Type/Value/BooleanValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean newtype BooleanValue = BooleanValue { booleanValueUnpack :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''BooleanValue) - -instance DeepSeq.NFData BooleanValue instance Aeson.ToJSON BooleanValue where toJSON x = diff --git a/library/Octane/Type/Value/ByteValue.hs b/library/Octane/Type/Value/ByteValue.hs --- a/library/Octane/Type/Value/ByteValue.hs +++ b/library/Octane/Type/Value/ByteValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Word8 as Word8 newtype ByteValue = ByteValue { byteValueUnpack :: Word8.Word8 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''ByteValue) - -instance DeepSeq.NFData ByteValue instance Aeson.ToJSON ByteValue where toJSON x = diff --git a/library/Octane/Type/Value/CamSettingsValue.hs b/library/Octane/Type/Value/CamSettingsValue.hs --- a/library/Octane/Type/Value/CamSettingsValue.hs +++ b/library/Octane/Type/Value/CamSettingsValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Float32 as Float32 data CamSettingsValue = CamSettingsValue @@ -30,11 +27,9 @@ , camSettingsValueDistance :: Float32.Float32 , camSettingsValueStiffness :: Float32.Float32 , camSettingsValueSwivelSpeed :: Float32.Float32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''CamSettingsValue) - -instance DeepSeq.NFData CamSettingsValue instance Aeson.ToJSON CamSettingsValue where toJSON x = diff --git a/library/Octane/Type/Value/ClubColorsValue.hs b/library/Octane/Type/Value/ClubColorsValue.hs new file mode 100644 --- /dev/null +++ b/library/Octane/Type/Value/ClubColorsValue.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Octane.Type.Value.ClubColorsValue + ( ClubColorsValue(..) + ) where + +import Data.Aeson ((.=)) + +import qualified Data.Aeson as Aeson +import qualified Data.Default.Class as Default +import qualified Data.OverloadedRecords.TH as OverloadedRecords +import qualified Data.Text as StrictText +import qualified Octane.Type.Boolean as Boolean +import qualified Octane.Type.Word8 as Word8 + +data ClubColorsValue = ClubColorsValue + { clubColorsValueBlueFlag :: Boolean.Boolean + , clubColorsValueBlueColor :: Word8.Word8 + , clubColorsValueOrangeFlag :: Boolean.Boolean + , clubColorsValueOrangeColor :: Word8.Word8 + } deriving (Eq, Show) + +$(OverloadedRecords.overloadedRecord Default.def ''ClubColorsValue) + +instance Aeson.ToJSON ClubColorsValue where + toJSON x = + Aeson.object + [ "Type" .= ("ClubColors" :: StrictText.Text) + , "Value" .= + Aeson.object + [ "BlueFlag" .= #blueFlag x + , "BlueColor" .= #blueColor x + , "OrangeFlag" .= #orangeFlag x + , "OrangeColor" .= #orangeColor x + ] + ] diff --git a/library/Octane/Type/Value/DemolishValue.hs b/library/Octane/Type/Value/DemolishValue.hs --- a/library/Octane/Type/Value/DemolishValue.hs +++ b/library/Octane/Type/Value/DemolishValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Vector as Vector import qualified Octane.Type.Word32 as Word32 @@ -32,11 +29,9 @@ , demolishValueVictimActorId :: Word32.Word32 , demolishValueAttackerVelocity :: Vector.Vector Int , demolishValueVictimVelocity :: Vector.Vector Int - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''DemolishValue) - -instance DeepSeq.NFData DemolishValue instance Aeson.ToJSON DemolishValue where toJSON x = diff --git a/library/Octane/Type/Value/EnumValue.hs b/library/Octane/Type/Value/EnumValue.hs --- a/library/Octane/Type/Value/EnumValue.hs +++ b/library/Octane/Type/Value/EnumValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,23 +14,19 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Word16 as Word16 data EnumValue = EnumValue { enumValueValue :: Word16.Word16 , enumValueFlag :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''EnumValue) - -instance DeepSeq.NFData EnumValue instance Aeson.ToJSON EnumValue where toJSON x = diff --git a/library/Octane/Type/Value/ExplosionValue.hs b/library/Octane/Type/Value/ExplosionValue.hs --- a/library/Octane/Type/Value/ExplosionValue.hs +++ b/library/Octane/Type/Value/ExplosionValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Int32 as Int32 import qualified Octane.Type.Vector as Vector @@ -29,11 +26,9 @@ { explosionValueActorless :: Boolean.Boolean , explosionValueActorId :: Maybe Int32.Int32 , explosionValuePosition :: Vector.Vector Int - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''ExplosionValue) - -instance DeepSeq.NFData ExplosionValue instance Aeson.ToJSON ExplosionValue where toJSON x = diff --git a/library/Octane/Type/Value/FlaggedIntValue.hs b/library/Octane/Type/Value/FlaggedIntValue.hs --- a/library/Octane/Type/Value/FlaggedIntValue.hs +++ b/library/Octane/Type/Value/FlaggedIntValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,23 +14,19 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Int32 as Int32 data FlaggedIntValue = FlaggedIntValue { flaggedIntValueFlag :: Boolean.Boolean , flaggedIntValueInt :: Int32.Int32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''FlaggedIntValue) - -instance DeepSeq.NFData FlaggedIntValue instance Aeson.ToJSON FlaggedIntValue where toJSON x = diff --git a/library/Octane/Type/Value/FloatValue.hs b/library/Octane/Type/Value/FloatValue.hs --- a/library/Octane/Type/Value/FloatValue.hs +++ b/library/Octane/Type/Value/FloatValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Float32 as Float32 newtype FloatValue = FloatValue { floatValueUnpack :: Float32.Float32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''FloatValue) - -instance DeepSeq.NFData FloatValue instance Aeson.ToJSON FloatValue where toJSON x = diff --git a/library/Octane/Type/Value/GameModeValue.hs b/library/Octane/Type/Value/GameModeValue.hs --- a/library/Octane/Type/Value/GameModeValue.hs +++ b/library/Octane/Type/Value/GameModeValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,13 +13,11 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Bimap as Bimap import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Data as Data import qualified Octane.Type.Word8 as Word8 @@ -29,11 +26,9 @@ newtype GameModeValue = GameModeValue { gameModeValueUnpack :: Word8.Word8 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''GameModeValue) - -instance DeepSeq.NFData GameModeValue instance Aeson.ToJSON GameModeValue where toJSON x = diff --git a/library/Octane/Type/Value/IntValue.hs b/library/Octane/Type/Value/IntValue.hs --- a/library/Octane/Type/Value/IntValue.hs +++ b/library/Octane/Type/Value/IntValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Int32 as Int32 newtype IntValue = IntValue { intValueUnpack :: Int32.Int32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''IntValue) - -instance DeepSeq.NFData IntValue instance Aeson.ToJSON IntValue where toJSON x = diff --git a/library/Octane/Type/Value/LoadoutOnlineValue.hs b/library/Octane/Type/Value/LoadoutOnlineValue.hs --- a/library/Octane/Type/Value/LoadoutOnlineValue.hs +++ b/library/Octane/Type/Value/LoadoutOnlineValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,22 +13,18 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.CompressedWord as CompressedWord import qualified Octane.Type.Word32 as Word32 newtype LoadoutOnlineValue = LoadoutOnlineValue { loadoutOnlineValueUnpack :: [[(Word32.Word32, CompressedWord.CompressedWord)]] - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''LoadoutOnlineValue) - -instance DeepSeq.NFData LoadoutOnlineValue instance Aeson.ToJSON LoadoutOnlineValue where toJSON x = diff --git a/library/Octane/Type/Value/LoadoutValue.hs b/library/Octane/Type/Value/LoadoutValue.hs --- a/library/Octane/Type/Value/LoadoutValue.hs +++ b/library/Octane/Type/Value/LoadoutValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,13 +14,11 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Bimap as Bimap import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Data as Data import qualified Octane.Type.Word32 as Word32 import qualified Octane.Type.Word8 as Word8 @@ -39,11 +36,9 @@ , loadoutValueTopper :: Word32.Word32 , loadoutValueUnknown1 :: Word32.Word32 , loadoutValueUnknown2 :: Maybe Word32.Word32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''LoadoutValue) - -instance DeepSeq.NFData LoadoutValue instance Aeson.ToJSON LoadoutValue where toJSON x = diff --git a/library/Octane/Type/Value/LoadoutsOnlineValue.hs b/library/Octane/Type/Value/LoadoutsOnlineValue.hs --- a/library/Octane/Type/Value/LoadoutsOnlineValue.hs +++ b/library/Octane/Type/Value/LoadoutsOnlineValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Value.LoadoutOnlineValue as LoadoutOnlineValue @@ -30,11 +27,9 @@ , loadoutsOnlineValueLoadout2 :: LoadoutOnlineValue.LoadoutOnlineValue , loadoutsOnlineValueUnknown1 :: Boolean.Boolean , loadoutsOnlineValueUnknown2 :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''LoadoutsOnlineValue) - -instance DeepSeq.NFData LoadoutsOnlineValue instance Aeson.ToJSON LoadoutsOnlineValue where toJSON x = diff --git a/library/Octane/Type/Value/LoadoutsValue.hs b/library/Octane/Type/Value/LoadoutsValue.hs --- a/library/Octane/Type/Value/LoadoutsValue.hs +++ b/library/Octane/Type/Value/LoadoutsValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,22 +14,18 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Value.LoadoutValue as LoadoutValue data LoadoutsValue = LoadoutsValue { loadoutsValueLoadout1 :: LoadoutValue.LoadoutValue -- ^ blue , loadoutsValueLoadout2 :: LoadoutValue.LoadoutValue -- ^ orange - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''LoadoutsValue) - -instance DeepSeq.NFData LoadoutsValue instance Aeson.ToJSON LoadoutsValue where toJSON x = diff --git a/library/Octane/Type/Value/LocationValue.hs b/library/Octane/Type/Value/LocationValue.hs --- a/library/Octane/Type/Value/LocationValue.hs +++ b/library/Octane/Type/Value/LocationValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Vector as Vector newtype LocationValue = LocationValue { locationValueUnpack :: Vector.Vector Int - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''LocationValue) - -instance DeepSeq.NFData LocationValue instance Aeson.ToJSON LocationValue where toJSON x = diff --git a/library/Octane/Type/Value/MusicStingerValue.hs b/library/Octane/Type/Value/MusicStingerValue.hs --- a/library/Octane/Type/Value/MusicStingerValue.hs +++ b/library/Octane/Type/Value/MusicStingerValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Word32 as Word32 import qualified Octane.Type.Word8 as Word8 @@ -29,11 +26,9 @@ { musicStingerValueFlag :: Boolean.Boolean , musicStingerValueCue :: Word32.Word32 , musicStingerValueTrigger :: Word8.Word8 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''MusicStingerValue) - -instance DeepSeq.NFData MusicStingerValue instance Aeson.ToJSON MusicStingerValue where toJSON x = diff --git a/library/Octane/Type/Value/PickupValue.hs b/library/Octane/Type/Value/PickupValue.hs --- a/library/Octane/Type/Value/PickupValue.hs +++ b/library/Octane/Type/Value/PickupValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Word32 as Word32 @@ -28,11 +25,9 @@ { pickupValueHasInstigator :: Boolean.Boolean , pickupValueInstigatorId :: Maybe Word32.Word32 , pickupValuePickedUp :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''PickupValue) - -instance DeepSeq.NFData PickupValue instance Aeson.ToJSON PickupValue where toJSON x = diff --git a/library/Octane/Type/Value/PrivateMatchSettingsValue.hs b/library/Octane/Type/Value/PrivateMatchSettingsValue.hs --- a/library/Octane/Type/Value/PrivateMatchSettingsValue.hs +++ b/library/Octane/Type/Value/PrivateMatchSettingsValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Text as Text import qualified Octane.Type.Word32 as Word32 @@ -32,11 +29,9 @@ , privateMatchSettingsValueGameName :: Text.Text , privateMatchSettingsValuePassword :: Text.Text , privateMatchSettingsValueFlag :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''PrivateMatchSettingsValue) - -instance DeepSeq.NFData PrivateMatchSettingsValue instance Aeson.ToJSON PrivateMatchSettingsValue where toJSON x = diff --git a/library/Octane/Type/Value/QWordValue.hs b/library/Octane/Type/Value/QWordValue.hs --- a/library/Octane/Type/Value/QWordValue.hs +++ b/library/Octane/Type/Value/QWordValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Word64 as Word64 newtype QWordValue = QWordValue { qWordValueUnpack :: Word64.Word64 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''QWordValue) - -instance DeepSeq.NFData QWordValue instance Aeson.ToJSON QWordValue where toJSON x = diff --git a/library/Octane/Type/Value/RelativeRotationValue.hs b/library/Octane/Type/Value/RelativeRotationValue.hs deleted file mode 100644 --- a/library/Octane/Type/Value/RelativeRotationValue.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Type.Value.RelativeRotationValue - ( RelativeRotationValue(..) - ) where - -import Data.Aeson ((.=)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Aeson as Aeson -import qualified Data.Default.Class as Default -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics -import qualified Octane.Type.Vector as Vector - -newtype RelativeRotationValue = RelativeRotationValue - { relativeRotationValueUnpack :: Vector.Vector Float - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''RelativeRotationValue) - -instance DeepSeq.NFData RelativeRotationValue - -instance Aeson.ToJSON RelativeRotationValue where - toJSON x = - Aeson.object - ["Type" .= ("RelativeRotation" :: StrictText.Text), "Value" .= #unpack x] diff --git a/library/Octane/Type/Value/ReservationValue.hs b/library/Octane/Type/Value/ReservationValue.hs --- a/library/Octane/Type/Value/ReservationValue.hs +++ b/library/Octane/Type/Value/ReservationValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.CompressedWord as CompressedWord import qualified Octane.Type.RemoteId as RemoteId @@ -35,11 +32,9 @@ , reservationValuePlayerName :: Maybe Text.Text , reservationValueUnknown1 :: Boolean.Boolean , reservationValueUnknown2 :: Boolean.Boolean - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''ReservationValue) - -instance DeepSeq.NFData ReservationValue instance Aeson.ToJSON ReservationValue where toJSON x = diff --git a/library/Octane/Type/Value/RigidBodyStateValue.hs b/library/Octane/Type/Value/RigidBodyStateValue.hs --- a/library/Octane/Type/Value/RigidBodyStateValue.hs +++ b/library/Octane/Type/Value/RigidBodyStateValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Vector as Vector @@ -30,11 +27,9 @@ , rigidBodyStateValueRotation :: Vector.Vector Float , rigidBodyStateValueLinearVelocity :: Maybe (Vector.Vector Int) , rigidBodyStateValueAngularVelocity :: Maybe (Vector.Vector Int) - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''RigidBodyStateValue) - -instance DeepSeq.NFData RigidBodyStateValue instance Aeson.ToJSON RigidBodyStateValue where toJSON x = diff --git a/library/Octane/Type/Value/StringValue.hs b/library/Octane/Type/Value/StringValue.hs --- a/library/Octane/Type/Value/StringValue.hs +++ b/library/Octane/Type/Value/StringValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,21 +13,17 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Text as Text newtype StringValue = StringValue { stringValueUnpack :: Text.Text - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''StringValue) - -instance DeepSeq.NFData StringValue instance Aeson.ToJSON StringValue where toJSON x = diff --git a/library/Octane/Type/Value/TeamPaintValue.hs b/library/Octane/Type/Value/TeamPaintValue.hs --- a/library/Octane/Type/Value/TeamPaintValue.hs +++ b/library/Octane/Type/Value/TeamPaintValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,13 +14,11 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Bimap as Bimap import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Data as Data import qualified Octane.Type.Word32 as Word32 import qualified Octane.Type.Word8 as Word8 @@ -35,11 +32,9 @@ , teamPaintValueAccentColor :: Word8.Word8 , teamPaintValuePrimaryFinish :: Word32.Word32 , teamPaintValueAccentFinish :: Word32.Word32 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''TeamPaintValue) - -instance DeepSeq.NFData TeamPaintValue instance Aeson.ToJSON TeamPaintValue where toJSON x = diff --git a/library/Octane/Type/Value/UniqueIdValue.hs b/library/Octane/Type/Value/UniqueIdValue.hs --- a/library/Octane/Type/Value/UniqueIdValue.hs +++ b/library/Octane/Type/Value/UniqueIdValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.RemoteId as RemoteId import qualified Octane.Type.Word8 as Word8 @@ -28,11 +25,9 @@ { uniqueIdValueSystemId :: Word8.Word8 , uniqueIdValueRemoteId :: RemoteId.RemoteId , uniqueIdValueLocalId :: Maybe Word8.Word8 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''UniqueIdValue) - -instance DeepSeq.NFData UniqueIdValue instance Aeson.ToJSON UniqueIdValue where toJSON x = diff --git a/library/Octane/Type/Value/WeldedInfoValue.hs b/library/Octane/Type/Value/WeldedInfoValue.hs --- a/library/Octane/Type/Value/WeldedInfoValue.hs +++ b/library/Octane/Type/Value/WeldedInfoValue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +14,10 @@ import Data.Aeson ((.=)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Text as StrictText -import qualified GHC.Generics as Generics import qualified Octane.Type.Boolean as Boolean import qualified Octane.Type.Float32 as Float32 import qualified Octane.Type.Int32 as Int32 @@ -33,11 +30,9 @@ , weldedInfoValueOffset :: Vector.Vector Int , weldedInfoValueMass :: Float32.Float32 , weldedInfoValueRotation :: Vector.Vector Int8.Int8 - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''WeldedInfoValue) - -instance DeepSeq.NFData WeldedInfoValue instance Aeson.ToJSON WeldedInfoValue where toJSON x = diff --git a/library/Octane/Type/Vector.hs b/library/Octane/Type/Vector.hs --- a/library/Octane/Type/Vector.hs +++ b/library/Octane/Type/Vector.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,29 +10,11 @@ module Octane.Type.Vector ( Vector(..) - , getFloatVector - , getInt8Vector - , getIntVector - , putFloatVector - , putInt8Vector - , putIntVector ) where -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Bits as Bits import qualified Data.Default.Class as Default -import qualified Data.Foldable as Foldable import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified GHC.Generics as Generics -import qualified Octane.Type.Boolean as Boolean -import qualified Octane.Type.CompressedWord as CompressedWord -import qualified Octane.Type.Int8 as Int8 -- | Three values packed together. Although the fields are called @x@, @y@, and -- @z@, that may not be what they actually represent. @@ -45,13 +26,10 @@ { vectorX :: a , vectorY :: a , vectorZ :: a - } deriving (Eq, Generics.Generic, Show) + } deriving (Eq, Show) $(OverloadedRecords.overloadedRecord Default.def ''Vector) -instance (DeepSeq.NFData a) => - DeepSeq.NFData (Vector a) - -- | Encoded as a JSON array with 3 elements. -- -- Aeson.encode (Vector 1 2 3 :: Vector Int) @@ -59,111 +37,3 @@ instance (Aeson.ToJSON a) => Aeson.ToJSON (Vector a) where toJSON vector = Aeson.toJSON [#x vector, #y vector, #z vector] - --- | Gets a 'Vector' full of 'Float's. -getFloatVector :: BinaryBit.BitGet (Vector Float) -getFloatVector = do - let maxValue = 1 - let numBits = 16 - x <- getFloat maxValue numBits - y <- getFloat maxValue numBits - z <- getFloat maxValue numBits - pure (Vector x y z) - -getFloat :: Int -> Int -> BinaryBit.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 <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits serIntMax) - let unscaledValue = (delta :: Int) - bias - let invScale = - if maxValue > maxBitValue - then fromIntegral maxValue / fromIntegral maxBitValue - else 1.0 / (fromIntegral maxBitValue / fromIntegral maxValue) - let value = fromIntegral unscaledValue * invScale - pure value - --- | Gets a 'Vector' full of 'Int8's. -getInt8Vector :: BinaryBit.BitGet (Vector Int8.Int8) -getInt8Vector = do - (hasX :: Boolean.Boolean) <- BinaryBit.getBits 0 - x <- - if #unpack hasX - then BinaryBit.getBits 0 - else pure 0 - (hasY :: Boolean.Boolean) <- BinaryBit.getBits 0 - y <- - if #unpack hasY - then BinaryBit.getBits 0 - else pure 0 - (hasZ :: Boolean.Boolean) <- BinaryBit.getBits 0 - z <- - if #unpack hasZ - then BinaryBit.getBits 0 - else pure 0 - pure (Vector x y z) - --- | Gets a 'Vector' full of 'Int's. -getIntVector :: BinaryBit.BitGet (Vector Int) -getIntVector = do - numBits <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits 19) - let bias = Bits.shiftL 1 (numBits + 1) - let maxBits = numBits + 2 - let maxValue = 2 ^ maxBits - dx <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits maxValue) - dy <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits maxValue) - dz <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits maxValue) - pure (Vector (dx - bias) (dy - bias) (dz - bias)) - --- | Puts a 'Vector' full of 'Float's. -putFloatVector :: Vector Float -> BinaryBit.BitPut () -putFloatVector vector = do - let maxValue = 1 - let numBits = 16 - [#x, #y, #z] & map (\field -> field vector) & - mapM_ (\value -> putFloat maxValue numBits value) - -putFloat :: Int -> Int -> Float -> BinaryBit.BitPut () -putFloat maxValue numBits value = do - let serIntMax = Bits.shiftL 1 numBits - let bias = Bits.shiftL 1 (numBits - 1) - let maxBitValue = (Bits.shiftL 1 (numBits - 1)) - 1 - let invScale = - if maxValue > maxBitValue - then fromIntegral maxValue / fromIntegral maxBitValue - else 1.0 / (fromIntegral maxBitValue / fromIntegral maxValue) - if abs value > fromIntegral maxValue * (invScale + 1) - then fail ("value " ++ show value ++ " > max value " ++ show maxValue) - else do - let unscaledValue = value / invScale - let delta = ceiling (unscaledValue + fromIntegral (bias :: Int)) - BinaryBit.putBits 0 (CompressedWord.CompressedWord serIntMax delta) - --- | Puts a 'Vector' full of 'Int8's. -putInt8Vector :: Vector Int8.Int8 -> BinaryBit.BitPut () -putInt8Vector vector = do - Foldable.for_ - [#x, #y, #z] - (\field -> do - case field vector of - 0 -> BinaryBit.putBits 0 (Boolean.Boolean False) - value -> do - BinaryBit.putBits 0 (Boolean.Boolean True) - BinaryBit.putBits 0 value) - --- | Puts a 'Vector' full of 'Int's. -putIntVector :: Vector Int -> BinaryBit.BitPut () -putIntVector vector = do - let maxNumBits = 19 - let numBits = 18 -- TODO - BinaryBit.putBits 0 (CompressedWord.CompressedWord maxNumBits numBits) - let bias = Bits.shiftL 1 (fromIntegral numBits + 1) - let maxBits = numBits + 2 - let maxValue = 2 ^ maxBits - let dx = vector & #x & (+ bias) & fromIntegral - let dy = vector & #y & (+ bias) & fromIntegral - let dz = vector & #z & (+ bias) & fromIntegral - BinaryBit.putBits 0 (CompressedWord.CompressedWord maxValue dx) - BinaryBit.putBits 0 (CompressedWord.CompressedWord maxValue dy) - BinaryBit.putBits 0 (CompressedWord.CompressedWord maxValue dz) diff --git a/library/Octane/Type/Word16.hs b/library/Octane/Type/Word16.hs --- a/library/Octane/Type/Word16.hs +++ b/library/Octane/Type/Word16.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,34 +15,18 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word -import qualified GHC.Generics as Generics import qualified Text.Printf as Printf -- | A 16-bit unsigned integer. newtype Word16 = Word16 { word16Unpack :: Word.Word16 - } deriving (Eq, Generics.Generic, Num, Ord) + } deriving (Eq, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Word16) - --- | Little-endian. -instance Binary.Binary Word16 where - get = do - value <- Binary.getWord16le - pure (Word16 value) - put word16 = do - let value = #unpack word16 - Binary.putWord16le value - -instance DeepSeq.NFData Word16 -- | Shown as @0x0102@. instance Show Word16 where diff --git a/library/Octane/Type/Word32.hs b/library/Octane/Type/Word32.hs --- a/library/Octane/Type/Word32.hs +++ b/library/Octane/Type/Word32.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,51 +15,18 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word -import qualified GHC.Generics as Generics -import qualified Octane.Utility.Endian as Endian import qualified Text.Printf as Printf -- | A 32-bit unsigned integer. newtype Word32 = Word32 { word32Unpack :: Word.Word32 - } deriving (Enum, Eq, Generics.Generic, Num, Ord) + } deriving (Enum, Eq, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Word32) - --- | Little-endian. -instance Binary.Binary Word32 where - get = do - value <- Binary.getWord32le - pure (Word32 value) - put word32 = do - let value = #unpack word32 - Binary.putWord32le value - --- | Little-endian with the bits in each byte reversed. -instance BinaryBit.BinaryBit Word32 where - getBits _ = do - bytes <- BinaryBit.getByteString 4 - bytes & LazyBytes.fromStrict & Endian.reverseBitsInLazyBytes & - Binary.runGet Binary.get & - pure - putBits _ word32 = - word32 & Binary.put & Binary.runPut & Endian.reverseBitsInLazyBytes & - LazyBytes.toStrict & - BinaryBit.putByteString - -instance DeepSeq.NFData Word32 -- | Shown as @0x01020304@. instance Show Word32 where diff --git a/library/Octane/Type/Word64.hs b/library/Octane/Type/Word64.hs --- a/library/Octane/Type/Word64.hs +++ b/library/Octane/Type/Word64.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,51 +15,18 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word -import qualified GHC.Generics as Generics -import qualified Octane.Utility.Endian as Endian import qualified Text.Printf as Printf -- | A 64-bit unsigned integer. newtype Word64 = Word64 { word64Unpack :: Word.Word64 - } deriving (Eq, Generics.Generic, Num, Ord) + } deriving (Eq, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Word64) - --- | Little-endian. -instance Binary.Binary Word64 where - get = do - value <- Binary.getWord64le - pure (Word64 value) - put word64 = do - let value = #unpack word64 - Binary.putWord64le value - --- | Little-endian with the bits in each byte reversed. -instance BinaryBit.BinaryBit Word64 where - getBits _ = do - bytes <- BinaryBit.getByteString 8 - bytes & LazyBytes.fromStrict & Endian.reverseBitsInLazyBytes & - Binary.runGet Binary.get & - pure - putBits _ word64 = - word64 & Binary.put & Binary.runPut & Endian.reverseBitsInLazyBytes & - LazyBytes.toStrict & - BinaryBit.putByteString - -instance DeepSeq.NFData Word64 -- | Shown as @0x0102030405060708@. instance Show Word64 where diff --git a/library/Octane/Type/Word8.hs b/library/Octane/Type/Word8.hs --- a/library/Octane/Type/Word8.hs +++ b/library/Octane/Type/Word8.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,50 +15,18 @@ import Data.Function ((&)) -import qualified Control.DeepSeq as DeepSeq import qualified Data.Aeson as Aeson -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Default.Class as Default import qualified Data.OverloadedRecords.TH as OverloadedRecords import qualified Data.Word as Word -import qualified GHC.Generics as Generics -import qualified Octane.Utility.Endian as Endian import qualified Text.Printf as Printf -- | A 8-bit unsigned integer. newtype Word8 = Word8 { word8Unpack :: Word.Word8 - } deriving (Eq, Generics.Generic, Num, Ord) + } deriving (Eq, Num, Ord) $(OverloadedRecords.overloadedRecord Default.def ''Word8) - -instance Binary.Binary Word8 where - get = do - value <- Binary.getWord8 - pure (Word8 value) - put word8 = do - let value = #unpack word8 - Binary.putWord8 value - --- | The bits are reversed. -instance BinaryBit.BinaryBit Word8 where - getBits _ = do - bytes <- BinaryBit.getByteString 1 - bytes & LazyBytes.fromStrict & Endian.reverseBitsInLazyBytes & - Binary.runGet Binary.get & - pure - putBits _ word8 = - word8 & Binary.put & Binary.runPut & Endian.reverseBitsInLazyBytes & - LazyBytes.toStrict & - BinaryBit.putByteString - -instance DeepSeq.NFData Word8 -- | Shown as @0x01@. instance Show Word8 where diff --git a/library/Octane/Utility.hs b/library/Octane/Utility.hs --- a/library/Octane/Utility.hs +++ b/library/Octane/Utility.hs @@ -1,17 +1,9 @@ module Octane.Utility - ( module Octane.Utility.ClassPropertyMap - , module Octane.Utility.CRC - , module Octane.Utility.Embed + ( module Octane.Utility.Embed , module Octane.Utility.Endian - , module Octane.Utility.Generator , module Octane.Utility.Optimizer - , module Octane.Utility.Parser ) where -import Octane.Utility.ClassPropertyMap -import Octane.Utility.CRC import Octane.Utility.Embed import Octane.Utility.Endian -import Octane.Utility.Generator import Octane.Utility.Optimizer -import Octane.Utility.Parser diff --git a/library/Octane/Utility/CRC.hs b/library/Octane/Utility/CRC.hs deleted file mode 100644 --- a/library/Octane/Utility/CRC.hs +++ /dev/null @@ -1,297 +0,0 @@ -module Octane.Utility.CRC - ( crc32 - ) where - -import qualified Data.Bits as Bits -import qualified Data.ByteString.Lazy as LazyBytes -import qualified Data.Vector.Unboxed as Vector -import qualified Data.Word as Word - --- | Computes the CRC32 of some bytes. Note that this is a non-standard CRC32. --- It probably only works for Rocket League. -crc32 :: LazyBytes.ByteString -> Word.Word32 -crc32 bytes = do - let update = crc32Update crc32Table - let initial = Bits.complement crc32Initial - let crc = LazyBytes.foldl update initial bytes - Bits.complement crc - -crc32Update :: Vector.Vector Word.Word32 - -> Word.Word32 - -> Word.Word8 - -> Word.Word32 -crc32Update table crc byte = do - let toWord8 = - fromIntegral :: (Integral a) => - a -> Word.Word8 - let toInt = - fromIntegral :: (Integral a) => - a -> Int - let index = toInt (Bits.xor byte (toWord8 (Bits.shiftR crc 24))) - let left = Vector.unsafeIndex table index - let right = Bits.shiftL crc 8 - Bits.xor left right - -crc32Initial :: Word.Word32 -crc32Initial = 0xefcbf201 - -crc32Table :: Vector.Vector Word.Word32 -crc32Table = - Vector.fromList - [ 0x00000000 - , 0x04c11db7 - , 0x09823b6e - , 0x0d4326d9 - , 0x130476dc - , 0x17c56b6b - , 0x1a864db2 - , 0x1e475005 - , 0x2608edb8 - , 0x22c9f00f - , 0x2f8ad6d6 - , 0x2b4bcb61 - , 0x350c9b64 - , 0x31cd86d3 - , 0x3c8ea00a - , 0x384fbdbd - , 0x4c11db70 - , 0x48d0c6c7 - , 0x4593e01e - , 0x4152fda9 - , 0x5f15adac - , 0x5bd4b01b - , 0x569796c2 - , 0x52568b75 - , 0x6a1936c8 - , 0x6ed82b7f - , 0x639b0da6 - , 0x675a1011 - , 0x791d4014 - , 0x7ddc5da3 - , 0x709f7b7a - , 0x745e66cd - , 0x9823b6e0 - , 0x9ce2ab57 - , 0x91a18d8e - , 0x95609039 - , 0x8b27c03c - , 0x8fe6dd8b - , 0x82a5fb52 - , 0x8664e6e5 - , 0xbe2b5b58 - , 0xbaea46ef - , 0xb7a96036 - , 0xb3687d81 - , 0xad2f2d84 - , 0xa9ee3033 - , 0xa4ad16ea - , 0xa06c0b5d - , 0xd4326d90 - , 0xd0f37027 - , 0xddb056fe - , 0xd9714b49 - , 0xc7361b4c - , 0xc3f706fb - , 0xceb42022 - , 0xca753d95 - , 0xf23a8028 - , 0xf6fb9d9f - , 0xfbb8bb46 - , 0xff79a6f1 - , 0xe13ef6f4 - , 0xe5ffeb43 - , 0xe8bccd9a - , 0xec7dd02d - , 0x34867077 - , 0x30476dc0 - , 0x3d044b19 - , 0x39c556ae - , 0x278206ab - , 0x23431b1c - , 0x2e003dc5 - , 0x2ac12072 - , 0x128e9dcf - , 0x164f8078 - , 0x1b0ca6a1 - , 0x1fcdbb16 - , 0x018aeb13 - , 0x054bf6a4 - , 0x0808d07d - , 0x0cc9cdca - , 0x7897ab07 - , 0x7c56b6b0 - , 0x71159069 - , 0x75d48dde - , 0x6b93dddb - , 0x6f52c06c - , 0x6211e6b5 - , 0x66d0fb02 - , 0x5e9f46bf - , 0x5a5e5b08 - , 0x571d7dd1 - , 0x53dc6066 - , 0x4d9b3063 - , 0x495a2dd4 - , 0x44190b0d - , 0x40d816ba - , 0xaca5c697 - , 0xa864db20 - , 0xa527fdf9 - , 0xa1e6e04e - , 0xbfa1b04b - , 0xbb60adfc - , 0xb6238b25 - , 0xb2e29692 - , 0x8aad2b2f - , 0x8e6c3698 - , 0x832f1041 - , 0x87ee0df6 - , 0x99a95df3 - , 0x9d684044 - , 0x902b669d - , 0x94ea7b2a - , 0xe0b41de7 - , 0xe4750050 - , 0xe9362689 - , 0xedf73b3e - , 0xf3b06b3b - , 0xf771768c - , 0xfa325055 - , 0xfef34de2 - , 0xc6bcf05f - , 0xc27dede8 - , 0xcf3ecb31 - , 0xcbffd686 - , 0xd5b88683 - , 0xd1799b34 - , 0xdc3abded - , 0xd8fba05a - , 0x690ce0ee - , 0x6dcdfd59 - , 0x608edb80 - , 0x644fc637 - , 0x7a089632 - , 0x7ec98b85 - , 0x738aad5c - , 0x774bb0eb - , 0x4f040d56 - , 0x4bc510e1 - , 0x46863638 - , 0x42472b8f - , 0x5c007b8a - , 0x58c1663d - , 0x558240e4 - , 0x51435d53 - , 0x251d3b9e - , 0x21dc2629 - , 0x2c9f00f0 - , 0x285e1d47 - , 0x36194d42 - , 0x32d850f5 - , 0x3f9b762c - , 0x3b5a6b9b - , 0x0315d626 - , 0x07d4cb91 - , 0x0a97ed48 - , 0x0e56f0ff - , 0x1011a0fa - , 0x14d0bd4d - , 0x19939b94 - , 0x1d528623 - , 0xf12f560e - , 0xf5ee4bb9 - , 0xf8ad6d60 - , 0xfc6c70d7 - , 0xe22b20d2 - , 0xe6ea3d65 - , 0xeba91bbc - , 0xef68060b - , 0xd727bbb6 - , 0xd3e6a601 - , 0xdea580d8 - , 0xda649d6f - , 0xc423cd6a - , 0xc0e2d0dd - , 0xcda1f604 - , 0xc960ebb3 - , 0xbd3e8d7e - , 0xb9ff90c9 - , 0xb4bcb610 - , 0xb07daba7 - , 0xae3afba2 - , 0xaafbe615 - , 0xa7b8c0cc - , 0xa379dd7b - , 0x9b3660c6 - , 0x9ff77d71 - , 0x92b45ba8 - , 0x9675461f - , 0x8832161a - , 0x8cf30bad - , 0x81b02d74 - , 0x857130c3 - , 0x5d8a9099 - , 0x594b8d2e - , 0x5408abf7 - , 0x50c9b640 - , 0x4e8ee645 - , 0x4a4ffbf2 - , 0x470cdd2b - , 0x43cdc09c - , 0x7b827d21 - , 0x7f436096 - , 0x7200464f - , 0x76c15bf8 - , 0x68860bfd - , 0x6c47164a - , 0x61043093 - , 0x65c52d24 - , 0x119b4be9 - , 0x155a565e - , 0x18197087 - , 0x1cd86d30 - , 0x029f3d35 - , 0x065e2082 - , 0x0b1d065b - , 0x0fdc1bec - , 0x3793a651 - , 0x3352bbe6 - , 0x3e119d3f - , 0x3ad08088 - , 0x2497d08d - , 0x2056cd3a - , 0x2d15ebe3 - , 0x29d4f654 - , 0xc5a92679 - , 0xc1683bce - , 0xcc2b1d17 - , 0xc8ea00a0 - , 0xd6ad50a5 - , 0xd26c4d12 - , 0xdf2f6bcb - , 0xdbee767c - , 0xe3a1cbc1 - , 0xe760d676 - , 0xea23f0af - , 0xeee2ed18 - , 0xf0a5bd1d - , 0xf464a0aa - , 0xf9278673 - , 0xfde69bc4 - , 0x89b8fd09 - , 0x8d79e0be - , 0x803ac667 - , 0x84fbdbd0 - , 0x9abc8bd5 - , 0x9e7d9662 - , 0x933eb0bb - , 0x97ffad0c - , 0xafb010b1 - , 0xab710d06 - , 0xa6322bdf - , 0xa2f33668 - , 0xbcb4666d - , 0xb8757bda - , 0xb5365d03 - , 0xb1f740b4 - ] diff --git a/library/Octane/Utility/ClassPropertyMap.hs b/library/Octane/Utility/ClassPropertyMap.hs deleted file mode 100644 --- a/library/Octane/Utility/ClassPropertyMap.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PackageImports #-} - --- | This module is responsible for building the class property map, which maps --- class IDs to a map of property IDs to property names. This map is the --- cornerstone of the replay stream parser. -module Octane.Utility.ClassPropertyMap - ( getClassPropertyMap - , getPropertyMap - , getActorMap - , getClass - ) where - -import Data.Function ((&)) - -import qualified Data.Bimap as Bimap -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.Text as StrictText -import qualified Octane.Data as Data -import qualified Octane.Type.ReplayWithoutFrames as Replay -import qualified Octane.Type.Word32 as Word32 -import qualified "regex-compat" Text.Regex as Regex - --- | 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 :: Replay.ReplayWithoutFrames - -> IntMap.IntMap (IntMap.IntMap StrictText.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 4-tuples where the first element is a class --- ID, the second is its name, the third is its cache ID, the fourth is its --- parent's cache ID. -getClassCache :: Replay.ReplayWithoutFrames - -> [(Int, StrictText.Text, Int, Int)] -getClassCache replay = do - let classNames = replay & getActorMap & Bimap.toMapR - replay & #cache & #unpack & - map - (\cacheItem -> do - let classId = cacheItem & #classId & Word32.fromWord32 - let className = - case Map.lookup classId classNames of - Nothing -> - error - ("could not find class name for id " ++ - show classId ++ " in " ++ show classNames) - Just x -> x - let cacheId = cacheItem & #cacheId & Word32.fromWord32 - let parentCacheId = cacheItem & #parentCacheId & Word32.fromWord32 - (classId, className, cacheId, parentCacheId)) - --- | The class IDs in a replay. Comes from the class cache. -getClassIds :: Replay.ReplayWithoutFrames -> [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 :: Maybe StrictText.Text - -> Int - -> [(Int, StrictText.Text, Int, Int)] - -> Maybe Int -getParentClassId maybeClassName parentCacheId xs = - case maybeClassName of - Nothing -> getParentClassIdById parentCacheId xs - Just className -> getParentClassIdByName className parentCacheId xs - -getParentClassIdById :: Int -> [(Int, StrictText.Text, Int, Int)] -> Maybe Int -getParentClassIdById parentCacheId xs = - case dropWhile (\(_, _, cacheId, _) -> cacheId /= parentCacheId) xs of - [] -> - if parentCacheId <= 0 - then Nothing - else getParentClassIdById (parentCacheId - 1) xs - (parentClassId, _, _, _):_ -> Just parentClassId - -getParentClassIdByName :: StrictText.Text - -> Int - -> [(Int, StrictText.Text, Int, Int)] - -> Maybe Int -getParentClassIdByName className parentCacheId xs = - case Map.lookup className Data.parentClasses of - Just parentClassName -> - xs & filter (\(_, name, _, _) -> name == parentClassName) & - filter (\(_, _, cacheId, _) -> cacheId == parentCacheId) & - map (\(classId, _, _, _) -> classId) & - Maybe.listToMaybe & - Maybe.maybe (getParentClassIdById parentCacheId xs) Just - Nothing -> getParentClassIdById parentCacheId xs - --- | 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 :: Replay.ReplayWithoutFrames -> IntMap.IntMap Int -getBasicClassMap replay = - replay & getClassCache & reverse & List.tails & - Maybe.mapMaybe - (\xs -> - case xs of - [] -> Nothing - (classId, className, _, parentCacheId):ys -> do - parentClassId <- getParentClassId (Just className) parentCacheId ys - pure (classId, parentClassId)) & - IntMap.fromList - --- | Given a naive mapping from class ID to its parent class ID, pure 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 :: Replay.ReplayWithoutFrames -> 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 :: Replay.ReplayWithoutFrames -> IntMap.IntMap StrictText.Text -getPropertyMap replay = - replay & #objects & #unpack & map #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 :: Replay.ReplayWithoutFrames - -> IntMap.IntMap (IntMap.IntMap StrictText.Text) -getBasicClassPropertyMap replay = - let propertyMap = getPropertyMap replay - in replay & #cache & #unpack & - map - (\x -> - let classId = x & #classId & Word32.fromWord32 - properties = - x & #properties & #unpack & - Maybe.mapMaybe - (\y -> - let streamId = y & #streamId & Word32.fromWord32 - propertyId = y & #objectId & Word32.fromWord32 - 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 :: Replay.ReplayWithoutFrames -> Bimap.Bimap StrictText.Text Int -getActorMap replay = - replay & #classes & #unpack & - map - (\x -> - let className = x & #name & #unpack - classId = x & #streamId & Word32.fromWord32 - in (className, classId)) & - Bimap.fromList - --- | Gets the class ID and name for a given property ID. -getClass - :: (Monad m) - => IntMap.IntMap StrictText.Text -- ^ Property ID to property name - -> Map.Map StrictText.Text StrictText.Text -- ^ Property name to class name - -> Map.Map StrictText.Text Int -- ^ Class name to class ID - -> Int -- ^ property ID - -> m (Int, StrictText.Text) -- ^ Maybe class ID and class name -getClass propertyIdsToNames propertyNamesToClassNames classNamesToIds propertyId = do - rawPropertyName <- getPropertyName propertyIdsToNames propertyId - let propertyName = normalizeName rawPropertyName - className <- getClassName propertyNamesToClassNames propertyName - classId <- getClassId classNamesToIds className - pure (classId, className) - -getPropertyName - :: (Monad m) - => IntMap.IntMap StrictText.Text -> Int -> m StrictText.Text -getPropertyName propertyNames propertyId = do - case IntMap.lookup propertyId propertyNames of - Nothing -> do - fail ("Could not find name for property " ++ show propertyId) - Just propertyName -> do - pure propertyName - -normalizeName :: StrictText.Text -> StrictText.Text -normalizeName name = - name & StrictText.unpack & replace "_[0-9]+$" "" & - replace "^[A-Z_a-z]+[.]TheWorld:" "TheWorld:" & - StrictText.pack - -replace :: String -> String -> String -> String -replace needle replacement haystack = - Regex.subRegex (Regex.mkRegex needle) haystack replacement - -getClassName - :: (Monad m) - => Map.Map StrictText.Text StrictText.Text - -> StrictText.Text - -> m StrictText.Text -getClassName classNames propertyName = do - case Map.lookup propertyName classNames of - Nothing -> do - fail ("Could not find class for property " ++ show propertyName) - Just className -> do - pure className - -getClassId - :: (Monad m) - => Map.Map StrictText.Text Int -> StrictText.Text -> m Int -getClassId classIds className = do - case Map.lookup className classIds of - Nothing -> do - fail ("Could not find ID for class " ++ show className) - Just classId -> do - pure classId diff --git a/library/Octane/Utility/Embed.hs b/library/Octane/Utility/Embed.hs --- a/library/Octane/Utility/Embed.hs +++ b/library/Octane/Utility/Embed.hs @@ -3,8 +3,6 @@ -- | These helper functions are usually used with 'Data.FileEmbed.embedFile'. module Octane.Utility.Embed ( decodeBimap - , decodeMap - , decodeSet ) where import Data.Function ((&)) @@ -14,7 +12,6 @@ import qualified Data.ByteString as StrictBytes import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -- | Decodes some bytes into a bidirection map. The bytes are assumed to be a -- JSON object mapping values to keys. That means the resulting bimap is @@ -26,16 +23,3 @@ bytes & Aeson.decodeStrict & Maybe.fromMaybe Map.empty & Map.toList & Bimap.fromList & Bimap.twist - --- | Decodes some bytes into a map. The bytes are assumed to be a JSON object --- mapping keys to values. -decodeMap - :: (Aeson.FromJSON (Map.Map a b)) - => StrictBytes.ByteString -> Map.Map a b -decodeMap bytes = bytes & Aeson.decodeStrict & Maybe.fromMaybe Map.empty - --- | Decodes some bytes into a set. The bytes are assumed to be a JSON array. -decodeSet - :: (Aeson.FromJSON a, Ord a) - => StrictBytes.ByteString -> Set.Set a -decodeSet bytes = bytes & Aeson.decodeStrict & Maybe.fromMaybe Set.empty diff --git a/library/Octane/Utility/Endian.hs b/library/Octane/Utility/Endian.hs --- a/library/Octane/Utility/Endian.hs +++ b/library/Octane/Utility/Endian.hs @@ -1,18 +1,12 @@ {-# LANGUAGE BinaryLiterals #-} module Octane.Utility.Endian - ( reverseBitsInLazyBytes - , reverseBitsInStrictBytes + ( reverseBitsInStrictBytes ) where import qualified Data.Bits as Bits import qualified Data.ByteString as StrictBytes -import qualified Data.ByteString.Lazy as LazyBytes import qualified Data.Word as Word - --- | Reverses all the bits in each lazy byte. -reverseBitsInLazyBytes :: LazyBytes.ByteString -> LazyBytes.ByteString -reverseBitsInLazyBytes bytes = LazyBytes.map reverseBits bytes -- | Reverses all the bits in each strict byte. reverseBitsInStrictBytes :: StrictBytes.ByteString -> StrictBytes.ByteString diff --git a/library/Octane/Utility/Generator.hs b/library/Octane/Utility/Generator.hs deleted file mode 100644 --- a/library/Octane/Utility/Generator.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Utility.Generator - ( generateStream - ) where - -import Data.Function ((&)) - -import qualified Control.Monad as Monad -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Put as Binary -import qualified Data.Default.Class as Default -import qualified Data.Map.Strict as Map -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified Data.Text as StrictText -import qualified Data.Tuple as Tuple -import qualified Octane.Type.Boolean as Boolean -import qualified Octane.Type.CacheItem as CacheItem -import qualified Octane.Type.ClassItem as ClassItem -import qualified Octane.Type.CompressedWord as CompressedWord -import qualified Octane.Type.Frame as Frame -import qualified Octane.Type.Initialization as Initialization -import qualified Octane.Type.Int32 as Int32 -import qualified Octane.Type.List as List -import qualified Octane.Type.RemoteId as RemoteId -import qualified Octane.Type.Replication as Replication -import qualified Octane.Type.State as State -import qualified Octane.Type.Stream as Stream -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Value as Value -import qualified Octane.Type.Vector as Vector -import qualified Octane.Type.Word16 as Word16 -import qualified Octane.Type.Word32 as Word32 -import qualified Octane.Type.Word8 as Word8 - -data Context = Context - { contextObjectMap :: Map.Map StrictText.Text Int32.Int32 - -- ^ { object name => object id } - , contextClassPropertyMap :: Map.Map StrictText.Text (Map.Map StrictText.Text CompressedWord.CompressedWord) - -- ^ { class name => { property name => property id } } - } - -$(OverloadedRecords.overloadedRecord Default.def ''Context) - --- | Generates a network stream. -generateStream - :: [Frame.Frame] - -> List.List Text.Text - -> List.List Text.Text - -> List.List ClassItem.ClassItem - -> List.List CacheItem.CacheItem - -> Stream.Stream -generateStream frames objects _names classes cache = do - let context = makeContext objects classes cache - let bitPut = putFrames context frames - let bytePut = BinaryBit.runBitPut bitPut - let bytes = Binary.runPut bytePut - Stream.Stream bytes - -makeContext - :: List.List Text.Text - -> List.List ClassItem.ClassItem - -> List.List CacheItem.CacheItem - -> Context -makeContext objects classes cache = do - let objectMap = - objects & #unpack & map #unpack & zip [0 ..] & map Tuple.swap & - Map.fromList - let classMap = - classes & #unpack & - map (\classItem -> (#streamId classItem, classItem & #name & #unpack)) & - Map.fromList - let classPropertyMap = - cache & #unpack & - map - (\cacheItem -> do - let className = - case Map.lookup (#classId cacheItem) classMap of - Nothing -> - error ("could not find class id for " ++ show className) - Just name -> name - let maxPropertyId = - cacheItem & #properties & #unpack & map #streamId & - map Word32.fromWord32 & - (0 :) & - maximum - let properties = - cacheItem & #properties & #unpack & - map - (\cacheProperty -> do - let propertyName = - case objectMap & Map.assocs & map Tuple.swap & - Map.fromList & - Map.lookup - (cacheProperty & #objectId & - Word32.fromWord32 & - (\x -> x :: Int) & - Int32.toInt32) of - Nothing -> - error - ("coult not find property name for " ++ - show cacheProperty) - Just name -> name - let propertyId = - cacheProperty & #streamId & Word32.fromWord32 & - CompressedWord.CompressedWord maxPropertyId - (propertyName, propertyId)) & - Map.fromList - (className, properties)) & - Map.fromList - Context objectMap classPropertyMap - -putFrames :: Context -> [Frame.Frame] -> BinaryBit.BitPut () -putFrames context frames = do - case frames of - [] -> pure () - frame:rest -> do - putFrame context frame - putFrames context rest - -putFrame :: Context -> Frame.Frame -> BinaryBit.BitPut () -putFrame context frame = do - frame & #time & BinaryBit.putBits 32 - frame & #delta & BinaryBit.putBits 32 - frame & #replications & putReplications context - -putReplications :: Context -> [Replication.Replication] -> BinaryBit.BitPut () -putReplications context replications = do - case replications of - [] -> do - False & Boolean.Boolean & BinaryBit.putBits 1 -- no more replications - replication:rest -> do - True & Boolean.Boolean & BinaryBit.putBits 1 -- has replication - putReplication context replication - putReplications context rest - -putReplication :: Context -> Replication.Replication -> BinaryBit.BitPut () -putReplication context replication = do - replication & #actorId & BinaryBit.putBits 0 - case #state replication of - State.Opening -> putNewReplication context replication - State.Existing -> putExistingReplication context replication - State.Closing -> putClosedReplication - -putNewReplication :: Context -> Replication.Replication -> BinaryBit.BitPut () -putNewReplication context replication = do - True & Boolean.Boolean & BinaryBit.putBits 1 -- open - True & Boolean.Boolean & BinaryBit.putBits 1 -- new - False & Boolean.Boolean & BinaryBit.putBits 1 -- unknown - let objectName = #objectName replication - case Map.lookup objectName (#objectMap context) of - Nothing -> fail ("could not find object id for name " ++ show objectName) - Just objectId -> BinaryBit.putBits 0 objectId - case #initialization replication of - Nothing -> pure () - Just x -> Initialization.putInitialization x - -putExistingReplication :: Context - -> Replication.Replication - -> BinaryBit.BitPut () -putExistingReplication context replication = do - True & Boolean.Boolean & BinaryBit.putBits 1 -- open - False & Boolean.Boolean & BinaryBit.putBits 1 -- existing - let className = #className replication - let properties = replication & #properties & Map.toAscList - mapM_ (putProperty context className) properties - False & Boolean.Boolean & BinaryBit.putBits 1 -- no more properties - -putClosedReplication :: BinaryBit.BitPut () -putClosedReplication = do - False & Boolean.Boolean & BinaryBit.putBits 1 -- closed - -putProperty - :: Context - -> StrictText.Text - -> (StrictText.Text, Value.Value) - -> BinaryBit.BitPut () -putProperty context className (propertyName, value) = do - True & Boolean.Boolean & BinaryBit.putBits 1 -- has property - case Map.lookup className (#classPropertyMap context) of - Nothing -> fail ("could not find properties for class " ++ show className) - Just properties -> - case Map.lookup propertyName properties of - Nothing -> - fail - ("could not find property id for name " ++ - show propertyName ++ " in class " ++ show className) - Just propertyId -> BinaryBit.putBits 0 propertyId - putValue value - -putValue :: Value.Value -> BinaryBit.BitPut () -putValue value = - case value of - Value.ValueBoolean x -> putBooleanValue x - Value.ValueByte x -> putByteValue x - Value.ValueCamSettings x -> putCamSettingsValue x - Value.ValueDemolish x -> putDemolishValue x - Value.ValueEnum x -> putEnumValue x - Value.ValueExplosion x -> putExplosionValue x - Value.ValueFlaggedInt x -> putFlaggedIntValue x - Value.ValueFloat x -> putFloatValue x - Value.ValueGameMode x -> putGameModeValue x - Value.ValueInt x -> putIntValue x - Value.ValueLoadout x -> putLoadoutValue x - Value.ValueLoadoutOnline x -> putLoadoutOnlineValue x - Value.ValueLoadouts x -> putLoadoutsValue x - Value.ValueLoadoutsOnline x -> putLoadoutsOnlineValue x - Value.ValueLocation x -> putLocationValue x - Value.ValueMusicStinger x -> putMusicStingerValue x - Value.ValuePickup x -> putPickupValue x - Value.ValuePrivateMatchSettings x -> putPrivateMatchSettingsValue x - Value.ValueQWord x -> putQWordValue x - Value.ValueRelativeRotation x -> putRelativeRotationValue x - Value.ValueReservation x -> putReservationValue x - Value.ValueRigidBodyState x -> putRigidBodyStateValue x - Value.ValueString x -> putStringValue x - Value.ValueTeamPaint x -> putTeamPaintValue x - Value.ValueUniqueId x -> putUniqueIdValue x - Value.ValueWeldedInfo x -> putWeldedInfoValue x - -putBooleanValue :: Value.BooleanValue -> BinaryBit.BitPut () -putBooleanValue value = do - value & #unpack & BinaryBit.putBits 0 - -putByteValue :: Value.ByteValue -> BinaryBit.BitPut () -putByteValue value = do - value & #unpack & BinaryBit.putBits 0 - -putCamSettingsValue :: Value.CamSettingsValue -> BinaryBit.BitPut () -putCamSettingsValue value = do - value & #fov & BinaryBit.putBits 0 - value & #height & BinaryBit.putBits 0 - value & #angle & BinaryBit.putBits 0 - value & #distance & BinaryBit.putBits 0 - value & #stiffness & BinaryBit.putBits 0 - value & #swivelSpeed & BinaryBit.putBits 0 - -putDemolishValue :: Value.DemolishValue -> BinaryBit.BitPut () -putDemolishValue value = do - value & #attackerFlag & BinaryBit.putBits 0 - value & #attackerActorId & BinaryBit.putBits 0 - value & #victimFlag & BinaryBit.putBits 0 - value & #victimActorId & BinaryBit.putBits 0 - value & #attackerVelocity & Vector.putIntVector - value & #victimVelocity & Vector.putIntVector - -putEnumValue :: Value.EnumValue -> BinaryBit.BitPut () -putEnumValue value = do - value & #value & Word16.fromWord16 & BinaryBit.putWord16be 10 - value & #flag & BinaryBit.putBits 0 - -putExplosionValue :: Value.ExplosionValue -> BinaryBit.BitPut () -putExplosionValue value = do - value & #actorless & BinaryBit.putBits 0 - value & #actorId & maybePutBits 0 - value & #position & Vector.putIntVector - -putFlaggedIntValue :: Value.FlaggedIntValue -> BinaryBit.BitPut () -putFlaggedIntValue value = do - value & #flag & BinaryBit.putBits 0 - value & #int & BinaryBit.putBits 0 - -putFloatValue :: Value.FloatValue -> BinaryBit.BitPut () -putFloatValue value = do - value & #unpack & BinaryBit.putBits 0 - -putGameModeValue :: Value.GameModeValue -> BinaryBit.BitPut () -putGameModeValue value - -- The parser only reads 2 bits for older replays. This generator only makes - -- replays that work with the latest version, so it always writes 8 bits. - = do - value & #unpack & BinaryBit.putBits 0 - -putIntValue :: Value.IntValue -> BinaryBit.BitPut () -putIntValue value = do - value & #unpack & BinaryBit.putBits 0 - -putLoadoutValue :: Value.LoadoutValue -> BinaryBit.BitPut () -putLoadoutValue value = do - value & #version & BinaryBit.putBits 0 - value & #body & BinaryBit.putBits 0 - value & #decal & BinaryBit.putBits 0 - value & #wheels & BinaryBit.putBits 0 - value & #rocketTrail & BinaryBit.putBits 0 - value & #antenna & BinaryBit.putBits 0 - value & #topper & BinaryBit.putBits 0 - value & #unknown1 & BinaryBit.putBits 0 - value & #unknown2 & maybePutBits 0 - -putLoadoutsValue :: Value.LoadoutsValue -> BinaryBit.BitPut () -putLoadoutsValue value = do - value & #loadout1 & putLoadoutValue - value & #loadout2 & putLoadoutValue - -putLoadoutOnlineValue :: Value.LoadoutOnlineValue -> BinaryBit.BitPut () -putLoadoutOnlineValue value = do - value & #unpack & length & Word8.toWord8 & BinaryBit.putBits 0 - Monad.forM_ - (#unpack value) - (\tuples -> do - tuples & length & Word8.toWord8 & BinaryBit.putBits 0 - Monad.forM_ - tuples - (\(k, v) -> do - BinaryBit.putBits 0 k - BinaryBit.putBits 0 v)) - -putLoadoutsOnlineValue :: Value.LoadoutsOnlineValue -> BinaryBit.BitPut () -putLoadoutsOnlineValue value = do - value & #loadout1 & putLoadoutOnlineValue - value & #loadout2 & putLoadoutOnlineValue - value & #unknown1 & BinaryBit.putBits 0 - value & #unknown2 & BinaryBit.putBits 0 - -putLocationValue :: Value.LocationValue -> BinaryBit.BitPut () -putLocationValue value = do - value & #unpack & Vector.putIntVector - -putMusicStingerValue :: Value.MusicStingerValue -> BinaryBit.BitPut () -putMusicStingerValue value = do - value & #flag & BinaryBit.putBits 0 - value & #cue & BinaryBit.putBits 0 - value & #trigger & BinaryBit.putBits 0 - -putPickupValue :: Value.PickupValue -> BinaryBit.BitPut () -putPickupValue value = do - value & #hasInstigator & BinaryBit.putBits 0 - value & #instigatorId & maybePutBits 0 - value & #pickedUp & BinaryBit.putBits 0 - -putPrivateMatchSettingsValue :: Value.PrivateMatchSettingsValue - -> BinaryBit.BitPut () -putPrivateMatchSettingsValue value = do - value & #mutators & BinaryBit.putBits 0 - value & #joinableBy & BinaryBit.putBits 0 - value & #maxPlayers & BinaryBit.putBits 0 - value & #gameName & BinaryBit.putBits 0 - value & #password & BinaryBit.putBits 0 - value & #flag & BinaryBit.putBits 0 - -putQWordValue :: Value.QWordValue -> BinaryBit.BitPut () -putQWordValue value = do - value & #unpack & BinaryBit.putBits 0 - -putRelativeRotationValue :: Value.RelativeRotationValue -> BinaryBit.BitPut () -putRelativeRotationValue value = do - value & #unpack & Vector.putFloatVector - -putReservationValue :: Value.ReservationValue -> BinaryBit.BitPut () -putReservationValue value = do - value & #number & BinaryBit.putBits 0 - Value.UniqueIdValue (#systemId value) (#remoteId value) (#localId value) & - putUniqueIdValue - value & #playerName & maybePutBits 0 - value & #unknown1 & BinaryBit.putBits 0 - value & #unknown2 & BinaryBit.putBits 0 - -- The parser only reads 6 bits for newer replays. This generator only makes - -- replays that work with the latest version, so it always writes 6 bits. - BinaryBit.putWord8 6 0 - -putRigidBodyStateValue :: Value.RigidBodyStateValue -> BinaryBit.BitPut () -putRigidBodyStateValue value = do - value & #sleeping & BinaryBit.putBits 0 - value & #position & Vector.putIntVector - value & #rotation & Vector.putFloatVector - case #linearVelocity value of - Nothing -> pure () - Just linearVelocity -> Vector.putIntVector linearVelocity - case #angularVelocity value of - Nothing -> pure () - Just angularVelocity -> Vector.putIntVector angularVelocity - -putStringValue :: Value.StringValue -> BinaryBit.BitPut () -putStringValue value = do - value & #unpack & BinaryBit.putBits 0 - -putTeamPaintValue :: Value.TeamPaintValue -> BinaryBit.BitPut () -putTeamPaintValue value = do - value & #team & BinaryBit.putBits 0 - value & #primaryColor & BinaryBit.putBits 0 - value & #accentColor & BinaryBit.putBits 0 - value & #primaryFinish & BinaryBit.putBits 0 - value & #accentFinish & BinaryBit.putBits 0 - -putUniqueIdValue :: Value.UniqueIdValue -> BinaryBit.BitPut () -putUniqueIdValue value = do - value & #systemId & BinaryBit.putBits 0 - value & #remoteId & putRemoteId - value & #localId & maybePutBits 0 - -putWeldedInfoValue :: Value.WeldedInfoValue -> BinaryBit.BitPut () -putWeldedInfoValue value = do - value & #active & BinaryBit.putBits 0 - value & #actorId & BinaryBit.putBits 0 - value & #offset & Vector.putIntVector - value & #mass & BinaryBit.putBits 0 - value & #rotation & Vector.putInt8Vector - -maybePutBits - :: (BinaryBit.BinaryBit a) - => Int -> Maybe a -> BinaryBit.BitPut () -maybePutBits n mx = - case mx of - Nothing -> pure () - Just x -> BinaryBit.putBits n x - -putRemoteId :: RemoteId.RemoteId -> BinaryBit.BitPut () -putRemoteId remoteId = - case remoteId of - RemoteId.RemoteSplitscreenId x -> BinaryBit.putBits 0 x - RemoteId.RemoteSteamId x -> BinaryBit.putBits 0 x - RemoteId.RemotePlayStationId x -> BinaryBit.putBits 0 x - RemoteId.RemoteXboxId x -> BinaryBit.putBits 0 x diff --git a/library/Octane/Utility/Parser.hs b/library/Octane/Utility/Parser.hs deleted file mode 100644 --- a/library/Octane/Utility/Parser.hs +++ /dev/null @@ -1,792 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Octane.Utility.Parser - ( parseStream - ) where - -import Data.Function ((&)) - -import qualified Control.DeepSeq as DeepSeq -import qualified Control.Monad as Monad -import qualified Data.Bimap as Bimap -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Default.Class as Default -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map.Strict as Map -import qualified Data.OverloadedRecords.TH as OverloadedRecords -import qualified Data.Set as Set -import qualified Data.Text as StrictText -import qualified Data.Version as Version -import qualified Debug.Trace as Trace -import qualified GHC.Generics as Generics -import qualified Octane.Data as Data -import qualified Octane.Type.Boolean as Boolean -import qualified Octane.Type.CompressedWord as CompressedWord -import qualified Octane.Type.Float32 as Float32 -import qualified Octane.Type.Frame as Frame -import qualified Octane.Type.Initialization as Initialization -import qualified Octane.Type.Int32 as Int32 -import qualified Octane.Type.Property as Property -import qualified Octane.Type.RemoteId as RemoteId -import qualified Octane.Type.ReplayWithoutFrames as Replay -import qualified Octane.Type.Replication as Replication -import qualified Octane.Type.State as State -import qualified Octane.Type.Text as Text -import qualified Octane.Type.Value as Value -import qualified Octane.Type.Vector as Vector -import qualified Octane.Type.Word16 as Word16 -import qualified Octane.Type.Word32 as Word32 -import qualified Octane.Type.Word64 as Word64 -import qualified Octane.Type.Word8 as Word8 -import qualified Octane.Utility.ClassPropertyMap as CPM -import qualified System.Environment as Environment -import qualified System.IO.Unsafe as Unsafe -import qualified Text.Printf as Printf - -debug :: Bool -debug = - Unsafe.unsafePerformIO (Environment.lookupEnv "OCTANE_DEBUG") == Just "1" - -trace - :: (Applicative m) - => String -> m () -trace message = Monad.when debug (Trace.traceM message) - --- Data types --- { class stream id => { property stream id => name } } -type ClassPropertyMap = IntMap.IntMap (IntMap.IntMap StrictText.Text) - --- { stream id => object name } -type ObjectMap = IntMap.IntMap StrictText.Text - --- { class name => class id } -type ClassMap = Map.Map StrictText.Text Int - -data Thing = Thing - { thingFlag :: Boolean.Boolean - , thingObjectId :: Int32.Int32 - , thingObjectName :: StrictText.Text - , thingClassId :: Int - , thingClassName :: StrictText.Text - , thingInitialization :: Initialization.Initialization - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''Thing) - -instance DeepSeq.NFData Thing - -data Context = Context - { contextObjectMap :: ObjectMap - , contextClassPropertyMap :: ClassPropertyMap - , contextThings :: IntMap.IntMap Thing - , contextClassMap :: ClassMap - , contextKeyFrames :: Set.Set Word - , contextVersion :: Version.Version - } deriving (Eq, Generics.Generic, Show) - -$(OverloadedRecords.overloadedRecord Default.def ''Context) - -instance DeepSeq.NFData Context - -extractContext :: Replay.ReplayWithoutFrames -> Context -extractContext replay = do - let keyFrames = - replay & #keyFrames & #unpack & map #frame & map Word32.fromWord32 & - Set.fromList - let version = - [replay & #version1, replay & #version2] & map Word32.fromWord32 & - Version.makeVersion - Context - (CPM.getPropertyMap replay) - (CPM.getClassPropertyMap replay) - IntMap.empty - (replay & CPM.getActorMap & Bimap.toMap) - keyFrames - version - --- | Parses the network stream and returns a list of frames. -parseStream :: Replay.ReplayWithoutFrames -> [Frame.Frame] -parseStream replay = do - let get = replay & getStream & BinaryBit.runBitGet - let stream = replay & #stream & #unpack - Binary.runGet get stream - -getStream :: Replay.ReplayWithoutFrames -> BinaryBit.BitGet [Frame.Frame] -getStream replay = do - let numFrames = - replay & #properties & #unpack & Map.lookup "NumFrames" & - (\property -> - case property of - Just (Property.PropertyInt int) -> int & #content & Int32.fromInt32 - _ -> 0) - trace (Printf.printf "Getting %d frame(s)" numFrames) - let context = extractContext replay - context & #classMap & Map.toAscList & - map (\(k, v) -> show k ++ "\t" ++ show v) & - ("CLASS MAP" :) & - unlines & - trace - context & #classPropertyMap & IntMap.toAscList & - map - (\(k1, v1) -> - show k1 ++ - "\n" ++ - (v1 & IntMap.toAscList & - map (\(k2, v2) -> "\t" ++ show k2 ++ "\t" ++ show v2) & - unlines)) & - ("CLASS PROPERTY MAP" :) & - unlines & - trace - (_newContext, frames) <- getFrames 0 numFrames context - pure frames - -getFrames :: Word -> Int -> Context -> BinaryBit.BitGet (Context, [Frame.Frame]) -getFrames number numFrames context = do - trace (Printf.printf "Getting frame %d of %d" number numFrames) - if fromIntegral number >= numFrames - then pure (context, []) - else do - isEmpty <- BinaryBit.isEmpty - if isEmpty - then pure (context, []) - else do - maybeFrame <- getMaybeFrame context number - case maybeFrame of - Nothing -> pure (context, []) - Just (newContext, frame) -> do - (newerContext, frames) <- - getFrames (number + 1) numFrames newContext - pure (newerContext, (frame : frames)) - -getMaybeFrame :: Context - -> Word - -> BinaryBit.BitGet (Maybe (Context, Frame.Frame)) -getMaybeFrame context number = do - time <- getFloat32 - delta <- getFloat32 - trace - (Printf.printf - "Getting frame %d at time %.2f with delta %.2f" - number - (#unpack time) - (#unpack delta)) - if time == 0 && delta == 0 - then pure Nothing - else if time < 0.001 || delta < 0.001 - then fail - ("parsing previous frame probably failed. time: " ++ - show time ++ ", delta: " ++ show delta) - else do - (newContext, frame) <- getFrame context number time delta - pure (Just (newContext, frame)) - -getFrame - :: Context - -> Word - -> Float32.Float32 - -> Float32.Float32 - -> BinaryBit.BitGet (Context, Frame.Frame) -getFrame context number time delta = do - trace (Printf.printf "Getting replications for frame %d" number) - (newContext, replications) <- getReplications context - let frame = - Frame.Frame - number - (context & #keyFrames & Set.member number) - time - delta - replications - (newContext, frame) & DeepSeq.force & pure - -getReplications :: Context - -> BinaryBit.BitGet (Context, [Replication.Replication]) -getReplications context = do - maybeReplication <- getMaybeReplication context - case maybeReplication of - Nothing -> pure (context, []) - Just (newContext, replication) -> do - (newerContext, replications) <- getReplications newContext - pure (newerContext, replication : replications) - -getMaybeReplication :: Context - -> BinaryBit.BitGet (Maybe (Context, Replication.Replication)) -getMaybeReplication context = do - hasReplication <- getBool - if #unpack hasReplication - then do - (newContext, replication) <- getReplication context - pure (Just (newContext, replication)) - else pure Nothing - -getReplication :: Context -> BinaryBit.BitGet (Context, Replication.Replication) -getReplication context = do - actorId <- BinaryBit.getBits Data.maxActorId - trace (Printf.printf "Getting replication for actor %d" (#value actorId)) - isOpen <- getBool - let go = - if #unpack isOpen - then getOpenReplication - else getClosedReplication - go context actorId - -getOpenReplication - :: Context - -> CompressedWord.CompressedWord - -> BinaryBit.BitGet (Context, Replication.Replication) -getOpenReplication context actorId = do - isNew <- getBool - let go = - if #unpack isNew - then getNewReplication - else getExistingReplication - go context actorId - -getNewReplication - :: Context - -> CompressedWord.CompressedWord - -> BinaryBit.BitGet (Context, Replication.Replication) -getNewReplication context actorId = do - unknownFlag <- getBool - if #unpack unknownFlag - then fail - "the unknown flag in a new replication is true! what does it mean?" - else pure () - objectId <- getInt32 - objectName <- - case context & #objectMap & IntMap.lookup (Int32.fromInt32 objectId) of - Nothing -> fail ("could not find object name for id " ++ show objectId) - Just x -> pure x - (classId, className) <- - CPM.getClass - (#objectMap context) - Data.classes - (#classMap context) - (Int32.fromInt32 objectId) - trace - (Printf.printf - "Got new replication for object %d %s class %d %s" - (#unpack objectId) - (show objectName) - classId - (show className)) - classInit <- Initialization.getInitialization className - let thing = Thing unknownFlag objectId objectName classId className classInit - let things = #things context - let newThings = - IntMap.insert (CompressedWord.fromCompressedWord actorId) thing things - let newContext = context {contextThings = newThings} - pure - ( newContext - , Replication.Replication - actorId - objectName - className - State.Opening - (Just classInit) - Map.empty) - -getExistingReplication - :: Context - -> CompressedWord.CompressedWord - -> BinaryBit.BitGet (Context, Replication.Replication) -getExistingReplication context actorId = do - thing <- - case context & #things & - IntMap.lookup (CompressedWord.fromCompressedWord actorId) of - Nothing -> - fail ("could not find thing for existing actor " ++ show actorId) - Just x -> pure x - trace - (Printf.printf - "Getting existing replication properties for object %d %s class %d %s" - (thing & #objectId & #unpack) - (thing & #objectName & show) - (thing & #classId) - (thing & #className & show)) - props <- getProps context thing - pure - ( context - , Replication.Replication - actorId - (#objectName thing) - (#className thing) - State.Existing - Nothing - props) - -getClosedReplication - :: Context - -> CompressedWord.CompressedWord - -> BinaryBit.BitGet (Context, Replication.Replication) -getClosedReplication context actorId = do - thing <- - case context & #things & - IntMap.lookup (CompressedWord.fromCompressedWord actorId) of - Nothing -> fail ("could not find thing for closed actor " ++ show actorId) - Just x -> pure x - trace - (Printf.printf - "Got closed replication for object %d %s class %d %s" - (thing & #objectId & #unpack) - (thing & #objectName & show) - (thing & #classId) - (thing & #className & show)) - let newThings = - context & #things & - IntMap.delete (CompressedWord.fromCompressedWord actorId) - let newContext = context {contextThings = newThings} - pure - ( newContext - , Replication.Replication - actorId - (#objectName thing) - (#className thing) - State.Closing - Nothing - Map.empty) - -getProps :: Context - -> Thing - -> BinaryBit.BitGet (Map.Map StrictText.Text Value.Value) -getProps context thing = do - maybeProp <- getMaybeProp context thing - case maybeProp of - Nothing -> pure Map.empty - Just (k, v) -> do - let m = Map.singleton k v - props <- getProps context thing - pure (Map.union m props) - -getMaybeProp :: Context - -> Thing - -> BinaryBit.BitGet (Maybe (StrictText.Text, Value.Value)) -getMaybeProp context thing = do - hasProp <- getBool - if #unpack hasProp - then do - prop <- getProp context thing - pure (Just prop) - else pure Nothing - -getProp :: Context -> Thing -> BinaryBit.BitGet (StrictText.Text, Value.Value) -getProp context thing = do - let classId = #classId thing - props <- - case context & #classPropertyMap & IntMap.lookup classId of - Nothing -> - fail ("could not find property map for class id " ++ show classId) - Just x -> pure x - let maxId = props & IntMap.keys & (0 :) & maximum - pid <- fmap CompressedWord.fromCompressedWord (BinaryBit.getBits maxId) - name <- - case props & IntMap.lookup pid of - Nothing -> - fail ("could not find property name for property id " ++ show pid) - Just x -> pure x - trace (Printf.printf "Getting property %d of %d %s" pid maxId (show name)) - value <- getPropValue context name - trace (Printf.printf "Got property %s" (show value)) - pure (name, value) - -getPropValue :: Context -> StrictText.Text -> BinaryBit.BitGet Value.Value -getPropValue context name = - case Map.lookup name Data.properties of - Just property -> - case StrictText.unpack property of - "boolean" -> getBooleanProperty - "byte" -> getByteProperty - "cam_settings" -> getCamSettingsProperty - "demolish" -> getDemolishProperty - "enum" -> getEnumProperty - "explosion" -> getExplosionProperty - "flagged_int" -> getFlaggedIntProperty - "float" -> getFloatProperty - "game_mode" -> getGameModeProperty context - "int" -> getIntProperty - "loadout_online" -> getLoadoutOnlineProperty - "loadout" -> getLoadoutProperty - "loadouts_online" -> getLoadoutsOnlineProperty - "loadouts" -> getLoadoutsProperty - "location" -> getLocationProperty - "music_stinger" -> getMusicStingerProperty - "party_leader" -> getPartyLeaderProperty - "pickup" -> getPickupProperty - "private_match_settings" -> getPrivateMatchSettingsProperty - "qword" -> getQWordProperty - "relative_rotation" -> getRelativeRotationProperty - "reservation" -> getReservationProperty context - "rigid_body_state" -> getRigidBodyStateProperty - "string" -> getStringProperty - "team_paint" -> getTeamPaintProperty - "unique_id" -> getUniqueIdProperty - "welded_info" -> getWeldedInfoProperty - _ -> - fail - ("Don't know how to read property type " ++ - show property ++ " for " ++ show name) - Nothing -> do - fail ("Don't know how to read property " ++ show name) - -getBooleanProperty :: BinaryBit.BitGet Value.Value -getBooleanProperty = do - bool <- getBool - pure (Value.ValueBoolean (Value.BooleanValue bool)) - -getByteProperty :: BinaryBit.BitGet Value.Value -getByteProperty = do - word <- getWord8 - pure (Value.ValueByte (Value.ByteValue word)) - -getCamSettingsProperty :: BinaryBit.BitGet Value.Value -getCamSettingsProperty = do - fov <- getFloat32 - height <- getFloat32 - angle <- getFloat32 - distance <- getFloat32 - stiffness <- getFloat32 - swivelSpeed <- getFloat32 - pure - (Value.ValueCamSettings - (Value.CamSettingsValue fov height angle distance stiffness swivelSpeed)) - -getDemolishProperty :: BinaryBit.BitGet Value.Value -getDemolishProperty = do - attackerFlag <- getBool - attackerActorId <- getWord32 - victimFlag <- getBool - victimActorId <- getWord32 - attackerVelocity <- Vector.getIntVector - victimVelocity <- Vector.getIntVector - pure - (Value.ValueDemolish - (Value.DemolishValue - attackerFlag - attackerActorId - victimFlag - victimActorId - attackerVelocity - victimVelocity)) - -getEnumProperty :: BinaryBit.BitGet Value.Value -getEnumProperty = do - value <- BinaryBit.getWord16be 10 - flag <- - if value == 1023 - then getBool - else fail ("unexpected enum value " ++ show value) - pure (Value.ValueEnum (Value.EnumValue (Word16.toWord16 value) flag)) - -getExplosionProperty :: BinaryBit.BitGet Value.Value -getExplosionProperty = do - actorless <- getBool - actorId <- - if #unpack actorless - then pure Nothing - else fmap Just getInt32 - position <- Vector.getIntVector - pure (Value.ValueExplosion (Value.ExplosionValue actorless actorId position)) - -getFlaggedIntProperty :: BinaryBit.BitGet Value.Value -getFlaggedIntProperty = do - flag <- getBool - int <- getInt32 - pure (Value.ValueFlaggedInt (Value.FlaggedIntValue flag int)) - -getFloatProperty :: BinaryBit.BitGet Value.Value -getFloatProperty = do - float <- getFloat32 - pure (Value.ValueFloat (Value.FloatValue float)) - -getGameModeProperty :: Context -> BinaryBit.BitGet Value.Value -getGameModeProperty context = do - let numBits = - if atLeastNeoTokyo context - then 8 - else 2 - x <- BinaryBit.getWord8 numBits - pure (Value.ValueGameMode (Value.GameModeValue (Word8.toWord8 x))) - -getIntProperty :: BinaryBit.BitGet Value.Value -getIntProperty = do - int <- getInt32 - pure (Value.ValueInt (Value.IntValue int)) - -getLoadoutOnlineProperty :: BinaryBit.BitGet Value.Value -getLoadoutOnlineProperty = do - size <- fmap Word8.fromWord8 getWord8 - values <- - Monad.replicateM - size - (do innerSize <- fmap Word8.fromWord8 getWord8 - Monad.replicateM - innerSize - (do x <- getWord32 - y <- BinaryBit.getBits 27 - pure (x, y))) - pure (Value.ValueLoadoutOnline (Value.LoadoutOnlineValue values)) - -getLoadoutsOnlineProperty :: BinaryBit.BitGet Value.Value -getLoadoutsOnlineProperty = do - Value.ValueLoadoutOnline loadout1 <- getLoadoutOnlineProperty - Value.ValueLoadoutOnline loadout2 <- getLoadoutOnlineProperty - unknown1 <- BinaryBit.getBits 0 - unknown2 <- BinaryBit.getBits 0 - pure - (Value.ValueLoadoutsOnline - (Value.LoadoutsOnlineValue loadout1 loadout2 unknown1 unknown2)) - -getLoadoutProperty :: BinaryBit.BitGet Value.Value -getLoadoutProperty = do - version <- getWord8 - body <- getWord32 - decal <- getWord32 - wheels <- getWord32 - rocketTrail <- getWord32 - antenna <- getWord32 - topper <- getWord32 - g <- getWord32 - h <- - if version > 10 - then fmap Just getWord32 - else pure Nothing - pure - (Value.ValueLoadout - (Value.LoadoutValue - version - body - decal - wheels - rocketTrail - antenna - topper - g - h)) - -getLoadoutsProperty :: BinaryBit.BitGet Value.Value -getLoadoutsProperty = do - Value.ValueLoadout loadout1 <- getLoadoutProperty - Value.ValueLoadout loadout2 <- getLoadoutProperty - pure (Value.ValueLoadouts (Value.LoadoutsValue loadout1 loadout2)) - -getLocationProperty :: BinaryBit.BitGet Value.Value -getLocationProperty = do - vector <- Vector.getIntVector - pure (Value.ValueLocation (Value.LocationValue vector)) - -getMusicStingerProperty :: BinaryBit.BitGet Value.Value -getMusicStingerProperty = do - flag <- getBool - cue <- getWord32 - trigger <- getWord8 - pure (Value.ValueMusicStinger (Value.MusicStingerValue flag cue trigger)) - -getPickupProperty :: BinaryBit.BitGet Value.Value -getPickupProperty = do - instigator <- getBool - instigatorId <- - if #unpack instigator - then fmap Just getWord32 - else pure Nothing - pickedUp <- getBool - pure (Value.ValuePickup (Value.PickupValue instigator instigatorId pickedUp)) - -getPrivateMatchSettingsProperty :: BinaryBit.BitGet Value.Value -getPrivateMatchSettingsProperty = do - mutators <- getText - joinableBy <- getWord32 - maxPlayers <- getWord32 - gameName <- getText - password <- getText - flag <- getBool - pure - (Value.ValuePrivateMatchSettings - (Value.PrivateMatchSettingsValue - mutators - joinableBy - maxPlayers - gameName - password - flag)) - -getQWordProperty :: BinaryBit.BitGet Value.Value -getQWordProperty = do - qword <- getWord64 - pure (Value.ValueQWord (Value.QWordValue qword)) - -getRelativeRotationProperty :: BinaryBit.BitGet Value.Value -getRelativeRotationProperty = do - vector <- Vector.getFloatVector - pure (Value.ValueRelativeRotation (Value.RelativeRotationValue vector)) - -getReservationProperty :: Context -> BinaryBit.BitGet Value.Value -getReservationProperty context - -- 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. - = do - number <- BinaryBit.getBits maxConnectionNumber - (systemId, remoteId, localId) <- getUniqueId - playerName <- - if systemId == 0 - then pure Nothing - else fmap Just getText - -- No idea what these two flags are. Might be for bots? - a <- getBool - b <- getBool - -- The Neo Tokyo update added 6 bits to the reservation property that are - -- always (as far as I can tell) 0. - Monad.when - (atLeastNeoTokyo context) - (do x <- BinaryBit.getWord8 6 - Monad.when - (x /= 0b000000) - (do fail - (Printf.printf - "Read 6 reservation bits and they weren't all 0! 0b%06b" - x))) - pure - (Value.ValueReservation - (Value.ReservationValue number systemId remoteId localId playerName a b)) - -getRigidBodyStateProperty :: BinaryBit.BitGet Value.Value -getRigidBodyStateProperty = do - flag <- getBool - position <- Vector.getIntVector - rotation <- Vector.getFloatVector - x <- - if #unpack flag - then pure Nothing - else fmap Just Vector.getIntVector - y <- - if #unpack flag - then pure Nothing - else fmap Just Vector.getIntVector - pure - (Value.ValueRigidBodyState - (Value.RigidBodyStateValue flag position rotation x y)) - -getStringProperty :: BinaryBit.BitGet Value.Value -getStringProperty = do - string <- getText - pure (Value.ValueString (Value.StringValue string)) - -getTeamPaintProperty :: BinaryBit.BitGet Value.Value -getTeamPaintProperty = do - team <- getWord8 - primaryColor <- getWord8 - accentColor <- getWord8 - primaryFinish <- getWord32 - accentFinish <- getWord32 - pure - (Value.ValueTeamPaint - (Value.TeamPaintValue - team - primaryColor - accentColor - primaryFinish - accentFinish)) - -getUniqueIdProperty :: BinaryBit.BitGet Value.Value -getUniqueIdProperty = do - (systemId, remoteId, localId) <- getUniqueId - pure (Value.ValueUniqueId (Value.UniqueIdValue systemId remoteId localId)) - --- | Even though this is just a unique ID property, it must be handled --- specially because it sometimes doesn't have the remote or local IDs. -getPartyLeaderProperty :: BinaryBit.BitGet Value.Value -getPartyLeaderProperty = do - systemId <- getWord8 - (remoteId, localId) <- - if systemId == 0 - then pure - ( RemoteId.RemoteSplitscreenId (RemoteId.SplitscreenId Nothing) - , Nothing) - else do - remoteId <- getRemoteId systemId - localId <- fmap Just getWord8 - pure (remoteId, localId) - pure (Value.ValueUniqueId (Value.UniqueIdValue systemId remoteId localId)) - -getWeldedInfoProperty :: BinaryBit.BitGet Value.Value -getWeldedInfoProperty = do - active <- getBool - actorId <- getInt32 - offset <- Vector.getIntVector - mass <- getFloat32 - rotation <- Vector.getInt8Vector - pure - (Value.ValueWeldedInfo - (Value.WeldedInfoValue active actorId offset mass rotation)) - -getUniqueId :: BinaryBit.BitGet (Word8.Word8, RemoteId.RemoteId, Maybe Word8.Word8) -getUniqueId = do - systemId <- getWord8 - remoteId <- getRemoteId systemId - localId <- fmap Just getWord8 - pure (systemId, remoteId, localId) - -getRemoteId :: Word8.Word8 -> BinaryBit.BitGet RemoteId.RemoteId -getRemoteId systemId = - case systemId of - 0 -> do - splitscreenId <- BinaryBit.getBits 0 - pure (RemoteId.RemoteSplitscreenId splitscreenId) - 1 -> do - steamId <- BinaryBit.getBits 0 - pure (RemoteId.RemoteSteamId steamId) - 2 -> do - playStationId <- BinaryBit.getBits 0 - pure (RemoteId.RemotePlayStationId playStationId) - 4 -> do - xboxId <- BinaryBit.getBits 0 - pure (RemoteId.RemoteXboxId xboxId) - _ -> fail ("unknown system id " ++ show systemId) - --- Helpers --- Some values are parsed differently depending on the version of the game that --- saved them. So far, all differences happened with the Neo Tokyo patch. This --- function takes a context and returns true if the replay was saved by a game --- running at least the Neo Tokyo version. -atLeastNeoTokyo :: Context -> Bool -atLeastNeoTokyo context = #version context >= neoTokyoVersion - --- Constants -neoTokyoVersion :: Version.Version -neoTokyoVersion = Version.makeVersion [868, 12] - -maxConnectionNumber :: Int -maxConnectionNumber = 7 - --- Type-restricted helpers. -getBool :: BinaryBit.BitGet Boolean.Boolean -getBool = BinaryBit.getBits 0 - -getFloat32 :: BinaryBit.BitGet Float32.Float32 -getFloat32 = BinaryBit.getBits 0 - -getInt32 :: BinaryBit.BitGet Int32.Int32 -getInt32 = BinaryBit.getBits 0 - -getText :: BinaryBit.BitGet Text.Text -getText = BinaryBit.getBits 0 - -getWord8 :: BinaryBit.BitGet Word8.Word8 -getWord8 = BinaryBit.getBits 0 - -getWord32 :: BinaryBit.BitGet Word32.Word32 -getWord32 = BinaryBit.getBits 0 - -getWord64 :: BinaryBit.BitGet Word64.Word64 -getWord64 = BinaryBit.getBits 0 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.16.3 +version: 0.17.0 synopsis: Parse Rocket League replays. description: Octane parses Rocket League replays. category: Game @@ -17,13 +17,8 @@ extra-source-files: CHANGELOG.markdown - data/classes-with-location.json - data/classes-with-rotation.json - data/classes.json data/game-modes.json - data/parent-classes.json data/products.json - data/properties.json package.yaml README.markdown stack.yaml @@ -41,26 +36,18 @@ , base ==4.9.* , bimap ==0.3.* , binary ==0.8.* - , binary-bits ==0.5.* , bytestring ==0.10.* , containers ==0.5.* - , data-binary-ieee754 ==0.4.* , data-default-class <0.2 - , deepseq ==1.4.* , file-embed ==0.0.* , overloaded-records ==0.4.* - , regex-compat ==0.95.* + , rattletrap ==1.0.* , text ==1.2.* - , unordered-containers ==0.2.* - , vector ==0.11.* exposed-modules: Octane Octane.Data Octane.Type Octane.Type.Boolean - Octane.Type.CacheItem - Octane.Type.CacheProperty - Octane.Type.ClassItem Octane.Type.CompressedWord Octane.Type.Dictionary Octane.Type.Float32 @@ -68,11 +55,7 @@ Octane.Type.Initialization Octane.Type.Int32 Octane.Type.Int8 - Octane.Type.KeyFrame Octane.Type.List - Octane.Type.Mark - Octane.Type.Message - Octane.Type.OptimizedReplay Octane.Type.Property Octane.Type.Property.ArrayProperty Octane.Type.Property.BoolProperty @@ -82,23 +65,20 @@ Octane.Type.Property.NameProperty Octane.Type.Property.QWordProperty Octane.Type.Property.StrProperty - Octane.Type.RawReplay Octane.Type.RemoteId Octane.Type.RemoteId.PlayStationId Octane.Type.RemoteId.SplitscreenId Octane.Type.RemoteId.SteamId Octane.Type.RemoteId.XboxId Octane.Type.Replay - Octane.Type.ReplayWithFrames - Octane.Type.ReplayWithoutFrames Octane.Type.Replication Octane.Type.State - Octane.Type.Stream Octane.Type.Text Octane.Type.Value Octane.Type.Value.BooleanValue Octane.Type.Value.ByteValue Octane.Type.Value.CamSettingsValue + Octane.Type.Value.ClubColorsValue Octane.Type.Value.DemolishValue Octane.Type.Value.EnumValue Octane.Type.Value.ExplosionValue @@ -115,7 +95,6 @@ Octane.Type.Value.PickupValue Octane.Type.Value.PrivateMatchSettingsValue Octane.Type.Value.QWordValue - Octane.Type.Value.RelativeRotationValue Octane.Type.Value.ReservationValue Octane.Type.Value.RigidBodyStateValue Octane.Type.Value.StringValue @@ -128,13 +107,9 @@ Octane.Type.Word64 Octane.Type.Word8 Octane.Utility - Octane.Utility.ClassPropertyMap - Octane.Utility.CRC Octane.Utility.Embed Octane.Utility.Endian - Octane.Utility.Generator Octane.Utility.Optimizer - Octane.Utility.Parser Octane.Version other-modules: Paths_octane @@ -153,39 +128,4 @@ , http-client >=0.4.30 && <0.6 , http-client-tls >=0.2 && <0.4 , octane - default-language: Haskell2010 - -test-suite octane-test-suite - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: - test-suite - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N - build-depends: - base - , binary - , binary-bits - , bytestring - , containers - , octane - , tasty ==0.11.* - , tasty-hspec ==1.1.* - , tasty-quickcheck ==0.8.* - , text - other-modules: - OctaneSpec - default-language: Haskell2010 - -benchmark octane-benchmark - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: - benchmark - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N - build-depends: - base - , criterion ==1.1.* - , octane - other-modules: - OctaneBench default-language: Haskell2010 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,15 +1,3 @@ -benchmarks: - octane-benchmark: - dependencies: - - base - - criterion ==1.1.* - - octane - ghc-options: - - -rtsopts - - -threaded - - -with-rtsopts=-N - main: Main.hs - source-dirs: benchmark category: Game description: Octane parses Rocket League replays. executables: @@ -42,18 +30,13 @@ - base ==4.9.* - bimap ==0.3.* - binary ==0.8.* - - binary-bits ==0.5.* - bytestring ==0.10.* - containers ==0.5.* - - data-binary-ieee754 ==0.4.* - data-default-class <0.2 - - deepseq ==1.4.* - file-embed ==0.0.* - overloaded-records ==0.4.* - - regex-compat ==0.95.* + - rattletrap ==1.0.* - text ==1.2.* - - unordered-containers ==0.2.* - - vector ==0.11.* other-modules: Paths_octane source-dirs: library license: MIT @@ -61,23 +44,4 @@ maintainer: Taylor Fausak name: octane synopsis: Parse Rocket League replays. -tests: - octane-test-suite: - dependencies: - - base - - binary - - binary-bits - - bytestring - - containers - - octane - - tasty ==0.11.* - - tasty-hspec ==1.1.* - - tasty-quickcheck ==0.8.* - - text - ghc-options: - - -rtsopts - - -threaded - - -with-rtsopts=-N - main: Main.hs - source-dirs: test-suite -version: '0.16.3' +version: '0.17.0' diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,3 @@ -packages: -- . -- extra-dep: true - location: - commit: 6c87162af7366105e045f35bf34624db5292dbdb - git: https://github.com/bitemyapp/hspec-expectations.git -resolver: nightly-2016-08-18 +extra-deps: +- rattletrap-1.0.0 +resolver: lts-7.8 diff --git a/test-suite/Main.hs b/test-suite/Main.hs deleted file mode 100644 --- a/test-suite/Main.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main - ( main - ) where - -import qualified OctaneSpec -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.Hspec as Hspec - -main :: IO () -main = do - test <- Hspec.testSpec "octane" spec - Tasty.defaultMain test - -spec :: Hspec.Spec -spec = Hspec.parallel OctaneSpec.spec diff --git a/test-suite/OctaneSpec.hs b/test-suite/OctaneSpec.hs deleted file mode 100644 --- a/test-suite/OctaneSpec.hs +++ /dev/null @@ -1,588 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module OctaneSpec - ( spec - ) where - -import qualified Data.Binary as Binary -import qualified Data.Binary.Bits as BinaryBit -import qualified Data.Binary.Bits.Get as BinaryBit -import qualified Data.Binary.Bits.Put as BinaryBit -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.ByteString.Lazy as LazyBytes -import qualified Data.Foldable as Foldable -import Data.Function ((&)) -import qualified Data.Functor.Identity as Identity -import qualified Data.Map.Strict as Map -import qualified Data.Proxy as Proxy -import qualified Data.Text as StrictText -import qualified Data.Typeable as Typeable -import qualified Data.Version as Version -import qualified Octane -import qualified Test.Tasty.Hspec as Hspec -import qualified Test.Tasty.QuickCheck as QuickCheck - -spec :: Hspec.Spec -spec = - Hspec.parallel $ - Hspec.describe "Octane" $ do - Hspec.describe "binary" $ do - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Boolean) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.CacheItem) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.CacheProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.ClassItem) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy (Octane.Dictionary ())) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Float32) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Int8) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Int32) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.KeyFrame) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy (Octane.List ())) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Mark) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Message) - pure () -- TODO: binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.OptimizedReplay) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Property) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy (Octane.ArrayProperty ())) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.BoolProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.ByteProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.FloatProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.IntProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.NameProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.QWordProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.StrProperty) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.RawReplay) - pure () -- TODO: binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Replay) - pure () -- TODO: binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.ReplayWithFrames) - pure () -- TODO: binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.ReplayWithoutFrames) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Stream) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Text) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word8) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word16) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word32) - binaryRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word64) - Hspec.describe "binary bit" $ do - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Boolean) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Float32) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Int8) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Int32) - pure () -- TODO: binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.PlayStationId) - pure () -- TODO: binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.SplitscreenId) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.SteamId) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.XboxId) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Text) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word8) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word32) - binaryBitRoundTrip (Proxy.Proxy :: Proxy.Proxy Octane.Word64) - Hspec.describe "custom binary bit" $ do - customBinaryBitRoundTrip - (Proxy.Proxy :: Proxy.Proxy Octane.CompressedWord) - (\x -> BinaryBit.putBits undefined x) - (\x -> BinaryBit.getBits (x & #limit & fromIntegral)) - Hspec.it "can round trip Vector Float" $ - QuickCheck.property $ \input -> do - let put = - input & floatVectorUnpack & Octane.putFloatVector & - BinaryBit.runBitPut - let get = - Octane.getFloatVector & BinaryBit.runBitGet & fmap FloatVector - let output = put & Binary.runPut & Binary.runGet get - let epsilon = 0.0001 - [#x, #y, #z] & - map - (\field -> do - let expected = input & floatVectorUnpack & field - let actual = output & floatVectorUnpack & field - let delta = actual - expected - Hspec.shouldSatisfy (abs delta) (< epsilon)) & - Foldable.sequence_ - customBinaryBitRoundTrip - (Proxy.Proxy :: Proxy.Proxy (Octane.Vector Int)) - (\x -> Octane.putIntVector x) - (\_ -> Octane.getIntVector) - customBinaryBitRoundTrip - (Proxy.Proxy :: Proxy.Proxy (Octane.Vector Octane.Int8)) - (\x -> Octane.putInt8Vector x) - (\_ -> Octane.getInt8Vector) - Hspec.describe "Replay" $ do - let proxy = Proxy.Proxy :: Proxy.Proxy Octane.Replay - let rid = Identity.runIdentity - roundTrip - proxy - (\x -> - x & Octane.toOptimizedReplay & rid & Octane.fromOptimizedReplay & rid) - -binaryRoundTrip - :: forall a. - ( QuickCheck.Arbitrary a - , Binary.Binary a - , Eq a - , Show a - , Typeable.Typeable a - ) - => Proxy.Proxy a -> Hspec.SpecWith () -binaryRoundTrip proxy = - roundTrip proxy (\x -> x & Binary.encode & Binary.decode) - -binaryBitRoundTrip - :: forall a. - ( QuickCheck.Arbitrary a - , BinaryBit.BinaryBit a - , Eq a - , Show a - , Typeable.Typeable a - ) - => Proxy.Proxy a -> Hspec.SpecWith () -binaryBitRoundTrip proxy = - customBinaryBitRoundTrip - proxy - (\x -> BinaryBit.putBits undefined x) - (\_ -> BinaryBit.getBits undefined) - -customBinaryBitRoundTrip - :: forall a. - (QuickCheck.Arbitrary a, Eq a, Show a, Typeable.Typeable a) - => Proxy.Proxy a - -> (a -> BinaryBit.BitPut ()) - -> (a -> BinaryBit.BitGet a) - -> Hspec.SpecWith () -customBinaryBitRoundTrip proxy bitPut bitGet = - roundTrip - proxy - (\x -> do - let put = x & bitPut & BinaryBit.runBitPut - let get = x & bitGet & BinaryBit.runBitGet - put & Binary.runPut & Binary.runGet get) - -roundTrip - :: forall a. - (QuickCheck.Arbitrary a, Eq a, Show a, Typeable.Typeable a) - => Proxy.Proxy a -> (a -> a) -> Hspec.SpecWith () -roundTrip proxy f = - Hspec.it - ("can round trip " ++ typeName proxy) - (QuickCheck.property (\x -> Hspec.shouldBe (f x) (x :: a))) - -typeName - :: forall a. - (Typeable.Typeable a) - => Proxy.Proxy a -> String -typeName _ = (undefined :: a) & Typeable.typeOf & show - -instance QuickCheck.Arbitrary Octane.Boolean where - arbitrary = Octane.Boolean <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.CacheItem where - arbitrary = - Octane.CacheItem <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.CacheProperty where - arbitrary = - Octane.CacheProperty <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.ClassItem where - arbitrary = Octane.ClassItem <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.CompressedWord where - arbitrary = do - limit <- QuickCheck.choose (0, Octane.maxActorId) - value <- QuickCheck.choose (0, limit) - pure (Octane.CompressedWord limit value) - -instance (QuickCheck.Arbitrary a) => - QuickCheck.Arbitrary (Octane.Dictionary a) where - arbitrary = - Octane.Dictionary <$> QuickCheck.scale (min 2) QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Float32 where - arbitrary = Octane.Float32 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Frame where - arbitrary = - Octane.Frame <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Initialization where - arbitrary = - Octane.Initialization <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Int8 where - arbitrary = Octane.Int8 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Int32 where - arbitrary = Octane.Int32 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.KeyFrame where - arbitrary = - Octane.KeyFrame <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance (QuickCheck.Arbitrary a) => - QuickCheck.Arbitrary (Octane.List a) where - arbitrary = Octane.List <$> QuickCheck.scale (min 2) QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Mark where - arbitrary = Octane.Mark <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Message where - arbitrary = - Octane.Message <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.OptimizedReplay where - arbitrary = - Octane.OptimizedReplay <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Property where - arbitrary = - QuickCheck.oneof - [ Octane.PropertyArray <$> QuickCheck.arbitrary - , Octane.PropertyBool <$> QuickCheck.arbitrary - , Octane.PropertyByte <$> QuickCheck.arbitrary - , Octane.PropertyFloat <$> QuickCheck.arbitrary - , Octane.PropertyInt <$> QuickCheck.arbitrary - , Octane.PropertyName <$> QuickCheck.arbitrary - , Octane.PropertyQWord <$> QuickCheck.arbitrary - , Octane.PropertyStr <$> QuickCheck.arbitrary - ] - -instance (QuickCheck.Arbitrary a) => - QuickCheck.Arbitrary (Octane.ArrayProperty a) where - arbitrary = - Octane.ArrayProperty <$> QuickCheck.arbitrary <*> - QuickCheck.scale (min 2) QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.BoolProperty where - arbitrary = - Octane.BoolProperty <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.ByteProperty where - arbitrary = - Octane.ByteProperty <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.FloatProperty where - arbitrary = Octane.FloatProperty <$> pure 4 <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.IntProperty where - arbitrary = Octane.IntProperty <$> pure 4 <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.NameProperty where - arbitrary = - Octane.NameProperty <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.QWordProperty where - arbitrary = Octane.QWordProperty <$> pure 8 <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.StrProperty where - arbitrary = - Octane.StrProperty <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.RawReplay where - arbitrary = - Octane.newRawReplay <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.RemoteId where - arbitrary = - QuickCheck.oneof - [ Octane.RemotePlayStationId <$> QuickCheck.arbitrary - , Octane.RemoteSplitscreenId <$> QuickCheck.arbitrary - , Octane.RemoteSteamId <$> QuickCheck.arbitrary - , Octane.RemoteXboxId <$> QuickCheck.arbitrary - ] - -instance QuickCheck.Arbitrary Octane.PlayStationId where - arbitrary = - Octane.PlayStationId <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.SplitscreenId where - arbitrary = Octane.SplitscreenId <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.SteamId where - arbitrary = Octane.SteamId <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.XboxId where - arbitrary = Octane.XboxId <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Replay where - arbitrary = do - let version = - Version.makeVersion - [Octane.latestMajorVersion, Octane.latestMinorVersion] - metadata <- QuickCheck.arbitrary - levels <- QuickCheck.arbitrary - -- The messages and tick marks must have keys that can be read as - -- non-negative integers. - messages <- - fmap Map.fromList $ - QuickCheck.listOf $ do - frame <- QuickCheck.arbitrarySizedNatural - let key = frame & (\x -> x :: Word) & show & StrictText.pack - value <- QuickCheck.arbitrary - pure (key, value) - tickMarks <- - fmap Map.fromList $ - QuickCheck.listOf $ do - frame <- QuickCheck.arbitrarySizedNatural - let key = frame & (\x -> x :: Word) & show & StrictText.pack - value <- QuickCheck.arbitrary - pure (key, value) - packages <- QuickCheck.arbitrary - -- Each frame has many replications. Each replication has many values. If - -- we don't limit the number of frames, things get out of hand quickly. - rawFrames <- QuickCheck.scale (min 10) QuickCheck.arbitrary - -- The first frame must be a key frame. Only the first frame can be a key - -- frame. - let frames = - rawFrames & zip (True : repeat False) & - map - (\(isKeyFrame, frame) -> frame {Octane.frameIsKeyFrame = isKeyFrame}) - pure - (Octane.Replay version metadata levels messages tickMarks packages frames) - -instance QuickCheck.Arbitrary Octane.ReplayWithFrames where - arbitrary = - Octane.ReplayWithFrames <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.ReplayWithoutFrames where - arbitrary = - Octane.ReplayWithoutFrames <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Replication where - arbitrary = - Octane.Replication <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.State where - arbitrary = - QuickCheck.elements [Octane.Opening, Octane.Existing, Octane.Closing] - -instance QuickCheck.Arbitrary Octane.Stream where - arbitrary = Octane.Stream <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Text where - arbitrary = Octane.Text <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Value where - arbitrary = - QuickCheck.oneof - [ Octane.ValueBoolean <$> QuickCheck.arbitrary - , Octane.ValueByte <$> QuickCheck.arbitrary - , Octane.ValueCamSettings <$> QuickCheck.arbitrary - , Octane.ValueDemolish <$> QuickCheck.arbitrary - , Octane.ValueEnum <$> QuickCheck.arbitrary - , Octane.ValueExplosion <$> QuickCheck.arbitrary - , Octane.ValueFlaggedInt <$> QuickCheck.arbitrary - , Octane.ValueFloat <$> QuickCheck.arbitrary - , Octane.ValueGameMode <$> QuickCheck.arbitrary - , Octane.ValueInt <$> QuickCheck.arbitrary - , Octane.ValueLoadout <$> QuickCheck.arbitrary - , Octane.ValueLoadoutOnline <$> QuickCheck.arbitrary - , Octane.ValueLocation <$> QuickCheck.arbitrary - , Octane.ValueMusicStinger <$> QuickCheck.arbitrary - , Octane.ValuePickup <$> QuickCheck.arbitrary - , Octane.ValuePrivateMatchSettings <$> QuickCheck.arbitrary - , Octane.ValueQWord <$> QuickCheck.arbitrary - , Octane.ValueRelativeRotation <$> QuickCheck.arbitrary - , Octane.ValueReservation <$> QuickCheck.arbitrary - , Octane.ValueRigidBodyState <$> QuickCheck.arbitrary - , Octane.ValueString <$> QuickCheck.arbitrary - , Octane.ValueTeamPaint <$> QuickCheck.arbitrary - , Octane.ValueUniqueId <$> QuickCheck.arbitrary - ] - -instance QuickCheck.Arbitrary Octane.BooleanValue where - arbitrary = Octane.BooleanValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.ByteValue where - arbitrary = Octane.ByteValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.CamSettingsValue where - arbitrary = - Octane.CamSettingsValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.DemolishValue where - arbitrary = - Octane.DemolishValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.EnumValue where - arbitrary = Octane.EnumValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.ExplosionValue where - arbitrary = - Octane.ExplosionValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.FlaggedIntValue where - arbitrary = - Octane.FlaggedIntValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.FloatValue where - arbitrary = Octane.FloatValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.GameModeValue where - arbitrary = Octane.GameModeValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.IntValue where - arbitrary = Octane.IntValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.LoadoutOnlineValue where - arbitrary = Octane.LoadoutOnlineValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.LoadoutValue where - arbitrary = - Octane.LoadoutValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.LocationValue where - arbitrary = Octane.LocationValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.MusicStingerValue where - arbitrary = - Octane.MusicStingerValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.PickupValue where - arbitrary = - Octane.PickupValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.PrivateMatchSettingsValue where - arbitrary = - Octane.PrivateMatchSettingsValue <$> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.QWordValue where - arbitrary = Octane.QWordValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.RelativeRotationValue where - arbitrary = Octane.RelativeRotationValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.ReservationValue where - arbitrary = - Octane.ReservationValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.RigidBodyStateValue where - arbitrary = - Octane.RigidBodyStateValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.StringValue where - arbitrary = Octane.StringValue <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.TeamPaintValue where - arbitrary = - Octane.TeamPaintValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.UniqueIdValue where - arbitrary = - Octane.UniqueIdValue <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance (QuickCheck.Arbitrary a) => - QuickCheck.Arbitrary (Octane.Vector a) where - arbitrary = - Octane.Vector <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> - QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Word8 where - arbitrary = Octane.Word8 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Word16 where - arbitrary = Octane.Word16 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Word32 where - arbitrary = Octane.Word32 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Octane.Word64 where - arbitrary = Octane.Word64 <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary LazyBytes.ByteString where - arbitrary = LazyBytes.pack <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary StrictText.Text where - arbitrary = StrictText.pack <$> QuickCheck.arbitrary - -newtype FloatVector = FloatVector - { floatVectorUnpack :: Octane.Vector Float - } deriving (Eq, Show) - -instance QuickCheck.Arbitrary FloatVector where - arbitrary = do - x <- QuickCheck.choose (-1, 1) - y <- QuickCheck.choose (-1, 1) - z <- QuickCheck.choose (-1, 1) - pure (FloatVector (Octane.Vector x y z))