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:
parent
4db3a68efe
commit
dd16166665
12 changed files with 82 additions and 14 deletions
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -41,6 +41,7 @@ instance Draw Character where
|
|||
|
||||
instance Entity Character where
|
||||
blocksVision _ = False
|
||||
description _ = "yourself"
|
||||
|
||||
instance Arbitrary Character where
|
||||
arbitrary = genericArbitrary
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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'
|
||||
|
|
15
src/Xanthous/Util/Inflection.hs
Normal file
15
src/Xanthous/Util/Inflection.hs
Normal 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
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
18
test/Xanthous/Util/InflectionSpec.hs
Normal file
18
test/Xanthous/Util/InflectionSpec.hs
Normal 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"
|
||||
]
|
||||
]
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue