Add doors and an open command

Add a Door entity and an Open command, which necessitated supporting the
direction prompt. Currently nothing actually puts doors on the map,
which puts a slight damper on actually testing this out.
This commit is contained in:
Griffin Smith 2019-09-20 13:14:55 -04:00
parent 7770ed0548
commit 4db3a68efe
13 changed files with 151 additions and 29 deletions

View file

@ -1,3 +1,4 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
module Xanthous.App (makeApp) where
--------------------------------------------------------------------------------
@ -18,7 +19,9 @@ import Xanthous.Data
( move
, Dimensions'(Dimensions)
, positioned
, Position
)
import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Game
import Xanthous.Game.Draw (drawGame)
@ -31,6 +34,7 @@ import qualified Xanthous.Entities.Character as Character
import Xanthous.Entities.Character (characterName)
import Xanthous.Entities
import Xanthous.Entities.Item (Item)
import Xanthous.Entities.Environment (Door, open, locked)
import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
--------------------------------------------------------------------------------
@ -96,11 +100,7 @@ handleCommand (Move dir) = do
handleCommand PickUp = do
pos <- use characterPosition
ents <- uses entities $ EntityMap.atPositionWithIDs pos
let items = flip foldMap ents $ \(eid, view positioned -> se) ->
case downcastEntity @Item se of
Just item -> [(eid, item)]
Nothing -> []
items <- uses entities $ entitiesAtPositionWithType @Item pos
case items of
[] -> say_ ["items", "nothingToPickUp"]
[(itemID, item)] -> do
@ -114,11 +114,26 @@ handleCommand PreviousMessage = do
messageHistory %= popMessage
continue
handleCommand Open = do
prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable
$ \(DirectionResult dir) -> do
pos <- move dir <$> use characterPosition
doors <- uses entities $ entitiesAtPositionWithType @Door pos
if | null doors -> say_ ["open", "nothingToOpen"]
| any (view $ _2 . locked) doors -> say_ ["open", "locked"]
| otherwise -> do
for_ doors $ \(eid, _) ->
entities . ix eid . positioned . _SomeEntity . open .= True
say_ ["open", "success"]
pure ()
continue
handlePromptEvent
:: Text -- ^ Prompt message
-> Prompt (AppT Identity)
-> BrickEvent Name ()
-> AppM (Next GameState)
handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do
promptState .= NoPrompt
continue
@ -126,6 +141,7 @@ handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do
() <- state . coerce $ submitPrompt pr
promptState .= NoPrompt
continue
handlePromptEvent
msg
(Prompt c SStringPrompt (StringPromptState edit) cb)
@ -135,6 +151,15 @@ handlePromptEvent
let prompt' = Prompt c SStringPrompt (StringPromptState edit') cb
promptState .= WaitingPrompt msg prompt'
continue
handlePromptEvent _ (Prompt _ SDirectionPrompt _ cb)
(VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
= do
() <- state . coerce . cb $ DirectionResult dir
promptState .= NoPrompt
continue
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue
handlePromptEvent _ _ _ = undefined
prompt
@ -159,3 +184,17 @@ prompt_
-> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
-> AppM ()
prompt_ msg = prompt msg $ object []
--------------------------------------------------------------------------------
entitiesAtPositionWithType
:: forall a. (Entity a, Typeable a)
=> Position
-> EntityMap SomeEntity
-> [(EntityMap.EntityID, a)]
entitiesAtPositionWithType pos em =
let someEnts = EntityMap.atPositionWithIDs pos em
in flip foldMap someEnts $ \(eid, view positioned -> se) ->
case downcastEntity @a se of
Just e -> [(eid, e)]
Nothing -> []

View file

@ -1,30 +1,39 @@
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
module Xanthous.Command where
import Graphics.Vty.Input (Key(..), Modifier(..))
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Left, Right, Down)
--------------------------------------------------------------------------------
import Graphics.Vty.Input (Key(..), Modifier(..))
--------------------------------------------------------------------------------
import Xanthous.Data (Direction(..))
--------------------------------------------------------------------------------
data Command
= Quit
| Move Direction
| PreviousMessage
| PickUp
| Open
commandFromKey :: Key -> [Modifier] -> Maybe Command
commandFromKey (KChar 'q') [] = Just Quit
commandFromKey (KChar 'h') [] = Just $ Move Left
commandFromKey (KChar 'j') [] = Just $ Move Down
commandFromKey (KChar 'k') [] = Just $ Move Up
commandFromKey (KChar 'l') [] = Just $ Move Right
commandFromKey (KChar 'y') [] = Just $ Move UpLeft
commandFromKey (KChar 'u') [] = Just $ Move UpRight
commandFromKey (KChar 'b') [] = Just $ Move DownLeft
commandFromKey (KChar 'n') [] = Just $ Move DownRight
commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
commandFromKey (KChar ',') [] = Just PickUp
commandFromKey (KChar 'o') [] = Just Open
commandFromKey _ _ = Nothing
--------------------------------------------------------------------------------
directionFromChar :: Char -> Maybe Direction
directionFromChar 'h' = Just Left
directionFromChar 'j' = Just Down
directionFromChar 'k' = Just Up
directionFromChar 'l' = Just Right
directionFromChar 'y' = Just UpLeft
directionFromChar 'u' = Just UpRight
directionFromChar 'b' = Just DownLeft
directionFromChar 'n' = Just DownRight
directionFromChar '.' = Just Here
directionFromChar _ = Nothing

