chore(users): grfn -> aspen
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9 Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809 Autosubmit: aspen <root@gws.fyi> Reviewed-by: sterni <sternenseemann@systemli.org> Tested-by: BuildkiteCI Reviewed-by: lukegb <lukegb@tvl.fyi>
This commit is contained in:
Aspen Smith
clbot
parent
0ba476a426
commit
82ecd61f5c
478 changed files with 75 additions and 77 deletions
53
users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs
Normal file
53
users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs
Normal file
|
|
@ -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
|
||||
224
users/aspen/xanthous/src/Xanthous/Game/Draw.hs
Normal file
224
users/aspen/xanthous/src/Xanthous/Game/Draw.hs
Normal file
|
|
@ -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)
|
||||
37
users/aspen/xanthous/src/Xanthous/Game/Env.hs
Normal file
37
users/aspen/xanthous/src/Xanthous/Game/Env.hs
Normal file
|
|
@ -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
|
||||
178
users/aspen/xanthous/src/Xanthous/Game/Lenses.hs
Normal file
178
users/aspen/xanthous/src/Xanthous/Game/Lenses.hs
Normal file
|
|
@ -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
|
||||
52
users/aspen/xanthous/src/Xanthous/Game/Memo.hs
Normal file
52
users/aspen/xanthous/src/Xanthous/Game/Memo.hs
Normal file
|
|
@ -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) #-}
|
||||
359
users/aspen/xanthous/src/Xanthous/Game/Prompt.hs
Normal file
359
users/aspen/xanthous/src/Xanthous/Game/Prompt.hs
Normal file
|
|
@ -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
|
||||
572
users/aspen/xanthous/src/Xanthous/Game/State.hs
Normal file
572
users/aspen/xanthous/src/Xanthous/Game/State.hs
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue