From dd1616666593f65bab70f1363b5d040fe5edd054 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 20 Sep 2019 19:38:16 -0400 Subject: Describe what you see when you walk over items Every step the character takes, describe the entities at that position excluding the character. --- src/Xanthous/App.hs | 18 +++++++++++++++++- src/Xanthous/Entities.hs | 3 +++ src/Xanthous/Entities/Character.hs | 1 + src/Xanthous/Entities/Creature.hs | 12 +++++++----- src/Xanthous/Entities/Environment.hs | 2 ++ src/Xanthous/Entities/Item.hs | 15 +++++++++------ src/Xanthous/Entities/Raws/noodles.yaml | 2 +- src/Xanthous/Util/Inflection.hs | 15 +++++++++++++++ src/Xanthous/messages.yaml | 3 +++ test/Spec.hs | 2 ++ test/Xanthous/Util/InflectionSpec.hs | 18 ++++++++++++++++++ xanthous.cabal | 5 ++++- 12 files changed, 82 insertions(+), 14 deletions(-) create mode 100644 src/Xanthous/Util/Inflection.hs create mode 100644 test/Xanthous/Util/InflectionSpec.hs diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index df0b30c41b..fce2beed13 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -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] diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs index e47e820f27..66a583f6b3 100644 --- a/src/Xanthous/Entities.hs +++ b/src/Xanthous/Entities.hs @@ -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 diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 695d7bb0d0..924c1857a8 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -41,6 +41,7 @@ instance Draw Character where instance Entity Character where blocksVision _ = False + description _ = "yourself" instance Arbitrary Character where arbitrary = genericArbitrary diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index b59cceab40..c660a6cdf5 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -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 = diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index d9275266b0..4ef67a577d 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/src/Xanthous/Entities/Environment.hs @@ -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" diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs index baf4be2f54..6b50f50ad8 100644 --- a/src/Xanthous/Entities/Item.hs +++ b/src/Xanthous/Entities/Item.hs @@ -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 diff --git a/src/Xanthous/Entities/Raws/noodles.yaml b/src/Xanthous/Entities/Raws/noodles.yaml index 120087d483..91a0a35388 100644 --- a/src/Xanthous/Entities/Raws/noodles.yaml +++ b/src/Xanthous/Entities/Raws/noodles.yaml @@ -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' diff --git a/src/Xanthous/Util/Inflection.hs b/src/Xanthous/Util/Inflection.hs new file mode 100644 index 0000000000..fc66c08761 --- /dev/null +++ b/src/Xanthous/Util/Inflection.hs @@ -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 diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index ef4f09543d..4d7b0003fa 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs index cac474053c..7af988a3d7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 ] diff --git a/test/Xanthous/Util/InflectionSpec.hs b/test/Xanthous/Util/InflectionSpec.hs new file mode 100644 index 0000000000..fad8410431 --- /dev/null +++ b/test/Xanthous/Util/InflectionSpec.hs @@ -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" + ] + ] diff --git a/xanthous.cabal b/xanthous.cabal index cb89323b2b..c7b19155dd 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -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 -- cgit 1.4.1