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:
parent
310ea90985
commit
97a5c61f28
15 changed files with 90 additions and 34 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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] ]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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] ]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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` ()
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue