scroll-1.20150313: Player.hs

module Player where

import Control.Monad.State.Strict
import qualified Data.Vector.Mutable as MV
import Control.Applicative
import Data.Maybe

import Types
import Level.Border

modifyPlayer :: (Player -> Player) -> M ()
modifyPlayer f = modify $ \s -> s { player = f (player s) }

isSpellCaster :: M ()
isSpellCaster = modify $ \s -> s { player = (player s) { spellCaster = True } }

shiftBody :: Player -> Segment -> [Segment]
shiftBody p segment
	| playerLen p == 0 = []
	| length (playerBody p) >= playerLen p = segment : shrinkBody p
	| otherwise = segment : playerBody p

shrinkBody :: Player -> [Segment]
shrinkBody = reverse . drop 1 . reverse . playerBody

-- Does not adjust the body.
setHeadPos :: Pos -> M ()
setHeadPos pos = modifyPlayer $ \p -> p { playerHead = pos }

-- Moves the player head and each segment up 1 space.
-- This is called when the scroll moves.
shiftPlayerUp :: M ()
shiftPlayerUp = modifyPlayer $ offsetPos (id, pred)

-- Find a starting position for the player that is
-- not occupied a letter, and from which the player can dive to the help
-- level.
--
-- The help level has a lot of whitespace in its first line, so the player
-- is put on the first line. In the unlikely event that there is no
-- suitable starting in the first line, one letter is destroyed to make
-- one.
startingPosition :: M ()
startingPosition = do
	w <- gets world
	l <- lift $ MV.read w 2
	divable <- scanv [0..MV.length l - 1] checkCanDiveTo
	usable <- scanv divable $ lift . checkBounded w
	if null usable
		then do
			let x = midpoint divable
			lift $ MV.write l x ' '
			setHeadPos (x, 2)
		else setHeadPos (midpoint usable, 2)
  where
	scanv range cond = do
		ms <- forM range $ \x -> do
			ok <- cond (x, 2)
			return $ if ok then Just x else Nothing
		return (catMaybes ms)
	midpoint [x] = x
	midpoint l = l !! pred (length l `div` 2)

-- In order to be able to dive through the scroll, there needs to be a
-- bordered area waiting on the flipSide.
--
-- This does not check if the player is in a position (empty stomach,
-- etc to use the spot), or check if the player will be able to dive
-- back from the flipSide to this side.
checkCanDive :: M Bool
checkCanDive = checkCanDiveTo =<< (playerHead <$> gets player)

checkCanDiveTo :: Pos -> M Bool
checkCanDiveTo pos = do
	w <- gets flipSide
	lift $ checkBounded w pos

removeSwallowing :: (Char -> Bool) -> Player -> Player
removeSwallowing match p = case playerSwallowing p of
	Just c | match c -> p { playerSwallowing = Nothing }
	_ -> p

-- Only positions on the current side of the scroll.
wormPositions :: M [Pos]
wormPositions = do
	p <- gets player
	ps <- wormTailPositions
	return (playerHead p : ps)

wormTailPositions :: M [Pos]
wormTailPositions = do
	p <- gets player
	let segs = filter (\s -> segmentSide s == CurrentSide) (playerBody p)
	return $ map getPos segs