1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
module Game.Entities (Entity (..), toSpriteSet, mkPlayer, render) where
import Data.IORef
import qualified Game.Controller as C
import qualified Game.Sprites as S
import qualified SDL
data Dir = DirRight | DirLeft deriving (Eq)
data Type = TypePlayer -- \| TypeEnemy | TypeItem
toSpriteSet :: Dir -> Int
toSpriteSet DirRight = 0
toSpriteSet DirLeft = 1
frameDelay :: Int
frameDelay = 6
jumpFrame :: Int
jumpFrame = 3
gravityOff :: Int
gravityOff = -1
gravityUp :: Int
gravityUp = 0
gravityDown :: Int
gravityDown = 16
gravityTable :: [Int]
gravityTable = [0, 6, 4, 4, 2, 2, 2, 2, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3]
data Entity = Entity
{ eType :: Type,
eX :: Int,
eY :: Int,
eDelay :: Int,
eFrame :: Int,
eFrameLimit :: Int,
eGravity :: Int,
eDir :: Dir,
eSprite :: S.Sprite,
eUpdate :: Entity -> IO Entity,
eBlocked :: Int -> Int -> Bool,
eDestroy :: Bool
}
mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> (Int -> Int -> Bool) -> IO Entity
mkPlayer sprites x y controls isBlocked = do
s <- S.get sprites "player"
pure $ Entity TypePlayer x y 0 0 3 gravityOff DirRight s (updatePlayer controls) isBlocked False
updateFrame :: Bool -> Entity -> Entity
updateFrame updated e
| isGravityOn = e
| delay > 0 = e {eDelay = delay - 1}
| frame < eFrameLimit e = e {eDelay = frameDelay, eFrame = if updated then frame + 1 else 0}
| otherwise = e {eDelay = frameDelay, eFrame = 0}
where
isGravityOn = eGravity e > gravityOff
frame = eFrame e
delay = eDelay e
updateHorizontal :: Bool -> Bool -> Entity -> Entity
updateHorizontal left right e
-- prevent pressing both directions (keyboard)
| left && right = e
-- change direction first
| left && eDir e /= DirLeft = e {eDir = DirLeft, eDelay = 0}
| right && eDir e /= DirRight = e {eDir = DirRight, eDelay = 0}
| left && isGoingDown = if isBlocked (x - 1) (y + 23) then e else e {eX = x - 1}
| left && not isGoingDown = if isBlocked (x - 1) (y + 23) && isBlocked (x - 1) (y + 17) then e else e {eX = x - 1}
| right && isGoingDown = if isBlocked (x + 17) (y + 23) then e else e {eX = x + 1}
| right && not isGoingDown = if isBlocked (x + 17) (y + 23) && isBlocked (x + 17) (y + 17) then e else e {eX = x + 1}
| otherwise = e
where
x = eX e
y = eY e
isBlocked = eBlocked e
gravity = eGravity e
isGoingDown = gravity == gravityOff || gravity >= gravityDown
updateVertical :: Bool -> Entity -> Entity
updateVertical jump e
| jump && gravity == gravityOff = e {eGravity = gravityUp, eFrame = jumpFrame}
| otherwise = e
where
gravity = eGravity e
applyGravity :: Int -> Entity -> Entity
applyGravity v e
| v == 0 = e
-- hit the floor
| isGoingDown
&& (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24))
&& not (isBlocked (x + 2) (y + 23))
&& not (isBlocked (x + 12) (y + 23)) =
e {eGravity = gravityOff, eDelay = 0, eFrame = 0}
| otherwise = applyGravity (v - 1) e {eY = y + change}
where
gravity = eGravity e
isGoingDown = gravity >= gravityDown
change = if isGoingDown then 1 else -1
x = eX e
y = eY e
isBlocked = eBlocked e
updateGravity :: Entity -> Entity
updateGravity e
| current > gravityOff = applyGravity (gravityTable !! current) e {eGravity = new}
| not (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) = e {eGravity = gravityDown, eFrame = jumpFrame}
| otherwise = e
where
current = eGravity e
new = if current > gravityOff && current < length gravityTable - 1 then current + 1 else current
x = eX e
y = eY e
isBlocked = eBlocked e
updatePlayer :: IORef C.Controls -> Entity -> IO Entity
updatePlayer controls e = do
ctl <- readIORef controls
pure $
updateGravity $
updateVertical (C.cA ctl) $
updateHorizontal (C.cLeft ctl) (C.cRight ctl) $
-- left or right, but not both (keyboard)
updateFrame ((C.cLeft ctl || C.cRight ctl) && (C.cLeft ctl /= C.cRight ctl)) e
render :: SDL.Renderer -> Entity -> IO ()
render renderer ent =
S.render renderer sp x y set frame
where
sp = eSprite ent
x = eX ent
y = eY ent
set = toSpriteSet $ eDir ent
frame = eFrame ent
|
