scroll-1.20250228: Control.hs

module Control where

import Control.Monad (when)
import Control.Monad.State.Strict
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 Term
import Term.Curses

mainLoop :: Step
mainLoop i = case inputCharacter i of
	Just '\t' -> forceRedraw
	Just 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
	Nothing -> maybe ignore move (arrowDirection i)

-- 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 inputCharacter i of
	Just '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 inputCharacter e of
			(Just c) -> case M.lookup c charMap of
				Just (CharControl (Movement d))
					| d /= DUp && d /= DDive -> d
				_ -> DDown
			Nothing -> case arrowDirection e of
				Just DLeft -> DLeft
				Just DRight -> 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 }