about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Xanthous/App.hs19
-rw-r--r--src/Xanthous/Data/Entities.hs68
-rw-r--r--src/Xanthous/Data/EntityMap/Graphics.hs4
-rw-r--r--src/Xanthous/Entities/Character.hs3
-rw-r--r--src/Xanthous/Entities/Creature.hs5
-rw-r--r--src/Xanthous/Entities/Entities.hs3
-rw-r--r--src/Xanthous/Entities/Environment.hs10
-rw-r--r--src/Xanthous/Entities/Item.hs1
-rw-r--r--src/Xanthous/Game/State.hs21
-rw-r--r--test/Spec.hs2
-rw-r--r--test/Xanthous/Data/EntitiesSpec.hs28
-rw-r--r--test/Xanthous/Data/EntityMap/GraphicsSpec.hs1
-rw-r--r--xanthous.cabal5
13 files changed, 132 insertions, 38 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index d786eb29daa3..ab7c8f8e5049 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -35,6 +35,7 @@ import           Xanthous.Data.EntityMap (EntityMap)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.Levels (prevLevel, nextLevel)
 import qualified Xanthous.Data.Levels as Levels
+import           Xanthous.Data.Entities (blocksObject)
 import           Xanthous.Game
 import           Xanthous.Game.State
 import           Xanthous.Game.Draw (drawGame)
@@ -205,17 +206,19 @@ handleCommand Close = do
         . EntityMap.atPositionWithIDs pos
       if | null doors -> say_ ["close", "nothingToClose"]
          | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"]
-         | any (blocksObject . snd) nonDoors ->
+         | any (view blocksObject . entityAttributes . snd) nonDoors ->
            say ["close", "blocked"]
            $ object [ "entityDescriptions"
-                    A..= ( toSentence . map description . filter blocksObject
-                         . map snd
-                         ) nonDoors
+                      A..= ( toSentence
+                           . map description
+                           . filter (view blocksObject . entityAttributes)
+                           . map snd
+                           ) nonDoors
                     , "blockOrBlocks"
-                    A..= ( if length nonDoors == 1
-                           then "blocks"
-                           else "block"
-                         :: Text)
+                      A..= ( if length nonDoors == 1
+                             then "blocks"
+                             else "block"
+                           :: Text)
                     ]
          | otherwise -> do
              for_ doors $ \(eid, _) ->
