Add a very basic, naive auto-move command
Add a very basic, naive auto-move command, which just steps the player in a direction until they collide with something, regardless of any surrounding beasties who might want to eat them. There's a lot of other stuff going on here - in order to get this working the way I wanted with a slight (I settled on 50ms) delay between every step in these autocommands while still redrawing in between I had to do all the extra machinery for custom Brick events with a channel, and then at the same time adding the bits for actually executing autocommands in a general fashion (because there will definitely be more!) hit my threshold for size for App.hs which sent me on a big journey to break it up into smaller files -- which seems actually like it was quite successful. Hopefully this will help with compile times too, though App.hs is still pretty slow (maybe more to do here).
This commit is contained in:
Griffin Smith
parent
ecd33e0c90
commit
34cabba896
18 changed files with 561 additions and 268 deletions
|
|
@ -19,6 +19,7 @@ dependencies:
|
|||
|
||||
- aeson
|
||||
- array
|
||||
- async
|
||||
- QuickCheck
|
||||
- quickcheck-text
|
||||
- quickcheck-instances
|
||||
|
|
@ -44,8 +45,11 @@ dependencies:
|
|||
- hgeometry-combinatorial
|
||||
- JuicyPixels
|
||||
- lens
|
||||
- lifted-async
|
||||
- linear
|
||||
- megaparsec
|
||||
- mmorph
|
||||
- monad-control
|
||||
- MonadRandom
|
||||
- mtl
|
||||
- optparse-applicative
|
||||
|
|
|
|||
34
src/Main.hs
34
src/Main.hs
|
|
@ -2,6 +2,8 @@ module Main ( main ) where
|
|||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude hiding (finally)
|
||||
import Brick
|
||||
import qualified Brick.BChan
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Options.Applicative as Opt
|
||||
import System.Random
|
||||
import Control.Monad.Random (getRandom)
|
||||
|
|
@ -9,6 +11,7 @@ import Control.Exception (finally)
|
|||
import System.Exit (die)
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Xanthous.Game as Game
|
||||
import Xanthous.Game.Env (GameEnv(..))
|
||||
import Xanthous.App
|
||||
import Xanthous.Generators
|
||||
( GeneratorInput
|
||||
|
|
@ -92,9 +95,8 @@ optParser = Opt.info
|
|||
thanks :: IO ()
|
||||
thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!"
|
||||
|
||||
runGame :: RunParams -> IO ()
|
||||
runGame rparams = do
|
||||
app <- makeApp NewGame
|
||||
newGame :: RunParams -> IO ()
|
||||
newGame rparams = do
|
||||
gameSeed <- maybe getRandom pure $ seed rparams
|
||||
when (isNothing $ seed rparams)
|
||||
. putStrLn
|
||||
|
|
@ -102,23 +104,33 @@ runGame rparams = do
|
|||
let initialState = Game.initialStateFromSeed gameSeed &~ do
|
||||
for_ (characterName rparams) $ \cn ->
|
||||
Game.character . Character.characterName ?= cn
|
||||
_game' <- defaultMain app initialState `finally` do
|
||||
putStr "\n\n"
|
||||
putStrLn "Thanks for playing Xanthous!"
|
||||
runGame NewGame initialState `finally` do
|
||||
thanks
|
||||
when (isNothing $ seed rparams)
|
||||
. putStrLn
|
||||
$ "Seed: " <> tshow gameSeed
|
||||
putStr "\n\n"
|
||||
pure ()
|
||||
|
||||
loadGame :: FilePath -> IO ()
|
||||
loadGame saveFile = do
|
||||
app <- makeApp LoadGame
|
||||
gameState <- maybe (die "Invalid save file!") pure
|
||||
=<< Game.loadGame . fromStrict <$> readFile @IO saveFile
|
||||
_game' <- gameState `deepseq` defaultMain app gameState `finally` thanks
|
||||
pure ()
|
||||
gameState `deepseq` runGame LoadGame gameState
|
||||
|
||||
runGame :: RunType -> Game.GameState -> IO ()
|
||||
runGame rt gameState = do
|
||||
eventChan <- Brick.BChan.newBChan 10
|
||||
let gameEnv = GameEnv eventChan
|
||||
app <- makeApp gameEnv rt
|
||||
let buildVty = Vty.mkVty Vty.defaultConfig
|
||||
initialVty <- buildVty
|
||||
_game' <- customMain
|
||||
initialVty
|
||||
buildVty
|
||||
(Just eventChan)
|
||||
app
|
||||
gameState
|
||||
pure ()
|
||||
|
||||
runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO ()
|
||||
runGenerate input dims mSeed = do
|
||||
|
|
@ -139,7 +151,7 @@ runGenerate input dims mSeed = do
|
|||
putStrLn $ showCells res
|
||||
|
||||
runCommand :: Command -> IO ()
|
||||
runCommand (Run runParams) = runGame runParams
|
||||
runCommand (Run runParams) = newGame runParams
|
||||
runCommand (Load saveFile) = loadGame saveFile
|
||||
runCommand (Generate input dims mSeed) = runGenerate input dims mSeed
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
44
src/Xanthous/App/Autocommands.hs
Normal file
44
src/Xanthous/App/Autocommands.hs
Normal file
|
|
@ -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
|
||||
67
src/Xanthous/App/Common.hs
Normal file
67
src/Xanthous/App/Common.hs
Normal file
|
|
@ -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]
|
||||
161
src/Xanthous/App/Prompt.hs
Normal file
161
src/Xanthous/App/Prompt.hs
Normal file
|
|
@ -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 []
|
||||
40
src/Xanthous/App/Time.hs
Normal file
40
src/Xanthous/App/Time.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
19
src/Xanthous/Game/Env.hs
Normal file
19
src/Xanthous/Game/Env.hs
Normal file
|
|
@ -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) #-}
|
||||
|
|
@ -56,6 +56,7 @@ initialStateFromSeed seed =
|
|||
_debugState = DebugState
|
||||
{ _allRevealed = False
|
||||
}
|
||||
_autocommand = NoAutocommand
|
||||
in GameState {..}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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,7 +120,8 @@ instance Arbitrary (PromptResult 'Continue) where
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
data PromptState pt where
|
||||
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
|
||||
StringPromptState
|
||||
:: Editor Text ResourceName -> PromptState 'StringPrompt
|
||||
DirectionPromptState :: PromptState 'DirectionPrompt
|
||||
ContinuePromptState :: PromptState 'Continue
|
||||
ConfirmPromptState :: PromptState 'Confirm
|
||||
|
|
|
|||
|
|
@ -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 (StateT GameState m)
|
||||
via (ReaderT GameEnv (StateT GameState m))
|
||||
deriving ( MonadTrans
|
||||
, MFunctor
|
||||
)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 09d294830fde12021527c15ba1e1698afdec092a16c4171ee67dce3256fe0d96
|
||||
-- hash: 61744d8e26bf309ee73e128a90af8badee98aedace39a756b6033f51711d3e2e
|
||||
|
||||
name: xanthous
|
||||
version: 0.1.0.0
|
||||
|
|
@ -32,8 +32,13 @@ library
|
|||
Main
|
||||
Xanthous.AI.Gormlak
|
||||
Xanthous.App
|
||||
Xanthous.App.Autocommands
|
||||
Xanthous.App.Common
|
||||
Xanthous.App.Prompt
|
||||
Xanthous.App.Time
|
||||
Xanthous.Command
|
||||
Xanthous.Data
|
||||
Xanthous.Data.App
|
||||
Xanthous.Data.Entities
|
||||
Xanthous.Data.EntityChar
|
||||
Xanthous.Data.EntityMap
|
||||
|
|
@ -52,6 +57,7 @@ library
|
|||
Xanthous.Game
|
||||
Xanthous.Game.Arbitrary
|
||||
Xanthous.Game.Draw
|
||||
Xanthous.Game.Env
|
||||
Xanthous.Game.Lenses
|
||||
Xanthous.Game.Prompt
|
||||
Xanthous.Game.State
|
||||
|
|
@ -65,7 +71,6 @@ library
|
|||
Xanthous.Orphans
|
||||
Xanthous.Prelude
|
||||
Xanthous.Random
|
||||
Xanthous.Resource
|
||||
Xanthous.Util
|
||||
Xanthous.Util.Comonad
|
||||
Xanthous.Util.Graph
|
||||
|
|
@ -78,7 +83,7 @@ library
|
|||
Paths_xanthous
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
JuicyPixels
|
||||
|
|
@ -87,6 +92,7 @@ library
|
|||
, Rasterific
|
||||
, aeson
|
||||
, array
|
||||
, async
|
||||
, base
|
||||
, brick
|
||||
, checkers
|
||||
|
|
@ -109,8 +115,11 @@ library
|
|||
, hgeometry
|
||||
, hgeometry-combinatorial
|
||||
, lens
|
||||
, lifted-async
|
||||
, linear
|
||||
, megaparsec
|
||||
, mmorph
|
||||
, monad-control
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, pointed
|
||||
|
|
@ -140,8 +149,13 @@ executable xanthous
|
|||
Data.Aeson.Generic.DerivingVia
|
||||
Xanthous.AI.Gormlak
|
||||
Xanthous.App
|
||||
Xanthous.App.Autocommands
|
||||
Xanthous.App.Common
|
||||
Xanthous.App.Prompt
|
||||
Xanthous.App.Time
|
||||
Xanthous.Command
|
||||
Xanthous.Data
|
||||
Xanthous.Data.App
|
||||
Xanthous.Data.Entities
|
||||
Xanthous.Data.EntityChar
|
||||
Xanthous.Data.EntityMap
|
||||
|
|
@ -160,6 +174,7 @@ executable xanthous
|
|||
Xanthous.Game
|
||||
Xanthous.Game.Arbitrary
|
||||
Xanthous.Game.Draw
|
||||
Xanthous.Game.Env
|
||||
Xanthous.Game.Lenses
|
||||
Xanthous.Game.Prompt
|
||||
Xanthous.Game.State
|
||||
|
|
@ -173,7 +188,6 @@ executable xanthous
|
|||
Xanthous.Orphans
|
||||
Xanthous.Prelude
|
||||
Xanthous.Random
|
||||
Xanthous.Resource
|
||||
Xanthous.Util
|
||||
Xanthous.Util.Comonad
|
||||
Xanthous.Util.Graph
|
||||
|
|
@ -185,7 +199,7 @@ executable xanthous
|
|||
Paths_xanthous
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2
|
||||
build-depends:
|
||||
JuicyPixels
|
||||
|
|
@ -194,6 +208,7 @@ executable xanthous
|
|||
, Rasterific
|
||||
, aeson
|
||||
, array
|
||||
, async
|
||||
, base
|
||||
, brick
|
||||
, checkers
|
||||
|
|
@ -216,8 +231,11 @@ executable xanthous
|
|||
, hgeometry
|
||||
, hgeometry-combinatorial
|
||||
, lens
|
||||
, lifted-async
|
||||
, linear
|
||||
, megaparsec
|
||||
, mmorph
|
||||
, monad-control
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, pointed
|
||||
|
|
@ -265,7 +283,7 @@ test-suite test
|
|||
Paths_xanthous
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0
|
||||
build-depends:
|
||||
JuicyPixels
|
||||
|
|
@ -274,6 +292,7 @@ test-suite test
|
|||
, Rasterific
|
||||
, aeson
|
||||
, array
|
||||
, async
|
||||
, base
|
||||
, brick
|
||||
, checkers
|
||||
|
|
@ -297,8 +316,11 @@ test-suite test
|
|||
, hgeometry-combinatorial
|
||||
, lens
|
||||
, lens-properties
|
||||
, lifted-async
|
||||
, linear
|
||||
, megaparsec
|
||||
, mmorph
|
||||
, monad-control
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, pointed
|
||||
|
|
|
|||
Loading…
Reference in a new issue