-
Notifications
You must be signed in to change notification settings - Fork 55
/
EffectAction.hs
329 lines (310 loc) · 12.3 KB
/
EffectAction.hs
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
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
module EffectAction where
import Control.Monad
import Control.Monad.State hiding (State)
import Data.Function
import Data.List as L
import Data.Map as M
import qualified Data.IntMap as IM
import Data.Maybe
import Data.Set as S
import System.Time
import Control.Exception (assert)
import Action
import Display hiding (display)
import Dungeon
import Geometry
import Grammar
import qualified HighScores as H
import Item
import qualified ItemKind
import qualified Keys as K
import Level
import LevelState
import Message
import Movable
import MovableState
import MovableKind
import MovableAdd
import Perception
import Random
import State
import qualified Config
import qualified Save
import Terrain
import qualified Effect
-- The effectToAction function and all it depends on.
-- This file should not depend on Action.hs nor ItemAction.hs.
-- | The source actor affects the target actor, with a given effect and power.
-- Both actors are on the current level and can be the same actor.
-- The bool result indicates if the actors identify the effect.
-- TODO: separately define messages for the case when source == target
-- and for the other case; then use the messages outside of effectToAction,
-- depending on the returned bool, perception and identity of the actors.
effectToAction :: Effect.Effect -> ActorId -> ActorId -> Int ->
Action (Bool, String)
effectToAction Effect.NoEffect source target power = nullEffect
effectToAction Effect.Heal _source target power = do
tm <- gets (getActor target)
if mhp tm >= nhpMax (mkind tm) || power <= 0
then nullEffect
else do
focusIfAHero target
let upd m = m { mhp = min (nhpMax (mkind m)) (mhp m + power) }
updateAnyActor target upd
return (True, subjectMovableVerb (mkind tm) "feel" ++ " better.")
effectToAction (Effect.Wound nDm) source target power = do
n <- liftIO $ rndToIO $ rollDice nDm
if (n + power <= 0) then nullEffect else do
focusIfAHero target
tm <- gets (getActor target)
let newHP = mhp tm - n - power
killed = newHP <= 0
msg = if source == target -- a potion of wounding, etc.
then subjectMovableVerb (mkind tm) "feel"
++ if killed then " mortally" else ""
++ " wounded."
else if killed
then if isAHero target
then ""
else subjectMovableVerb (mkind tm) "die" ++ "."
else if isAHero target
then subjectMovableVerb (mkind tm) "lose"
++ " " ++ show (n + power) ++ "HP."
else subjectMovableVerb (mkind tm) "hiss" ++ " in pain."
updateAnyActor target $ \ m -> m { mhp = newHP } -- Damage the target.
when killed $ do
-- Place the actor's possessions on the map.
modify (updateLevel (dropItemsAt (mitems tm) (mloc tm)))
-- Clean bodies up.
pl <- gets splayer
if target == pl
then checkPartyDeath -- kills the player and checks game over
else modify (deleteActor target) -- kills the enemy
return (True, msg)
effectToAction Effect.Dominate source target power =
if isAMonster target -- Monsters have weaker will than heroes.
then do
assertTrue $ selectPlayer target
-- Prevent AI from getting a few free moves until new player ready.
updatePlayerBody (\ m -> m { mtime = 0})
display
return (True, "")
else nullEffect
effectToAction Effect.SummonFriend source target power = do
tm <- gets (getActor target)
if isAHero source
then summonHeroes (1 + power) (mloc tm)
else summonMonsters (1 + power) (mloc tm)
return (True, "")
effectToAction Effect.SummonEnemy source target power = do
tm <- gets (getActor target)
if not $ isAHero source -- a trick: monster player will summon a hero
then summonHeroes (1 + power) (mloc tm)
else summonMonsters (1 + power) (mloc tm)
return (True, "")
effectToAction Effect.ApplyPerfume source target _ =
if source == target
then return (True, "Tastes like water, but with a strong rose scent.")
else do
let upd lvl = lvl { lsmell = M.map (const (-100)) (lsmell lvl) }
modify (updateLevel upd)
return (True, "The fragrance quells all scents in the vicinity.")
effectToAction Effect.Regneration source target power =
effectToAction Effect.Heal source target power
effectToAction Effect.Searching source target power =
return (True, "It gets lost and you search in vain.")
nullEffect :: Action (Bool, String)
nullEffect = return (False, "Nothing happens.")
-- | The source actor affects the target actor, with a given item.
-- If either actor is a hero, the item may get identified.
itemEffectAction :: ActorId -> ActorId -> Item -> Action Bool
itemEffectAction source target item = do
state <- get
pl <- gets splayer
tm <- gets (getActor target)
per <- currentPerception
let effect = ItemKind.jeffect $ ItemKind.getIK $ ikind item
-- The message describes the target part of the action.
(b, msg) <- effectToAction effect source target (ipower item)
-- Determine how the player perceives the event.
-- TODO: factor it out as a function messageActor
-- and messageActorVerb (incorporating subjectActorVerb).
if mloc tm `S.member` ptvisible per
then messageAdd msg
else if not b
then return () -- Victim is not seen, nothing interestng happens.
else messageAdd "You hear some noises."
-- If something happens, the item gets identified.
when (b && (isAHero source || isAHero target)) $ discover item
return b
-- | Given item is now known to the player.
discover :: Item -> Action ()
discover i = do
state <- get
let ik = ikind i
obj = unwords $ tail $ words $ objectItem state i
msg = "The " ++ obj ++ " turns out to be "
kind = ItemKind.getIK ik
alreadyIdentified = L.length (ItemKind.jflavour kind) == 1 ||
ik `S.member` sdiscoveries state
if alreadyIdentified
then return ()
else do
modify (updateDiscoveries (S.insert ik))
state <- get
messageAdd $ msg ++ objectItem state i ++ "."
-- | Make the actor controlled by the player.
-- Focus on the actor if level changes. False, if nothing to do.
selectPlayer :: ActorId -> Action Bool
selectPlayer actor =
do
pl <- gets splayer
if (actor == pl)
then return False -- already selected
else do
state <- get
case findActorAnyLevel actor state of
Nothing -> abortWith $ "No such member of the party."
Just (nln, pbody) -> do
-- Make the new actor the player-controlled actor.
modify (\ s -> s { splayer = actor })
-- Record the original level of the new player.
modify (updateCursor (\ c -> c { creturnLn = nln }))
-- Don't continue an old run, if any.
stopRunning
-- Switch to the level.
lvlSwitch nln
-- Set smell display, depending on player capabilities.
-- This also resets FOV mode.
modify (\ s -> s { ssensory = if MovableKind.nsmell (mkind pbody)
then Smell
else Implicit })
-- Announce.
messageAdd $ subjectMovable (mkind pbody) ++ " selected."
return True
focusIfAHero :: ActorId -> Action ()
focusIfAHero target =
if isAHero target
then do
-- Focus on the hero being wounded/displaced/etc.
b <- selectPlayer target
-- Display status line for the new hero.
when b $ display >> return ()
else return ()
summonHeroes :: Int -> Loc -> Action ()
summonHeroes n loc =
assert (n > 0) $ do
newHeroIndex <- gets (fst . scounter)
modify (\ state -> iterate (addHero loc) state !! n)
assertTrue $ selectPlayer (AHero newHeroIndex)
-- Display status line for the new hero.
display >> return ()
summonMonsters :: Int -> Loc -> Action ()
summonMonsters n loc = do
let fmk = Frequency $ L.zip (L.map nfreq dungeonMonsters) dungeonMonsters
mk <- liftIO $ rndToIO $ frequency fmk
modify (\ state -> iterate (addMonster mk (nhpMax mk) loc) state !! n)
-- | Remove dead heroes, check if game over.
-- For now we only check the selected hero, but if poison, etc.
-- is implemented, we'd need to check all heroes on the level.
checkPartyDeath :: Action ()
checkPartyDeath =
do
ahs <- gets allHeroesAnyLevel
pl <- gets splayer
pbody <- gets getPlayerBody
config <- gets sconfig
when (mhp pbody <= 0) $ do -- TODO: change to guard? define mzero? Why are the writes to to files performed when I call abort later? That probably breaks the laws of MonadPlus.
go <- messageMoreConfirm ColorBW $
subjectMovableVerb (mkind pbody) "die" ++ "."
history -- Prevent the messages from being repeated.
let firstDeathEnds = Config.get config "heroes" "firstDeathEnds"
if firstDeathEnds
then gameOver go
else case L.filter (\ (actor, _) -> actor /= pl) ahs of
[] -> gameOver go
(actor, _nln) : _ -> do
messageAdd "The survivors carry on."
-- Remove the dead player.
modify (deleteActor pl)
-- At this place the invariant that the player exists fails.
-- Focus on the new hero (invariant not needed).
assertTrue $ selectPlayer actor
-- At this place the invariant is restored again.
-- | End game, showing the ending screens, if requested.
gameOver :: Bool -> Action ()
gameOver showEndingScreens =
do
when showEndingScreens $ do
state <- get
ln <- gets (lname . slevel)
let total = calculateTotal state
status = H.Killed ln
handleScores True status total
messageMore "Let's hope another party can save the day!"
end
-- | Calculate loot's worth for heroes on the current level.
calculateTotal :: State -> Int
calculateTotal s =
L.sum $ L.map itemPrice $ L.concatMap mitems (levelHeroList s)
-- | Handle current score and display it with the high scores. Scores
-- should not be shown during the game, because ultimately the worth of items might give
-- information about the nature of the items.
-- False if display of the scores was void or interrupted by the user
handleScores :: Bool -> H.Status -> Int -> Action Bool
handleScores write status total =
if (total == 0)
then return False
else do
config <- gets sconfig
time <- gets stime
curDate <- liftIO getClockTime
let points = case status of
H.Killed _ -> (total + 1) `div` 2
_ -> total
let score = H.ScoreRecord points (-time) curDate status
(placeMsg, slideshow) <- liftIO $ H.register config write score
messageOverlaysConfirm placeMsg slideshow
-- | Perform a level switch to a given level. False, if nothing to do.
lvlSwitch :: LevelName -> Action Bool
lvlSwitch nln =
do
ln <- gets (lname . slevel)
if (nln == ln)
then return False
else do
level <- gets slevel
dungeon <- gets sdungeon
-- put back current level
-- (first put back, then get, in case we change to the same level!)
let full = putDungeonLevel level dungeon
-- get new level
let (new, ndng) = getDungeonLevel nln full
modify (\ s -> s { sdungeon = ndng, slevel = new })
return True
-- effectToAction does not depend on this function right now, but it might,
-- and I know no better place to put it.
displayItems :: Message -> Bool -> [Item] -> Action Bool
displayItems msg sorted is = do
state <- get
let inv = unlines $
L.map (\ i -> letterLabel (iletter i) ++ objectItem state i ++ " ")
((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)
let ovl = inv ++ more
messageReset msg
overlay ovl
stopRunning :: Action ()
stopRunning = updatePlayerBody (\ p -> p { mdir = Nothing })
-- | Store current message in the history and reset current message.
history :: Action ()
history =
do
(_, sx) <- gets (lsize . slevel)
msg <- currentMessage
messageClear
config <- gets sconfig
let historyMax = Config.get config "ui" "historyMax"
-- TODO: not ideal, continuations of sentences are atop beginnings.
split = splitMsg sx (msg ++ " ")
unless (L.null msg) $
modify (updateHistory (take historyMax . (L.reverse split ++)))