about summary refs log tree commit diff
path: root/src/Xanthous
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous')
-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
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
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-16T02·49+0000