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
- 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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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] ]

View file

@ -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)

View file

@ -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)

View file

@ -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] ]

View file

@ -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)

View file

@ -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` ()

View file

@ -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

View file

@ -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

View file

@ -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
]

View file

@ -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

View file

@ -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