diff --git a/library/Octane/Data.hs b/library/Octane/Data.hs --- a/library/Octane/Data.hs +++ b/library/Octane/Data.hs @@ -27,6 +27,19 @@ 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. 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 @@ -26,6 +26,7 @@ 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 @@ -89,7 +90,11 @@ bitSize :: (Integral a, Integral b) => a -> b -bitSize x = x & fromIntegral & logBase (2 :: Double) & ceiling & max 1 +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 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 @@ -23,11 +23,14 @@ import qualified Data.Binary as Binary 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.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 @@ -158,72 +161,72 @@ toOptimizedReplay :: (Monad m) => Replay -> m OptimizedReplay.OptimizedReplay -toOptimizedReplay replay = do - let [version1, version2] = - replay & #version & Version.versionBranch & map Word32.toWord32 - -- Key frames aren't important for replays. Mark the first frame as a key - -- frame and the rest as regular frames. +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}) - let objectNames = frames & concatMap #replications & map #objectName - let classNames = frames & concatMap #replications & map #className + -- 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 - let objects = - [objectNames, classNames, propertyNames] & concat & Set.fromList & + 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 - let objectsToPosition = objects & #unpack & flip zip [0 ..] & Map.fromList - classes <- - frames & concatMap #replications & map #className & Set.fromList & - Set.toAscList & - map Text.Text & - mapM - (\className -> - case Map.lookup className objectsToPosition of - Nothing -> - fail - ("class " ++ show className ++ " not found in list of objects") - Just position -> pure (ClassItem.ClassItem className position)) & - fmap List.List - let numClasses = classes & #unpack & length & fromIntegral - classesToProperties <- - frames & concatMap #replications & - concatMap - (\replication -> - zip - (replication & #className & repeat) - (replication & #properties & Map.keys & map Text.Text)) & - zip [numClasses ..] & - mapM - (\(streamId, (className, propertyName)) -> do - case Map.lookup propertyName objectsToPosition of - Nothing -> - fail - ("property " ++ - show propertyName ++ " not found in list of objects") - Just propertyId -> - pure (className, [CacheProperty.CacheProperty propertyId streamId])) & - fmap (Map.fromListWith (++)) - let cache = - classes & #unpack & zip [0 ..] & + -- 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 - (\(index, classItem) -> do - let classId = #streamId classItem - let parentCacheId = index - let cacheId = index + (\(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 = - classesToProperties & - Map.findWithDefault [] (classItem & #name & #unpack) & + propertiesByClass & Map.findWithDefault [] className & List.List CacheItem.CacheItem classId parentCacheId cacheId properties) & List.List pure OptimizedReplay.OptimizedReplay - { OptimizedReplay.optimizedReplayVersion1 = version1 - , OptimizedReplay.optimizedReplayVersion2 = version2 + { OptimizedReplay.optimizedReplayVersion1 = Data.latestMajorVersion + , OptimizedReplay.optimizedReplayVersion2 = Data.latestMinorVersion , OptimizedReplay.optimizedReplayLabel = "TAGame.Replay_Soccar_TA" , OptimizedReplay.optimizedReplayProperties = replay & #metadata & Map.mapKeys Text.Text & Dictionary.Dictionary @@ -257,8 +260,8 @@ List.List , OptimizedReplay.optimizedReplayPackages = replay & #packages & map Text.Text & List.List - , OptimizedReplay.optimizedReplayObjects = objects + , OptimizedReplay.optimizedReplayObjects = actors , OptimizedReplay.optimizedReplayNames = List.List [] -- TODO - , OptimizedReplay.optimizedReplayClasses = classes - , OptimizedReplay.optimizedReplayCache = cache + , OptimizedReplay.optimizedReplayClasses = classItems + , OptimizedReplay.optimizedReplayCache = cacheItems } diff --git a/library/Octane/Utility/ClassPropertyMap.hs b/library/Octane/Utility/ClassPropertyMap.hs --- a/library/Octane/Utility/ClassPropertyMap.hs +++ b/library/Octane/Utility/ClassPropertyMap.hs @@ -61,13 +61,19 @@ getClassCache replay = do let classNames = replay & getActorMap & Bimap.toMapR replay & #cache & #unpack & - Maybe.mapMaybe + map (\cacheItem -> do let classId = cacheItem & #classId & Word32.fromWord32 - className <- Map.lookup classId classNames + 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 - pure (classId, className, cacheId, parentCacheId)) + (classId, className, cacheId, parentCacheId)) -- | The class IDs in a replay. Comes from the class cache. getClassIds :: Replay.ReplayWithoutFrames -> [Int] @@ -76,24 +82,37 @@ -- | 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 :: StrictText.Text +getParentClassId :: Maybe StrictText.Text -> Int -> [(Int, StrictText.Text, Int, Int)] -> Maybe Int -getParentClassId className parentCacheId xs = +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 - Nothing -> - case dropWhile (\(_, _, cacheId, _) -> cacheId /= parentCacheId) xs of - [] -> - if parentCacheId <= 0 - then Nothing - else getParentClassId className (parentCacheId - 1) xs - (parentClassId, _, _, _):_ -> Just parentClassId + 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. @@ -106,7 +125,7 @@ case xs of [] -> Nothing (classId, className, _, parentCacheId):ys -> do - parentClassId <- getParentClassId className parentCacheId ys + parentClassId <- getParentClassId (Just className) parentCacheId ys pure (classId, parentClassId)) & IntMap.fromList diff --git a/library/Octane/Utility/Generator.hs b/library/Octane/Utility/Generator.hs --- a/library/Octane/Utility/Generator.hs +++ b/library/Octane/Utility/Generator.hs @@ -57,28 +57,32 @@ -> List.List ClassItem.ClassItem -> List.List CacheItem.CacheItem -> Stream.Stream -generateStream frames objects _names _classes cache = do - let context = makeContext objects cache +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 CacheItem.CacheItem -> Context -makeContext objects cache = do +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 objectMap & Map.assocs & map Tuple.swap & Map.fromList & - Map.lookup - (cacheItem & #classId & Word32.fromWord32 & - (\x -> x :: Int) & - Int32.toInt32) of + case Map.lookup (#classId cacheItem) classMap of Nothing -> error ("could not find class id for " ++ show className) Just name -> name @@ -131,9 +135,9 @@ putReplications context replications = do case replications of [] -> do - False & Boolean.Boolean & BinaryBit.putBits 1 + False & Boolean.Boolean & BinaryBit.putBits 1 -- no more replications replication:rest -> do - True & Boolean.Boolean & BinaryBit.putBits 1 + True & Boolean.Boolean & BinaryBit.putBits 1 -- has replication putReplication context replication putReplications context rest @@ -167,6 +171,7 @@ 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 diff --git a/library/Octane/Utility/Parser.hs b/library/Octane/Utility/Parser.hs --- a/library/Octane/Utility/Parser.hs +++ b/library/Octane/Utility/Parser.hs @@ -132,7 +132,25 @@ Just (Property.PropertyInt int) -> int & #content & Int32.fromInt32 _ -> 0) trace (Printf.printf "Getting %d frame(s)" numFrames) - replay & extractContext & getFrames 0 numFrames & fmap snd + 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 @@ -214,7 +232,7 @@ getReplication :: Context -> BinaryBit.BitGet (Context, Replication.Replication) getReplication context = do - actorId <- BinaryBit.getBits maxActorId + actorId <- BinaryBit.getBits Data.maxActorId trace (Printf.printf "Getting replication for actor %d" (#value actorId)) isOpen <- getBool let go = @@ -377,7 +395,7 @@ Nothing -> fail ("could not find property name for property id " ++ show pid) Just x -> pure x - trace (Printf.printf "Getting property %s" (show name)) + 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) @@ -747,9 +765,6 @@ -- Constants neoTokyoVersion :: Version.Version neoTokyoVersion = Version.makeVersion [868, 12] - -maxActorId :: Int -maxActorId = 1024 maxConnectionNumber :: Int maxConnectionNumber = 7 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.1 +version: 0.16.2 synopsis: Parse Rocket League replays. description: Octane parses Rocket League replays. category: Game diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -80,4 +80,4 @@ - -with-rtsopts=-N main: Main.hs source-dirs: test-suite -version: '0.16.1' +version: '0.16.2' diff --git a/test-suite/OctaneSpec.hs b/test-suite/OctaneSpec.hs --- a/test-suite/OctaneSpec.hs +++ b/test-suite/OctaneSpec.hs @@ -112,14 +112,6 @@ proxy (\x -> x & Octane.toOptimizedReplay & rid & Octane.fromOptimizedReplay & rid) - roundTrip - proxy - (\x -> - x & Octane.toOptimizedReplay & rid & Octane.toReplayWithFrames & rid & - Octane.fromReplayWithFrames & - rid & - Octane.fromOptimizedReplay & - rid) binaryRoundTrip :: forall a. @@ -196,7 +188,7 @@ instance QuickCheck.Arbitrary Octane.CompressedWord where arbitrary = do - limit <- QuickCheck.choose (1, maxBound) + limit <- QuickCheck.choose (0, Octane.maxActorId) value <- QuickCheck.choose (0, limit) pure (Octane.CompressedWord limit value) @@ -331,12 +323,10 @@ arbitrary = Octane.XboxId <$> QuickCheck.arbitrary instance QuickCheck.Arbitrary Octane.Replay where - arbitrary - -- The vesion must have exactly two pieces and both must be non-negative. - = do - major <- QuickCheck.arbitrarySizedNatural - minor <- QuickCheck.arbitrarySizedNatural - let version = Version.makeVersion [major, minor] + 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 @@ -585,9 +575,6 @@ instance QuickCheck.Arbitrary StrictText.Text where arbitrary = StrictText.pack <$> QuickCheck.arbitrary - -instance QuickCheck.Arbitrary Version.Version where - arbitrary = Version.makeVersion <$> QuickCheck.arbitrary newtype FloatVector = FloatVector { floatVectorUnpack :: Octane.Vector Float