858 lines
33 KiB
Racket
858 lines
33 KiB
Racket
#lang racket
|
|
|
|
#|
|
|
The Snake game revolves around a room filled with pieces of radioactive goo
|
|
and a snake that can remove this goo.
|
|
|
|
When the snake eats the goo, it grows and new goo appears. Like all
|
|
radioactive material, goo decays over time. Eventually it expires, but
|
|
fortunately for the snake, a new piece of goo appears elsewhere.
|
|
|
|
The player is in control of a snake, and the objective is to grow the snake as
|
|
large as possible. She may change the direction of the snake by pressing one of
|
|
the four arrow keys. When the snake gets close to a piece of goo, it eats the
|
|
goo and grows a new segment. If the snake runs into itself or one of the four
|
|
walls, the game is over. The length of the snake is the player's score.
|
|
|#
|
|
|
|
;; Play a Snake game.
|
|
;; Run program and evaluate
|
|
;; (start-snake)
|
|
;; This will pop up a window with instructions for interacting with the program.
|
|
;; Watch how qiuckly the program guesses X.
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;
|
|
; ;;; ; ;
|
|
; ; ;; ;
|
|
; ; ; ;; ;;; ;;;; ; ;;; ;;;
|
|
; ; ;; ; ; ; ; ; ; ;
|
|
; ;;;; ; ; ; ; ; ; ;
|
|
; ; ; ; ;;;;;; ;;; ;;;;;;;
|
|
; ; ; ; ; ; ; ; ; ;
|
|
; ;; ; ; ; ; ;; ; ; ; ;
|
|
; ; ;;; ;;; ;;; ;;;; ;; ;; ;;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
(require 2htdp/image 2htdp/universe)
|
|
;; -----------------------------------------------------------------------------
|
|
;; Data Definitions
|
|
|
|
;; A Pit is a (pit Snake (Listof Goo))
|
|
(struct pit (snake goos) #:transparent)
|
|
|
|
;; A Snake is a (make-snake Direction (cons Seg [Listof Seg]))
|
|
(struct snake (dir segs) #:transparent)
|
|
;; The head of the snake is the first element in the list of segs.
|
|
;; Each segment of a snake is located with:
|
|
;; - x in (0,SIZE),
|
|
;; - y in (0,SIZE).
|
|
;; And is SEG-SIZE aligned (x and y are multiples of SEG-SIZE).
|
|
|
|
;; A Seg is a (posn Number Number)
|
|
|
|
;; A Goo is a (goo Posn Number)
|
|
(struct goo (loc expire) #:transparent)
|
|
;; The expire field is a Natural Number that represents the number
|
|
;; of ticks until the goo expires. A goo is expired when this field is 1
|
|
|
|
;; A Direction is one of "up" "down" "left" "right"
|
|
|
|
;; A Posn is (posn number number)
|
|
(struct posn (x y) #:transparent)
|
|
;; Represents a two dimensional point.
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Constants
|
|
|
|
;; Tick Rate
|
|
(define TICK-RATE 1/10)
|
|
|
|
;; Board Size Constants
|
|
(define SIZE 30)
|
|
|
|
;; Snake Constants
|
|
(define SEG-SIZE 15)
|
|
|
|
;; Goo Constants
|
|
(define MAX-GOO 5)
|
|
(define EXPIRATION-TIME 150)
|
|
|
|
;; GRAPHICAL BOARD
|
|
(define WIDTH-PX (* SEG-SIZE 30))
|
|
(define HEIGHT-PX (* SEG-SIZE 30))
|
|
|
|
;; Visual constants
|
|
(define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX))
|
|
(define GOO-IMG (bitmap "graphics/goo.gif"))
|
|
(define SEG-IMG (bitmap "graphics/body.gif"))
|
|
(define HEAD-IMG (bitmap "graphics/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)
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;
|
|
; ;;; ;;;
|
|
; ;; ;;
|
|
; ; ; ; ; ;;;; ;;; ;; ;;;
|
|
; ; ; ; ; ; ; ; ;; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ;;;;;; ; ; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ;; ; ; ;
|
|
; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; Start the Game
|
|
(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)))
|
|
(on-tick next-pit TICK-RATE)
|
|
(on-key direct-snake)
|
|
(to-draw render-pit)
|
|
(stop-when dead? render-end)))
|
|
|
|
;; Pit -> Pit
|
|
;; Take one step: eat or slither
|
|
(define (next-pit w)
|
|
(define snake (pit-snake w))
|
|
(define goos (pit-goos w))
|
|
(define goo-to-eat (can-eat snake goos))
|
|
(if goo-to-eat
|
|
(pit (grow snake) (age-goo (eat goos goo-to-eat)))
|
|
(pit (slither snake) (age-goo goos))))
|
|
|
|
;; Pit KeyEvent -> Pit
|
|
;; Handle a key event
|
|
(define (direct-snake w ke)
|
|
(cond [(dir? ke) (world-change-dir w ke)]
|
|
[else w]))
|
|
|
|
;; Pit -> Scene
|
|
;; Render the world as a scene
|
|
(define (render-pit w)
|
|
(snake+scene (pit-snake w)
|
|
(goo-list+scene (pit-goos w) MT-SCENE)))
|
|
|
|
;; Pit -> Boolean
|
|
;; Is the snake dead?
|
|
(define (dead? w)
|
|
(define snake (pit-snake w))
|
|
(or (self-colliding? snake) (wall-colliding? snake)))
|
|
|
|
;; Pit -> Scene
|
|
;; produces a gameover image
|
|
(define (render-end w)
|
|
(overlay (text "Game over" ENDGAME-TEXT-SIZE "black")
|
|
(render-pit w)))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;;; ;; ;; ;;;;;; ; ;;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ;;;; ;;; ; ; ;;;; ; ;;; ;;; ; ; ;;;; ;;;;;
|
|
; ; ; ; ; ;; ;; ; ; ; ; ;; ;; ; ; ; ;
|
|
; ; ; ; ; ; ;;; ; ; ; ;;; ;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ;;;;; ;;;; ;;;; ;; ;;; ;;; ;;;;; ;;;; ;; ;;; ;;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Movement and Eating
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Eating and Growth
|
|
|
|
;; Snake [Listof Goo] -> Goo or #f
|
|
;; Can the snake eat any of the goos?
|
|
;; > (can-eat (snake "right" `(,(posn 3 3))) `(,(goo (posn 3 3) 130)))
|
|
;; (goo (posn 3 3) 130)
|
|
(define (can-eat snake goos)
|
|
(cond [(empty? goos) #f]
|
|
[else (if (close? (snake-head snake) (first goos))
|
|
(first goos)
|
|
(can-eat snake (rest goos)))]))
|
|
|
|
;; [Listof Goo] Goo -> [Listof Goo]
|
|
;; Eat and replenish a goo.
|
|
;; > (eat (list (goo (posn 5 5) 5)) (goo (posn 5 5) 5))
|
|
;; (list (new-goo))
|
|
(define (eat goos goo-to-eat)
|
|
(cons (fresh-goo) (remove goo-to-eat goos)))
|
|
|
|
;; Seg Goo -> Boolean
|
|
;; Is the segment close to the goo?
|
|
;; > (close? (posn 1 2) (goo (posn 1 2) 4))
|
|
;; #t
|
|
(define (close? s g)
|
|
(posn=? s (goo-loc g)))
|
|
|
|
;; Grow the snake one segment.
|
|
;; Snake -> Snake
|
|
;; > (grow snake0)
|
|
;; (snake "right" `(,(posn 2 1) ,(posn 1 1)))
|
|
(define (grow sn)
|
|
(snake (snake-dir sn) (cons (next-head sn) (snake-segs sn))))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Movement
|
|
|
|
;; Snake -> Snake
|
|
;; Slither the snake forward one segment.
|
|
;; > (slither snake0)
|
|
;; (snake "right" (posn 2 1))
|
|
(define (slither sn)
|
|
(snake (snake-dir sn)
|
|
(cons (next-head sn) (all-but-last (snake-segs sn)))))
|
|
|
|
;; Snake -> Seg
|
|
;; Compute the next head position of the snake.
|
|
;; > (next-head snake0)
|
|
;; (snake "right" (list (posn 2 1)))
|
|
(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)]))
|
|
|
|
;; Posn Number Number -> Posn
|
|
;; Move the position by dx, dy.
|
|
;; > (posn-move (posn 1 1) 2 3)
|
|
;; (posn 3 4)
|
|
(define (posn-move p dx dy)
|
|
(posn (+ (posn-x p) dx)
|
|
(+ (posn-y p) dy)))
|
|
|
|
;; (cons X [Listof X]) -> [Listof X]
|
|
;; Returns a List that is does not contain the last element of the given list.
|
|
;; > (all-but-last '(1 2 3 4))
|
|
;; '(1 2 3)
|
|
(define (all-but-last segs)
|
|
(cond [(empty? (rest segs)) empty]
|
|
[else (cons (first segs)
|
|
(all-but-last (rest segs)))]))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Rotting Goo
|
|
|
|
;; [Listof Goo] -> [Listof Goo]
|
|
;; Renew and rot goos.
|
|
(define (age-goo goos)
|
|
(rot (renew goos)))
|
|
|
|
;; [Listof Goo] -> [Listof Goo]
|
|
;; Renew any rotten goos.
|
|
(define (renew goos)
|
|
(cond [(empty? goos) empty]
|
|
[(rotten? (first goos))
|
|
(cons (fresh-goo) (renew (rest goos)))]
|
|
[else
|
|
(cons (first goos) (renew (rest goos)))]))
|
|
|
|
;; [Listof Goo] -> [Listof Goo]
|
|
;; Rot all of the goos.
|
|
(define (rot goos)
|
|
(cond [(empty? goos) empty]
|
|
[else (cons (decay (first goos))
|
|
(rot (rest goos)))]))
|
|
|
|
;; Goo -> Boolean
|
|
;; has the goo expired?
|
|
;; > (rotten? (goo 1 2) 0)
|
|
;; #t
|
|
(define (rotten? g)
|
|
(zero? (goo-expire g)))
|
|
|
|
;; Goo -> Goo
|
|
;; decreases the expire field of goo by one
|
|
;; > (decay (goo (posn 1 2) 2))
|
|
;; (goo (posn 1 2) 1)
|
|
(define (decay g)
|
|
(goo (goo-loc g) (sub1 (goo-expire g))))
|
|
|
|
;; -> Goo
|
|
;; Create random goo with fresh expiration.
|
|
;; Property: The position of the goo is:
|
|
;; - x in (0,WIDTH),
|
|
;; - y in (0,HEIGHT).
|
|
(define (fresh-goo)
|
|
(goo (posn (add1 (random (sub1 SIZE)))
|
|
(add1 (random (sub1 SIZE))))
|
|
EXPIRATION-TIME))
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;; ;;;;
|
|
; ; ;
|
|
; ; ; ;;; ;;; ;;; ;;;; ;
|
|
; ; ; ; ; ; ; ; ;;
|
|
; ;;;; ; ; ; ; ;
|
|
; ; ; ;;;;;;; ; ; ;;;;;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ;;; ;; ;;;; ; ;;;;;;
|
|
; ;
|
|
; ;
|
|
; ;;;;;
|
|
;
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; String -> Boolean
|
|
;; Is the given value a direction?
|
|
;; > (dir? "up")
|
|
;; #t
|
|
(define (dir? x)
|
|
(or (string=? x "up")
|
|
(string=? x "down")
|
|
(string=? x "left")
|
|
(string=? x "right")))
|
|
|
|
;; Pit Direction-> Pit
|
|
;; Change the direction (if not opposite current snake dir)
|
|
;; > (world-change-dir world0 "up")
|
|
;; (pit snake1 (list goo0))
|
|
(define (world-change-dir w d)
|
|
(define the-snake (pit-snake w))
|
|
(cond [(and (opposite-dir? (snake-dir the-snake) d)
|
|
;; consists of the head and at least one segment:
|
|
(cons? (rest (snake-segs the-snake))))
|
|
(stop-with w)]
|
|
[else
|
|
(pit (snake-change-dir the-snake d)
|
|
(pit-goos w))]))
|
|
|
|
;; Direction Direction -> Boolean
|
|
;; Are d1 and d2 opposites?
|
|
;; > (opposite-dir? "up" "down")
|
|
;; #t
|
|
(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")]))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;
|
|
; ;;;;;; ;
|
|
; ; ; ;
|
|
; ; ; ;;; ;; ;;; ;;; ; ;;; ;; ;;;
|
|
; ; ; ; ; ;; ; ; ;; ; ; ;;;
|
|
; ;;;;; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;;;;; ; ; ; ; ;;;;;;; ;
|
|
; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;; ; ; ;
|
|
; ;;; ;; ;;;; ;;; ;;; ;;; ;; ;;;; ;;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; Snake Scene -> Scene
|
|
;; Draws the snake onto the scene
|
|
;; > (snake+scene snake0 MT-SCENE)
|
|
;; (place-image SEG-IMG 8 8 MT-SCENE)
|
|
(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))
|
|
|
|
;; [Listof Goo] Scene -> Scene
|
|
;; draws all of the goo to a scene
|
|
;; > (goo-list+scene (list goo0) MT-SCENE)
|
|
;; (place-image GOO-IMG 32 32 MT-SCENE)
|
|
(define (goo-list+scene goos scene)
|
|
;; [Listof Goo] -> [Listof Posn]
|
|
;; gets the posns of all the goo
|
|
;; > (get-posns-from-goo (list (goo (posn 2 2) 1) (goo (posn 3 3) 1))
|
|
;; (list (posn 2 2) (posn 3 3))
|
|
(define (get-posns-from-goo goos)
|
|
(cond [(empty? goos) empty]
|
|
[else (cons (goo-loc (first goos))
|
|
(get-posns-from-goo (rest goos)))]))
|
|
(img-list+scene (get-posns-from-goo goos) GOO-IMG scene))
|
|
|
|
;; [Listof Posn] Image Scene -> Scene
|
|
;; Draws a the image to each posn in the list
|
|
;; > (img-list+scene (list (posn 1 1)) GOO-IMG MT-SCENE)
|
|
;; (place-image GOO-IMG 8 8
|
|
;; (img-list+scene empty GOO-IMG MT-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))]))
|
|
|
|
;; Posn Image Scene -> Scene
|
|
;; Draws a the given image onto the scene at the posn.
|
|
;; > (img+scene (posn 2 2) GOO-IMG MT-SCENE)
|
|
;; (place-image GOO-IMG 32 32 MT-SCENE)
|
|
(define (img+scene posn img scene)
|
|
(place-image img
|
|
(* (posn-x posn) SEG-SIZE)
|
|
(* (posn-y posn) SEG-SIZE)
|
|
scene))
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;
|
|
; ;;;;;;; ; ;;;; ;
|
|
; ; ; ; ; ;;
|
|
; ; ; ;; ;;; ;;; ; ; ;;;; ;; ; ; ;;;
|
|
; ; ; ;; ; ; ;; ; ; ; ;; ;; ; ; ;
|
|
; ;;;; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;;;;; ;;;;;; ; ; ; ;;;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ;
|
|
; ;;;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;; ;; ;;; ;; ;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; Snake -> Boolean
|
|
;; Determine if the snake is colliding with itself.
|
|
;; > (self-colliding? (snake "up" (list (posn 1 1) (posn 2 1)
|
|
;; (posn 2 2) (posn 1 2)
|
|
;; (posn 1 1))))
|
|
;; #t
|
|
(define (self-colliding? sn)
|
|
(cons? (member (snake-head sn) (snake-body sn))))
|
|
|
|
;; Snake -> Boolean
|
|
;; Determine if the snake is colliding with any of the walls.
|
|
;; > (wall-colliding? (snake "up" (list (posn 0 1))))
|
|
;; #t
|
|
(define (wall-colliding? sn)
|
|
(define x (posn-x (snake-head sn)))
|
|
(define y (posn-y (snake-head sn)))
|
|
(or (= 0 x) (= x SIZE)
|
|
(= 0 y) (= y SIZE)))
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;;;; ;;;;;;; ;;; ;;;;;; ;;; ;;;
|
|
; ;; ; ; ; ; ; ; ; ;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;;;; ;
|
|
; ;;;;;; ; ; ; ; ; ; ; ; ;;;;;; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ;;; ;;;; ;;; ;;; ;;;;;;; ;;;;;;;; ;;;;;;; ;;; ;;; ;;; ;; ;;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;; -----------------------------------------------------------------------------
|
|
;; Posn Posn -> Boolean
|
|
;; Are the two posns are equal?
|
|
;; > (posn=? (posn 1 1) (posn 1 1))
|
|
;; true
|
|
(define (posn=? p1 p2)
|
|
(and (= (posn-x p1) (posn-x p2))
|
|
(= (posn-y p1) (posn-y p2))))
|
|
|
|
;; Access the head position of the snake.
|
|
;; snake-head : Snake -> Seg
|
|
;; > (snake-head (snake "right" (list (posn 1 1) (posn 2 1)))
|
|
;; (posn 1 1)
|
|
(define (snake-head sn)
|
|
(first (snake-segs sn)))
|
|
|
|
;; Snake -> [Listof Segs]
|
|
;; returns the snake's body.
|
|
;; That is everyting that isn't the snake's head.
|
|
(define (snake-body sn)
|
|
(rest (snake-segs sn)))
|
|
|
|
;; Snake Direction -> Snake
|
|
(define (snake-change-dir sn d)
|
|
(snake d (snake-segs sn)))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;;;;;; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;;; ;;;; ; ;;;;;;; ;;;; ;
|
|
; ; ; ; ; ; ; ;; ; ; ;;
|
|
; ; ; ; ; ; ;
|
|
; ; ;;;;;;; ;;;;; ; ;;;;;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ;
|
|
; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; Initial Structures
|
|
|
|
(define goo-list (build-list MAX-GOO (lambda (x) (fresh-goo))))
|
|
(define snake0 (snake "right" (list (posn 1 1)))) ;; BUG? << -- moving this define into the test module blows up
|
|
(define world0 (pit snake0 goo-list))
|
|
|
|
(define left-snake0 (snake "left" (list (posn 1 1))))
|
|
(define left-world0 (pit left-snake0 goo-list))
|
|
|
|
;; Test Constants
|
|
|
|
(define snake1 (snake "left" (list (posn 5 5))))
|
|
(define snake2 (snake "up" (list (posn 2 2) (posn 2 3) (posn 2 4))))
|
|
(define wall-snake (snake "right" (list (posn 0 1) (posn 1 1))))
|
|
(define self-eating-snake (snake "up" (list
|
|
(posn 19 3)
|
|
(posn 19 4)
|
|
(posn 20 4)
|
|
(posn 21 4)
|
|
(posn 22 4)
|
|
(posn 22 3)
|
|
(posn 21 3)
|
|
(posn 20 3)
|
|
(posn 19 3)
|
|
(posn 18 3))))
|
|
(define goo1 (goo (posn 5 5) 45))
|
|
(define goo2 (goo (posn 4 8) 1))
|
|
(define goo3 (goo (posn 6 9) 40))
|
|
(define goo4 (goo (posn 1 1) 120))
|
|
(define goo5 (goo (posn 1 9) 58))
|
|
(define goo-list1 (list goo1 goo2 goo3 goo4 goo5))
|
|
(define world1 (pit snake1 goo-list1))
|
|
(define world2 (pit snake2 goo-list1))
|
|
|
|
(define right-snake1 (snake "right" (list (posn 5 5))))
|
|
(define right-world1 (pit right-snake1 goo-list1))
|
|
|
|
(module+ test
|
|
|
|
(require rackunit rackunit/text-ui)
|
|
|
|
;; test the major basic snake functions
|
|
(check-equal? (pit-snake (next-pit world2))
|
|
(snake "up" (list (posn 2 1) (posn 2 2) (posn 2 3))))
|
|
(check-equal? (pit-snake (next-pit world1))
|
|
(snake "left" (list (posn 4 5) (posn 5 5))))
|
|
(check-true (let ([f (pit-goos (next-pit world1))])
|
|
(= (length f) MAX-GOO)))
|
|
(check-equal? (pit-snake (next-pit world0))
|
|
(snake "right" (list (posn 2 1))))
|
|
(check-equal? (pit-snake (next-pit (pit snake0 (list (goo (posn 1 1) 130)))))
|
|
(snake "right" (list (posn 2 1) (posn 1 1))))
|
|
|
|
(check-equal? (direct-snake world0 "down")
|
|
(world-change-dir world0 "down"))
|
|
(check-equal? (direct-snake world0 "a")
|
|
world0)
|
|
|
|
(check-equal? (render-pit world0)
|
|
(snake+scene snake0
|
|
(goo-list+scene goo-list MT-SCENE)))
|
|
(check-equal? (render-pit world1)
|
|
(snake+scene snake1 (goo-list+scene goo-list1 MT-SCENE)))
|
|
(check-equal? (render-pit world2)
|
|
(snake+scene snake2 (goo-list+scene goo-list1 MT-SCENE)))
|
|
|
|
(check-true (dead? (pit wall-snake '())))
|
|
(check-true (dead? (pit self-eating-snake '())))
|
|
(check-false (dead? (pit snake1 '())))
|
|
(check-false (dead? (pit snake2 '())))
|
|
(check-false (dead? world0))
|
|
|
|
(check-equal? (render-end world1)
|
|
(overlay (text "Game over" 15 "black")
|
|
(render-pit world1)))
|
|
(check-equal? (render-end world2)
|
|
(overlay (text "Game over" 15 "black")
|
|
(render-pit world2)))
|
|
|
|
;; Properties
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; Property: each goo in the list has its 'expire' field decremented by 1
|
|
(define (prop:goo-rot-- i)
|
|
(test-begin
|
|
(for ([i (in-range i)])
|
|
(define goos (list-of-n-goo MAX-GOO))
|
|
(define goo-initial-expire (map goo-expire goos))
|
|
(check-equal? (map sub1 goo-initial-expire)
|
|
(map goo-expire (age-goo goos))))))
|
|
|
|
;; Property: The position of the goo is:
|
|
;; - x in (0,WIDTH-SEGS),
|
|
;; - y in (0,HEIGHT-SEGS).
|
|
(define (prop:new-goo-range i)
|
|
(test-begin
|
|
(for ([i (in-range i)])
|
|
(define f (fresh-goo))
|
|
(check-true (and (< 0 (posn-x (goo-loc f)) SIZE)
|
|
(< 0 (posn-y (goo-loc f)) SIZE))))))
|
|
|
|
;; Number -> [Listof Goo]
|
|
;; creates a list of randomly selected goo that is n long.
|
|
(define (list-of-n-goo n)
|
|
(cond [(zero? n) empty]
|
|
[else (define rand (random 5))
|
|
(cons (list-ref goo-list1 rand) (list-of-n-goo (sub1 n)))]))
|
|
|
|
;; testing pit-snake event handling
|
|
|
|
(check-equal? (pit-snake (world-change-dir (pit snake1 "foobar") "down"))
|
|
(snake "down" (list (posn 5 5))))
|
|
(check-equal? (pit-snake (world-change-dir (pit snake2 "left") "left"))
|
|
(snake "left" (list (posn 2 2) (posn 2 3) (posn 2 4))))
|
|
|
|
(prop:goo-rot-- 1000)
|
|
|
|
(check-equal? (grow snake0)
|
|
(snake "right" (list (posn 2 1) (posn 1 1))))
|
|
(check-equal? (grow snake1)
|
|
(snake "left" (list (posn 4 5) (posn 5 5))))
|
|
(check-equal? (grow snake0)
|
|
(snake "right" (list (posn 2 1)
|
|
(posn 1 1))))
|
|
|
|
(prop:new-goo-range 1000)
|
|
|
|
(check-equal? (can-eat (snake "right" `(,(posn 3 3))) `(,(goo (posn 3 3) 130)))
|
|
(goo (posn 3 3) 130))
|
|
(check-false (can-eat (snake "right" `(,(posn 3 3))) `(,(goo (posn 3 4) 130)
|
|
,(goo (posn 2 2) 0))))
|
|
(check-equal? (can-eat snake0 (list (goo (posn 1 1) 1)))
|
|
(goo (posn 1 1) 1))
|
|
(check-false (can-eat snake0 (list (goo (posn 2 1) 1))))
|
|
|
|
(check-equal? (slither snake0) (snake "right" (list (posn 2 1))))
|
|
(check-equal? (slither (snake "right" (list (posn 4 4)
|
|
(posn 4 5)
|
|
(posn 4 6))))
|
|
(snake "right" (list (posn 5 4) (posn 4 4) (posn 4 5))))
|
|
(check-equal? (slither snake0)
|
|
(snake "right" (list (posn 2 1))))
|
|
|
|
(check-equal? (length (eat (list (goo (posn 1 1) 130)) (goo (posn 1 1) 130)))
|
|
1)
|
|
(check-equal? (grow (snake "left" (list (posn 1 1))))
|
|
(snake "left" (list (posn 0 1) (posn 1 1))))
|
|
|
|
(check-equal? (next-head snake0) (posn 2 1))
|
|
(check-equal? (next-head (snake "left" (list (posn 1 1))))
|
|
(posn 0 1))
|
|
(check-equal? (next-head (snake "up" (list (posn 1 1))))
|
|
(posn 1 0))
|
|
(check-equal? (next-head (snake "down" (list (posn 1 1))))
|
|
(posn 1 2))
|
|
(check-equal? (next-head snake0) (posn 2 1))
|
|
|
|
(check-equal? (posn-move (posn 1 1) 2 3) (posn 3 4))
|
|
(check-equal? (posn-move (posn 3 4) 6 0) (posn 9 4))
|
|
(check-equal? (posn-move (posn 2 8) 0 5) (posn 2 13))
|
|
(check-equal? (posn-move (posn 2 3) 0 0) (posn 2 3))
|
|
|
|
(check-equal? (all-but-last '(1 2 3 4 5 6))
|
|
'(1 2 3 4 5))
|
|
(check-equal? (all-but-last (snake-segs snake2))
|
|
`(,(posn 2 2) ,(posn 2 3)))
|
|
(check-equal? (all-but-last (list 0)) empty)
|
|
(check-equal? (all-but-last (list 0 1 2)) (list 0 1))
|
|
|
|
;; testing snake-key-handling
|
|
|
|
(check-true (dir? "up"))
|
|
(check-true (dir? "down"))
|
|
(check-true (dir? "left"))
|
|
(check-true (dir? "right"))
|
|
(check-false (dir? "f"))
|
|
(check-true (dir? "right"))
|
|
|
|
(check-equal? (world-change-dir world1 "left") world1)
|
|
(check-equal? (world-change-dir world1 "right") right-world1)
|
|
(check-equal? (world-change-dir world0 "left") left-world0)
|
|
(check-equal? (world-change-dir world0 "right")
|
|
(pit (snake "right" (snake-segs (pit-snake world0)))
|
|
(pit-goos world0)))
|
|
(check-equal? (world-change-dir world0 "down")
|
|
(pit (snake "down" (snake-segs (pit-snake world0)))
|
|
(pit-goos world0)))
|
|
|
|
(check-true (opposite-dir? "up" "down"))
|
|
(check-true (opposite-dir? "left" "right"))
|
|
(check-true (opposite-dir? "right" "left"))
|
|
(check-true (opposite-dir? "down" "up"))
|
|
(check-false (opposite-dir? "left" "down"))
|
|
(check-false (opposite-dir? "right" "down"))
|
|
(check-false (opposite-dir? "down" "left"))
|
|
(check-false (opposite-dir? "up" "right"))
|
|
(check-true (opposite-dir? "up" "down"))
|
|
(check-true (opposite-dir? "down" "up"))
|
|
(check-false (opposite-dir? "up" "up") false)
|
|
(check-equal? (opposite-dir? "right" "left") true)
|
|
(check-equal? (opposite-dir? "left" "right") true)
|
|
|
|
;; testing snake rendering
|
|
|
|
(check-equal? (snake+scene snake1 MT-SCENE)
|
|
(place-image HEAD-LEFT-IMG (* 5 SEG-SIZE)
|
|
(* 5 SEG-SIZE) MT-SCENE))
|
|
(check-equal? (snake+scene snake2 MT-SCENE)
|
|
(img+scene (posn 2 2) HEAD-UP-IMG
|
|
(img+scene (posn 2 3) SEG-IMG
|
|
(img+scene (posn 2 4) SEG-IMG MT-SCENE))))
|
|
(check-equal? (snake+scene (snake "up" (list (posn 1 1))) MT-SCENE)
|
|
(img+scene (posn 1 1) HEAD-UP-IMG MT-SCENE))
|
|
|
|
(check-equal? (goo-list+scene (list goo1) MT-SCENE)
|
|
(place-image GOO-IMG (* 5 SEG-SIZE)
|
|
(* 5 SEG-SIZE) MT-SCENE))
|
|
(check-equal? (goo-list+scene goo-list1 MT-SCENE)
|
|
(img-list+scene (list (posn 5 5) (posn 4 8) (posn 6 9) (posn 1 1) (posn 1 9))
|
|
GOO-IMG MT-SCENE))
|
|
|
|
(check-equal? (img-list+scene (list (posn 3 3) (posn 4 4)) SEG-IMG MT-SCENE)
|
|
(place-image SEG-IMG (* 3 SEG-SIZE) (* 3 SEG-SIZE)
|
|
(place-image SEG-IMG (* 4 SEG-SIZE) (* 4 SEG-SIZE) MT-SCENE)))
|
|
(check-equal? (img-list+scene (list (posn 1 1) (posn 10 10)) SEG-IMG MT-SCENE)
|
|
(place-image SEG-IMG (* 1 SEG-SIZE) (* 1 SEG-SIZE)
|
|
(place-image SEG-IMG (* 10 SEG-SIZE) (* 10 SEG-SIZE) MT-SCENE)))
|
|
(check-equal? (img-list+scene (list (posn 1 1)) GOO-IMG MT-SCENE)
|
|
(place-image GOO-IMG SEG-SIZE SEG-SIZE
|
|
(img-list+scene empty GOO-IMG MT-SCENE)))
|
|
|
|
(check-equal? (img+scene (posn 4 3) SEG-IMG MT-SCENE)
|
|
(place-image SEG-IMG (* 4 SEG-SIZE) (* 3 SEG-SIZE) MT-SCENE))
|
|
(check-equal? (img+scene (posn 5 2) GOO-IMG MT-SCENE)
|
|
(place-image GOO-IMG (* 5 SEG-SIZE) (* 2 SEG-SIZE) MT-SCENE))
|
|
(check-equal? (img+scene (posn 1 1) SEG-IMG MT-SCENE)
|
|
(place-image SEG-IMG SEG-SIZE SEG-SIZE MT-SCENE))
|
|
|
|
;; testing the endgame
|
|
(check-false (self-colliding? snake1))
|
|
(check-false (self-colliding? snake2))
|
|
(check-false (self-colliding? wall-snake))
|
|
(check-true (self-colliding? self-eating-snake))
|
|
(check-false (self-colliding? snake0))
|
|
(check-true (self-colliding? (snake (snake-dir snake0)
|
|
(cons (posn 1 1)
|
|
(snake-segs snake0)))))
|
|
|
|
(check-false (wall-colliding? snake1))
|
|
(check-false (wall-colliding? snake2))
|
|
(check-false (wall-colliding? self-eating-snake))
|
|
(check-true (wall-colliding? wall-snake))
|
|
(check-true
|
|
(wall-colliding? (snake "right" (list (posn (/ WIDTH-PX SEG-SIZE) 0)))))
|
|
(check-true
|
|
(wall-colliding? (snake "down" (list (posn 0 (/ HEIGHT-PX SEG-SIZE))))))
|
|
(check-true
|
|
(wall-colliding? (snake "up" (list (posn 1 0)))))
|
|
(check-equal? (wall-colliding? (snake "right"
|
|
(list (posn 0 1))))
|
|
true)
|
|
(check-equal? (wall-colliding? (snake "right"
|
|
(list (posn 1 0))))
|
|
true)
|
|
(check-equal? (wall-colliding? (snake "right"
|
|
(list (posn 1 1))))
|
|
false)
|
|
(check-true (wall-colliding? (snake "right" (list (posn 1 SIZE)))))
|
|
|
|
|
|
;; testing utilities functions
|
|
|
|
(check-false (posn=? (posn 1 1) (posn 2 2)))
|
|
(check-false (posn=? (posn 1 2) (posn 2 1)))
|
|
(check-true (posn=? (posn 3 4) (posn 3 4)))
|
|
(check-true (posn=? (posn 2 2) (posn 2 2)))
|
|
(check-equal? (posn=? (posn 1 2) (posn 1 1)) false)
|
|
(check-equal? (posn=? (posn 1 2) (posn 1 2)) true)
|
|
(check-equal? (posn-move (posn 0 0) 2 3) (posn 2 3))
|
|
|
|
(check-equal? (snake-head snake1) (posn 5 5))
|
|
(check-equal? (snake-head snake2) (posn 2 2))
|
|
(check-equal? (snake-head snake0) (posn 1 1))
|
|
|
|
(check-equal? (snake-body snake1) empty)
|
|
(check-equal? (snake-body snake0) empty)
|
|
(check-equal? (snake-body snake2) (list (posn 2 3) (posn 2 4)))
|
|
|
|
(check-equal? (snake-change-dir snake0 "up")
|
|
(snake "up" (list (posn 1 1))))
|
|
(check-equal? (snake-change-dir snake1 "down")
|
|
(snake "down" (list (posn 5 5))))
|
|
(check-equal? (snake-change-dir snake2 "left")
|
|
(snake "left" (list (posn 2 2) (posn 2 3) (posn 2 4))))
|
|
|
|
(check-true (rotten? (goo (posn 1 2) 0)))
|
|
(check-true (rotten? (goo (posn 6 9) 0)))
|
|
(check-true (rotten? (goo (posn 23 2) 0)))
|
|
|
|
(check-false (rotten? (goo (posn 1 2) 2)))
|
|
(check-false (rotten? (goo (posn 3 45) 45334534)))
|
|
(check-false (rotten? (goo (posn 2 4) 9)))
|
|
|
|
(check-equal? (decay (goo (posn 1 2) 2))
|
|
(goo (posn 1 2) 1))
|
|
(check-equal? (decay (goo (posn 132 0) 2))
|
|
(goo (posn 132 0) 1))
|
|
(check-equal? (decay (goo (posn 1 2) 10))
|
|
(goo (posn 1 2) 9))
|
|
(check-equal? (decay (goo (posn 3 5) 8))
|
|
(goo (posn 3 5) 7))
|
|
|
|
"all tests run") |