Code from part one:
;;; dependencies
(require 'sb-sprof)
(require 'cl-opengl)
(require 'vecto)
(require 'lispbuilder-sdl-image)
(require 'bordeaux-threads);;; actual code
(defmacro restartable (&body body)
"helper macro since we use continue restarts a lot
(remember to hit C in slime or pick the restart so errors don't kill the app)"
`(restart-case
(progn ,@body)
(continue () :report "Continue")))
(defun load-a-texture (filename)
(let ((texture (car (gl:gen-textures 1)))
(image (sdl-image:load-image filename)))
(gl:bind-texture :texture-2d texture)
(gl:tex-parameter :texture-2d :generate-mipmap t) ;; <- new
(gl:tex-parameter :texture-2d :texture-min-filter :linear-mipmap-linear) ;; <- new
(sdl-base::with-pixel (pix (sdl:fp image))
(let ((texture-format (ecase (sdl-base::pixel-bpp pix)
(1 :luminance)
(2 :luminance-alpha)
(3 :rgb)
(4 :rgba))))
(assert (and (= (sdl-base::pixel-pitch pix)
(* (sdl:width image) (sdl-base::pixel-bpp pix)))
(zerop (rem (sdl-base::pixel-pitch pix) 4))))
(gl:tex-image-2d :texture-2d 0 :rgba
(sdl:width image) (sdl:height image)
0
texture-format
:unsigned-byte (sdl-base::pixel-data pix))))
texture))
;; physical size of window in pixels
(defparameter *actual-screen-width* 320)
(defparameter *actual-screen-height* 200)
;; nominal size of window in pixels, in case we just want to scale the
;; scene to match the window instead of showing more of the world
(defparameter *nominal-screen-width* 320)
(defparameter *nominal-screen-height* 200)
;; extents of the window in GL coordinates
(defparameter *screen-width* nil)
(defparameter *screen-height* nil)
;; flag specifying how we want to handle chamging resolution:
;; if T, always show a fixed amount of the world
;; if NIL, keep 1 pixel on screen = 1 unit of world space, so more of the
;; world shows when the window gets larger
(defparameter *use-nominal-size* t)
(defun setup-ortho-projection (width height)
(setf *actual-screen-width* width)
(setf *actual-screen-height* height)
(gl:matrix-mode :projection)
(gl:load-identity)
(gl:viewport 0 0 width height)
(if *use-nominal-size*
(setf *screen-width* *nominal-screen-width*
*screen-height* *nominal-screen-height*)
(setf *screen-width* *actual-screen-width*
*screen-height* *actual-screen-height*))
;; this sets up the world so the screen coordinates go from 0,0 at lower
;; left to width,height at upper right
(gl:ortho 0 *screen-width* *screen-height* 0 0 1)
(gl:matrix-mode :modelview))
(defclass particle-system ()
())
(defgeneric draw-object (object)
(:documentation "draw object to screen")
(:method ((object particle-system))))
(defgeneric update-object (object delta-t)
(:documentation "update state of object by delta-t milliseconds, return NIL if
object is no longer active and should be removed, T otherwise")
(:method ((object particle-system) delta-t) nil))
(defclass particle-manager ()
((systems :initform nil :accessor systems)))
(defmethod draw-object ((object particle-manager))
(mapc 'draw-object (systems object)))
(defmethod update-object ((object particle-manager) delta-t)
(setf (systems object)
(delete-if-not (lambda (x) (update-object x delta-t))
(systems object))))
(defclass managed-texture ()
((name :initform nil :initarg :name :accessor name)
(target :initform :texture-2d :accessor target)))
(defgeneric create-texture (texture)
(:documentation "Create the GL texture name, and upload the texture data"))
(defgeneric bind-texture (texture)
(:documentation "Bind the texture"))
(defgeneric delete-texture (texture)
(:documentation "Release the GL texture name, if previously allocated"))
(defmethod bind-texture ((texture managed-texture))
(gl:bind-texture (target texture) (name texture)))
(defmethod delete-texture ((texture managed-texture))
(when (name texture)
(let ((name (name texture)))
(setf (name texture) nil)
;; newer versions of cl-opengl can automatically check for
;; errors, but this function might legitimately be called
;; after GL is shut down, so ignore that error if applicable
(handler-case
(gl:delete-textures (list name))
;; (putting :cl-opengl-checks-errors on *features* was added
;; after the error checks, so if you get errors anyway, try
;; updating cl-opengl)
#+cl-opengl-checks-errors(%gl::opengl-error (c) (values nil c))))))
(defclass file-texture (managed-texture)
((filename :initarg filename :accessor filename)))
(defmethod create-texture ((texture file-texture))
;; these could reuse the name if we were sure it was still valid,
;; but just to be safe we recreate it
(when (name texture)
(gl:delete-textures (list (name texture))))
(setf (name texture) (load-a-texture (filename texture))))
(defclass sequence-texture (managed-texture)
;; we keep a copy of the image data so we can recreate the texture
;; if needed, for example after recreating the main window
((width :initarg :width :accessor width)
(height :initarg :height :accessor height)
(image-data :initarg :image-data :accessor image-data)))
(defmethod create-texture ((texture sequence-texture))
(when (name texture)
(gl:delete-textures (list (name texture))))
(let ((name (car (gl:gen-textures 1))))
(gl:bind-texture :texture-2d name)
(gl:tex-parameter :texture-2d :texture-mag-filter :linear)
(gl:tex-parameter :texture-2d :generate-mipmap t)
(gl:tex-parameter :texture-2d :texture-min-filter :linear-mipmap-linear)
(gl:tex-image-2d :texture-2d 0 :rgba (width texture) (height texture)
0 :rgba :unsigned-byte
(image-data texture))
(setf (name texture) name)) )
(defclass texture-manager ()
((id-map :initform (make-hash-table) :accessor id-map)))
(defgeneric reload-textures (manager)
(:documentation
"(re)create GL data for all textures managed by this texture manager"))
(defgeneric unload-textures (manager)
(:documentation
"release any GL resources associated with textures managed by this texture manager"))
(defgeneric get-texture-by-id (manager id)
(:documentation
"return the texture corresponding to the (EQL comparable) ID"))
(defgeneric (setf get-texture-by-id) (texture manager id)
(:documentation
"add or replace the texture corresponding tothe specified ID"))
(defmethod reload-textures ((manager texture-manager))
(loop for i being the hash-values of (id-map manager)
do (create-texture i)))
(defmethod unload-textures ((manager texture-manager))
(loop for i being the hash-values of (id-map manager)
do (delete-texture i)))
(defmethod get-texture-by-id ((manager texture-manager) id)
(gethash id (id-map manager)))
(defmethod (setf get-texture-by-id) (texture (manager texture-manager) id)
(let ((old-texture (get-texture-by-id manager id)))
;; if we had a texture with that ID already, and it wasn't listed
;; under any other ID, unload it before replacing it
(when (and old-texture (not (eq texture old-texture))
(loop for v being the hash-values of (id-map manager)
never (eq old-texture v)))
(delete-texture old-texture)))
(setf (gethash id (id-map manager)) texture))
(defparameter *texture-manager* nil)
(defmethod bind-texture ((texture symbol))
(let ((tex (get-texture-by-id *texture-manager* texture)))
(when (and tex (not (symbolp tex)))
(bind-texture tex))))
(defmethod create-texture ((texture symbol))
(let ((tex (get-texture-by-id *texture-manager* texture)))
(when (and tex (not (symbolp tex)))
(create-texture tex))))
(defmethod delete-texture ((texture symbol))
(let ((tex (get-texture-by-id *texture-manager* texture)))
(when (and tex (not (symbolp tex)))
(delete-texture tex))))
(defmacro with-texture-manager (&body body)
(let ((manager (gensym "MANAGER-")))
`(let* ((,manager (make-instance 'texture-manager))
(*texture-manager* ,manager))
(unwind-protect
(progn
,@body)
(unload-textures ,manager)))))
(defun file-texture (id filename)
(setf (get-texture-by-id *texture-manager* id)
(make-instance 'file-texture :filename filename)))
(defmacro vecto-texture ((id width height) &body body)
`(vecto:with-canvas (:width ,width :height ,height)
;; run some vecto code
,@body
;; and create a texture with (a copy of) the results
(setf (get-texture-by-id *texture-manager* ,id)
(make-instance 'sequence-texture :width ,width :height ,height
:image-data (copy-seq (vecto::image-data vecto::*graphics-state*))))))
;; store the mouse position somewhere easy to get to
(defparameter *mouse-x* 0)
(defparameter *mouse-y* 0)
(defvar *next-frame-hook-mutex* (bt:make-lock "frame-hook-lock"))
(defparameter *next-frame-hook* nil)
(defparameter *particle-manager* (make-instance 'particle-manager))
(defparameter *click-particles-lifetime-ms* 3000)
(defparameter *click-particles-count* 24)
(defparameter *click-particles-speed* 50) ;; pixels per second
(defclass click-particles (particle-system)
(;; we store the particles in a flat array of N * x,y for position,
;; and another for velocity
;; *note: premature optimization, don't try this at home kids!
(age :initform 0 :accessor age)
(positions :accessor positions)
(velocities :accessor velocities))
(:default-initargs :count *click-particles-count*
:speed *click-particles-speed*))
(defmethod initialize-instance :after ((o click-particles) &key count speed &allow-other-keys)
(let ((positions
(make-array (list (* 2 count)) :element-type 'single-float :initial-element 0.0))
(velocities
(make-array (list (* 2 count)) :element-type 'single-float :initial-element 0.0)))
(loop
for i below count
for j = (* i 2)
do (setf (aref positions (+ j 0)) (float *mouse-x* 1.0))
do (setf (aref positions (+ j 1)) (float *mouse-y* 1.0))
do (setf (aref velocities (+ j 0))
(float (* speed (sin (* i (/ (* 2 pi) count)))) 1.0))
do (setf (aref velocities (+ j 1))
(float (* speed (cos (* i (/ (* 2 pi) count)))) 1.0)))
(setf (positions o) positions)
(setf (velocities o) velocities)))
(defun rectangle (x y width height &optional (u1 0) (v1 0) (u2 1) (v2 1))
(let* ((w/2 (/ width 2.0))
(h/2 (/ height 2.0))
(x1 (- x w/2))
(x2 (+ x w/2))
(y1 (- y h/2))
(y2 (+ y h/2)))
(gl:tex-coord u1 v2)
(gl:vertex x1 y1 0)
(gl:tex-coord u2 v2)
(gl:vertex x2 y1 0)
(gl:tex-coord u2 v1)
(gl:vertex x2 y2 0)
(gl:tex-coord u1 v1)
(gl:vertex x1 y2 0)))
(defmethod draw-object ((o click-particles))
(bind-texture :click-particle)
(gl:with-primitive :quads
(loop with positions = (positions o)
for i below (length positions) by 2
for x = (aref positions i)
for y = (aref positions (1+ i))
do (rectangle x y 32 32))))
(defmethod update-object ((o click-particles) delta-t)
(incf (age o) delta-t)
(setf delta-t (float delta-t 1.0))
(if (< (age o) *click-particles-lifetime-ms*)
;; not done, update particles, and return a non-nil value
(map-into (positions o) (lambda (p v)
(+ p (* v delta-t 0.001)))
(positions o) (velocities o))
;; particle system is done, remove it
nil))
(defun key-down (key state mod-key scancode unicode)
(declare (ignore key state mod-key scancode unicode)))
(defun key-up (key state mod-key scancode unicode)
(declare (ignore state mod-key scancode unicode))
(when (eql key :sdl-key-escape) (sdl:push-quit-event)))
(defun mouse-up (button state x y)
(declare (ignore button state x y)))
(defun mouse-move (x y delta-x delta-y)
(declare (ignore x y delta-x delta-y)))
(defun mouse-down (button state x y)
(declare (ignore button state x y))
(push (make-instance 'click-particles) (systems *particle-manager*)))
(defun init ()
(vecto-texture (:click-particle 64 64)
(vecto:set-rgba-fill 1 0 0 0)
(vecto:clear-canvas)
(vecto:set-rgba-stroke 1 0 0 0.75)
(vecto:set-line-width 10)
(vecto:centered-circle-path 32 32 20)
(vecto:stroke))
(reload-textures *texture-manager*))
(defun draw ()
(gl:clear :color-buffer-bit)
(gl:enable :texture-2d :blend)
(gl:blend-func :src-alpha :one-minus-src-alpha)
(draw-object *particle-manager*)
(sdl:update-display))
(defun update (delta-t)
(update-object *particle-manager* delta-t))
(defun main-loop ()
(sdl:with-init ()
(sdl:window *nominal-screen-width* *nominal-screen-height*
:flags (logior sdl:sdl-opengl
sdl:sdl-resizable))
(setf cl-opengl-bindings:*gl-get-proc-address* #'sdl-cffi::sdl-gl-get-proc-address)
(let ((previous-tick (sdl:sdl-get-ticks)))
(flet ((mx (x) ;; adjust mouse coordinates from screen to world
(* x (/ (float *screen-width* 1.0) *actual-screen-width*)))
(my (y) ;; adjust mouse coordinates from screen to world
(* y (/ (float *screen-height* 1.0) *actual-screen-height*))))
(with-texture-manager
(init)
(setup-ortho-projection *nominal-screen-width* *nominal-screen-height*)
(sdl:with-events ()
(:quit-event () t)
(:video-resize-event (:w w :h h)
(sdl:resize-window w h)
(reload-textures *texture-manager*)
(restartable (setup-ortho-projection w h)))
(:key-down-event (:state state :scancode scancode :key key
:mod-key mod-key :unicode unicode)
(restartable (key-down key state mod-key scancode unicode)))
(:key-up-event (:state state :scancode scancode :key key
:mod-key mod-key :unicode unicode)
(restartable (key-up key state mod-key scancode unicode)))
(:mouse-button-up-event (:button button :state state :x x :y y)
(restartable (mouse-up button state (mx x) (my y))))
(:mouse-button-down-event (:button button :state state :x x :y y)
(restartable (mouse-down button state (mx x) (my y))))
(:mouse-motion-event (:x x :y y :x-rel delta-x :y-rel delta-y)
(setf *mouse-x* (mx x)
*mouse-y* (my y))
(restartable (mouse-move (mx x) (my y) (mx delta-x) (my delta-y))))
(:idle ()
#+(and sbcl (not sb-thread)) (restartable
(sb-sys:serve-all-events 0))
(let ((delta-t (- (sdl:sdl-get-ticks) previous-tick)))
(setf previous-tick (sdl:sdl-get-ticks))
;; we check for negative delta-t in case sdl's timer wraps
;; after some amount of time, 0 for a frame is better
;; a large negative number
(restartable (update (if (minusp delta-t) 0 delta-t))))
(restartable (draw))
(restartable
(bt:with-lock-held (*next-frame-hook-mutex*)
(loop for i in *next-frame-hook*
do (funcall i))
(setf *next-frame-hook* nil))))))))))
(main-loop)
;; and the wrapper macro for setting up something to run next frame
(defmacro next-frame (&body body)
`(bt:with-lock-held (*next-frame-hook-mutex*)
(progn (push (lambda () ,@body) *next-frame-hook*))))