Describe what you see when you walk over items

Every step the character takes, describe the entities at that position
excluding the character.
This commit is contained in:
Griffin Smith 2019-09-20 19:38:16 -04:00
parent 4db3a68efe
commit dd16166665
12 changed files with 82 additions and 14 deletions

View file

@ -8,7 +8,8 @@ import qualified Brick
import Brick.Widgets.Edit (handleEditorEvent)
import Graphics.Vty.Attributes (defAttr)
import Graphics.Vty.Input.Events (Event(EvKey), Key(..))
import Control.Monad.State (get, state, StateT(..))
import Control.Monad.State (get, state, StateT(..), MonadState)
import Control.Monad.Random (MonadRandom)
import Data.Coerce
import Control.Monad.State.Class (modify)
import Data.Aeson (object, ToJSON)
@ -29,12 +30,14 @@ import Xanthous.Game.Prompt
import Xanthous.Monad
import Xanthous.Resource (Name)
import Xanthous.Messages (message)
import Xanthous.Util.Inflection (toSentence)
--------------------------------------------------------------------------------
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.Entities.Character
import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
--------------------------------------------------------------------------------
@ -93,6 +96,7 @@ handleCommand (Move dir) = do
collisionAt newPos >>= \case
Nothing -> do
characterPosition .= newPos
describeEntitiesAt newPos
modify updateCharacterVision
Just Combat -> undefined
Just Stop -> pure ()
@ -198,3 +202,15 @@ entitiesAtPositionWithType pos em =
case downcastEntity @a se of
Just e -> [(eid, e)]
Nothing -> []
describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m ()
describeEntitiesAt pos =
use ( entities
. EntityMap.atPosition pos
. to (filter (not . entityIs @Character))
) >>= \case
Empty -> pure ()
ents ->
let descriptions = description <$> ents
in say ["entities", "description"] $ object
["entityDescriptions" A..= toSentence descriptions]

View file

@ -38,9 +38,11 @@ import Xanthous.Orphans ()
class (Show a, Eq a, Draw a) => Entity a where
blocksVision :: a -> Bool
description :: a -> Text
instance Entity a => Entity (Positioned a) where
blocksVision (Positioned _ ent) = blocksVision ent
description (Positioned _ ent) = description ent
--------------------------------------------------------------------------------
data SomeEntity where
@ -59,6 +61,7 @@ instance Draw SomeEntity where
instance Entity SomeEntity where
blocksVision (SomeEntity ent) = blocksVision ent
description (SomeEntity ent) = description ent
downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a
downcastEntity (SomeEntity e) = cast e

View file

@ -41,6 +41,7 @@ instance Draw Character where
instance Entity Character where
blocksVision _ = False
description _ = "yourself"
instance Arbitrary Character where
arbitrary = genericArbitrary

View file

@ -9,13 +9,14 @@ module Xanthous.Entities.Creature
, damage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.Word
import Test.QuickCheck.Arbitrary.Generic
import Data.Word
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Creature)
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
import Xanthous.Entities.RawTypes hiding (Creature, description)
import qualified Xanthous.Entities.RawTypes as Raw
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
--------------------------------------------------------------------------------
data Creature = Creature
@ -31,6 +32,7 @@ instance Arbitrary Creature where
instance Entity Creature where
blocksVision _ = False
description = view $ creatureType . Raw.description
newWithType :: CreatureType -> Creature
newWithType _creatureType =

View file

@ -24,6 +24,7 @@ data Wall = Wall
instance Entity Wall where
blocksVision _ = True
description _ = "a wall"
instance Arbitrary Wall where
arbitrary = pure Wall
@ -65,3 +66,4 @@ instance Draw Door where
instance Entity Door where
blocksVision = not . view open
description _ = "a door"

View file

@ -1,17 +1,19 @@
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.Item
( Item(..)
, itemType
, newWithType
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Test.QuickCheck
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson.Generic.DerivingVia
import Xanthous.Prelude
import Test.QuickCheck
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Item)
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
import Xanthous.Entities.RawTypes hiding (Item, description)
import qualified Xanthous.Entities.RawTypes as Raw
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
--------------------------------------------------------------------------------
data Item = Item
@ -30,6 +32,7 @@ instance Arbitrary Item where
instance Entity Item where
blocksVision _ = False
description = view $ itemType . Raw.description
newWithType :: ItemType -> Item
newWithType = Item

View file

@ -1,6 +1,6 @@
Item:
name: noodles
description: a big bowl o' noodles
description: "a big bowl o' noodles"
longDescription: You know exactly what kind of noodles
char:
char: 'n'

View file

@ -0,0 +1,15 @@
{-# LANGUAGE ViewPatterns #-}
module Xanthous.Util.Inflection
( toSentence
) where
import Xanthous.Prelude
toSentence :: (MonoFoldable mono, Element mono ~ Text) => mono -> Text
toSentence xs = case reverse . toList $ xs of
[] -> ""
[x] -> x
[b, a] -> a <> " and " <> b
(final : butlast) ->
intercalate ", " (reverse butlast) <> ", and " <> final

View file

@ -1,5 +1,8 @@
welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
entities:
description: You see here {{entityDescriptions}}
items:
pickUp: You pick up the {{item.itemType.name}}
nothingToPickUp: "There's nothing here to pick up"

View file

@ -7,6 +7,7 @@ import qualified Xanthous.Generators.UtilSpec
import qualified Xanthous.MessageSpec
import qualified Xanthous.OrphansSpec
import qualified Xanthous.Util.GraphicsSpec
import qualified Xanthous.Util.InflectionSpec
main :: IO ()
main = defaultMain test
@ -21,4 +22,5 @@ test = testGroup "Xanthous"
, Xanthous.OrphansSpec.test
, Xanthous.DataSpec.test
, Xanthous.Util.GraphicsSpec.test
, Xanthous.Util.InflectionSpec.test
]

View file

@ -0,0 +1,18 @@
module Xanthous.Util.InflectionSpec (main, test) where
import Test.Prelude
import Xanthous.Util.Inflection
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Util.Inflection"
[ testGroup "toSentence"
[ testCase "empty" $ toSentence [] @?= ""
, testCase "single" $ toSentence ["x"] @?= "x"
, testCase "two" $ toSentence ["x", "y"] @?= "x and y"
, testCase "three" $ toSentence ["x", "y", "z"] @?= "x, y, and z"
, testCase "four" $ toSentence ["x", "y", "z", "w"] @?= "x, y, z, and w"
]
]

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 40187d0301465905043b8caafec5465e644f711620c9fc1cfc57af4105ebe08c
-- hash: cebd0598e7aa48a62741fd8a9acc462bb693bb9356947147e0604d8e4b395739
name: xanthous
version: 0.1.0.0
@ -59,6 +59,7 @@ library
Xanthous.Resource
Xanthous.Util
Xanthous.Util.Graphics
Xanthous.Util.Inflection
other-modules:
Paths_xanthous
hs-source-dirs:
@ -132,6 +133,7 @@ executable xanthous
Xanthous.Resource
Xanthous.Util
Xanthous.Util.Graphics
Xanthous.Util.Inflection
Paths_xanthous
hs-source-dirs:
src
@ -185,6 +187,7 @@ test-suite test
Xanthous.MessageSpec
Xanthous.OrphansSpec
Xanthous.Util.GraphicsSpec
Xanthous.Util.InflectionSpec
Paths_xanthous
hs-source-dirs:
test