scroll-1.20250228: Spell.hs

module Spell where

import Control.Monad.State.Strict
import Control.Monad (when)
import Control.Monad.Compat ((<=<))
import Data.Foldable (forM_)
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.CaseInsensitive as CI
import qualified Data.Vector.Mutable as MV
import Data.Char
import Data.Maybe
import Control.Monad.IfElse
import Control.Applicative
import Prelude

import Spell.Enum
import CharMap
import Types
import Player
import Time
import World
import Status
import Unicode
import Level.Border
import Rand
import DeepCopy
import Invert
import Term

type SpellAction = M NextStep -> M NextStep

-- All spells in the game. Note though that the spells active in the world
-- can change at run time; it's in the state.
allSpells :: S.Set Spell
allSpells = S.fromList
	[ spell SpellWhiteout "Whiteout" (++ " will clear the way ahead") whiteOut
	, spell SpellGenocide "Genocide Letter" (\i -> "Use " ++ i ++ " with care, it wipes the scroll bare!" ) genocide
	, spell SpellWish "Wish" (++ " will give you any letter you wish" ) wish
	] `S.union` startingSpells `S.union` maybeStartingSpells

-- Spells that the player starts off knowing. Both needed to get
-- through the tutorial.
startingSpells :: S.Set Spell
startingSpells = S.fromList
	[ spell SpellVomit "Vomit" (++ " helps when you've swallowed too many letters") vomit
	, spell SpellNew "New" (++ "is a way to change what magic letters do") new
	]

-- Spells that the player may start off knowing. (Less powerful.)
maybeStartingSpells :: S.Set Spell
maybeStartingSpells = S.fromList
	[ spell SpellDream "Dream" (++ " lulls you away into dreamland" ) dream  
	, spell SpellReverse "Reverse" (++ "turns back to front") reversePlayer
	, spell SpellBerzerk "Berzerk" (++ " makes you mad and strong") berzerk
	]

invokeString :: String -> String
invokeString ingredients = "\"" ++ map toUpper ingredients ++ "\""

spell :: SpellEnum -> SpellName -> (String -> String) -> (M NextStep -> M NextStep) -> Spell
spell spellenum name hint = Spell name 
	(hint (invokeString ingredients))
	(S.fromList $ map CI.mk ingredients)
	ingredients
  where
	ingredients = findingredients 0 ""
	findingredients n s = case M.lookup (IngredientFor spellenum n) charUseMap of
		Nothing
			| null s -> error $ "Internal error: No ingredients defined for " ++ show spellenum
			| otherwise -> reverse s
		Just i -> findingredients (succ n) (i:s)

vomit :: SpellAction
vomit cont = do
	showMessage "You cast a spell to clear your stomach."
	p <- gets player
	let l = catMaybes $ playerSwallowing p : (map segmentSwallowed (playerBody p))
	removeIngredients' (S.fromList $ map CI.mk l)
	modifyPlayer $ removeSwallowing (const True)
	writeWorld (getPos p) '*'

	when (playerLen p > 4 && length (playerBody p) > 4 && length l >= 3)  $ do
		roll <- randM $ randomR (0, 15)
		when (playerLen p > roll) $ do
			modifyPlayer $ \pl -> pl
				{ playerLen = playerLen pl - 1
				, playerBody = reverse (drop 1 (reverse (playerBody pl)))
				}
			showMessage "You feel queasy after vomiting up those letters.. You lose a tail segment."
	cont

new :: SpellAction
new = promptingredient
  where
	promptingredient cont = do
		swallowed <- mapMaybe segmentSwallowed . playerBody <$> gets player
		if null swallowed 
			then noingredients cont
			else prompt ("Pick the new spell's ingredient: [" ++ swallowed ++ "]") $ \i ->
				case inputCharacter i of
					Just c | (CI.mk c `elem` map CI.mk swallowed) -> do
						removeIngredients' (S.singleton (CI.mk c))
						possibilities <- checkSpells (const True) <$> gets player
						case possibilities of
							[] -> noingredients cont
							[s] -> do
								addnewspell c s
								cont
							_ -> promptknownspell cont c
					_ -> promptingredient cont
	
	noingredients cont = do
		showMessage "Failed to create new spell: You have no spell ingredients swallowed."
		cont

	promptknownspell cont ingredient = do
		let retry = promptknownspell cont ingredient
		prompt ("What spell should " ++ invokeString [ingredient] ++ " invoke?") $ \i ->
			case inputCharacter i of
				Just c -> do
					p <- gets player
					case toggleInvoke c p of
						(InvokedChar, p') -> do
							change p'
							case checkInvokedSpells p' of
								[] -> retry
								l -> do
									mapM_ (addnewspell ingredient) l
									cont
						(DeInvokedChar, p') -> do
							change p'
							retry
						(NoInvoke, _) -> retry
				Nothing -> retry
	change p' = modifyPlayer (const p')

	addnewspell ingredient basespell = do
		let i = S.singleton (CI.mk ingredient)
		let newspell = basespell { spellIngredients = i, spellWord = [ingredient] }
		removeIngredients basespell
		p <- gets player
		change $ p { playerSpells = S.insert newspell (playerSpells p) }
		showMessage $ "You can now cast " ++ spellName newspell ++ " using " ++ invokeString [ingredient]

whiteOut :: SpellAction
whiteOut cont = do
	p <- gets player
	writeWorld (playerHead p) ' '
	modifyPlayer $ removeSwallowing (const True)
	case playerBody p of
		(s:_) | segmentDirection s /= DDive ->
			showeffect (\n -> "You cast Whiteout forward " ++ show n ++ " spaces") 
				=<< beam 
					(directionOffset $ segmentDirection s)
					(playerHead p)
					(beamlength p)
					(0 :: Integer)
		_ -> showeffect (const "You cast Whiteout all around your head.")
			=<< around (playerHead p)
	cont
  where
	showeffect _ 0 = showMessage "The Whiteout has no effect on the scroll's border."
	showeffect msg n = showMessage (msg n)

	beamlength :: Player -> Integer
	beamlength p = ceiling (fromIntegral (playerLen p) / if playerEnergized p then 1 else 2 :: Double)

	beam _ _ 0 n = return n
	beam offset pos len n = do
		let pos' = offsetPos offset pos
		ok <- effect pos'
		if ok
			then beam offset pos' (len - 1) (n + 1)
			else return n

	around pos = length . filter id
		<$> mapM (effect . (`offsetPos` pos)) (zip offs offs)
	offs = [succ, pred, id]

	effect pos@(_x,y) = do
		maxy <- worldHeight
		if y >= maxy
			then return False
			else do
				c <- readWorld pos
				if isBoundry c || y >= maxy
					then return False
					else do
						writeWorld pos ' '
						return True

genocide :: SpellAction
genocide = promptletter
  where
	promptletter cont = prompt "Genocide which letter?" $ \i -> case inputCharacter i of
		Just c
			| isBoundry c || isSpace c -> do
				showMessage "The spell fizzles and dies. Nice try."
				cont
			| otherwise -> removeall c cont
		Nothing -> promptletter cont

	removeall c cont = do
		let toremove = CI.mk c
		let removable = (== toremove)
		p <- gets player
		let playercharacters = '@' : map (bodyChar . segmentDirection) (playerBody p)
		let selfgenocide = c `elem` playercharacters
		energized <- playerEnergized <$> gets player
		showMessage $ concat
			[ "You genocided all "
			, if energized then "" else "visible "
			, if selfgenocide then [c] else unicodeCharString c ++ "'s!"
			]
		-- remove from mouth
		modifyPlayer $ removeSwallowing (removable . CI.mk)
		-- remove swallowed
		removeIngredients' (S.singleton toremove)
		-- remove from world
		removeworld c
		when energized $
			removebuffer c
		if selfgenocide
			then do
				showMessage "Sadly, that includes parts of you! You die.."
				endThread
			else cont

	removeworld c = mapWorld $ \_ v -> return $
		if (v == c)
			then Just ' '
			else Nothing

	removebuffer c = do
		b <- fst <$> gets bottomBuffer
		let height = MV.length b
		width <- worldWidth
		let onb = \a -> lift (a b)
		forM_ [0..height-1] $ \y ->
			forM_ [0..width-1] $ \x -> do
				v <- readS onb (x,y)
				when (v == c) $
					writeS onb (x,y) ' '

dream :: SpellAction
dream cont = do
	-- Deep copy is needed because S contains mutable vectors,
	-- and the dream would otherwise alter them.
	st <- deepCopy =<< get
	showMessage "You drift into a lucid dream..."
	whenM (randM random) $
		modify $ \s -> s { peruser = nightmarespeed (peruser s) }
	runDream cont cont (wakeupstate st)
  where
  	-- In a nightmare, the scroll will seem to scroll faster.
	nightmarespeed p@(Peruser { peruseSpeed = s } )
		| s > 2 = p { peruseSpeed = s - 1 }
		| otherwise = p
	wakeupstate origst dreamst = origst
		-- Propigate random source to avoid identical
		-- game play; this was not a precognitive dream. ;)
		{ randSource = randSource dreamst
		-- Let the player learn new spells in the dream,
		-- and use them upon awakening.
		, spells = spells dreamst
		-- If the player somehow didn't use help until in the
		-- dream, propigate that state change too.
		, helpShown = helpShown dreamst
		}

runDream :: M NextStep -> M NextStep -> (S -> S) -> M NextStep
runDream sleepcont wakecont wakeupstate = go =<< sleepcont
  where
	go (NextStep v ms) = return $ NextStep v $ Just $ maybe wake (go <=<) ms

	wake _evt = do
		modify wakeupstate
		showMessage $ "You wake from your dream, back where you were!"
		wakecont

berzerk :: SpellAction
berzerk cont = do
	showMessage "You fall into a mighty rage!"
	modifyPlayer $ \p -> p { playerBerzerk = True }
	p <- gets player
	let len = playerLen p
	duration <- randM $ randomR (len, len * 2)
	let minduration = if playerEnergized p then 20 else 10
	delayAction (min minduration duration) cont $
		-- Multiple berzerk spells can be in effect;
		-- the first to expire expires them all.
		whenM (playerBerzerk <$> gets player) $ do
			showMessage "You stop seeing red.."
			modifyPlayer $ \pl -> pl
				{ playerBerzerk = False
				, playerEnergized = False
				}

reversePlayer :: SpellAction
reversePlayer cont = do
	p <- gets player
	if null (playerBody p)
		then fizzle
		else if all (\s -> segmentSide s == CurrentSide) (playerBody p)
			then do
				modifyPlayer $ \_ -> invert p
				success
			else do
				s <- get
				let s' = flipOver s
				put $ s' { player = invert (player s') }
				success
  where
	fizzle = do
		showMessage "The spell seems to do nothing much."
		cont
	success = do
		showMessage "All of a sudden, you're going backwards!"
		cont

wish :: SpellAction
wish cont = prompt ("What letter do you wish for?") $ \ev -> case inputCharacter ev of
	Just want -> do
		result <- if isSpace want
			then do
				roll <-randM $ randomR (1,10 :: Int)
				if roll < 3
					then return '|'
					else return $ toUpper want
			else return $ toUpper want
		showMessage $ "A scattering of " ++ unicodeCharString result ++ "'s appear!"
		width <- worldWidth
		bodypos <- S.fromList <$> wormPositions
		mapWorld $ \p@(x,_) c ->
			if isSpace c || isBoundry c || p `S.member` bodypos
				then return Nothing
				else do
					roll <- randM $ randomR (1,width)
					return $ if roll == x
						then Just result
						else Nothing
		cont
	Nothing -> wish cont

data ToggleInvokeResult
	= InvokedChar
	| DeInvokedChar
	| NoInvoke

toggleInvoke :: Char -> Player -> (ToggleInvokeResult, Player)
toggleInvoke c p = case break matching (playerBody p) of
	(_, []) -> (NoInvoke, p)
	(presegs, s : postsegs) ->
		let invoked = not (segmentInvoked s)
		    s' = s { segmentInvoked = invoked }
		    p' = p { playerBody = presegs ++ [s'] ++ postsegs }
		    result = if invoked then InvokedChar else DeInvokedChar
		in (result, p')
  where
	ci = CI.mk c
	matching s = case segmentSwallowed s of
		Just sc | CI.mk sc == ci -> True
		_ -> False

-- It's possible for multiple spells to use the same ingredients. In this
-- case, all matching spells are returned.
checkInvokedSpells :: Player -> [Spell]
checkInvokedSpells = checkSpells segmentInvoked

checkSpells :: (Segment -> Bool) -> Player -> [Spell]
checkSpells f p = S.toList matches
  where
	ingredients = S.fromList $ map CI.mk $ catMaybes $
		map avail $ playerBody p
	avail s
		| f s = segmentSwallowed s
		| otherwise = Nothing
	match sp = all (`S.member` ingredients) $ S.toList $ spellIngredients sp
	matches = S.filter match (playerSpells p)

removeIngredients :: Spell -> M ()
removeIngredients = removeIngredients' . spellIngredients

-- Remove spell ingredients from the map and from being swallowed.
removeIngredients' :: S.Set (CI.CI Char) -> M ()
removeIngredients' is = do
	segs <- mapM go . playerBody =<< gets player
	modifyPlayer $ \p -> p { playerBody = segs }
  where
	go seg = case segmentSwallowed seg of
		Just c | S.member (CI.mk c) is -> do
			case segmentSide seg of
				CurrentSide -> writeWorld (getPos seg) ' '
				FlipSide -> writeFlipSide (getPos seg) ' '
				InSide -> return ()
			return $ seg
				{ segmentSwallowed = Nothing
				, segmentInvoked = False
				}
		_ -> return seg

-- Invokes all the listed spells, in order.
invoke :: [Spell] -> M NextStep -> M NextStep
invoke [] cont = cont
invoke (s:rest) cont = do
	isSpellCaster
	removeIngredients s
	spellAction s (invoke rest cont)

teachRandomSpell :: Player -> M Player
teachRandomSpell p = do
	let known = playerSpells p
	avail <- gets spells
	let unknown = S.difference avail known
	if S.null unknown
		then do
			showMessage "You wrack your brain, but any more spells, you'll have to learn."
			return p
		else go unknown
  where
	go set = do
		s <- randFrom (S.toList set)
		showMessage $ "You remember a spell: " ++ spellHint s
		return $ p { playerSpells = S.insert s (playerSpells p) }

spellInventory :: M [String]
spellInventory = header . map fmt . S.toList . playerSpells <$> gets player
  where
	header l = "  Spell Inventory" : "" : l
	fmt s = concat 
		[ "  "
		, pad maxspellname $ spellName s
		, pad 6 $ invokeString $ spellWord s
		]
	pad n s = s ++ (replicate (1 + n - length s) ' ')
	maxspellname = maximum $ map (length . spellName) (S.toList allSpells)