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.
This commit is contained in:
Griffin Smith 2019-11-30 15:00:39 -05:00
parent 310ea90985
commit 97a5c61f28
15 changed files with 90 additions and 34 deletions

View file

@ -41,6 +41,7 @@ dependencies:
- MonadRandom - MonadRandom
- mtl - mtl
- optparse-applicative - optparse-applicative
- parallel
- random - random
- random-fu - random-fu
- random-extras - random-extras
@ -97,6 +98,7 @@ executable:
- -threaded - -threaded
- -rtsopts - -rtsopts
- -with-rtsopts=-N - -with-rtsopts=-N
- -O2
tests: tests:
test: test:
@ -106,6 +108,7 @@ tests:
- -threaded - -threaded
- -rtsopts - -rtsopts
- -with-rtsopts=-N - -with-rtsopts=-N
- -O0
dependencies: dependencies:
- xanthous - xanthous
- tasty - tasty

View file

@ -115,7 +115,7 @@ type Position = Position' Int
instance Arbitrary a => Arbitrary (Position' a) where instance Arbitrary a => Arbitrary (Position' a) where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink (Position px py) = Position <$> shrink px <*> shrink py
instance Num a => Semigroup (Position' a) where instance Num a => Semigroup (Position' a) where

View file

@ -30,7 +30,7 @@ data EntityChar = EntityChar
{ _char :: Char { _char :: Char
, _style :: Vty.Attr , _style :: Vty.Attr
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary EntityChar deriving Arbitrary via GenericArbitrary EntityChar
makeFieldsNoPrefix ''EntityChar makeFieldsNoPrefix ''EntityChar

View file

@ -27,6 +27,7 @@ module Xanthous.Data.EntityMap
-- * debug -- * debug
, byID , byID
, byPosition , byPosition
, lastID
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -46,26 +47,28 @@ import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function)
import Test.QuickCheck.Checkers (EqProp) import Test.QuickCheck.Checkers (EqProp)
import Test.QuickCheck.Instances.UnorderedContainers () import Test.QuickCheck.Instances.UnorderedContainers ()
import Test.QuickCheck.Instances.Vector () import Test.QuickCheck.Instances.Vector ()
import Text.Show (showString, showParen)
import Data.Aeson import Data.Aeson
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type EntityID = Word32 type EntityID = Word32
type NonNullVector a = NonNull (Vector a) type NonNullSet a = NonNull (Set a)
data EntityMap a where data EntityMap a where
EntityMap :: EntityMap ::
{ _byPosition :: Map Position (NonNullVector EntityID) { _byPosition :: Map Position (NonNullSet EntityID)
, _byID :: HashMap EntityID (Positioned a) , _byID :: HashMap EntityID (Positioned a)
, _lastID :: EntityID , _lastID :: EntityID
} -> EntityMap a } -> EntityMap a
deriving stock (Functor, Foldable, Traversable, Generic) deriving stock (Functor, Foldable, Traversable, Generic)
deriving anyclass (NFData, CoArbitrary, Function) 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 makeLenses ''EntityMap
instance ToJSON a => ToJSON (EntityMap a) where instance ToJSON a => ToJSON (EntityMap a) where
toJSON = toJSON . toEIDsAndPositioned toJSON = toJSON . toEIDsAndPositioned
instance FromJSON a => FromJSON (EntityMap a) where instance FromJSON a => FromJSON (EntityMap a) where
parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
@ -73,14 +76,24 @@ byIDInvariantError :: forall a. a
byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
<> "must point to entityIDs in byID" <> "must point to entityIDs in byID"
instance Eq a => Eq (EntityMap a) where instance (Ord a, Eq a) => Eq (EntityMap a) where
em == em = em ^. _EntityMap == em ^. _EntityMap -- 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 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 instance Arbitrary a => Arbitrary (EntityMap a) where
arbitrary = review _EntityMap <$> arbitrary arbitrary = review _EntityMap <$> arbitrary
shrink em = review _EntityMap <$> shrink (em ^. _EntityMap)
type instance Index (EntityMap a) = EntityID type instance Index (EntityMap a) = EntityID
type instance IxValue (EntityMap a) = (Positioned a) type instance IxValue (EntityMap a) = (Positioned a)
@ -102,10 +115,10 @@ instance At (EntityMap a) where
) )
& byID . at eid ?~ pe & byID . at eid ?~ pe
& byPosition . at pos %~ \case & byPosition . at pos %~ \case
Nothing -> Just $ ncons eid mempty Nothing -> Just $ opoint eid
Just es -> Just $ eid <| es Just es -> Just $ ninsertSet eid es
removeEIDAtPos pos = removeEIDAtPos pos =
byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid)) byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid)
instance Semigroup (EntityMap a) where instance Semigroup (EntityMap a) where
em <> em = alaf Endo foldMap (uncurry insertAt) (em ^. _EntityMap) em em <> em = alaf Endo foldMap (uncurry insertAt) (em ^. _EntityMap) em
@ -137,8 +150,8 @@ instance Semigroup (Deduplicate a) where
_byPosition = mempty &~ do _byPosition = mempty &~ do
ifor_ _byID $ \eid (Positioned pos _) -> ifor_ _byID $ \eid (Positioned pos _) ->
at pos %= \case at pos %= \case
Just eids -> Just $ eid <| eids Just eids -> Just $ ninsertSet eid eids
Nothing -> Just $ ncons eid mempty Nothing -> Just $ opoint eid
_lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
in Deduplicate EntityMap{..} in Deduplicate EntityMap{..}
@ -164,8 +177,8 @@ insertAtReturningID pos e em =
in em' in em'
& byID . at eid ?~ Positioned pos e & byID . at eid ?~ Positioned pos e
& byPosition . at pos %~ \case & byPosition . at pos %~ \case
Nothing -> Just $ ncons eid mempty Nothing -> Just $ opoint eid
Just es -> Just $ eid <| es Just es -> Just $ ninsertSet eid es
& (eid, ) & (eid, )
insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
@ -176,7 +189,8 @@ atPosition pos = lens getter setter
where where
getter em = getter em =
let eids :: Vector EntityID 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 in getEIDAssume em <$> eids
setter em Empty = em & byPosition . at pos .~ Nothing setter em Empty = em & byPosition . at pos .~ Nothing
setter em entities = alaf Endo foldMap (insertAt pos) entities em 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 :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
atPositionWithIDs pos em = 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 in (id &&& Positioned pos . getEIDAssume em) <$> eids
fromEIDsAndPositioned fromEIDsAndPositioned
@ -199,8 +214,8 @@ fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
insert' (eid, pe@(Positioned pos _)) insert' (eid, pe@(Positioned pos _))
= (byID . at eid ?~ pe) = (byID . at eid ?~ pe)
. (byPosition . at pos %~ \case . (byPosition . at pos %~ \case
Just eids -> Just $ eid <| eids Just eids -> Just $ ninsertSet eid eids
Nothing -> Just $ ncons eid mempty Nothing -> Just $ opoint eid
) )
newLastID em = em & lastID newLastID em = em & lastID
.~ fromMaybe 1 .~ fromMaybe 1

