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.
This commit is contained in:
Griffin Smith 2020-02-08 17:24:27 -05:00
parent 782d3880c8
commit 25a1c5ade3
13 changed files with 132 additions and 38 deletions

View file

@ -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, _) ->

View file

@ -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
}

View file

@ -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

View file

@ -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 _ = "@"

View file

@ -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

View file

@ -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

View file

@ -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 = "<"

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
]
]

View file

@ -42,6 +42,5 @@ instance Brain TestEntity where
step _ = pure
instance Draw TestEntity
instance Entity TestEntity where
blocksVision _ = False
description _ = ""
entityChar _ = "e"

View file

@ -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