diff options
Diffstat (limited to 'users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs')
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs b/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs new file mode 100644 index 0000000000..1f2b513ffe --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs @@ -0,0 +1,201 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +module Xanthous.AI.Gormlak + ( HasVisionRadius(..) + , GormlakBrain(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lines) +-------------------------------------------------------------------------------- +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, _Position + , diffPositions, stepTowards, isUnit + , Ticks, (|*|), invertedRate + ) +import Xanthous.Data.EntityMap +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, HasLanguage(language), getLanguage + , HasAttacks (attacks), creatureAttackMessage + ) +import Xanthous.Entities.Common + ( wielded, Inventory, wieldedItems, WieldedItem (WieldedItem) ) +import Xanthous.Game.State +import Xanthous.Game.Lenses + ( entitiesCollision, collisionAt + , character, characterPosition, positionIsCharacterVisible + , hearingRadius + ) +import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) +import Xanthous.Random +import Xanthous.Monad (say, message) +import Xanthous.Generators.Speech (word) +import qualified Linear.Metric as Metric +import qualified Xanthous.Messages as Messages +-------------------------------------------------------------------------------- + +-- 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 + , HasField "_inventory" entity entity Inventory Inventory + , A.ToJSON entity + ) + +-------------------------------------------------------------------------------- + +stepGormlak + :: forall entity m. + ( MonadState GameState m, MonadRandom m + , IsCreature entity + ) + => Ticks + -> Positioned entity + -> m (Positioned entity) +stepGormlak ticks pe@(Positioned pos creature) = do + canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision + + let selectDestination pos' creature' = destinationFromPos <$> do + if canSeeCharacter + then do + charPos <- use characterPosition + if isUnit (pos' `diffPositions` charPos) + then attackCharacter $> pos' + else pure $ pos' `stepTowards` charPos + else do + 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') + <$> use entities + line <- choose $ weightedBy length lines + pure $ fromMaybe pos' $ fmap fst . headMay =<< line + + pe' <- if canSeeCharacter && not (creature ^. creatureGreeted) + then yellAtCharacter $> (pe & positioned . creatureGreeted .~ True) + else pure pe + + dest <- maybe (selectDestination pos creature) pure + . mfilter (\(Destination p _) -> p /= pos) + $ creature ^. hippocampus . destination + let progress' = + dest ^. destinationProgress + + creature ^. creatureType . Raw.speed . invertedRate |*| ticks + if progress' < 1 + then pure + $ pe' + & positioned . 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 + collisionAt newPos >>= \case + Nothing -> pure $ pe'' & position .~ newPos + Just Stop -> pure pe'' + Just Combat -> do + ents <- use $ entities . atPosition newPos + when (any (entityIs @Character) ents) attackCharacter + pure pe' + where + vision = visionRadius creature + attackCharacter = do + dmg <- case creature ^? inventory . wielded . wieldedItems of + Just (WieldedItem item wi) -> do + let msg = fromMaybe + (Messages.lookup ["combat", "creatureAttack", "genericWeapon"]) + $ wi ^. creatureAttackMessage + message msg $ object [ "creature" A..= creature + , "item" A..= item + ] + pure $ wi ^. Raw.damage + Nothing -> do + attack <- choose $ creature ^. creatureType . attacks + attackDescription <- Messages.render (attack ^. Raw.description) + $ object [] + say ["combat", "creatureAttack", "natural"] + $ object [ "creature" A..= creature + , "attackDescription" A..= attackDescription + ] + pure $ attack ^. Raw.damage + + character %= Character.damage dmg + + yellAtCharacter = for_ (creature ^. creatureType . language) + $ \lang -> do + utterance <- fmap (<> "!") . word $ getLanguage lang + creatureSaysText pe utterance + + creatureGreeted :: Lens' entity Bool + creatureGreeted = hippocampus . greetedCharacter + + +-- | A creature sends some text +-- +-- If that creature is visible to the character, its description will be +-- included, otherwise if it's within earshot the character will just hear the +-- sound +creatureSaysText + :: (MonadState GameState m, MonadRandom m, IsCreature entity) + => Positioned entity + -> Text + -> m () +creatureSaysText ent txt = do + let entPos = ent ^. position . _Position . to (fmap fromIntegral) + charPos <- use $ characterPosition . _Position . to (fmap fromIntegral) + let dist :: Int + dist = round $ Metric.distance @_ @Double entPos charPos + audible = dist <= fromIntegral hearingRadius + when audible $ do + visible <- positionIsCharacterVisible $ ent ^. position + let path = ["entities", "say", "creature"] + <> [if visible then "visible" else "invisible"] + params = object [ "creature" A..= (ent ^. positioned) + , "message" A..= txt + ] + say path params + +newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity } + +instance (IsCreature entity) => Brain (GormlakBrain entity) where + step ticks + = fmap (fmap GormlakBrain) + . stepGormlak ticks + . fmap _unGormlakBrain + entityCanMove = const True + +hippocampus :: HasField "_hippocampus" s t a b => Lens s t a b +hippocampus = field @"_hippocampus" + +creatureType :: HasField "_creatureType" s t a b => Lens s t a b +creatureType = field @"_creatureType" + +inventory :: HasField "_inventory" s t a b => Lens s t a b +inventory = field @"_inventory" + +-------------------------------------------------------------------------------- + +-- 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 |