]> git.jsancho.org Git - gacela.git/blob - games/asteroids/asteroids.scm
Adjustments for running games from emacs or shell.
[gacela.git] / games / asteroids / asteroids.scm
1 #!/usr/bin/guile \
2 -e gacela-script -s
3 !#
4
5 (use-modules (gacela gacela)
6              (gacela math))
7 (init-gacela)
8
9 (set-game-properties! #:title "Gacela Asteroids")
10
11 (define max-x (/ (assoc-ref (get-game-properties) 'width) 2))
12 (define min-x (- max-x))
13 (define max-y (/ (assoc-ref (get-game-properties) 'height) 2))
14 (define min-y (- max-y))
15
16
17 ;;; Asteroids
18
19 (define-checking-mobs (asteroid-shots x y size) (shot (sx x) (sy y))
20   (if (< (distance-between-points (list sx sy) (list x y)) size) 1 0))
21
22 (define (asteroid-killed? x y size)
23   (> (apply + (asteroid-shots x y size)) 0))
24
25 (define-mob (asteroid
26              (image (load-texture "Asteroid.png"))
27              (x 0) (y 0) (angle 0) (dir 0) (size 100))
28   (cond ((asteroid-killed? x y size)
29          (kill-me))
30         (else
31          (let ((r (degrees-to-radians (- dir))))
32            (set! x (+ x (sin r)))
33            (set! y (+ y (cos r))))
34          (set! angle (+ angle 1))
35
36          (cond ((or (> x max-x) (< x min-x))
37                 (set! dir (* -1 dir))))
38          (cond ((or (> y max-y) (< y min-y))
39                 (set! dir (- 180 dir))))))
40   
41   (translate x y)
42   (rotate angle)
43   (draw-texture image))
44
45
46 ;;; Ship
47
48 (define-mob (ship
49              (ship1 (load-texture "Ship1.png"))
50              (ship2 (load-texture "Ship2.png"))
51              (x 0) (y 0) (angle 0)
52              (moving #f))
53   (cond ((key? 'left) (set! angle (+ angle 5)))
54         ((key? 'right) (set! angle (- angle 5))))
55   (cond ((key? 'up)
56          (let ((r (degrees-to-radians (- angle))))
57            (set! x (+ x (* 4 (sin r))))
58            (set! y (+ y (* 4 (cos r)))))
59          (cond ((> x max-x) (set! x min-x))
60                ((< x min-x) (set! x max-x)))
61          (cond ((> y max-y) (set! y min-y))
62                ((< y min-y) (set! y max-y)))
63          (set! moving #t))
64         (else
65          (set! moving #f)))
66   (cond ((key-pressed? 'space)
67          (show-mob (make-shot #:x x #:y y #:angle angle))))
68
69   (translate x y)
70   (rotate angle)
71   (draw-texture (if moving ship2 ship1)))
72
73
74 ;;; Shots
75
76 (define-checking-mobs (impacted-shots x y) (asteroid (ax x) (ay y) (size size))
77   (if (< (distance-between-points (list ax ay) (list x y)) size) 1 0))
78
79 (define (shot-killed? x y)
80   (> (apply + (impacted-shots x y)) 0))
81
82 (define-mob (shot (x 0) (y 0) (angle 0))
83   (cond ((shot-killed? x y)
84          (kill-me))
85         (else
86          (let ((r (degrees-to-radians (- angle))))
87            (set! x (+ x (* 10 (sin r))))
88            (set! y (+ y (* 10 (cos r))))
89            (cond ((or (> x max-x)
90                       (< x min-x)
91                       (> y max-y)
92                       (< y min-y))
93                   (kill-me))))))
94
95   (translate x y)
96   (rotate angle)
97   (draw-line 10))
98
99
100 ;;; Game
101
102 (define (init-asteroids n)
103   (cond ((> n 0)
104          (let ((x (- (random (* max-x 2)) max-x))
105                (y (- (random (* max-y 2)) max-y)))
106            (cond ((< (distance-between-points (list x y) '(0 0)) 120)
107                   (init-asteroids n))
108                  (else
109                   (let ((angle (random 360)) (dir (- (random 360) 180)))
110                     (show-mob (make-asteroid #:x x #:y y #:angle angle #:dir dir)))
111                   (init-asteroids (- n 1))))))))
112
113
114 (init-asteroids 2)
115 (show-mob (make-ship))
116      
117 (let ((font (load-font "../tetris/lazy.ttf" #:size 20)))
118   (game
119    (render-text (format #f "Mobs: ~a" (length (get-active-mobs))) font)))
120
121
122 ;;   (define (new-game n)
123 ;;     (set! asteroids (make-asteroids n))
124 ;;     (set! ship '((x . 0) (y . 0) (angle . 0) (moving . #f)))
125 ;;     (set! shots '()))
126
127 ;;   (new-game 2)
128
129 ;; (define (killed-ship? s a)
130 ;;   (cond ((null? a) #f)
131 ;;      (else
132 ;;       (or (< (distance-between-points (list (assoc-ref s 'x) (assoc-ref s 'y))
133 ;;                                       (list (assoc-ref (car a) 'x) (assoc-ref (car a) 'y)))
134 ;;              (assoc-ref (car a) 'size))
135 ;;           (killed-ship? s (cdr a))))))
136
137
138 ;; (let ((asteroids #f) (ship #f) (shots #f))
139
140 ;;   (run-game
141 ;;    (cond ((killed-ship? ship asteroids)
142 ;;        (new-game 2)))
143 ;;    (receive (s a) (kill-asteroids shots asteroids)
144 ;;          (set! shots s)
145 ;;          (set! asteroids a))
146 ;;    (set! asteroids (map move-asteroid asteroids))
147 ;;    (set! ship (move-ship (alist-copy ship)))
148 ;;    (let ((shot (ship-shot ship)))
149 ;;      (cond (shot
150 ;;          (set! shots (cons shot shots)))))
151 ;;    (set! shots (move-shots shots))
152 ;;    (for-each draw-asteroid asteroids)
153 ;;    (for-each draw-shot shots)
154 ;;    (draw-ship ship)))