diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Game')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs | 53 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 224 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Env.hs | 37 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Lenses.hs | 178 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Memo.hs | 52 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Prompt.hs | 359 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/State.hs | 572 |
7 files changed, 0 insertions, 1475 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs deleted file mode 100644 index 679bfe54597f..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Arbitrary where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (foldMap) --------------------------------------------------------------------------------- -import Test.QuickCheck -import System.Random -import Data.Foldable (foldMap) --------------------------------------------------------------------------------- -import Xanthous.Data.Levels -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Entities () -import Xanthous.Entities.Character -import Xanthous.Game.State -import Xanthous.Orphans () -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) --------------------------------------------------------------------------------- - -deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel - -instance Arbitrary GameState where - arbitrary = do - chr <- arbitrary @Character - _upStaircasePosition <- arbitrary - _messageHistory <- arbitrary - levs <- arbitrary @(Levels GameLevel) - _levelRevealedPositions <- - fmap setFromList - . sublistOf - . foldMap (EntityMap.positions . _levelEntities) - $ levs - let (_characterEntityID, _levelEntities) = - EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr) - $ levs ^. current . levelEntities - _levels = levs & current .~ GameLevel {..} - _randomGen <- mkStdGen <$> arbitrary - let _promptState = NoPrompt -- TODO - _activePanel <- arbitrary - _debugState <- arbitrary - let _autocommand = NoAutocommand - _memo <- arbitrary - _savefile <- arbitrary - pure $ GameState {..} - - -instance CoArbitrary GameLevel -instance Function GameLevel -instance CoArbitrary GameState -instance Function GameState diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs deleted file mode 100644 index 291dfd8b5e46..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ /dev/null @@ -1,224 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Game.Draw - ( drawGame - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick hiding (loc, on) -import Brick.Widgets.Border -import Brick.Widgets.Border.Style -import Brick.Widgets.Edit -import Control.Monad.State.Lazy (evalState) -import Control.Monad.State.Class ( get, MonadState, gets ) --------------------------------------------------------------------------------- -import Xanthous.Data -import Xanthous.Data.App (ResourceName, Panel(..)) -import qualified Xanthous.Data.App as Resource -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Game.State -import Xanthous.Entities.Common (Wielded(..), wielded, backpack) -import Xanthous.Entities.Character -import Xanthous.Entities.Item (Item) -import Xanthous.Game - ( characterPosition - , character - , revealedEntitiesAtPosition - ) -import Xanthous.Game.Prompt -import Xanthous.Orphans () -import Brick.Widgets.Center (hCenter) -import Xanthous.Command (Keybinding (..), keybindings, Command, commandIsHidden) -import Graphics.Vty.Input.Events (Modifier(..)) -import Graphics.Vty.Input (Key(..)) -import Brick.Widgets.Table --------------------------------------------------------------------------------- - -cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName -cursorPosition game - | WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _) - <- game ^. promptState - = showCursor Resource.Prompt (pos ^. loc) - | otherwise - = showCursor Resource.Character (game ^. characterPosition . loc) - -drawMessages :: MessageHistory -> Widget ResourceName -drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract - -drawPromptState :: GamePromptState m -> Widget ResourceName -drawPromptState NoPrompt = emptyWidget -drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = - case (pt, ps, pri) of - (SStringPrompt, StringPromptState edit, mDef) -> - txt msg - <+> txt (maybe "" (\def -> "(default: " <> def <> ") ") mDef) - <+> renderEditor (txt . fold) True edit - (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg - (SMenu, _, menuItems) -> - txtWrap msg - <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) - _ -> txtWrap msg - where - drawMenuItem (chr, MenuOption m _) = - str ("[" <> pure chr <> "] ") <+> txtWrap m - -drawEntities - :: forall m. MonadState GameState m - => m (Widget ResourceName) -drawEntities = do - allEnts <- use entities - let entityPositions = EntityMap.positions allEnts - maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions - maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions - rows = traverse mkRow [0..maxY] - mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX] - renderEntityAt pos - = renderTopEntity pos <$> revealedEntitiesAtPosition pos - renderTopEntity pos ents - = let neighbors = EntityMap.neighbors pos allEnts - in maybe (str " ") (drawWithNeighbors neighbors) - $ maximumBy (compare `on` drawPriority) - <$> fromNullable ents - vBox <$> rows - -drawMap :: MonadState GameState m => m (Widget ResourceName) -drawMap = do - cursorPos <- gets cursorPosition - viewport Resource.MapViewport Both . cursorPos <$> drawEntities - -bullet :: Char -bullet = '•' - -drawInventoryPanel :: GameState -> Widget ResourceName -drawInventoryPanel game - = drawWielded (game ^. character . inventory . wielded) - <=> drawBackpack (game ^. character . inventory . backpack) - where - drawWielded (Hands Nothing Nothing) = emptyWidget - drawWielded (DoubleHanded i) = - txtWrap $ "You are holding " <> description i <> " in both hands" - drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r - drawHand side = maybe emptyWidget $ \i -> - txtWrap ( "You are holding " - <> description i - <> " in your " <> side <> " hand" - ) - <=> txt " " - - 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 " - <> "backpack:") - <=> txt " " - <=> foldl' (<=>) emptyWidget - (map - (txtWrap . ((bullet <| " ") <>) . description) - backpackItems) - -drawHelpPanel :: Widget ResourceName -drawHelpPanel - = txtWrap "To move in a direction or attack, use vi keys (hjklyubn):" - <=> txt " " - <=> hCenter keyStar - <=> txt " " - <=> cmds - where - keyStar - = txt "y k u" - <=> txt " \\|/" - <=> txt "h-.-l" - <=> txt " /|\\" - <=> txt "b j n" - - cmds - = renderTable - . alignRight 0 - . setDefaultRowAlignment AlignTop - . surroundingBorder False - . rowBorders False - . columnBorders False - . table $ help <&> \(key, cmd) -> [ txt $ key <> " : " - , hLimitPercent 100 $ txtWrap cmd] - - help = - extraHelp <> - keybindings - ^.. ifolded - . filtered (not . commandIsHidden) - . withIndex - . to (bimap displayKeybinding displayCommand) - extraHelp - = [("Shift-Dir", "Auto-move")] - - displayCommand = tshow @Command - displayKeybinding (Keybinding k mods) = foldMap showMod mods <> showKey k - - showMod MCtrl = "Ctrl-" - showMod MShift = "Shift-" - showMod MAlt = "Alt-" - showMod MMeta = "Meta-" - - showKey (KChar c) = pack [c] - showKey KEsc = "<Esc>" - showKey KBS = "<Backspace>" - showKey KEnter = "<Enter>" - showKey KLeft = "<Left>" - showKey KRight = "<Right>" - showKey KUp = "<Up>" - showKey KDown = "<Down>" - showKey KUpLeft = "<UpLeft>" - showKey KUpRight = "<UpRight>" - showKey KDownLeft = "<DownLeft>" - showKey KDownRight = "<DownRight>" - showKey KCenter = "<Center>" - showKey (KFun n) = "<F" <> tshow n <> ">" - showKey KBackTab = "<BackTab>" - showKey KPrtScr = "<PrtScr>" - showKey KPause = "<Pause>" - showKey KIns = "<Ins>" - showKey KHome = "<Home>" - showKey KPageUp = "<PageUp>" - showKey KDel = "<Del>" - showKey KEnd = "<End>" - showKey KPageDown = "<PageDown>" - showKey KBegin = "<Begin>" - showKey KMenu = "<Menu>" - -drawPanel :: GameState -> Panel -> Widget ResourceName -drawPanel game panel - = border - . hLimit 35 - . viewport (Resource.Panel panel) Vertical - $ case panel of - HelpPanel -> drawHelpPanel - InventoryPanel -> drawInventoryPanel game - ItemDescriptionPanel desc -> txtWrap desc - -drawCharacterInfo :: Character -> Widget ResourceName -drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints - where - charName | Just n <- ch ^. characterName - = txt $ n <> " " - | otherwise - = emptyWidget - charHitpoints - = txt "Hitpoints: " - <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) - -drawGame :: GameState -> [Widget ResourceName] -drawGame = evalState $ do - game <- get - drawnMap <- drawMap - pure - . pure - . withBorderStyle unicode - $ case game ^. promptState of - NoPrompt -> drawMessages (game ^. messageHistory) - _ -> emptyWidget - <=> drawPromptState (game ^. promptState) - <=> - (maybe emptyWidget (drawPanel game) (game ^. activePanel) - <+> border drawnMap - ) - <=> drawCharacterInfo (game ^. character) diff --git a/users/grfn/xanthous/src/Xanthous/Game/Env.hs b/users/grfn/xanthous/src/Xanthous/Game/Env.hs deleted file mode 100644 index 5d7b275c8a0b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Env.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Env - ( Config(..) - , defaultConfig - , disableSaving - , GameEnv(..) - , eventChan - , config - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick.BChan (BChan) -import Xanthous.Data.App (AppEvent) --------------------------------------------------------------------------------- - -data Config = Config - { _disableSaving :: Bool - } - deriving stock (Generic, Show, Eq) -makeLenses ''Config -{-# ANN Config ("HLint: ignore Use newtype instead of data" :: String) #-} - -defaultConfig :: Config -defaultConfig = Config - { _disableSaving = False - } - --------------------------------------------------------------------------------- - -data GameEnv = GameEnv - { _eventChan :: BChan AppEvent - , _config :: Config - } - deriving stock (Generic) -makeLenses ''GameEnv diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs deleted file mode 100644 index c692a3b47944..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Lenses - ( clearMemo - , positionedCharacter - , character - , characterPosition - , updateCharacterVision - , characterVisiblePositions - , characterVisibleEntities - , positionIsCharacterVisible - , getInitialState - , initialStateFromSeed - , entitiesAtCharacter - , revealedEntitiesAtPosition - , hearingRadius - - -- * Collisions - , Collision(..) - , entitiesCollision - , collisionAt - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import System.Random -import Control.Monad.State -import Control.Monad.Random (getRandom) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import qualified Xanthous.Game.Memo as Memo -import Xanthous.Data -import Xanthous.Data.Levels -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data.EntityMap.Graphics - (visiblePositions, visibleEntities) -import Xanthous.Data.VectorBag -import Xanthous.Entities.Character (Character, mkCharacter) -import {-# SOURCE #-} Xanthous.Entities.Entities () -import Xanthous.Game.Memo (emptyMemoState, MemoState) -import Xanthous.Data.Memo (fillWithM, Memoized) --------------------------------------------------------------------------------- - -getInitialState :: IO GameState -getInitialState = initialStateFromSeed <$> getRandom - -initialStateFromSeed :: Int -> GameState -initialStateFromSeed seed = - let _randomGen = mkStdGen seed - chr = mkCharacter - _upStaircasePosition = Position 0 0 - (_characterEntityID, _levelEntities) - = EntityMap.insertAtReturningID - _upStaircasePosition - (SomeEntity chr) - mempty - _levelRevealedPositions = mempty - level = GameLevel {..} - _levels = oneLevel level - _messageHistory = mempty - _promptState = NoPrompt - _activePanel = Nothing - _debugState = DebugState - { _allRevealed = False - } - _savefile = Nothing - _autocommand = NoAutocommand - _memo = emptyMemoState - in GameState {..} - -clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m () -clearMemo l = memo %= Memo.clear l - -positionedCharacter :: Lens' GameState (Positioned Character) -positionedCharacter = lens getPositionedCharacter setPositionedCharacter - where - setPositionedCharacter :: GameState -> Positioned Character -> GameState - setPositionedCharacter game chr - = game - & entities . at (game ^. characterEntityID) - ?~ fmap SomeEntity chr - - getPositionedCharacter :: GameState -> Positioned Character - getPositionedCharacter game - = over positioned - ( fromMaybe (error "Invariant error: Character was not a character!") - . downcastEntity - ) - . fromMaybe (error "Invariant error: Character not found!") - $ EntityMap.lookupWithPosition - (game ^. characterEntityID) - (game ^. entities) - - -character :: Lens' GameState Character -character = positionedCharacter . positioned - -characterPosition :: Lens' GameState Position -characterPosition = positionedCharacter . position - --- TODO make this dynamic -visionRadius :: Word -visionRadius = 12 - --- TODO make this dynamic -hearingRadius :: Word -hearingRadius = 12 - --- | Update the revealed entities at the character's position based on their --- vision -updateCharacterVision :: GameState -> GameState -updateCharacterVision = execState $ do - positions <- characterVisiblePositions - revealedPositions <>= positions - -characterVisiblePositions :: MonadState GameState m => m (Set Position) -characterVisiblePositions = do - charPos <- use characterPosition - fillWithM - (memo . Memo.characterVisiblePositions) - charPos - (uses entities $ visiblePositions charPos visionRadius) - -characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity -characterVisibleEntities game = - let charPos = game ^. characterPosition - in visibleEntities charPos visionRadius $ game ^. entities - -positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool -positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions --- ^ TODO optimize - -entitiesCollision - :: ( Functor f - , forall xx. MonoFoldable (f xx) - , Element (f SomeEntity) ~ SomeEntity - , Element (f (Maybe Collision)) ~ Maybe Collision - , Show (f (Maybe Collision)) - , Show (f SomeEntity) - ) - => f SomeEntity - -> Maybe Collision -entitiesCollision = join . maximumMay . fmap entityCollision - -collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) -collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision - -entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity) -entitiesAtCharacter = lens getter setter - where - getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition) - setter gs ents = gs - & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents - --- | Returns all entities at the given position that are revealed to the --- character. --- --- Concretely, this is either entities that are *currently* visible to the --- character, or entities, that are immobile and that the character has seen --- before -revealedEntitiesAtPosition - :: MonadState GameState m - => Position - -> m (VectorBag SomeEntity) -revealedEntitiesAtPosition p = do - allRev <- use $ debugState . allRevealed - cvps <- characterVisiblePositions - entitiesAtPosition <- use $ entities . EntityMap.atPosition p - revealed <- use revealedPositions - let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition - pure $ if | allRev || p `member` cvps - -> entitiesAtPosition - | p `member` revealed - -> immobileEntitiesAtPosition - | otherwise - -> mempty diff --git a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs deleted file mode 100644 index 154063b5dde2..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | Memoized versions of calculations --------------------------------------------------------------------------------- -module Xanthous.Game.Memo - ( MemoState - , emptyMemoState - , clear - -- ** Memo lenses - , characterVisiblePositions - - -- * Memoized values - , Memoized(UnMemoized) - , memoizeWith - , getMemoized - , runMemoized - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Test.QuickCheck (CoArbitrary, Function, Arbitrary) --------------------------------------------------------------------------------- -import Xanthous.Data (Position) -import Xanthous.Data.Memo -import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary)) --------------------------------------------------------------------------------- - --- | Memoized calculations on the game state -data MemoState = MemoState - { -- | Memoized version of 'Xanthous.Game.Lenses.characterVisiblePositions', - -- memoized with the position of the character - _characterVisiblePositions :: Memoized Position (Set Position) - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary MemoState - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - MemoState -makeLenses ''MemoState - -emptyMemoState :: MemoState -emptyMemoState = MemoState { _characterVisiblePositions = UnMemoized } -{-# INLINE emptyMemoState #-} - -clear :: ASetter' MemoState (Memoized key val) -> MemoState -> MemoState -clear = flip set UnMemoized -{-# INLINE clear #-} - -{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 2d6c0a280f41..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Prompt - ( PromptType(..) - , SPromptType(..) - , SingPromptType(..) - , PromptCancellable(..) - , PromptResult(..) - , PromptState(..) - , promptStatePosition - , MenuOption(..) - , mkMenuItems - , PromptInput - , Prompt(..) - , mkPrompt - , mkStringPrompt - , mkStringPromptWithDefault - , mkMenu - , mkPointOnMapPrompt - , mkFirePrompt - , isCancellable - , submitPrompt - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick.Widgets.Edit (Editor, editorText, getEditContents) -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic --------------------------------------------------------------------------------- -import Xanthous.Util (smallestNotIn, AlphaChar (..)) -import Xanthous.Data (Direction, Position, Tiles) -import Xanthous.Data.App (ResourceName) -import qualified Xanthous.Data.App as Resource --------------------------------------------------------------------------------- - -data PromptType where - StringPrompt :: PromptType - Confirm :: PromptType - Menu :: Type -> PromptType - DirectionPrompt :: PromptType - PointOnMap :: PromptType - -- | Throw an item or fire a projectile weapon. Prompt is to select the - -- direction - Fire :: PromptType - Continue :: PromptType - deriving stock (Generic) - -instance Show PromptType where - show StringPrompt = "StringPrompt" - show Confirm = "Confirm" - show (Menu _) = "Menu" - show DirectionPrompt = "DirectionPrompt" - show PointOnMap = "PointOnMap" - show Continue = "Continue" - show Fire = "Fire" - -data SPromptType :: PromptType -> Type where - SStringPrompt :: SPromptType 'StringPrompt - SConfirm :: SPromptType 'Confirm - SMenu :: SPromptType ('Menu a) - SDirectionPrompt :: SPromptType 'DirectionPrompt - SPointOnMap :: SPromptType 'PointOnMap - SContinue :: SPromptType 'Continue - SFire :: SPromptType 'Fire - -instance NFData (SPromptType pt) where - rnf SStringPrompt = () - rnf SConfirm = () - rnf SMenu = () - rnf SDirectionPrompt = () - rnf SPointOnMap = () - rnf SContinue = () - rnf SFire = () - -class SingPromptType pt where singPromptType :: SPromptType pt -instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt -instance SingPromptType 'Confirm where singPromptType = SConfirm -instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt -instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap -instance SingPromptType 'Continue where singPromptType = SContinue -instance SingPromptType 'Fire where singPromptType = SFire - -instance Show (SPromptType pt) where - show SStringPrompt = "SStringPrompt" - show SConfirm = "SConfirm" - show SMenu = "SMenu" - show SDirectionPrompt = "SDirectionPrompt" - show SPointOnMap = "SPointOnMap" - show SContinue = "SContinue" - show SFire = "SFire" - -data PromptCancellable - = Cancellable - | Uncancellable - deriving stock (Show, Eq, Ord, Enum, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - -instance Arbitrary PromptCancellable where - arbitrary = genericArbitrary - -data PromptResult (pt :: PromptType) where - StringResult :: Text -> PromptResult 'StringPrompt - ConfirmResult :: Bool -> PromptResult 'Confirm - MenuResult :: forall a. a -> PromptResult ('Menu a) - DirectionResult :: Direction -> PromptResult 'DirectionPrompt - PointOnMapResult :: Position -> PromptResult 'PointOnMap - FireResult :: Position -> PromptResult 'Fire - ContinueResult :: PromptResult 'Continue - -instance Arbitrary (PromptResult 'StringPrompt) where - arbitrary = StringResult <$> arbitrary - -instance Arbitrary (PromptResult 'Confirm) where - arbitrary = ConfirmResult <$> arbitrary - -instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where - arbitrary = MenuResult <$> arbitrary - -instance Arbitrary (PromptResult 'DirectionPrompt) where - arbitrary = DirectionResult <$> arbitrary - -instance Arbitrary (PromptResult 'PointOnMap) where - arbitrary = PointOnMapResult <$> arbitrary - -instance Arbitrary (PromptResult 'Continue) where - arbitrary = pure ContinueResult - -instance Arbitrary (PromptResult 'Fire) where - arbitrary = FireResult <$> arbitrary - --------------------------------------------------------------------------------- - -data PromptState pt where - 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 - FirePromptState :: Position -> PromptState 'Fire - -instance NFData (PromptState pt) where - rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` () - rnf DirectionPromptState = () - rnf ContinuePromptState = () - rnf ConfirmPromptState = () - rnf MenuPromptState = () - rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` () - rnf fps@(FirePromptState pos) = fps `deepseq` pos `deepseq` () - -instance Arbitrary (PromptState 'StringPrompt) where - arbitrary = StringPromptState <$> arbitrary - -instance Arbitrary (PromptState 'DirectionPrompt) where - arbitrary = pure DirectionPromptState - -instance Arbitrary (PromptState 'Continue) where - arbitrary = pure ContinuePromptState - -instance Arbitrary (PromptState ('Menu a)) where - arbitrary = pure MenuPromptState - -instance Arbitrary (PromptState 'Fire) where - arbitrary = FirePromptState <$> arbitrary - -instance CoArbitrary (PromptState 'StringPrompt) where - coarbitrary (StringPromptState ed) = coarbitrary ed - -instance CoArbitrary (PromptState 'DirectionPrompt) where - coarbitrary DirectionPromptState = coarbitrary () - -instance CoArbitrary (PromptState 'Continue) where - coarbitrary ContinuePromptState = coarbitrary () - -instance CoArbitrary (PromptState ('Menu a)) where - coarbitrary MenuPromptState = coarbitrary () - -instance CoArbitrary (PromptState 'Fire) where - coarbitrary (FirePromptState pos) = coarbitrary pos - -deriving stock instance Show (PromptState pt) - --- | Traversal over the position for the prompt types with positions in their --- prompt state (currently 'Fire' and 'PointOnMap') -promptStatePosition :: forall pt. Traversal' (PromptState pt) Position -promptStatePosition _ ps@(StringPromptState _) = pure ps -promptStatePosition _ DirectionPromptState = pure DirectionPromptState -promptStatePosition _ ContinuePromptState = pure ContinuePromptState -promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState -promptStatePosition _ MenuPromptState = pure MenuPromptState -promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p -promptStatePosition f (FirePromptState p) = FirePromptState <$> f p - -data MenuOption a = MenuOption Text a - deriving stock (Eq, Generic, Functor) - deriving anyclass (NFData, CoArbitrary, Function) - -instance Comonad MenuOption where - extract (MenuOption _ x) = x - extend cok mo@(MenuOption text _) = MenuOption text (cok mo) - -mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a)) - => f - -> Map Char (MenuOption a) -mkMenuItems = flip foldl' mempty $ \items (chr, option) -> - let chr' = if has (ix chr) items - then getAlphaChar . smallestNotIn . map AlphaChar $ keys items - else chr - in items & at chr' ?~ option - -instance Show (MenuOption a) where - show (MenuOption m _) = show m - -type family PromptInput (pt :: PromptType) :: Type where - PromptInput ('Menu a) = Map Char (MenuOption a) - PromptInput 'PointOnMap = Position -- Character pos - PromptInput 'Fire = (Position, Tiles) -- Nearest enemy, range - PromptInput 'StringPrompt = Maybe Text -- Default value - PromptInput _ = () - -data Prompt (m :: Type -> Type) where - Prompt - :: forall (pt :: PromptType) - (m :: Type -> Type). - PromptCancellable - -> SPromptType pt - -> PromptState pt - -> PromptInput pt - -> (PromptResult pt -> m ()) - -> Prompt m - -instance Show (Prompt m) where - show (Prompt c pt ps pri _) - = "(Prompt " - <> show c <> " " - <> show pt <> " " - <> show ps <> " " - <> showPri - <> " <function>)" - where showPri = case pt of - SMenu -> show pri - _ -> "()" - -instance NFData (Prompt m) where - rnf (Prompt c SMenu ps pri cb) - = c - `deepseq` ps - `deepseq` pri - `seq` cb - `seq` () - rnf (Prompt c spt ps pri cb) - = c - `deepseq` spt - `deepseq` ps - `deepseq` pri - `seq` cb - `seq` () - -instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where - coarbitrary (Prompt c SStringPrompt ps pri cb) = - variant @Int 1 . coarbitrary (c, ps, pri, cb) - coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state - variant @Int 2 . coarbitrary (c, pri, cb) - coarbitrary (Prompt c SMenu _ps _pri _cb) = - variant @Int 3 . coarbitrary c {-, ps, pri, cb -} - coarbitrary (Prompt c SDirectionPrompt ps pri cb) = - variant @Int 4 . coarbitrary (c, ps, pri, cb) - coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state - variant @Int 5 . coarbitrary (c, pri, cb) - coarbitrary (Prompt c SContinue ps pri cb) = - variant @Int 6 . coarbitrary (c, ps, pri, cb) - coarbitrary (Prompt c SFire ps pri cb) = - variant @Int 7 . coarbitrary (c, ps, pri, cb) - --- instance Function (Prompt m) where --- function = functionMap toTuple _fromTuple --- where --- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb) - - -mkPrompt - :: (PromptInput pt ~ ()) - => PromptCancellable -- ^ Is the prompt cancellable or not? - -> SPromptType pt -- ^ The type of the prompt - -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb -mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb -mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb - -mkStringPrompt - :: PromptCancellable -- ^ Is the prompt cancellable or not? - -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkStringPrompt c = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c SStringPrompt ps Nothing - -mkStringPromptWithDefault - :: PromptCancellable -- ^ Is the prompt cancellable or not? - -> Text -- ^ Default value for the prompt - -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkStringPromptWithDefault c def = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c SStringPrompt ps (Just def) - -mkMenu - :: forall a m. - PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> m ()) - -> Prompt m -mkMenu c = Prompt c SMenu MenuPromptState - -mkPointOnMapPrompt - :: PromptCancellable - -> Position - -> (PromptResult 'PointOnMap -> m ()) - -> Prompt m -mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos - -mkFirePrompt - :: PromptCancellable - -> Position -- ^ Initial position - -> Tiles -- ^ Range - -> (PromptResult 'Fire -> m ()) - -> Prompt m -mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range) - -isCancellable :: Prompt m -> Bool -isCancellable (Prompt Cancellable _ _ _ _) = True -isCancellable (Prompt Uncancellable _ _ _ _) = False - -submitPrompt :: Applicative m => Prompt m -> m () -submitPrompt (Prompt _ pt ps pri cb) = - case (pt, ps, pri) of - (SStringPrompt, StringPromptState edit, mDef) -> - let inputVal = mconcat . getEditContents $ edit - val | null inputVal, Just def <- mDef = def - | otherwise = inputVal - in cb $ StringResult val - (SDirectionPrompt, DirectionPromptState, _) -> - pure () -- Don't use submit with a direction prompt - (SContinue, ContinuePromptState, _) -> - cb ContinueResult - (SMenu, MenuPromptState, _) -> - pure () -- Don't use submit with a menu prompt - (SPointOnMap, PointOnMapPromptState pos, _) -> - cb $ PointOnMapResult pos - (SConfirm, ConfirmPromptState, _) -> - cb $ ConfirmResult True - (SFire, FirePromptState pos, _) -> - cb $ FireResult pos diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs deleted file mode 100644 index 13b1ba158818..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/State.hs +++ /dev/null @@ -1,572 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Game.State - ( GameState(..) - , entities - , levels - , revealedPositions - , messageHistory - , randomGen - , activePanel - , promptState - , characterEntityID - , autocommand - , savefile - , memo - , GamePromptState(..) - - -- * Game Level - , GameLevel(..) - , levelEntities - , upStaircasePosition - , levelRevealedPositions - - -- * Messages - , MessageHistory(..) - , HasMessages(..) - , HasTurn(..) - , HasDisplayedTurn(..) - , pushMessage - , previousMessage - , nextTurn - - -- * Autocommands - , Autocommand(..) - , AutocommandState(..) - , _NoAutocommand - , _ActiveAutocommand - - -- * App monad - , AppT(..) - , AppM - , runAppT - - -- * Entities - , Draw(..) - , Brain(..) - , Brainless(..) - , brainVia - , Collision(..) - , Entity(..) - , SomeEntity(..) - , downcastEntity - , _SomeEntity - , entityIs - , entityTypeName - - -- ** Vias - , Color(..) - , DrawNothing(..) - , DrawRawChar(..) - , DrawRawCharPriority(..) - , DrawCharacter(..) - , DrawStyledCharacter(..) - , DeriveEntity(..) - -- ** Field classes - , HasChar(..) - , HasStyle(..) - - -- * Debug State - , DebugState(..) - , debugState - , allRevealed - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.List.NonEmpty ( NonEmpty((:|))) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Typeable -import Data.Coerce -import System.Random -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic -import Control.Monad.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 -import Data.Aeson.Generic.DerivingVia -import Data.Generics.Product.Fields -import qualified Graphics.Vty.Attributes as Vty -import qualified Graphics.Vty.Image as Vty --------------------------------------------------------------------------------- -import Xanthous.Util (KnownBool(..)) -import Xanthous.Data -import Xanthous.Data.App -import Xanthous.Data.Levels -import Xanthous.Data.EntityMap (EntityMap, EntityID) -import Xanthous.Data.EntityChar -import Xanthous.Data.VectorBag -import Xanthous.Data.Entities -import Xanthous.Orphans () -import Xanthous.Game.Prompt -import Xanthous.Game.Env -import Xanthous.Game.Memo (MemoState) --------------------------------------------------------------------------------- - -data MessageHistory - = MessageHistory - { _messages :: Map Word (NonEmpty Text) - , _turn :: Word - , _displayedTurn :: Maybe Word - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary MessageHistory - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - MessageHistory -makeFieldsNoPrefix ''MessageHistory - -instance Semigroup MessageHistory where - (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) = - MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of - (_, Nothing) -> Nothing - (Just t, _) -> Just t - (Nothing, Just t) -> Just t - -instance Monoid MessageHistory where - mempty = MessageHistory mempty 0 Nothing - -type instance Element MessageHistory = [Text] -instance MonoFunctor MessageHistory where - omap f mh@(MessageHistory _ t _) = - mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<) - -instance MonoComonad MessageHistory where - oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt) - oextend cok mh@(MessageHistory _ t dt) = - mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh) - -pushMessage :: Text -> MessageHistory -> MessageHistory -pushMessage msg mh@(MessageHistory _ turn' _) = - mh - & messages . at turn' %~ \case - Nothing -> Just $ msg :| mempty - Just msgs -> Just $ msg <| msgs - & displayedTurn .~ Nothing - -nextTurn :: MessageHistory -> MessageHistory -nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing) - -previousMessage :: MessageHistory -> MessageHistory -previousMessage mh = mh & displayedTurn .~ maximumOf - (messages . ifolded . asIndex . filtered (< mh ^. turn)) - mh - - --------------------------------------------------------------------------------- - -data GamePromptState m where - NoPrompt :: GamePromptState m - WaitingPrompt :: Text -> Prompt m -> GamePromptState m - deriving stock (Show, Generic) - deriving anyclass (NFData) - --- | Non-injective! We never try to serialize waiting prompts, since: --- --- * they contain callback functions --- * we can't save the game when in a prompt anyway -instance ToJSON (GamePromptState m) where - toJSON _ = Null - --- | Always expects Null -instance FromJSON (GamePromptState m) where - parseJSON Null = pure NoPrompt - parseJSON _ = fail "Invalid GamePromptState; expected null" - -instance CoArbitrary (GamePromptState m) where - coarbitrary NoPrompt = variant @Int 1 - coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt - -instance Function (GamePromptState m) where - function = functionMap onlyNoPrompt (const NoPrompt) - where - onlyNoPrompt NoPrompt = () - onlyNoPrompt (WaitingPrompt _ _) = - error "Can't handle prompts in Function!" - --------------------------------------------------------------------------------- - -newtype AppT m a - = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a } - deriving ( Functor - , Applicative - , Monad - , MonadState GameState - , MonadReader GameEnv - , MonadIO - ) - via (ReaderT GameEnv (StateT GameState m)) - deriving ( MonadTrans - , MFunctor - ) - via (ReaderT GameEnv `ComposeT` StateT GameState) - -type AppM = AppT (EventM ResourceName) - --------------------------------------------------------------------------------- - -class Draw a where - drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n - drawWithNeighbors = const draw - - draw :: a -> Widget n - draw = drawWithNeighbors $ pure mempty - - -- | higher priority gets drawn on top - drawPriority :: a -> Word - drawPriority = const minBound - -instance Draw a => Draw (Positioned a) where - drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a - draw (Positioned _ a) = draw a - -newtype DrawCharacter (char :: Symbol) (a :: Type) where - DrawCharacter :: a -> DrawCharacter char a - -instance KnownSymbol char => Draw (DrawCharacter char a) where - draw _ = str $ symbolVal @char Proxy - -data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White - -class KnownColor (color :: Color) where - colorVal :: forall proxy. proxy color -> Vty.Color - -instance KnownColor 'Black where colorVal _ = Vty.black -instance KnownColor 'Red where colorVal _ = Vty.red -instance KnownColor 'Green where colorVal _ = Vty.green -instance KnownColor 'Yellow where colorVal _ = Vty.yellow -instance KnownColor 'Blue where colorVal _ = Vty.blue -instance KnownColor 'Magenta where colorVal _ = Vty.magenta -instance KnownColor 'Cyan where colorVal _ = Vty.cyan -instance KnownColor 'White where colorVal _ = Vty.white - -class KnownMaybeColor (maybeColor :: Maybe Color) where - maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color - -instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing -instance KnownColor color => KnownMaybeColor ('Just color) where - maybeColorVal _ = Just $ colorVal @color Proxy - -newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where - DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a - -instance - ( KnownMaybeColor fg - , KnownMaybeColor bg - , KnownSymbol char - ) - => Draw (DrawStyledCharacter fg bg char a) where - draw _ = raw $ Vty.string attr $ symbolVal @char Proxy - where attr = Vty.Attr - { Vty.attrStyle = Vty.Default - , Vty.attrForeColor = maybe Vty.Default Vty.SetTo - $ maybeColorVal @fg Proxy - , Vty.attrBackColor = maybe Vty.Default Vty.SetTo - $ maybeColorVal @bg Proxy - , Vty.attrURL = Vty.Default - } - -instance Draw EntityChar where - draw EntityChar{..} = raw $ Vty.string _style [_char] - --------------------------------------------------------------------------------- - -newtype DrawNothing (a :: Type) = DrawNothing a - -instance Draw (DrawNothing a) where - draw = const emptyWidget - drawPriority = const 0 - -newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a - -instance - forall rawField a raw. - ( HasField rawField a a raw raw - , HasChar raw EntityChar - ) => Draw (DrawRawChar rawField a) where - draw (DrawRawChar e) = draw $ e ^. field @rawField . char - -newtype DrawRawCharPriority - (rawField :: Symbol) - (priority :: Nat) - (a :: Type) - = DrawRawCharPriority a - -instance - forall rawField priority a raw. - ( HasField rawField a a raw raw - , KnownNat priority - , HasChar raw EntityChar - ) => Draw (DrawRawCharPriority rawField priority a) where - draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char - drawPriority = const . fromIntegral $ natVal @priority Proxy - - --------------------------------------------------------------------------------- - -class Brain a where - step :: Ticks -> Positioned a -> AppM (Positioned a) - -- | Does this entity ever move on its own? - entityCanMove :: a -> Bool - entityCanMove = const False - -newtype Brainless a = Brainless a - -instance Brain (Brainless a) where - step = const pure - --- | Workaround for the inability to use DerivingVia on Brain due to the lack of --- higher-order roles (specifically AppT not having its last type argument have --- role representational bc of StateT) -brainVia - :: forall brain entity. (Coercible entity brain, Brain brain) - => (entity -> brain) -- ^ constructor, ignored - -> (Ticks -> Positioned entity -> AppM (Positioned entity)) -brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain) - --------------------------------------------------------------------------------- - -class ( Show a, Eq a, Ord a, NFData a - , ToJSON a, FromJSON a - , Draw a, Brain a - ) => Entity a where - entityAttributes :: a -> EntityAttributes - entityAttributes = const defaultEntityAttributes - description :: a -> Text - entityChar :: a -> EntityChar - entityCollision :: a -> Maybe Collision - entityCollision = const $ Just Stop - -data SomeEntity where - SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity - -instance Show SomeEntity where - show (SomeEntity e) = "SomeEntity (" <> show e <> ")" - -instance Eq SomeEntity where - (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of - Just Refl -> a == b - _ -> False - -instance Ord SomeEntity where - compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of - Just Refl -> compare a b - _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb) - - -instance NFData SomeEntity where - rnf (SomeEntity ent) = ent `deepseq` () - -instance ToJSON SomeEntity where - toJSON (SomeEntity ent) = entityToJSON ent - where - entityToJSON :: forall entity. (Entity entity, Typeable entity) - => entity -> JSON.Value - entityToJSON entity = JSON.object - [ "type" JSON..= tshow (typeRep @_ @entity Proxy) - , "data" JSON..= toJSON entity - ] - -instance Draw SomeEntity where - drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent - drawPriority (SomeEntity ent) = drawPriority ent - -instance Brain SomeEntity where - step ticks (Positioned p (SomeEntity ent)) = - fmap SomeEntity <$> step ticks (Positioned p ent) - entityCanMove (SomeEntity ent) = entityCanMove ent - -downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a -downcastEntity (SomeEntity e) = cast e - -entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool -entityIs = isJust . downcastEntity @a - -_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a -_SomeEntity = prism' SomeEntity downcastEntity - --- | Get the name of the type of 'SomeEntity' as a string -entityTypeName :: SomeEntity -> Text -entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e - -newtype DeriveEntity - (blocksVision :: Bool) - (description :: Symbol) - (entityChar :: Symbol) - (entity :: Type) - = DeriveEntity entity - deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw) - -instance Brain entity => Brain (DeriveEntity b d c entity) where - step = brainVia $ \(DeriveEntity e) -> e - -instance - ( KnownBool blocksVision - , KnownSymbol description - , KnownSymbol entityChar - , Show entity, Eq entity, Ord entity, NFData entity - , ToJSON entity, FromJSON entity - , Draw entity, Brain entity - ) - => Entity (DeriveEntity blocksVision description entityChar entity) where - entityAttributes _ = defaultEntityAttributes - & blocksVision .~ boolVal @blocksVision - description _ = pack . symbolVal $ Proxy @description - entityChar _ = fromString . symbolVal $ Proxy @entityChar - --------------------------------------------------------------------------------- - -data GameLevel = GameLevel - { _levelEntities :: !(EntityMap SomeEntity) - , _upStaircasePosition :: !Position - , _levelRevealedPositions :: !(Set Position) - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - GameLevel - --------------------------------------------------------------------------------- - -data Autocommand - = AutoMove Direction - | AutoRest - 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 - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - DebugState -{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-} - -instance Arbitrary DebugState where - arbitrary = genericArbitrary - -data GameState = GameState - { _levels :: !(Levels GameLevel) - , _characterEntityID :: !EntityID - , _messageHistory :: !MessageHistory - , _randomGen :: !StdGen - - -- | The active panel displayed in the UI, if any - , _activePanel :: !(Maybe Panel) - - , _promptState :: !(GamePromptState AppM) - , _debugState :: !DebugState - , _autocommand :: !AutocommandState - - -- | The path to the savefile that was loaded for this game, if any - , _savefile :: !(Maybe FilePath) - - , _memo :: MemoState - } - deriving stock (Show, Generic) - deriving anyclass (NFData) - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - GameState - -makeLenses ''GameLevel -makeLenses ''GameState - -entities :: Lens' GameState (EntityMap SomeEntity) -entities = levels . current . levelEntities - -revealedPositions :: Lens' GameState (Set Position) -revealedPositions = levels . current . levelRevealedPositions - -instance Eq GameState where - (==) = (==) `on` \gs -> - ( gs ^. entities - , gs ^. revealedPositions - , gs ^. characterEntityID - , gs ^. messageHistory - , gs ^. activePanel - , gs ^. debugState - ) - --------------------------------------------------------------------------------- - -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 - getRandom = randomGen %%= random - getRandomRs rng = uses randomGen $ randomRs rng - getRandoms = uses randomGen randoms - -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 |