-
Notifications
You must be signed in to change notification settings - Fork 1
/
hebi.rkt
executable file
·339 lines (267 loc) · 9.56 KB
/
hebi.rkt
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
#!/usr/bin/env gracket
#lang racket/gui
(require racket/async-channel)
;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define GAME-W 400)
(define GAME-H 400)
(define SCALE 20)
(define ROWS (/ GAME-H SCALE))
(define COLS (/ GAME-W SCALE))
;; entities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct entity (row col)
#:transparent)
(define collision?
(match-lambda*
[(list (entity row col)
(entity row col)) #t]
[_ #f]))
(module+ test
(require rackunit)
(test-case "entities collied when they occupy the same space"
(check-true (collision? (entity 0 0)
(entity 0 0)))
(check-false (collision? (entity 1 0)
(entity 0 0)))))
;; apples ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct apple entity (ts)
#:transparent)
(define (make-apple)
(apple (random (sub1 ROWS))
(random (sub1 COLS))
(current-inexact-milliseconds)))
(define (apple-points a)
(inexact->exact
(round
((max 0 (- 10000
(- (current-inexact-milliseconds) (apple-ts a)))) . / . 1000))))
;; snakes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct part entity ()
#:transparent)
(define (part-move p direction)
(define row (entity-row p))
(define col (entity-col p))
(define-values (next-row next-col)
(case direction
[(north) (values (sub1 row) col)]
[(south) (values (add1 row) col)]
[(west) (values row (sub1 col))]
[(east) (values row (add1 col))]
[(halt) (values row col)]))
(struct-copy part p
[row #:parent entity (modulo next-row ROWS)]
[col #:parent entity (modulo next-col COLS)]))
(struct snake (parts)
#:transparent)
(define (make-snake locations)
(snake (map (curry apply part) locations)))
(define (make-initial-snake)
(make-snake '((9 10)
(9 9)
(9 8))))
(define (snake-move s directions)
(define parts (snake-parts s))
(snake (map part-move parts (take directions (length parts)))))
(define (snake-grow s)
(define parts (snake-parts s))
(snake (append parts (list (last parts)))))
(define (snake-head s)
(car (snake-parts s)))
(define (snake-body s)
(cdr (snake-parts s)))
(define (snake-length s)
(length (snake-parts s)))
(module+ test
(require rackunit)
(test-case "all the parts of a snake move together"
(define s (make-initial-snake))
(check-equal? (snake-move s '(east east east))
(make-snake '((9 11)
(9 10)
(9 9)))))
(test-case "the snake teleports at world boundaries"
(check-equal? (snake-move (make-snake '((9 19)
(9 18)
(9 17)))
'(east east east))
(make-snake '((9 0)
(9 19)
(9 18))))
(check-equal? (snake-move (make-snake '((19 5)
(18 5)
(17 5)))
'(south south south))
(make-snake '((0 5)
(19 5)
(18 5)))))
(test-case "when a snake grows, its last part is duplicated"
(check-equal? (snake-grow (make-initial-snake))
(make-snake '((9 10)
(9 9)
(9 8)
(9 8))))))
;; worlds ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct world (snake apple direction directions score paused?)
#:transparent)
(define (make-initial-world)
(world (make-initial-snake)
(make-apple)
'east
'(east east east)
0
#f))
(define (world-difficulty w)
(max 8 (sqrt ((world-score w) . / . 2))))
(define (world-apply-events w events)
(define current-direction (world-direction w))
(for/fold ([w w])
([e events])
(match e
['restart
(make-initial-world)]
['pause/unpause
(struct-copy world w [paused? (not (world-paused? w))])]
[(list 'change-direction dir)
(define can-change-direction?
(match (cons current-direction dir)
[(or (cons 'north 'south)
(cons 'south 'north)
(cons 'east 'west)
(cons 'west 'east)) #f]
[_ #t]))
(if can-change-direction?
(struct-copy world w [direction dir])
w)])))
(module+ test
(require rackunit)
(test-case "apply events ignores conflicting directions"
(define w (make-initial-world))
(check-equal? (world-direction (world-apply-events w '((change-direction west))))
'east)
;; the latter 'west direction is ignored since it would conflict with the current direction
(check-equal? (world-direction (world-apply-events w '((change-direction north)
(change-direction west))))
'north)))
(define (world-handle-apple-collision w)
(define apple (world-apple w))
(define snake (world-snake w))
(define directions (world-directions w))
(cond
[(collision? apple (snake-head snake))
(struct-copy world w
[apple (make-apple)]
[score (+ (world-score w) (apple-points apple))]
[snake (snake-grow snake)]
[directions (append directions (list 'halt))])]
[else w]))
(define (world-handle-snake-collisions w)
(define snake (world-snake w))
(cond
[(ormap (curry collision? (snake-head snake)) (snake-body snake))
(make-initial-world)]
[else w]))
(define (world-move-snake w)
(define snake (world-snake w))
(define direction (world-direction w))
(define directions (world-directions w))
(struct-copy world w
[snake (snake-move snake directions)]
[directions (take (cons direction directions)
(snake-length snake))]))
(define (world-step w [events null])
(let [(w (world-apply-events w events))]
(cond
[(world-paused? w) w]
[else (let* ([w (world-handle-apple-collision w)]
[w (world-handle-snake-collisions w)]
[w (world-move-snake w)])
w)])))
;; game loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (async-channel->list c)
(let loop ([e (async-channel-try-get c)]
[events null])
(if e
(loop (async-channel-try-get c) (cons e events))
(reverse events))))
(define (entity-screen-position e)
(values
(* (entity-col e) SCALE)
(* (entity-row e) SCALE)))
(define (render-apple a dc)
(define-values (x y)
(entity-screen-position a))
(send dc set-brush "red" 'solid)
(send dc set-pen "white" 1 'transparent)
(send dc draw-rounded-rectangle x y SCALE SCALE 5))
(define (render-snake-part p dc [color "black"])
(define-values (x y)
(entity-screen-position p))
(send dc set-brush color 'solid)
(send dc set-pen "white" 1 'solid)
(send dc draw-rectangle x y SCALE SCALE))
(define (render-snake s dc)
(render-snake-part (snake-head s) dc "gray")
(for-each (curryr render-snake-part dc) (snake-body s)))
(define (render-score s dc)
(define score:str (string-upcase (format "Score: ~a" s)))
(send dc set-text-foreground "white")
(send dc draw-text score:str 11 11)
(send dc set-text-foreground "black")
(send dc draw-text score:str 10 10))
(define (make-game-loop)
(define events (make-async-channel))
(define world (make-initial-world))
(values
(lambda (cb)
(let loop ()
(define next-loop-time
(alarm-evt (+ (current-inexact-milliseconds)
(/ 1000 (world-difficulty world)))))
(set! world (world-step world (async-channel->list events)))
(cb)
(sync next-loop-time)
(loop)))
(lambda (e)
(async-channel-put events e))
(lambda (dc)
(send dc clear)
(render-apple (world-apple world) dc)
(render-snake (world-snake world) dc)
(render-score (world-score world) dc))))
;; GUI ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ main
(define-values (loop-forever enqueue-event render)
(make-game-loop))
(define window
(new (class frame%
(super-new)
(define/override (on-subwindow-char _ e)
(define event
(match (send e get-key-code)
[#\q ((application-quit-handler))]
[#\r 'restart]
[#\space 'pause/unpause]
['up '(change-direction north)]
['down '(change-direction south)]
['left '(change-direction west)]
['right '(change-direction east)]
[_ #f]))
(and event (enqueue-event event))))
[label "Hebi"]
[width GAME-W]
[height (+ GAME-H SCALE)]
[style '(no-resize-border)]))
(define monospace-font
(send the-font-list find-or-create-font 12 'modern 'normal 'bold))
(define canvas
(new canvas%
[parent window]
[paint-callback (lambda (_ dc)
(send dc set-font monospace-font)
(send dc set-smoothing 'aligned)
(render dc))]))
(send window show #t)
(void
(thread
(lambda _
(loop-forever (lambda _
(send canvas refresh)))))))