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:
parent
1b88921bc3
commit
84f32efad4
9 changed files with 37 additions and 35 deletions
|
@ -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')
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -1,2 +0,0 @@
|
||||||
module Xanthous.Entities.Creature where
|
|
||||||
data Creature
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue