scroll-1.20151219: Player/Move.hs

{-# LANGUAGE FlexibleContexts #-}

module Player.Move where

import Control.Monad.State.Strict
import Data.Char
import Data.Maybe
import Control.Applicative
import Prelude

import Types
import World
import Level.Border
import Player
import Status
import Player.Consume
import Unicode

-- If the last but one segment is full, the player is too full to move
-- forward.
checkTailFull :: M Bool
checkTailFull = do
	p <- gets player
	return $ 
		length (playerBody p) >= playerLen p &&
		case ptail p of
			[] -> False
			(s:_) -> isJust (segmentSwallowed s)
  where
	ptail = drop 1 . reverse . playerBody

data MoveResult
	= CannotMove
	| EscapedScroll
	| SuccessfulMove (M NextStep -> M NextStep)
	| SuccessfulBacktrack
	| TooFullToMove

checkedMove :: Direction -> M MoveResult
checkedMove dir = do
	p <- gets player
	let oldpos@(oldx, oldy) = playerHead p
	let newpos = (fx oldx, fy oldy)
	case playerBody p of
		(s:_) | segmentPos s == newpos && segmentSide s == CurrentSide ->
			backTrack p newpos
		_ -> go p oldpos newpos =<< checkTailFull
  where
	(fx, fy) = directionOffset dir

	go _ _ _ True = return TooFullToMove
	go p oldpos newpos@(x, y) False = do
		maxx <- worldWidth
		maxy <- worldHeight
		if x < 0 || y < 0 || x >= maxx || y >= maxy
			then return EscapedScroll
			else do
				c <- readWorld newpos
				if isBoundry c || not (isSpace c || isEdible c)
					then return CannotMove
					else if playerBerzerk p && not (isSpace c)
						then berzerkpush p c oldpos newpos maxx maxy
						else if playerEnergized p && isAlphaNum c
								then push p c oldpos newpos maxx maxy
								else consume p c oldpos newpos
	
	consume p c oldpos newpos = do
		let newsegment = Segment oldpos dir CurrentSide (playerSwallowing p) False
		let p' = p
			{ playerHead = newpos
			, playerBody = shiftBody p newsegment
			}
		modify $ \w -> w { player = p' }
		return $ SuccessfulMove $ flip playerConsume c

	berzerkpush p c oldpos newpos maxx maxy = do
		pushed <- fst <$> tryPushChar True c newpos dir maxx maxy
		when pushed $
			showMessage $ "You bash at the walls. Move!"
		consume p (if pushed then ' ' else c) oldpos newpos
	
	push p c oldpos newpos maxx maxy = do
		pushed <- fst <$> tryPushChar False c newpos dir maxx maxy
		when pushed $
			showMessage $ "You shove the " ++ unicodeCharDesc c ++ "!"
		consume p (if pushed then ' ' else c) oldpos newpos

tryPushChar :: Bool -> Char -> Pos -> Direction -> Int -> Int -> M (Bool, Char)
tryPushChar recur c pos@(x, y) dir maxx maxy
	| isBoundry c || x2 < 0 || y2 < 0 || x2 >= maxx || y2 >= maxy =
		return (False, c)
	| otherwise = do
		nextc <- readWorld (x2, y2)
		let swap swapc = do
			writeWorld (x2,y2) c
			writeWorld pos swapc
			return (True, swapc)
			
		if isSpace nextc
			then swap nextc
			else if recur
				then do
					(ok, c') <- tryPushChar True nextc (x2,y2) dir maxx maxy
					if ok
						then swap c'
						else return (False, c)
				else return (False, c)
  where
	(fx, fy) = directionOffset dir
	(x2, y2) = (fx x, fy y)

-- A full player can only back up.
-- Doing so deletes the segment they backtrack over,
-- and anything that was in that segment is moved to
-- their mouth.
--
-- However, if the segment is the only segment, anything it
-- contains is ignored. This handles a case where the last but one segment
-- was full, and then the last segment got destroyed. In this case,
-- the player should be able to back up over the new final segment, and then
-- away from it, without getting stuck on that it contained.
backTrack :: Player -> Pos -> M MoveResult
backTrack p newpos = case playerBody p of
	(s:rest) | segmentPos s == newpos && segmentSide s == CurrentSide -> do
		let p' = p
			{ playerHead = newpos
			, playerSwallowing = 
				if null rest
					then Nothing
					else segmentSwallowed s
			, playerBody = rest
			}
		modify $ \w -> w { player = p' }
		return SuccessfulBacktrack
	_ -> return TooFullToMove

diveThrough :: M Bool
diveThrough = go =<< checkCanDive
  where
	go False = unable "No holes here in the scroll."
	go True = do
		p <- gets player
		if toofull p
			then unable "You're too full of letters to squeeze through!"
			else do
				s <- get
				let s' = flipOver s
				put s' { player = dive (player s') }
				return True

	toofull p = any (isJust . segmentSwallowed) (playerBody p)
		|| isJust (playerSwallowing p)

	unable m = do
		showMessage m
		return False

-- One body segment is used to go through the scroll,
-- unless the most recent segment is already inside,
dive :: Player -> Player
dive p = case playerBody p of
	(s:_) | segmentSide s == InSide -> p
	([_]) -> p { playerBody = shiftBody p (Segment (0,0) DDive InSide Nothing False) }
	_ -> p