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.

15 files changed, 90 insertions, 34 deletions

diff --git a/package.yaml b/package.yaml
index cadfd04d8d79..f982a2339708 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 fdeb71beb5eb..dfad2cffd392 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 7aeb5fdf86a0..855a3462daee 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 9ca915553594..9ea952c054fb 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 22589252acce..dd14390df979 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 de9122746bcf..6f97c128d257 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 465110069c1d..0156cd54c8a7 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 f715f8743ab1..822b93f2dfe1 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 8e9ec04ccb33..b83c3d246fa2 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 16d93c61bae6..028688542a25 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 bb6b0d024e32..6a860e1c49f1 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 b17fd2897bb1..2f50635e783d 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 53f03020f346..88e0d0d7712c 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 75e9f6215ade..2fa8527d0e59 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 a5fbe9b4dcea..7198e9ab9d9a 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