Factor out an EntityAttributes type

Factor out a new EntityAttributes type from some of the methods of the
Entity class, to avoid the proliferation of 1-argument boolean methods
on the entity class that always have to be forwarded through the Entity
instance for SomeEntity if they have defaults (forgetting to do which
has wasted tons of my time up to this point). Currently blocksVision,
blocksObject, and collision are all in there.

9 files changed, 98 insertions, 36 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