diff --git a/src/Xanthous/Data/Entities.hs b/src/Xanthous/Data/Entities.hs
new file mode 100644
index 000000000000..39953410f2f3
--- /dev/null
+++ b/src/Xanthous/Data/Entities.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.Entities
+  ( -- * Collisions
+    Collision(..)
+  , _Stop
+  , _Combat
+    -- * Entity Attributes
+  , EntityAttributes(..)
+  , blocksVision
+  , blocksObject
+  , collision
+  , defaultEntityAttributes
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (ToJSON(..), FromJSON(..), (.:?), (.!=), withObject)
+import           Data.Aeson.Generic.DerivingVia
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Test.QuickCheck
+--------------------------------------------------------------------------------
+
+data Collision
+  = Stop   -- ^ Can't move through this
+  | Combat -- ^ Moving into this equates to hitting it with a stick
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Collision
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ AllNullaryToStringTag 'True ]
+           Collision
+makePrisms ''Collision
+
+-- | Attributes of an entity
+data EntityAttributes = EntityAttributes
+  { _blocksVision :: Bool
+    -- | Does this entity block a large object from being put in the same tile as
+    -- it - eg a a door being closed on it
+  , _blocksObject :: Bool
+    -- | What type of collision happens when moving into this entity?
+  , _collision :: Collision
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EntityAttributes
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           EntityAttributes
+makeLenses ''EntityAttributes
+
+instance FromJSON EntityAttributes where
+  parseJSON = withObject "EntityAttributes" $ \o -> do
+    _blocksVision <- o .:? "blocksVision"
+                      .!= _blocksVision defaultEntityAttributes
+    _blocksObject <- o .:? "blocksObject"
+                      .!= _blocksObject defaultEntityAttributes
+    _collision    <- o .:? "collision"
+                      .!= _collision defaultEntityAttributes
+    pure EntityAttributes {..}
+
+defaultEntityAttributes :: EntityAttributes
+defaultEntityAttributes = EntityAttributes
+  { _blocksVision = False
+  , _blocksObject = False
+  , _collision    = Stop
+  }
diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs
index 30c6d096737e..9064855bdbae 100644
--- a/src/Xanthous/Data/EntityMap/Graphics.hs
+++ b/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -11,6 +11,7 @@ import Xanthous.Prelude hiding (lines)
 --------------------------------------------------------------------------------
 import Xanthous.Util (takeWhileInclusive)
 import Xanthous.Data
+import Xanthous.Data.Entities
 import Xanthous.Data.EntityMap
 import Xanthous.Game.State
 import Xanthous.Util.Graphics (circle, line)
@@ -29,7 +30,8 @@ linesOfSight
   -> [[(Position, Vector (EntityID, e))]]
 linesOfSight (view _Position -> pos) visionRadius em
   = entitiesOnLines
-  <&> takeWhileInclusive (none (blocksVision . snd) . snd)
+  <&> takeWhileInclusive
+      (none (view blocksVision . entityAttributes . snd) . snd)
   where
     radius = circle pos $ fromIntegral visionRadius
     lines = line pos <$> radius
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 43d4f8a52942..424488828c75 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -84,7 +84,7 @@ instance Draw WieldedItem where
   draw = draw . view wieldedItem
 
 instance Entity WieldedItem where
-  blocksVision = blocksVision . view wieldedItem
+  entityAttributes = entityAttributes . view wieldedItem
   description = description . view wieldedItem
   entityChar = entityChar . view wieldedItem
 
@@ -232,7 +232,6 @@ instance Brain Character where
     else hp + hitpointRecoveryRate |*| ticks
 
 instance Entity Character where
-  blocksVision _ = False
   description _ = "yourself"
   entityChar _ = "@"
 
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index cc07b3560c2c..e95e9f0b985b 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -40,6 +40,7 @@ import           Xanthous.Entities.RawTypes hiding
 import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Game.State
 import           Xanthous.Data
+import           Xanthous.Data.Entities
 import           Xanthous.Entities.Creature.Hippocampus
 --------------------------------------------------------------------------------
 
@@ -65,8 +66,8 @@ instance Brain Creature where
   entityCanMove = const True
 
 instance Entity Creature where
-  blocksVision _ = False
-  blocksObject _ = True
+  entityAttributes _ = defaultEntityAttributes
+    & blocksObject .~ True
   description = view $ creatureType . Raw.description
   entityChar = view $ creatureType . char
   entityCollision = const $ Just Combat
diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
index 710e577be866..55991fc28428 100644
--- a/src/Xanthous/Entities/Entities.hs
+++ b/src/Xanthous/Entities/Entities.hs
@@ -46,8 +46,7 @@ deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
   instance FromJSON GameState
 
 instance Entity SomeEntity where
-  blocksVision (SomeEntity ent) = blocksVision ent
-  blocksObject (SomeEntity ent) = blocksObject ent
+  entityAttributes (SomeEntity ent) = entityAttributes ent
   description (SomeEntity ent) = description ent
   entityChar (SomeEntity ent) = entityChar ent
   entityCollision (SomeEntity ent) = entityCollision ent
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 430ce1b7a99e..b45a91eabed2 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -29,6 +29,7 @@ import Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
 import Xanthous.Entities.Draw.Util
 import Xanthous.Data
+import Xanthous.Data.Entities
 import Xanthous.Game.State
 import Xanthous.Util.QuickCheck
 --------------------------------------------------------------------------------
@@ -48,7 +49,9 @@ instance FromJSON Wall where
 instance Brain Wall where step = brainVia Brainless
 
 instance Entity Wall where
-  blocksVision _ = True
+  entityAttributes _ = defaultEntityAttributes
+    & blocksVision .~ True
+    & blocksObject .~ True
   description _ = "a wall"
   entityChar _ = "┼"
 
@@ -93,7 +96,8 @@ instance Draw Door where
 instance Brain Door where step = brainVia Brainless
 
 instance Entity Door where
-  blocksVision = not . view open
+  entityAttributes door = defaultEntityAttributes
+    & blocksVision .~ not (door ^. open)
   description door | door ^. open = "an open door"
                    | otherwise    = "a closed door"
   entityChar _ = "d"
@@ -127,7 +131,6 @@ newtype GroundMessage = GroundMessage Text
 instance Brain GroundMessage where step = brainVia Brainless
 
 instance Entity GroundMessage where
-  blocksVision = const False
   description = const "a message on the ground. Press r. to read it."
   entityChar = const "≈"
   entityCollision = const Nothing
@@ -150,7 +153,6 @@ instance Draw Staircase where
   draw DownStaircase = str ">"
 
 instance Entity Staircase where
-  blocksVision = const False
   description UpStaircase = "a staircase leading upwards"
   description DownStaircase = "a staircase leading downwards"
   entityChar UpStaircase = "<"
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
index cedd75507a70..b50a5eab809d 100644
--- a/src/Xanthous/Entities/Item.hs
+++ b/src/Xanthous/Entities/Item.hs
@@ -38,7 +38,6 @@ instance Arbitrary Item where
   arbitrary = Item <$> arbitrary
 
 instance Entity Item where
-  blocksVision _ = False
   description = view $ itemType . Raw.description
   entityChar = view $ itemType . Raw.char
   entityCollision = const Nothing
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 5c9130de386a..100204c755c3 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -92,6 +92,7 @@ import           Xanthous.Data.Levels
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data.EntityChar
 import           Xanthous.Data.VectorBag
+import           Xanthous.Data.Entities
 import           Xanthous.Orphans ()
 import           Xanthous.Game.Prompt
 import           Xanthous.Resource
@@ -315,24 +316,12 @@ brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
 
 --------------------------------------------------------------------------------
 
-
-data Collision
-  = Stop   -- ^ Can't move through this
-  | Combat -- ^ Moving into this equates to hitting it with a stick
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (NFData)
-
 class ( Show a, Eq a, Ord a, NFData a
       , ToJSON a, FromJSON a
       , Draw a, Brain a
       ) => Entity a where
-  blocksVision :: a -> Bool
-
-  -- | Does this entity block a large object from being put in the same tile as
-  -- it - eg a a door being closed on it
-  blocksObject :: a -> Bool
-  blocksObject = const False
-
+  entityAttributes :: a -> EntityAttributes
+  entityAttributes = const defaultEntityAttributes
   description :: a -> Text
   entityChar :: a -> EntityChar
   entityCollision :: a -> Maybe Collision
@@ -406,8 +395,8 @@ instance
   , Draw entity, Brain entity
   )
   => Entity (DeriveEntity blocksVision description entityChar entity) where
-
-  blocksVision _ = boolVal @blocksVision
+  entityAttributes _ = defaultEntityAttributes
+    & blocksVision .~ boolVal @blocksVision
   description _ = pack . symbolVal $ Proxy @description
   entityChar _ = fromString . symbolVal $ Proxy @entityChar
 
diff --git a/test/Spec.hs b/test/Spec.hs
index ba8f868a8172..3790f3ce65ba 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -5,6 +5,7 @@ import qualified Xanthous.Data.EntityCharSpec
 import qualified Xanthous.Data.EntityMapSpec
 import qualified Xanthous.Data.EntityMap.GraphicsSpec
 import qualified Xanthous.Data.LevelsSpec
+import qualified Xanthous.Data.EntitiesSpec
 import qualified Xanthous.DataSpec
 import qualified Xanthous.Entities.RawsSpec
 import qualified Xanthous.GameSpec
@@ -26,6 +27,7 @@ test = testGroup "Xanthous"
   , Xanthous.Data.EntityMapSpec.test
   , Xanthous.Data.EntityMap.GraphicsSpec.test
   , Xanthous.Data.LevelsSpec.test
+  , Xanthous.Data.EntitiesSpec.test
   , Xanthous.Entities.RawsSpec.test
   , Xanthous.GameSpec.test
   , Xanthous.Generators.UtilSpec.test
diff --git a/test/Xanthous/Data/EntitiesSpec.hs b/test/Xanthous/Data/EntitiesSpec.hs
new file mode 100644
index 000000000000..e403503743c0
--- /dev/null
+++ b/test/Xanthous/Data/EntitiesSpec.hs
@@ -0,0 +1,28 @@
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntitiesSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+--------------------------------------------------------------------------------
+import           Xanthous.Data.Entities
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Data.Entities"
+  [ testGroup "Collision"
+    [ testProperty "JSON round-trip" $ \(c :: Collision) ->
+        JSON.decode (JSON.encode c) === Just c
+    , testGroup "JSON encoding examples"
+      [ testCase "Stop" $ JSON.encode Stop @?= "\"Stop\""
+      , testCase "Combat" $ JSON.encode Combat @?= "\"Combat\""
+      ]
+    ]
+  , testGroup "EntityAttributes"
+    [ testProperty "JSON round-trip" $ \(ea :: EntityAttributes) ->
+        JSON.decode (JSON.encode ea) === Just ea
+    ]
+  ]
diff --git a/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
index 6b736be4ee21..9347a1c1b569 100644
--- a/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
+++ b/test/Xanthous/Data/EntityMap/GraphicsSpec.hs
@@ -42,6 +42,5 @@ instance Brain TestEntity where
   step _ = pure
 instance Draw TestEntity
 instance Entity TestEntity where
-  blocksVision _ = False
   description _ = ""
   entityChar _ = "e"
diff --git a/xanthous.cabal b/xanthous.cabal
index 702496b2906d..3dc2de467f9b 100644
--- a/xanthous.cabal
+++ b/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: eb0a7cd56cc2ea885be582c8ea7113a5f50f96a8d1b12ed27ca1a0271a45ad03
+-- hash: 09d294830fde12021527c15ba1e1698afdec092a16c4171ee67dce3256fe0d96
 
 name:           xanthous
 version:        0.1.0.0
@@ -34,6 +34,7 @@ library
       Xanthous.App
       Xanthous.Command
       Xanthous.Data
+      Xanthous.Data.Entities
       Xanthous.Data.EntityChar
       Xanthous.Data.EntityMap
       Xanthous.Data.EntityMap.Graphics
@@ -141,6 +142,7 @@ executable xanthous
       Xanthous.App
       Xanthous.Command
       Xanthous.Data
+      Xanthous.Data.Entities
       Xanthous.Data.EntityChar
       Xanthous.Data.EntityMap
       Xanthous.Data.EntityMap.Graphics
@@ -245,6 +247,7 @@ test-suite test
   main-is: Spec.hs
   other-modules:
       Test.Prelude
+      Xanthous.Data.EntitiesSpec
       Xanthous.Data.EntityCharSpec
       Xanthous.Data.EntityMap.GraphicsSpec
       Xanthous.Data.EntityMapSpec
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-11T12·53+0000