about summary refs log tree commit diff
path: root/src/Xanthous
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous')
-rw-r--r--src/Xanthous/AI/Gormlak.hs39
-rw-r--r--src/Xanthous/App.hs50
-rw-r--r--src/Xanthous/Command.hs2
-rw-r--r--src/Xanthous/Data.hs2
-rw-r--r--src/Xanthous/Data/EntityMap.hs12
-rw-r--r--src/Xanthous/Data/EntityMap/Graphics.hs44
-rw-r--r--src/Xanthous/Entities.hs66
-rw-r--r--src/Xanthous/Entities/Arbitrary.hs1
-rw-r--r--src/Xanthous/Entities/Character.hs3
-rw-r--r--src/Xanthous/Entities/Creature.hs11
-rw-r--r--src/Xanthous/Entities/Environment.hs16
-rw-r--r--src/Xanthous/Entities/Item.hs13
-rw-r--r--src/Xanthous/Entities/Raws.hs1
-rw-r--r--src/Xanthous/Game.hs194
-rw-r--r--src/Xanthous/Game/Arbitrary.hs27
-rw-r--r--src/Xanthous/Game/Lenses.hs72
-rw-r--r--src/Xanthous/Game/State.hs200
-rw-r--r--src/Xanthous/Monad.hs3
-rw-r--r--src/Xanthous/Util.hs1
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 000000000000..1cdb977619f3
--- /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 8353df437b41..8d9ea54f0f7c 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 19c5e17e0a64..c2dbfe37efa6 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 afba273005f8..ff9da6280bfb 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 7885839d51b0..5b5e8a063f2c 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 9dcc02b8e88f..3124c6a334cc 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 66a583f6b3fd..15080b3221e0 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 2d1890f787a3..8ba6447933b2 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 9423f2dc96b0..1c7d1bbe82a6 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 5151f78b3061..accf0c42e2ad 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 4ef67a577dbb..e8190cd42a92 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 6b50f50ad83c..832f0d4d62b3 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 e1bb429a0f0d..9b7d63c6c4c5 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 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 ()
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
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index 4e3e58607ce8..3e567ee8fa5e 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 439f9e8ffaef..d90cf5b03d3d 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(..)
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-03T03·17+0000