View file

@ -135,6 +135,7 @@ data Direction where
UpRight :: Direction
DownLeft :: Direction
DownRight :: Direction
Here :: Direction
deriving stock (Show, Eq, Generic)
instance Arbitrary Direction where
@ -150,6 +151,7 @@ opposite UpLeft = DownRight
opposite UpRight = DownLeft
opposite DownLeft = UpRight
opposite DownRight = UpLeft
opposite Here = Here
move :: Direction -> Position -> Position
move Up = y -~ 1
@ -160,6 +162,7 @@ move UpLeft = move Up . move Left
move UpRight = move Up . move Right
move DownLeft = move Down . move Left
move DownRight = move Down . move Right
move Here = id
asPosition :: Direction -> Position
asPosition dir = move dir mempty

View file

@ -9,11 +9,16 @@ import qualified Test.QuickCheck.Gen as Gen
--------------------------------------------------------------------------------
import Xanthous.Entities (SomeEntity(..))
import Xanthous.Entities.Character
import Xanthous.Entities.Item
import Xanthous.Entities.Creature
import Xanthous.Entities.Environment
--------------------------------------------------------------------------------
instance Arbitrary SomeEntity where
arbitrary = Gen.oneof
[ SomeEntity <$> arbitrary @Character
, pure $ SomeEntity Wall
, SomeEntity <$> arbitrary @Item
, SomeEntity <$> arbitrary @Creature
, SomeEntity <$> arbitrary @Wall
, SomeEntity <$> arbitrary @Door
]

View file

@ -12,6 +12,7 @@ module Xanthous.Entities.Creature
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.Word
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Creature)
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
@ -25,6 +26,9 @@ data Creature = Creature
deriving Draw via DrawRawChar "_creatureType" Creature
makeLenses ''Creature
instance Arbitrary Creature where
arbitrary = genericArbitrary
instance Entity Creature where
blocksVision _ = False

View file

