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.Game.State
|
||||
import Xanthous.Game.Lenses
|
||||
( Collision(..), entityCollision, collisionAt
|
||||
( Collision(..), entitiesCollision, collisionAt
|
||||
, character, characterPosition
|
||||
)
|
||||
import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee)
|
||||
|
@ -90,7 +90,7 @@ stepGormlak ticks pe@(Positioned pos creature) = do
|
|||
then attackCharacter $> pos'
|
||||
else pure $ pos' `stepTowards` charPos
|
||||
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
|
||||
. fromMaybe mempty . tailMay)
|
||||
. linesOfSight pos' (visionRadius creature')
|
||||
|
|
|
@ -68,6 +68,7 @@ instance Entity Creature where
|
|||
blocksVision _ = False
|
||||
description = view $ creatureType . Raw.description
|
||||
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
|
||||
description (SomeEntity ent) = description ent
|
||||
entityChar (SomeEntity ent) = entityChar ent
|
||||
entityCollision (SomeEntity ent) = entityCollision ent
|
||||
|
||||
instance Function SomeEntity where
|
||||
function = functionJSON
|
||||
|
|
|
@ -91,6 +91,8 @@ instance Entity Door where
|
|||
description door | door ^. open = "an open door"
|
||||
| otherwise = "a closed door"
|
||||
entityChar _ = "d"
|
||||
entityCollision door | door ^. open = Nothing
|
||||
| otherwise = Just Stop
|
||||
|
||||
-- | A closed, unlocked door
|
||||
unlockedDoor :: Door
|
||||
|
@ -113,8 +115,10 @@ newtype GroundMessage = GroundMessage Text
|
|||
deriving Draw
|
||||
via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
|
||||
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 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
|
||||
description = view $ itemType . Raw.description
|
||||
entityChar = view $ itemType . Raw.char
|
||||
entityCollision = const Nothing
|
||||
|
||||
newWithType :: ItemType -> Item
|
||||
newWithType = Item
|
||||
|
|
|
@ -1,4 +1,6 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Game.Lenses
|
||||
( positionedCharacter
|
||||
|
@ -11,7 +13,7 @@ module Xanthous.Game.Lenses
|
|||
|
||||
-- * Collisions
|
||||
, Collision(..)
|
||||
, entityCollision
|
||||
, entitiesCollision
|
||||
, collisionAt
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -26,9 +28,6 @@ import Xanthous.Data
|
|||
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||
import Xanthous.Data.EntityMap.Graphics (visiblePositions)
|
||||
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 ()
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -96,31 +95,17 @@ characterVisiblePositions game =
|
|||
let charPos = game ^. characterPosition
|
||||
in visiblePositions charPos visionRadius $ game ^. entities
|
||||
|
||||
data Collision
|
||||
= Stop
|
||||
| Combat
|
||||
deriving stock (Show, Eq, Ord, Generic)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
entityCollision
|
||||
:: ( MonoFoldable (f SomeEntity)
|
||||
, Foldable f
|
||||
, Element (f SomeEntity) ~ SomeEntity
|
||||
, AsEmpty (f SomeEntity)
|
||||
entitiesCollision
|
||||
:: ( Functor f
|
||||
, forall xx. MonoFoldable (f xx)
|
||||
, forall xx. Element (f xx) ~ xx
|
||||
, Element (f (Maybe Collision)) ~ Maybe Collision
|
||||
, Show (f (Maybe Collision))
|
||||
, Show (f SomeEntity)
|
||||
)
|
||||
=> f SomeEntity
|
||||
-> Maybe Collision
|
||||
entityCollision Empty = Nothing
|
||||
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
|
||||
entitiesCollision = join . maximumMay . fmap entityCollision
|
||||
|
||||
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(..)
|
||||
, Brainless(..)
|
||||
, brainVia
|
||||
, Collision(..)
|
||||
, Entity(..)
|
||||
, SomeEntity(..)
|
||||
, 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
|
||||
, ToJSON a, FromJSON a
|
||||
, Draw a, Brain a
|
||||
|
@ -313,6 +321,8 @@ class ( Show a, Eq a, Ord a, NFData a
|
|||
blocksVision :: a -> Bool
|
||||
description :: a -> Text
|
||||
entityChar :: a -> EntityChar
|
||||
entityCollision :: a -> Maybe Collision
|
||||
entityCollision = const $ Just Stop
|
||||
|
||||
data SomeEntity where
|
||||
SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity
|
||||
|
|
|
@ -45,6 +45,8 @@ randomDoors cells = do
|
|||
candidateCells = filter doorable $ Arr.indices cells
|
||||
subsetRange = (0.8 :: Double, 1.0)
|
||||
doorable (x, y) =
|
||||
not (fromMaybe True $ cells ^? ix (x, y))
|
||||
&&
|
||||
( fromMaybe True $ cells ^? ix (x - 1, y) -- left
|
||||
, fromMaybe True $ cells ^? ix (x, y - 1) -- top
|
||||
, fromMaybe True $ cells ^? ix (x + 1, y) -- right
|
||||
|
|
Loading…
Reference in a new issue