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.

5 files changed, 11 insertions, 6 deletions

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