summaryrefslogtreecommitdiffstats
path: root/chapter6/snake.rkt
blob: c57b01c7b37a4ab3388ee28cd3d88ece73c40961 (plain) (blame)
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
#lang racket
(require 2htdp/universe 2htdp/image)

;; data
(struct pit (snake goos obstacles dinged))
(struct snake (dir segs))
(struct goo (loc expire type))
(struct obstacle (loc expire))
(struct posn (x y))

;; constants
(define TICK-RATE 1/10)

(define SIZE 30)

(define SEG-SIZE 15)

(define EXPIRATION-TIME 150)
(define OBSTACLE-EXPIRATION-TIME 250)

(define WIDTH-PX (* SEG-SIZE 30))
(define HEIGHT-PX (* SEG-SIZE 30))

(define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX))
(define GOO-IMG (bitmap "resources/goo.gif"))
(define GOO-RED-IMG (bitmap "resources/goo-red.gif"))
(define OBSTACLE-IMG (bitmap "resources/obstacle.gif"))
(define SEG-IMG (bitmap "resources/body.gif"))
(define HEAD-IMG (bitmap "resources/head.gif"))

(define HEAD-LEFT-IMG HEAD-IMG)
(define HEAD-DOWN-IMG (rotate 90 HEAD-LEFT-IMG))
(define HEAD-RIGHT-IMG (flip-horizontal HEAD-LEFT-IMG))
(define HEAD-UP-IMG (flip-vertical HEAD-DOWN-IMG))

(define ENDGAME-TEXT-SIZE 15)

;; main
(define (start-snake)
  (big-bang (pit (snake "right" (list (posn 1 1)))
                 (list (fresh-goo)
                       (fresh-goo)
                       (fresh-goo)
                       (fresh-goo)
                       (fresh-goo)
                       (fresh-goo))
                 (list (fresh-obstacle)
                       (fresh-obstacle))
                 0)
            (on-tick next-pit TICK-RATE)
            (on-key direct-snake)
            (to-draw render-pit)
            (stop-when dead? render-end)))

(define (next-pit w)
  (define snake (pit-snake w))
  (define goos (pit-goos w))
  (define obstacles (pit-obstacles w))
  (define dinged (pit-dinged w))
  (define goo-to-eat (can-eat snake goos))
  (if goo-to-eat
      (pit (grow-size snake (goo-type goo-to-eat))
           (age-goo (eat goos goo-to-eat))
           (age-obstacle obstacles) (+ 1 dinged))
      (pit (slither snake)
           (age-goo goos)
           (age-obstacle obstacles) dinged)))

(define (direct-snake w ke)
  (cond [(dir? ke) (world-change-dir w ke)]
        [else w]))

(define (render-pit w)
  (snake+scene (pit-snake w)
               (goo-list+scene (pit-goos w)
                               (obstacle-list+scene
                                (pit-obstacles w) MT-SCENE))))

(define (dead? w)
  (define snake (pit-snake w))
  (or (self-colliding? snake)
      (wall-colliding? snake)
      (obstacle-colliding? snake (pit-obstacles w))))

(define (render-end w)
  (overlay (above (text "Game Over" ENDGAME-TEXT-SIZE "black")
                  (text (string-append "You dinged "
                                       (number->string (pit-dinged w))
                                       " goos.")
                        ENDGAME-TEXT-SIZE "black"))
           (render-pit w)))


