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, 3 insertions, 191 deletions

diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 68bd9e0438cc..278e3d8ff4cc 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -1,7 +1,3 @@
-{-# LANGUAGE MultiWayIf      #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE RecordWildCards #-}
---------------------------------------------------------------------------------
 module Xanthous.Game
   ( GameState(..)
   , entities
@@ -23,194 +19,10 @@ module Xanthous.Game
   , popMessage
   , hideMessage
 
-    -- * collisions
-  , Collision(..)
-  , collisionAt
-
     -- * App monad
   , AppT(..)
   ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude
---------------------------------------------------------------------------------
-import           Data.List.NonEmpty ( NonEmpty((:|)))
-import qualified Data.List.NonEmpty as NonEmpty
-import           System.Random
-import           Test.QuickCheck
-import           Test.QuickCheck.Arbitrary.Generic
-import           Control.Monad.State.Class
-import           Control.Monad.State
-import           Control.Monad.Random.Class
---------------------------------------------------------------------------------
-import           Xanthous.Data.EntityMap (EntityMap, EntityID)
-import qualified Xanthous.Data.EntityMap as EntityMap
-import           Xanthous.Data.EntityMap.Graphics
-import           Xanthous.Data (Positioned, Position(..), positioned, position)
-import           Xanthous.Entities
-                 (SomeEntity(..), downcastEntity, entityIs, _SomeEntity)
-import           Xanthous.Entities.Character
-import           Xanthous.Entities.Creature
-import           Xanthous.Entities.Item
-import           Xanthous.Entities.Environment
-import           Xanthous.Entities.Arbitrary ()
-import           Xanthous.Orphans ()
-import           Xanthous.Game.Prompt
---------------------------------------------------------------------------------
-
-data MessageHistory
-  = NoMessageHistory
-  | MessageHistory (NonEmpty Text) Bool
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-
-instance Arbitrary MessageHistory where
-  arbitrary = genericArbitrary
-
-pushMessage :: Text -> MessageHistory -> MessageHistory
-pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
-pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
-
-popMessage :: MessageHistory -> MessageHistory
-popMessage NoMessageHistory = NoMessageHistory
-popMessage (MessageHistory msgs False) = MessageHistory msgs True
-popMessage (MessageHistory msgs@(_ :| []) _) = MessageHistory msgs True
-popMessage (MessageHistory (_ :| (msg : msgs)) True) = MessageHistory (msg :| msgs) True
-
-hideMessage :: MessageHistory -> MessageHistory
-hideMessage NoMessageHistory = NoMessageHistory
-hideMessage (MessageHistory msgs _) = MessageHistory msgs False
-
---------------------------------------------------------------------------------
-
-data GamePromptState m where
-  NoPrompt :: GamePromptState m
-  WaitingPrompt :: Text -> Prompt m -> GamePromptState m
-  deriving stock (Show)
-
---------------------------------------------------------------------------------
-
-newtype AppT m a
-  = AppT { unAppT :: StateT GameState m a }
-  deriving ( Functor
-           , Applicative
-           , Monad
-           , MonadState GameState
-           )
-       via (StateT GameState m)
-
---------------------------------------------------------------------------------
-
-data GameState = GameState
-  { _entities          :: !(EntityMap SomeEntity)
-  , _revealedPositions :: !(Set Position)
-  , _characterEntityID :: !EntityID
-  , _messageHistory    :: !MessageHistory
-  , _randomGen         :: !StdGen
-  , _promptState       :: !(GamePromptState (AppT Identity))
-  }
-  deriving stock (Show)
-makeLenses ''GameState
-
-instance Eq GameState where
-  (==) = (==) `on` \gs ->
-    ( gs ^. entities
-    , gs ^. revealedPositions
-    , gs ^. characterEntityID
-    , gs ^. messageHistory
-    )
-
-
-instance Arbitrary GameState where
-  arbitrary = do
-    char <- arbitrary @Character
-    charPos <- arbitrary
-    _messageHistory <- arbitrary
-    (_characterEntityID, _entities) <- arbitrary <&>
-      EntityMap.insertAtReturningID charPos (SomeEntity char)
-    _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
-    _randomGen <- mkStdGen <$> arbitrary
-    let _promptState = NoPrompt -- TODO
-    pure $ GameState {..}
-
-
-getInitialState :: IO GameState
-getInitialState = do
-  _randomGen <- getStdGen
-  let char = mkCharacter
-      (_characterEntityID, _entities)
-        = EntityMap.insertAtReturningID
-          (Position 0 0)
-          (SomeEntity char)
-          mempty
-      _messageHistory = NoMessageHistory
-      _revealedPositions = mempty
-      _promptState = NoPrompt
-  pure GameState {..}
-
-positionedCharacter :: Lens' GameState (Positioned Character)
-positionedCharacter = lens getPositionedCharacter setPositionedCharacter
-  where
-    setPositionedCharacter :: GameState -> Positioned Character -> GameState
-    setPositionedCharacter game char
-      = game
-      &  entities . at (game ^. characterEntityID)
-      ?~ fmap SomeEntity char
-
-    getPositionedCharacter :: GameState -> Positioned Character
-    getPositionedCharacter game
-      = over positioned
-        ( fromMaybe (error "Invariant error: Character was not a character!")
-        . downcastEntity
-        )
-      . fromMaybe (error "Invariant error: Character not found!")
-      $ EntityMap.lookupWithPosition
-        (game ^. characterEntityID)
-        (game ^. entities)
-
-
-character :: Lens' GameState Character
-character = positionedCharacter . positioned
-
-characterPosition :: Lens' GameState Position
-characterPosition = positionedCharacter . position
-
-visionRadius :: Word
-visionRadius = 12 -- TODO make this dynamic
-
--- | Update the revealed entities at the character's position based on their vision
-updateCharacterVision :: GameState -> GameState
-updateCharacterVision game =
-  let charPos = game ^. characterPosition
-      visible = visiblePositions charPos visionRadius $ game ^. entities
-  in game & revealedPositions <>~ visible
-
-
---------------------------------------------------------------------------------
-
-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
-
---------------------------------------------------------------------------------
-
-instance MonadTrans AppT where
-  lift = AppT . lift
-
-instance (Monad m) => MonadRandom (AppT m) where
-  getRandomR rng = randomGen %%= randomR rng
-  getRandom = randomGen %%= random
-  getRandomRs rng = uses randomGen $ randomRs rng
-  getRandoms = uses randomGen randoms
+import Xanthous.Game.State
+import Xanthous.Game.Lenses
+import Xanthous.Game.Arbitrary ()