diff --git a/package.yaml b/package.yaml index 936fc4fd0..b74a4df9e 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 95cfc9edb..dcd31afff 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index f7013076d..672aa93f6 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 000000000..e8d94ce74 --- /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 000000000..69ba6f0e0 --- /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 000000000..6704a601d --- /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 000000000..b17348f38 --- /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 2e7e6f1ff..37025dd37 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 ec40b8721..3cb74bdca 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 similarity index 74% rename from src/Xanthous/Resource.hs rename to src/Xanthous/Data/App.hs index cc2fc97a1..0361d2a59 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 886a8c03d..a1eb789a3 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 659081e57..b855ce88e 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 000000000..6e10d0f73 --- /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 017d53652..48b7235d2 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 e89cf5bee..30b5fe754 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 80137df7a..f614cad47 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 (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 <> " )" + +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 1138a7a5a..db602de56 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 diff --git a/xanthous.cabal b/xanthous.cabal index 3dc2de467..85b70c97f 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -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