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