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