]> git.jsancho.org Git - gacela.git/blob - games/asteroids/asteroids.scm
(no commit message)
[gacela.git] / 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)))