Preserve entityIDs in atPosition's setter
Make the setter for the atPosition lens preserve entityIDs for already-existing entities at the position, so that when we plop something in the same tile as the character the character's entity ID doesn't disappear.
This commit is contained in:
		
							parent
							
								
									052bc8455a
								
							
						
					
					
						commit
						f701a0be40
					
				
					 2 changed files with 50 additions and 15 deletions
				
			
		| 
						 | 
					@ -1,3 +1,4 @@
 | 
				
			||||||
 | 
					{-# LANGUAGE ViewPatterns #-}
 | 
				
			||||||
{-# LANGUAGE UndecidableInstances #-}
 | 
					{-# LANGUAGE UndecidableInstances #-}
 | 
				
			||||||
{-# LANGUAGE RecordWildCards #-}
 | 
					{-# LANGUAGE RecordWildCards #-}
 | 
				
			||||||
{-# LANGUAGE DeriveTraversable  #-}
 | 
					{-# LANGUAGE DeriveTraversable  #-}
 | 
				
			||||||
| 
						 | 
					@ -185,7 +186,7 @@ insertAtReturningID pos e em =
 | 
				
			||||||
insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
 | 
					insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
 | 
				
			||||||
insertAt pos e = snd . insertAtReturningID pos e
 | 
					insertAt pos e = snd . insertAtReturningID pos e
 | 
				
			||||||
 | 
					
 | 
				
			||||||
atPosition :: forall a. Position -> Lens' (EntityMap a) (VectorBag a)
 | 
					atPosition :: forall a. (Ord a, Show a) => Position -> Lens' (EntityMap a) (VectorBag a)
 | 
				
			||||||
atPosition pos = lens getter setter
 | 
					atPosition pos = lens getter setter
 | 
				
			||||||
  where
 | 
					  where
 | 
				
			||||||
    getter em =
 | 
					    getter em =
 | 
				
			||||||
| 
						 | 
					@ -194,16 +195,34 @@ atPosition pos = lens getter setter
 | 
				
			||||||
                 $ em ^. byPosition . at pos
 | 
					                 $ 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 =
 | 
					    setter em (sort -> entities) =
 | 
				
			||||||
      alaf Endo foldMap (insertAt pos) entities
 | 
					      let origEIDs = maybe Empty toNullable $ em ^. byPosition . at pos
 | 
				
			||||||
      . removeAllAt pos
 | 
					          origEntitiesWithIDs =
 | 
				
			||||||
      $ em
 | 
					            sortOn snd $ toList origEIDs <&> \eid -> (eid, getEIDAssume em eid)
 | 
				
			||||||
      where
 | 
					          go alles₁@((eid, e₁) :< es₁) -- orig
 | 
				
			||||||
        removeAllAt p e =
 | 
					             (e₂ :< es₂)               -- new
 | 
				
			||||||
          let eids = e ^.. byPosition . at p >>= toList >>= toList
 | 
					            | e₁ == e₂
 | 
				
			||||||
          in alaf Endo foldMap (\eid -> byID . at eid .~ Nothing) eids
 | 
					              -- same, do nothing
 | 
				
			||||||
           . (byPosition . at pos .~ Nothing)
 | 
					            = let (eids, lastEID, byID') = go es₁ es₂
 | 
				
			||||||
           $ e
 | 
					              in (insertSet eid eids, lastEID, byID')
 | 
				
			||||||
 | 
					            | otherwise
 | 
				
			||||||
 | 
					              -- e₂ is new, generate a new ID for it
 | 
				
			||||||
 | 
					            = let (eids, lastEID, byID') = go alles₁ es₂
 | 
				
			||||||
 | 
					                  eid' = succ lastEID
 | 
				
			||||||
 | 
					              in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos e₂)
 | 
				
			||||||
 | 
					          go Empty Empty = (mempty, em ^. lastID, em ^. byID)
 | 
				
			||||||
 | 
					          go orig Empty =
 | 
				
			||||||
 | 
					            let byID' = foldr deleteMap (em ^. byID) $ map fst orig
 | 
				
			||||||
 | 
					            in (mempty, em ^. lastID, byID')
 | 
				
			||||||
 | 
					          go Empty (new :< news) =
 | 
				
			||||||
 | 
					            let (eids, lastEID, byID') = go Empty news
 | 
				
			||||||
 | 
					                eid' = succ lastEID
 | 
				
			||||||
 | 
					            in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos new)
 | 
				
			||||||
 | 
					          go _ _ = error "unreachable"
 | 
				
			||||||
 | 
					          (eidsAtPosition, newLastID, newByID) = go origEntitiesWithIDs entities
 | 
				
			||||||
 | 
					      in em & byPosition . at pos .~ fromNullable eidsAtPosition
 | 
				
			||||||
 | 
					            & byID .~ newByID
 | 
				
			||||||
 | 
					            & lastID .~ newLastID
 | 
				
			||||||
 | 
					
 | 
				
			||||||
getEIDAssume :: EntityMap a -> EntityID -> a
 | 
					getEIDAssume :: EntityMap a -> EntityID -> a
 | 
				
			||||||
getEIDAssume em eid = fromMaybe byIDInvariantError
 | 
					getEIDAssume em eid = fromMaybe byIDInvariantError
 | 
				
			||||||
| 
						 | 
					@ -247,7 +266,7 @@ lookup eid = fmap (view positioned) . lookupWithPosition eid
 | 
				
			||||||
-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
 | 
					-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
 | 
				
			||||||
-- positionedEntities = byID . itraversed
 | 
					-- positionedEntities = byID . itraversed
 | 
				
			||||||
 | 
					
 | 
				
			||||||
neighbors :: Position -> EntityMap a -> Neighbors (VectorBag a)
 | 
					neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a)
 | 
				
			||||||
neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
 | 
					neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
 | 
				
			||||||
 | 
					
 | 
				
			||||||
--------------------------------------------------------------------------------
 | 
					--------------------------------------------------------------------------------
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -3,11 +3,11 @@
 | 
				
			||||||
module Xanthous.Data.EntityMapSpec where
 | 
					module Xanthous.Data.EntityMapSpec where
 | 
				
			||||||
--------------------------------------------------------------------------------
 | 
					--------------------------------------------------------------------------------
 | 
				
			||||||
import           Test.Prelude
 | 
					import           Test.Prelude
 | 
				
			||||||
import           Control.Lens.Properties
 | 
					 | 
				
			||||||
--------------------------------------------------------------------------------
 | 
					--------------------------------------------------------------------------------
 | 
				
			||||||
import qualified Data.Aeson as JSON
 | 
					import qualified Data.Aeson as JSON
 | 
				
			||||||
--------------------------------------------------------------------------------
 | 
					--------------------------------------------------------------------------------
 | 
				
			||||||
import           Xanthous.Data.EntityMap
 | 
					import           Xanthous.Data.EntityMap
 | 
				
			||||||
 | 
					import           Xanthous.Data (Positioned(..))
 | 
				
			||||||
--------------------------------------------------------------------------------
 | 
					--------------------------------------------------------------------------------
 | 
				
			||||||
 | 
					
 | 
				
			||||||
main :: IO ()
 | 
					main :: IO ()
 | 
				
			||||||
| 
						 | 
					@ -47,7 +47,23 @@ test = localOption (QuickCheckTests 20)
 | 
				
			||||||
        in toEIDsAndPositioned em' === toEIDsAndPositioned em
 | 
					        in toEIDsAndPositioned em' === toEIDsAndPositioned em
 | 
				
			||||||
    ]
 | 
					    ]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  , testGroup "atPosition"
 | 
					  , localOption (QuickCheckTests 50)
 | 
				
			||||||
    [ testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos
 | 
					  $ testGroup "atPosition"
 | 
				
			||||||
 | 
					    [ testProperty "setget" $ \pos (em :: EntityMap Int) es ->
 | 
				
			||||||
 | 
					        view (atPosition pos) (set (atPosition pos) es em) === es
 | 
				
			||||||
 | 
					    , testProperty "getset" $ \pos (em :: EntityMap Int) ->
 | 
				
			||||||
 | 
					        set (atPosition pos) (view (atPosition pos) em) em === em
 | 
				
			||||||
 | 
					    , testProperty "setset" $ \pos (em :: EntityMap Int) es ->
 | 
				
			||||||
 | 
					        (set (atPosition pos) es . set (atPosition pos) es) em
 | 
				
			||||||
 | 
					        ===
 | 
				
			||||||
 | 
					        set (atPosition pos) es em
 | 
				
			||||||
 | 
					      -- testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos
 | 
				
			||||||
 | 
					    , testProperty "preserves IDs" $ \(em :: EntityMap Int) e1 e2 p ->
 | 
				
			||||||
 | 
					        let (eid, em') = insertAtReturningID p e1 em
 | 
				
			||||||
 | 
					            em'' = em' & atPosition p %~ (e2 <|)
 | 
				
			||||||
 | 
					        in
 | 
				
			||||||
 | 
					          counterexample ("em': " <> show em')
 | 
				
			||||||
 | 
					          . counterexample ("em'': " <> show em'')
 | 
				
			||||||
 | 
					          $ em'' ^. at eid === Just (Positioned p e1)
 | 
				
			||||||
    ]
 | 
					    ]
 | 
				
			||||||
  ]
 | 
					  ]
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue