scroll-1.20151219: 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 Prelude

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 }