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.

src/Xanthous/App.hs

@@ -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
+  items <- uses entities $ entitiesAtPositionWithType @Item pos
-  let items = flip foldMap ents $ \(eid, view positioned -> se) ->
-        case downcastEntity @Item se of
-          Just item -> [(eid, item)]
-          Nothing   -> []
   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 -> []

src/Xanthous/Command.hs

@@ -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 (directionFromChar -> Just dir)) [] = Just $ Move dir
-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 '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

src/Xanthous/Data.hs

@@ -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

src/Xanthous/Entities/Arbitrary.hs

@@ -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
     ]

src/Xanthous/Entities/Creature.hs

@@ -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
 

src/Xanthous/Entities/Environment.hs

@@ -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

src/Xanthous/Entities/RawTypes.hs

@@ -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

src/Xanthous/Game.hs

@@ -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
 
 --------------------------------------------------------------------------------

src/Xanthous/Game/Draw.hs

@@ -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

src/Xanthous/Game/Prompt.hs

@@ -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

src/Xanthous/Generators/CaveAutomata.hs

@@ -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 ()

src/Xanthous/Generators/LevelContents.hs

@@ -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

src/Xanthous/messages.yaml

@@ -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? "