1module Player where 2 3import Control.Monad.State.Strict 4import qualified Data.Vector.Mutable as MV 5import Control.Applicative 6import Data.Maybe 7import Prelude 8 9import Types 10import Level.Border 11 12modifyPlayer :: (Player -> Player) -> M () 13modifyPlayer f = modify $ \s -> s { player = f (player s) } 14 15isSpellCaster :: M () 16isSpellCaster = modify $ \s -> s { player = (player s) { spellCaster = True } } 17 18shiftBody :: Player -> Segment -> [Segment] 19shiftBody p segment 20 | playerLen p == 0 = [] 21 | length (playerBody p) >= playerLen p = segment : shrinkBody p 22 | otherwise = segment : playerBody p 23 24shrinkBody :: Player -> [Segment] 25shrinkBody = reverse . drop 1 . reverse . playerBody 26 27-- Does not adjust the body. 28setHeadPos :: Pos -> M () 29setHeadPos pos = modifyPlayer $ \p -> p { playerHead = pos } 30 31-- Moves the player head and each segment up 1 space. 32-- This is called when the scroll moves. 33shiftPlayerUp :: M () 34shiftPlayerUp = modifyPlayer $ offsetPos (id, pred) 35 36-- Find a starting position for the player that is 37-- not occupied a letter, and from which the player can dive to the help 38-- level. 39-- 40-- The help level has a lot of whitespace in its first line, so the player 41-- is put on the first line. In the unlikely event that there is no 42-- suitable starting in the first line, one letter is destroyed to make 43-- one. 44startingPosition :: M () 45startingPosition = do 46 w <- gets world 47 l <- lift $ MV.read w 2 48 divable <- scanv [0..MV.length l - 1] checkCanDiveTo 49 usable <- scanv divable $ lift . checkBounded w 50 if null usable 51 then do 52 let x = midpoint divable 53 lift $ MV.write l x ' ' 54 setHeadPos (x, 2) 55 else setHeadPos (midpoint usable, 2) 56 where 57 scanv range cond = do 58 ms <- forM range $ \x -> do 59 ok <- cond (x, 2) 60 return $ if ok then Just x else Nothing 61 return (catMaybes ms) 62 midpoint [x] = x 63 midpoint l = l !! pred (length l `div` 2) 64 65-- In order to be able to dive through the scroll, there needs to be a 66-- bordered area waiting on the flipSide. 67-- 68-- This does not check if the player is in a position (empty stomach, 69-- etc to use the spot), or check if the player will be able to dive 70-- back from the flipSide to this side. 71checkCanDive :: M Bool 72checkCanDive = checkCanDiveTo =<< (playerHead <$> gets player) 73 74checkCanDiveTo :: Pos -> M Bool 75checkCanDiveTo pos = do 76 w <- gets flipSide 77 lift $ checkBounded w pos 78 79removeSwallowing :: (Char -> Bool) -> Player -> Player 80removeSwallowing match p = case playerSwallowing p of 81 Just c | match c -> p { playerSwallowing = Nothing } 82 _ -> p 83 84-- Only positions on the current side of the scroll. 85wormPositions :: M [Pos] 86wormPositions = do 87 p <- gets player 88 ps <- wormTailPositions 89 return (playerHead p : ps) 90 91wormTailPositions :: M [Pos] 92wormTailPositions = do 93 p <- gets player 94 let segs = filter (\s -> segmentSide s == CurrentSide) (playerBody p) 95 return $ map getPos segs 96