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.

19 files changed, 480 insertions, 277 deletions

diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs
new file mode 100644
index 0000000000..1cdb977619
--- /dev/null
+++ b/src/Xanthous/AI/Gormlak.hs
@@ -0,0 +1,39 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.AI.Gormlak () where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (lines)
+--------------------------------------------------------------------------------
+import           Data.Coerce
+import           Control.Monad.State
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Positioned(..))
+import qualified Xanthous.Entities.Creature as Creature
+import           Xanthous.Entities.Creature (Creature)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Entities (Entity(..), Brain(..), brainVia)
+import           Xanthous.Game.State (entities, GameState)
+import           Xanthous.Data.EntityMap.Graphics (linesOfSight)
+--------------------------------------------------------------------------------
+
+stepGormlak :: MonadState GameState m => Positioned Creature -> m (Positioned Creature)
+stepGormlak (Positioned pos creature) = do
+  lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature)
+  let newPos = fromMaybe pos
+               $ fmap fst
+               . headMay <=< tailMay <=< headMay
+               . sortOn (Down . length)
+               $ lines
+  pure $ Positioned newPos creature
+
+newtype GormlakBrain = GormlakBrain Creature
+
+instance Brain GormlakBrain where
+  step = fmap coerce . stepGormlak . coerce
+--------------------------------------------------------------------------------
+
+instance Brain Creature where step = brainVia GormlakBrain
+
+instance Entity Creature where
+  blocksVision _ = False
+  description = view $ Creature.creatureType . Raw.description
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
diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs
index 19c5e17e0a..c2dbfe37ef 100644
--- a/src/Xanthous/Command.hs
+++ b/src/Xanthous/Command.hs
@@ -15,9 +15,11 @@ data Command
   | PreviousMessage
   | PickUp
   | Open
+  | Wait
 
 commandFromKey :: Key -> [Modifier] -> Maybe Command
 commandFromKey (KChar 'q') [] = Just Quit
+commandFromKey (KChar '.') [] = Just Wait
 commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
 commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
 commandFromKey (KChar ',') [] = Just PickUp
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index afba273005..ff9da6280b 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DeriveFoldable #-}
@@ -74,6 +75,7 @@ data Positioned a where
   Positioned :: Position -> a -> Positioned a
   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
   deriving anyclass (CoArbitrary, Function)
+type role Positioned representational
 
 _Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b)
 _Positioned = iso hither yon
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index 7885839d51..5b5e8a063f 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -14,6 +14,7 @@ module Xanthous.Data.EntityMap
   , insertAt
   , insertAtReturningID
   , fromEIDsAndPositioned
+  , toEIDsAndPositioned
   , atPosition
   , atPositionWithIDs
   , positions
@@ -101,6 +102,14 @@ instance Semigroup (EntityMap a) where
 instance Monoid (EntityMap a) where
   mempty = emptyEntityMap
 
+instance FunctorWithIndex EntityID EntityMap
+
+instance FoldableWithIndex EntityID EntityMap
+
+instance TraversableWithIndex EntityID EntityMap where
+  itraversed = byID . itraversed . rmap sequenceA . distrib
+  itraverse = itraverseOf itraversed
+
 emptyEntityMap :: EntityMap a
 emptyEntityMap = EntityMap mempty mempty 0
 
@@ -183,6 +192,9 @@ fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
       .~ fromMaybe 1
          (maximumOf (ifolded . asIndex) (em ^. byID))
 
+toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)]
+toEIDsAndPositioned = itoListOf $ byID . ifolded
+
 positions :: EntityMap a -> [Position]
 positions = toListOf $ byPosition . to keys . folded
 
diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs
index 9dcc02b8e8..3124c6a334 100644
--- a/src/Xanthous/Data/EntityMap/Graphics.hs
+++ b/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -3,9 +3,10 @@
 module Xanthous.Data.EntityMap.Graphics
   ( visiblePositions
   , visibleEntities
+  , linesOfSight
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude
+import Xanthous.Prelude hiding (lines)
 --------------------------------------------------------------------------------
 import Xanthous.Util (takeWhileInclusive)
 import Xanthous.Data
@@ -14,22 +15,37 @@ import Xanthous.Entities
 import Xanthous.Util.Graphics (circle, line)
 --------------------------------------------------------------------------------
 
-visiblePositions :: Position -> Word -> EntityMap SomeEntity -> Set Position
+visiblePositions :: Entity e => Position -> Word -> EntityMap e -> Set Position
 visiblePositions pos radius = setFromList . positions . visibleEntities pos radius
 
-
--- | Given a point and a radius of vision, returns a list of all entities that
--- are *visible* (eg, not blocked by an entity that obscures vision) from that
--- point
-visibleEntities :: Position -> Word -> EntityMap SomeEntity -> EntityMap SomeEntity
-visibleEntities (view _Position -> pos) visionRadius em
-  = fromEIDsAndPositioned . fold . fold $ sightAdjustedLines
+-- | Returns a list of individual lines of sight, each of which is a list of
+-- entities at positions on that line of sight
+linesOfSight
+  :: forall e. Entity e
+  => Position
+  -> Word
+  -> EntityMap e
+  -> [[(Position, Vector (EntityID, e))]]
+linesOfSight (view _Position -> pos) visionRadius em
+  = entitiesOnLines
+  <&> takeWhileInclusive (none (blocksVision . snd) . snd)
   where
-    -- I love laziness!
     radius = circle pos $ fromIntegral visionRadius
-    linesOfSight = radius <&> line pos
-    entitiesOnLines = linesOfSight <&> map getPositionedAt
-    sightAdjustedLines = entitiesOnLines <&> takeWhileInclusive (none $ blocksVision . snd)
+    lines = line pos <$> radius
+    entitiesOnLines :: [[(Position, Vector (EntityID, e))]]
+    entitiesOnLines = lines <&> map getPositionedAt
+    getPositionedAt :: (Int, Int) -> (Position, Vector (EntityID, e))
     getPositionedAt p =
       let ppos = _Position # p
-      in atPositionWithIDs ppos em
+      in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em)
+
+-- | Given a point and a radius of vision, returns a list of all entities that
+-- are *visible* (eg, not blocked by an entity that obscures vision) from that
+-- point
+visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e
+visibleEntities pos visionRadius
+  = fromEIDsAndPositioned
+  . fold
+  . map (\(p, es) -> over _2 (Positioned p) <$> es)
+  . fold
+  . linesOfSight pos visionRadius
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
index 66a583f6b3..15080b3221 100644
--- a/src/Xanthous/Entities.hs
+++ b/src/Xanthous/Entities.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE RoleAnnotations       #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities
   ( Draw(..)
@@ -19,72 +20,27 @@ module Xanthous.Entities
 
   , EntityChar(..)
   , HasChar(..)
+
+  , Brain(..)
+  , Brainless(..)
+  , brainVia
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude hiding ((.=))
 --------------------------------------------------------------------------------
 import           Brick
-import           Data.Typeable
 import qualified Graphics.Vty.Attributes as Vty
 import qualified Graphics.Vty.Image as Vty
 import           Data.Aeson
+import           Data.Typeable (Proxy(..))
 import           Data.Generics.Product.Fields
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 --------------------------------------------------------------------------------
-import           Xanthous.Data
 import           Xanthous.Orphans ()
+import           Xanthous.Game.State
 --------------------------------------------------------------------------------
 
-class (Show a, Eq a, Draw a) => Entity a where
-  blocksVision :: a -> Bool
-  description :: a -> Text
-
-instance Entity a => Entity (Positioned a) where
-  blocksVision (Positioned _ ent) = blocksVision ent
-  description (Positioned _ ent) = description ent
-
---------------------------------------------------------------------------------
-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 Entity SomeEntity where
-  blocksVision (SomeEntity ent) = blocksVision ent
-  description (SomeEntity ent) = description ent
-
-downcastEntity :: (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
-
---------------------------------------------------------------------------------
-
-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
-
 newtype DrawCharacter (char :: Symbol) (a :: Type) where
   DrawCharacter :: a -> DrawCharacter char a
 
diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs
index 2d1890f787..8ba6447933 100644
--- a/src/Xanthous/Entities/Arbitrary.hs
+++ b/src/Xanthous/Entities/Arbitrary.hs
@@ -12,6 +12,7 @@ import           Xanthous.Entities.Character
 import           Xanthous.Entities.Item
 import           Xanthous.Entities.Creature
 import           Xanthous.Entities.Environment
+import           Xanthous.AI.Gormlak ()
 --------------------------------------------------------------------------------
 
 instance Arbitrary SomeEntity where
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 9423f2dc96..1c7d1bbe82 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -41,6 +41,9 @@ instance Draw Character where
       rloc = Location (negate scrollOffset, negate scrollOffset)
       rreg = (2 * scrollOffset, 2 * scrollOffset)
 
+-- the character does not (yet) have a mind of its own
+instance Brain Character where step = brainVia Brainless
+
 instance Entity Character where
   blocksVision _ = False
   description _ = "yourself"
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 5151f78b30..accf0c42e2 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -8,6 +8,7 @@ module Xanthous.Entities.Creature
   , newWithType
   , damage
   , isDead
+  , visionRadius
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -17,8 +18,7 @@ import           Data.Aeson.Generic.DerivingVia
 import           Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes hiding (Creature, description)
-import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
+import           Xanthous.Entities (Draw(..), DrawRawChar(..))
 --------------------------------------------------------------------------------
 
 data Creature = Creature
@@ -35,9 +35,7 @@ makeLenses ''Creature
 instance Arbitrary Creature where
   arbitrary = genericArbitrary
 
-instance Entity Creature where
-  blocksVision _ = False
-  description = view $ creatureType . Raw.description
+--------------------------------------------------------------------------------
 
 newWithType :: CreatureType -> Creature
 newWithType _creatureType =
@@ -52,3 +50,6 @@ damage amount = hitpoints %~ \hp ->
 
 isDead :: Creature -> Bool
 isDead = views hitpoints (== 0)
+
+visionRadius :: Creature -> Word
+visionRadius = const 12 -- TODO
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 4ef67a577d..e8190cd42a 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -13,7 +13,15 @@ import Brick (str)
 import Brick.Widgets.Border.Style (unicode)
 import Brick.Types (Edges(..))
 --------------------------------------------------------------------------------
-import Xanthous.Entities (Draw(..), entityIs, Entity(..), SomeEntity)
+import Xanthous.Entities
+       ( Draw(..)
+       , entityIs
+       , Entity(..)
+       , SomeEntity
+       , Brain(..)
+       , Brainless(..)
+       , brainVia
+       )
 import Xanthous.Entities.Draw.Util
 import Xanthous.Data
 --------------------------------------------------------------------------------
@@ -22,6 +30,9 @@ data Wall = Wall
   deriving stock (Show, Eq, Ord, Generic, Enum)
   deriving anyclass (CoArbitrary, Function)
 
+-- deriving via Brainless Wall instance Brain Wall
+instance Brain Wall where step = brainVia Brainless
+
 instance Entity Wall where
   blocksVision _ = True
   description _ = "a wall"
@@ -64,6 +75,9 @@ instance Draw Door where
       horizDoor = '␣'
       vertDoor = '['
 
+-- deriving via Brainless Door instance Brain Door
+instance Brain Door where step = brainVia Brainless
+
 instance Entity Door where
   blocksVision = not . view open
   description _ = "a door"
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
index 6b50f50ad8..832f0d4d62 100644
--- a/src/Xanthous/Entities/Item.hs
+++ b/src/Xanthous/Entities/Item.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities.Item
   ( Item(..)
@@ -13,7 +14,14 @@ import           Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes hiding (Item, description)
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
+import           Xanthous.Entities
+                 ( Draw(..)
+                 , Entity(..)
+                 , DrawRawChar(..)
+                 , Brain(..)
+                 , Brainless(..)
+                 , brainVia
+                 )
 --------------------------------------------------------------------------------
 
 data Item = Item
@@ -27,6 +35,9 @@ data Item = Item
                        Item
 makeLenses ''Item
 
+-- deriving via (Brainless Item) instance Brain Item
+instance Brain Item where step = brainVia Brainless
+
 instance Arbitrary Item where
   arbitrary = Item <$> arbitrary
 
diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs
index e1bb429a0f..9b7d63c6c4 100644
--- a/src/Xanthous/Entities/Raws.hs
+++ b/src/Xanthous/Entities/Raws.hs
@@ -17,6 +17,7 @@ import           Xanthous.Entities.RawTypes
 import           Xanthous.Entities
 import qualified Xanthous.Entities.Creature as Creature
 import qualified Xanthous.Entities.Item as Item
+import           Xanthous.AI.Gormlak ()
 --------------------------------------------------------------------------------
 rawRaws :: [(FilePath, ByteString)]
 rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 68bd9e0438..278e3d8ff4 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 ()
diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
new file mode 100644
index 0000000000..5ab2301e70
--- /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 0000000000..91ff5c137d
--- /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 0000000000..9b81abe352
--- /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
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index 4e3e58607c..3e567ee8fa 100644
--- a/src/Xanthous/Monad.hs
+++ b/src/Xanthous/Monad.hs
@@ -1,5 +1,6 @@
 module Xanthous.Monad
   ( AppT(..)
+  , AppM
   , runAppT
   , continue
   , halt
@@ -14,7 +15,7 @@ import qualified Brick
 import Brick (EventM, Next)
 import Data.Aeson
 
-import Xanthous.Game
+import Xanthous.Game.State
 import Xanthous.Messages (message)
 
 runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs
index 439f9e8ffa..d90cf5b03d 100644
--- a/src/Xanthous/Util.hs
+++ b/src/Xanthous/Util.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 
 module Xanthous.Util
   ( EqEqProp(..)