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:
parent
782d3880c8
commit
25a1c5ade3
13 changed files with 132 additions and 38 deletions
|
@ -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, _) ->
|
||||
|
|
68
src/Xanthous/Data/Entities.hs
Normal file
68
src/Xanthous/Data/Entities.hs
Normal 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
|
||||
}
|
|
@ -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
|
||||
|
|
|
@ -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 _ = "@"
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 = "<"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
28
test/Xanthous/Data/EntitiesSpec.hs
Normal file
28
test/Xanthous/Data/EntitiesSpec.hs
Normal 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
|
||||
]
|
||||
]
|
|
@ -42,6 +42,5 @@ instance Brain TestEntity where
|
|||
step _ = pure
|
||||
instance Draw TestEntity
|
||||
instance Entity TestEntity where
|
||||
blocksVision _ = False
|
||||
description _ = ""
|
||||
entityChar _ = "e"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue