scroll-1.20150313: Poison.hs

module Poison where

import Control.Monad.State.Strict
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as M
import Control.Applicative
import Data.Char
import Data.Maybe

import Types
import Rand
import Status
import Time
import Peruser
import Poison.Enum
import CharMap
import Player
import World

allPoisons :: M.Map (CI.CI Char) PoisonEffect
allPoisons = M.fromList
	[ (find PoisonMold, mold)
	, (find PoisonStunner, stunner)
	, (find PoisonFungus, fungus)
	]
  where
	find p = case M.lookup (Poison p) charUseMap of
		Nothing -> error $ "internal error; cannot find " ++ show p ++ " in charUseMap"
		Just c -> CI.mk c

mold :: PoisonEffect
mold c cont = do
	showMessage $ "You eat a moldy " ++ [toUpper c] ++ ". You feel lethargic.."
	origspeed <- peruseSpeed <$> gets peruser
	let newspeed = max 0 (origspeed - 2)
	let delta = origspeed - newspeed
	changePeruser $ \p -> p
		{ peruseSpeed = newspeed
		, peruseCountDown = peruseCountDown p - 1
		}
	duration <- randM $ randomR (10,15)
	delayAction duration cont $ do
		-- Note use of delta to restore, not origspeed.
		-- Other things may also be changing the peruser speed.
		changePeruser $ \p -> p { peruseSpeed = peruseSpeed p + delta }
		showMessage "You feel less lethargic now."

stunner :: PoisonEffect
stunner c cont = do
	showMessage $ "The " ++ [toUpper c] ++ " stuns you! You can't walk straight!"
	modifyPlayer $ \p -> p { playerStaggering = True }
	duration <- randM $ randomR (5,10)
	delayAction duration cont $ do
		modifyPlayer $ \p -> p { playerStaggering = False }
		len <- length . playerBody <$> gets player
		showMessage $ "You now feel more steady on your " ++ show (len * 2) ++ " tiny feet."

supportStaggaring :: Direction -> M Direction
supportStaggaring d = go . playerStaggering =<< gets player
  where
	go False = return d
	go True = do
		showMessage "Stunned, you stagger.."
		d' <- randFrom [minBound..maxBound]
		roll <- randFrom [1..10 :: Int]
		if roll < 8 && d' /= DDive
			then return d'
			else return d

fungus :: PoisonEffect
fungus = startFungalInfection

moreFungus :: PoisonEffect
moreFungus c cont = go =<< stillInfected c
  where
	go False = startFungalInfection c cont
	go True = do
		showMessage $ "Pushing through this fungus is slowing you down.."
		next $ \_ -> cont

startFungalInfection :: Char -> M NextStep -> M NextStep
startFungalInfection sporechar cont = do
	spreadFungus sporechar
	go =<< stillInfected sporechar
  where
	go True = do
		modify $ \s -> s { poisons = M.insert (CI.mk sporechar) moreFungus (poisons s) }
		showMessage $ "The fungal " ++ [toUpper sporechar] ++ " covers your body with spores! You should scrape them off somehow before they spread.."
		fork (fungalInfection sporechar) cont
	go False = do
		showMessage "You deftly avoid the fungal spores."
		cont

fungalInfection :: Char -> M NextStep
fungalInfection sporechar = go =<< stillInfected sporechar
  where
	go False = do
		showMessage "Finally you escaped the fungal infection!"
		endThread
	go True = do
		spreadFungus sporechar
		next $ \_ -> fungalInfection sporechar

spreadFungus :: Char -> M ()
spreadFungus sporechar = do
	-- Look for any whitespace surrounding the front half of
	-- the body, on the current scroll side, and plant fungus there.
	-- Note that fungus is not placed in front of the head.
	p <- gets player
	wp <- wormPositions
	let contagionzone = take ((playerLen p `div` 2) + 2) wp
	let exclusionzone = wp ++ (nearby $ playerHead p)
	wspos <- filter (`notElem` exclusionzone) . concat
		<$> mapM (findNearby isSpace) contagionzone
	mapM_ (growSpore sporechar) wspos

-- If there is no more fungus around the worm's tail the infection is over.
stillInfected :: Char -> M Bool
stillInfected sporechar = not . null . concat 
	<$> (mapM (findNearby (== sporechar)) =<< wormTailPositions)

growSpore :: Char -> Pos -> M ()
growSpore sporechar p = do
	roll <- randFrom [1..10 :: Int]
	when (roll > 3) $
		writeWorld p sporechar

nearby :: Pos -> [Pos]
nearby pos = map (flip offsetPos pos . directionOffset)
	[DLeft, DRight, DUp, DDown]

findNearby :: (Char -> Bool) -> Pos -> M [Pos]
findNearby want pos = catMaybes <$> mapM check (nearby pos)
  where
	check p = do
		v <- readWorldSafe p
		case v of
			Just c | want c -> return (Just p)
			_ -> return Nothing