From 25a1c5ade32ee0dca41b8057f053972e4ab816d7 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 8 Feb 2020 17:24:27 -0500 Subject: [PATCH] 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. --- src/Xanthous/App.hs | 19 +++--- src/Xanthous/Data/Entities.hs | 68 ++++++++++++++++++++ src/Xanthous/Data/EntityMap/Graphics.hs | 4 +- src/Xanthous/Entities/Character.hs | 3 +- src/Xanthous/Entities/Creature.hs | 5 +- src/Xanthous/Entities/Entities.hs | 3 +- src/Xanthous/Entities/Environment.hs | 10 +-- src/Xanthous/Entities/Item.hs | 1 - src/Xanthous/Game/State.hs | 21 ++---- test/Spec.hs | 2 + test/Xanthous/Data/EntitiesSpec.hs | 28 ++++++++ test/Xanthous/Data/EntityMap/GraphicsSpec.hs | 1 - xanthous.cabal | 5 +- 13 files changed, 132 insertions(+), 38 deletions(-) create mode 100644 src/Xanthous/Data/Entities.hs create mode 100644 test/Xanthous/Data/EntitiesSpec.hs diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index d786eb29d..ab7c8f8e5 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 000000000..39953410f --- /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 30c6d0967..9064855bd 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 43d4f8a52..424488828 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 cc07b3560..e95e9f0b9 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 710e577be..55991fc28 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 430ce1b7a..b45a91eab 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 cedd75507..b50a5eab8 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 5c9130de3..100204c75 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 ba8f868a8..3790f3ce6 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 000000000..e40350374 --- /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 6b736be4e..9347a1c1b 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 702496b29..3dc2de467 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