]> 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 (assoc-ref a 'x) (assoc-ref a 'y))
13       (rotate (assoc-ref a 'angle))
14       (draw-texture asteroid))))
15
16 (define (move-asteroid a)
17   (let* ((x (assoc-ref a 'x)) (y (assoc-ref a 'y))
18          (angle (assoc-ref a 'angle))
19          (vx (assoc-ref a 'vx)) (vy (assoc-ref a 'vy))
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     `((x . ,(+ x vx)) (y . ,(+ y vy)) (angle . ,angle) (vx . ,vx) (vy . ,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            (cond ((> x max-x) (set! x min-x))
49                  ((< x min-x) (set! x max-x)))
50            (cond ((> y max-y) (set! y min-y))
51                  ((< y min-y) (set! y max-y)))
52            (set! moving #t))
53           (else
54            (set! moving #f)))
55     `((x . ,x) (y . ,y) (angle . ,angle) (moving . ,moving))))
56
57 (define (ship-shot s)
58   (cond ((key-released? 'space)
59          #f)))
60
61 (define (make-asteroids n)
62   (define (xy n r)
63     (let ((n2 (- (random (* n 2)) n)))
64       (cond ((and (< n2 r) (>= n2 0)) r)
65             ((and (> n2 (- r)) (< n2 0)) (- r))
66             (else n2))))
67
68   (cond ((= n 0) '())
69         (else
70          (cons `((x . ,(xy max-x 20)) (y . ,(xy max-y 20)) (angle . 0) (vx . 1) (vy . 1)) (make-asteroids (- n 1))))))
71
72 (let ((asteroids (make-asteroids 2))
73       (ship '((x . 0) (y . 0) (angle . 0) (moving . #f)))
74       (shots '())
75   (run-game
76    (set! asteroids (map move-asteroid asteroids))
77    (set! ship (move-ship ship))
78    (let ((shot (ship-shot ship)))
79      (cond (shot
80             (set! shots (cons shot shots)))))
81    (for-each draw-asteroid asteroids)
82    (draw-ship ship)))