[pal-cvs] CVS pal/examples/bermuda

[tneste]

Update of /project/pal/cvsroot/pal/examples/bermuda
In directory cl-net:/tmp/cvs-serv5791/examples/bermuda

Added Files:
	bermuda.asd bermuda.lisp package.lisp particles.lisp 
	resources.lisp sprites.lisp 
Log Message:
Committed patch by Quentin Stievenart.
Added the Bermuda example project.


--- /project/pal/cvsroot/pal/examples/bermuda/bermuda.asd	2009/08/17 12:43:01	NONE
+++ /project/pal/cvsroot/pal/examples/bermuda/bermuda.asd	2009/08/17 12:43:01	1.1

(in-package #:asdf)

(defsystem bermuda
  :components
  ((:file "bermuda" :depends-on ("sprites" "resources" "particles" "package"))
   (:file "sprites" :depends-on ("resources" "package"))
   (:file "resources" :depends-on ("package"))
   (:file "particles" :depends-on ("package"))
   (:file "package"))
  :depends-on ("pal"))


--- /project/pal/cvsroot/pal/examples/bermuda/bermuda.lisp	2009/08/17 12:43:01	NONE
+++ /project/pal/cvsroot/pal/examples/bermuda/bermuda.lisp	2009/08/17 12:43:01	1.1
(in-package :bermuda)

(defparameter *player* nil)
(defparameter *score* 0)
(defparameter *lives* 0)
(defconstant +level-size+ 25600)

(defun build-level (n)
  (init-particles)
  (init-sprites)
  (dotimes (i (* n 1000))
    (random 1))
  (dotimes (i 150)
    (make-instance 'enemy-plane
                   :pos (v (random 15000) (random 600))))
  (setf *player* (make-instance 'player :pos (v 0 0))
        *map* (let ((map (make-array (/ +level-size+ 256) :initial-element nil)))
                (dotimes (x (/ +level-size+ 256))
                  (setf (aref map x) (random-elt (list (make-tile :image (tag 'grass))
                                                       (make-tile :image (tag 'land))
                                                       (make-tile :image (tag 'grass))))))
                map)))


(defun bermuda ()
  (with-pal (:fullscreenp t :title "Bermuda" :paths "data/")
    (set-cursor nil)
    (main-loop)))


(defun main-loop (&aux (score-display 0) (level 0))
  (setf *score* 0
        *lives* 3)
  (build-level level)
  (play-music (tag 'music) :loops t :volume 60)
  (event-loop ()
    (setf *view* (v-round (v (min (- (* +level-size+ 256) 800)
                                  (+ (vx *view*) 2))
                             (* (- (vy (pos-of *player*)) 300) .2f0))))

    (if (> *shake* 0)
        (with-transformation (:pos (if (> *shake* 0f0)
                                       (v (random (float *shake*)) (random (float *shake*)))
                                       (v 0 0)))
          (draw-screen)
          (decf *shake*))
        (draw-screen))
    (when (< score-display *score*)
      (incf score-display))
    (draw-text (prin1-to-string score-display) (v 5 -2) (tag 'font))
    (with-blend ()
      (if (< (hp-of *player*) 20)
          (set-blend-color (color 0 0 0 (random 255)))
          (set-blend-color (color 0 0 0 128)))
      (dotimes (i *lives*)
        (draw-image (tag 'plane) (v (- 700 (* i 40)) 25) :angle -45f0 :scale 0.5f0))
      (draw-image* (tag 'plane) (v 0 0) (v 730 2) (hp-of *player*) 50))))

;;(bermuda)--- /project/pal/cvsroot/pal/examples/bermuda/package.lisp	2009/08/17 12:43:01	NONE
+++ /project/pal/cvsroot/pal/examples/bermuda/package.lisp	2009/08/17 12:43:01	1.1
(in-package :cl-user)

(defpackage :bermuda
  (:use :cl :pal))--- /project/pal/cvsroot/pal/examples/bermuda/particles.lisp	2009/08/17 12:43:01	NONE
+++ /project/pal/cvsroot/pal/examples/bermuda/particles.lisp	2009/08/17 12:43:01	1.1
(in-package :bermuda)

(declaim (optimize (speed 3)
                   (safety 0)
                   (debug 1)))

(defparameter *particles* nil)
(declaim (list *particles*))

(defstruct particle
  (pos (v 0 0) :type vec)
  (vel (v 0 0) :type vec)
  image
  (age 0 :type u11)
  (scale 1f0 :type single-float))



(defun particle (image pos &optional (dir (v 0 0)) (scale 1.0f0))
  (let ((p (make-particle :image image :pos pos :vel (v+ (v* (v-random 0.7) (+ (random 1.0) .01)) dir) :age 255 :scale scale)))
    (push p *particles*)))

(defun init-particles ()
  (setf *particles* nil))

(defun explosion (image pos)
  (play-sample (tag 'explosion-1))
  (dotimes (i 5)
    (particle image (copy-vec pos))))

(defun draw-particles ()
  (dolist (p *particles*)
    (declare (type particle p))
    (v+! (particle-pos p)
         (particle-vel p))
    (v*! (particle-vel p) 0.99)
    (decf (particle-age p) 2)
    (when (and (> (particle-age p) 180) (= (random 300) 0))
      (play-sample (tag 'explosion-2))
      (dotimes (i 3)
        (particle (particle-image p)
                  (copy-vec (particle-pos p))
                  (particle-vel p)
                  (* (particle-scale p) .90))))
    (when (<= (particle-age p) 1)
      (setf *particles* (remove p *particles*))))
  (with-blend (:mode :blend)
    (dolist (p *particles*)
      (declare (type particle p))
      (set-blend-color (color 0 0 0 (min 255 (* (particle-age p) 2))))
      (draw-image (particle-image p)
                  (screen-pos (particle-pos p))
                  :angle (* .5 (particle-age p))
                  :scale (particle-scale p))))

  (with-blend (:mode :additive)
    (dolist (p *particles*)
      (declare (type particle p))
      (set-blend-color (color 255 (particle-age p) 30 (particle-age p)))
      (draw-image (particle-image p)
                  (screen-pos (particle-pos p))
                  :angle (* .5 (particle-age p))
                  :scale (particle-scale p)))))--- /project/pal/cvsroot/pal/examples/bermuda/resources.lisp	2009/08/17 12:43:01	NONE
+++ /project/pal/cvsroot/pal/examples/bermuda/resources.lisp	2009/08/17 12:43:01	1.1
(in-package :bermuda)

(define-tags ufo (load-image "ufo.png" t)
  music (load-music "urafaerie+numberone.ogg")
  particle (load-image "particle.png")
  font (load-font "font")
  plane (load-image "plane.png" t)
  bullet (load-image "bullet.png")
  land (load-image "mass.png")
  grass (load-image "grass.png")
  explosion-1 (load-sample "explosion2.wav")
  explosion-2 (load-sample "h_gs1.WAV")
  shoot (load-sample "Gatling.wav" 8)
  horizon (load-image "horizon.png"))--- /project/pal/cvsroot/pal/examples/bermuda/sprites.lisp	2009/08/17 12:43:01	NONE
+++ /project/pal/cvsroot/pal/examples/bermuda/sprites.lisp	2009/08/17 12:43:01	1.1
(in-package :bermuda)

(defparameter *sprites* nil)
(defparameter *categories* nil)
(defparameter *view* (v 0 0))
(defparameter *shake* 0)
(defparameter *map* nil)
(defconstant +ground-base+ 645)


(defstruct tile
  image)


(defclass sprite ()
  ((pos :accessor pos-of :initarg :pos :type vec)
   (score :accessor score-of :initarg :score :initform 0)
   (hp :accessor hp-of :initarg :hp :initform 0)
   (vel :accessor vel-of :initform (v 0 0) :initarg :vel :type vec)
   (angle :accessor angle-of :initform 0f0 :initarg :angle :type single-float)
   (image :accessor image-of :initarg :image :type image)
   (category :accessor category-of :initarg :category :initform 'sprite :type symbol)))

(declaim (inline screen-pos))
(defun screen-pos (p)
  (declare (type vec p))
  (v-round (v- p *view*)))

(defmethod initialize-instance :after ((sprite sprite) &key &allow-other-keys)
  (let ((c (gethash (category-of sprite) *categories*)))
    (if c
        (push sprite (gethash (category-of sprite) *categories*))
        (setf (gethash (category-of sprite) *categories*) (list sprite))))
  (push sprite *sprites*))

(defmethod hit ((s sprite) dmg)
  (decf (hp-of s) dmg)
  (when (< (hp-of s) 1)
    (kill s)))

(defmethod collidesp ((a sprite) (b sprite))
  (if (< (v-distance (pos-of a) (pos-of b))
         30f0)
      t nil))

(defmethod draw ((s sprite))
  (draw-image (image-of s) (screen-pos (pos-of s))))

(defmethod act ((s sprite))
  (when (or (groundp (pos-of s)))
    (kill s))
  (v+! (pos-of s) (vel-of s)))

(defmethod force ((s sprite) v)
  (v+! (vel-of s) v))

(defmethod kill ((s sprite))
  (incf *score* (score-of s))
  (setf *sprites* (delete s *sprites*)
        (gethash (category-of s) *categories*) (delete s (gethash (category-of s) *categories*))))


(declaim (inline get-sprites))
(defun get-sprites (category)
  (gethash category *categories*))

(defun init-sprites ()
  (setf *sprites* nil
        *view* (v 0 0)
        *categories* (make-hash-table :test 'eq)))

(defun find-sprite (predicate category)
  (find-if predicate
           (get-sprites category)))

(defun alt-at (pos)
  (declare (type vec pos))
  (let ((tile (aref *map* (truncate (vx pos) 256))))
    (- +ground-base+ (image-height (tile-image tile)))))

(declaim (inline groundp))
(defun groundp (pos)
  (declare (type vec pos))
  (> (vy pos) (alt-at pos)))

(defun draw-screen ()
  (with-blend (:mode nil)
    (set-blend-mode nil)
    (draw-image* (tag 'horizon) (v 0 0)
                 (v 0 (* (vy *view*) .1f0 ))
                 800 600))
  (loop for x from (truncate (vx *view*) 256) to (+ (truncate (vx *view*) 256) 5) do
       (let ((tile (aref *map* x)))
         (draw-image (tile-image tile)
                     (screen-pos (v (* x 256)
                                    (- +ground-base+ (image-height (tile-image tile))))))))
  (dolist (s *sprites*)
    (let ((p (- (vx (pos-of s)) (vx *view*))))
      (when (and (> p -100)
                 (< p 900))
        (draw s)
        (act s))))
  (draw-particles))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defclass plane (sprite)
  ())

(defmethod act ((p plane))
  (setf (angle-of p) (- (v-angle (vel-of p)) 90f0))
  (call-next-method))

(defmethod fire ((s plane) bullet-class)
  (make-instance bullet-class
                 :pos (v+ (pos-of s) (v* (vel-of s) 5f0))
                 :vel (v* (angle-v (- (angle-of s) 270f0)) 6f0)))

(defmethod kill ((p plane))
  (setf *shake* 5f0)
  (explosion (tag 'particle) (pos-of p))
  (call-next-method))



(defclass bullet (sprite)
  ((age :accessor age-of :initform 0)
   (dmg :accessor dmg-of :initarg :dmg :initform 10)))

(defmethod act ((b bullet))
  (incf (age-of b))
  (when (> (age-of b) 150)
    (kill b))
  (call-next-method))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defclass enemy-bullet (bullet)
  ((age :accessor age-of :initform 0))
  (:default-initargs :category 'enemy-bullet :image (tag 'bullet)))


(defclass enemy-plane (plane)
  ()
  (:default-initargs :category 'enemy :image (tag 'ufo) :score 10 :hp 1 :vel (v (- (random 2f0) 1f0) (- (random 1f0) .5f0))))

(defmethod act ((e enemy-plane))
  (setf (angle-of e) (v-angle (vel-of e)))
  (randomly 100
    (fire e 'enemy-bullet))
  (let ((b (find-sprite (lambda (s) (collidesp s e)) 'player-bullet)))
    (when b
      (hit e (dmg-of b))
      (kill b)))
  (call-next-method))

(defmethod draw ((e enemy-plane))
  (draw-image (image-of e)
              (screen-pos (pos-of e))
              :angle (angle-of e)
              :halign :middle :valign :middle))



(defclass player-bullet (bullet)
  ((age :accessor age-of :initform 0))
  (:default-initargs :category 'player-bullet :image (tag 'bullet)))



(defclass player (plane)
  ()
  (:default-initargs :hp 100 :image (tag 'plane)))

(defmethod draw ((s player))
  (draw-image (image-of s)
              (screen-pos (pos-of s))
              :angle (angle-of s)
              :halign :middle :valign :middle))

(defmethod act ((p player))
  (let ((e (find-sprite (lambda (s) (collidesp s p)) 'enemy)))
    (when e
      (hit e 30)
      (hit p 30)))
  (let ((b (find-sprite (lambda (s)
                          (collidesp s p)) 'enemy-bullet)))
    (when b
      (setf *shake* 10f0)
      (hit p (dmg-of b))
      (kill b)))
  (test-keys
    (:key-mouse-1 (play-sample (tag 'shoot))
                  (fire p 'player-bullet)))
  (v*! (vel-of p) .1f0)
  (force p (v* (v-direction (v- (pos-of p) *view*) (get-mouse-pos))
               (* (v-distance (v- (pos-of p) *view*) (get-mouse-pos)) .02f0)))
  (call-next-method))