diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs | 201 |
1 files changed, 0 insertions, 201 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs b/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs deleted file mode 100644 index 1f2b513ffe0e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# 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 |