games/asteroids/asteroids.scm

   1 (set-game-properties! #:title "Gacela Asteroids")
   2
   3 (define max-x (/ (assoc-ref (get-game-properties) 'width) 2))
   4 (define min-x (- max-x))
   5 (define max-y (/ (assoc-ref (get-game-properties) 'height) 2))
   6 (define min-y (- max-y))
   7
   8 (define draw-asteroid
   9   (let ((asteroid (load-texture "Asteroid.png")))
  10     (lambda (a)
  11       (to-origin)
  12       (translate (car a) (cadr a))
  13       (rotate (caddr a))
  14       (draw-texture asteroid))))
  15
  16 (define (move-asteroid a)
  17   (let* ((x (car a)) (y (cadr a))
  18          (angle (caddr a))
  19          (vx (cadddr a)) (vy (cadddr (cdr a)))
  20          (nx (+ x vx)) (ny (+ y vy)))
  21     (cond ((> nx max-x) (set! vx -1))
  22           ((< nx min-x) (set! vx 1)))
  23     (cond ((> ny max-y) (set! vy -1))
  24           ((< ny min-y) (set! vy 1)))
  25     (set! angle (+ angle 1))
  26     (list (+ x vx) (+ y vy) angle vx vy)))
  27
  28 (define draw-ship
  29   (let ((ship1 (load-texture "Ship1.png"))
  30         (ship2 (load-texture "Ship2.png")))
  31     (lambda (s)
  32       (to-origin)
  33       (translate (assoc-ref s 'x) (assoc-ref s 'y))
  34       (rotate (assoc-ref s 'angle))
  35       (let ((ship (if (assoc-ref s 'moving) ship2 ship1)))
  36         (draw-texture ship)))))
  37
  38 (define (move-ship s)
  39   (let ((x (assoc-ref s 'x)) (y (assoc-ref s 'y))
  40         (angle (assoc-ref s 'angle))
  41         (moving (assoc-ref s 'moving)))
  42     (cond ((key? 'left) (set! angle (+ angle 5)))
  43           ((key? 'right) (set! angle (- angle 5))))
  44     (cond ((key? 'up)
  45            (let ((r (degrees-to-radians (- angle))))
  46              (set! x (+ x (* 4 (sin r))))
  47              (set! y (+ y (* 4 (cos r)))))
  48            (set! moving #t))
  49           (else
  50            (set! moving #f)))
  51     `((x . ,x) (y . ,y) (angle . ,angle) (moving . ,moving))))
  52
  53 (define (make-asteroids n)
  54   (define (xy n r)
  55     (let ((n2 (- (random (* n 2)) n)))
  56       (cond ((and (< n2 r) (>= n2 0)) r)
  57             ((and (> n2 (- r)) (< n2 0)) (- r))
  58             (else n2))))
  59
  60   (cond ((= n 0) '())
  61         (else
  62          (cons (list (xy max-x 20) (xy max-y 20) 0 1 1) (make-asteroids (- n 1))))))
  63
  64 (let ((asteroids (make-asteroids 2))
  65       (ship '((x . 0) (y . 0) (angle . 0) (moving . #f))))
  66   (run-game
  67    (set! asteroids (map move-asteroid asteroids))
  68    (set! ship (move-ship ship))
  69    (for-each draw-asteroid asteroids)
  70    (draw-ship ship)))