about summary refs log tree commit diff
path: root/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs
blob: 1f2b513ffe0e84c39fd446684e8d65210dbef194 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
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