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