Track entity collision in the Entity class

Rather than having a single function in the Game.Lenses module for
determining what collision type if any an entity has, track it in the
Entity typeclass itself. This is both more extensible and a better
separation of concerns and gets rid of one of the two needs for a
circular import. Yay!

As part of this, I realized nothing was being done to prevent doors from
being placed on tiles that already had walls (since now that was
properly causing a collision!) so I've fixed that as well.
This commit is contained in:
Griffin Smith 2020-01-03 18:28:43 -05:00
parent 1b88921bc3
commit 84f32efad4
9 changed files with 37 additions and 35 deletions

View file

@ -27,7 +27,7 @@ import qualified Xanthous.Entities.RawTypes as Raw
import Xanthous.Entities.RawTypes (CreatureType) import Xanthous.Entities.RawTypes (CreatureType)
import Xanthous.Game.State import Xanthous.Game.State
import Xanthous.Game.Lenses import Xanthous.Game.Lenses
( Collision(..), entityCollision, collisionAt ( Collision(..), entitiesCollision, collisionAt
, character, characterPosition , character, characterPosition
) )
import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
@ -90,7 +90,7 @@ stepGormlak ticks pe@(Positioned pos creature) = do
then attackCharacter $> pos' then attackCharacter $> pos'
else pure $ pos' `stepTowards` charPos else pure $ pos' `stepTowards` charPos
else do else do
lines <- map (takeWhile (isNothing . entityCollision . map snd . snd) lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd)
-- the first item on these lines is always the creature itself -- the first item on these lines is always the creature itself
. fromMaybe mempty . tailMay) . fromMaybe mempty . tailMay)
. linesOfSight pos' (visionRadius creature') . linesOfSight pos' (visionRadius creature')

View file

@ -68,6 +68,7 @@ instance Entity Creature where
blocksVision _ = False blocksVision _ = False
description = view $ creatureType . Raw.description description = view $ creatureType . Raw.description
entityChar = view $ creatureType . char entityChar = view $ creatureType . char
entityCollision = const $ Just Combat
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -1,2 +0,0 @@
module Xanthous.Entities.Creature where
data Creature

View file

@ -47,6 +47,7 @@ instance Entity SomeEntity where
blocksVision (SomeEntity ent) = blocksVision ent blocksVision (SomeEntity ent) = blocksVision ent
description (SomeEntity ent) = description ent description (SomeEntity ent) = description ent
entityChar (SomeEntity ent) = entityChar ent entityChar (SomeEntity ent) = entityChar ent
entityCollision (SomeEntity ent) = entityCollision ent
instance Function SomeEntity where instance Function SomeEntity where
function = functionJSON function = functionJSON

View file

@ -91,6 +91,8 @@ instance Entity Door where
description door | door ^. open = "an open door" description door | door ^. open = "an open door"
| otherwise = "a closed door" | otherwise = "a closed door"
entityChar _ = "d" entityChar _ = "d"
entityCollision door | door ^. open = Nothing
| otherwise = Just Stop
-- | A closed, unlocked door -- | A closed, unlocked door
unlockedDoor :: Door unlockedDoor :: Door
@ -113,8 +115,10 @@ newtype GroundMessage = GroundMessage Text
deriving Draw deriving Draw
via DrawStyledCharacter ('Just 'Yellow) 'Nothing "" via DrawStyledCharacter ('Just 'Yellow) 'Nothing ""
GroundMessage GroundMessage
deriving Entity
via DeriveEntity 'False "a message on the ground. Press r. to read it."
""
GroundMessage
instance Brain GroundMessage where step = brainVia Brainless 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

View file

@ -41,6 +41,7 @@ instance Entity Item where
blocksVision _ = False blocksVision _ = False
description = view $ itemType . Raw.description description = view $ itemType . Raw.description
entityChar = view $ itemType . Raw.char entityChar = view $ itemType . Raw.char
entityCollision = const Nothing
newWithType :: ItemType -> Item newWithType :: ItemType -> Item
newWithType = Item newWithType = Item

View file

