Implement the start of creature AI

Add a Brain class, which determines for an entity the set of moves it
makes every step of the game, and begin to implement that for gormlaks.
The idea here is that every step of the game, a gormlak will move
towards the furthest-away wall it can see.

1 files changed, 41 insertions, 9 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 8353df437b..8d9ea54f0f 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE ViewPatterns #-}
+--------------------------------------------------------------------------------
 module Xanthous.App (makeApp) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -8,9 +8,8 @@ import qualified Brick
 import           Brick.Widgets.Edit (handleEditorEvent)
 import           Graphics.Vty.Attributes (defAttr)
 import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
-import           Control.Monad.State (get, state, StateT(..), MonadState)
+import           Control.Monad.State (get, MonadState)
 import           Control.Monad.Random (MonadRandom)
-import           Data.Coerce
 import           Control.Monad.State.Class (modify)
 import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
@@ -45,7 +44,6 @@ import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
 --------------------------------------------------------------------------------
 
 type App = Brick.App GameState () Name
-type AppM a = AppT (EventM Name) a
 
 makeApp :: IO App
 makeApp = pure $ Brick.App
@@ -85,6 +83,17 @@ initLevel = do
 
   characterPosition .= level ^. levelCharacterPosition
 
+--------------------------------------------------------------------------------
+
+stepGame :: AppM ()
+stepGame = do
+  ents <- uses entities EntityMap.toEIDsAndPositioned
+  for_ ents $ \(eid, pEntity) -> do
+    pEntity' <- step pEntity
+    entities . ix eid .= pEntity'
+
+--------------------------------------------------------------------------------
+
 handleEvent :: BrickEvent Name () -> AppM (Next GameState)
 handleEvent ev = use promptState >>= \case
   NoPrompt -> handleNoPromptEvent ev
@@ -107,6 +116,7 @@ handleCommand (Move dir) = do
       characterPosition .= newPos
       describeEntitiesAt newPos
       modify updateCharacterVision
+      stepGame
     Just Combat -> attackAt newPos
     Just Stop -> pure ()
   continue
@@ -120,6 +130,7 @@ handleCommand PickUp = do
       character %= Character.pickUpItem item
       entities . at itemID .= Nothing
       say ["items", "pickUp"] $ object [ "item" A..= item ]
+      stepGame
     _ -> undefined
   continue
 
@@ -139,11 +150,14 @@ handleCommand Open = do
                entities . ix eid . positioned . _SomeEntity . open .= True
              say_ ["open", "success"]
       pure ()
+  stepGame
   continue
 
+handleCommand Wait = stepGame >> continue
+
 handlePromptEvent
   :: Text -- ^ Prompt message
-  -> Prompt (AppT Identity)
+  -> Prompt AppM
   -> BrickEvent Name ()
   -> AppM (Next GameState)
 
@@ -151,7 +165,7 @@ handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do
   promptState .= NoPrompt
   continue
 handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do
-  () <- state . coerce $ submitPrompt pr
+  submitPrompt pr
   promptState .= NoPrompt
   continue
 
@@ -168,7 +182,7 @@ handlePromptEvent
 handlePromptEvent _ (Prompt _ SDirectionPrompt _ cb)
   (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
   = do
-    () <- state . coerce . cb $ DirectionResult dir
+    cb $ DirectionResult dir
     promptState .= NoPrompt
     continue
 handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue
@@ -181,7 +195,7 @@ prompt
   => [Text]                     -- ^ Message key
   -> params                     -- ^ Message params
   -> PromptCancellable
-  -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
   -> AppM ()
 prompt msgPath params cancellable cb = do
   let pt = singPromptType @pt
@@ -194,7 +208,7 @@ prompt_
     (SingPromptType pt)
   => [Text] -- ^ Message key
   -> PromptCancellable
-  -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
   -> AppM ()
 prompt_ msg = prompt msg $ object []
 
@@ -242,3 +256,21 @@ attackAt pos =
       else do
         say ["combat", "hit"] msgParams
         entities . ix creatureID . positioned .= SomeEntity creature'
+    stepGame
+
+data Collision
+  = Stop
+  | Combat
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData)
+
+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