aboutsummaryrefslogtreecommitdiff
path: root/Demos/Pong/Pong.hs
blob: 0e24a42bb5703371e2beacc316fb341c35b8f6c9 (plain)
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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
module Pong
  ( GameEvent (..),
    GameObject,
    newWorld,
    stepWorld,
    aabb,
  )
where

import           Data.Monoid         (mconcat)
import           GHC.Float           (double2Float)
import           Spear.Math.AABB
import           Spear.Math.Spatial2
import           Spear.Math.Vector
import           Spear.Step

-- Configuration

padSize = vec2 0.07 0.02
ballSize = 0.012
ballSpeed = 0.6
initialBallVelocity = vec2 1 1
maxBounceAngle = 65 * pi/180
playerSpeed = 1.0
enemySpeed = 1.5
initialEnemyPos = vec2 0.5 0.9
initialPlayerPos = vec2 0.5 0.1
initialBallPos = vec2 0.5 0.5

-- Game events

data GameEvent
  = MoveLeft
  | MoveRight
  | StopLeft
  | StopRight
  deriving (Eq, Ord)

-- Game objects

data GameObject = GameObject
  { aabb   :: AABB2,
    obj    :: Obj2,
    gostep :: Step [GameObject] [GameEvent] GameObject GameObject
  }

instance Spatial2 GameObject where
  getObj2 = obj
  setObj2 s o = s {obj = o}

stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos

update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
update elapsed dt evts gos go =
  let (go', s') = runStep (gostep go) elapsed dt gos evts go
   in go' {gostep = s'}

ballBox, padBox :: AABB2
ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
padBox = AABB2 (-padSize) padSize

obj2 = obj2FromVectors unitx2 unity2

newWorld =
  [ GameObject ballBox (obj2 initialBallPos) $ stepBall initialBallVelocity,
    GameObject padBox (obj2 initialEnemyPos) stepEnemy,
    GameObject padBox (obj2 initialPlayerPos) stepPlayer
  ]

-- Ball steppers

stepBall vel = collideBall vel .> moveBall

-- TODO: in collideBall and paddleBounce, we should an apply an offset to the
-- ball when collision is detected.
collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
collideBall vel = step $ \_ dt gos _ ball ->
  let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
      collideSide = x pmin < 0 || x pmax > 1
      collideBack = y pmin < 0 || y pmax > 1
      collidePaddle = any (collide ball) (tail gos)
      flipX v@(Vector2 x y) = if collideSide then vec2 (-x) y else v
      flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v
      vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel
      -- A small delta to apply when collision occurs.
      delta = 1 + if collideSide || collideBack || collidePaddle then 2*dt else 0
   in ((scale ballSpeed (scale delta vel'), ball), collideBall vel')

paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
paddleBounce ball v paddle =
  if collide ball paddle
  then
    let (AABB2 pmin pmax) = aabb paddle `aabbAdd` pos paddle
        center = (x pmin + x pmax) / 2
        -- Normalized offset of the ball from the paddle's center, [-1, +1].
        -- It's outside the [-1, +1] range if there is no collision.
        offset = (x (pos ball) - center) / ((x pmax - x pmin) / 2)
        angle  = offset * maxBounceAngle
        -- When it bounces off of a paddle, y vel is flipped.
        ysign = -(signum (y v))
    in vec2 (sin angle) (ysign * cos angle)
  else v

collide :: GameObject -> GameObject -> Bool
collide go1 go2 =
  let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
        aabb go1 `aabbAdd` pos go1
      (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
        aabb go2 `aabbAdd` pos go2
   in not $
        xmax1 < xmin2
          || xmin1 > xmax2
          || ymax1 < ymin2
          || ymin1 > ymax2

aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)

moveBall :: Step s e (Vector2, GameObject) GameObject
moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)

-- Enemy stepper

stepEnemy = movePad

movePad :: Step s e GameObject GameObject
movePad = step $ \elapsed _ _ _ pad ->
  let p = vec2 px 0.9
      px =
        double2Float (sin (elapsed * enemySpeed) * 0.5 + 0.5)
          * (1 - 2 * x padSize)
          + x padSize
   in (setPos p pad, movePad)

-- Player stepper

stepPlayer = sfold moveGO .> clamp

moveGO =
  mconcat
    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0),
      switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0)
    ]

moveGO' :: Vector2 -> Step s e GameObject GameObject
moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)

clamp :: Step s e GameObject GameObject
clamp = spure $ \go ->
  let p' = vec2 (clamp' x s (1 - s)) y
      (Vector2 x y) = pos go
      clamp' x a b
        | x < a = a
        | x > b = b
        | otherwise = x
      (Vector2 s _) = padSize
   in setPos p' go