about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Xanthous/App.hs18
-rw-r--r--src/Xanthous/Entities.hs3
-rw-r--r--src/Xanthous/Entities/Character.hs1
-rw-r--r--src/Xanthous/Entities/Creature.hs12
-rw-r--r--src/Xanthous/Entities/Environment.hs2
-rw-r--r--src/Xanthous/Entities/Item.hs15
-rw-r--r--src/Xanthous/Entities/Raws/noodles.yaml2
-rw-r--r--src/Xanthous/Util/Inflection.hs15
-rw-r--r--src/Xanthous/messages.yaml3
-rw-r--r--test/Spec.hs2
-rw-r--r--test/Xanthous/Util/InflectionSpec.hs18
-rw-r--r--xanthous.cabal5
12 files changed, 82 insertions, 14 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index df0b30c41b5f..fce2beed13c1 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 e47e820f27ab..66a583f6b3fd 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 695d7bb0d0d1..924c1857a8ae 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 b59cceab4045..c660a6cdf5d4 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 d9275266b0f4..4ef67a577dbb 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 baf4be2f5426..6b50f50ad83c 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 120087d48357..91a0a35388ad 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 000000000000..fc66c0876125
--- /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 ef4f09543d49..4d7b0003fac7 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 cac474053ccb..7af988a3d7e3 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 000000000000..fad841043152
--- /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 cb89323b2b08..c7b19155dde4 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
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-03T09ยท44+0000