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