Track entity collision in the Entity class

Rather than having a single function in the Game.Lenses module for
determining what collision type if any an entity has, track it in the
Entity typeclass itself. This is both more extensible and a better
separation of concerns and gets rid of one of the two needs for a
circular import. Yay!

As part of this, I realized nothing was being done to prevent doors from
being placed on tiles that already had walls (since now that was
properly causing a collision!) so I've fixed that as well.

2 files changed, 22 insertions, 27 deletions

diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index 580435a0688b..f7f4648dd5ed 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 --------------------------------------------------------------------------------
 module Xanthous.Game.Lenses
   ( positionedCharacter
@@ -11,7 +13,7 @@ module Xanthous.Game.Lenses
 
     -- * Collisions
   , Collision(..)
-  , entityCollision
+  , entitiesCollision
   , collisionAt
   ) where
 --------------------------------------------------------------------------------
@@ -26,9 +28,6 @@ import           Xanthous.Data
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.EntityMap.Graphics (visiblePositions)
 import           Xanthous.Entities.Character (Character, mkCharacter)
-import           Xanthous.Entities.Environment (Door, open, GroundMessage)
-import            Xanthous.Entities.Item (Item)
-import           {-# SOURCE #-} Xanthous.Entities.Creature (Creature)
 import           {-# SOURCE #-} Xanthous.Entities.Entities ()
 --------------------------------------------------------------------------------
 
@@ -96,31 +95,17 @@ characterVisiblePositions game =
   let charPos = game ^. characterPosition
   in visiblePositions charPos visionRadius $ game ^. entities
 
-data Collision
-  = Stop
-  | Combat
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (NFData)
-
-entityCollision
-  :: ( MonoFoldable (f SomeEntity)
-    , Foldable f
-    , Element (f SomeEntity) ~ SomeEntity
-    , AsEmpty (f SomeEntity)
+entitiesCollision
+  :: ( Functor f
+    , forall xx. MonoFoldable (f xx)
+    , forall xx. Element (f xx) ~ xx
+    , Element (f (Maybe Collision)) ~ Maybe Collision
+    , Show (f (Maybe Collision))
+    , Show (f SomeEntity)
     )
   => f SomeEntity
   -> Maybe Collision
-entityCollision Empty = Nothing
-entityCollision ents
-  -- TODO track entity collision in the Entity class
-  | any (entityIs @Creature) ents = pure Combat
-  | all (\e ->
-          entityIs @Item e
-        || entityIs @GroundMessage e
-        ) ents = Nothing
-  | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
-  , all (view open) doors = Nothing
-  | otherwise = pure Stop
+entitiesCollision = join . maximumMay . fmap entityCollision
 
 collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
-collisionAt pos = uses (entities . EntityMap.atPosition pos) entityCollision
+collisionAt pos = uses (entities . EntityMap.atPosition pos) entitiesCollision
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 853d0b6922d1..171f381e6b74 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -34,6 +34,7 @@ module Xanthous.Game.State
   , Brain(..)
   , Brainless(..)
   , brainVia
+  , Collision(..)
   , Entity(..)
   , SomeEntity(..)
   , downcastEntity
@@ -306,6 +307,13 @@ brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
 
 --------------------------------------------------------------------------------
 
+
+data Collision
+  = Stop   -- ^ Can't move through this
+  | Combat -- ^ Moving into this equates to hitting it with a stick
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData)
+
 class ( Show a, Eq a, Ord a, NFData a
       , ToJSON a, FromJSON a
       , Draw a, Brain a
@@ -313,6 +321,8 @@ class ( Show a, Eq a, Ord a, NFData a
   blocksVision :: a -> Bool
   description :: a -> Text
   entityChar :: a -> EntityChar
+  entityCollision :: a -> Maybe Collision
+  entityCollision = const $ Just Stop
 
 data SomeEntity where
   SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity