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