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.
This commit is contained in:
parent
c4351d46ef
commit
1b88921bc3
9 changed files with 149 additions and 81 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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) #-}
|
||||
|
|
2
src/Xanthous/Entities/Creature.hs-boot
Normal file
2
src/Xanthous/Entities/Creature.hs-boot
Normal file
|
@ -0,0 +1,2 @@
|
|||
module Xanthous.Entities.Creature where
|
||||
data Creature
|
64
src/Xanthous/Entities/Creature/Hippocampus.hs
Normal file
64
src/Xanthous/Entities/Creature/Hippocampus.hs
Normal file
|
@ -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
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
14
src/Xanthous/Entities/Entities.hs-boot
Normal file
14
src/Xanthous/Entities/Entities.hs-boot
Normal file
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue