lib/opengl-convenience.lisp

   1 (in-package #:opengl)
   2
   3 (defmacro with-new-list (list mode &body forms)
   4   "New/End-List wrapper."
   5   `(progn
   6      (gl:new-list ,list ,mode)
   7      (unwind-protect (progn ,@forms)
   8        (gl:end-list))))
   9
  10 (defmacro with-push-name (name &body forms)
  11   "Select name push/pop wrapper"
  12   `(progn
  13      (gl:push-name ,name)
  14      (unwind-protect (progn ,@forms)
  15        (gl:pop-name))))
  16
  17 (defmacro with-begin (mode &body forms)
  18   "Immediate mode block wrapper."
  19   `(progn
  20      (gl:begin ,mode)
  21      (unwind-protect (progn ,@forms)
  22        (gl:end))))
  23
  24 (defmacro with-push-attrib ((&rest attrib-bits) &body forms)
  25   "Pushes the bitwise or of attrib-bits, executing forms and clean up with pop-attrib."
  26   `(progn
  27      (gl:push-attrib (logior ,@attrib-bits))
  28      (unwind-protect (progn ,@forms)
  29        (gl:pop-attrib))))
  30
  31 (defmacro with-push-matrix (&body forms)
  32   "Pushes the current matrix onto the stack, executes forms and clean up with pop-matrix."
  33   `(progn
  34      (gl:push-matrix)
  35      (unwind-protect (progn ,@forms)
  36        (gl:pop-matrix))))
  37
  38 (defmacro with-setup-projection (&body forms)
  39   "Switch to projection mode, load identity, execute forms and return to modelview matrix mode."
  40   `(progn
  41      (gl:matrix-mode gl:+projection+)
  42      (gl:load-identity)
  43      (unwind-protect (progn ,@forms)
  44        (gl:matrix-mode gl:+modelview+))))
  45
  46 (defmacro with-projection-matrix ((&body projection-matrix-setup-forms)
  47                                   &body forms)
  48   "Temporarily change the projection matrix:
  49 Saves the current projection matrix,
  50 loads identity in the projection matrix,
  51 runs projection-matrix-setup-forms in projection matrix-mode,
  52 runs forms in modelview matrix-mode,
  53 restores the saved projection-matrix
  54 and leaves in modelview matrix-mode."
  55   `(progn
  56      (gl:matrix-mode gl:+projection+)
  57      (gl:push-matrix)
  58      (gl:load-identity)
  59      (unwind-protect
  60           (progn
  61             ,@projection-matrix-setup-forms
  62             (gl:matrix-mode gl:+modelview+)
  63             ,@forms)
  64        (gl:matrix-mode gl:+projection+)
  65        (gl:pop-matrix)
  66        (gl:matrix-mode gl:+modelview+))))
  67
  68 ;; 1.1 Conveniences
  69
  70 (defmacro with-push-client-attrib ((&rest attrib-bits) &body forms)
  71   "Pushes the bitwise or of the client attrib-bits, executing forms and clean up with pop-client-attrib."
  72   `(progn
  73      (gl:push-client-attrib (logior ,@attrib-bits))
  74      (unwind-protect (progn ,@forms)
  75        (gl:pop-client-attrib))))
  76
  77 ;; 1.5 Conveniences
  78 (defmacro with-begin-query ((target id) &body forms)
  79   `(progn
  80      (gl:begin-query ,target ,id)
  81      (unwind-protect (progn ,@forms)
  82        (gl:end-query))))
  83
  84 (defmacro with-map-buffer ((target access) &body forms)
  85   "Executes forms with VBO buffer mapped as with gl:map-buffer, unmapping cleanly afterwards."
  86   (let ((ntarget (gensym "TARGET-")))
  87     `(let ((,ntarget ,target))
  88        (gl:map-buffer ,ntarget ,access)
  89        (unwind-protect (progn ,@forms)
  90          (gl:unmap-buffer ,ntarget)))))
  91
  92 (defmacro with-bind-buffer ((target buffer) &body forms)
  93   "Executes forms with the VBO buffer bound with gl:bind-buffer, cleanly restoring to previous state afterwards."
  94   (let ((ntarget (gensym "TARGET-"))
  95         (saved-buffer-v (gensym "SAVED-BUFFER-V-")))
  96     `(let ((,ntarget ,target))
  97        (cffi:with-foreign-object (,saved-buffer-v 'gl:int)
  98          (cond
  99            ((eql ,ntarget gl:+array-buffer+)         (gl:get-integerv gl:+array-buffer-binding+ ,saved-buffer-v))
 100            ((eql ,ntarget gl:+element-array-buffer+) (gl:get-integerv gl:+element-array-buffer-binding+ ,saved-buffer-v))
 101            ((eql ,ntarget gl:+pixel-pack-buffer+)    (gl:get-integerv gl:+pixel-pack-buffer-binding+ ,saved-buffer-v))
 102            ((eql ,ntarget gl:+pixel-unpack-buffer+)  (gl:get-integerv gl:+pixel-unpack-buffer-binding+ ,saved-buffer-v)))
 103          (gl:bind-buffer ,ntarget ,buffer)
 104          (unwind-protect (progn ,@forms)
 105            (gl:bind-buffer ,ntarget (cffi:mem-ref ,saved-buffer-v 'gl:int)))))))
 106
 107 ;; ARB_vertex_buffer_object
 108
 109 (defmacro with-map-buffer-arb ((target access) &body forms)
 110   "Executes forms with VBO buffer mapped as with gl:map-buffer-arb, unmapping cleanly afterwards."
 111   (let ((ntarget (gensym "TARGET-")))
 112     `(let ((,ntarget ,target))
 113        (gl:map-buffer-arb ,ntarget ,access)
 114        (unwind-protect (progn ,@forms)
 115          (gl:unmap-buffer-arb ,ntarget)))))
 116
 117 (defmacro with-bind-buffer-arb ((target buffer) &body forms)
 118   "Executes forms with the VBO buffer bound with gl:bind-buffer-arb, cleanly restoring to previous state afterwards."
 119   (let ((ntarget (gensym "TARGET-"))
 120         (saved-buffer-v (gensym "SAVED-BUFFER-V-")))
 121     `(let ((,ntarget ,target))
 122        (cffi:with-foreign-object (,saved-buffer-v 'gl:int)
 123          (cond
 124            ((eql ,ntarget gl:+array-buffer-arb+)         (gl:get-integerv gl:+array-buffer-binding-arb+ ,saved-buffer-v))
 125            ((eql ,ntarget gl:+element-array-buffer-arb+) (gl:get-integerv gl:+element-array-buffer-binding-arb+ ,saved-buffer-v))
 126            ((eql ,ntarget gl:+pixel-pack-buffer-arb+)    (gl:get-integerv gl:+pixel-pack-buffer-binding-arb+ ,saved-buffer-v))
 127            ((eql ,ntarget gl:+pixel-unpack-buffer-arb+)  (gl:get-integerv gl:+pixel-unpack-buffer-binding-arb+ ,saved-buffer-v)))
 128          (gl:bind-buffer-arb ,ntarget ,buffer)
 129          (unwind-protect (progn ,@forms)
 130            (gl:bind-buffer-arb ,ntarget (cffi:mem-ref ,saved-buffer-v 'gl:int)))))))
 131
 132
 133 ;; common (between ARB and 2.0) shader stuff
 134
 135
 136
 137 (define-condition shader-object-error (error)
 138   ((object-handle :initarg :object-handle :reader object-handle)
 139    (info-log :initarg :info-log :reader info-log))
 140   (:report (lambda (condition stream)
 141              (format stream "~a Error with ~a:~%~a~%"
 142                      (type-of condition)
 143                      (object-handle condition)
 144                      (info-log condition)))))
 145 (define-condition shader-compile-error (shader-object-error) ())
 146 (define-condition program-link-error (shader-object-error) ())
 147
 148 ;; 2.0 and ARB_shader_objects/ARB_vertex_shader/ARB_fragment_shader conveniences
 149
 150 (eval-when (:compile-toplevel :load-toplevel :execute)
 151   (defmacro define-arb-and-non-arb (&body form)
 152     "Expands out code with (?extension with-arb without-arb) markers in it.
 153 Care should be taken that it doesn't interfere with code with ` , markers in it."
 154     (let ((extension nil))
 155       (declare (special extension))
 156       (labels ((expand-extension (form)
 157                  (if (listp form)
 158                      (if (eql (first form) '?extension)
 159                          (if extension (second form) (third form))
 160                          (mapcar #'expand-extension form))
 161                      form)))
 162         `(progn
 163            ,@(let ((extension t))
 164                   (declare (special extension))
 165                   (expand-extension form)) ;  undefined function: EXPAND-EXTENSION
 166            ,@(expand-extension form))))))
 167
 168 (define-arb-and-non-arb
 169   (defun (?extension shader-source-from-stream-arb shader-source-from-stream) (handle in)
 170     (declare (type stream in))
 171     (let* ((lines (loop for line = (read-line in nil) while line collecting line))
 172            (c-lines (cffi:foreign-alloc :string :initial-contents lines)))
 173       ((?extension gl:shader-source-arb gl:shader-source) handle (length lines) c-lines (cffi:null-pointer))))
 174
 175   (defun (?extension check-compiled-shader-arb check-compiled-shader) (handle)
 176     "Given a shader handle that has been compiled, checks and flags in a lisp-friendly manner
 177 their compile status. Errors are signalled using an error with the shader log, success will
 178 just warn with the contents of the program-log, if present."
 179     (cffi:with-foreign-objects ((log-length 'gl:sizei)
 180                                 (compile-status 'gl:int))
 181       (?extension
 182        (gl:get-object-parameter-iv-arb handle gl:+object-info-log-length-arb+ log-length)
 183        (gl:get-shader-iv handle gl:+info-log-length+ log-length))
 184       (?extension
 185        (gl:get-object-parameter-iv-arb handle gl:+object-compile-status-arb+ compile-status)
 186        (gl:get-shader-iv handle gl:+compile-status+ compile-status))
 187       (let ((shader-log (when (> (cffi:mem-ref log-length 'gl:sizei) 1)
 188                           (cffi:with-foreign-pointer-as-string (str 4096)
 189                             ((?extension gl:get-info-log-arb gl:get-shader-info-log) handle (cffi:mem-ref log-length 'gl:sizei) (cffi:null-pointer) str)
 190                             (cffi:foreign-string-to-lisp str :count (cffi:mem-ref log-length 'gl:sizei))))))
 191         (if (= (cffi:mem-ref compile-status 'gl:int)
 192                gl:+true+)
 193             (when shader-log (warn shader-log))
 194             (error 'shader-compile-error :info-log shader-log :object-handle handle)))))
 195
 196   (defun (?extension make-shader-arb make-shader) (type source)
 197     "Convenience function to create a shader of type given from source, which may either be a
 198 pathname of a file to load from, or a string of the shader source directly. Returns handle of the new shader."
 199     (let ((handle ((?extension gl:create-shader-object-arb gl:create-shader) type)))
 200       (if (typep source 'pathname)
 201           (with-open-file (in source :direction :input)
 202             ((?extension shader-source-from-stream-arb shader-source-from-stream) handle in))
 203           (with-input-from-string (in source)
 204             ((?extension shader-source-from-stream-arb shader-source-from-stream) handle in)))
 205       ((?extension gl:compile-shader-arb gl:compile-shader) handle)
 206       ((?extension check-compiled-shader-arb check-compiled-shader) handle)
 207       handle))
 208
 209   (defun (?extension check-linked-program-arb check-linked-program) (handle)
 210     "Given a program handle that has been linked, checks and flags in a lisp-friendly manner
 211 their link status. Errors are signalled using an error with the program log, success will
 212 just warn with the contents of the program-log, if present."
 213     (cffi:with-foreign-objects ((log-length 'gl:sizei)
 214                                 (link-status 'gl:int))
 215       (?extension
 216        (gl:get-object-parameter-iv-arb handle gl:+object-info-log-length-arb+ log-length)
 217        (gl:get-program-iv handle gl:+info-log-length+ log-length))
 218       (?extension
 219        (gl:get-object-parameter-iv-arb handle gl:+object-link-status-arb+ link-status)
 220        (gl:get-program-iv handle gl:+link-status+ link-status))
 221       (let ((program-log (when (> (cffi:mem-ref log-length 'gl:sizei) 1)
 222                            (cffi:with-foreign-pointer-as-string (str 4096)
 223                              ((?extension gl:get-info-log-arb gl:get-program-info-log) handle (cffi:mem-ref log-length 'gl:sizei) (cffi:null-pointer) str)
 224                              (cffi:foreign-string-to-lisp str :count (cffi:mem-ref log-length 'gl:sizei))))))
 225         (if (= (cffi:mem-ref link-status 'gl:int)
 226                gl:+true+)
 227             (when program-log (warn program-log))
 228             (error 'program-link-error :info-log program-log :object-handle handle)))))
 229
 230   (defun (?extension make-program-arb make-program) (&rest shader-handles)
 231     "Given shader handles, creates a program, attaches any shaders given and links the program."
 232     (let ((handle ((?extension gl:create-program-object-arb gl:create-program))))
 233       (dolist (shader-handle shader-handles)
 234         ((?extension gl:attach-object-arb gl:attach-shader) handle shader-handle))
 235       (when shader-handles
 236         ((?extension gl:link-program-arb gl:link-program) handle)
 237         ((?extension check-linked-program-arb check-linked-program) handle))
 238       handle))
 239
 240   (defparameter (?extension *fallback-synchronizing-program-arb* *fallback-synchronizing-program*) nil)
 241
 242   (defun (?extension fallback-synchronizing-program-arb fallback-synchronizing-program) ()
 243     (or (?extension *fallback-synchronizing-program-arb* *fallback-synchronizing-program*)
 244         (setf (?extension *fallback-synchronizing-program-arb* *fallback-synchronizing-program*)
 245               ((?extension make-program-arb make-program)
 246                ((?extension make-shader-arb make-shader) (?extension gl:+vertex-shader-arb+ gl:+vertex-shader+)
 247                 "varying float position;
 248 void main()
 249 {
 250   gl_Position=ftransform();
 251   position=gl_Position.x+gl_Position.y+gl_Position.z;
 252 }
 253 ")
 254                ((?extension make-shader-arb make-shader) (?extension gl:+fragment-shader-arb+ gl:+fragment-shader+)
 255                 "varying float position;
 256 void main() {
 257   float intensity=mod(position*4.0,1.0) > 0.5 ? 1.0 : 0.1;
 258   gl_FragColor=vec4(intensity,intensity,0.0,1.0);
 259 }")))))
 260
 261   (defun (?extension synchronizing-program-arb synchronizing-program) (program-name &rest shader-type-sources)
 262     "Creates a managed shader program that will poll shader files on disk
 263 and load them automatically if their write-times change. This can be used for
 264 easily developing shader code while the program is running. If the shader code
 265 does not compile for any reason, errors will be displayed on the *error-output*
 266 and a program specified by gl:*fallback-synchronizing-program* will be returned
 267 instead (a black and yellow striped static pattern).
 268
 269 For an example, please see examples/synchronized-shader.lisp."
 270     (defvar *synchronizing-shader-programs* (make-hash-table :test 'equal))
 271     ;; structure of an entry:
 272     ;; program-name: (program-object-handle shader-entry+ ... )
 273     ;; shader-entry: (shader-object-handle source-file last-compile-time)
 274
 275     ;; make-structure
 276     (when (not (nth-value 1 (gethash program-name *synchronizing-shader-programs*)))
 277       (let* ((program ((?extension create-program-object-arb create-program)))
 278              (shaders (mapcar #'(lambda (type-source)
 279                                   (let ((shader
 280                                          ((?extension create-shader-object-arb create-shader) (first type-source))))
 281                                     ((?extension attach-object-arb attach-shader) program shader)
 282                                     shader))
 283                               shader-type-sources)))
 284         (setf (gethash program-name *synchronizing-shader-programs*)
 285               (list program (mapcar #'(lambda (shader type-source)
 286                                         (list shader (second type-source) 0))
 287                                     shaders
 288                                     shader-type-sources)))))
 289     (let ((program-spec (gethash program-name *synchronizing-shader-programs*)))
 290       ;; compile out-of-date shaders
 291       ;; TODO is (some ...) a great idea here really? Maybe they won't all load at the same time?
 292       (when (some #'(lambda (shader-entry)
 293                       (destructuring-bind (shader source last-time) shader-entry
 294                         (let ((now-time (handler-case (file-write-date source)
 295                                           (file-error (condition) 0))))
 296                           (when (> now-time last-time)
 297                             (with-open-file (in source :direction :input)
 298                               ((?extension shader-source-from-stream-arb shader-source-from-stream) shader in))
 299                             ((?extension gl:compile-shader-arb gl:compile-shader) shader)
 300                             (handler-case
 301                                 ((?extension check-compiled-shader-arb check-compiled-shader) shader)
 302                               (shader-object-error (e)
 303                                 (let ((*print-escape* nil))
 304                                   (print-object e *error-output*))))
 305                             (setf (third shader-entry) now-time)
 306                             t))))
 307                   (second program-spec))
 308         ;; re-link if anything was out of date
 309         ((?extension gl:link-program-arb gl:link-program) (first program-spec))
 310         (handler-case
 311             ((?extension check-linked-program-arb check-linked-program) (first program-spec))
 312           (shader-object-error (e)
 313             (let ((*print-escape* nil))
 314               (print-object e *error-output*)))))
 315
 316       ;; check link status: return or fallback
 317       (if (cffi:with-foreign-object (link-status 'gl:int)
 318             ((?extension gl:get-object-parameter-iv-arb gl:get-program-iv)
 319              (first program-spec)
 320              (?extension gl:+object-link-status-arb+ gl:+link-status+)
 321              link-status)
 322             (eql (cffi:mem-ref link-status 'gl:int) gl:+true+))
 323           (first program-spec)
 324           ((?extension fallback-synchronizing-program-arb fallback-synchronizing-program)))))
 325
 326   (defmacro (?extension with-use-program-arb with-use-program) (name &body forms)
 327     "Executes forms using the shader program named. And cleanly use no-program afterwards."
 328     (let ((current-program (gensym "CURRENT-PROGRAM-")))
 329       `(let ((,current-program (?extension
 330                                 (gl:get-handle-arb gl:+program-object-arb+)
 331                                 (cffi:with-foreign-object (current-program-v 'gl:int)
 332                                   (gl:get-integerv gl:+current-program+ current-program-v)
 333                                   (cffi:mem-ref current-program-v 'gl:int)))))
 334          ((?extension gl:use-program-object-arb gl:use-program) ,name)
 335          (unwind-protect (progn ,@forms)
 336            ((?extension gl:use-program-object-arb gl:use-program) ,current-program))))))
 337
 338
 339 (defun clear-synchronizing-shaders ()
 340   (makunbound '#:*synchronizing-shader-programs*))
 341
 342
 343
 344
 345 (export '(with-new-list with-push-name with-begin with-push-attrib with-push-matrix with-setup-projection with-projection-matrix
 346           ;; 1.1
 347           with-push-client-attrib
 348           ;; ARB_vertex_buffer_object
 349           with-map-buffer-arb with-bind-buffer-arb
 350           ;; 1.5
 351           with-begin-query
 352           with-map-buffer with-bind-buffer
 353           ;; ARB_vertex_shader/ARB_fragment_shader/ARB_shader_objects
 354           shader-source-from-stream-arb check-compiled-shader-arb make-shader-arb synchronizing-shader-arb
 355           check-linked-program-arb make-program-arb
 356           with-use-program-arb synchronizing-program-arb
 357           fallback-synchronizing-program-arb
 358           *fallback-synchronizing-program-arb*
 359           ;; 2.0
 360           shader-source-from-stream check-compiled-shader make-shader synchronizing-shader
 361           check-linked-program make-program
 362           with-use-program synchronizing-program
 363           fallback-synchronizing-program
 364           *fallback-synchronizing-program*
 365
 366           clear-synchronizing-shaders))