From 84f32efad4ff6d358fdeb985b3b4ac408e753b78 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 3 Jan 2020 18:28:43 -0500 Subject: 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. --- src/Xanthous/AI/Gormlak.hs | 4 ++-- src/Xanthous/Entities/Creature.hs | 1 + src/Xanthous/Entities/Creature.hs-boot | 2 -- src/Xanthous/Entities/Entities.hs | 1 + src/Xanthous/Entities/Environment.hs | 12 ++++++---- src/Xanthous/Entities/Item.hs | 1 + src/Xanthous/Game/Lenses.hs | 39 ++++++++++---------------------- src/Xanthous/Game/State.hs | 10 ++++++++ src/Xanthous/Generators/LevelContents.hs | 2 ++ 9 files changed, 37 insertions(+), 35 deletions(-) delete mode 100644 src/Xanthous/Entities/Creature.hs-boot diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index 031262533d21..8040fea35b8d 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -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') diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index 6e955324a06a..a44b3b22813b 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -68,6 +68,7 @@ instance Entity Creature where blocksVision _ = False description = view $ creatureType . Raw.description entityChar = view $ creatureType . char + entityCollision = const $ Just Combat -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Creature.hs-boot b/src/Xanthous/Entities/Creature.hs-boot deleted file mode 100644 index 4c930d26426d..000000000000 --- a/src/Xanthous/Entities/Creature.hs-boot +++ /dev/null @@ -1,2 +0,0 @@ -module Xanthous.Entities.Creature where -data Creature diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs index 8793565a2a34..1e533a297310 100644 --- a/src/Xanthous/Entities/Entities.hs +++ b/src/Xanthous/Entities/Entities.hs @@ -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 diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index 46416d1da59a..dee8d83c3239 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/src/Xanthous/Entities/Environment.hs @@ -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 diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs index 0156cd54c8a7..cedd75507a70 100644 --- a/src/Xanthous/Entities/Item.hs +++ b/src/Xanthous/Entities/Item.hs @@ -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 diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 580435a0688b..f7f4648dd5ed 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -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 diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 853d0b6922d1..171f381e6b74 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -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 diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index aaeb4a77fdda..96d64a693774 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -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 -- cgit 1.4.1