Lisp-to-GLSL translation works!
This commit is contained in:
parent
d44935fb14
commit
079990422d
GPG key ID:
5BEBEEAB2C73D520
1 changed files with 294 additions and 142 deletions
|
|
@ -12,14 +12,6 @@
|
|||
else if (consp form)
|
||||
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")
|
||||
(*instance-id* . "gl_InstanceID")
|
||||
(*draw-id* . "gl_DrawID")
|
||||
|
|
@ -68,9 +60,9 @@
|
|||
(or "||" t)))
|
||||
|
||||
(defvar *types* '((:void . "void")
|
||||
(:boolean . "bool")
|
||||
(:integer . "int")
|
||||
(:unsigned-integer . "uint")
|
||||
(:bool . "bool")
|
||||
(:int . "int")
|
||||
(:uint . "uint")
|
||||
(:float . "float")
|
||||
(:double . "double")
|
||||
(:vec2 . "vec2")
|
||||
|
|
@ -79,15 +71,15 @@
|
|||
(:double-vec2 . "dvec2")
|
||||
(:double-vec3 . "dvec3")
|
||||
(:double-vec4 . "dvec4")
|
||||
(:boolean-vec2 . "bvec2")
|
||||
(:boolean-vec3 . "bvec3")
|
||||
(:boolean-vec4 . "bvec4")
|
||||
(:integer-vec2 . "ivec2")
|
||||
(:integer-vec3 . "ivec3")
|
||||
(:integer-vec4 . "ivec4")
|
||||
(:unsigned-vec2 . "uvec2")
|
||||
(:unsigned-vec3 . "uvec3")
|
||||
(:unsigned-vec4 . "uvec4")
|
||||
(: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")
|
||||
|
|
@ -108,8 +100,75 @@
|
|||
(:depth-cube-sampler . "samplerCubeShadow")
|
||||
(:array-cube-sampler . "samplerCubeArray")
|
||||
(: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)
|
||||
(let ((sym-str (string-downcase (symbol-name sym))))
|
||||
|
|
@ -118,8 +177,21 @@
|
|||
always (member c '(#\x #\y #\z #\w) :test #'char=))
|
||||
(subseq sym-str 1))))
|
||||
|
||||
(defun conv-shader-form (form funs vars)
|
||||
(flet ((conv-form (x) (conv-shader-form x funs vars)))
|
||||
(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))
|
||||
|
|
@ -190,15 +262,6 @@
|
|||
(format nil "~A.~A"
|
||||
(conv-form (first args))
|
||||
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
|
||||
(format nil "~A(~{~A~^, ~})"
|
||||
(or (cdr (assoc sym funs)) (error "Invalid shader fun: ~S" sym))
|
||||
|
|
@ -208,15 +271,14 @@
|
|||
(integer (format nil "~D" form))
|
||||
(float (format nil "~F" form)))))
|
||||
|
||||
(defun conv-shader-stmt (stmt funs vars returnp)
|
||||
(labels ((conv-form (x) (conv-shader-form x funs vars))
|
||||
(conv-stmt (x r) (conv-shader-stmt x funs vars r))
|
||||
(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)))))))
|
||||
(if (consp stmt)
|
||||
(let* ((sym (car stmt))
|
||||
(args (cdr stmt)))
|
||||
(let* ((sym (when (consp stmt) (car stmt)))
|
||||
(args (when (consp stmt) (cdr stmt))))
|
||||
(case sym
|
||||
((progn)
|
||||
(format nil "{~%~{~A~}}~%"
|
||||
|
|
@ -269,7 +331,17 @@
|
|||
(error "Invalid # of args for shader while"))
|
||||
(format nil "while (~A) {~%~{~A~}}~%"
|
||||
(conv-form (first args))
|
||||
(loop-conv-stmts (rest 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"))
|
||||
|
|
@ -278,25 +350,79 @@
|
|||
(conv-form (cadar args))
|
||||
(conv-form (caddar args))
|
||||
(loop-conv-stmts (cdr args) returnp)))
|
||||
((let*)
|
||||
(conv-stmt `(progn
|
||||
,@(loop for x in (first args)
|
||||
if (consp (car x))
|
||||
collect `(declare-var ,@x)
|
||||
((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 `(declare-var ,x))
|
||||
,@(rest args))
|
||||
returnp))
|
||||
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)))))
|
||||
;; something else
|
||||
(format nil "~:[~;return ~]~A;~%" returnp (conv-form stmt)))
|
||||
))
|
||||
(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
|
||||
|
|
@ -320,8 +446,34 @@
|
|||
inter-vars)
|
||||
(push `(setf ,new-var ,orig-var) vert-body)
|
||||
new-var)))))
|
||||
`(:in ,vert-inputs :inter ,inter-vars :out ,frag-outputs :uniform ,uniform-vars
|
||||
:vert ,vert-body :frag ,frag-body))
|
||||
(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)) ())
|
||||
|
|
|
|||
Loading…
Reference in a new issue