1module Peruser where 2 3import Control.Monad.State.Strict 4import qualified Data.Vector.Mutable as MV 5import qualified Data.Vector as V 6import Control.Monad.IfElse 7import Control.Applicative 8import Prelude 9 10import Types 11import Status 12import Time 13import Player 14import Rand 15import World 16import Level.Border 17 18changePeruser :: (Peruser -> Peruser) -> M () 19changePeruser f = modify $ \s -> s { peruser = f (peruser s) } 20 21runPeruser :: NextStep -> M NextStep 22runPeruser cont = do 23 playery <- snd . playerHead <$> gets player 24 wh <- worldHeight 25 if playery > wh - 5 26 then do 27 -- scroll now, since the player is near the bottom 28 scrollUp cont 29 else do 30 -- scroll occasionaly 31 thistime <- randM random 32 if thistime 33 then do 34 p <- gets peruser 35 let (n, p') = stepPeruser p 36 modify $ \s -> s { peruser = p' } 37 timeleft n 38 else return cont 39 where 40 timeleft n 41 | n == 0 = scrollUp cont 42 | n < 4 = checkPinch cont 43 | n < 5 = do 44 showRandomMessage 45 [ "The scroll tightens alarmingly.." 46 , "The scroll shifts menacingly.." 47 , "The scroll begins to move.." 48 , "The scroll shudders beneath you.." 49 ] 50 return cont 51 | otherwise = return cont 52 53stepPeruser :: Peruser -> (Int, Peruser) 54stepPeruser p 55 | peruseCountDown p < 1 = (0, p { peruseCountDown = peruseSpeed p }) 56 | otherwise = (peruseCountDown p, p { peruseCountDown = pred (peruseCountDown p) }) 57 58data Danger 59 = Safe 60 | SegmentCrush [Segment] 61 | HeadCrush 62 63checkDanger :: M Danger 64checkDanger = do 65 p <- gets player 66 return $ 67 if atTop (playerHead p) 68 then HeadCrush 69 else case break (atTop . getPos) (filter (\s -> segmentSide s /= InSide) (playerBody p)) of 70 (_uncrushed, []) -> Safe 71 (uncrushed, _) -> SegmentCrush uncrushed 72 73atTop :: Pos -> Bool 74atTop (_, n) = n < 3 75 76checkPinch :: NextStep -> M NextStep 77checkPinch cont = handle =<< checkDanger 78 where 79 handle Safe = return cont 80 handle (SegmentCrush _) = do 81 showMessage "The scroll pinches your tail!" 82 return cont 83 handle HeadCrush = do 84 showMessage "The scroll is crushing you!" 85 return cont 86 87scrollUp :: NextStep -> M NextStep 88scrollUp cont = do 89 shiftScrollUp 90 handle =<< checkDanger 91 where 92 handle Safe = do 93 shiftPlayerUp 94 return cont 95 handle (SegmentCrush remaining) = do 96 p <- gets player 97 let n = length (playerBody p) - length remaining 98 let p' = p { playerBody = remaining, playerLen = playerLen p - n } 99 modify $ \s -> s { player = p' } 100 shiftPlayerUp 101 if playerLen p' < 2 102 then do 103 showMessage "Owowow! It crushed your whole tail!" 104 when (playerLen p' < 1) $ 105 showMessage "A lone @ vs this scroll? What chance would you have?" 106 crushed 107 else do 108 showMessage $ "Ouch" ++ (replicate n '!') ++ " " ++ 109 show n ++ " tail segment" ++ 110 (if n > 1 then "s" else "") ++ 111 " crushed." 112 joke "You have a sad feeling for a moment, but it passes." 113 return cont 114 handle HeadCrush = crushed 115 joke s = whenM (randM random) (showMessage s) 116 117 crushed = do 118 shiftPlayerUp 119 showMessage "You die. Crushed by the scroll." 120 endThread 121 122-- Update both the world and the flipSide the same way for the scroll 123-- moving up 1 line. 124-- 125-- If the buffer is empty, the cap is moved down 1 line, covering a line of 126-- the scrolls -- so the scroll eventually rolls up. 127-- 128-- When there are lines left in the buffer, each line of the scroll 129-- is swapped with the line above. Then the next line is taken out 130-- of the buffer, and fills in at the bottom. 131shiftScrollUp :: M () 132shiftScrollUp = put . addTopBuffer . flipOver =<< go . flipOver =<< go =<< get 133 where 134 addTopBuffer s = s { topBuffer = topBuffer s + 1 } 135 go s = lift $ do 136 let w = world s 137 let b = fst (bottomBuffer s) 138 if MV.null b 139 then do 140 MV.swap w 2 1 141 MV.swap w 1 0 142 return $ s { world = MV.drop 1 w } 143 else do 144 let firstline = 2 145 let lastline = MV.length w - 3 146 let (h, b') = MV.splitAt 1 b 147 new <- MV.read h 0 148 forM_ ([firstline..lastline-1]) $ \n -> 149 MV.swap w (n+1) n 150 MV.write w lastline new 151 cap <- MV.read w (lastline+1) 152 above <- V.freeze new 153 joinCap above cap 154 return $ s { bottomBuffer = (b', snd (bottomBuffer s)) } 155