View file

@ -39,7 +39,7 @@ data Character = Character
, _characterHitpoints' :: !Double , _characterHitpoints' :: !Double
, _speed :: TicksPerTile , _speed :: TicksPerTile
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]

View file

@ -47,7 +47,7 @@ data Destination = Destination
-- When this value reaches >= 1, the creature has reached their destination -- When this value reaches >= 1, the creature has reached their destination
, _destinationProgress :: !Tiles , _destinationProgress :: !Tiles
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
@ -63,7 +63,7 @@ destinationFromPos _destinationPosition =
data Hippocampus = Hippocampus data Hippocampus = Hippocampus
{ _destination :: !(Maybe Destination) { _destination :: !(Maybe Destination)
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
@ -81,7 +81,7 @@ data Creature = Creature
, _hitpoints :: !Hitpoints , _hitpoints :: !Hitpoints
, _hippocampus :: !Hippocampus , _hippocampus :: !Hippocampus
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)

View file

@ -21,7 +21,7 @@ import Xanthous.Game.State
data Item = Item data Item = Item
{ _itemType :: ItemType { _itemType :: ItemType
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving Draw via DrawRawChar "_itemType" Item deriving Draw via DrawRawChar "_itemType" Item
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)

View file

@ -40,7 +40,7 @@ data CreatureType = CreatureType
, _friendly :: !Bool , _friendly :: !Bool
, _speed :: !TicksPerTile , _speed :: !TicksPerTile
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
@ -56,7 +56,7 @@ data EdibleItem = EdibleItem
{ _hitpointsHealed :: Int { _hitpointsHealed :: Int
, _eatMessage :: Maybe Message , _eatMessage :: Maybe Message
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
@ -73,7 +73,7 @@ data ItemType = ItemType
, _char :: EntityChar , _char :: EntityChar
, _edible :: Maybe EdibleItem , _edible :: Maybe EdibleItem
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function) deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]

View file

@ -27,7 +27,6 @@ import Xanthous.Prelude
import Brick.Widgets.Edit (Editor, editorText, getEditContents) import Brick.Widgets.Edit (Editor, editorText, getEditContents)
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
import Control.Comonad
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Util (smallestNotIn) import Xanthous.Util (smallestNotIn)
import Xanthous.Data (Direction, Position) import Xanthous.Data (Direction, Position)

View file

@ -70,7 +70,6 @@ import Data.Aeson.Generic.DerivingVia
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
import qualified Graphics.Vty.Attributes as Vty import qualified Graphics.Vty.Attributes as Vty
import qualified Graphics.Vty.Image as Vty import qualified Graphics.Vty.Image as Vty
import Control.Comonad
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Data import Xanthous.Data
import Xanthous.Data.EntityMap (EntityMap, EntityID) 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 , ToJSON a, FromJSON a
, Draw a, Brain a , Draw a, Brain a
) => Entity a where ) => Entity a where
@ -301,6 +300,12 @@ instance Eq SomeEntity where
Just Refl -> a == b Just Refl -> a == b
_ -> False _ -> 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 instance NFData SomeEntity where
rnf (SomeEntity ent) = ent `deepseq` () rnf (SomeEntity ent) = ent `deepseq` ()

