Challenge: 2D Tank

The Challenge:
|---->Program a 2d tank application in the language of your choice that adheres to the following:

#-The tank must rotate using the left and right directional keys.
#-The tank must loosely resemble a tank.
#-The tank must move forward or backward respectively from the direction it is facing using the up and down directional keys.
#-Pressing spacebar must fire a 'shot' in the direction the tank is facing.
#-The perspective of the user must be fixed and facing down at the tank.
#-The tank, shot, and ground must each have their own color. (all shots may have the same color)

<------You have 24 hours!------>
GET TO WORK!

I wrote this earlier as a half OO/ half imperative piece of spaghetti. I had planned to give this a proper refactoring, but I got bored halfway through. If anyone else wants to sort it out, you can.

To run, save as tanks.ss, and use the command mred tanks.ss. You have to use mred instead of mzscheme because I used the scheme/gui library.

Also, thanks to the OP for the contest thread, they are always welcome.


#lang scheme/gui
(require scheme/set)
;;;BEGIN LICENSE: Goatse Prostate License (GPL)
;;;g                                               g 
;;;o /     \             \            /    \       o
;;;a|       |             \          |      |      a
;;;t|       `.             |         |       :     t
;;;s`        |             |        \|       |     s
;;;e \       | /       /  \\\   --__ \\       :    e
;;;x  \      \/   _--~~          ~--__| \     |    x 
;;;*   \      \_-~                    ~-_\    |    *
;;;g    \_     \        _.--------.______\|   |    g
;;;o      \     \______// _ ___ _ (_(__>  \   |    o
;;;a       \   .  C ___)  ______ (_(____>  |  /    a
;;;t       /\ |   C ____)/      \ (_____>  |_/     t
;;;s      / /\|   C_____)       |  (___>   /  \    s
;;;e     |   (   _C_____)\______/  // _/ /     \   e
;;;x     |    \  |__   \\_________// (__/       |  x
;;;*    | \    \____)   `----   --'             |  *
;;;g    |  \_          ___\       /_          _/ | g
;;;o   |              /    |     |  \            | o
;;;a   |             |    /       \  \           | a
;;;t   |          / /    |         |  \           |t
;;;s   |         / /      \__/\___/    |          |s
;;;e  |           /        |    |       |         |e
;;;x  |          |         |    |       |         |x
;;;Viewing this goatse gives you the right to freely
;;;use, modify, and distribute this code, as long as
;;;this GPL license comment, ASCII graphic included,
;;;continues to appear in its entirety alongside the
;;;GPL protected code.
;;;jagoffhour.appspot.com/goatse-prostate-license
;;;END LICENSE

;various utilities
(define no-pen       (make-object pen% "BLACK" 1 'transparent))
(define black-pen    (make-object pen% "BLACK" 2 'solid))
(define no-brush     (make-object brush% "BLACK" 'transparent))
(define yellow-brush (make-object brush% "YELLOW" 'solid))
(define green-brush  (make-object brush% "GREEN" 'solid))
(define blue-brush   (make-object brush% "BLUE" 'solid))

(define (pythagoras x y)
  (sqrt (+ (expt x 2) (expt y 2))))

; scheme/class doesn't support monkey patching :(
(define augmented-frame%
  (class frame%
    (define/augment (on-close)
      (send game timer-stop))
    (super-new)))

(define augmented-canvas%
  (class canvas%
    (init-field on-char-callback)
    (define/public (in-canvas? object)
      (let-values (((width height) (send this get-size)))
        (and (<= 0 (get-field x object) width)
             (<= 0 (get-field y object) height))))
    (define/override (on-char ch)
      (on-char-callback ch))
    (super-new)))

(define bullet%
  (class object%
    (init-field canvas x y direction (size 5) (speed 10))
    (super-new)
    (define/public (draw dc)
      (send dc set-pen black-pen)
      (send dc set-brush blue-brush)
      (send dc draw-ellipse x y size size))
    (define/public (update)
      (unless (send canvas in-canvas? this)
        (send game remove-updatee! this))
      (set! x (+ x (* speed (sin direction))))
      (set! y (- y (* speed (cos direction)))))))

(define tank%
  (class object%
    (init-field canvas x y (direction 0) (speed 20) (barrel-length 25) (barrel-width 10))
    (super-new)
    (define (draw-rectangle dc x y width height angle)
      ; ideally this would be a method of a class that implements dc<%>
      ; but since I'm only using it in the tank% class, I'm just making it private
      ; and keeping it here
      (let* ((p1 (make-object point% x y))
             (p2 (make-object point% (- x (* height (sin angle)))
                   (+ y (* height (cos angle)))))
             (p3 (make-object point% (+ x (* width (cos angle)))
                   (+ y (* width (sin angle)))))
             (diagonal-length (pythagoras width height))
             (theta (atan (/ height width)))
             (p4 (make-object point% (+ x (* diagonal-length (cos (+ theta angle))))
                   (+ y (* diagonal-length (sin (+ theta angle)))))))
        (send dc draw-polygon (list p1 p2 p4 p3))))
   
    (define/public (turn amount)
      (set! direction (+ direction amount)))
    (define/public (turn-left)
      (turn (- (/ pi 4))))
    (define/public (turn-right)
      (turn (/ pi 4)))
   
    (define/public (move speed)
      (set! x (+ x (* speed (sin direction))))
      (set! y (- y (* speed (cos direction)))))
    (define/public (move-forward)
      (move speed))
    (define/public (move-backward)
      (move (- speed)))
   
    (define (front-left-corner)
      (let ((hyp (pythagoras 20 10))
            (angle (atan (/ 20 10))))
        (values (+ x (* hyp (sin (- direction angle))))
                (- y (* hyp (cos (- direction angle)))))))
    (define (barrel-front-left)
      (values (+ x (* barrel-length (sin direction)))
              (- y (* barrel-length (cos direction)))))
   
    (define (draw-barrel dc)
      (let-values (((x y) (barrel-front-left)))
        (draw-rectangle dc x y barrel-width barrel-length direction)))
    (define (draw-body dc)
      (let-values (((x y) (front-left-corner)))
        (draw-rectangle dc x y 40 20 direction)))
    (define/public (draw dc)
      (send dc set-pen black-pen)
      (send dc set-brush yellow-brush)
      (draw-body dc)
      (draw-barrel dc))
   
    (define/public (shoot)
      (let-values (((x1 y1) (barrel-front-left)))
        (send game add-updatee! (new bullet% [canvas canvas][x x1] [y y1] [direction direction]))))))

(define game%
  (class object%
    (init-field title width height [updatees (set)])
   
    (define timer (new timer% [interval 100] [just-once? #f]
                       [notify-callback
                        (lambda ()
                          (set-for-each updatees (lambda (x) (send x update)))
                          (redraw))]))
   
    (define/public (add-updatee! object)
      (set! updatees (set-add updatees object)))
    (define/public (remove-updatee! object)
      (set! updatees (set-remove updatees object)))
    (define/public (timer-stop)
      (send timer stop))
   
    (define frame (new augmented-frame% [label title] [width width] [height height]))
    (define (redraw)
      (draw-background )
      (send tank draw dc)
      (set-for-each updatees (lambda (x) (send x draw dc))))
   
    (define canvas
      (new augmented-canvas% [parent frame]
           [paint-callback (lambda (canvas dc)
                             (redraw))]
           [on-char-callback
            (lambda (ch)
              (case (send ch get-key-code)
                ((left) (send tank turn-left))
                ((right) (send tank turn-right))
                ((up) (send tank move-forward))
                ((down) (send tank move-backward))
                ((#\space) (send tank shoot)))
              (redraw))]))
    (define dc (send canvas get-dc))
    (define (draw-background)
      (let-values (((width height) (send canvas get-client-size)))
        (send dc set-pen no-pen)
        (send dc set-brush green-brush)
        (send dc draw-rectangle 0 0 width height)))
    (define/public (show)
      (send frame show #t))
    (define tank
      (new tank% [canvas canvas][x 100] [y 100] [direction 0]))
    (super-new)))

(define game (new game% [title "Tank \"game\""] [width 300] [height 300]))

(send game show)