From 1b88921bc36e5da1ade5c52827d057dc2be65bc5 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 3 Jan 2020 12:41:48 -0500 Subject: Decouple Gormlak AI from creatures Decouple the definition of the Gormlak AI from the creature type itself using generic lenses and a "HasVisionRadius" typeclass, to begin to untangle the hs-boot web of circular dependencies. This actually *increases* the number of hs-boot files from 1 to 2, but both of the source imports that use them are single-instance (unlike gormlak AI which I would expect to grow linearly with the growth of the game), plus at least one should be able to go away once we remove collision from the game lenses module and move it into something defined in the entity class itself. --- src/Xanthous/AI/Gormlak.hs | 74 +++++++++++++++++---------- src/Xanthous/AI/Gormlak.hs-boot | 7 --- src/Xanthous/Entities/Creature.hs | 58 ++++++--------------- src/Xanthous/Entities/Creature.hs-boot | 2 + src/Xanthous/Entities/Creature/Hippocampus.hs | 64 +++++++++++++++++++++++ src/Xanthous/Entities/Entities.hs | 1 - src/Xanthous/Entities/Entities.hs-boot | 14 +++++ src/Xanthous/Game/Lenses.hs | 6 +-- xanthous.cabal | 4 +- 9 files changed, 149 insertions(+), 81 deletions(-) delete mode 100644 src/Xanthous/AI/Gormlak.hs-boot create mode 100644 src/Xanthous/Entities/Creature.hs-boot create mode 100644 src/Xanthous/Entities/Creature/Hippocampus.hs create mode 100644 src/Xanthous/Entities/Entities.hs-boot diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index 3e950f67f364..031262533d21 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -1,14 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -module Xanthous.AI.Gormlak () where +module Xanthous.AI.Gormlak + ( HasVisionRadius(..) + , GormlakBrain(..) + ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (lines) -------------------------------------------------------------------------------- -import Data.Coerce import Control.Monad.State import Control.Monad.Random import Data.Aeson (object) import qualified Data.Aeson as A +import Data.Generics.Product.Fields -------------------------------------------------------------------------------- import Xanthous.Data ( Positioned(..), positioned, position @@ -16,14 +20,11 @@ import Xanthous.Data , Ticks, (|*|), invertedRate ) import Xanthous.Data.EntityMap -import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Creature - ( Creature, hippocampus, creatureType - , destination, destinationProgress, destinationPosition - ) +import Xanthous.Entities.Creature.Hippocampus import Xanthous.Entities.Character (Character) import qualified Xanthous.Entities.Character as Character import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Entities.RawTypes (CreatureType) import Xanthous.Game.State import Xanthous.Game.Lenses ( Collision(..), entityCollision, collisionAt @@ -34,28 +35,44 @@ import Xanthous.Random import Xanthous.Monad (say) -------------------------------------------------------------------------------- +-- TODO move the following two classes to a more central location + +class HasVisionRadius a where visionRadius :: a -> Word + +type IsCreature entity = + ( HasVisionRadius entity + , HasField "_hippocampus" entity entity Hippocampus Hippocampus + , HasField "_creatureType" entity entity CreatureType CreatureType + , A.ToJSON entity + ) + +-------------------------------------------------------------------------------- + stepGormlak - :: (MonadState GameState m, MonadRandom m) + :: forall entity m. + ( MonadState GameState m, MonadRandom m + , IsCreature entity + ) => Ticks - -> Positioned Creature - -> m (Positioned Creature) + -> Positioned entity + -> m (Positioned entity) stepGormlak ticks pe@(Positioned pos creature) = do dest <- maybe (selectDestination pos creature) pure - $ creature ^. hippocampus . destination + $ creature ^. field @"_hippocampus" . destination let progress' = dest ^. destinationProgress - + creature ^. creatureType . Raw.speed . invertedRate |*| ticks + + creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks if progress' < 1 then pure $ pe - & positioned . hippocampus . destination + & positioned . field @"_hippocampus" . destination ?~ (dest & destinationProgress .~ progress') else do let newPos = dest ^. destinationPosition remainingSpeed = progress' - 1 newDest <- selectDestination newPos creature <&> destinationProgress +~ remainingSpeed - let pe' = pe & positioned . hippocampus . destination ?~ newDest + let pe' = pe & positioned . field @"_hippocampus" . destination ?~ newDest collisionAt newPos >>= \case Nothing -> pure $ pe' & position .~ newPos Just Stop -> pure pe' @@ -64,7 +81,7 @@ stepGormlak ticks pe@(Positioned pos creature) = do when (any (entityIs @Character) ents) attackCharacter pure pe' where - selectDestination pos' creature' = Creature.destinationFromPos <$> do + selectDestination pos' creature' = destinationFromPos <$> do canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision if canSeeCharacter then do @@ -76,29 +93,32 @@ stepGormlak ticks pe@(Positioned pos creature) = do lines <- map (takeWhile (isNothing . entityCollision . map snd . snd) -- the first item on these lines is always the creature itself . fromMaybe mempty . tailMay) - . linesOfSight pos' (Creature.visionRadius creature') + . linesOfSight pos' (visionRadius creature') <$> use entities line <- choose $ weightedBy length lines pure $ fromMaybe pos' $ fmap fst . headMay =<< line - vision = Creature.visionRadius creature + vision = visionRadius creature attackCharacter = do say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] character %= Character.damage 1 -newtype GormlakBrain = GormlakBrain Creature +newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity } -instance Brain GormlakBrain where - step ticks = fmap coerce . stepGormlak ticks . coerce +instance (IsCreature entity) => Brain (GormlakBrain entity) where + step ticks + = fmap (fmap GormlakBrain) + . stepGormlak ticks + . fmap _unGormlakBrain entityCanMove = const True -------------------------------------------------------------------------------- -instance Brain Creature where - step = brainVia GormlakBrain - entityCanMove = const True +-- instance Brain Creature where +-- step = brainVia GormlakBrain +-- entityCanMove = const True -instance Entity Creature where - blocksVision _ = False - description = view $ Creature.creatureType . Raw.description - entityChar = view $ Creature.creatureType . char +-- instance Entity Creature where +-- blocksVision _ = False +-- description = view $ Creature.creatureType . Raw.description +-- entityChar = view $ Creature.creatureType . char diff --git a/src/Xanthous/AI/Gormlak.hs-boot b/src/Xanthous/AI/Gormlak.hs-boot deleted file mode 100644 index 47e62f624905..000000000000 --- a/src/Xanthous/AI/Gormlak.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Xanthous.AI.Gormlak where - -import Xanthous.Game.State -import Xanthous.Entities.Creature - -instance Entity Creature diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index 19c7834228e0..6e955324a06a 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -34,47 +34,13 @@ import Test.QuickCheck.Arbitrary.Generic import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes - hiding (Creature, description, damage) +import Xanthous.AI.Gormlak +import Xanthous.Entities.RawTypes hiding + (Creature, description, damage) +import qualified Xanthous.Entities.RawTypes as Raw import Xanthous.Game.State import Xanthous.Data --------------------------------------------------------------------------------- - -data Destination = Destination - { _destinationPosition :: !Position - -- | The progress towards the destination, tracked as an offset from the - -- creature's original position. - -- - -- When this value reaches >= 1, the creature has reached their destination - , _destinationProgress :: !Tiles - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Destination -instance Arbitrary Destination where arbitrary = genericArbitrary -makeLenses ''Destination - -destinationFromPos :: Position -> Destination -destinationFromPos _destinationPosition = - let _destinationProgress = 0 - in Destination{..} - -data Hippocampus = Hippocampus - { _destination :: !(Maybe Destination) - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Hippocampus -instance Arbitrary Hippocampus where arbitrary = genericArbitrary -makeLenses ''Hippocampus - -initialHippocampus :: Hippocampus -initialHippocampus = Hippocampus Nothing - +import Xanthous.Entities.Creature.Hippocampus -------------------------------------------------------------------------------- data Creature = Creature @@ -91,6 +57,17 @@ data Creature = Creature instance Arbitrary Creature where arbitrary = genericArbitrary makeLenses ''Creature +instance HasVisionRadius Creature where + visionRadius = const 50 -- TODO + +instance Brain Creature where + step = brainVia GormlakBrain + entityCanMove = const True + +instance Entity Creature where + blocksVision _ = False + description = view $ creatureType . Raw.description + entityChar = view $ creatureType . char -------------------------------------------------------------------------------- @@ -109,7 +86,4 @@ damage amount = hitpoints %~ \hp -> isDead :: Creature -> Bool isDead = views hitpoints (== 0) -visionRadius :: Creature -> Word -visionRadius = const 50 -- TODO - {-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/src/Xanthous/Entities/Creature.hs-boot b/src/Xanthous/Entities/Creature.hs-boot new file mode 100644 index 000000000000..4c930d26426d --- /dev/null +++ b/src/Xanthous/Entities/Creature.hs-boot @@ -0,0 +1,2 @@ +module Xanthous.Entities.Creature where +data Creature diff --git a/src/Xanthous/Entities/Creature/Hippocampus.hs b/src/Xanthous/Entities/Creature/Hippocampus.hs new file mode 100644 index 000000000000..501a5b597221 --- /dev/null +++ b/src/Xanthous/Entities/Creature/Hippocampus.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature.Hippocampus + (-- * Hippocampus + Hippocampus(..) + , initialHippocampus + -- ** Lenses + , destination + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress + ) +where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Data +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + + +data Destination = Destination + { _destinationPosition :: !Position + -- | The progress towards the destination, tracked as an offset from the + -- creature's original position. + -- + -- When this value reaches >= 1, the creature has reached their destination + , _destinationProgress :: !Tiles + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Destination +instance Arbitrary Destination where arbitrary = genericArbitrary +makeLenses ''Destination + +destinationFromPos :: Position -> Destination +destinationFromPos _destinationPosition = + let _destinationProgress = 0 + in Destination{..} + +data Hippocampus = Hippocampus + { _destination :: !(Maybe Destination) + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Hippocampus + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Hippocampus +makeLenses ''Hippocampus + +initialHippocampus :: Hippocampus +initialHippocampus = Hippocampus Nothing diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs index 802aecddebdf..8793565a2a34 100644 --- a/src/Xanthous/Entities/Entities.hs +++ b/src/Xanthous/Entities/Entities.hs @@ -14,7 +14,6 @@ import Xanthous.Entities.Item import Xanthous.Entities.Creature import Xanthous.Entities.Environment import Xanthous.Game.State -import {-# SOURCE #-} Xanthous.AI.Gormlak () import Xanthous.Util.QuickCheck import Data.Aeson.Generic.DerivingVia -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Entities.hs-boot b/src/Xanthous/Entities/Entities.hs-boot new file mode 100644 index 000000000000..519a862c6a5a --- /dev/null +++ b/src/Xanthous/Entities/Entities.hs-boot @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Xanthous.Entities.Entities where + +import Test.QuickCheck +import Data.Aeson +import Xanthous.Game.State (SomeEntity, GameState, Entity) + +instance Arbitrary SomeEntity +instance Function SomeEntity +instance CoArbitrary SomeEntity +instance FromJSON SomeEntity +instance Entity SomeEntity + +instance FromJSON GameState diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 4a080f85f017..580435a0688b 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -27,9 +27,9 @@ 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 Xanthous.Entities.Creature (Creature) -import Xanthous.Entities.Entities () +import Xanthous.Entities.Item (Item) +import {-# SOURCE #-} Xanthous.Entities.Creature (Creature) +import {-# SOURCE #-} Xanthous.Entities.Entities () -------------------------------------------------------------------------------- getInitialState :: IO GameState diff --git a/xanthous.cabal b/xanthous.cabal index f173b1a114a9..090739c2894b 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a4f6c2c91e3c94c81de5d6b27201cb22e7f9f9c5d8a4f14beec63c1540d01ca1 +-- hash: 36af39a9e3b4e97923c1b363d7d84e2c99f126efd908778d0d048d0c472f2723 name: xanthous version: 0.1.0.0 @@ -40,6 +40,7 @@ library Xanthous.Data.VectorBag Xanthous.Entities.Character Xanthous.Entities.Creature + Xanthous.Entities.Creature.Hippocampus Xanthous.Entities.Draw.Util Xanthous.Entities.Entities Xanthous.Entities.Environment @@ -141,6 +142,7 @@ executable xanthous Xanthous.Data.VectorBag Xanthous.Entities.Character Xanthous.Entities.Creature + Xanthous.Entities.Creature.Hippocampus Xanthous.Entities.Draw.Util Xanthous.Entities.Entities Xanthous.Entities.Environment -- cgit 1.4.1