Permalink
Browse files

Fix stuff about shader source parsing and gl-structs and uniform-buff…

…ers and crap like that.
  • Loading branch information...
Shinmera committed Dec 22, 2018
1 parent 3e3aa13 commit f34a79f0a6df21d1ed9259e85fbb3c7eed39352b
Showing with 108 additions and 57 deletions.
  1. +47 −38 assets/uniform-buffer.lisp
  2. +12 −12 effects.lisp
  3. +27 −0 package.lisp
  4. +9 −1 resources/gl-struct.lisp
  5. +13 −6 shader-entity.lisp
@@ -27,49 +27,58 @@
(fields (gl-struct (input buffer))))

(defmethod gl-source ((buffer uniform-buffer))
`(glsl-toolkit:interface-declaration
(glsl-toolkit:type-qualifier
,@(when (layout buffer)
`((glsl-toolkit:layout-qualifier
,@(loop for id in (enlist (layout buffer))
collect `(glsl-toolkit:layout-qualifier-id ,@(enlist id))))))
:uniform
,@(qualifiers buffer))
,(gl-type buffer)
,(if (binding buffer)
`(glsl-toolkit:instance-name ,(binding buffer))
'glsl-toolkit:no-value)
,@(mapcar #'gl-source (fields buffer))))
`(glsl-toolkit:shader
,@(loop for dependent in (compute-dependant-types buffer)
collect (gl-source (gl-struct dependent)))
(glsl-toolkit:interface-declaration
(glsl-toolkit:type-qualifier
,@(when (layout buffer)
`((glsl-toolkit:layout-qualifier
,@(loop for id in (enlist (layout buffer))
collect `(glsl-toolkit:layout-qualifier-id ,@(enlist id))))))
:uniform
,@(qualifiers buffer))
,(gl-type buffer)
,(if (binding buffer)
`(glsl-toolkit:instance-name ,(binding buffer))
'glsl-toolkit:no-value)
,@(mapcar #'gl-source (fields buffer)))))

(defmethod compute-dependant-types ((buffer uniform-buffer))
(compute-dependant-types (gl-struct (input buffer))))

(defun compute-uniform-buffer-fields (buffer)
(labels ((gather-fields (struct prefix)
(loop for field in (fields struct)
nconc (cond ((and (array-size field) (listp (gl-type field)))
(loop for i from 0 below (array-size field)
nconc (gather-fields (gl-struct (second (gl-type field)))
(format NIL "~a~a[~d]." prefix (gl-name field) i))))
((array-size field)
(loop for i from 0 below (array-size field)
collect (format NIL "~a~a[~d]." prefix (gl-name field) i)))
((listp (gl-type field))
(gather-fields (gl-struct (second (gl-type field)))
(format NIL "~a~a." prefix (gl-name field))))
(T
(list (format NIL "~a~a" prefix (gl-name field))))))))
(gather-fields (gl-struct (input buffer)) (format NIL "~@[~a.~]" (binding buffer)))))

(defmethod compute-offsets ((buffer uniform-buffer) (program shader-program))
(let* ((struct (gl-struct (input buffer)))
(index (gl:get-uniform-block-index (gl-name program) (gl-type struct)))
(size (gl:get-active-uniform-block (gl-name program) index :uniform-block-data-size))
(offsets (make-hash-table :test 'equal)))
(labels ((gather-fields (struct prefix)
(loop for field in (fields struct)
nconc (cond ((and (array-size field) (listp (gl-type field)))
(loop for i from 0 below (array-size field)
nconc (gather-fields (gl-struct (second (gl-type field)))
(format NIL "~a~a[~d]" prefix (gl-name field) i))))
((array-size field)
(loop for i from 0 below (array-size field)
collect (format NIL "~a~a[~d]" prefix (gl-name field) i)))
((listp (gl-type field))
(gather-fields (gl-struct (second (gl-type field)))
(format NIL "~a~a." prefix (gl-name field))))
(T
(list (format NIL "~a~a" prefix (gl-name field))))))))
(let ((fields (gather-fields struct (format NIL "~@[~a.~]" (binding buffer)))))
(cffi:with-foreign-objects ((names :pointer 1)
(indices :int 1)
(params :int 1))
(dolist (field fields)
(cffi:with-foreign-string (name field)
(setf (cffi:mem-ref names :pointer) name)
(%gl:get-uniform-indices (gl-name program) 1 names indices)
(%gl:get-active-uniforms-iv (gl-name program) 1 indices :uniform-offset params)
(setf (gethash field offsets) (cffi:mem-ref params :int)))))))
(offsets (make-hash-table :test 'equal))
(fields (compute-uniform-buffer-fields buffer)))
(cffi:with-foreign-objects ((names :pointer 1)
(indices :int 1)
(params :int 1))
(dolist (field fields)
(cffi:with-foreign-string (name field)
(setf (cffi:mem-ref names :pointer) name)
(%gl:get-uniform-indices (gl-name program) 1 names indices)
(%gl:get-active-uniforms-iv (gl-name program) 1 indices :uniform-offset params)
(setf (gethash field offsets) (cffi:mem-ref params :int)))))
(values offsets size)))

(defmethod load ((buffer uniform-buffer))
@@ -34,69 +34,69 @@ void main(){
())

(define-class-shader (negative-pass :fragment-shader)
'(effects #p"negative.frag"))
(pool-path 'effects #p"negative.frag"))

(define-shader-pass grayscale-pass (simple-post-effect-pass)
())

(define-class-shader (grayscale-pass :fragment-shader)
'(effects #p"gray-filter.frag"))
(pool-path 'effects #p"gray-filter.frag"))

(define-shader-pass box-blur-pass (simple-post-effect-pass)
())

(define-class-shader (box-blur-pass :fragment-shader)
'(effects #p"box-blur.frag"))
(pool-path 'effects #p"box-blur.frag"))

(define-shader-pass sobel-pass (simple-post-effect-pass)
())

(define-class-shader (sobel-pass :fragment-shader)
'(effects #p"sobel.frag"))
(pool-path 'effects #p"sobel.frag"))

(define-shader-pass gaussian-blur-pass (simple-post-effect-pass)
())

(define-class-shader (gaussian-blur-pass :fragment-shader)
'(effects #p"gaussian.frag"))
(pool-path 'effects #p"gaussian.frag"))

(define-shader-pass radial-blur-pass (simple-post-effect-pass)
())

(define-class-shader (radial-blur-pass :fragment-shader)
'(effects #p"radial-blur.frag"))
(pool-path 'effects #p"radial-blur.frag"))

(define-shader-pass fxaa-pass (simple-post-effect-pass)
())

(define-class-shader (fxaa-pass :fragment-shader)
'(effects #p"fxaa.frag"))
(pool-path 'effects #p"fxaa.frag"))

(define-shader-pass blend-pass (post-effect-pass)
((a-pass :port-type input)
(b-pass :port-type input)
(color :port-type output)))

(define-class-shader (blend-pass :fragment-shader)
'(effects #p"blend.frag"))
(pool-path 'effects #p"blend.frag"))

(define-shader-pass high-pass-filter (simple-post-effect-pass)
())

(define-class-shader (high-pass-filter :fragment-shader)
'(effects #p"high-pass-filter.frag"))
(pool-path 'effects #p"high-pass-filter.frag"))

(define-shader-pass low-pass-filter (simple-post-effect-pass)
())

(define-class-shader (low-pass-filter :fragment-shader)
'(effects #p"low-pass-filter.frag"))
(pool-path 'effects #p"low-pass-filter.frag"))

(define-shader-pass chromatic-aberration-filter (simple-post-effect-pass)
())

(define-class-shader (chromatic-aberration-filter :fragment-shader)
'(effects #p"aberration.frag"))
(pool-path 'effects #p"aberration.frag"))

(define-shader-pass black-render-pass (render-pass)
((color :port-type output)))
@@ -114,4 +114,4 @@ void main(){
(color :port-type output)))

(define-class-shader (light-scatter-pass :fragment-shader)
'(effects #p"light-scatter.frag"))
(pool-path 'effects #p"light-scatter.frag"))
@@ -31,6 +31,18 @@
#:geometry-name
#:attributes
#:data-usage)
;; assets/uniform-buffer.lisp
(:export
#:uniform-buffer
#:layout
#:qualifiers
#:binding
#:offsets
#:gl-type
#:gl-source
#:compute-offsets
#:bind
#:buffer-field)
;; formats/collada.lisp
(:export)
;; formats/vertex-format.lisp
@@ -40,6 +52,21 @@
#:framebuffer
#:attachments
#:resize)
;; resources/gl-struct.lisp
(:export
#:gl-declaration
#:name
#:gl-name
#:gl-type
#:qualifiers
#:layout
#:compute-dependant-types
#:gl-source
#:gl-struct-field
#:array-size
#:gl-struct
#:fields
#:define-gl-struct)
;; resources/shader-program.lisp
(:export
#:shader-program
@@ -28,6 +28,11 @@
(print-unreadable-object (gl-declaration stream :type T)
(format stream "~s" (name gl-declaration))))

(defmethod compute-dependant-types ((gl-declaration gl-declaration))
(let ((type (gl-type gl-declaration)))
(when (and (listp type) (eq (first type) :struct))
(list (second type)))))

(defmethod gl-source ((gl-declaration gl-declaration))
`(glsl-toolkit:struct-declarator
(glsl-toolkit:type-qualifier
@@ -66,7 +71,7 @@

(defmethod initialize-instance :after ((gl-struct gl-struct) &key name gl-type)
(unless gl-type
(setf (gl-type gl-struct) (format NIL "~@(~a~)" (cffi:translate-underscore-separated-name name)))))
(setf (gl-type gl-struct) (cffi:translate-camelcase-name name :upper-initial-p T))))

(defmethod print-object ((gl-struct gl-struct) stream)
(print-unreadable-object (gl-struct stream :type T)
@@ -88,6 +93,9 @@
(defun remove-gl-struct (name)
(remhash name *gl-structs*))

(defmethod compute-dependant-types ((gl-struct gl-struct))
(mapcan #'compute-dependant-types (fields gl-struct)))

(defun translate-gl-struct-field-info (fields)
(loop for field in fields
collect (destructuring-bind (name type &rest args) field
@@ -55,11 +55,7 @@
(loop for (type shaders) on effective-shaders by #'cddr
do (setf (getf effective-shaders type)
(glsl-toolkit:merge-shader-sources
(loop for (priority shader) in (stable-sort shaders #'> :key #'first)
collect (etypecase shader
(string shader)
(list (destructuring-bind (pool path) shader
(pool-path pool path))))))))
(mapcar #'second (stable-sort shaders #'> :key #'first)))))
effective-shaders))

(defmethod compute-effective-shader-class ((class shader-entity-class))
@@ -143,9 +139,20 @@
(defmethod make-class-shader-program ((class symbol))
(make-class-shader-program (find-class class)))

(defun combine-shader-sources (&rest sources)
(list* 'glsl-toolkit:shader
(loop for source in sources
for parsed = (etypecase source
(cons source)
(T (glsl-toolkit:parse source)))
append (case (car parsed)
(glsl-toolkit:shader
(cdr parsed))
(T (list parsed))))))

(defmacro define-class-shader ((class type &optional (priority 0)) &body definitions)
`(setf (class-shader ,type ',class)
(list ,priority (progn ,@definitions))))
(list ,priority (combine-shader-sources ,@definitions))))

(defclass shader-entity (entity)
()

0 comments on commit f34a79f

Please sign in to comment.