diff --git a/src/render/mesh.lisp b/src/render/mesh.lisp index 1b0de20..b74d19e 100644 --- a/src/render/mesh.lisp +++ b/src/render/mesh.lisp @@ -11,7 +11,7 @@ (in-package :stoe.render.mesh) (defstruct attrib - (name "") + (symb nil) type size offset) @@ -42,12 +42,12 @@ (buffer-size 0) (end-offset 0)) (let* ((attribs (mapcar (lambda (attrib) - (let ((name (first attrib)) + (let ((symb (first attrib)) (type (second attrib)) (size (third attrib)) (buffer (fourth attrib))) (prog1 - (make-attrib :name (symbol-name name) :type type + (make-attrib :symb (intern (symbol-name symb) :keyword) :type type :size size :offset end-offset) (setf buffer-data (cons buffer buffer-data)) (let ((len (length buffer))) diff --git a/src/render/render.lisp b/src/render/render.lisp index c681804..d41365b 100644 --- a/src/render/render.lisp +++ b/src/render/render.lisp @@ -6,8 +6,7 @@ (in-package :cl-user) (defpackage stoe.render (:nicknames :render) - (:use :cl - :utils) + (:use :cl :utils :gl-utils :shader) (:export :poll-events) (:import-from :modules :defmodule) @@ -49,14 +48,14 @@ Create an opengl context attached to a window and initialize the shader system." (progn (setf *window* (glop:create-window title width height)) (gl-utils:initialize 0))) - (shader:compile-all-shaders)) + (compile-all-shaders)) (initialize-renderer)) (defun finalize () "Finalize the render module. Destroy the opengl context and the related resources." (format t "Finalize Render module~%") - (shader:destroy-all-shaders) + (destroy-all-shaders) (glop:destroy-window *window*) (setf *window* nil) (gl-utils:finalize)) @@ -80,7 +79,7 @@ This needs to be called once per frame, at the beginning of the loop." (glop:dispatch-events *window* :blocking nil :on-foo nil))) (defmethod glop:on-event (window event) - (declare (ignore window event)) + (declare (ignore window)) (typecase event (glop:key-press-event (input:on-key-event t (glop:keycode event) (glop:keysym event) (glop:text event))) (glop:key-release-event (input:on-key-event nil (glop:keycode event) (glop:keysym event) (glop:text event))) @@ -101,8 +100,8 @@ This needs to be called once per frame, at the beginning of the loop." (defun render-mesh (node mesh) "Render a single mesh." (loop for stream in (mesh::mesh-streams mesh) - do (shader::using-program (program (mesh::mesh-stream-program stream)) - (shader::with-uniforms (model-to-camera camera-to-clip) program + do (using-program (program (mesh::mesh-stream-program stream)) + (with-locations (model-to-camera camera-to-clip) program (gl:uniform-matrix model-to-camera 4 (vector (m:* (view (get-current-camera)) (trans-mat node)))) (gl:uniform-matrix camera-to-clip 4 (vector (proj (get-current-camera))))) @@ -111,16 +110,17 @@ This needs to be called once per frame, at the beginning of the loop." (attribs (mesh::vertex-buffer-attribs vertex-buffer))) (gl:bind-buffer :array-buffer (mesh::vertex-buffer-buffer-object vertex-buffer)) (loop for attrib in attribs - do (let* ((attrib-name (mesh::attrib-name attrib)) - (attrib-loc (shader::get-attrib-location program attrib-name))) - (gl-utils:gl-assert (gl:enable-vertex-attrib-array attrib-loc)) - (gl-utils:gl-assert (gl:vertex-attrib-pointer attrib-loc (mesh::attrib-size attrib) - (mesh::attrib-type attrib) :false 0 - (mesh::attrib-offset attrib))))) + do (let* ((attrib-name (mesh::attrib-symb attrib)) + (attrib-loc (get-location program attrib-name))) + (unless (= attrib-loc -1) + (gl-assert (gl:enable-vertex-attrib-array attrib-loc) + (gl:vertex-attrib-pointer attrib-loc (mesh::attrib-size attrib) + (mesh::attrib-type attrib) :false 0 + (mesh::attrib-offset attrib)))))) (gl:bind-buffer :element-array-buffer (mesh::index-buffer-buffer-object index-buffer)) - (gl-utils:gl-assert (%gl:draw-elements (mesh::index-buffer-mode index-buffer) - (mesh::index-buffer-size index-buffer) - (mesh::index-buffer-type index-buffer) 0)) + (gl-assert (%gl:draw-elements (mesh::index-buffer-mode index-buffer) + (mesh::index-buffer-size index-buffer) + (mesh::index-buffer-type index-buffer) 0)) (gl:disable-vertex-attrib-array 0) (gl:bind-buffer :element-array-buffer 0) (gl:bind-buffer :array-buffer 0))))) diff --git a/src/render/shader/compiler.lisp b/src/render/shader/compiler.lisp index f39c92c..a9cc3bb 100644 --- a/src/render/shader/compiler.lisp +++ b/src/render/shader/compiler.lisp @@ -1,25 +1,147 @@ #| This file is a part of stoe project. - Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr) + Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr) |# (in-package :cl-user) (defpackage stoe.shader.compiler - (:use :cl :utils) + (:use :cl :utils :gl-utils :shader :glsl) (:nicknames :compiler) - (:import-from :stoe.shader.glsl - :glsl-compile) - (:export :defshader)) + (:export :defshader + :defprogram + :compile-all-shaders + :destroy-all-shaders)) (in-package :stoe.shader.compiler) +(defvar *shaders-table* (make-hash-table)) +(defvar *programs-table* (make-hash-table)) + (defun %defshader (lambda-list body) - (let ((shader (glsl-compile lambda-list body))) - shader)) + (glsl-compile lambda-list body)) (defmacro defshader (name lambda-list &body body) "Define a shader defining function. The newly created shader will be put in a special package: `%stoe.shaders'." - (let ((symbol (intern (symbol-name name) :%stoe.shaders))) - `(progn - (set ',symbol (%defshader ',lambda-list ',body)) - ',symbol))) + `(progn + (set ',name (%defshader ',lambda-list ',body)) + (when (gl-initialized-p) + (mapc (lambda (program) + (delete-program program) + (compile-program program)) (gethash ',name *shaders-table*))))) + +(defun %defprogram (lambda-list body) + (make-program lambda-list body)) + +(defun clean-dep (name shader-list) + (loop for shader in (cdr shader-list) by #'cddr + do (setf (gethash shader *shaders-table*) + (delete name (gethash shader *shaders-table*))))) + +(defun add-dep (name shader-list) + (loop for shader in (cdr shader-list) by #'cddr + do (pushnew name (gethash shader *shaders-table*)))) + +(defmacro defprogram (name lambda-list &body body) + "Define a new program comprised of all the specified shaders." + `(progn + (when (gethash ',name *programs-table*) + (clean-dep ',name (gethash ',name *programs-table*))) + (set ',name (%defprogram ',lambda-list ',body)) + (setf (gethash ',name *programs-table*) ',body) + (add-dep ',name ',body) + (when (gl-initialized-p) + (compile-program ',name)))) + +(defun compile-shader (type shader) + "Compile the shader into opengl." + (let ((shader-obj (gl-assert (gl:create-shader type)))) + (when (= shader-obj 0) + (error "Couldn't create shader object.")) + (handler-case + (progn + (gl-assert (gl:shader-source shader-obj (glsl-print shader)) + (gl:compile-shader shader-obj)) + (unless (gl:get-shader shader-obj :compile-status) + (error "Compile failure in ~(~s~) shader:~%~a~%~2i~a~%" type + (glsl-print shader) (gl:get-shader-info-log shader-obj))) + shader-obj) + (error (condition) + (gl:delete-shader shader-obj) + (error condition))))) + +(defun initialize-program (program) + "Initialize the program. +Retrieve the attributes and uniform locations." + (flet ((retrieve-location (var) + (unless (member :location (var-qualifiers var)) + (let ((target (var-target var))) + (setf (var-qualifiers var) + (append (var-qualifiers var) + (list :location (funcall (cond + ((eq target :in) #'gl:get-attrib-location) + ((eq target :uniform) #'gl:get-uniform-location)) + (program-id program) + (var-name var))))))))) + (mapc #'retrieve-location (program-vars program)))) + +(defun compile-program (symbol) + "Compile and link the program." + (loop + while (restart-case + (let ((program (symbol-value symbol)) + compiled-shaders) + (unless program + (error "The program ~s is undefined." symbol)) + (unwind-protect + (progn + (loop for type in (program-stages program) by #'cddr + for shader in (cdr (program-stages program)) by #'cddr + do (push (compile-shader type (symbol-value shader)) compiled-shaders)) + (let ((prog-id (gl-assert (gl:create-program)))) + (when (= prog-id 0) + (error "Couldn't create program object.")) + (unwind-protect + (progn + (mapc (lambda (shader) (gl-assert (gl:attach-shader prog-id shader))) + compiled-shaders) + (gl-assert (gl:link-program prog-id)) + (unless (gl:get-program prog-id :link-status) + (error "Link failure in shader program ~s:~%~2i~a~%" symbol + (gl:get-program-info-log prog-id))) + (setf (program-id program) prog-id) + (initialize-program program)) + (mapc (lambda (shader) (gl:detach-shader prog-id shader)) + (gl:get-attached-shaders prog-id))))) + (mapc (lambda (shader) (gl:delete-shader shader)) compiled-shaders)) + nil) + (retry () + :report (lambda (stream) (format stream "Retry compiling the shader program ~a." + symbol)) + t) + (give-up () + :report (lambda (stream) (format stream "Give up on the shader program ~a." + symbol)) + nil)))) + +(defun delete-program (symbol) + "Delete the program." + (let ((program (symbol-value symbol))) + (when (program-id program) + (gl:delete-program (program-id program)) + (setf (program-id program) nil)))) + +(defun compile-all-shaders () + "Compile and link all the shaders into opengl." + (loop-with-progress "Compiling shaders" + for symbol being the hash-key in *programs-table* + do (progn + (compile-program symbol) + progress-step))) + +(defun destroy-all-shaders () + "Destroy the programs registered in opengl." + (loop-with-progress "Deleting shaders" + for symbol being the hash-key in *programs-table* + do (progn + (delete-program symbol) + progress-step))) diff --git a/src/render/shader/glsl-compiler.lisp b/src/render/shader/glsl-compiler.lisp deleted file mode 100644 index 75dd4d8..0000000 --- a/src/render/shader/glsl-compiler.lisp +++ /dev/null @@ -1,92 +0,0 @@ -#| - This file is a part of stoe project. - Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr) -|# - -(in-package :cl-user) -(defpackage stoe.shader.glsl-compiler - (:nicknames :glsl-compiler) - (:use :cl :utils) - (:export :make-shader)) -(in-package :stoe.shader.glsl-compiler) - -(defvar +default-version+ '(330 :core)) -(defvar +profile-names+ '(:core :compatibility)) -(defvar +interpolation-qualifiers+ '(:flat :noperspective :smooth)) - -(defstruct sh-version - (number 0 :read-only t) - (profile nil :read-only t)) - -(defstruct sh-variable - (name "" :read-only t) - (type :int :read-only t) - (qualifier :in :read-only t) - (array 1 :read-only t) - (location nil :read-only t) - (interp nil :read-only t)) - -(defstruct (shader (:constructor %make-shader)) - (name "" :read-only t) - (version nil :read-only t) - (inputs nil :read-only t) - (outputs nil :read-only t) - (uniforms nil :read-only t) - (code "" :read-only t)) - -(defun compile-shader-version (version) - (format nil "#version ~a~@[ ~(~a~)~]~%" (sh-version-number version) (sh-version-profile version))) - -(defun fix-name-convention (cl-name) - "Convert a variable name in common-lisp convention to a glsl compliant name." - (string-downcase (substitute #\_ #\- cl-name))) - -(defun compile-shader-variables (vars) - (apply #'concatenate 'string - (loop for var in vars - collect (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~)~[~;~:;[~:*~a]~];~%" - (sh-variable-location var) - (sh-variable-interp var) - (sh-variable-qualifier var) - (sh-variable-type var) - (fix-name-convention (sh-variable-name var)) - (sh-variable-array var))))) - -(defun compile-shader-main (body) - (format nil "void main ()~%{~%~a~%}~%" body)) - -(defun process-version (spec) - (make-sh-version :number (if (numberp (car spec)) (car spec) (car +default-version+)) - :profile (if (and (cdr spec) (member (cadr spec) +profile-names+)) - (cadr spec) - (car +profile-names+)))) - -(defun process-variable-1 (qualifier spec) - (make-sh-variable :name (symbol-name (car spec)) - :type (cadr spec) - :qualifier qualifier - :array (getf (cddr spec) :array 1) - :location (getf (cddr spec) :location nil) - :interp (safe-first (member (getf (cddr spec) :interp) +interpolation-qualifiers+)))) - -(defun process-variables (qualifier specs) - (loop for spec in specs - collect (process-variable-1 qualifier spec))) - -(defun compile-shader (version inputs outputs uniforms body) - "Compile a shader's data into a string containing the shader in glsl." - (concatenate 'string - (compile-shader-version version) - (compile-shader-variables inputs) - (compile-shader-variables outputs) - (compile-shader-variables uniforms) - (compile-shader-main body))) - -(defun make-shader (name args body) - (let* ((version (process-version (safe-list (getf args :version)))) - (inputs (process-variables :in (getf args :in))) - (outputs (process-variables :out (getf args :out))) - (uniforms (process-variables :uniform (getf args :uniform))) - (code (compile-shader version inputs outputs uniforms (safe-first body)))) - (%make-shader :name (symbol-name name) :version version :inputs inputs - :outputs outputs :uniforms uniforms :code code))) diff --git a/src/render/shader/glsl.lisp b/src/render/shader/glsl.lisp index a688d24..077d895 100644 --- a/src/render/shader/glsl.lisp +++ b/src/render/shader/glsl.lisp @@ -1,18 +1,13 @@ #| This file is a part of stoe project. - Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr) + Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr) |# (in-package :cl-user) (defpackage stoe.shader.glsl - (:use :cl :utils) + (:use :cl :utils :walker :shader) (:nicknames :glsl) - (:import-from :stoe.shader.walker - :defhandler - :walk - :walk-list - :walk-1) - (:export :compile)) + (:export :glsl-compile :glsl-print)) (in-package :stoe.shader.glsl) (defvar *form-handlers* (make-hash-table) @@ -28,16 +23,19 @@ "Configure the verbosity of the compiler. if non-nil, the dsl will be printed in comments together with the glsl code.") -(defvar *version-profiles* '(("1.30" . "#version 130 -#extension ARB_explicit_attrib_location : require") - ("3.30" . "#version 330 core"))) +(defvar *version-profiles* '((1.3 . "#version 130 +// #extension ARB_explicit_attrib_location : require") + (3.3 . "#version 330 core") + (4.4 . "#version 440 core"))) -(defvar *glsl-symbols* '(gl-position "gl_Position") +(defvar *glsl-symbols* '(:gl-position "gl_Position" + :gl-fragcoord "gl_FragCoord" + :gl-fragcolor "gl_FragColor") "Keep a table of reserved glsl symbols.") (defun glsl-name (cl-name) "Convert a variable name in common-lisp convention to a glsl compliant name." - (or (getf *glsl-symbols* cl-name) + (or (getf *glsl-symbols* (intern (symbol-name cl-name) :keyword)) (string-downcase (substitute #\_ #\- (symbol-name cl-name))))) (defmacro noop-handler (body) @@ -65,15 +63,15 @@ the forms comprised of these keywords will be printed in comments." (declare (ignore let)) (format nil "~{~a;~%~}~%~a" (loop for binding in bindings - collect (format nil "~@[~vt~]~(~a~) ~(~a~)~@[ = ~(~a~)~]" + collect (format nil "~@[~vt~]~(~a~) ~a~@[ = ~a~]" (when (> *current-indent* 0) *current-indent*) - (second binding) (first binding) + (second binding) (glsl-name (first binding)) (if (and (cddr binding) (not (cdddr binding))) (walk-1 (third binding)) (walk-list (cddr binding))))) - (format nil "~{~a;~%~}" (walk-list body)))) + (format nil "~{~a~^;~%~}" (walk-list body)))) (defhandler setf (setf &rest pairs) "Handle the assignment special form." @@ -81,8 +79,10 @@ the forms comprised of these keywords will be printed in comments." (let ((vars (loop for s in pairs by #'cddr collect s))) (let ((expanded (loop for n in vars for r in (rest pairs) by #'cddr - collect (glsl-name n) collect (walk-1 r)))) - (format nil "~@[~vt~]~{~(~a~) = ~(~a~)~^;~%~}" + collect (glsl-name n) collect (if (symbolp r) + (glsl-name r) + (walk-1 r))))) + (format nil "~@[~vt~]~{~a = ~a~^;~%~}" (when (> *current-indent* 0) *current-indent*) expanded)))) @@ -99,25 +99,56 @@ the forms comprised of these keywords will be printed in comments." (expand a) op (expand b)))) (reduce #'oper body))) +(defhandler (x y z w xy xz xw + yz yw zw xyz yzw xyzw) (attribs &rest rest) + "Handle swizzle." + (let ((symbol (first rest))) + (format nil "~a.~(~a~)" + (if (symbolp symbol) + (glsl-name symbol) + (walk-list symbol)) + attribs))) + (defun default-handler (first &rest rest) "Handle a simple function call." - (format nil "~@[~vt~]~(~a~) (~{~(~a~)~^, ~})" + (format nil "~@[~vt~]~a (~{~a~^, ~})" (when (> *current-indent* 0) *current-indent*) (if (symbolp first) - first + (glsl-name first) (walk-1 first)) (walk-list rest))) +(defun symbol-handler (sym) + "Handle a single symbol." + (glsl-name sym)) + (defun handle-preamble (form) "Handle a preamble declaration." - (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~);~%" - (awhen (member :location form) (cadr it)) - (awhen (member :interp form) (cadr it)) - (third form) (second form) (glsl-name (first form)))) + (make-var (intern (symbol-name (first form)) :keyword) (glsl-name (first form)) + (second form) (cddr form) + (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~);~%" + (awhen (member :location form) (cadr it)) + (awhen (member :interp form) (cadr it)) + (third form) (second form) (glsl-name (first form))))) (defun glsl-compile (lambda-list body) - (format nil "~a~%~%~{~a~}~%void main ()~%{~%~a}~%" - (cdr (assoc gl-utils:*glsl-version* *version-profiles* :test #'equal)) - (mapcar #'handle-preamble lambda-list) - (let ((*current-indent* 2)) - (walk (cons 'progn body) *form-handlers* #'default-handler *env*)))) + "Compile the shader defined in BODY to glsl format. +The forms contained in LAMBDA-LIST are used to define the global variables of +the shader." + (merge-shaders (make-shader :version (cdr (assoc gl-utils:*glsl-version* *version-profiles* + :test #'equal))) + (flet ((merge-preamble (sh1 sh2) + (merge-shaders sh1 (handle-preamble sh2)))) + (reduce #'merge-preamble (cons (handle-preamble (first lambda-list)) + (rest lambda-list)))) + (make-exp (format nil "void main ()~%{~%~a}~%" + (let ((*current-indent* 2)) + (walk (cons 'progn body) *form-handlers* #'default-handler #'symbol-handler *env*)))))) + +(defun glsl-print (shader) + "Returns a string containing the complete SHADER in glsl format." + (format nil "~@[~a~%~%~]~{~a~}~%~a" + (or (shader-version shader) (cdr (assoc gl-utils:*glsl-version* *version-profiles* + :test #'equal))) + (loop for var in (shader-vars shader) + collect (var-exp var)) (shader-exp shader))) diff --git a/src/render/shader/shader.lisp b/src/render/shader/shader.lisp index e57a98a..975baac 100644 --- a/src/render/shader/shader.lisp +++ b/src/render/shader/shader.lisp @@ -1,182 +1,118 @@ #| This file is a part of stoe project. - Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr) + Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr) |# (in-package :cl-user) (defpackage stoe.shader (:nicknames :shader) - (:use :cl :utils) - (:export :defshader - :defprogram - :compile-all-shaders - :destroy-all-shaders)) + (:use :cl :utils :gl-utils) + (:export :make-shader + :make-var + :make-exp + :merge-shaders + :shader-version + :shader-vars + :shader-exp + :var-symb + :var-name + :var-qualifiers + :var-target + :var-exp + :make-program + :program-stages + :program-vars + :program-id + :get-location + :using-program + :with-locations)) (in-package :stoe.shader) -(defpackage %stoe.shaders - (:documentation "Package used to hold the symbols for the shader programs defined by defprogram.")) +(defstruct shader + "Structure containing the shader in glsl format together with metadata used to +properly handle the shader." + (version nil) + (vars nil) + (exp "")) -(defstruct program - (name "" :read-only t) +(defstruct (var (:constructor %make-var)) + "Structure containing the shader variable in glsl format together with its +attributes to properly handle the variable." + (symb nil) + (name "") + (type :none) + (qualifiers nil) + (exp "")) + +(defun make-var (symb name type qualifiers exp) + "Creates and returns a new shader container to keep track of the variable +defined by the arguments." + (make-shader :vars (list (%make-var :symb symb + :name name + :type type + :qualifiers qualifiers + :exp exp)))) + +(defun var-target (var) + "Returns the target type of the variable. Either :in, :out or :uniform." + (first (member-if (lambda (x) (or (eq x :in) + (eq x :out) + (eq x :uniform))) + (var-qualifiers var)))) + +(defun make-exp (exp) + "Creates and returns a new shader container to keep track of the glsl +expression." + (make-shader :exp exp)) + +(defun merge-shaders (&rest shaders) + "Merges two or more shader containers and returns the result." + (labels ((sh-merge (sh1 sh2) + (make-shader :version (or (shader-version sh1) (shader-version sh2)) + :vars (append (shader-vars sh1) (shader-vars sh2)) + :exp (concatenate 'string (shader-exp sh1) (shader-exp sh2))))) + (reduce #'sh-merge shaders))) + +(defstruct (program (:constructor %make-program)) + "Structure containing the symbols of the different stages' shaders and the +associated in/out/uniform variables. +If the program is compiled into glsl, it keeps track of the object id." (stages nil :read-only t) - attribs - uniforms - gl-program) + vars + id) -(defvar *shader-db* (make-hash-table :test 'eq) - "The database containing all the shaders defined with `defshader'.") +(defun make-program (lambda-list stages) + "Creates a new program by using and analyzing the specified shaders." + (declare (ignore lambda-list)) + (%make-program :stages stages + :vars (remove-duplicates + (reduce #'append + (loop for shader in (cdr stages) by #'cddr + collect (remove-if-not + (lambda (var) + (member-if (lambda (x) (or (eq x :in) (eq x :uniform))) + (var-qualifiers var))) + (shader-vars (symbol-value shader)))))))) -(defun %defshader (name args body) - (setf (gethash name *shader-db*) (glsl-compiler:make-shader name args body))) - -(defmacro defshader (name args &body body) - "Define a new shader in common-lisp style. -The shader will be compiled in shader language and added to the pool." - `(stoe.shader::%defshader ',name ',args ',body)) - -(defun %defprogram (name args body) - (declare (ignore args)) - (let ((components (mapcar #'(lambda (comp) - (cons (first comp) (gethash (second comp) *shader-db*))) - (group body 2)))) - (make-program :name (symbol-name name) :stages components))) - -(defmacro defprogram (name args &body body) - "Define a new program comprised of all the specified shaders." - (let ((symbol (intern (symbol-name name) :%stoe.shaders))) - `(progn - (set ',symbol (stoe.shader::%defprogram ',symbol ',args ',body)) - ',symbol))) - -(defun compile-shader (type shader) - "Compile the shader into opengl." - (let ((shader-obj (gl-utils:gl-assert (gl:create-shader type)))) - (when (= shader-obj 0) - (error "Couldn't create shader object.")) - (handler-case - (progn - (gl-utils:gl-assert (gl:shader-source shader-obj (glsl-compiler::shader-code shader))) ; Not great… - (gl-utils:gl-assert (gl:compile-shader shader-obj)) - (unless (gl:get-shader shader-obj :compile-status) - (error "Compile failure in ~(~s~) shader:~%~2i~a~%" type (gl:get-shader-info-log shader-obj))) - shader-obj) - (error (condition) - (gl:delete-shader shader-obj) - (error condition))))) - -(defun initialize-program (program) - "Initialize the program. -Retrieve the attributes and uniform locations." - (let* ((shader (cdr (first (program-stages program)))) - (inputs (glsl-compiler::shader-inputs shader)) - (uniforms (glsl-compiler::shader-uniforms shader))) - (labels ((get-var-with-location (var fun) - (list (glsl-compiler::sh-variable-name var) - (glsl-compiler::sh-variable-type var) - (glsl-compiler::sh-variable-array var) - (aif (glsl-compiler::sh-variable-location var) - it - (apply fun (program-gl-program program) (list (glsl-compiler::fix-name-convention - (glsl-compiler::sh-variable-name var))))))) - (get-attrib (var) - (get-var-with-location var #'gl:get-attrib-location)) - (get-uniforms (var) - (get-var-with-location var #'gl:get-uniform-location))) - (setf (program-attribs program) (mapcar #'get-attrib inputs)) - (setf (program-uniforms program) (mapcar #'get-uniforms uniforms))))) - -(defun compile-program (program-symbol) - "Compile and link the program." - (loop - (restart-case - (return - (let ((program (symbol-value program-symbol))) - (unless program - (error "The program ~s is undefined." program-symbol)) - (let (compiled-shaders) - (unwind-protect - (progn - (loop for shader in (program-stages program) - do (push (compile-shader (car shader) (cdr shader)) compiled-shaders)) - (let ((program-obj (gl-utils:gl-assert (gl:create-program)))) - (when (= program-obj 0) - (error "Couldn't create program object.")) - (unwind-protect - (progn - (mapc (lambda (shader) (gl-utils:gl-assert (gl:attach-shader program-obj shader))) - compiled-shaders) - (gl-utils:gl-assert (gl:link-program program-obj)) - (unless (gl:get-program program-obj :link-status) - (error "Link failure in shader program ~s:~%~2i~a~%" program-symbol - (gl:get-program-info-log program-obj))) - (setf (program-gl-program program) program-obj) - (initialize-program program)) - (mapc (lambda (shader) (gl:detach-shader program-obj shader)) - (gl:get-attached-shaders program-obj))))) - (mapc (lambda (shader) (gl:delete-shader shader)) compiled-shaders))))) - (retry () :report (lambda (stream) (format stream "Retry compiling the shader program ~S." program-symbol)))))) - -(defun delete-program (program-symbol) - "Delete the program bound to PROGRAM-SYMBOL." - (let ((program (symbol-value program-symbol))) - (when (program-gl-program program) - (gl:delete-program (program-gl-program program))))) - -(defun compile-all-shaders () - "Compile and link all the shaders into opengl." - (let ((cmp-message "Compiling shaders") - ;; Count the columns used by the progress message - ;; if it goes on for more than max-columns, continue on the next line - (max-columns 80)) - (format t cmp-message) - (loop for i upfrom (length cmp-message) - for program-symbol being the symbol in :%stoe.shaders - do (progn - (when (> i max-columns) - (format t "~%") - (setf i 0)) - (format t ".") - (compile-program program-symbol))) - (format t "~%"))) - -(defun destroy-all-shaders () - "Destroy the programs registered in opengl." - (format t "Deleting shaders") - (loop for program-symbol being the symbol in :%stoe.shaders - do (delete-program program-symbol))) - -(defun get-attrib-location (program symbol) - (fourth (first (member symbol (program-attribs program) :key #'car :test #'equal)))) +(defun get-location (program var) + "Retrieve the location value of the variable in program." + (second (member :location (var-qualifiers (first (member (intern (symbol-name var) :keyword) + (program-vars program) + :key #'var-symb)))))) (defmacro using-program ((var program) &body body) - "Use the specified program and bind all its attributes and uniform for use in `body'." - `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :%stoe.shaders)))) - (gl-utils:gl-assert (gl:use-program (program-gl-program ,var))) + "Use the specified program and bind all its attributes and uniforms for use in BODY." + `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :stoe.render.shaders)))) + (gl-assert (gl:use-program (program-id ,var))) ,@body - (gl-utils:gl-assert (gl:use-program 0)))) + (gl-assert (gl:use-program 0)))) -(defmacro with-uniforms (vars program &body body) +(defmacro with-locations (vars program &body body) + "Binds the programs uniforms into the corresponding symbols of vars, using the +same syntax as `with-accessors'." `(let ,(mapcar (lambda (var) (cond - ((listp var) (list (first var) - `(fourth (first (member (symbol-name ',(second var)) - (program-uniforms ,program) - :key #'car :test #'equal))))) - ((symbolp var) (list var `(fourth (first (member (symbol-name ',var) - (program-uniforms ,program) - :key #'car :test #'equal))))))) - vars) - ,@body)) - -(defmacro with-attribs (vars program &body body) - `(let ,(mapcar (lambda (var) - (cond - ((listp var) (list (first var) - `(fourth (first (member (symbol-name ',(second var)) - (program-attribs ,program) - :key #'car :test #'equal))))) - ((symbolp var) (list var `(fourth (first (member (symbol-name ',var) - (program-attribs ,program) - :key #'car :test #'equal))))))) + ((listp var) (list (first var) `(get-location ,program ',(second var)))) + ((symbolp var) (list var `(get-location ,program ',var))))) vars) ,@body)) diff --git a/src/render/shader/walker.lisp b/src/render/shader/walker.lisp index ec0a4de..aa4d43c 100644 --- a/src/render/shader/walker.lisp +++ b/src/render/shader/walker.lisp @@ -1,6 +1,6 @@ #| This file is a part of stoe project. - Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr) + Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr) |# (in-package :cl-user) @@ -18,14 +18,18 @@ "A special variable containing the handlers for our dsl keywords.")) (defvar *default-handler* nil - "A special variable containing the default handler used for unknown symbols.") + "A special variable containing the default handler used for unknown function symbols.") + +(defvar *symbol-handler* nil + "A special variable containing the default handler used for single symbols.") (defvar *env* nil "A special variable used as a container for the macro environment.") (defun form-handler (first) "Retreive the handler for the symbol FIRST." - (gethash first *form-handlers* *default-handler*)) + (gethash (intern (symbol-name first) :keyword) + *form-handlers* *default-handler*)) (defun binding-to-symbol (binding) (let ((name (safe-first binding))) @@ -65,7 +69,8 @@ "Walk across the specified form." (flet ((handle (form) (apply (form-handler (first form)) form))) - (cond ((and (listp form) (gethash (first form) *form-handlers*)) + (cond ((and (listp form) (gethash (intern (symbol-name (first form)) :keyword) + *form-handlers*)) (handle form)) (t (multiple-value-bind (form expanded) @@ -80,6 +85,7 @@ (if (eq form next) (handle form) (walk-1 next)))) + (symbol (apply *symbol-handler* form)) (t form))))))))) @@ -100,12 +106,16 @@ (defun ,func ,lambda-list ,@body) (setf ,@(loop for sym in syms - collect `(gethash ',sym ,(intern (symbol-name '*form-handlers*))) - collect `',func)))))) + collect `(gethash ,(intern (symbol-name sym) :keyword) + ,(intern (symbol-name '*form-handlers*))) + collect `',func)))))) -(defun walk (form handlers default-handler env) - "Walk the sexp FORM and transform it according to the rules defined in HANDLERS." +(defun walk (form handlers default-handler symbol-handler env) + "Walk the sexp FORM and transform it according to the rules defined in HANDLERS. +When no known symbol is parsed, it is either handled by DEFAULT-HANDLER or by SYMBOL-HANDLER, +whether it is the first symbol of a form or just a single symbol." (let ((*form-handlers* handlers) (*default-handler* default-handler) + (*symbol-handler* symbol-handler) (*env* env)) (walk-1 form))) diff --git a/src/render/shaders.lisp b/src/render/shaders.lisp index d63f50e..06d3f8a 100644 --- a/src/render/shaders.lisp +++ b/src/render/shaders.lisp @@ -6,24 +6,20 @@ (in-package :cl-user) (defpackage stoe.render.shaders (:nicknames :shaders) - (:use :cl - :shader)) + (:use :stoe.shader.compiler)) (in-package :stoe.render.shaders) -(defshader simple-vertex (:version 330 - :in ((position :vec4 :location 0) - (color :vec4 :location 1)) - :out ((out-color :vec4 :interp :smooth)) - :uniform ((camera-to-clip :mat4) - (model-to-camera :mat4)) - ) - "gl_Position = camera_to_clip * model_to_camera * position; -out_color = color;") +(defshader simple-vertex ((position :vec4 :in) + (color :vec4 :in) + (out-color :vec4 :out :interp :smooth) + (camera-to-clip :mat4 :uniform) + (model-to-camera :mat4 :uniform)) + (setf gl-position (* camera-to-clip model-to-camera position) + out-color color)) -(defshader simple-fragment (:version 330 - :in ((out-color :vec4)) - :out ((frag-color :vec4))) - "frag_color = out_color;") +(defshader simple-fragment ((out-color :vec4 :in :interp :smooth) + (frag-color :vec4 :out)) + (setf frag-color out-color)) (defprogram simple-shader () :vertex-shader simple-vertex diff --git a/stoe.asd b/stoe.asd index 4635d26..0bc6628 100644 --- a/stoe.asd +++ b/stoe.asd @@ -59,11 +59,10 @@ ((:file "gl-utils") (:module "shader" :components - ((:file "walker") + ((:file "shader") + (:file "walker") (:file "glsl") - (:file "compiler") - (:file "glsl-compiler") - (:file "shader"))) + (:file "compiler"))) (:file "mesh") (:file "render") (:file "shaders"))