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

@@ -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.Hippocampus
-import           Xanthous.Entities.Creature
-                 ( Creature, hippocampus, creatureType
-                 , destination, destinationProgress, destinationPosition
-                 )
 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
+  -> Positioned entity
-  -> m (Positioned Creature)
+  -> 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
+instance (IsCreature entity) => Brain (GormlakBrain entity) where
-  step ticks = fmap coerce . stepGormlak ticks . coerce
+  step ticks
+    = fmap (fmap GormlakBrain)
+    . stepGormlak ticks
+    . fmap _unGormlakBrain
   entityCanMove = const True
 
 --------------------------------------------------------------------------------
 
-instance Brain Creature where
+-- instance Brain Creature where
-  step = brainVia GormlakBrain
+--   step = brainVia GormlakBrain
-  entityCanMove = const True
+--   entityCanMove = const True
 
-instance Entity Creature where
+-- instance Entity Creature where
-  blocksVision _ = False
+--   blocksVision _ = False
-  description = view $ Creature.creatureType . Raw.description
+--   description = view $ Creature.creatureType . Raw.description
-  entityChar = view $ Creature.creatureType . char
+--   entityChar = view $ Creature.creatureType . char

src/Xanthous/AI/Gormlak.hs-boot

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

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
+import           Xanthous.AI.Gormlak
-                 hiding (Creature, description, damage)
+import           Xanthous.Entities.RawTypes hiding
+                 (Creature, description, damage)
+import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Game.State
 import           Xanthous.Data
---------------------------------------------------------------------------------
+import           Xanthous.Entities.Creature.Hippocampus
-
-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
-
 --------------------------------------------------------------------------------
 
 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) #-}

src/Xanthous/Entities/Creature.hs-boot

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

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

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

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

src/Xanthous/Game/Lenses.hs

@@ -28,8 +28,8 @@ 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           {-# SOURCE #-} Xanthous.Entities.Creature (Creature)
-import           Xanthous.Entities.Entities ()
+import           {-# SOURCE #-} Xanthous.Entities.Entities ()
 --------------------------------------------------------------------------------
 
 getInitialState :: IO GameState

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