diff options
Diffstat (limited to 'chapter6/snake.rkt')
-rw-r--r-- | chapter6/snake.rkt | 295 |
1 files changed, 295 insertions, 0 deletions
diff --git a/chapter6/snake.rkt b/chapter6/snake.rkt new file mode 100644 index 0000000..c57b01c --- /dev/null +++ b/chapter6/snake.rkt @@ -0,0 +1,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))) |