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:
Griffin Smith 2020-01-03 12:41:48 -05:00
parent c4351d46ef
commit 1b88921bc3
9 changed files with 149 additions and 81 deletions

View file

@ -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

View file

@ -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

View file

@ -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) #-}

View file

@ -0,0 +1,2 @@
module Xanthous.Entities.Creature where
data Creature

View 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

View file

@ -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
--------------------------------------------------------------------------------

View 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

View file

@ -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

View file

@ -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