@ -1,13 +1,19 @@
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Environment
( Wall(..)
, Door(..)
, open
, locked
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Brick (str)
import Brick.Widgets.Border.Style (unicode)
import Brick.Types (Edges(..))
--------------------------------------------------------------------------------
import Xanthous.Entities (Draw(..), entityIs, Entity(..))
import Xanthous.Entities (Draw(..), entityIs, Entity(..), SomeEntity)
import Xanthous.Entities.Draw.Util
import Xanthous.Data
--------------------------------------------------------------------------------
@ -22,8 +28,40 @@ instance Entity Wall where
instance Arbitrary Wall where
arbitrary = pure Wall
wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity)
=> Neighbors mono -> Edges Bool
wallEdges neighs = any (entityIs @Wall) <$> edges neighs
instance Draw Wall where
drawWithNeighbors neighs _wall =
str . pure . borderFromEdges unicode $ wallEdges
str . pure . borderFromEdges unicode $ wallEdges neighs
data Door = Door
{ _open :: Bool
, _locked :: Bool
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
makeLenses ''Door
instance Arbitrary Door where
arbitrary = genericArbitrary
instance Draw Door where
drawWithNeighbors neighs door
| door ^. open
= str . pure $ case wallEdges neighs of
Edges True False False False -> vertDoor
Edges False True False False -> vertDoor
Edges True True False False -> vertDoor
Edges False False True False -> horizDoor
Edges False False False True -> horizDoor
Edges False False True True -> horizDoor
_ -> '+'
| otherwise = str "\\"
where
wallEdges = any (entityIs @Wall) <$> edges neighs
horizDoor = '␣'
vertDoor = '['
instance Entity Door where
blocksVision = not . view open

View file

@ -36,7 +36,12 @@ data CreatureType = CreatureType
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
CreatureType
makeFieldsNoPrefix ''CreatureType
instance Arbitrary CreatureType where
arbitrary = genericArbitrary
--------------------------------------------------------------------------------
data ItemType = ItemType
{ _name :: Text
, _description :: Text

View file

@ -46,10 +46,12 @@ import Xanthous.Data.EntityMap (EntityMap, EntityID)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap.Graphics
import Xanthous.Data (Positioned, Position(..), positioned, position)
import Xanthous.Entities (SomeEntity(..), downcastEntity, entityIs)
import Xanthous.Entities
(SomeEntity(..), downcastEntity, entityIs, _SomeEntity)
import Xanthous.Entities.Character
import Xanthous.Entities.Creature
import Xanthous.Entities.Item
import Xanthous.Entities.Environment
import Xanthous.Entities.Arbitrary ()
import Xanthous.Orphans ()
import Xanthous.Game.Prompt
@ -198,6 +200,8 @@ collisionAt pos = do
if | null ents -> Nothing
| any (entityIs @Creature) ents -> pure Combat
| all (entityIs @Item) ents -> Nothing
| doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
, all (view open) doors -> Nothing
| otherwise -> pure Stop
--------------------------------------------------------------------------------

View file

@ -41,6 +41,8 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
case (pt, ps) of
(SStringPrompt, StringPromptState edit) ->
txt msg <+> renderEditor (txt . fold) True edit
(SDirectionPrompt, DirectionPromptState) ->
txt msg
_ -> undefined
drawEntities

View file

@ -49,6 +49,7 @@ data SPromptType :: PromptType -> Type where
class SingPromptType pt where singPromptType :: SPromptType pt
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
instance Show (SPromptType pt) where
show SStringPrompt = "SStringPrompt"
@ -75,6 +76,7 @@ data PromptResult (pt :: PromptType) where
data PromptState pt where
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
DirectionPromptState :: PromptState 'DirectionPrompt
deriving stock instance Show (PromptState pt)
@ -100,17 +102,20 @@ mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) ->
mkPrompt c pt@SStringPrompt cb =
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
in Prompt c pt ps cb
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState cb
mkPrompt _ _ _ = undefined
isCancellable :: Prompt m -> Bool
isCancellable (Prompt Cancellable _ _ _) = True
isCancellable (Prompt Uncancellable _ _ _) = False
submitPrompt :: Prompt m -> m ()
submitPrompt :: Applicative m => Prompt m -> m ()
submitPrompt (Prompt _ pt ps cb) =
case (pt, ps) of
(SStringPrompt, StringPromptState edit) ->
cb . StringResult . mconcat . getEditContents $ edit
(SDirectionPrompt, DirectionPromptState) ->
pure () -- Don't use submit with a direction prompt
_ -> undefined
-- data PromptInput :: PromptType -> Type where

View file

@ -98,10 +98,10 @@ generate' params dims = do
let steps' = params ^. steps
when (steps' > 0)
$ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
lift $ fillOuterEdgesM cells
-- Remove all but the largest contiguous region of unfilled space
(_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells
lift $ fillAllM (fold smallerRegions) cells
lift $ fillOuterEdgesM cells
pure cells
stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s ()

View file

@ -27,7 +27,7 @@ randomItems cells = do
let len = rangeSize $ bounds cells
(numItems :: Int) <- floor . (* fromIntegral len)
<$> getRandomR @_ @Float (0.0004, 0.001)
items <- for [0..numItems] $ const do
items <- for [0..numItems] $ const $ do
pos <- randomPosition cells
itemType <- fmap (fromMaybe (error "no item raws!"))
. choose . ChooseElement

View file

@ -1,6 +1,14 @@
welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
items:
pickUp: You pick up the {{item.itemType.name}}
nothingToPickUp: There's nothing here to pick up
nothingToPickUp: "There's nothing here to pick up"
open:
prompt: Direction to open (hjklybnu.)?
success: "You open the door."
locked: "That door is locked"
nothingToOpen: "There's nothing to open there"
character:
namePrompt: "What's your name? "