@@ -0,0 +1,165 @@
1+
2+module Pong where
3+
4+import Foreign.JavaScript
5+import Signal.Keyboard.Raw
6+import Signal.Window as Win
7+
8+
9+------------------------------------------------------------------------
10+------ Extracting timesteps from JavaScript ------
11+------------------------------------------------------------------------
12+
13+desiredFPS = constant (castIntToJSNumber 30)
14+
15+foreign export jsevent "desiredFPS"
16+ desiredFPS :: Signal JSNumber
17+
18+foreign import jsevent "trigger" (castIntToJSNumber 0)
19+ jsTime :: Signal JSNumber
20+
21+time = lift castJSNumberToFloat jsTime
22+
23+delta = lift snd $ foldp (\t1 (t0,d) -> (t1, t1-t0)) (0,0) time
24+
25+
26+------------------------------------------------------------------------
27+------ Modelling user input ------
28+------------------------------------------------------------------------
29+
30+-- Each paddle can be moving up, down, or not at all. We'll call this
31+-- the `direction' of the paddle.
32+
33+data Direction = Up | Neutral | Down
34+
35+-- During gameplay, all keyboard input is about the position of the two
36+-- paddles. So the keyboard input can be reduced to two `Directions'.
37+
38+data KeyInput = KeyInput Bool Direction Direction
39+
40+
41+-- Now we determine how to update the direction of a paddle based on
42+-- keyboard input. The first two args of `updatePaddle` are the key
43+-- codes of the up and down keys.
44+
45+updateDirection upKey downKey key direction =
46+ case direction of
47+ { Up -> if key == downKey then Neutral else Up
48+ ; Down -> if key == upKey then Neutral else Down
49+ ; Neutral -> if key == upKey then Up else
50+ if key == downKey then Down else Neutral
51+ }
52+
53+updateDirection1 = updateDirection 87 83 -- 'w' for up and 's' for down
54+updateDirection2 = updateDirection 38 40 -- 'UP' for up and 'DOWN' for down
55+
56+updateInput key (KeyInput space dir1 dir2) =
57+ KeyInput (space || key == 32)
58+ (updateDirection1 key dir1)
59+ (updateDirection2 key dir2)
60+
61+keyInput = lift (foldl updateInput (KeyInput False Neutral Neutral)) keysDown
62+
63+
64+------------------------------------------------------------------------
65+------ Combining all inputs to game ------
66+------------------------------------------------------------------------
67+
68+-- The inputs to this game include a timestep (which we extracted from
69+-- JavaScript) and the keyboard input from the users.
70+
71+data Input = Input Float KeyInput
72+
73+input = lift2 Input delta keyInput
74+
75+
76+------------------------------------------------------------------------
77+------ Modelling Pong / a State Machine ------
78+------------------------------------------------------------------------
79+
80+data Paddle = Paddle Float -- y-position
81+data Ball = Ball (Float,Float) (Float,Float) -- position and velocity
82+
83+data Score = Score Int Int
84+data State = Play | BetweenRounds
85+
86+data GameState = GameState State Score Ball Paddle Paddle
87+
88+gameWidth = 600
89+gameHeight = 400
90+halfWidth = gameWidth / 2
91+halfHeight = gameHeight / 2
92+
93+defaultGame = GameState BetweenRounds
94+ (Score 0 0)
95+ (Ball (halfWidth, halfHeight) (150,150))
96+ (Paddle halfHeight)
97+ (Paddle halfHeight)
98+
99+stepPaddle delta dir (Paddle y) =
100+ case dir of
101+ { Up -> Paddle . clamp 20 (gameHeight-20) $ y - 200 * delta
102+ ; Down -> Paddle . clamp 20 (gameHeight-20) $ y + 200 * delta
103+ ; Neutral -> Paddle y
104+ }
105+
106+stepBall delta (Ball (x,y) (vx,vy)) (Paddle y1) (Paddle y2) =
107+ let { makePositive n = if n > 0 then n else 0-n
108+ ; makeNegative n = if n > 0 then 0-n else n
109+ ; near epsilon n x = x > n - epsilon && x < n + epsilon
110+ ; vx' = if near 20 y1 y && near 8 25 x
111+ then makePositive vx else
112+ if near 20 y2 y && near 8 (gameWidth - 25) x
113+ then makeNegative vx else vx
114+ ; vy' = if y < 7 then makePositive vy else
115+ if y > gameHeight - 7 then makeNegative vy else vy
116+ ; scored = x > gameWidth || x < 0
117+ ; x' = if scored then halfWidth else x + vx' * delta
118+ ; y' = if scored then halfHeight else y + vy' * delta
119+ }
120+ in ( Ball (x',y') (vx',vy')
121+ , if x > gameWidth then 1 else 0
122+ , if x < 0 then 1 else 0
123+ )
124+
125+
126+stepGame (Input delta (KeyInput space dir1 dir2))
127+ (GameState state (Score s1 s2) ball paddle1 paddle2) =
128+ let { (ball',s1',s2') = if state == Play
129+ then stepBall delta ball paddle1 paddle2
130+ else (ball, 0, 0)
131+ ; state' = case state of { Play -> if s1' /= s2' then BetweenRounds else state
132+ ; BetweenRounds -> if space then Play else state }
133+ }
134+ in GameState state'
135+ (Score (s1+s1') (s2+s2'))
136+ ball'
137+ (stepPaddle delta dir1 paddle1)
138+ (stepPaddle delta dir2 paddle2)
139+
140+gameState = foldp stepGame defaultGame input
141+
142+
143+
144+display (w,h) (GameState state (Score p1 p2) (Ball pos _) (Paddle y1) (Paddle y2)) =
145+ let score = width w . centeredText . Text.height 4 $
146+ show p1 ++ toText " " ++ show p2
147+ in layers
148+ [ if state == Play then score else
149+ score `above` (width w . centeredText $ toText "Press SPACE to begin.")
150+ , let pongGreen = rgb 60 100 60 in
151+ size w h . box 5 $ collage gameWidth gameHeight
152+ [ filled pongGreen (rect gameWidth gameHeight (halfWidth,halfHeight))
153+ , filled white (oval 15 15 pos)
154+ , filled white (rect 10 40 ( 20, y1))
155+ , filled white (rect 10 40 (gameWidth - 20, y2))
156+ ]
157+ ]
158+
159+view = lift2 display Win.dimensions gameState
160+
161+done = lift (\_ -> castBoolToJSBool True) view
162+foreign export jsevent "finished"
163+ done :: Signal JSBool
164+
165+main = view