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:
parent
7770ed0548
commit
4db3a68efe
13 changed files with 151 additions and 29 deletions
|
@ -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 -> []
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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? "
|
||||
|
|
Loading…
Reference in a new issue