From 4882350f5d7e54a6ae5c8760f2510273dae19c60 Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Tue, 15 Oct 2019 22:54:31 -0400
Subject: [PATCH] Don't walk gormlaks into walls

Because of the way lines are drawn, a specific configuration of
positioning for gormlaks would have them decide they desperately wanted
to walk *inside* a wall, which they would then both fail to do but also
always collide with whenever they tried to go anywhere else.
---
 src/Xanthous/AI/Gormlak.hs  | 12 +++++++++---
 src/Xanthous/Game/Lenses.hs | 27 ++++++++++++++++++---------
 test/Xanthous/UtilSpec.hs   |  4 ++++
 3 files changed, 31 insertions(+), 12 deletions(-)

diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs
index e13eb8ffe..268e33ad6 100644
--- a/src/Xanthous/AI/Gormlak.hs
+++ b/src/Xanthous/AI/Gormlak.hs
@@ -27,7 +27,9 @@ import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Entities (Entity(..), Brain(..), brainVia)
 import           Xanthous.Game.State (entities, GameState, entityIs)
 import           Xanthous.Game.Lenses
-                 ( Collision(..), collisionAt, character, characterPosition )
+                 ( Collision(..), entityCollision, collisionAt
+                 , character, characterPosition
+                 )
 import           Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
 import           Xanthous.Random
 import           Xanthous.Monad (say)
@@ -72,9 +74,13 @@ stepGormlak ticks pe@(Positioned pos creature) = do
             then attackCharacter $> pos'
             else pure $ pos' `stepTowards` charPos
       else do
-        lines <- uses entities $ linesOfSight pos' (Creature.visionRadius creature')
+        lines <- map (takeWhile (isNothing . entityCollision . map snd . snd)
+                    -- the first item on these lines is always the creature itself
+                    . fromMaybe mempty . tailMay)
+                . linesOfSight pos' (Creature.visionRadius creature')
+                <$> use entities
         line <- choose $ weightedBy length lines
-        pure $ fromMaybe pos' $ fmap fst . headMay =<< tailMay =<< line
+        pure $ fromMaybe pos' $ fmap fst . headMay =<< line
 
     vision = Creature.visionRadius creature
     attackCharacter = do
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index f49477a2d..77314a9ae 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -10,6 +10,7 @@ module Xanthous.Game.Lenses
 
     -- * Collisions
   , Collision(..)
+  , entityCollision
   , collisionAt
   ) where
 --------------------------------------------------------------------------------
@@ -93,13 +94,21 @@ data Collision
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData)
 
+entityCollision
+  :: ( MonoFoldable (f SomeEntity)
+    , Foldable f
+    , Element (f SomeEntity) ~ SomeEntity
+    , AsEmpty (f SomeEntity)
+    )
+  => f SomeEntity
+  -> Maybe Collision
+entityCollision Empty = Nothing
+entityCollision ents
+  | any (entityIs @Creature) ents = pure Combat
+  | all (entityIs @Item) ents = Nothing
+  | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
+  , all (view open) doors = Nothing
+  | otherwise = pure Stop
+
 collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
-collisionAt pos = do
-  ents <- use $ entities . EntityMap.atPosition pos
-  pure $
-    if | null ents -> Nothing
-       | any (entityIs @Creature) ents -> pure Combat
-       | all (entityIs @Item) ents -> Nothing
-       | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
-       , all (view open) doors -> Nothing
-       | otherwise -> pure Stop
+collisionAt pos = uses (entities . EntityMap.atPosition pos) entityCollision
diff --git a/test/Xanthous/UtilSpec.hs b/test/Xanthous/UtilSpec.hs
index 1cfca1ffc..8538ea509 100644
--- a/test/Xanthous/UtilSpec.hs
+++ b/test/Xanthous/UtilSpec.hs
@@ -21,4 +21,8 @@ test = testGroup "Xanthous.Util"
         forAll (shuffle xs) $ \shuffledXs ->
           smallestNotIn xs === smallestNotIn shuffledXs
     ]
+  , testGroup "takeWhileInclusive"
+    [ testProperty "takeWhileInclusive (const True) ≡ id"
+      $ \(xs :: [Int]) -> takeWhileInclusive (const True) xs === xs
+    ]
   ]