From 782d3880c8da35b48276a874d396d24ca6dc7004 Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Sat, 8 Feb 2020 13:42:51 -0500
Subject: Block doors being closed on gormlaks

Prevent closing doors when there's a gormlak or other entity with the
blocksObject attribute set to true on the same tile. There's a message
sent here which is grammatically incorrect - it says "The a gormlak
blocks the door" - should fix that later.
---
 src/Xanthous/App.hs               | 23 ++++++++++++++++++++++-
 src/Xanthous/Entities/Creature.hs |  1 +
 src/Xanthous/Entities/Entities.hs |  1 +
 src/Xanthous/Game/State.hs        |  8 ++++++++
 src/Xanthous/messages.yaml        |  1 +
 5 files changed, 33 insertions(+), 1 deletion(-)

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 0d4f973d71..d786eb29da 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -26,6 +26,7 @@ import           Xanthous.Data
                  ( move
                  , Dimensions'(Dimensions)
                  , positioned
+                 , position
                  , Position
                  , Ticks
                  , (|*|)
@@ -195,12 +196,32 @@ handleCommand Close = do
   prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable
     $ \(DirectionResult dir) -> do
       pos <- move dir <$> use characterPosition
-      doors <- uses entities $ entitiesAtPositionWithType @Door pos
+      (nonDoors, doors) <- uses entities
+        $ partitionEithers
+        . toList
+        . map ( (matching . aside $ _SomeEntity @Door)
+              . over _2 (view positioned)
+              )
+        . EntityMap.atPositionWithIDs pos
       if | null doors -> say_ ["close", "nothingToClose"]
          | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"]
+         | any (blocksObject . snd) nonDoors ->
+           say ["close", "blocked"]
+           $ object [ "entityDescriptions"
+                    A..= ( toSentence . map description . filter blocksObject
+                         . map snd
+                         ) nonDoors
+                    , "blockOrBlocks"
+                    A..= ( if length nonDoors == 1
+                           then "blocks"
+                           else "block"
+                         :: Text)
+                    ]
          | otherwise -> do
              for_ doors $ \(eid, _) ->
                entities . ix eid . positioned . _SomeEntity . closed .= True
+             for_ nonDoors $ \(eid, _) ->
+               entities . ix eid . position %= move dir
              say_ ["close", "success"]
       pure ()
   stepGame -- TODO
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index a44b3b2281..cc07b3560c 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -66,6 +66,7 @@ instance Brain Creature where
 
 instance Entity Creature where
   blocksVision _ = False
+  blocksObject _ = True
   description = view $ creatureType . Raw.description
   entityChar = view $ creatureType . char
   entityCollision = const $ Just Combat
diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
index 1b9f138fe2..710e577be8 100644
--- a/src/Xanthous/Entities/Entities.hs
+++ b/src/Xanthous/Entities/Entities.hs
@@ -47,6 +47,7 @@ deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
 
 instance Entity SomeEntity where
   blocksVision (SomeEntity ent) = blocksVision ent
+  blocksObject (SomeEntity ent) = blocksObject ent
   description (SomeEntity ent) = description ent
   entityChar (SomeEntity ent) = entityChar ent
   entityCollision (SomeEntity ent) = entityCollision ent
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index e5ee66deac..5c9130de38 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -295,6 +295,7 @@ instance
 
 class Brain a where
   step :: Ticks -> Positioned a -> AppM (Positioned a)
+  -- | Does this entity ever move on its own?
   entityCanMove :: a -> Bool
   entityCanMove = const False
 
@@ -326,6 +327,12 @@ class ( Show a, Eq a, Ord a, NFData a
       , Draw a, Brain a
       ) => Entity a where
   blocksVision :: a -> Bool
+
+  -- | Does this entity block a large object from being put in the same tile as
+  -- it - eg a a door being closed on it
+  blocksObject :: a -> Bool
+  blocksObject = const False
+
   description :: a -> Text
   entityChar :: a -> EntityChar
   entityCollision :: a -> Maybe Collision
@@ -368,6 +375,7 @@ instance Draw SomeEntity where
 instance Brain SomeEntity where
   step ticks (Positioned p (SomeEntity ent)) =
     fmap SomeEntity <$> step ticks (Positioned p ent)
+  entityCanMove (SomeEntity ent) = entityCanMove ent
 
 downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
 downcastEntity (SomeEntity e) = cast e
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 4efcc8dbc3..ed592e2650 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -45,6 +45,7 @@ close:
     - You shut the door.
   nothingToClose: "There's nothing to close there."
   alreadyClosed: "That door is already closed."
+  blocked: "The {{entityDescriptions}} {{blockOrBlocks}} the door!"
 
 look:
   prompt: Select a position on the map to describe (use Enter to confirm)
-- 
cgit 1.4.1