keith/wh-engine
1
0
Fork 0
Code Issues 6 Pull requests Projects Releases Wiki Activity

Lisp-to-GLSL translation works!

Browse source
This commit is contained in:
~keith 2022-03-24 18:45:26 +00:00
parent d44935fb14
commit 079990422d
Signed by: keith
GPG key ID: 5BEBEEAB2C73D520
1 changed files with 294 additions and 142 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

436
wh-engine/render/shader.lisp
View file

@ -12,14 +12,6 @@
else if (consp form) else if (consp form)
do (replace-xref-vars (cdr form) vars replace-fun))) do (replace-xref-vars (cdr form) vars replace-fun)))
(defun collect-shader-vars (forms)
(loop for elt on forms
for form = (car elt)
if (symbolp form)
collect form
else if (consp form)
nconc (collect-shader-vars (cdr form))))
(defvar *vert-builtins* '((*vertex-id* . "gl_VertexID") (defvar *vert-builtins* '((*vertex-id* . "gl_VertexID")
(*instance-id* . "gl_InstanceID") (*instance-id* . "gl_InstanceID")
(*draw-id* . "gl_DrawID") (*draw-id* . "gl_DrawID")
@ -42,35 +34,35 @@
(*viewport-index* . "gl_ViewportIndex") (*viewport-index* . "gl_ViewportIndex")
;; out ;; out
(*frag-depth* . "gl_FragDepth") (*frag-depth* . "gl_FragDepth")
(*sample-mask* . "gl_SampleMask"))) (*sample-mask* . "gl_SampleMask")))
(defvar *infix-ops* '((+ "+" t) (defvar *infix-ops* '((+ "+" t)
(- "-" t) (- "-" t)
(* "*" t) (* "*" t)
(/ "/" t) (/ "/" t)
(mod "%" t) (mod "%" t)
(= "==" t) (= "==" t)
(eq "==" nil) (eq "==" nil)
(eql "==" nil) (eql "==" nil)
(equal "==" nil) (equal "==" nil)
(/= "!=" nil) (/= "!=" nil)
(< "<" t) (< "<" t)
(> ">" t) (> ">" t)
(<= "<=" t) (<= "<=" t)
(>= ">=" t) (>= ">=" t)
(<< "<<" nil) (<< "<<" nil)
(>> ">>" nil) (>> ">>" nil)
(ash "<<" nil) (ash "<<" nil)
(logand "&" t) (logand "&" t)
(logior "|" t) (logior "|" t)
(logxor "^" t) (logxor "^" t)
(and "&&" t) (and "&&" t)
(or "||" t))) (or "||" t)))
(defvar *types* '((:void . "void") (defvar *types* '((:void . "void")
(:boolean . "bool") (:bool . "bool")
(:integer . "int") (:int . "int")
(:unsigned-integer . "uint") (:uint . "uint")
(:float . "float") (:float . "float")
(:double . "double") (:double . "double")
(:vec2 . "vec2") (:vec2 . "vec2")
@ -79,15 +71,15 @@
(:double-vec2 . "dvec2") (:double-vec2 . "dvec2")
(:double-vec3 . "dvec3") (:double-vec3 . "dvec3")
(:double-vec4 . "dvec4") (:double-vec4 . "dvec4")
(:boolean-vec2 . "bvec2") (:bool-vec2 . "bvec2")
(:boolean-vec3 . "bvec3") (:bool-vec3 . "bvec3")
(:boolean-vec4 . "bvec4") (:bool-vec4 . "bvec4")
(:integer-vec2 . "ivec2") (:int-vec2 . "ivec2")
(:integer-vec3 . "ivec3") (:int-vec3 . "ivec3")
(:integer-vec4 . "ivec4") (:int-vec4 . "ivec4")
(:unsigned-vec2 . "uvec2") (:uint-vec2 . "uvec2")
(:unsigned-vec3 . "uvec3") (:uint-vec3 . "uvec3")
(:unsigned-vec4 . "uvec4") (:uint-vec4 . "uvec4")
(:mat2 . "mat2") (:mat2 . "mat2")
(:mat3 . "mat3") (:mat3 . "mat3")
(:mat4 . "mat4") (:mat4 . "mat4")
@ -108,8 +100,75 @@
(:depth-cube-sampler . "samplerCubeShadow") (:depth-cube-sampler . "samplerCubeShadow")
(:array-cube-sampler . "samplerCubeArray") (:array-cube-sampler . "samplerCubeArray")
(:depth-array-cube-sampler . "samplerCubeArrayShadow") (:depth-array-cube-sampler . "samplerCubeArrayShadow")
(:buffer-sampler . "samplerBuffer") (: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) (defun swizzlep (sym)
(let ((sym-str (string-downcase (symbol-name sym)))) (let ((sym-str (string-downcase (symbol-name sym))))
@ -118,8 +177,21 @@
always (member c '(#\x #\y #\z #\w) :test #'char=)) always (member c '(#\x #\y #\z #\w) :test #'char=))
(subseq sym-str 1)))) (subseq sym-str 1))))
(defun conv-shader-form (form funs vars) (defun conv-shader-type (type)
(flet ((conv-form (x) (conv-shader-form x funs vars))) (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 (etypecase form
(cons (cons
(let* ((sym (car form)) (let* ((sym (car form))
@ -190,15 +262,6 @@
(format nil "~A.~A" (format nil "~A.~A"
(conv-form (first args)) (conv-form (first args))
swizzle)) swizzle))
;; need this for (for)
((eq sym 'declare-var)
(unless (and (<= 1 (length args) 2) (= (length (first args)) 2))
(error "Invalid # of args for shader declare-var"))
(format nil "~A ~A~:[~; = ~A~]"
(or (cdr (assoc (cadar args) *types*)) (error "Invalid type specifier: ~S" (second args)))
(conv-form (caar args))
(= (length args) 2)
(conv-form (second args))))
(t (t
(format nil "~A(~{~A~^, ~})" (format nil "~A(~{~A~^, ~})"
(or (cdr (assoc sym funs)) (error "Invalid shader fun: ~S" sym)) (or (cdr (assoc sym funs)) (error "Invalid shader fun: ~S" sym))
@ -208,95 +271,158 @@
(integer (format nil "~D" form)) (integer (format nil "~D" form))
(float (format nil "~F" form))))) (float (format nil "~F" form)))))
(defun conv-shader-stmt (stmt funs vars returnp) (defun conv-shader-stmt (stmt vars funs returnp)
(labels ((conv-form (x) (conv-shader-form x funs vars)) (labels ((conv-form (x) (conv-shader-form x vars funs))
(conv-stmt (x r) (conv-shader-stmt x funs vars r)) (conv-stmt (x r) (conv-shader-stmt x vars funs r))
(loop-conv-stmts (list r) (loop-conv-stmts (list r)
(loop for x on list (loop for x on list
collect (conv-stmt (car x) (and r (not (cdr x))))))) collect (conv-stmt (car x) (and r (not (cdr x)))))))
(if (consp stmt) (let* ((sym (when (consp stmt) (car stmt)))
(let* ((sym (car stmt)) (args (when (consp stmt) (cdr stmt))))
(args (cdr stmt))) (case sym
(case sym ((progn)
((progn) (format nil "{~%~{~A~}}~%"
(format nil "{~%~{~A~}}~%" (loop-conv-stmts args returnp)))
(loop-conv-stmts args returnp))) ((if)
((if) (unless (<= 2 (length args) 3)
(unless (<= 2 (length args) 3) (error "Invalid # of args for shader if"))
(error "Invalid # of args for shader if")) (format nil "if (~A) ~{~%~A~^else~}"
(format nil "if (~A) ~{~%~A~^else~}" (conv-form (first args))
(conv-form (first args)) (loop-conv-stmts (rest args) returnp)))
(loop-conv-stmts (rest args) returnp))) ;; handle both forms in one case clause
;; handle both forms in one case clause ((when unless)
((when unless) (unless (>= (length args) 2)
(unless (>= (length args) 2) (error "Invalid # of args for shader when/unless"))
(error "Invalid # of args for shader when/unless")) (format nil "if (~:[~;!(~]~A~2:*~:[~;)~]~1*) {~%~{~A~}}~%"
(format nil "if (~:[~;!(~]~A~2:*~:[~;)~]~1*) {~%~{~A~}}~%" (eq sym 'unless)
(eq sym 'unless) (conv-form (first args))
(conv-form (first args)) (loop-conv-stmts (rest args) returnp)))
(loop-conv-stmts (rest args) returnp))) ((cond)
((cond) (unless (>= (length args) 1)
(unless (>= (length args) 1) (error "Invalid # of args for shader cond"))
(error "Invalid # of args for shader cond")) (format nil "~{~:[if (~A) ~;~1*~]{~%~{~A~}}~^ else ~}~%"
(format nil "~{~:[if (~A) ~;~1*~]{~%~{~A~}}~^ else ~}~%" (loop for clause in args
(loop for clause in args nconc (list (eq (first clause) t)
nconc (list (eq (first clause) t) (conv-form (first clause))
(conv-form (first clause)) (loop-conv-stmts (rest clause) returnp)))))
(loop-conv-stmts (rest clause) returnp))))) ((case)
((case) (unless (>= (length args) 2)
(unless (>= (length args) 2) (error "Invalid # of args for shader case"))
(error "Invalid # of args for shader case")) (format nil "switch (~A) {~%~{~:[~{case ~A:~%~}~;default:~%~1*~]~{~A~}break;~%~}}~%"
(format nil "switch (~A) {~%~{~:[~{case ~A:~%~}~;default:~%~1*~]~{~A~}break;~%~}}~%" (conv-form (first args))
(conv-form (first args)) (loop for clause in (rest args)
(loop for clause in (rest args) nconc (list (eq (car clause) t)
nconc (list (eq (car clause) t) (if (listp (car clause))
(if (listp (car clause)) (loop for x in (car clause) collect (conv-form x))
(loop for x in (car clause) collect (conv-form x)) (list (conv-form (car clause))))
(list (conv-form (car clause)))) (loop-conv-stmts (cdr clause) returnp)))))
(loop-conv-stmts (cdr clause) returnp))))) ((return)
((return) (unless (<= 0 (length args) 1)
(unless (<= 0 (length args) 1) (error "Invalid # of args for shader return"))
(error "Invalid # of args for shader return")) (format nil "return~:[~; ~A~];~%"
(format nil "return~:[~; ~A~];~%" args
args (and args (conv-form (first args)))))
(and args (conv-form (first args))))) ((break continue discard)
((break continue discard) (when args
(when args (error "Invalid # of args for shader break"))
(error "Invalid # of args for shader break")) (format nil "~(~A~);~%" sym))
(format nil "~(~A~);~%" sym)) ((while)
((while) (unless (>= (length args) 1)
(unless (>= (length args) 1) (error "Invalid # of args for shader while"))
(error "Invalid # of args for shader while")) (format nil "while (~A) {~%~{~A~}}~%"
(format nil "while (~A) {~%~{~A~}}~%" (conv-form (first args))
(conv-form (first args)) (loop-conv-stmts (rest args) returnp)))
(loop-conv-stmts (rest args)))) ((dotimes)
((for) (unless (and (>= (length args) 1) (= (length (first args)) 2))
(unless (and (>= (length args) 1) (= (length (first args)) 3)) (error "Invalid # of args for shader dotimes"))
(error "Invalid # of args for shader for")) (let ((new-vars (cons (cons (caar args) (conv-shader-var (caar args) t)) vars)))
(format nil "for (~A;~A;~A) {~%~{~A~}}~%" (format nil "for (int ~A = 0; ~1:*~A < ~A; ~2:*~A++~1*) {~%~{~A~}}~%"
(conv-form (caar args)) (conv-shader-form (caar args) new-vars funs)
(conv-form (cadar args)) (conv-shader-form (cadar args) new-vars funs)
(conv-form (caddar args)) (loop for x on (cdr args)
(loop-conv-stmts (cdr args) returnp))) collect (conv-shader-stmt (car x) new-vars funs
((let*) (and returnp (not (cdr x))))))))
(conv-stmt `(progn ((for)
,@(loop for x in (first args) (unless (and (>= (length args) 1) (= (length (first args)) 3))
if (consp (car x)) (error "Invalid # of args for shader for"))
collect `(declare-var ,@x) (format nil "for (~A;~A;~A) {~%~{~A~}}~%"
else (conv-form (caar args))
collect `(declare-var ,x)) (conv-form (cadar args))
,@(rest args)) (conv-form (caddar args))
returnp)) (loop-conv-stmts (cdr args) returnp)))
((setf) ((let let*)
(unless (= (mod (length args) 2) 0) (unless (>= (length args) 1)
(error "Invalid # of args for shader setf")) (error "Invalid # of args for shader let"))
(format nil "~{~A = ~A;~%~}" (let ((new-vars (nconc (loop for decl in (first args)
(loop for x in args collect (conv-form x)))) if (consp (car decl))
(t collect (cons (caar decl) (conv-shader-var (caar decl) t))
(format nil "~:[~;return ~]~A;~%" returnp (conv-form stmt))))) else
;; something else collect (cons (car decl) (conv-shader-var (car decl) t)))
(format nil "~:[~;return ~]~A;~%" returnp (conv-form stmt))) 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 (defun transpile-shader (name &key
version version
@ -320,8 +446,34 @@
inter-vars) inter-vars)
(push `(setf ,new-var ,orig-var) vert-body) (push `(setf ,new-var ,orig-var) vert-body)
new-var))))) new-var)))))
`(:in ,vert-inputs :inter ,inter-vars :out ,frag-outputs :uniform ,uniform-vars (let* ((vert-vars (nconc (loop for var-entry in (append inter-vars vert-inputs uniform-vars)
:vert ,vert-body :frag ,frag-body)) 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 (defmacro define-shader (name (&key
((:in (&rest vert-inputs)) ()) ((:in (&rest vert-inputs)) ())