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, 1475 insertions, 0 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs new file mode 100644 index 000000000000..679bfe54597f --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs @@ -0,0 +1,53 @@ +{-# 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 new file mode 100644 index 000000000000..291dfd8b5e46 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs @@ -0,0 +1,224 @@ +-------------------------------------------------------------------------------- +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 new file mode 100644 index 000000000000..5d7b275c8a0b --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Env.hs @@ -0,0 +1,37 @@ +{-# 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 new file mode 100644 index 000000000000..c692a3b47944 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs @@ -0,0 +1,178 @@ +{-# 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 new file mode 100644 index 000000000000..154063b5dde2 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs @@ -0,0 +1,52 @@ +{-# 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 new file mode 100644 index 000000000000..2d6c0a280f41 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs @@ -0,0 +1,359 @@ +{-# 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 new file mode 100644 index 000000000000..13b1ba158818 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/State.hs @@ -0,0 +1,572 @@ +{-# 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 |