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.

11 files changed, 70 insertions, 30 deletions

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