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/App.hs235
-rw-r--r--src/Xanthous/App/Autocommands.hs44
-rw-r--r--src/Xanthous/App/Common.hs67
-rw-r--r--src/Xanthous/App/Prompt.hs161
-rw-r--r--src/Xanthous/App/Time.hs40
-rw-r--r--src/Xanthous/Command.hs6
-rw-r--r--src/Xanthous/Data.hs2
-rw-r--r--src/Xanthous/Data/App.hs (renamed from src/Xanthous/Resource.hs)16
-rw-r--r--src/Xanthous/Game/Arbitrary.hs2
-rw-r--r--src/Xanthous/Game/Draw.hs24
-rw-r--r--src/Xanthous/Game/Env.hs19
-rw-r--r--src/Xanthous/Game/Lenses.hs1
-rw-r--r--src/Xanthous/Game/Prompt.hs17
-rw-r--r--src/Xanthous/Game/State.hs94
-rw-r--r--src/Xanthous/Monad.hs29
15 files changed, 506 insertions, 251 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index f7013076d594..672aa93f6b32 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -9,11 +9,9 @@ module Xanthous.App
 import           Xanthous.Prelude
 import           Brick hiding (App, halt, continue, raw)
 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, gets, MonadState)
-import           Control.Monad.Random (MonadRandom)
+import           Graphics.Vty.Input.Events (Event(EvKey))
+import           Control.Monad.State (get, gets)
 import           Control.Monad.State.Class (modify)
 import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
@@ -21,8 +19,11 @@ import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Vector as V
 import           System.Exit
 import           System.Directory (doesFileExist)
-import           GHC.TypeLits (TypeError, ErrorMessage(..))
 --------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.App.Time
+import           Xanthous.App.Prompt
+import           Xanthous.App.Autocommands
 import           Xanthous.Command
 import           Xanthous.Data
                  ( move
@@ -30,20 +31,18 @@ import           Xanthous.Data
                  , positioned
                  , position
                  , Position
-                 , Ticks
                  , (|*|)
                  )
-import           Xanthous.Data.EntityMap (EntityMap)
+import           Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.Levels (prevLevel, nextLevel)
 import qualified Xanthous.Data.Levels as Levels
 import           Xanthous.Data.Entities (blocksObject)
 import           Xanthous.Game
 import           Xanthous.Game.State
+import           Xanthous.Game.Env
 import           Xanthous.Game.Draw (drawGame)
 import           Xanthous.Game.Prompt
-import           Xanthous.Monad
-import           Xanthous.Resource (Name, Panel(..))
 import qualified Xanthous.Messages as Messages
 import           Xanthous.Random
 import           Xanthous.Util (removeVectorIndex)
@@ -66,24 +65,24 @@ import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
 import qualified Xanthous.Generators.Dungeon as Dungeon
 --------------------------------------------------------------------------------
 
-type App = Brick.App GameState () Name
+type App = Brick.App GameState AppEvent ResourceName
 
 data RunType = NewGame | LoadGame
   deriving stock (Eq)
 
-makeApp :: RunType -> IO App
-makeApp rt = pure $ Brick.App
+makeApp :: GameEnv -> RunType -> IO App
+makeApp env rt = pure $ Brick.App
   { appDraw = drawGame
   , appChooseCursor = const headMay
-  , appHandleEvent = \game event -> runAppM (handleEvent event) game
+  , appHandleEvent = \game event -> runAppM (handleEvent event) env game
   , appStartEvent = case rt of
-      NewGame -> runAppM $ startEvent >> get
+      NewGame -> runAppM (startEvent >> get) env
       LoadGame -> pure
   , appAttrMap = const $ attrMap defAttr []
   }
 
-runAppM :: AppM a -> GameState -> EventM Name a
-runAppM appm = fmap fst . runAppT appm
+runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a
+runAppM appm ge = fmap fst . runAppT appm ge
 
 startEvent :: AppM ()
 startEvent = do
@@ -104,39 +103,20 @@ initLevel = do
 
 --------------------------------------------------------------------------------
 
-stepGameBy :: Ticks -> AppM ()
-stepGameBy ticks = do
-  ents <- uses entities EntityMap.toEIDsAndPositioned
-  for_ ents $ \(eid, pEntity) -> do
-    pEntity' <- step ticks pEntity
-    entities . ix eid .= pEntity'
-
-  modify updateCharacterVision
-
-  whenM (uses character isDead)
-    . prompt_ @'Continue ["dead"] Uncancellable
-    . const . lift . liftIO
-    $ exitSuccess
-
-ticksPerTurn :: Ticks
-ticksPerTurn = 100
-
-stepGame :: AppM ()
-stepGame = stepGameBy ticksPerTurn
-
---------------------------------------------------------------------------------
-
-handleEvent :: BrickEvent Name () -> AppM (Next GameState)
+handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
 handleEvent ev = use promptState >>= \case
   NoPrompt -> handleNoPromptEvent ev
   WaitingPrompt msg pr -> handlePromptEvent msg pr ev
 
 
-handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
+handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState)
 handleNoPromptEvent (VtyEvent (EvKey k mods))
   | Just command <- commandFromKey k mods
   = do messageHistory %= nextTurn
        handleCommand command
+handleNoPromptEvent (AppEvent AutoContinue) = do
+  preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep
+  continue
 handleNoPromptEvent _ = continue
 
 handleCommand :: Command -> AppM (Next GameState)
@@ -347,6 +327,10 @@ handleCommand GoDown = do
 
   continue
 
+handleCommand (StartAutoMove dir) = do
+  runAutocommand $ AutoMove dir
+  continue
+
 --
 
 handleCommand ToggleRevealAll = do
@@ -355,177 +339,6 @@ handleCommand ToggleRevealAll = do
   continue
 
 --------------------------------------------------------------------------------
-
-handlePromptEvent
-  :: Text -- ^ Prompt message
-  -> Prompt AppM
-  -> BrickEvent Name ()
-  -> AppM (Next GameState)
-
-handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
-  = clearPrompt >> continue
-handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
-  = clearPrompt >> submitPrompt pr >> continue
-
-handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
-  = clearPrompt >> submitPrompt pr >> continue
-
-handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
-  = clearPrompt >> continue
-
-handlePromptEvent
-  msg
-  (Prompt c SStringPrompt (StringPromptState edit) pri cb)
-  (VtyEvent ev)
-  = do
-    edit' <- lift $ handleEditorEvent ev edit
-    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
-    promptState .= WaitingPrompt msg prompt'
-    continue
-
-handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
-  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
-  = clearPrompt >> cb (DirectionResult dir) >> continue
-handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
-
-handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
-  | Just (MenuOption _ res) <- items' ^. at chr
-  = clearPrompt >> cb (MenuResult res) >> continue
-  | otherwise
-  = continue
-
-handlePromptEvent
-  msg
-  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
-  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
-  = let pos' = move dir pos
-        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
-    in promptState .= WaitingPrompt msg prompt'
-       >> continue
-handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
-
-handlePromptEvent
-  _
-  (Prompt Cancellable _ _ _ _)
-  (VtyEvent (EvKey (KChar 'q') []))
-  = clearPrompt >> continue
-handlePromptEvent _ _ _ = continue
-
-clearPrompt :: AppM ()
-clearPrompt = promptState .= NoPrompt
-
-class NotMenu (pt :: PromptType)
-instance NotMenu 'StringPrompt
-instance NotMenu 'Confirm
-instance NotMenu 'DirectionPrompt
-instance NotMenu 'PointOnMap
-instance NotMenu 'Continue
-instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
-                    ':$$: 'Text "Use `menu` or `menu_` instead")
-         => NotMenu ('Menu a)
-
-prompt
-  :: forall (pt :: PromptType) (params :: Type).
-    (ToJSON params, SingPromptType pt, NotMenu pt)
-  => [Text]                     -- ^ Message key
-  -> params                     -- ^ Message params
-  -> PromptCancellable
-  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
-  -> AppM ()
-prompt msgPath params cancellable cb = do
-  let pt = singPromptType @pt
-  msg <- Messages.message msgPath params
-  p <- case pt of
-    SPointOnMap -> do
-      charPos <- use characterPosition
-      pure $ mkPointOnMapPrompt cancellable charPos cb
-    SStringPrompt -> pure $ mkPrompt cancellable pt cb
-    SConfirm -> pure $ mkPrompt cancellable pt cb
-    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
-    SContinue -> pure $ mkPrompt cancellable pt cb
-    SMenu -> error "unreachable"
-  promptState .= WaitingPrompt msg p
-
-prompt_
-  :: forall (pt :: PromptType).
-    (SingPromptType pt, NotMenu pt)
-  => [Text] -- ^ Message key
-  -> PromptCancellable
-  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
-  -> AppM ()
-prompt_ msg = prompt msg $ object []
-
-confirm
-  :: ToJSON params
-  => [Text] -- ^ Message key
-  -> params
-  -> AppM ()
-  -> AppM ()
-confirm msgPath params
-  = prompt @'Confirm msgPath params Cancellable . const
-
-confirm_ :: [Text] -> AppM () -> AppM ()
-confirm_ msgPath = confirm msgPath $ object []
-
-menu :: forall (a :: Type) (params :: Type).
-       (ToJSON params)
-     => [Text]                            -- ^ Message key
-     -> params                            -- ^ Message params
-     -> PromptCancellable
-     -> Map Char (MenuOption a)           -- ^ Menu items
-     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
-     -> AppM ()
-menu msgPath params cancellable items' cb = do
-  msg <- Messages.message msgPath params
-  let p = mkMenu cancellable items' cb
-  promptState .= WaitingPrompt msg p
-
-menu_ :: forall (a :: Type).
-        [Text]                            -- ^ Message key
-      -> PromptCancellable
-      -> Map Char (MenuOption a)           -- ^ Menu items
-      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
-      -> AppM ()
-menu_ msgPath = menu msgPath $ object []
-
---------------------------------------------------------------------------------
-
-entitiesAtPositionWithType
-  :: forall a. (Entity a, Typeable a)
-  => Position
-  -> EntityMap SomeEntity
-  -> [(EntityMap.EntityID, a)]
-entitiesAtPositionWithType pos em =
-  let someEnts = EntityMap.atPositionWithIDs pos em
-  in flip foldMap someEnts $ \(eid, view positioned -> se) ->
-    case downcastEntity @a se of
-      Just e  -> [(eid, e)]
-      Nothing -> []
-
-describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m ()
-describeEntitiesAt pos =
-  use ( entities
-      . EntityMap.atPosition pos
-      . to (filter (not . entityIs @Character))
-      ) >>= \case
-        Empty -> pure ()
-        ents  -> describeEntities ents
-
-describeEntities
-  :: ( Entity entity
-    , MonadRandom m
-    , MonadState GameState m
-    , MonoFoldable (f Text)
-    , Functor f
-    , Element (f Text) ~ Text
-    )
-  => f entity
-  -> m ()
-describeEntities ents =
-  let descriptions = description <$> ents
-  in say ["entities", "description"]
-     $ object ["entityDescriptions" A..= toSentence descriptions]
-
 attackAt :: Position -> AppM ()
 attackAt pos =
   uses entities (entitiesAtPositionWithType @Creature pos) >>= \case
diff --git a/src/Xanthous/App/Autocommands.hs b/src/Xanthous/App/Autocommands.hs
new file mode 100644
index 000000000000..e8d94ce741fd
--- /dev/null
+++ b/src/Xanthous/App/Autocommands.hs
@@ -0,0 +1,44 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Autocommands
+  ( runAutocommand
+  , autoStep
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Control.Concurrent (threadDelay)
+--------------------------------------------------------------------------------
+import Xanthous.App.Common
+import Xanthous.App.Time
+import Xanthous.Data
+import Xanthous.Data.App
+import Xanthous.Entities.Character (speed)
+import Xanthous.Game.State
+--------------------------------------------------------------------------------
+
+autoStep :: Autocommand -> AppM ()
+autoStep (AutoMove dir) = do
+  newPos <- uses characterPosition $ move dir
+  collisionAt newPos >>= \case
+    Nothing -> do
+      characterPosition .= newPos
+      stepGameBy =<< uses (character . speed) (|*| 1)
+      describeEntitiesAt newPos
+    Just _ -> cancelAutocommand
+
+--------------------------------------------------------------------------------
+
+autocommandIntervalμs :: Int
+autocommandIntervalμs = 1000 * 50 -- 50 ms
+
+runAutocommand :: Autocommand -> AppM ()
+runAutocommand ac = do
+  env <- ask
+  tid <- liftIO . async $ runReaderT go env
+  autocommand .= ActiveAutocommand ac tid
+  where
+    go = everyμs autocommandIntervalμs $ sendEvent AutoContinue
+
+-- | Perform 'act' every μs microseconds forever
+everyμs :: MonadIO m => Int -> m () -> m ()
+everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act
diff --git a/src/Xanthous/App/Common.hs b/src/Xanthous/App/Common.hs
new file mode 100644
index 000000000000..69ba6f0e0596
--- /dev/null
+++ b/src/Xanthous/App/Common.hs
@@ -0,0 +1,67 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Common
+  ( describeEntities
+  , describeEntitiesAt
+  , entitiesAtPositionWithType
+
+    -- * Re-exports
+  , MonadState
+  , MonadRandom
+  , EntityMap
+  , module Xanthous.Game.Lenses
+  , module Xanthous.Monad
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (object)
+import qualified Data.Aeson as A
+import           Control.Monad.State (MonadState)
+import           Control.Monad.Random (MonadRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Position, positioned)
+import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game
+import           Xanthous.Game.Lenses
+import           Xanthous.Game.State
+import           Xanthous.Monad
+import           Xanthous.Entities.Character (Character)
+import           Xanthous.Util.Inflection (toSentence)
+--------------------------------------------------------------------------------
+
+entitiesAtPositionWithType
+  :: forall a. (Entity a, Typeable a)
+  => Position
+  -> EntityMap SomeEntity
+  -> [(EntityMap.EntityID, a)]
+entitiesAtPositionWithType pos em =
+  let someEnts = EntityMap.atPositionWithIDs pos em
+  in flip foldMap someEnts $ \(eid, view positioned -> se) ->
+    case downcastEntity @a se of
+      Just e  -> [(eid, e)]
+      Nothing -> []
+
+describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m ()
+describeEntitiesAt pos =
+  use ( entities
+      . EntityMap.atPosition pos
+      . to (filter (not . entityIs @Character))
+      ) >>= \case
+        Empty -> pure ()
+        ents  -> describeEntities ents
+
+describeEntities
+  :: ( Entity entity
+    , MonadRandom m
+    , MonadState GameState m
+    , MonoFoldable (f Text)
+    , Functor f
+    , Element (f Text) ~ Text
+    )
+  => f entity
+  -> m ()
+describeEntities ents =
+  let descriptions = description <$> ents
+  in say ["entities", "description"]
+     $ object ["entityDescriptions" A..= toSentence descriptions]
diff --git a/src/Xanthous/App/Prompt.hs b/src/Xanthous/App/Prompt.hs
new file mode 100644
index 000000000000..6704a601da90
--- /dev/null
+++ b/src/Xanthous/App/Prompt.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+module Xanthous.App.Prompt
+  ( handlePromptEvent
+  , clearPrompt
+  , prompt
+  , prompt_
+  , confirm_
+  , confirm
+  , menu
+  , menu_
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick (BrickEvent(..), Next)
+import           Brick.Widgets.Edit (handleEditorEvent)
+import           Data.Aeson (ToJSON, object)
+import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
+import           GHC.TypeLits (TypeError, ErrorMessage(..))
+--------------------------------------------------------------------------------
+import           Xanthous.App.Common
+import           Xanthous.Data (move)
+import           Xanthous.Command (directionFromChar)
+import           Xanthous.Data.App (ResourceName, AppEvent)
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.State
+import qualified Xanthous.Messages as Messages
+--------------------------------------------------------------------------------
+
+handlePromptEvent
+  :: Text -- ^ Prompt message
+  -> Prompt AppM
+  -> BrickEvent ResourceName AppEvent
+  -> AppM (Next GameState)
+
+handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
+  = clearPrompt >> continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
+  = clearPrompt >> submitPrompt pr >> continue
+
+handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
+  = clearPrompt >> continue
+
+handlePromptEvent
+  msg
+  (Prompt c SStringPrompt (StringPromptState edit) pri cb)
+  (VtyEvent ev)
+  = do
+    edit' <- lift $ handleEditorEvent ev edit
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
+    promptState .= WaitingPrompt msg prompt'
+    continue
+
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = clearPrompt >> cb (DirectionResult dir) >> continue
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
+
+handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
+  | Just (MenuOption _ res) <- items' ^. at chr
+  = clearPrompt >> cb (MenuResult res) >> continue
+  | otherwise
+  = continue
+
+handlePromptEvent
+  msg
+  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = let pos' = move dir pos
+        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
+    in promptState .= WaitingPrompt msg prompt'
+       >> continue
+handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
+
+handlePromptEvent
+  _
+  (Prompt Cancellable _ _ _ _)
+  (VtyEvent (EvKey (KChar 'q') []))
+  = clearPrompt >> continue
+handlePromptEvent _ _ _ = continue
+
+clearPrompt :: AppM ()
+clearPrompt = promptState .= NoPrompt
+
+class NotMenu (pt :: PromptType)
+instance NotMenu 'StringPrompt
+instance NotMenu 'Confirm
+instance NotMenu 'DirectionPrompt
+instance NotMenu 'PointOnMap
+instance NotMenu 'Continue
+instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
+                    ':$$: 'Text "Use `menu` or `menu_` instead")
+         => NotMenu ('Menu a)
+
+prompt
+  :: forall (pt :: PromptType) (params :: Type).
+    (ToJSON params, SingPromptType pt, NotMenu pt)
+  => [Text]                     -- ^ Message key
+  -> params                     -- ^ Message params
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt msgPath params cancellable cb = do
+  let pt = singPromptType @pt
+  msg <- Messages.message msgPath params
+  p <- case pt of
+    SPointOnMap -> do
+      charPos <- use characterPosition
+      pure $ mkPointOnMapPrompt cancellable charPos cb
+    SStringPrompt -> pure $ mkPrompt cancellable pt cb
+    SConfirm -> pure $ mkPrompt cancellable pt cb
+    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
+    SContinue -> pure $ mkPrompt cancellable pt cb
+    SMenu -> error "unreachable"
+  promptState .= WaitingPrompt msg p
+
+prompt_
+  :: forall (pt :: PromptType).
+    (SingPromptType pt, NotMenu pt)
+  => [Text] -- ^ Message key
+  -> PromptCancellable
+  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+prompt_ msg = prompt msg $ object []
+
+confirm
+  :: ToJSON params
+  => [Text] -- ^ Message key
+  -> params
+  -> AppM ()
+  -> AppM ()
+confirm msgPath params
+  = prompt @'Confirm msgPath params Cancellable . const
+
+confirm_ :: [Text] -> AppM () -> AppM ()
+confirm_ msgPath = confirm msgPath $ object []
+
+menu :: forall (a :: Type) (params :: Type).
+       (ToJSON params)
+     => [Text]                            -- ^ Message key
+     -> params                            -- ^ Message params
+     -> PromptCancellable
+     -> Map Char (MenuOption a)           -- ^ Menu items
+     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+     -> AppM ()
+menu msgPath params cancellable items' cb = do
+  msg <- Messages.message msgPath params
+  let p = mkMenu cancellable items' cb
+  promptState .= WaitingPrompt msg p
+
+menu_ :: forall (a :: Type).
+        [Text]                            -- ^ Message key
+      -> PromptCancellable
+      -> Map Char (MenuOption a)           -- ^ Menu items
+      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+      -> AppM ()
+menu_ msgPath = menu msgPath $ object []
diff --git a/src/Xanthous/App/Time.hs b/src/Xanthous/App/Time.hs
new file mode 100644
index 000000000000..b17348f3853e
--- /dev/null
+++ b/src/Xanthous/App/Time.hs
@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+module Xanthous.App.Time
+  ( stepGame
+  , stepGameBy
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           System.Exit
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Ticks)
+import           Xanthous.App.Prompt
+import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Entities.Character (isDead)
+import           Xanthous.Game.State
+import           Xanthous.Game.Prompt
+import           Xanthous.Game.Lenses
+import           Control.Monad.State (modify)
+--------------------------------------------------------------------------------
+
+
+stepGameBy :: Ticks -> AppM ()
+stepGameBy ticks = do
+  ents <- uses entities EntityMap.toEIDsAndPositioned
+  for_ ents $ \(eid, pEntity) -> do
+    pEntity' <- step ticks pEntity
+    entities . ix eid .= pEntity'
+
+  modify updateCharacterVision
+
+  whenM (uses character isDead)
+    . prompt_ @'Continue ["dead"] Uncancellable
+    . const . lift . liftIO
+    $ exitSuccess
+
+ticksPerTurn :: Ticks
+ticksPerTurn = 100
+
+stepGame :: AppM ()
+stepGame = stepGameBy ticksPerTurn
diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs
index 2e7e6f1ff566..37025dd37ad2 100644
--- a/src/Xanthous/Command.hs
+++ b/src/Xanthous/Command.hs
@@ -4,6 +4,7 @@ module Xanthous.Command where
 import Xanthous.Prelude hiding (Left, Right, Down)
 --------------------------------------------------------------------------------
 import Graphics.Vty.Input (Key(..), Modifier(..))
+import qualified Data.Char as Char
 --------------------------------------------------------------------------------
 import Xanthous.Data (Direction(..))
 --------------------------------------------------------------------------------
@@ -11,6 +12,7 @@ import Xanthous.Data (Direction(..))
 data Command
   = Quit
   | Move Direction
+  | StartAutoMove Direction
   | PreviousMessage
   | PickUp
   | Drop
@@ -33,6 +35,10 @@ commandFromKey :: Key -> [Modifier] -> Maybe Command
 commandFromKey (KChar 'q') [] = Just Quit
 commandFromKey (KChar '.') [] = Just Wait
 commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
+commandFromKey (KChar c) []
+  | Char.isUpper c
+  , Just dir <- directionFromChar $ Char.toLower c
+  = Just $ StartAutoMove dir
 commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
 commandFromKey (KChar ',') [] = Just PickUp
 commandFromKey (KChar 'd') [] = Just Drop
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index ec40b8721122..3cb74bdca9fd 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -268,7 +268,7 @@ data Direction where
   DownRight :: Direction
   Here      :: Direction
   deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (CoArbitrary, Function, NFData)
+  deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable)
   deriving Arbitrary via GenericArbitrary Direction
 
 instance Opposite Direction where
diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Data/App.hs
index cc2fc97a1464..0361d2a59ed5 100644
--- a/src/Xanthous/Resource.hs
+++ b/src/Xanthous/Data/App.hs
@@ -1,7 +1,8 @@
 --------------------------------------------------------------------------------
-module Xanthous.Resource
+module Xanthous.Data.App
   ( Panel(..)
-  , Name(..)
+  , ResourceName(..)
+  , AppEvent(..)
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
@@ -20,7 +21,7 @@ data Panel
   deriving Arbitrary via GenericArbitrary Panel
 
 
-data Name
+data ResourceName
   = MapViewport -- ^ The main viewport where we display the game content
   | Character   -- ^ The character
   | MessageBox  -- ^ The box where we display messages to the user
@@ -28,4 +29,11 @@ data Name
   | Panel Panel -- ^ A panel in the game
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
-  deriving Arbitrary via GenericArbitrary Name
+  deriving Arbitrary via GenericArbitrary ResourceName
+
+data AppEvent
+  = AutoContinue -- ^ Continue whatever autocommand has been requested by the
+                 --   user
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary AppEvent
diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
index 886a8c03d786..a1eb789a33c9 100644
--- a/src/Xanthous/Game/Arbitrary.hs
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -40,6 +40,7 @@ instance Arbitrary GameState where
     let _promptState = NoPrompt -- TODO
     _activePanel <- arbitrary
     _debugState <- arbitrary
+    let _autocommand = NoAutocommand
     pure $ GameState {..}
 
 
@@ -47,4 +48,3 @@ instance CoArbitrary GameLevel
 instance Function GameLevel
 instance CoArbitrary GameState
 instance Function GameState
-deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a)
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 659081e5731b..b855ce88e46b 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -10,6 +10,8 @@ import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Edit
 --------------------------------------------------------------------------------
 import           Xanthous.Data
+import           Xanthous.Data.App (ResourceName, Panel(..))
+import qualified Xanthous.Data.App as Resource
 import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game.State
@@ -29,12 +31,10 @@ import           Xanthous.Game
                  , debugState, allRevealed
                  )
 import           Xanthous.Game.Prompt
-import           Xanthous.Resource (Name, Panel(..))
-import qualified Xanthous.Resource as Resource
 import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
-cursorPosition :: GameState -> Widget Name -> Widget Name
+cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
 cursorPosition game
   | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
     <- game ^. promptState
@@ -42,10 +42,10 @@ cursorPosition game
   | otherwise
   = showCursor Resource.Character (game ^. characterPosition . loc)
 
-drawMessages :: MessageHistory -> Widget Name
+drawMessages :: MessageHistory -> Widget ResourceName
 drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract
 
-drawPromptState :: GamePromptState m -> Widget Name
+drawPromptState :: GamePromptState m -> Widget ResourceName
 drawPromptState NoPrompt = emptyWidget
 drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
   case (pt, ps, pri) of
@@ -67,7 +67,7 @@ drawEntities
   -> (Position -> Bool)
     -- ^ Has a given position *ever* been seen by the character?
   -> EntityMap SomeEntity -- ^ all entities
-  -> Widget Name
+  -> Widget ResourceName
 drawEntities isVisible isRevealed allEnts
   = vBox rows
   where
@@ -90,7 +90,7 @@ drawEntities isVisible isRevealed allEnts
            $ maximumBy (compare `on` drawPriority)
            <$> fromNullable ents
 
-drawMap :: GameState -> Widget Name
+drawMap :: GameState -> Widget ResourceName
 drawMap game
   = viewport Resource.MapViewport Both
   . cursorPosition game
@@ -106,7 +106,7 @@ drawMap game
 bullet :: Char
 bullet = '•'
 
-drawInventoryPanel :: GameState -> Widget Name
+drawInventoryPanel :: GameState -> Widget ResourceName
 drawInventoryPanel game
   =   drawWielded  (game ^. character . inventory . wielded)
   <=> drawBackpack (game ^. character . inventory . backpack)
@@ -122,7 +122,7 @@ drawInventoryPanel game
               )
       <=> txt " "
 
-    drawBackpack :: Vector Item -> Widget Name
+    drawBackpack :: Vector Item -> Widget ResourceName
     drawBackpack Empty = txtWrap "Your backpack is empty right now."
     drawBackpack backpackItems
       = txtWrap ( "You are currently carrying the following items in your "
@@ -134,7 +134,7 @@ drawInventoryPanel game
               backpackItems)
 
 
-drawPanel :: GameState -> Panel -> Widget Name
+drawPanel :: GameState -> Panel -> Widget ResourceName
 drawPanel game panel
   = border
   . hLimit 35
@@ -143,7 +143,7 @@ drawPanel game panel
       InventoryPanel -> drawInventoryPanel
   $ game
 
-drawCharacterInfo :: Character -> Widget Name
+drawCharacterInfo :: Character -> Widget ResourceName
 drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
   where
     charName | Just n <- ch ^. characterName
@@ -154,7 +154,7 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
         = txt "Hitpoints: "
       <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
 
-drawGame :: GameState -> [Widget Name]
+drawGame :: GameState -> [Widget ResourceName]
 drawGame game
   = pure
   . withBorderStyle unicode
diff --git a/src/Xanthous/Game/Env.hs b/src/Xanthous/Game/Env.hs
new file mode 100644
index 000000000000..6e10d0f73581
--- /dev/null
+++ b/src/Xanthous/Game/Env.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Env
+  ( GameEnv(..)
+  , eventChan
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.BChan (BChan)
+import Xanthous.Data.App (AppEvent)
+--------------------------------------------------------------------------------
+
+data GameEnv = GameEnv
+  { _eventChan :: BChan AppEvent
+  }
+  deriving stock (Generic)
+makeLenses ''GameEnv
+{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-}
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index 017d53652c4f..48b7235d2263 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -56,6 +56,7 @@ initialStateFromSeed seed =
       _debugState = DebugState
         { _allRevealed = False
         }
+      _autocommand = NoAutocommand
   in GameState {..}
 
 
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index e89cf5bee3d0..30b5fe7545e0 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -30,8 +30,8 @@ import           Test.QuickCheck.Arbitrary.Generic
 --------------------------------------------------------------------------------
 import           Xanthous.Util (smallestNotIn)
 import           Xanthous.Data (Direction, Position)
-import           Xanthous.Resource (Name)
-import qualified Xanthous.Resource as Resource
+import           Xanthous.Data.App (ResourceName)
+import qualified Xanthous.Data.App as Resource
 --------------------------------------------------------------------------------
 
 data PromptType where
@@ -120,12 +120,13 @@ instance Arbitrary (PromptResult 'Continue) where
 --------------------------------------------------------------------------------
 
 data PromptState pt where
-  StringPromptState     :: Editor Text Name -> PromptState 'StringPrompt
-  DirectionPromptState  ::                    PromptState 'DirectionPrompt
-  ContinuePromptState   ::                    PromptState 'Continue
-  ConfirmPromptState    ::                    PromptState 'Confirm
-  MenuPromptState       :: forall a.               PromptState ('Menu a)
-  PointOnMapPromptState :: Position         -> PromptState 'PointOnMap
+  StringPromptState
+    :: Editor Text ResourceName     -> PromptState 'StringPrompt
+  DirectionPromptState  ::            PromptState 'DirectionPrompt
+  ContinuePromptState   ::            PromptState 'Continue
+  ConfirmPromptState    ::            PromptState 'Confirm
+  MenuPromptState       :: forall a.       PromptState ('Menu a)
+  PointOnMapPromptState :: Position -> PromptState 'PointOnMap
 
 instance NFData (PromptState pt) where
   rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 80137df7a721..f614cad47339 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell      #-}
@@ -14,6 +15,7 @@ module Xanthous.Game.State
   , activePanel
   , promptState
   , characterEntityID
+  , autocommand
   , GamePromptState(..)
 
     -- * Game Level
@@ -31,9 +33,16 @@ module Xanthous.Game.State
   , previousMessage
   , nextTurn
 
+    -- * Autocommands
+  , Autocommand(..)
+  , AutocommandState(..)
+  , _NoAutocommand
+  , _ActiveAutocommand
+
     -- * App monad
   , AppT(..)
   , AppM
+  , runAppT
 
     -- * Entities
   , Draw(..)
@@ -73,9 +82,11 @@ 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           Control.Monad.State
+import           Control.Monad.Trans.Control (MonadTransControl(..))
+import           Control.Monad.Trans.Compose
+import           Control.Monad.Morph (MFunctor(..))
 import           Brick (EventM, Widget, raw, str, emptyWidget)
 import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
 import qualified Data.Aeson as JSON
@@ -87,6 +98,7 @@ import qualified Graphics.Vty.Image as Vty
 import           Xanthous.Util (KnownBool(..))
 import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
 import           Xanthous.Data
+import           Xanthous.Data.App
 import           Xanthous.Data.Levels
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data.EntityChar
@@ -94,7 +106,7 @@ import           Xanthous.Data.VectorBag
 import           Xanthous.Data.Entities
 import           Xanthous.Orphans ()
 import           Xanthous.Game.Prompt
-import           Xanthous.Resource
+import           Xanthous.Game.Env
 --------------------------------------------------------------------------------
 
 data MessageHistory
@@ -182,15 +194,21 @@ instance Function (GamePromptState m) where
 --------------------------------------------------------------------------------
 
 newtype AppT m a
-  = AppT { unAppT :: StateT GameState m a }
+  = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a }
   deriving ( Functor
            , Applicative
            , Monad
            , MonadState GameState
+           , MonadReader GameEnv
+           , MonadIO
+           )
+       via (ReaderT GameEnv (StateT GameState m))
+  deriving ( MonadTrans
+           , MFunctor
            )
-       via (StateT GameState m)
+       via (ReaderT GameEnv `ComposeT` StateT GameState)
 
-type AppM = AppT (EventM Name)
+type AppM = AppT (EventM ResourceName)
 
 --------------------------------------------------------------------------------
 
@@ -414,6 +432,50 @@ data GameLevel = GameLevel
 
 --------------------------------------------------------------------------------
 
+data Autocommand
+  = AutoMove Direction
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Autocommand
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+data AutocommandState
+  = NoAutocommand
+  | ActiveAutocommand Autocommand (Async ())
+  deriving stock (Eq, Ord, Generic)
+  deriving anyclass (Hashable)
+
+instance Show AutocommandState where
+  show NoAutocommand = "NoAutocommand"
+  show (ActiveAutocommand ac _) =
+    "(ActiveAutocommand " <> show ac <> " <Async>)"
+
+instance ToJSON AutocommandState where
+  toJSON = const Null
+
+instance FromJSON AutocommandState where
+  parseJSON Null = pure NoAutocommand
+  parseJSON _ = fail "Invalid AutocommandState; expected null"
+
+instance NFData AutocommandState where
+  rnf NoAutocommand = ()
+  rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` ()
+
+instance CoArbitrary AutocommandState where
+  coarbitrary NoAutocommand = variant @Int 1
+  coarbitrary (ActiveAutocommand ac t)
+    = variant @Int 2
+    . coarbitrary ac
+    . coarbitrary (hash t)
+
+instance Function AutocommandState where
+  function = functionMap onlyNoAC (const NoAutocommand)
+    where
+      onlyNoAC NoAutocommand = ()
+      onlyNoAC _ = error "Can't handle autocommands in Function"
+
+--------------------------------------------------------------------------------
+
 
 data DebugState = DebugState
   { _allRevealed :: !Bool
@@ -439,6 +501,7 @@ data GameState = GameState
 
   , _promptState       :: !(GamePromptState AppM)
   , _debugState        :: !DebugState
+  , _autocommand       :: !AutocommandState
   }
   deriving stock (Show, Generic)
   deriving anyclass (NFData)
@@ -467,8 +530,12 @@ instance Eq GameState where
 
 --------------------------------------------------------------------------------
 
-instance MonadTrans AppT where
-  lift = AppT . lift
+runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState)
+runAppT appt env initialState
+  = flip runStateT initialState
+  . flip runReaderT env
+  . unAppT
+  $ appt
 
 instance (Monad m) => MonadRandom (AppT m) where
   getRandomR rng = randomGen %%= randomR rng
@@ -476,9 +543,16 @@ instance (Monad m) => MonadRandom (AppT m) where
   getRandomRs rng = uses randomGen $ randomRs rng
   getRandoms = uses randomGen randoms
 
-instance (MonadIO m) => MonadIO (AppT m) where
-  liftIO = lift . liftIO
+instance MonadTransControl AppT where
+  type StT AppT a = (a, GameState)
+  liftWith f
+    = AppT
+    . ReaderT $ \e
+    -> StateT $ \s
+    -> (,s) <$> f (\action -> runAppT action e s)
+  restoreT = AppT . ReaderT . const . StateT . const
 
 --------------------------------------------------------------------------------
 
 makeLenses ''DebugState
+makePrisms ''AutocommandState
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index 1138a7a5a09b..db602de56f3a 100644
--- a/src/Xanthous/Monad.hs
+++ b/src/Xanthous/Monad.hs
@@ -5,12 +5,19 @@ module Xanthous.Monad
   , runAppT
   , continue
   , halt
+
     -- * Messages
   , say
   , say_
   , message
   , message_
   , writeMessage
+
+    -- * Autocommands
+  , cancelAutocommand
+
+    -- * Events
+  , sendEvent
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -18,16 +25,16 @@ import           Control.Monad.Random
 import           Control.Monad.State
 import qualified Brick
 import           Brick (EventM, Next)
-import           Data.Aeson
+import           Brick.BChan (writeBChan)
+import           Data.Aeson (ToJSON, object)
 --------------------------------------------------------------------------------
+import           Xanthous.Data.App (AppEvent)
 import           Xanthous.Game.State
+import           Xanthous.Game.Env
 import           Xanthous.Messages (Message)
 import qualified Xanthous.Messages as Messages
 --------------------------------------------------------------------------------
 
-runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
-runAppT appt initialState = flip runStateT initialState . unAppT $ appt
-
 halt :: AppT (EventM n) (Next GameState)
 halt = lift . Brick.halt =<< get
 
@@ -53,3 +60,17 @@ message_ msg = message msg $ object []
 
 writeMessage :: MonadState GameState m => Text -> m ()
 writeMessage m = messageHistory %= pushMessage m
+
+-- | Cancel the currently active autocommand, if any
+cancelAutocommand :: (MonadState GameState m, MonadIO m) => m ()
+cancelAutocommand = do
+  traverse_ (liftIO . cancel . snd) =<< preuse (autocommand . _ActiveAutocommand)
+  autocommand .= NoAutocommand
+
+--------------------------------------------------------------------------------
+
+-- | Send an event to the app in an environment where the game env is available
+sendEvent :: (MonadReader GameEnv m, MonadIO m) => AppEvent -> m ()
+sendEvent evt = do
+  ec <- view eventChan
+  liftIO $ writeBChan ec evt
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-08T09·28+0000