snake-rkt/private/ui.rkt

#lang racket/gui

(require
  "snake.rkt")

(provide
  make-gui-snake run-gui-snake)

; Game constants
(define *FRAME-WIDTH* 640)
(define *FRAME-HEIGHT* 480)
(define *TILE-SIZE* 16)
(define *WIDTH* 40)
(define *HEIGHT* 30)
(define *SNAKE-HEADING* *NORTH*)
(define *SNAKE-LENGTH* 3)
(define *SNAKE-GROWTH* 2)
(define *NB-PREYS* 20)

; Canvas for drawing the game and handling keyboard events
(define snake-canvas%
  (class canvas%
    (init game tiles-path)
    (define gm game)
    (define tiles (read-bitmap tiles-path))
    (define timer
      (new timer% [notify-callback
                    (lambda ()
                      (if (not (game-over? gm))
                          (begin
                            (update-game! gm)
                            (send this refresh))
                          (send this stop-timer)))
                    ]))

    ; Override method for keyboard events
    (define/override (on-char event)
      (when (not (game-over? gm))
        (let ((snk (game-snake gm))
              (key-code (send event get-key-code)))
          (case key-code
            ((up) (turn-snake! snk *NORTH*))
            ((down) (turn-snake! snk *SOUTH*))
            ((left) (turn-snake! snk *WEST*))
            ((right) (turn-snake! snk *EAST*))
            (else #f)))))

    ; Draw a tile
    (define (draw-tile dc pos tile-idx)
      (send dc draw-bitmap-section tiles
            (* *TILE-SIZE* (car pos)) (* *TILE-SIZE* (cdr pos))
            (* *TILE-SIZE* (car tile-idx)) (* *TILE-SIZE* (cdr tile-idx))
            *TILE-SIZE* *TILE-SIZE*))

    ; Get the snake tile from the previous and current positions
    (define (get-snake-tile-idx pos-2 pos-1 pos)
      (if pos-2
        ; Not head
        (let ((diff-1 (-pos pos-2 pos-1))
              (diff (-pos pos-1 pos)))
          (cond
            ((and (=pos diff-1 *NORTH*) (=pos diff *NORTH*)) '(0 . 2))
            ((and (=pos diff-1 *SOUTH*) (=pos diff *SOUTH*)) '(0 . 2))
            ((and (=pos diff-1 *EAST*) (=pos diff *EAST*)) '(1 . 2))
            ((and (=pos diff-1 *WEST*) (=pos diff *WEST*)) '(1 . 2))
            ((and (=pos diff-1 *EAST*) (=pos diff *SOUTH*)) '(0 . 3))
            ((and (=pos diff-1 *NORTH*) (=pos diff *WEST*)) '(0 . 3))
            ((and (=pos diff-1 *EAST*) (=pos diff *NORTH*)) '(1 . 3))
            ((and (=pos diff-1 *SOUTH*) (=pos diff *WEST*)) '(1 . 3))
            ((and (=pos diff-1 *WEST*) (=pos diff *NORTH*)) '(2 . 3))
            ((and (=pos diff-1 *SOUTH*) (=pos diff *EAST*)) '(2 . 3))
            ((and (=pos diff-1 *WEST*) (=pos diff *SOUTH*)) '(3 . 3))
            ((and (=pos diff-1 *NORTH*) (=pos diff *EAST*)) '(3 . 3))
            (#t '(1 . 0))))
        ; Else: head
        (let ((diff (-pos pos-1 pos)))
          (cond
             ((=pos diff *NORTH*) '(0 . 1))
             ((=pos diff *EAST*) '(1 . 1))
             ((=pos diff *SOUTH*) '(2 . 1))
             ((=pos diff *WEST*) '(3 . 1))
             (#t '(1 . 0))))))

    ; Draw the snake tail
    (define (draw-snake-tail dc last-pos)
      (let* ((pos (cadr last-pos))
             (pos-1 (car last-pos))
             (diff (-pos pos-1 pos))
             (tile-idx
              (cond
                ((=pos diff *NORTH*) '(0 . 4))
                ((=pos diff *EAST*) '(1 . 4))
                ((=pos diff *SOUTH*) '(2 . 4))
                ((=pos diff *WEST*) '(3 . 4))
                (#t '(1 . 0)))))
        (draw-tile dc pos tile-idx)))

    ; Draw the snake
    (define (draw-snake dc)
      (let* ((snk (game-snake gm))
             (positions (snake-positions snk)))
        (foldl
          (lambda (pos old-pos) ; old-pos contain the two previous positions
            (if old-pos
              ; Draw the previous tile
              (let ((tile-idx (get-snake-tile-idx (car old-pos) (cdr old-pos) pos)))
                (draw-tile dc (cdr old-pos) tile-idx)
                (cons (cdr old-pos) pos))
              (cons old-pos pos)))
          #f
          positions)
        (draw-snake-tail dc (reverse (take (reverse (remove-duplicates positions)) 2)))))

    ; Draw the preys
    (define (draw-preys dc)
      (for-each
        (lambda (pos)
          (draw-tile dc pos '(0 . 0)))
        (game-preys gm)))

    (define *TEXT-COLOR* (make-color 255 0 0 1.0))
    (define *TEXT-FONT* (make-font #:size 30))
    ; Override the on-paint method for drawing canvas
    (define/override (on-paint)
      (let ((dc (send this get-dc)))
        ; Clear
        (send dc clear)
        ; Text features
        (send dc set-text-foreground *TEXT-COLOR*)
        (send dc set-font *TEXT-FONT*)
        (case (game-over? gm)
          ((#f)
           ; Draw snake
           (draw-snake dc)
           ; Draw preys
           (draw-preys dc))
          ((WON)
           (call-with-values
             (lambda () (send dc get-text-extent "GAME WON"))
             (lambda (width height . rest)
               (send dc draw-text "GAME WON" (/ (- *FRAME-WIDTH* width) 2) (/ (- *FRAME-HEIGHT* height) 2)))))
          ((LOST)
           (call-with-values
             (lambda () (send dc get-text-extent "GAME LOST"))
             (lambda (width height . rest)
               (send dc draw-text "GAME LOST" (/ (- *FRAME-WIDTH* width) 2) (/ (- *FRAME-HEIGHT* height) 2))))))))

    ; Start game
    (define/public (start-timer period)
      (send timer start period))

    ; Stop game
    (define/public (stop-timer)
      (send timer stop))

    ; Call the superclass init
    (super-new)))

; GUI structure
(struct gui-snake
  (frame
   canvas
   game))

; Instanciation
(define (make-gui-snake tiles-path)
  (let* ((frame (new frame% [label "Snake"][width *FRAME-WIDTH*][height *FRAME-HEIGHT*]))
         (game (make-game *WIDTH* *HEIGHT* *SNAKE-HEADING* *SNAKE-LENGTH* *SNAKE-GROWTH* *NB-PREYS*))
         (canvas (new snake-canvas% [game game] [tiles-path tiles-path] [parent frame])))
    (gui-snake
      frame
      canvas
      game)))

; Run the game
(define (run-gui-snake gui)
  (send (gui-snake-frame gui) show #t)
  ; Start the timer for updating the game
  (send (gui-snake-canvas gui) start-timer 200))