snake game

snake.rkt

#lang racket/gui
(require data/queue)
(define snake%
  (class object%
    (super-new)
    (init w h)
    (define x (inexact->exact (floor (/ w 2))))
    (define y (inexact->exact (floor (/ h 2))))
    (define dir 'E)
    (define body (let ((q (make-queue)))
                   (map (λ (e) (enqueue! q e)) 
                        `((,(- x 2) . ,y) (,(- x 1) . ,y)(,x . ,y))) q))
    (define len 3)
    (define/public (set-dir d) (set! dir d))
    (define/public (move)
      (case dir
        [(N) (if (valid x (sub1 y)) (begin (set! y (sub1 y)) (moved) (cons x y)) #f)]
        [(S) (if (valid x (add1 y)) (begin (set! y (add1 y)) (moved) (cons x y)) #f)]
        [(E) (if (valid (add1 x) y) (begin (set! x (add1 x)) (moved) (cons x y)) #f)]
        [(W) (if (valid (sub1 x) y) (begin (set! x (sub1 x)) (moved) (cons x y)) #f)]))
    (define (valid x y)
      (and (>= x 0) (>= y 0) (< x w) (< y h)
           (not (member (cons x y) (queue->list body)))))
    (define/public (grow) (set! len (add1 len)) len)
    (define/public (moved)
      (enqueue! body (cons x y))
      (when (> (queue-length body) len) (dequeue! body)))
    (define/public (get-body) (queue->list body))))

(define game%
  (class canvas%
    (super-new)
    (inherit get-dc)
    (define interval 100)
    (define width 800)
    (define height 480)
    (define snake (make-object snake% (/ width 10) (/ height 10)))
    (define food-timer 1)
    (define food '())
    (define tick? #t)
    (define game-over? #f)
    (define sb-brush (make-object brush% "red" 'solid))
    (define food-brush (make-object brush% "green" 'solid))
    (send (get-dc) set-background (make-object color% 0 0 0))
    (send (get-dc) set-text-foreground "red")
    (define (draw-pt pt) (send (get-dc) draw-rectangle (* 10 (car pt)) (* 10 (cdr pt)) 10 10))  
    (define/override (on-char e)
      (case (send e get-key-code)
        [(up #\w #\W)    (send snake set-dir 'N)]
        [(down #\s #\S)  (send snake set-dir 'S)]
        [(left #\a #\A)  (send snake set-dir 'W)]
        [(right #\d #\D) (send snake set-dir 'E)]
        [(#\q #\Q) (set! game-over? #t)]))
    (define/override (on-paint)
      (send (get-dc) clear)
      (cond [game-over?
             (send (get-dc) draw-text 
                   (format "DEAD.  SCORE: ~a" (- (length (send snake get-body)) 3))
                   300 200)]
            [else
             (send (get-dc) set-brush food-brush)
             (for-each draw-pt food)
             (send (get-dc) set-brush sb-brush)
             (for-each draw-pt (send snake get-body))]))
    (define/public (tick)
      (unless game-over?
        (let ((mv (send snake move)))
          (set! food-timer (sub1 food-timer))
          (cond [(not mv) (set! game-over? #t)]
                [(member mv food) => (λ (f) (set! food (remove (car f) food))
                                       (when (= 0 (modulo (send snake grow) 5)) (speed-up)))]
                [(<= food-timer 0) (generate-food) (set! food-timer (+ 15 (random 50)))]))))
    (define (generate-food)
      (let ([occ (append food (send snake get-body))])
        (let loop ([p (cons (random 80) (random 48))])
          (if (member p occ) (loop (cons (random 80) (random 48)))
              (set! food (cons p food))))))
    (define/public (game-is-over?) game-over?)))
(define sema (make-semaphore 0))
(define frame (make-object (class frame% (define/augment (on-close) 
                                           (semaphore-post sema)
                                           (inner (void) on-close))
                             (super-new)) "SNNAAAAAAKEEE!!"))
(define cvs (make-object game% frame))
(send cvs min-width 800)
(send cvs min-height 480)
(send frame show #t)
(define timer-speed 100)
(define timer
  (new timer% [interval timer-speed]
       [notify-callback
        (λ () (cond [(send cvs game-is-over?) (send timer stop)]
                    [else (send cvs tick) (send cvs refresh)]))]))
(define (speed-up)
  (define (reduce-ticks) (set! timer-speed (- timer-speed 5)))
  (when (>= timer-speed 50) 
    (when (= timer-speed 50) (displayln "TOP SPEED!!!"))
    (reduce-ticks)))
(void (yield sema))