scroll-1.20150313: Control.hs

module Control where

import Control.Monad.State.Strict
import UI.NCurses (Event(..), Key(..))
import qualified Data.Map as M
import Data.Maybe
import Control.Applicative

import Types
import Status
import Time
import Player
import Player.Move
import Peruser
import Spell
import CharMap
import Poison
import Help
import View
import Curses

mainLoop :: Step
mainLoop (EventCharacter '\t') = forceRedraw
mainLoop (EventCharacter c) = case M.lookup c charMap of
	Just (CharControl (Movement d)) -> move d
	Just (CharControl Inventory) -> inventory
	Just (CharControl Help) -> showHelp
	Just (CharControl Quit) -> checkQuit
	Just (CharControl Wait) -> wait
	Just (IngredientFor _ _) -> invokeSwallowed c
	Just (Poison _) -> ignore
	Nothing -> invokeSwallowed c
mainLoop e = maybe ignore move (arrowDirection e)

-- Does not step time
ignore :: M NextStep
ignore = next mainLoop

-- Does step time
continue :: M NextStep
continue = runPeruser =<< next mainLoop

wait :: M NextStep
wait = continue

showHelp :: M NextStep
showHelp = do
	modify $ \s -> s { helpShown = True }
	helpWindow
	next $ \_ -> clearWindows >> ignore

diveIn :: M NextStep
diveIn = go =<< diveThrough
  where
	go False = ignore
	go True = do
		modify $ \s -> s { helpShown = True }
		continue

move :: Direction -> M NextStep
move DDive = diveIn
move d = go =<< checkedMove =<< supportStaggaring d
  where
	go CannotMove = ignore
	go EscapedScroll = escapedScroll
	go (SuccessfulMove a) = a continue
	go SuccessfulBacktrack = continue
	go TooFullToMove = do
		n <- length . mapMaybe segmentSwallowed . playerBody <$> gets player
		showMessage $ concat
			[ "You've swallowed "
			, if n > 1 then "some letters" else "a letter"
			, ", and cannot drag "
			, if n > 1 then "them" else "it"
			, " along."
			]
		ignore

invokeSwallowed :: Char -> M NextStep
invokeSwallowed c = do
	p <- gets player
	case toggleInvoke c p of
		(InvokedChar, p') -> do
			change p'
			case checkInvokedSpells p' of
				[] -> continue
				l -> invoke l continue
		(DeInvokedChar, p') -> do
			change p'
			continue
		(NoInvoke, _) -> ignore
  where
	change p' = modifyPlayer (const p')

inventory :: M NextStep
inventory = do
	showWindow (3, 0) =<< spellInventory
	next $ \_ -> clearWindows >> ignore

checkQuit :: M NextStep
checkQuit = prompt "Are you sure you want to quit? [yn]" $ \i -> case i of
	EventCharacter 'y' -> do
		showMessage "Bye!"
		endThread
	_ -> do
		clearMessage
		ignore

forceRedraw :: M NextStep
forceRedraw = do
	view <- lift . mkView =<< get
	let view' = view { viewForceRedraw = True }
	return $ NextStep view' (Just mainLoop)

escapedScroll :: M NextStep
escapedScroll = do
	showMessage "You escaped the scroll! You win!"
	next $ victorydance (30 :: Int)
  where
	victorydance 0 _ = endThread
	victorydance n e = do
		let dir = case e of
			(EventCharacter c) -> case M.lookup c charMap of
				Just (CharControl (Movement d))
					| d /= DUp && d /= DDive -> d
				_ -> DDown
			(EventSpecialKey KeyLeftArrow) -> DLeft
			(EventSpecialKey KeyRightArrow) -> DRight
			_ -> DDown
		moveaway DDown
		when (dir /= DDown) $
			moveaway dir
		next $ victorydance (n-1)
	
	moveaway dir = do
		hpos <- getPos <$> gets player
		let seg = Segment hpos dir CurrentSide Nothing False
		setHeadPos $ directionOffset dir `offsetPos` hpos
		modifyPlayer $ \p -> p { playerBody = shiftBody p seg }