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)))