diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/App')
4 files changed, 0 insertions, 332 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs deleted file mode 100644 index f393a0e2ea..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs +++ /dev/null @@ -1,64 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.App.Autocommands - ( runAutocommand - , autoStep - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Control.Concurrent (threadDelay) -import qualified Data.Aeson as A -import Data.Aeson (object) -import Data.List.NonEmpty (nonEmpty) -import qualified Data.List.NonEmpty as NE -import Control.Monad.State (gets) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.App.Time -import Xanthous.Data -import Xanthous.Data.App -import Xanthous.Entities.Character (speed) -import Xanthous.Entities.Creature (Creature, creatureType) -import Xanthous.Entities.RawTypes (hostile) -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 - maybeVisibleEnemies <- nonEmpty <$> enemiesInSight - for_ maybeVisibleEnemies $ \visibleEnemies -> do - say ["autoMove", "enemyInSight"] - $ object [ "firstEntity" A..= NE.head visibleEnemies ] - cancelAutocommand - Just _ -> cancelAutocommand - where - enemiesInSight :: AppM [Creature] - enemiesInSight = do - ents <- gets characterVisibleEntities - pure $ ents - ^.. folded - . _SomeEntity @Creature - . filtered (view $ creatureType . hostile) - --------------------------------------------------------------------------------- - -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/users/glittershark/xanthous/src/Xanthous/App/Common.hs b/users/glittershark/xanthous/src/Xanthous/App/Common.hs deleted file mode 100644 index 69ba6f0e05..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Common.hs +++ /dev/null @@ -1,67 +0,0 @@ --------------------------------------------------------------------------------- -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/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs deleted file mode 100644 index 9b5a3bf24f..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# 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 (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/users/glittershark/xanthous/src/Xanthous/App/Time.hs b/users/glittershark/xanthous/src/Xanthous/App/Time.hs deleted file mode 100644 index b17348f385..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Time.hs +++ /dev/null @@ -1,40 +0,0 @@ --------------------------------------------------------------------------------- -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 |