octane 0.16.1 → 0.16.2
raw patch · 9 files changed
+154/−107 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Octane.Data: latestMajorVersion :: (Num a) => a
+ Octane.Data: latestMinorVersion :: (Num a) => a
+ Octane.Data: maxActorId :: (Num a) => a
Files
- library/Octane/Data.hs +13/−0
- library/Octane/Type/CompressedWord.hs +6/−1
- library/Octane/Type/Replay.hs +58/−55
- library/Octane/Utility/ClassPropertyMap.hs +33/−14
- library/Octane/Utility/Generator.hs +16/−11
- library/Octane/Utility/Parser.hs +21/−6
- octane.cabal +1/−1
- package.yaml +1/−1
- test-suite/OctaneSpec.hs +5/−18
library/Octane/Data.hs view
@@ -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.
library/Octane/Type/CompressedWord.hs view
@@ -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
library/Octane/Type/Replay.hs view
@@ -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 }
library/Octane/Utility/ClassPropertyMap.hs view
@@ -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
library/Octane/Utility/Generator.hs view
@@ -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
library/Octane/Utility/Parser.hs view
@@ -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
octane.cabal view
@@ -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
package.yaml view
@@ -80,4 +80,4 @@ - -with-rtsopts=-N main: Main.hs source-dirs: test-suite-version: '0.16.1'+version: '0.16.2'
test-suite/OctaneSpec.hs view
@@ -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