495 lines
23 KiB
Common Lisp
495 lines
23 KiB
Common Lisp
;;;; wh-engine/render/shader.lisp
|
|
;;;; Lisp class for holding & handling shaders.
|
|
(in-package wh-engine/render)
|
|
|
|
(defun replace-xref-vars (forms vars replace-fun)
|
|
(loop for elt on forms
|
|
for form = (car elt)
|
|
if (symbolp form)
|
|
do (let ((var-entry (find form vars :key #'car)))
|
|
(when var-entry
|
|
(rplaca elt (funcall replace-fun var-entry))))
|
|
else if (consp form)
|
|
do (replace-xref-vars (cdr form) vars replace-fun)))
|
|
|
|
(defvar *vert-builtins* '((*vertex-id* . "gl_VertexID")
|
|
(*instance-id* . "gl_InstanceID")
|
|
(*draw-id* . "gl_DrawID")
|
|
(*base-vertex* . "gl_BaseVertex")
|
|
(*base-instance* . "gl_BaseInstance")
|
|
;; out
|
|
(*position* . "gl_Position")
|
|
(*point-size* . "gl_PointSize")
|
|
(*clip-distance* . "gl_ClipDistance")))
|
|
|
|
(defvar *frag-builtins* '((*frag-coord* . "gl_FragCoord")
|
|
(*front-facing* . "gl_FrontFacing")
|
|
(*point-coord* . "gl_PointCoord")
|
|
(*sample-id* . "gl_SampleID")
|
|
(*sample-position* . "gl_SamplePosition")
|
|
(*sample-mask-in* . "gl_SampleMaskIn")
|
|
(*clip-distance* . "gl_ClipDistance")
|
|
(*primitive-id* . "gl_PrimitiveID")
|
|
(*layer* . "gl_Layer")
|
|
(*viewport-index* . "gl_ViewportIndex")
|
|
;; out
|
|
(*frag-depth* . "gl_FragDepth")
|
|
(*sample-mask* . "gl_SampleMask")))
|
|
|
|
(defvar *infix-ops* '((+ "+" t)
|
|
(- "-" t)
|
|
(* "*" t)
|
|
(/ "/" t)
|
|
(mod "%" t)
|
|
(= "==" t)
|
|
(eq "==" nil)
|
|
(eql "==" nil)
|
|
(equal "==" nil)
|
|
(/= "!=" nil)
|
|
(< "<" t)
|
|
(> ">" t)
|
|
(<= "<=" t)
|
|
(>= ">=" t)
|
|
(<< "<<" nil)
|
|
(>> ">>" nil)
|
|
(ash "<<" nil)
|
|
(logand "&" t)
|
|
(logior "|" t)
|
|
(logxor "^" t)
|
|
(and "&&" t)
|
|
(or "||" t)))
|
|
|
|
(defvar *types* '((:void . "void")
|
|
(:bool . "bool")
|
|
(:int . "int")
|
|
(:uint . "uint")
|
|
(:float . "float")
|
|
(:double . "double")
|
|
(:vec2 . "vec2")
|
|
(:vec3 . "vec3")
|
|
(:vec4 . "vec4")
|
|
(:double-vec2 . "dvec2")
|
|
(:double-vec3 . "dvec3")
|
|
(:double-vec4 . "dvec4")
|
|
(:bool-vec2 . "bvec2")
|
|
(:bool-vec3 . "bvec3")
|
|
(:bool-vec4 . "bvec4")
|
|
(:int-vec2 . "ivec2")
|
|
(:int-vec3 . "ivec3")
|
|
(:int-vec4 . "ivec4")
|
|
(:uint-vec2 . "uvec2")
|
|
(:uint-vec3 . "uvec3")
|
|
(:uint-vec4 . "uvec4")
|
|
(:mat2 . "mat2")
|
|
(:mat3 . "mat3")
|
|
(:mat4 . "mat4")
|
|
(:sampler-1d . "sampler1D")
|
|
(:depth-sampler-1d . "sampler1DShadow")
|
|
(:array-sampler-1d . "sampler1DArray")
|
|
(:depth-array-sampler-1d . "sampler1DArrayShadow")
|
|
(:sampler-2d . "sampler2D")
|
|
(:depth-sampler-2d . "sampler2DShadow")
|
|
(:array-sampler-2d . "sampler2DArray")
|
|
(:depth-array-sampler-2d . "sampler2DArrayShadow")
|
|
(:multisampler-2d . "sampler2DMS")
|
|
(:array-multisampler-2d . "sampler2DMSArray")
|
|
(:rect-sampler-2d . "sampler2DRect")
|
|
(:depth-rect-sampler-2d . "sampler2DRectShadow")
|
|
(:sampler-3d . "sampler3D")
|
|
(:cube-sampler . "samplerCube")
|
|
(:depth-cube-sampler . "samplerCubeShadow")
|
|
(:array-cube-sampler . "samplerCubeArray")
|
|
(:depth-array-cube-sampler . "samplerCubeArrayShadow")
|
|
(:buffer-sampler . "samplerBuffer")))
|
|
|
|
(defvar *shader-funs* '((bool . "bool")
|
|
(int . "int")
|
|
(uint . "uint")
|
|
(float . "float")
|
|
(double . "double")
|
|
(vec2 . "vec2")
|
|
(vec3 . "vec3")
|
|
(vec4 . "vec4")
|
|
(radians . "radians")
|
|
(degrees . "degrees")
|
|
(sin . "sin")
|
|
(cos . "cos")
|
|
(tan . "tan")
|
|
(asin . "asin")
|
|
(acos . "acos")
|
|
(atan . "atan")
|
|
(sinh . "sinh")
|
|
(cosh . "cosh")
|
|
(tanh . "tanh")
|
|
(asinh . "asinh")
|
|
(acosh . "acosh")
|
|
(atanh . "atanh")
|
|
(expt . "pow")
|
|
(exp . "exp")
|
|
(log . "log")
|
|
(sqrt . "sqrt")
|
|
(abs . "abs")
|
|
(signum . "sign")
|
|
(floor . "floor")
|
|
(ffloor . "floor")
|
|
(truncate . "trunc")
|
|
(ftruncate . "trunc")
|
|
(round . "round")
|
|
(fround . "round")
|
|
(ceiling . "ceil")
|
|
(fceiling . "ceil")
|
|
(mod . "mod")
|
|
(min . "min")
|
|
(max . "max")
|
|
(linear-blend . "mix")
|
|
(step . "step")
|
|
(smooth-step . "smoothstep")
|
|
(float-nan-p . "isnan")
|
|
(float-infinity-p . "isinf")
|
|
(vlength . "length")
|
|
(vdistance . "distance")
|
|
(v. . "dot")
|
|
(vc . "cross")
|
|
(v2norm . "normalize")
|
|
(vforward . "faceforward")
|
|
(vreflect . "reflect")
|
|
(vrefract . "refract")
|
|
(mtranspose . "transpose")
|
|
(mdet . "determinant")
|
|
(minv . "inverse")
|
|
(v< . "lessThan")
|
|
(v<= . "lessThanEqual")
|
|
(v> . "greaterThan")
|
|
(v>= . "greaterThanEqual")
|
|
(v= . "equal")
|
|
(v/= . "notEqual")
|
|
(texture-size . "textureSize")
|
|
(texture-lod . "textureQueryLod")
|
|
(texture-levels . "textureQueryLevels")
|
|
(texture-samples . "textureSamples")
|
|
(sample-texture . "texture")
|
|
(sample-texture-raw . "texelFetch")))
|
|
|
|
(defun swizzlep (sym)
|
|
(let ((sym-str (string-downcase (symbol-name sym))))
|
|
(and (char= (char sym-str 0) #\v)
|
|
(loop for c across (subseq sym-str 1)
|
|
always (member c '(#\x #\y #\z #\w) :test #'char=))
|
|
(subseq sym-str 1))))
|
|
|
|
(defun conv-shader-type (type)
|
|
(or (cdr (assoc type *types*))
|
|
(error "Invalid type specifier: ~S" type)))
|
|
|
|
(defvar *shader-var-suffix* 0)
|
|
(defun conv-shader-var (sym &optional gen-suffix)
|
|
(concatenate 'string
|
|
(substitute-if-not #\_ (lambda (c) (or (alpha-char-p c) (digit-char-p c)))
|
|
(remove #\- (string-downcase (string-capitalize (symbol-name sym)) :end 1)))
|
|
(if gen-suffix
|
|
(write-to-string (incf *shader-var-suffix*))
|
|
"")))
|
|
|
|
(defun conv-shader-form (form vars funs)
|
|
(flet ((conv-form (x) (conv-shader-form x vars funs)))
|
|
(etypecase form
|
|
(cons
|
|
(let* ((sym (car form))
|
|
(args (cdr form))
|
|
(infix-op (assoc sym *infix-ops*))
|
|
(swizzle (swizzlep sym)))
|
|
(cond
|
|
(infix-op
|
|
;; special case for -, which is also a unary op
|
|
(if (and (eq sym '-) (= (length args) 1))
|
|
(format nil "(-~A)"
|
|
(conv-form (first args)))
|
|
(progn
|
|
(unless (or (= (length args) 2) (and (nth 2 infix-op) (> (length args) 2)))
|
|
(error "Invalid # of args for shader infix-op: ~S" infix-op))
|
|
;; don't wanna repeat this a bajillion times, so just splice the
|
|
;; GLSL version of the operator into the format control string
|
|
(format nil (concatenate 'string "(~{~A~^ " (nth 1 infix-op) " ~})")
|
|
(loop for x in args collect (conv-form x))))))
|
|
;; the unary operators ! and ~
|
|
((member sym '(not lognot))
|
|
(unless (= (length args) 1)
|
|
(error "Invalid # of args for shader unary-op: ~S" sym))
|
|
(format nil (if (eq sym 'not) "(!~A)" "(~~~A)")
|
|
(conv-form (first args))))
|
|
;; hijack the (exprA, exprB, ...) to allow multi-setf
|
|
((eq sym 'setf)
|
|
(unless (= (mod (length args) 2) 0)
|
|
(error "Invalid # of args for shader setf"))
|
|
(format nil "(~{~A = ~A~^, ~})"
|
|
(loop for x in args collect (conv-form x))))
|
|
((eq sym 'nth)
|
|
(unless (= (length args) 2)
|
|
(error "Invalid # of args for shader nth"))
|
|
(format nil "~A[~A]"
|
|
(conv-form (second args))
|
|
(conv-form (first args))))
|
|
((eq sym 'aref)
|
|
(unless (>= (length args) 2)
|
|
(error "Invalid # of args for shader aref"))
|
|
(format nil "~A~{[~A]~}"
|
|
(conv-form (first args))
|
|
(loop for x in (rest args) collect (conv-form x))))
|
|
;; non-statement (if) is the ternary operator
|
|
((eq sym 'if)
|
|
(unless (= (length args) 3)
|
|
(error "Invalid # of args for shader if"))
|
|
(format nil "(~A ? ~A : ~A)"
|
|
(conv-form (first args))
|
|
(conv-form (second args))
|
|
(conv-form (third args))))
|
|
;; WHY IS THIS A FUNCTION HISS
|
|
((eq sym 'length)
|
|
(unless (= (length args) 1)
|
|
(error "Invalid # of args for shader length"))
|
|
(format nil "~A.length()"
|
|
(conv-form (first args))))
|
|
;; apparently you can do this, (exprA, exprB) is non-statement progn
|
|
;; thanks C
|
|
((eq sym 'progn)
|
|
(unless (>= (length args) 1)
|
|
(error "Invalid # of args for shader progn"))
|
|
(format nil "(~{~A~^, ~})"
|
|
(loop for x in args collect (conv-form x))))
|
|
(swizzle
|
|
(unless (= (length args) 1)
|
|
(error "Invalid # of args for shader swizzle"))
|
|
(format nil "~A.~A"
|
|
(conv-form (first args))
|
|
swizzle))
|
|
(t
|
|
(format nil "~A(~{~A~^, ~})"
|
|
(or (cdr (assoc sym funs)) (error "Invalid shader fun: ~S" sym))
|
|
(loop for x in args collect (conv-form x)))))))
|
|
(boolean (if form "true" "false"))
|
|
(symbol (or (cdr (assoc form vars)) (error "Invalid shader var: ~S" form)))
|
|
(integer (format nil "~D" form))
|
|
(float (format nil "~F" form)))))
|
|
|
|
(defun conv-shader-stmt (stmt vars funs returnp)
|
|
(labels ((conv-form (x) (conv-shader-form x vars funs))
|
|
(conv-stmt (x r) (conv-shader-stmt x vars funs r))
|
|
(loop-conv-stmts (list r)
|
|
(loop for x on list
|
|
collect (conv-stmt (car x) (and r (not (cdr x)))))))
|
|
(let* ((sym (when (consp stmt) (car stmt)))
|
|
(args (when (consp stmt) (cdr stmt))))
|
|
(case sym
|
|
((progn)
|
|
(format nil "{~%~{~A~}}~%"
|
|
(loop-conv-stmts args returnp)))
|
|
((if)
|
|
(unless (<= 2 (length args) 3)
|
|
(error "Invalid # of args for shader if"))
|
|
(format nil "if (~A) ~{~%~A~^else~}"
|
|
(conv-form (first args))
|
|
(loop-conv-stmts (rest args) returnp)))
|
|
;; handle both forms in one case clause
|
|
((when unless)
|
|
(unless (>= (length args) 2)
|
|
(error "Invalid # of args for shader when/unless"))
|
|
(format nil "if (~:[~;!(~]~A~2:*~:[~;)~]~1*) {~%~{~A~}}~%"
|
|
(eq sym 'unless)
|
|
(conv-form (first args))
|
|
(loop-conv-stmts (rest args) returnp)))
|
|
((cond)
|
|
(unless (>= (length args) 1)
|
|
(error "Invalid # of args for shader cond"))
|
|
(format nil "~{~:[if (~A) ~;~1*~]{~%~{~A~}}~^ else ~}~%"
|
|
(loop for clause in args
|
|
nconc (list (eq (first clause) t)
|
|
(conv-form (first clause))
|
|
(loop-conv-stmts (rest clause) returnp)))))
|
|
((case)
|
|
(unless (>= (length args) 2)
|
|
(error "Invalid # of args for shader case"))
|
|
(format nil "switch (~A) {~%~{~:[~{case ~A:~%~}~;default:~%~1*~]~{~A~}break;~%~}}~%"
|
|
(conv-form (first args))
|
|
(loop for clause in (rest args)
|
|
nconc (list (eq (car clause) t)
|
|
(if (listp (car clause))
|
|
(loop for x in (car clause) collect (conv-form x))
|
|
(list (conv-form (car clause))))
|
|
(loop-conv-stmts (cdr clause) returnp)))))
|
|
((return)
|
|
(unless (<= 0 (length args) 1)
|
|
(error "Invalid # of args for shader return"))
|
|
(format nil "return~:[~; ~A~];~%"
|
|
args
|
|
(and args (conv-form (first args)))))
|
|
((break continue discard)
|
|
(when args
|
|
(error "Invalid # of args for shader break"))
|
|
(format nil "~(~A~);~%" sym))
|
|
((while)
|
|
(unless (>= (length args) 1)
|
|
(error "Invalid # of args for shader while"))
|
|
(format nil "while (~A) {~%~{~A~}}~%"
|
|
(conv-form (first args))
|
|
(loop-conv-stmts (rest args) returnp)))
|
|
((dotimes)
|
|
(unless (and (>= (length args) 1) (= (length (first args)) 2))
|
|
(error "Invalid # of args for shader dotimes"))
|
|
(let ((new-vars (cons (cons (caar args) (conv-shader-var (caar args) t)) vars)))
|
|
(format nil "for (int ~A = 0; ~1:*~A < ~A; ~2:*~A++~1*) {~%~{~A~}}~%"
|
|
(conv-shader-form (caar args) new-vars funs)
|
|
(conv-shader-form (cadar args) new-vars funs)
|
|
(loop for x on (cdr args)
|
|
collect (conv-shader-stmt (car x) new-vars funs
|
|
(and returnp (not (cdr x))))))))
|
|
((for)
|
|
(unless (and (>= (length args) 1) (= (length (first args)) 3))
|
|
(error "Invalid # of args for shader for"))
|
|
(format nil "for (~A;~A;~A) {~%~{~A~}}~%"
|
|
(conv-form (caar args))
|
|
(conv-form (cadar args))
|
|
(conv-form (caddar args))
|
|
(loop-conv-stmts (cdr args) returnp)))
|
|
((let let*)
|
|
(unless (>= (length args) 1)
|
|
(error "Invalid # of args for shader let"))
|
|
(let ((new-vars (nconc (loop for decl in (first args)
|
|
if (consp (car decl))
|
|
collect (cons (caar decl) (conv-shader-var (caar decl) t))
|
|
else
|
|
collect (cons (car decl) (conv-shader-var (car decl) t)))
|
|
vars)))
|
|
(format nil "{~%~{~A ~A~:[~; = ~A~];~%~}~{~A~}}~%"
|
|
(loop for decl in (first args)
|
|
if (consp (car decl))
|
|
nconc (list
|
|
(conv-shader-type (cadar decl))
|
|
(conv-shader-form (caar decl) new-vars funs)
|
|
t (conv-shader-form (cadr decl) new-vars funs))
|
|
else
|
|
nconc (list
|
|
(conv-shader-type (cadr decl))
|
|
(conv-shader-form (car decl) new-vars funs)
|
|
nil))
|
|
(loop for x on (rest args)
|
|
collect (conv-shader-stmt (car x) new-vars funs
|
|
(and returnp (not (cdr x))))))))
|
|
((setf)
|
|
(unless (= (mod (length args) 2) 0)
|
|
(error "Invalid # of args for shader setf"))
|
|
(format nil "~{~A = ~A;~%~}"
|
|
(loop for x in args collect (conv-form x))))
|
|
(t
|
|
(format nil "~:[~;return ~]~A;~%" returnp (conv-form stmt)))))))
|
|
|
|
(defun conv-shader-fun (name return-type params body vars funs)
|
|
(let ((new-vars (nconc (loop for decl in params
|
|
collect (cons (car decl) (conv-shader-var (car decl))))
|
|
vars)))
|
|
(format nil "~A ~A(~{~A ~A~^, ~}) {~%~{~A~}}"
|
|
(conv-shader-type return-type) name
|
|
(loop for decl in params
|
|
nconc (list (conv-shader-type (cadr decl))
|
|
(conv-shader-form (car decl) new-vars funs)))
|
|
(loop for x on body
|
|
collect (conv-shader-stmt (car x) new-vars funs
|
|
(not (or (cdr x) (eq return-type :void))))))))
|
|
|
|
(defun conv-shader-io
|
|
(mode name &key type
|
|
(location nil)
|
|
(component nil)
|
|
(binding nil)
|
|
(top-left-origin-p nil)
|
|
(pixel-coords-p nil)
|
|
&allow-other-keys)
|
|
(format nil "~:[~;~1:*layout(~{~A~^, ~}) ~]~(~A~) ~A ~A;~%"
|
|
(loop for val in (list location component binding top-left-origin-p pixel-coords-p)
|
|
for key in (list "location" "component" "binding" "origin_upper_left" "pixel_center_integer")
|
|
if (eq val t)
|
|
collect key
|
|
else if val
|
|
collect (format nil "~A=~D" key val))
|
|
mode (conv-shader-type type) (conv-shader-var name)))
|
|
|
|
(defun conv-shader-part (name part version in-vars out-vars uniform-vars funs)
|
|
(apply #'concatenate 'string
|
|
(format nil "#version ~D core~%// GLSL-ified Lisp shader: ~S~S~%" version name part)
|
|
(nconc
|
|
(loop for var in in-vars
|
|
collect (apply #'conv-shader-io :in var))
|
|
(loop for var in out-vars
|
|
collect (apply #'conv-shader-io :out var))
|
|
(loop for var in uniform-vars
|
|
collect (apply #'conv-shader-io :uniform var))
|
|
funs)))
|
|
|
|
(defun transpile-shader (name &key
|
|
version
|
|
((:in vert-inputs))
|
|
((:inter inter-vars))
|
|
((:out frag-outputs))
|
|
((:uniform uniform-vars))
|
|
((:vert vert-body))
|
|
((:frag frag-body)))
|
|
"Translate Lisp shader code to GLSL."
|
|
;; create implicit inter vars
|
|
(replace-xref-vars frag-body vert-inputs
|
|
(lambda (var-entry)
|
|
(let* ((orig-var (car var-entry))
|
|
(inter-var-entry (find orig-var inter-vars
|
|
:key (lambda (e) (getf (cdr e) :orig-var)))))
|
|
(if inter-var-entry
|
|
(car inter-var-entry)
|
|
(let ((new-var (gensym (symbol-name orig-var))))
|
|
(push `(,new-var :orig-var ,orig-var :type ,(getf (cdr var-entry) :type))
|
|
inter-vars)
|
|
(push `(setf ,new-var ,orig-var) vert-body)
|
|
new-var)))))
|
|
(let* ((vert-vars (nconc (loop for var-entry in (append inter-vars vert-inputs uniform-vars)
|
|
collect (cons (car var-entry) (conv-shader-var (car var-entry))))
|
|
*vert-builtins*))
|
|
(frag-vars (nconc (loop for var-entry in (append frag-outputs inter-vars uniform-vars)
|
|
collect (cons (car var-entry) (conv-shader-var (car var-entry))))
|
|
*frag-builtins*))
|
|
(vert-uniforms ()) (frag-uniforms ())
|
|
vert-glsl frag-glsl)
|
|
(replace-xref-vars vert-body uniform-vars
|
|
(lambda (var-entry)
|
|
(pushnew var-entry vert-uniforms)
|
|
(car var-entry)))
|
|
(replace-xref-vars frag-body uniform-vars
|
|
(lambda (var-entry)
|
|
(pushnew var-entry frag-uniforms)
|
|
(car var-entry)))
|
|
(setf vert-glsl
|
|
(conv-shader-part name :vert version
|
|
vert-inputs inter-vars vert-uniforms
|
|
(list (conv-shader-fun "main" :void () vert-body vert-vars *shader-funs*)))
|
|
frag-glsl
|
|
(conv-shader-part name :frag version
|
|
inter-vars frag-outputs frag-uniforms
|
|
(list (conv-shader-fun "main" :void () frag-body frag-vars *shader-funs*))))
|
|
`(:vert ,vert-glsl :frag ,frag-glsl
|
|
(:in ,vert-inputs :inter ,inter-vars :out ,frag-outputs :uniform ,uniform-vars
|
|
:version ,version :vert ,vert-body :frag ,frag-body))))
|
|
|
|
|
|
(defmacro define-shader (name (&key
|
|
((:in (&rest vert-inputs)) ())
|
|
((:inter (&rest inter-vars)) ())
|
|
((:out (&rest frag-outputs)) ())
|
|
((:uniform (&rest uniform-vars)) ()))
|
|
&key
|
|
((:vert (&body vert-body)))
|
|
((:frag (&body frag-body)))
|
|
version)
|
|
"Define a GLSL shader with Lisp code."
|
|
`(defparameter ,name (transpile-shader ',name
|
|
:version ,version
|
|
:in ',vert-inputs
|
|
:inter ',inter-vars
|
|
:out ',frag-outputs
|
|
:uniform ',uniform-vars
|
|
:vert ',vert-body :frag ',frag-body)))
|