Skip to content
This repository
branch: master
file 578 lines (490 sloc) 20.77 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577
;;;; ASTeroids

; vim: ts=2 sts=2 sw=2 et ai
(ql:quickload "lispbuilder-sdl")
(ql:quickload "lispbuilder-sdl-gfx")

(defpackage :asteroids
  (:use :cl :sdl)
  (:export main))

(in-package :asteroids)

(defparameter *map-width* 640)
(defparameter *map-height* 480)

(defparameter *window* nil)
(defparameter *window-width* 640)

(defparameter *deceleration* 0.99)

(defparameter *ticks* 0)

(defparameter *powerup-max-age* 9)
(defparameter *explosion-max-radius* 0.5)

(defun vector-sum (a b)
  (mapcar #'+ a b))

(defun vector-scale (v factor)
  (mapcar #'* v (list factor factor)))

(defun vector-subtract (a b)
  (mapcar #'- a b))

;;; distance between point a and point b
;;; parameters must be lists of 2 numbers (x y)
(defun my-distance (a b)
  (sqrt (apply #'+
               (mapcar (lambda (x)
                         (expt x 2))
                       (vector-subtract a b)))))

(defun square-from-midpoint (point radius)
  (rectangle-from-midpoint-* (x point)
                             (y point)
                             (* radius 2)
                             (* radius 2)))

(defun deg->rad (degs)
  (* degs (/ pi 180)))

(defun rad->deg (rads)
  (* rads (/ 180 pi)))

(defun radial-point-from (p radius angle)
  (point :x (+ (* radius (sin (deg->rad angle))) (x p))
         :y (+ (* radius (cos (deg->rad angle))) (y p))))

(defun get-ticks ()
  (let ((ticks (shiftf *ticks* (sdl-get-ticks))))
    (* (- *ticks* ticks) 0.001)))

;;; represents an object on the game map
(defclass mob ()
  ((pos :initarg :pos :initform '(0.5 0.5) :accessor pos)
   (radius :initarg :radius :accessor radius)
   (velocity :initarg :velocity :initform '(0 0) :accessor velocity)))

(defclass asteroid (mob)
  ((size :initarg :size :initform 'big :reader size)
   (radii :initform nil :accessor radii)
   (rotation :initform (* (- (random 1.0) 0.5) 5) :reader rotation)
   (facing :initform 0 :accessor facing)
   (pos :initform `(,(random 1.0) ,(random 1.0)))))

(defclass bullet (mob)
  ((radius :initform 0.005)
   (ship :initarg :ship :accessor ship)))

(defclass explosion (mob)
  ((radius :initform 0)))

(defclass powerup (mob)
  ((radius :initform 0.03)
   (age :initform 0 :accessor age)))

(defclass bullet-powerup (powerup) ())

(defclass freeze-powerup (powerup) ())

(defclass shield-powerup (powerup) ())

(defclass ship (mob)
  ((timers :initform (make-hash-table) :accessor timers)
   (acceleration :initform '(0 0) :accessor acceleration)
   (facing :initform 0 :accessor facing)
   (radius :initform 0.04)))

(defclass timer ()
  ((remaining :initarg :seconds :initform 0 :accessor remaining)))

(defclass world ()
  ((mobs :initform nil :accessor mobs)
   (ship :initform nil :accessor ship)
   (bullet :initform nil :accessor bullet)
   (timers :initform (make-hash-table) :accessor timers)
   (level :initform 0 :accessor level)
   (num-asteroids :initform 0 :accessor num-asteroids)
   (score :initform 0 :accessor score)
   (max-level :initform 0 :accessor max-level)
   (high-score :initform 0 :accessor high-score)
   (lives :initform 0 :accessor lives)))

(defmethod collide ((mob mob) (other mob) (world world)) t)

(defmethod map-coords ((mob mob))
  (destructuring-bind (x y) (pos mob)
    (point :x (round (* x *map-width*))
           :y (round (* y *map-height*)))))

(defun relative-coords (x y)
  (list (/ x *map-width*) (/ y *map-height*)))

(defmethod map-radius ((mob mob))
  (round (* (radius mob) *map-width*)))

(defmethod update ((mob mob) time-delta (world world))
  (setf (pos mob)
        (mapcar (lambda (x) (mod x 1))
                (vector-sum (pos mob)
                            (vector-scale (velocity mob)
                                          time-delta)))))

(defmethod intersects-p ((mob mob) (other mob))
  (< (my-distance (pos mob) (pos other))
     (+ (radius mob) (radius other))))

(defmethod render ((mob mob))
  (values))

(defmethod initialize-instance :after ((asteroid asteroid) &key)
  (let ((radius (cdr (assoc (size asteroid)
                            '((big . 0.1) (medium . 0.075) (small . 0.05)))))
        (spd (cdr (assoc (size asteroid)
                         '((big . 0.1) (medium . 0.15) (small . 0.25))))))
    (setf (radius asteroid) radius)
    (setf (radii asteroid)
          (loop for i from 0 below 20
            collect (round (* (+ 0.9 (random 0.2))
                              (map-radius asteroid)))))
    (setf (velocity asteroid)
          `(,(- (random (* 2 spd)) spd) ,(- (random (* 2 spd)) spd)))))

(defun random-powerup (&key pos)
  (make-instance (case (random 3)
                   (0 'bullet-powerup)
                   (1 'freeze-powerup)
                   (2 'shield-powerup))
                 :pos pos))

(defmethod break-down ((asteroid asteroid) (world world))
  (with-slots ((pos pos) (size size)) asteroid
    (if (eq size 'small)
      ;; gradually reduce the probability of powerups appearing
      (if (< (random 100) (/ 100 (+ 4 (* (level world) 0.3))))
          `(,(random-powerup :pos pos))
          nil)
      (let ((smaller (cond
                     ((eq size 'big) 'medium)
                     ((eq size 'medium) 'small))))
        `(,(make-instance 'asteroid :pos pos :size smaller)
          ,(make-instance 'asteroid :pos pos :size smaller))))))

(defmethod done ((timer timer))
  (<= (ceiling (remaining timer)) 0))

(defmethod frozen-p ((world world))
  (let ((timer (gethash 'freeze (timers world) nil)))
    (and timer
         (not (done timer)))))

(defmethod update ((asteroid asteroid) time-delta (world world))
  (declare (ignore time-delta))
  (when (not (frozen-p world))
    (incf (facing asteroid) (rotation asteroid))
    (call-next-method)))

(defmethod render ((asteroid asteroid))
  (draw-polygon (loop for i from 0
                      for r in (radii asteroid)
                  collect (radial-point-from (map-coords asteroid) r
                                             (+ (facing asteroid)
                                                (* i 18))))
                :color *white*))

(defmethod remove-from-world ((world world) (mob mob))
  (setf (mobs world) (remove mob (mobs world))))

(defmethod remove-from-world :after ((world world) (asteroid asteroid))
  (decf (num-asteroids world)))

(defmethod remove-from-world :after ((world world) (ship ship))
  (setf (ship world) nil))

(defmethod update ((powerup powerup) time-delta (world world))
  (when (> (ceiling (incf (age powerup) time-delta))
           *powerup-max-age*)
    (remove-from-world world powerup)))

(defmethod add-score ((world world) (score number))
  (setf (high-score world)
        (max (incf (score world) score)
             (high-score world))))

(defmethod add-score ((world world) (powerup powerup))
  (add-score world (* (level world) 10)))

(defmethod add-score ((world world) (asteroid asteroid))
  (add-score world (cdr (assoc (size asteroid)
                               '((big . 1) (medium . 2) (small . 5))))))

(defmethod collide :before ((ship ship) (powerup powerup) (world world))
  (remove-from-world world powerup)
  (add-score world powerup))

(defmethod powerup-active-p ((ship ship) powerup)
  (let ((timer (gethash powerup (timers ship) nil)))
    (and timer
         (not (done timer)))))

(defmethod add-seconds ((timer timer) seconds)
  (incf (remaining timer) seconds))

(defmethod add-shield ((ship ship) &key (seconds 0))
  (if (powerup-active-p ship 'shield)
    (add-seconds (gethash 'shield (timers ship)) seconds)
    (setf (gethash 'shield (timers ship))
          (make-instance 'timer :seconds seconds))))

(defmethod collide :before ((ship ship) (powerup shield-powerup) (world world))
  (add-shield ship :seconds 6))

(defmethod render ((powerup shield-powerup))
  (let ((coords (map-coords powerup))
        (radius (map-radius powerup)))
    (draw-circle coords radius
                 :color *green*)
    (draw-polygon `(,(radial-point-from coords (round (* radius 0.8)) 40)
                    ,(radial-point-from coords (round (* radius 0.8)) 0)
                    ,(radial-point-from coords (round (* radius 0.8)) -40)
                    ,(radial-point-from coords (round (* radius 0.8)) -135)
                    ,(radial-point-from coords (round (* radius 0.8)) 135))
                  :color *white*)))

(defmethod add-super-bullets ((ship ship) &key (seconds 0))
  (if (powerup-active-p ship 'super-bullets)
    (add-seconds (gethash 'super-bullets (timers ship)) seconds)
    (setf (gethash 'super-bullets (timers ship))
          (make-instance 'timer :seconds seconds))))

(defmethod collide :before ((ship ship) (powerup bullet-powerup) (world world))
  (add-super-bullets ship :seconds 6))

(defmethod render ((powerup bullet-powerup))
  (let ((coords (map-coords powerup))
        (radius (map-radius powerup)))
    (draw-circle coords radius
                 :color *magenta*)
    (draw-circle coords (round (* radius 0.3))
                 :color *white*)))

(defmethod add-freeze ((world world) &key (seconds 0))
  (if (frozen-p world)
    (add-seconds (gethash 'freeze (timers world)) seconds)
    (setf (gethash 'freeze (timers world))
          (make-instance 'timer :seconds seconds))))

(defmethod collide :before ((ship ship) (powerup freeze-powerup) (world world))
  (add-freeze world :seconds 6))

(defmethod render ((powerup freeze-powerup))
  (let ((coords (map-coords powerup))
        (radius (map-radius powerup)))
    (draw-circle coords radius
                 :color *cyan*)
    (draw-polygon (loop for i from 0 to 11
                    collect (radial-point-from coords
                                               (round (* radius (if (= (mod i 2) 0)
                                                                       0.7
                                                                       0.2)))
                                               (* i 30)))
                  :color *white*)))

(defmethod add-to-world ((world world) (mob mob))
  (setf (mobs world) (cons mob (mobs world)))
  (values mob))

(defmethod collide :before ((ship ship) (asteroid asteroid) (world world))
  (unless (powerup-active-p ship 'shield)
    (remove-from-world world ship)
    (add-to-world world (make-instance 'explosion :pos (pos ship)))
    (decf (lives world))))

(defmethod in-world-p ((world world) (mob mob))
  (find mob (mobs world)))

(defmethod ship-moved ((world world) (ship ship))
  (dolist (mob (mobs world))
    (when (and (not (eq ship mob))
               (intersects-p ship mob))
      (collide ship mob world))
    ;; if a collision destroyed the ship, stop checking for collisions
    (when (not (in-world-p world ship))
      (return ship))))

(defmethod update-timer ((timer timer) time-delta)
  (unless (done timer)
    (decf (remaining timer) time-delta)))

(defmethod update :around ((ship ship) time-delta (world world))
  (setf (velocity ship)
        (vector-scale (vector-sum (velocity ship)
                                  (acceleration ship))
                      *deceleration*))
  (maphash (lambda (name timer)
             (declare (ignore name))
             (update-timer timer time-delta))
           (timers ship))
  (call-next-method)
  (ship-moved world ship))

(defmethod thrust-at ((ship ship) coords)
  (setf (acceleration ship)
        (vector-sum (acceleration ship)
                    (vector-scale (vector-subtract coords (pos ship))
                                  0.03))))

(defmethod stop-thrust ((ship ship))
  (setf (acceleration ship) '(0 0)))

(defmethod shoot-at ((ship ship) coords (world world))
  (let ((bullet (make-instance 'bullet :pos (pos ship)
                                       :ship ship)))
    (setf (velocity bullet)
          (vector-scale (vector-subtract coords (pos bullet))
                        3))
    (add-to-world world bullet)))

(defmethod render ((ship ship))
  (let* ((coords (map-coords ship))
         (radius (map-radius ship))
         (facing (facing ship))
         (nose (radial-point-from coords radius facing))
         (left (radial-point-from coords radius (- facing 130)))
         (right (radial-point-from coords radius (+ facing 130)))
         (tail (radial-point-from coords (round (* radius 0.5)) (+ facing 180))))
    (draw-polygon (list nose left tail right)
                  :color *white*)
    (when (powerup-active-p ship 'shield)
          (draw-circle coords
                      (round (+ radius (random 3)))
                      :color *green*))))

(defmethod super-p ((bullet bullet))
  (powerup-active-p (ship bullet) 'super-bullets))

(defmethod collide :before ((bullet bullet) (asteroid asteroid) (world world))
  (remove-from-world world asteroid)
  (when (not (super-p bullet))
    (remove-from-world world bullet))
  (mapcar (lambda (mob)
            (add-to-world world mob))
          (break-down asteroid world))
  (add-to-world world (make-instance 'explosion :pos (pos asteroid)))
  (add-score world asteroid))

(defmethod render ((bullet bullet))
  (let ((coords (map-coords bullet))
        (radius (map-radius bullet)))
    (draw-circle coords radius
                 :color *red*)
    (when (super-p bullet)
          (draw-circle coords (+ (random 3))
                       :color *magenta*))))

(defmethod bullet-moved ((world world) (bullet bullet))
  (dolist (mob (mobs world))
    (when (and (not (eq bullet mob))
               (intersects-p bullet mob))
      (collide bullet mob world))
    (when (not (in-world-p world bullet))
      (return bullet))))

(defmethod update ((bullet bullet) time-delta (world world))
  (setf (pos bullet)
        (vector-sum (pos bullet)
                    (vector-scale (velocity bullet)
                                  time-delta)))
  (destructuring-bind (x y) (pos bullet)
    (when (or (not (< 0 x *map-width*))
              (not (< 0 y *map-height*)))
      (remove-from-world world bullet)))
  (bullet-moved world bullet))

(defmethod render ((explosion explosion))
  (let ((coords (map-coords explosion))
        (radius (map-radius explosion)))
    (draw-circle coords radius :color *red*)
    (draw-circle coords
                 (+ radius (random 3))
                 :color *red*)))

(defmethod update ((explosion explosion) time-delta (world world))
  (when (> (incf (radius explosion) time-delta)
           *explosion-max-radius*)
    (remove-from-world world explosion)))

(defmethod start-next-level ((world world))
  (with-accessors ((level level)
                   (max-level max-level)
                   (mobs mobs)
                   (timers timers)
                   (ship ship))
                   world
    (incf level)
    (setf max-level (max max-level level))
    (setf mobs nil)
    (setf timers (make-hash-table))
    (dotimes (i level)
      (add-to-world world (make-instance 'asteroid)))
    (add-to-world world (or ship (make-instance 'ship)))
    (add-shield (ship world) :seconds 6)))

(defmethod level-cleared-p ((world world))
  (< (num-asteroids world) 1))

(defmethod after ((world world) timer-name &key (seconds 0) do)
  (multiple-value-bind (timer exists) (gethash timer-name (timers world))
    (if exists
      (when (done timer)
        (remhash timer-name (timers world))
        (when (functionp do)
          (funcall do)))
      (setf (gethash timer-name (timers world))
            (make-instance 'timer :seconds seconds)))))

(defmethod update-world ((world world) time-delta)
  (maphash (lambda (name timer)
             (declare (ignore name))
             (update-timer timer time-delta))
           (timers world))
  (dolist (mob (mobs world))
    (update mob time-delta world))
  ;; start next level 3 seconds after clearing
  (when (level-cleared-p world)
    (after world
           'cleared
           :seconds 3
           :do (lambda ()
                 (incf (lives world))
                 (start-next-level world))))
  ;; restart level 3 seconds after death - game over if no more lives
  (unless (ship world)
    (after world
           'death
           :seconds 3
           :do (lambda ()
                 (if (< (lives world) 1)
                   (setf (level world) 0) ; game over
                   (let ((ship (make-instance 'ship)))
                     (add-to-world world ship)
                     (add-shield ship :seconds 6)))))))

(defmethod add-to-world :after ((world world) (asteroid asteroid))
  (incf (num-asteroids world)))

(defmethod add-to-world :after ((world world) (ship ship))
  (setf (ship world) ship))

(defmethod render-world ((world world) paused)
  (clear-display *black*)
  ;; hud
  (sdl-gfx:draw-string-solid-* (format nil "Level ~d" (level world))
                               10 10
                               :color *green*)
  (sdl-gfx:draw-string-solid-* (format nil "Lives ~d" (lives world))
                               10 (- *map-height* 28)
                               :color *green*)
  (sdl-gfx:draw-string-solid-* (format nil "Score ~d" (score world))
                               (- *map-width* 127) (- *map-height* 28)
                               :color *green*)
  (sdl-gfx:draw-string-solid-* (format nil
                                       "~a [Q]uit"
                                       (if (= (level world) 0)
                                           "[P]lay"
                                           "[P]ause"))
                               (- *map-width* 127) 10
                               :color *green*)
  (if (= (level world) 0)
    ;; title screen
    (progn
      (sdl-gfx:draw-string-solid-* "ASTeroids"
                                   (round (* 1/2 (- *map-width* 81)))
                                   (round (* 1/4 (- *map-height* 18)))
                                   :color *green*)
      (sdl-gfx:draw-string-solid-* (format nil
                                           "High score: ~d"
                                           (high-score world))
                                   (round (* 1/2 (- *map-width* 171)))
                                   (round (* 1/2 (- *map-height* 18)))
                                   :color *green*)
      (sdl-gfx:draw-string-solid-* (format nil "Max level: ~d" (max-level world))
                                   (round (* 1/2 (- *map-width* 135)))
                                   (round (* 3/4 (- *map-height* 18)))
                                   :color *green*))
    (progn
      ;; game world
      (set-clip-rect (rectangle :x 0 :y 0 :w *map-width* :h *map-height*)
                     :surface *default-display*)
      (dolist (mob (mobs world))
        (render mob))
      (set-clip-rect nil :surface *default-display*)
      ;; pause text
      (when paused
        (sdl-gfx:draw-string-solid-* "PAUSED"
                                     (round (* 1/2 (- *map-width* 54)))
                                     (round (* 1/2 (- *map-height* 18)))
                                     :color *green*)))))

(defun calc-angle (a b)
  (destructuring-bind (x y) (vector-subtract b a)
    (rad->deg (atan x y))))

(defun main ()
  (with-init ()
    (setf *window*
          (window 640 480
                  :title-caption "ASTeroids"
                  :icon-caption "ASTeroids"))
    (sdl-gfx:initialise-default-font sdl-gfx:*font-9x18*)
    (setf (frame-rate) 60)
    (clear-display *black*)
    (let ((world (make-instance 'world))
          (paused nil))
      (with-events ()
        (:quit-event () t)
        (:mouse-motion-event (:x x :y y)
          (when (ship world)
            (setf (facing (ship world))
                  (calc-angle (pos (ship world)) (relative-coords x y)))))
        (:mouse-button-down-event (:x x :y y)
          (when (and (> (level world) 0)
                     (ship world)
                     (not paused))
            (shoot-at (ship world) (relative-coords x y) world)
            (thrust-at (ship world) (relative-coords x y))))
        (:mouse-button-up-event ()
          (when (and (> (level world) 0)
                     (ship world))
            (stop-thrust (ship world))))
        (:key-up-event (:key key)
          (case key
            (:sdl-key-escape (push-quit-event))
            (:sdl-key-q (setf (level world) 0))
            (:sdl-key-p (if (= (level world) 0)
                          (progn
                            (setf (score world) 0)
                            (setf (lives world) 1)
                            (setf *ticks* (sdl-get-ticks))
                            (start-next-level world))
                          (setf paused (not paused))))))
        (:idle ()
          (when (and (> (level world) 0)
                     (not paused))
            (update-world world (get-ticks)))
          (render-world world paused)
          (update-display))))))
Something went wrong with that request. Please try again.