scroll-1.20151219: Peruser.hs

module Peruser where

import Control.Monad.State.Strict
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector as V
import Control.Monad.IfElse
import Control.Applicative
import Prelude

import Types
import Status
import Time
import Player
import Rand
import World
import Level.Border

changePeruser :: (Peruser -> Peruser) -> M ()
changePeruser f = modify $ \s -> s { peruser = f (peruser s) }

runPeruser :: NextStep -> M NextStep
runPeruser cont = do
	playery <- snd . playerHead <$> gets player
	wh <- worldHeight
	if playery > wh - 5
		then do
			-- scroll now, since the player is near the bottom
			scrollUp cont
		else do
			-- scroll occasionaly
			thistime <- randM random
			if thistime
				then do
					p <- gets peruser
					let (n, p') = stepPeruser p
					modify $ \s -> s { peruser = p' }
					timeleft n
				else return cont
  where
	timeleft n
		| n == 0 = scrollUp cont
		| n < 4 = checkPinch cont
		| n < 5 = do
			showRandomMessage 
				[ "The scroll tightens alarmingly.."
				, "The scroll shifts menacingly.."
				, "The scroll begins to move.."
				, "The scroll shudders beneath you.."
				]
			return cont
		| otherwise = return cont

stepPeruser :: Peruser -> (Int, Peruser)
stepPeruser p
	| peruseCountDown p < 1 = (0, p { peruseCountDown = peruseSpeed p })
	| otherwise = (peruseCountDown p, p { peruseCountDown = pred (peruseCountDown p) })

data Danger
	= Safe
	| SegmentCrush [Segment]
	| HeadCrush

checkDanger :: M Danger
checkDanger = do
	p <- gets player
	return $ 
		if atTop (playerHead p)
			then HeadCrush
			else case break (atTop . getPos) (filter (\s -> segmentSide s /= InSide) (playerBody p)) of
				(_uncrushed, []) -> Safe
				(uncrushed, _) -> SegmentCrush uncrushed

atTop :: Pos -> Bool
atTop (_, n) = n < 3

checkPinch :: NextStep -> M NextStep
checkPinch cont = handle =<< checkDanger
  where
	handle Safe = return cont
	handle (SegmentCrush _) = do
		showMessage "The scroll pinches your tail!"
		return cont
	handle HeadCrush = do
		showMessage "The scroll is crushing you!"
		return cont

scrollUp :: NextStep -> M NextStep
scrollUp cont = do
	shiftScrollUp
	handle =<< checkDanger
  where
	handle Safe = do
		shiftPlayerUp
		return cont
	handle (SegmentCrush remaining) = do
		p <- gets player
		let n = length (playerBody p) - length remaining
		let p' = p { playerBody = remaining, playerLen = playerLen p - n }
		modify $ \s -> s { player = p' }
		shiftPlayerUp
		if playerLen p' < 2
			then do
				showMessage "Owowow! It crushed your whole tail!"
				when (playerLen p' < 1) $
					showMessage "A lone @ vs this scroll? What chance would you have?"
				crushed
			else do
				showMessage $ "Ouch" ++ (replicate n '!') ++ " " ++
					show n ++ " tail segment" ++ 
					(if n > 1 then "s" else "") ++
					" crushed."
				joke "You have a sad feeling for a moment, but it passes."
				return cont
	handle HeadCrush = crushed
	joke s = whenM (randM random) (showMessage s)

	crushed = do
		shiftPlayerUp
		showMessage "You die. Crushed by the scroll."
		endThread

-- Update both the world and the flipSide the same way for the scroll
-- moving up 1 line.
--
-- If the buffer is empty, the cap is moved down 1 line, covering a line of
-- the scrolls -- so the scroll eventually rolls up.
--
-- When there are lines left in the buffer, each line of the scroll
-- is swapped with the line above. Then the next line is taken out
-- of the buffer, and fills in at the bottom.
shiftScrollUp :: M ()
shiftScrollUp = put . addTopBuffer . flipOver =<< go . flipOver =<< go =<< get
  where
	addTopBuffer s = s { topBuffer = topBuffer s + 1 }
	go s = lift $ do
		let w = world s 
		let b = fst (bottomBuffer s)
		if MV.null b
			then do
				MV.swap w 2 1
				MV.swap w 1 0
				return $ s { world = MV.drop 1 w }
			else do
				let firstline = 2
				let lastline = MV.length w - 3
				let (h, b') = MV.splitAt 1 b
				new <- MV.read h 0
				forM_ ([firstline..lastline-1]) $ \n ->
					MV.swap w (n+1) n
				MV.write w lastline new
				cap <- MV.read w (lastline+1)
				above <- V.freeze new
				joinCap above cap
				return $ s { bottomBuffer = (b', snd (bottomBuffer s)) }