View file

@ -306,6 +306,10 @@ instance FromJSON Attr where
parseStyle Default = pure Default parseStyle Default = pure Default
parseStyle KeepCurrent = pure KeepCurrent 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 instance NFData a => NFData (NonNull a) where

View file

@ -7,6 +7,12 @@ module Xanthous.Prelude
, module Control.Lens , module Control.Lens
, module Data.Void , module Data.Void
, module Control.Comonad , module Control.Comonad
-- * Classy-Prelude addons
, ninsertSet
, ndeleteSet
, toVector
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import ClassyPrelude hiding import ClassyPrelude hiding
@ -17,3 +23,14 @@ import Control.Lens
import Data.Void import Data.Void
import Control.Comonad 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

View file

@ -33,7 +33,15 @@ test = localOption (QuickCheckTests 20)
else True else True
] ]
, testGroup "JSON encoding/decoding" , 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 let Just em' = JSON.decode $ JSON.encode em
in toEIDsAndPositioned em' === toEIDsAndPositioned em in toEIDsAndPositioned em' === toEIDsAndPositioned em
] ]

View file

@ -46,6 +46,8 @@ test
] ]
, testGroup "Saving the game" , testGroup "Saving the game"
[ testProperty "forms a prism" $ isPrism saved [ testProperty "forms a prism" $ isPrism saved
, testProperty "round-trips" $ \gs ->
loadGame (saveGame gs) === Just gs
, testProperty "preserves the character ID" $ \gs -> , testProperty "preserves the character ID" $ \gs ->
let Just gs' = loadGame $ saveGame gs let Just gs' = loadGame $ saveGame gs
in gs' ^. character === gs ^. character in gs' ^. character === gs ^. character

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 2f93900ad18d56709eb363a7f8dd251a9474dd7092b1aef956389f32c036a121 -- hash: 0476b4307dfceb20b9358ca2e6f78c753e3e0a4ae60c6faed54528f6a9c0dc5c
name: xanthous name: xanthous
version: 0.1.0.0 version: 0.1.0.0
@ -96,6 +96,7 @@ library
, megaparsec , megaparsec
, mtl , mtl
, optparse-applicative , optparse-applicative
, parallel
, quickcheck-instances , quickcheck-instances
, quickcheck-text , quickcheck-text
, random , random
@ -157,7 +158,7 @@ executable xanthous
hs-source-dirs: hs-source-dirs:
src 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 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: build-depends:
MonadRandom MonadRandom
, QuickCheck , QuickCheck
@ -182,6 +183,7 @@ executable xanthous
, megaparsec , megaparsec
, mtl , mtl
, optparse-applicative , optparse-applicative
, parallel
, quickcheck-instances , quickcheck-instances
, quickcheck-text , quickcheck-text
, random , random
@ -220,7 +222,7 @@ test-suite test
hs-source-dirs: hs-source-dirs:
test 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 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: build-depends:
MonadRandom MonadRandom
, QuickCheck , QuickCheck
@ -246,6 +248,7 @@ test-suite test
, megaparsec , megaparsec
, mtl , mtl
, optparse-applicative , optparse-applicative
, parallel
, quickcheck-instances , quickcheck-instances
, quickcheck-text , quickcheck-text
, random , random