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.

3 files changed, 299 insertions, 0 deletions

diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
new file mode 100644
index 000000000000..5ab2301e7083
--- /dev/null
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Arbitrary where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           System.Random
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Entities.Arbitrary ()
+import           Xanthous.Entities.Character
+import qualified Xanthous.Data.EntityMap as EntityMap
+--------------------------------------------------------------------------------
+
+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 {..}
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
new file mode 100644
index 000000000000..91ff5c137d1a
--- /dev/null
+++ b/src/Xanthous/Game/Lenses.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Lenses
+  ( positionedCharacter
+  , character
+  , characterPosition
+  , updateCharacterVision
+  , getInitialState
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Random
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Data
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.EntityMap.Graphics (visiblePositions)
+import           Xanthous.Entities.Character (Character, mkCharacter)
+--------------------------------------------------------------------------------
+
+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
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
new file mode 100644
index 000000000000..9b81abe35247
--- /dev/null
+++ b/src/Xanthous/Game/State.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.State
+  ( GameState(..)
+  , entities
+  , revealedPositions
+  , messageHistory
+  , randomGen
+  , promptState
+  , characterEntityID
+  , GamePromptState(..)
+
+    -- * Messages
+  , MessageHistory(..)
+  , pushMessage
+  , popMessage
+  , hideMessage
+
+    -- * App monad
+  , AppT(..)
+  , AppM
+
+    -- * Entities
+  , Draw(..)
+  , Brain(..)
+  , Brainless(..)
+  , brainVia
+  , Entity(..)
+  , SomeEntity(..)
+  , downcastEntity
+  , _SomeEntity
+  , entityIs
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.List.NonEmpty ( NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+import           Data.Typeable
+import           Data.Coerce
+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           Brick (EventM, Widget)
+--------------------------------------------------------------------------------
+import           Xanthous.Data.EntityMap (EntityMap, EntityID)
+import           Xanthous.Data (Positioned(..), Position(..), Neighbors)
+import           Xanthous.Orphans ()
+import           Xanthous.Game.Prompt
+import           Xanthous.Resource
+--------------------------------------------------------------------------------
+
+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)
+
+type AppM = AppT (EventM Name)
+
+--------------------------------------------------------------------------------
+
+class Draw a where
+  drawWithNeighbors :: Neighbors (Vector SomeEntity) -> a -> Widget n
+  drawWithNeighbors = const draw
+
+  draw :: a -> Widget n
+  draw = drawWithNeighbors $ pure mempty
+
+instance Draw a => Draw (Positioned a) where
+  drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
+  draw (Positioned _ a) = draw a
+
+--------------------------------------------------------------------------------
+
+class Brain a where
+  step :: Positioned a -> AppM (Positioned a)
+
+newtype Brainless a = Brainless a
+
+instance Brain (Brainless a) where
+  step = pure
+
+-- | Workaround for the inability to use DerivingVia on Brain due to the lack of
+-- higher-order roles (specifically AppT not having its last type argument have
+-- role representational bc of StateT)
+brainVia
+  :: forall brain entity. (Coercible entity brain, Brain brain)
+  => (entity -> brain) -- ^ constructor, ignored
+  -> (Positioned entity -> AppM (Positioned entity))
+brainVia _ = fmap coerce . step . coerce @_ @(Positioned brain)
+
+--------------------------------------------------------------------------------
+
+class (Show a, Eq a, Draw a, Brain a) => Entity a where
+  blocksVision :: a -> Bool
+  description :: a -> Text
+
+data SomeEntity where
+  SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
+
+instance Show SomeEntity where
+  show (SomeEntity e) = "SomeEntity (" <> show e <> ")"
+
+instance Eq SomeEntity where
+  (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of
+    Just Refl -> a == b
+    _ -> False
+
+instance Draw (SomeEntity) where
+  drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
+
+instance Brain SomeEntity where
+  step (Positioned pos (SomeEntity ent)) =
+    fmap SomeEntity <$> step (Positioned pos ent)
+
+instance Entity SomeEntity where
+  blocksVision (SomeEntity ent) = blocksVision ent
+  description (SomeEntity ent) = description ent
+
+downcastEntity :: forall a. (Entity a, Typeable a) => SomeEntity -> Maybe a
+downcastEntity (SomeEntity e) = cast e
+
+entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool
+entityIs = isJust . downcastEntity @a
+
+_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
+_SomeEntity = prism' SomeEntity downcastEntity
+
+--------------------------------------------------------------------------------
+
+data GameState = GameState
+  { _entities          :: !(EntityMap SomeEntity)
+  , _revealedPositions :: !(Set Position)
+  , _characterEntityID :: !EntityID
+  , _messageHistory    :: !MessageHistory
+  , _randomGen         :: !StdGen
+  , _promptState       :: !(GamePromptState AppM)
+  }
+  deriving stock (Show)
+makeLenses ''GameState
+
+instance Eq GameState where
+  (==) = (==) `on` \gs ->
+    ( gs ^. entities
+    , gs ^. revealedPositions
+    , gs ^. characterEntityID
+    , gs ^. messageHistory
+    )
+
+--------------------------------------------------------------------------------
+
+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