@ -1,4 +1,6 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Game.Lenses module Xanthous.Game.Lenses
( positionedCharacter ( positionedCharacter
@ -11,7 +13,7 @@ module Xanthous.Game.Lenses
-- * Collisions -- * Collisions
, Collision(..) , Collision(..)
, entityCollision , entitiesCollision
, collisionAt , collisionAt
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -26,9 +28,6 @@ import Xanthous.Data
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap.Graphics (visiblePositions) import Xanthous.Data.EntityMap.Graphics (visiblePositions)
import Xanthous.Entities.Character (Character, mkCharacter) import Xanthous.Entities.Character (Character, mkCharacter)
import Xanthous.Entities.Environment (Door, open, GroundMessage)
import Xanthous.Entities.Item (Item)
import {-# SOURCE #-} Xanthous.Entities.Creature (Creature)
import {-# SOURCE #-} Xanthous.Entities.Entities () import {-# SOURCE #-} Xanthous.Entities.Entities ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -96,31 +95,17 @@ characterVisiblePositions game =
let charPos = game ^. characterPosition let charPos = game ^. characterPosition
in visiblePositions charPos visionRadius $ game ^. entities in visiblePositions charPos visionRadius $ game ^. entities
data Collision entitiesCollision
= Stop :: ( Functor f
| Combat , forall xx. MonoFoldable (f xx)
deriving stock (Show, Eq, Ord, Generic) , forall xx. Element (f xx) ~ xx
deriving anyclass (NFData) , Element (f (Maybe Collision)) ~ Maybe Collision
, Show (f (Maybe Collision))
entityCollision , Show (f SomeEntity)
:: ( MonoFoldable (f SomeEntity)
, Foldable f
, Element (f SomeEntity) ~ SomeEntity
, AsEmpty (f SomeEntity)
) )
=> f SomeEntity => f SomeEntity
-> Maybe Collision -> Maybe Collision
entityCollision Empty = Nothing entitiesCollision = join . maximumMay . fmap entityCollision
entityCollision ents
-- TODO track entity collision in the Entity class
| any (entityIs @Creature) ents = pure Combat
| all (\e ->
entityIs @Item e
|| entityIs @GroundMessage e
) ents = Nothing
| doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
, all (view open) doors = Nothing
| otherwise = pure Stop
collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
collisionAt pos = uses (entities . EntityMap.atPosition pos) entityCollision collisionAt pos = uses (entities . EntityMap.atPosition pos) entitiesCollision

View file

@ -34,6 +34,7 @@ module Xanthous.Game.State
, Brain(..) , Brain(..)
, Brainless(..) , Brainless(..)
, brainVia , brainVia
, Collision(..)
, Entity(..) , Entity(..)
, SomeEntity(..) , SomeEntity(..)
, downcastEntity , downcastEntity
@ -306,6 +307,13 @@ 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 class ( Show a, Eq a, Ord a, NFData a
, ToJSON a, FromJSON a , ToJSON a, FromJSON a
, Draw a, Brain a , Draw a, Brain a
@ -313,6 +321,8 @@ class ( Show a, Eq a, Ord a, NFData a
blocksVision :: a -> Bool blocksVision :: a -> Bool
description :: a -> Text description :: a -> Text
entityChar :: a -> EntityChar entityChar :: a -> EntityChar
entityCollision :: a -> Maybe Collision
entityCollision = const $ Just Stop
data SomeEntity where data SomeEntity where
SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity

View file

@ -45,6 +45,8 @@ randomDoors cells = do
candidateCells = filter doorable $ Arr.indices cells candidateCells = filter doorable $ Arr.indices cells
subsetRange = (0.8 :: Double, 1.0) subsetRange = (0.8 :: Double, 1.0)
doorable (x, y) = doorable (x, y) =
not (fromMaybe True $ cells ^? ix (x, y))
&&
( fromMaybe True $ cells ^? ix (x - 1, y) -- left ( fromMaybe True $ cells ^? ix (x - 1, y) -- left
, fromMaybe True $ cells ^? ix (x, y - 1) -- top , fromMaybe True $ cells ^? ix (x, y - 1) -- top
, fromMaybe True $ cells ^? ix (x + 1, y) -- right , fromMaybe True $ cells ^? ix (x + 1, y) -- right