;; clock
(define (can-eat snake goos)
  (cond [(empty? goos) #f]
        [else (if (close? (snake-head snake) (first goos))
                  (first goos)
                  (can-eat snake (rest goos)))]))

(define (eat goos goo-to-eat)
  (append (list (fresh-goo)) (remove goo-to-eat goos)))

(define (close? s g)
  (posn=? s (goo-loc g)))

(define (grow-size sn size)
  (cond [(= size 0) sn]
        [else (grow-size (grow sn) (- size 1))]))

(define (grow sn)
  (snake (snake-dir sn)
         (cons (next-head sn) (snake-segs sn))))

(define (slither sn)
  (snake (snake-dir sn)
         (cons (next-head sn) (all-but-last (snake-segs sn)))))

(define (next-head sn)
  (define head (snake-head sn))
  (define dir (snake-dir sn))
  (cond [(string=? dir "up") (posn-move head 0 -1)]
        [(string=? dir "down") (posn-move head 0 1)]
        [(string=? dir "left") (posn-move head -1 0)]
        [(string=? dir "right") (posn-move head 1 0)]))

(define (posn-move p dx dy)
  (posn (+ (posn-x p) dx)
        (+ (posn-y p) dy)))

(define (all-but-last segs)
  (cond [(empty? (rest segs)) empty]
        [else (cons (first segs) (all-but-last (rest segs)))]))

(define (age-goo goos)
  (rot (renew goos)))

(define (renew goos)
  (cond [(empty? goos) empty]
        [(rotten? (first goos))
         (append (fresh-goos) (renew (rest goos)))]
        [else
         (append (list (first goos)) (renew (rest goos)))]))

(define (rot goos)
  (cond [(empty? goos) empty]
        [else (cons (decay (first goos)) (rot (rest goos)))]))

(define (rotten? g)
  (zero? (goo-expire g)))

(define (decay g)
  (goo (goo-loc g) (sub1 (goo-expire g)) (goo-type g)))

(define (fresh-goo)
  (goo (posn (add1 (random (sub1 SIZE)))
             (add1 (random (sub1 SIZE))))
       EXPIRATION-TIME
       (random 1 3)))

(define (fresh-goos)
  (define (gen-goos n)
    (cond [(= n 0) empty]
          [else (cons (fresh-goo) (gen-goos (- n 1)))]))
  (let ((n (random 3)))
    (gen-goos n)))

(define (age-obstacle obstacles)
  (rot-obstacles (renew-obstacles obstacles)))

(define (renew-obstacles obstacles)
  (cond [(empty? obstacles)  empty]
        [(obstacle-expired? (first obstacles))
         (cons (fresh-obstacle) (renew-obstacles (rest obstacles)))]
        [else
         (cons (first obstacles) (renew-obstacles (rest obstacles)))]))

(define (rot-obstacles obstacles)
  (cond [(empty? obstacles) empty]
        [else (cons (decay-obstacle (first obstacles))
                    (rot-obstacles (rest obstacles)))]))

(define (obstacle-expired? obs)
  (zero? (obstacle-expire obs)))

(define (decay-obstacle obs)
  (obstacle (obstacle-loc obs) (sub1 (obstacle-expire obs))))

(define (fresh-obstacle)
  (obstacle (posn (add1 (random (sub1 SIZE)))
                  (add1 (random (sub1 SIZE))))
            OBSTACLE-EXPIRATION-TIME))

;; keys
(define (dir? x)
  (or (key=? x "up")
      (key=? x "down")
      (key=? x "left")
      (key=? x "right")))

(define (world-change-dir w d)
  (define the-snake (pit-snake w))
  (cond [(and (opposite-dir? (snake-dir the-snake) d)
              (cons? (rest (snake-segs the-snake))))
         (stop-with w)]
        [else
         (pit (snake-change-dir the-snake d)
              (pit-goos w)
              (pit-obstacles w)
              (pit-dinged w))]))

(define (opposite-dir? d1 d2)
  (cond [(string=? d1 "up") (string=? d2 "down")]
        [(string=? d1 "down") (string=? d2 "up")]
        [(string=? d1 "left") (string=? d2 "right")]
        [(string=? d1 "right") (string=? d2 "left")]))


;; render
(define (snake+scene snake scene)
  (define snake-body-scene
    (img-list+scene (snake-body snake) SEG-IMG scene))
  (define dir (snake-dir snake))
  (img+scene (snake-head snake)
             (cond [(string=? "up" dir) HEAD-UP-IMG]
                   [(string=? "down" dir) HEAD-DOWN-IMG]
                   [(string=? "left" dir) HEAD-LEFT-IMG]
                   [(string=? "right" dir) HEAD-RIGHT-IMG])
             snake-body-scene))

(define (goo-list+scene goos scene)
  (define (get-posns-from-goo goos type)
    (cond [(empty? goos) empty]
          [(= (goo-type (first goos)) type)
           (cons (goo-loc (first goos))
                 (get-posns-from-goo (rest goos) type))]
          [else (get-posns-from-goo (rest goos) type)]))
  (img-list+scene (get-posns-from-goo goos 1) GOO-IMG
                  (img-list+scene (get-posns-from-goo goos 2)
                                  GOO-RED-IMG scene)))

(define (obstacle-list+scene obstacles scene)
  (define (get-posns-from-obstacle obstacles)
    (cond [(empty? obstacles) empty]
          [else (cons (obstacle-loc (first obstacles))
                      (get-posns-from-obstacle (rest obstacles)))]))
  (img-list+scene (get-posns-from-obstacle obstacles)
                  OBSTACLE-IMG scene))

(define (img-list+scene posns img scene)
  (cond [(empty? posns) scene]
        [else (img+scene
               (first posns)
               img
               (img-list+scene (rest posns) img scene))]))

(define (img+scene posn img scene)
  (place-image img
               (* (posn-x posn) SEG-SIZE)
               (* (posn-y posn) SEG-SIZE)
               scene))


;; end game
(define (self-colliding? snake)
  (cons? (member (snake-head snake) (snake-body snake))))

(define (wall-colliding? snake)
  (define x (posn-x (snake-head snake)))
  (define y (posn-y (snake-head snake)))
  (or (= 0 x) (= x SIZE)
      (= 0 y) (= y SIZE)))

(define (obstacle-colliding? snake obstacles)
  (cond [(empty? obstacles) #f]
        [(posn=? (snake-head snake)
                 (obstacle-loc (first obstacles))) #t]
        [else (obstacle-colliding? snake (rest obstacles))]))

;; aux
(define (posn=? p1 p2)
  (and (= (posn-x p1) (posn-x p2))
       (= (posn-y p1) (posn-y p2))))

(define (snake-head sn)
  (first (snake-segs sn)))

(define (snake-body sn)
  (rest (snake-segs sn)))

(define (snake-tail sn)
  (last (snake-segs sn)))

(define (snake-change-dir sn d)
  (snake d (snake-segs sn)))