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…
	
	Add table
		Add a link
		
	
		Reference in a new issue