From 97a5c61f28ba98728bab390e0ea745edfbea7103 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 30 Nov 2019 15:00:39 -0500 Subject: [PATCH] Fix an injectivity issue with saving the game Fix an injectivity issue with JSON-encoding the entity map that was causing the game saving to not properly round-trip. As part of this, there's a refactor to the internals of the entity map to use sets instead of vectors, which should also get us a nice perf boost. --- package.yaml | 3 ++ src/Xanthous/Data.hs | 2 +- src/Xanthous/Data/EntityChar.hs | 2 +- src/Xanthous/Data/EntityMap.hs | 49 +++++++++++++++++++---------- src/Xanthous/Entities/Character.hs | 2 +- src/Xanthous/Entities/Creature.hs | 6 ++-- src/Xanthous/Entities/Item.hs | 2 +- src/Xanthous/Entities/RawTypes.hs | 6 ++-- src/Xanthous/Game/Prompt.hs | 1 - src/Xanthous/Game/State.hs | 9 ++++-- src/Xanthous/Orphans.hs | 4 +++ src/Xanthous/Prelude.hs | 17 ++++++++++ test/Xanthous/Data/EntityMapSpec.hs | 10 +++++- test/Xanthous/GameSpec.hs | 2 ++ xanthous.cabal | 9 ++++-- 15 files changed, 90 insertions(+), 34 deletions(-) diff --git a/package.yaml b/package.yaml index cadfd04d8..f982a2339 100644 --- a/package.yaml +++ b/package.yaml @@ -41,6 +41,7 @@ dependencies: - MonadRandom - mtl - optparse-applicative +- parallel - random - random-fu - random-extras @@ -97,6 +98,7 @@ executable: - -threaded - -rtsopts - -with-rtsopts=-N + - -O2 tests: test: @@ -106,6 +108,7 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N + - -O0 dependencies: - xanthous - tasty diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index fdeb71beb..dfad2cffd 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -115,7 +115,7 @@ type Position = Position' Int instance Arbitrary a => Arbitrary (Position' a) where arbitrary = genericArbitrary - shrink = genericShrink + shrink (Position px py) = Position <$> shrink px <*> shrink py instance Num a => Semigroup (Position' a) where diff --git a/src/Xanthous/Data/EntityChar.hs b/src/Xanthous/Data/EntityChar.hs index 7aeb5fdf8..855a3462d 100644 --- a/src/Xanthous/Data/EntityChar.hs +++ b/src/Xanthous/Data/EntityChar.hs @@ -30,7 +30,7 @@ data EntityChar = EntityChar { _char :: Char , _style :: Vty.Attr } - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving Arbitrary via GenericArbitrary EntityChar makeFieldsNoPrefix ''EntityChar diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index 9ca915553..9ea952c05 100644 --- a/src/Xanthous/Data/EntityMap.hs +++ b/src/Xanthous/Data/EntityMap.hs @@ -27,6 +27,7 @@ module Xanthous.Data.EntityMap -- * debug , byID , byPosition + , lastID ) where -------------------------------------------------------------------------------- @@ -46,26 +47,28 @@ import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function) import Test.QuickCheck.Checkers (EqProp) import Test.QuickCheck.Instances.UnorderedContainers () import Test.QuickCheck.Instances.Vector () +import Text.Show (showString, showParen) import Data.Aeson -------------------------------------------------------------------------------- type EntityID = Word32 -type NonNullVector a = NonNull (Vector a) +type NonNullSet a = NonNull (Set a) data EntityMap a where EntityMap :: - { _byPosition :: Map Position (NonNullVector EntityID) + { _byPosition :: Map Position (NonNullSet EntityID) , _byID :: HashMap EntityID (Positioned a) , _lastID :: EntityID } -> EntityMap a deriving stock (Functor, Foldable, Traversable, Generic) deriving anyclass (NFData, CoArbitrary, Function) -deriving via (EqEqProp (EntityMap a)) instance Eq a => EqProp (EntityMap a) +deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a) makeLenses ''EntityMap instance ToJSON a => ToJSON (EntityMap a) where toJSON = toJSON . toEIDsAndPositioned + instance FromJSON a => FromJSON (EntityMap a) where parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON @@ -73,14 +76,24 @@ byIDInvariantError :: forall a. a byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " <> "must point to entityIDs in byID" -instance Eq a => Eq (EntityMap a) where - em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap +instance (Ord a, Eq a) => Eq (EntityMap a) where + -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap + (==) = (==) `on` view (_EntityMap . to sort) + +deriving stock instance (Ord a) => Ord (EntityMap a) instance Show a => Show (EntityMap a) where - show em = "_EntityMap # " <> show (em ^. _EntityMap) + showsPrec pr em + = showParen (pr > 10) + $ showString + . ("fromEIDsAndPositioned " <>) + . show + . toEIDsAndPositioned + $ em instance Arbitrary a => Arbitrary (EntityMap a) where arbitrary = review _EntityMap <$> arbitrary + shrink em = review _EntityMap <$> shrink (em ^. _EntityMap) type instance Index (EntityMap a) = EntityID type instance IxValue (EntityMap a) = (Positioned a) @@ -102,10 +115,10 @@ instance At (EntityMap a) where ) & byID . at eid ?~ pe & byPosition . at pos %~ \case - Nothing -> Just $ ncons eid mempty - Just es -> Just $ eid <| es + Nothing -> Just $ opoint eid + Just es -> Just $ ninsertSet eid es removeEIDAtPos pos = - byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid)) + byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid) instance Semigroup (EntityMap a) where em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁ @@ -137,8 +150,8 @@ instance Semigroup (Deduplicate a) where _byPosition = mempty &~ do ifor_ _byID $ \eid (Positioned pos _) -> at pos %= \case - Just eids -> Just $ eid <| eids - Nothing -> Just $ ncons eid mempty + Just eids -> Just $ ninsertSet eid eids + Nothing -> Just $ opoint eid _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID in Deduplicate EntityMap{..} @@ -164,8 +177,8 @@ insertAtReturningID pos e em = in em' & byID . at eid ?~ Positioned pos e & byPosition . at pos %~ \case - Nothing -> Just $ ncons eid mempty - Just es -> Just $ eid <| es + Nothing -> Just $ opoint eid + Just es -> Just $ ninsertSet eid es & (eid, ) insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a @@ -176,7 +189,8 @@ atPosition pos = lens getter setter where getter em = let eids :: Vector EntityID - eids = maybe mempty toNullable $ em ^. byPosition . at pos + eids = maybe mempty (toVector . toNullable) + $ em ^. byPosition . at pos in getEIDAssume em <$> eids setter em Empty = em & byPosition . at pos .~ Nothing setter em entities = alaf Endo foldMap (insertAt pos) entities em @@ -187,7 +201,8 @@ getEIDAssume em eid = fromMaybe byIDInvariantError atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a) atPositionWithIDs pos em = - let eids = maybe mempty toNullable $ em ^. byPosition . at pos + let eids = maybe mempty (toVector . toNullable) + $ em ^. byPosition . at pos in (id &&& Positioned pos . getEIDAssume em) <$> eids fromEIDsAndPositioned @@ -199,8 +214,8 @@ fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty insert' (eid, pe@(Positioned pos _)) = (byID . at eid ?~ pe) . (byPosition . at pos %~ \case - Just eids -> Just $ eid <| eids - Nothing -> Just $ ncons eid mempty + Just eids -> Just $ ninsertSet eid eids + Nothing -> Just $ opoint eid ) newLastID em = em & lastID .~ fromMaybe 1 diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 22589252a..dd14390df 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -39,7 +39,7 @@ data Character = Character , _characterHitpoints' :: !Double , _speed :: TicksPerTile } - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index de9122746..6f97c128d 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -47,7 +47,7 @@ data Destination = Destination -- When this value reaches >= 1, the creature has reached their destination , _destinationProgress :: !Tiles } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] @@ -63,7 +63,7 @@ destinationFromPos _destinationPosition = data Hippocampus = Hippocampus { _destination :: !(Maybe Destination) } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] @@ -81,7 +81,7 @@ data Creature = Creature , _hitpoints :: !Hitpoints , _hippocampus :: !Hippocampus } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature deriving (ToJSON, FromJSON) diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs index 465110069..0156cd54c 100644 --- a/src/Xanthous/Entities/Item.hs +++ b/src/Xanthous/Entities/Item.hs @@ -21,7 +21,7 @@ import Xanthous.Game.State data Item = Item { _itemType :: ItemType } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving Draw via DrawRawChar "_itemType" Item deriving (ToJSON, FromJSON) diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs index f715f8743..822b93f2d 100644 --- a/src/Xanthous/Entities/RawTypes.hs +++ b/src/Xanthous/Entities/RawTypes.hs @@ -40,7 +40,7 @@ data CreatureType = CreatureType , _friendly :: !Bool , _speed :: !TicksPerTile } - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] @@ -56,7 +56,7 @@ data EdibleItem = EdibleItem { _hitpointsHealed :: Int , _eatMessage :: Maybe Message } - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] @@ -73,7 +73,7 @@ data ItemType = ItemType , _char :: EntityChar , _edible :: Maybe EdibleItem } - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs index 8e9ec04cc..b83c3d246 100644 --- a/src/Xanthous/Game/Prompt.hs +++ b/src/Xanthous/Game/Prompt.hs @@ -27,7 +27,6 @@ import Xanthous.Prelude import Brick.Widgets.Edit (Editor, editorText, getEditContents) import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic -import Control.Comonad -------------------------------------------------------------------------------- import Xanthous.Util (smallestNotIn) import Xanthous.Data (Direction, Position) diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 16d93c61b..028688542 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -70,7 +70,6 @@ import Data.Aeson.Generic.DerivingVia import Data.Generics.Product.Fields import qualified Graphics.Vty.Attributes as Vty import qualified Graphics.Vty.Image as Vty -import Control.Comonad -------------------------------------------------------------------------------- import Xanthous.Data import Xanthous.Data.EntityMap (EntityMap, EntityID) @@ -282,7 +281,7 @@ brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain) -------------------------------------------------------------------------------- -class ( Show a, Eq a, NFData a +class ( Show a, Eq a, Ord a, NFData a , ToJSON a, FromJSON a , Draw a, Brain a ) => Entity a where @@ -301,6 +300,12 @@ instance Eq SomeEntity where Just Refl -> a == b _ -> False +instance Ord SomeEntity where + compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of + Just Refl -> compare a b + _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb) + + instance NFData SomeEntity where rnf (SomeEntity ent) = ent `deepseq` () diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index bb6b0d024..6a860e1c4 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -306,6 +306,10 @@ instance FromJSON Attr where parseStyle Default = pure Default parseStyle KeepCurrent = pure KeepCurrent +deriving stock instance Ord Color +deriving stock instance Ord a => Ord (MaybeDefault a) +deriving stock instance Ord Attr + -------------------------------------------------------------------------------- instance NFData a => NFData (NonNull a) where diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs index b17fd2897..2f50635e7 100644 --- a/src/Xanthous/Prelude.hs +++ b/src/Xanthous/Prelude.hs @@ -7,6 +7,12 @@ module Xanthous.Prelude , module Control.Lens , module Data.Void , module Control.Comonad + + + -- * Classy-Prelude addons + , ninsertSet + , ndeleteSet + , toVector ) where -------------------------------------------------------------------------------- import ClassyPrelude hiding @@ -17,3 +23,14 @@ import Control.Lens import Data.Void import Control.Comonad -------------------------------------------------------------------------------- + +ninsertSet + :: (IsSet set, MonoPointed set) + => Element set -> NonNull set -> NonNull set +ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs + +ndeleteSet :: IsSet b => Element b -> NonNull b -> b +ndeleteSet x = deleteSet x . toNullable + +toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a +toVector = fromList . toList diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs index 53f03020f..88e0d0d77 100644 --- a/test/Xanthous/Data/EntityMapSpec.hs +++ b/test/Xanthous/Data/EntityMapSpec.hs @@ -33,7 +33,15 @@ test = localOption (QuickCheckTests 20) else True ] , testGroup "JSON encoding/decoding" - [ testProperty "Preserves IDs" $ \(em :: EntityMap Int) -> + [ testProperty "round-trips" $ \(em :: EntityMap Int) -> + let em' = JSON.decode (JSON.encode em) + in counterexample (show (em' ^? _Just . lastID, em ^. lastID + , em' ^? _Just . byID == em ^. byID . re _Just + , em' ^? _Just . byPosition == em ^. byPosition . re _Just + , em' ^? _Just . _EntityMap == em ^. _EntityMap . re _Just + )) + $ em' === Just em + , testProperty "Preserves IDs" $ \(em :: EntityMap Int) -> let Just em' = JSON.decode $ JSON.encode em in toEIDsAndPositioned em' === toEIDsAndPositioned em ] diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs index 75e9f6215..2fa8527d0 100644 --- a/test/Xanthous/GameSpec.hs +++ b/test/Xanthous/GameSpec.hs @@ -46,6 +46,8 @@ test ] , testGroup "Saving the game" [ testProperty "forms a prism" $ isPrism saved + , testProperty "round-trips" $ \gs -> + loadGame (saveGame gs) === Just gs , testProperty "preserves the character ID" $ \gs -> let Just gs' = loadGame $ saveGame gs in gs' ^. character === gs ^. character diff --git a/xanthous.cabal b/xanthous.cabal index a5fbe9b4d..7198e9ab9 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 2f93900ad18d56709eb363a7f8dd251a9474dd7092b1aef956389f32c036a121 +-- hash: 0476b4307dfceb20b9358ca2e6f78c753e3e0a4ae60c6faed54528f6a9c0dc5c name: xanthous version: 0.1.0.0 @@ -96,6 +96,7 @@ library , megaparsec , mtl , optparse-applicative + , parallel , quickcheck-instances , quickcheck-text , random @@ -157,7 +158,7 @@ executable xanthous hs-source-dirs: src default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 build-depends: MonadRandom , QuickCheck @@ -182,6 +183,7 @@ executable xanthous , megaparsec , mtl , optparse-applicative + , parallel , quickcheck-instances , quickcheck-text , random @@ -220,7 +222,7 @@ test-suite test hs-source-dirs: test default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0 build-depends: MonadRandom , QuickCheck @@ -246,6 +248,7 @@ test-suite test , megaparsec , mtl , optparse-applicative + , parallel , quickcheck-instances , quickcheck-text , random