1module Spell where
2
3import Control.Monad.State.Strict
4import qualified Data.Set as S
5import qualified Data.Map as M
6import qualified Data.CaseInsensitive as CI
7import qualified Data.Vector.Mutable as MV
8import Data.Char
9import Data.Maybe
10import Control.Monad.IfElse
11import UI.NCurses (Event(..))
12import Control.Applicative
13import Prelude
14
15import Spell.Enum
16import CharMap
17import Types
18import Player
19import Time
20import World
21import Status
22import Unicode
23import Level.Border
24import Rand
25import DeepCopy
26import Invert
27
28type SpellAction = M NextStep -> M NextStep
29
30-- All spells in the game. Note though that the spells active in the world
31-- can change at run time; it's in the state.
32allSpells :: S.Set Spell
33allSpells = S.fromList
34	[ spell SpellWhiteout "Whiteout" (++ " will clear the way ahead") whiteOut
35	, spell SpellGenocide "Genocide Letter" (\i -> "Use " ++ i ++ " with care, it wipes the scroll bare!" ) genocide
36	, spell SpellWish "Wish" (++ " will give you any letter you wish" ) wish
37	] `S.union` startingSpells `S.union` maybeStartingSpells
38
39-- Spells that the player starts off knowing. Both needed to get
40-- through the tutorial.
41startingSpells :: S.Set Spell
42startingSpells = S.fromList
43	[ spell SpellVomit "Vomit" (++ " helps when you've swallowed too many letters") vomit
44	, spell SpellNew "New" (++ "is a way to change what magic letters do") new
45	]
46
47-- Spells that the player may start off knowing. (Less powerful.)
48maybeStartingSpells :: S.Set Spell
49maybeStartingSpells = S.fromList
50	[ spell SpellDream "Dream" (++ " lulls you away into dreamland" ) dream
51	, spell SpellReverse "Reverse" (++ "turns back to front") reversePlayer
52	, spell SpellBerzerk "Berzerk" (++ " makes you mad and strong") berzerk
53	]
54
55invokeString :: String -> String
56invokeString ingredients = "\"" ++ map toUpper ingredients ++ "\""
57
58spell :: SpellEnum -> SpellName -> (String -> String) -> (M NextStep -> M NextStep) -> Spell
59spell spellenum name hint = Spell name
60	(hint (invokeString ingredients))
61	(S.fromList $ map CI.mk ingredients)
62	ingredients
63  where
64	ingredients = findingredients 0 ""
65	findingredients n s = case M.lookup (IngredientFor spellenum n) charUseMap of
66		Nothing
67			| null s -> error $ "Internal error: No ingredients defined for " ++ show spellenum
68			| otherwise -> reverse s
69		Just i -> findingredients (succ n) (i:s)
70
71vomit :: SpellAction
72vomit cont = do
73	showMessage "You cast a spell to clear your stomach."
74	p <- gets player
75	let l = catMaybes $ playerSwallowing p : (map segmentSwallowed (playerBody p))
76	removeIngredients' (S.fromList $ map CI.mk l)
77	modifyPlayer $ removeSwallowing (const True)
78	writeWorld (getPos p) '*'
79
80	when (playerLen p > 4 && length (playerBody p) > 4 && length l >= 3)  $ do
81		roll <- randM $ randomR (0, 15)
82		when (playerLen p > roll) $ do
83			modifyPlayer $ \pl -> pl
84				{ playerLen = playerLen pl - 1
85				, playerBody = reverse (drop 1 (reverse (playerBody pl)))
86				}
87			showMessage "You feel queasy after vomiting up those letters.. You lose a tail segment."
88	cont
89
90new :: SpellAction
91new = promptingredient
92  where
93	promptingredient cont = do
94		swallowed <- mapMaybe segmentSwallowed . playerBody <$> gets player
95		if null swallowed
96			then noingredients cont
97			else prompt ("Pick the new spell's ingredient: [" ++ swallowed ++ "]") $ \i ->
98				case i of
99					(EventCharacter c) | (CI.mk c `elem` map CI.mk swallowed) -> do
100						removeIngredients' (S.singleton (CI.mk c))
101						possibilities <- checkSpells (const True) <$> gets player
102						case possibilities of
103							[] -> noingredients cont
104							[s] -> do
105								addnewspell c s
106								cont
107							_ -> promptknownspell cont c
108					_ -> promptingredient cont
109
110	noingredients cont = do
111		showMessage "Failed to create new spell: You have no spell ingredients swallowed."
112		cont
113
114	promptknownspell cont ingredient = do
115		let retry = promptknownspell cont ingredient
116		prompt ("What spell should " ++ invokeString [ingredient] ++ " invoke?") $ \i ->
117			case i of
118				(EventCharacter c) -> do
119					p <- gets player
120					case toggleInvoke c p of
121						(InvokedChar, p') -> do
122							change p'
123							case checkInvokedSpells p' of
124								[] -> retry
125								l -> do
126									mapM_ (addnewspell ingredient) l
127									cont
128						(DeInvokedChar, p') -> do
129							change p'
130							retry
131						(NoInvoke, _) -> retry
132				_ -> retry
133	change p' = modifyPlayer (const p')
134
135	addnewspell ingredient basespell = do
136		let i = S.singleton (CI.mk ingredient)
137		let newspell = basespell { spellIngredients = i, spellWord = [ingredient] }
138		removeIngredients basespell
139		p <- gets player
140		change $ p { playerSpells = S.insert newspell (playerSpells p) }
141		showMessage $ "You can now cast " ++ spellName newspell ++ " using " ++ invokeString [ingredient]
142
143whiteOut :: SpellAction
144whiteOut cont = do
145	p <- gets player
146	writeWorld (playerHead p) ' '
147	modifyPlayer $ removeSwallowing (const True)
148	case playerBody p of
149		(s:_) | segmentDirection s /= DDive ->
150			showeffect (\n -> "You cast Whiteout forward " ++ show n ++ " spaces")
151				=<< beam
152					(directionOffset $ segmentDirection s)
153					(playerHead p)
154					(beamlength p)
155					(0 :: Integer)
156		_ -> showeffect (const "You cast Whiteout all around your head.")
157			=<< around (playerHead p)
158	cont
159  where
160	showeffect _ 0 = showMessage "The Whiteout has no effect on the scroll's border."
161	showeffect msg n = showMessage (msg n)
162
163	beamlength :: Player -> Integer
164	beamlength p = ceiling (fromIntegral (playerLen p) / if playerEnergized p then 1 else 2 :: Double)
165
166	beam _ _ 0 n = return n
167	beam offset pos len n = do
168		let pos' = offsetPos offset pos
169		ok <- effect pos'
170		if ok
171			then beam offset pos' (len - 1) (n + 1)
172			else return n
173
174	around pos = length . filter id
175		<$> mapM (effect . (`offsetPos` pos)) (zip offs offs)
176	offs = [succ, pred, id]
177
178	effect pos@(_x,y) = do
179		maxy <- worldHeight
180		if y >= maxy
181			then return False
182			else do
183				c <- readWorld pos
184				if isBoundry c || y >= maxy
185					then return False
186					else do
187						writeWorld pos ' '
188						return True
189
190genocide :: SpellAction
191genocide = promptletter
192  where
193	promptletter cont = prompt "Genocide which letter?" $ \i -> case i of
194		(EventCharacter c)
195			| isBoundry c || isSpace c -> do
196				showMessage "The spell fizzles and dies. Nice try."
197				cont
198			| otherwise -> removeall c cont
199		_ -> promptletter cont
200
201	removeall c cont = do
202		let toremove = CI.mk c
203		let removable = (== toremove)
204		p <- gets player
205		let playercharacters = '@' : map (bodyChar . segmentDirection) (playerBody p)
206		let selfgenocide = c `elem` playercharacters
207		energized <- playerEnergized <$> gets player
208		showMessage $ concat
209			[ "You genocided all "
210			, if energized then "" else "visible "
211			, if selfgenocide then [c] else unicodeCharString c ++ "'s!"
212			]
213		-- remove from mouth
214		modifyPlayer $ removeSwallowing (removable . CI.mk)
215		-- remove swallowed
216		removeIngredients' (S.singleton toremove)
217		-- remove from world
218		removeworld c
219		when energized $
220			removebuffer c
221		if selfgenocide
222			then do
223				showMessage "Sadly, that includes parts of you! You die.."
224				endThread
225			else cont
226
227	removeworld c = mapWorld $ \_ v -> return $
228		if (v == c)
229			then Just ' '
230			else Nothing
231
232	removebuffer c = do
233		b <- fst <$> gets bottomBuffer
234		let height = MV.length b
235		width <- worldWidth
236		let onb = \a -> lift (a b)
237		forM_ [0..height-1] $ \y ->
238			forM_ [0..width-1] $ \x -> do
239				v <- readS onb (x,y)
240				when (v == c) $
241					writeS onb (x,y) ' '
242
243dream :: SpellAction
244dream cont = do
245	-- Deep copy is needed because S contains mutable vectors,
246	-- and the dream would otherwise alter them.
247	st <- deepCopy =<< get
248	showMessage "You drift into a lucid dream..."
249	whenM (randM random) $
250		modify $ \s -> s { peruser = nightmarespeed (peruser s) }
251	runDream cont cont (wakeupstate st)
252  where
253  	-- In a nightmare, the scroll will seem to scroll faster.
254	nightmarespeed p@(Peruser { peruseSpeed = s } )
255		| s > 2 = p { peruseSpeed = s - 1 }
256		| otherwise = p
257	wakeupstate origst dreamst = origst
258		-- Propigate random source to avoid identical
259		-- game play; this was not a precognitive dream. ;)
260		{ randSource = randSource dreamst
261		-- Let the player learn new spells in the dream,
262		-- and use them upon awakening.
263		, spells = spells dreamst
264		-- If the player somehow didn't use help until in the
265		-- dream, propigate that state change too.
266		, helpShown = helpShown dreamst
267		}
268
269runDream :: M NextStep -> M NextStep -> (S -> S) -> M NextStep
270runDream sleepcont wakecont wakeupstate = go =<< sleepcont
271  where
272	go (NextStep v ms) = return $ NextStep v $ Just $ maybe wake (go <=<) ms
273
274	wake _evt = do
275		modify wakeupstate
276		showMessage $ "You wake from your dream, back where you were!"
277		wakecont
278
279berzerk :: SpellAction
280berzerk cont = do
281	showMessage "You fall into a mighty rage!"
282	modifyPlayer $ \p -> p { playerBerzerk = True }
283	p <- gets player
284	let len = playerLen p
285	duration <- randM $ randomR (len, len * 2)
286	let minduration = if playerEnergized p then 20 else 10
287	delayAction (min minduration duration) cont $
288		-- Multiple berzerk spells can be in effect;
289		-- the first to expire expires them all.
290		whenM (playerBerzerk <$> gets player) $ do
291			showMessage "You stop seeing red.."
292			modifyPlayer $ \pl -> pl
293				{ playerBerzerk = False
294				, playerEnergized = False
295				}
296
297reversePlayer :: SpellAction
298reversePlayer cont = do
299	p <- gets player
300	if null (playerBody p)
301		then fizzle
302		else if all (\s -> segmentSide s == CurrentSide) (playerBody p)
303			then do
304				modifyPlayer $ \_ -> invert p
305				success
306			else do
307				s <- get
308				let s' = flipOver s
309				put $ s' { player = invert (player s') }
310				success
311  where
312	fizzle = do
313		showMessage "The spell seems to do nothing much."
314		cont
315	success = do
316		showMessage "All of a sudden, you're going backwards!"
317		cont
318
319wish :: SpellAction
320wish cont = prompt ("What letter do you wish for?") $ \ev -> case ev of
321	(EventCharacter want) -> do
322		result <- if isSpace want
323			then do
324				roll <-randM $ randomR (1,10 :: Int)
325				if roll < 3
326					then return '|'
327					else return $ toUpper want
328			else return $ toUpper want
329		showMessage $ "A scattering of " ++ unicodeCharString result ++ "'s appear!"
330		width <- worldWidth
331		bodypos <- S.fromList <$> wormPositions
332		mapWorld $ \p@(x,_) c ->
333			if isSpace c || isBoundry c || p `S.member` bodypos
334				then return Nothing
335				else do
336					roll <- randM $ randomR (1,width)
337					return $ if roll == x
338						then Just result
339						else Nothing
340		cont
341	_ -> wish cont
342
343data ToggleInvokeResult
344	= InvokedChar
345	| DeInvokedChar
346	| NoInvoke
347
348toggleInvoke :: Char -> Player -> (ToggleInvokeResult, Player)
349toggleInvoke c p = case break matching (playerBody p) of
350	(_, []) -> (NoInvoke, p)
351	(presegs, s : postsegs) ->
352		let invoked = not (segmentInvoked s)
353		    s' = s { segmentInvoked = invoked }
354		    p' = p { playerBody = presegs ++ [s'] ++ postsegs }
355		    result = if invoked then InvokedChar else DeInvokedChar
356		in (result, p')
357  where
358	ci = CI.mk c
359	matching s = case segmentSwallowed s of
360		Just sc | CI.mk sc == ci -> True
361		_ -> False
362
363-- It's possible for multiple spells to use the same ingredients. In this
364-- case, all matching spells are returned.
365checkInvokedSpells :: Player -> [Spell]
366checkInvokedSpells = checkSpells segmentInvoked
367
368checkSpells :: (Segment -> Bool) -> Player -> [Spell]
369checkSpells f p = S.toList matches
370  where
371	ingredients = S.fromList $ map CI.mk $ catMaybes $
372		map avail $ playerBody p
373	avail s
374		| f s = segmentSwallowed s
375		| otherwise = Nothing
376	match sp = all (`S.member` ingredients) $ S.toList $ spellIngredients sp
377	matches = S.filter match (playerSpells p)
378
379removeIngredients :: Spell -> M ()
380removeIngredients = removeIngredients' . spellIngredients
381
382-- Remove spell ingredients from the map and from being swallowed.
383removeIngredients' :: S.Set (CI.CI Char) -> M ()
384removeIngredients' is = do
385	segs <- mapM go . playerBody =<< gets player
386	modifyPlayer $ \p -> p { playerBody = segs }
387  where
388	go seg = case segmentSwallowed seg of
389		Just c | S.member (CI.mk c) is -> do
390			case segmentSide seg of
391				CurrentSide -> writeWorld (getPos seg) ' '
392				FlipSide -> writeFlipSide (getPos seg) ' '
393				InSide -> return ()
394			return $ seg
395				{ segmentSwallowed = Nothing
396				, segmentInvoked = False
397				}
398		_ -> return seg
399
400-- Invokes all the listed spells, in order.
401invoke :: [Spell] -> M NextStep -> M NextStep
402invoke [] cont = cont
403invoke (s:rest) cont = do
404	isSpellCaster
405	removeIngredients s
406	spellAction s (invoke rest cont)
407
408teachRandomSpell :: Player -> M Player
409teachRandomSpell p = do
410	let known = playerSpells p
411	avail <- gets spells
412	let unknown = S.difference avail known
413	if S.null unknown
414		then do
415			showMessage "You wrack your brain, but any more spells, you'll have to learn."
416			return p
417		else go unknown
418  where
419	go set = do
420		s <- randFrom (S.toList set)
421		showMessage $ "You remember a spell: " ++ spellHint s
422		return $ p { playerSpells = S.insert s (playerSpells p) }
423
424spellInventory :: M [String]
425spellInventory = header . map fmt . S.toList . playerSpells <$> gets player
426  where
427	header l = "  Spell Inventory" : "" : l
428	fmt s = concat
429		[ "  "
430		, pad maxspellname $ spellName s
431		, pad 6 $ invokeString $ spellWord s
432		]
433	pad n s = s ++ (replicate (1 + n - length s) ' ')
434	maxspellname = maximum $ map (length . spellName) (S.toList allSpells)
435