Describe what you see when you walk over items

Every step the character takes, describe the entities at that position
excluding the character.

12 files changed, 82 insertions, 14 deletions

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