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.

9 files changed, 37 insertions, 35 deletions

diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs
index 031262533d21..8040fea35b8d 100644
--- a/src/Xanthous/AI/Gormlak.hs
+++ b/src/Xanthous/AI/Gormlak.hs
@@ -27,7 +27,7 @@ import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Entities.RawTypes (CreatureType)
 import           Xanthous.Game.State
 import           Xanthous.Game.Lenses
-                 ( Collision(..), entityCollision, collisionAt
+                 ( Collision(..), entitiesCollision, collisionAt
                  , character, characterPosition
                  )
 import           Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
@@ -90,7 +90,7 @@ stepGormlak ticks pe@(Positioned pos creature) = do
             then attackCharacter $> pos'
             else pure $ pos' `stepTowards` charPos
       else do
-        lines <- map (takeWhile (isNothing . entityCollision . map snd . snd)
+        lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd)
                     -- the first item on these lines is always the creature itself
                     . fromMaybe mempty . tailMay)
                 . linesOfSight pos' (visionRadius creature')
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 6e955324a06a..a44b3b22813b 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -68,6 +68,7 @@ instance Entity Creature where
   blocksVision _ = False
   description = view $ creatureType . Raw.description
   entityChar = view $ creatureType . char
+  entityCollision = const $ Just Combat
 
 --------------------------------------------------------------------------------
 
diff --git a/src/Xanthous/Entities/Creature.hs-boot b/src/Xanthous/Entities/Creature.hs-boot
deleted file mode 100644
index 4c930d26426d..000000000000
--- a/src/Xanthous/Entities/Creature.hs-boot
+++ /dev/null
@@ -1,2 +0,0 @@
-module Xanthous.Entities.Creature where
-data Creature
diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
index 8793565a2a34..1e533a297310 100644
--- a/src/Xanthous/Entities/Entities.hs
+++ b/src/Xanthous/Entities/Entities.hs
@@ -47,6 +47,7 @@ instance Entity SomeEntity where
   blocksVision (SomeEntity ent) = blocksVision ent
   description (SomeEntity ent) = description ent
   entityChar (SomeEntity ent) = entityChar ent
+  entityCollision (SomeEntity ent) = entityCollision ent
 
 instance Function SomeEntity where
   function = functionJSON
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 46416d1da59a..dee8d83c3239 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -91,6 +91,8 @@ instance Entity Door where
   description door | door ^. open = "an open door"
                    | otherwise    = "a closed door"
   entityChar _ = "d"
+  entityCollision door | door ^. open = Nothing
+                       | otherwise = Just Stop
 
 -- | A closed, unlocked door
 unlockedDoor :: Door
@@ -113,8 +115,10 @@ newtype GroundMessage = GroundMessage Text
   deriving Draw
        via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
            GroundMessage
-  deriving Entity
-       via DeriveEntity 'False "a message on the ground. Press r. to read it."
-                        "≈"
-           GroundMessage
 instance Brain GroundMessage where step = brainVia Brainless
+
+instance Entity GroundMessage where
+  blocksVision = const False
+  description = const "a message on the ground. Press r. to read it."
+  entityChar = const "≈"
+  entityCollision = const Nothing
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
index 0156cd54c8a7..cedd75507a70 100644
--- a/src/Xanthous/Entities/Item.hs
+++ b/src/Xanthous/Entities/Item.hs
@@ -41,6 +41,7 @@ instance Entity Item where
   blocksVision _ = False
   description = view $ itemType . Raw.description
   entityChar = view $ itemType . Raw.char
+  entityCollision = const Nothing
 
 newWithType :: ItemType -> Item
 newWithType = Item
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
diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs
index aaeb4a77fdda..96d64a693774 100644
--- a/src/Xanthous/Generators/LevelContents.hs
+++ b/src/Xanthous/Generators/LevelContents.hs
@@ -45,6 +45,8 @@ randomDoors cells = do
     candidateCells = filter doorable $ Arr.indices cells
     subsetRange = (0.8 :: Double, 1.0)
     doorable (x, y) =
+      not (fromMaybe True $ cells ^? ix (x, y))
+      &&
       ( fromMaybe True $ cells ^? ix (x - 1, y) -- left
       , fromMaybe True $ cells ^? ix (x, y - 1) -- top
       , fromMaybe True $ cells ^? ix (x + 1, y) -- right