Lisp-to-GLSL translation works!

wh-engine/render/shader.lisp

@@ -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")
+                  (:bool . "bool")
-                  (:integer . "int")
+                  (:int . "int")
-                  (:unsigned-integer . "uint")
+                  (:uint . "uint")
                   (:float . "float")
                   (:double . "double")
                   (:vec2 . "vec2")
@@ -79,15 +71,15 @@
                   (:double-vec2 . "dvec2")
                   (:double-vec3 . "dvec3")
                   (: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")
                   (: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)
+(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
       (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)
+(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 for x on list
                    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
         ((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*)
+        ((let let*)
-             (conv-stmt `(progn
+         (unless (>= (length args) 1)
-                           ,@(loop for x in (first args)
+           (error "Invalid # of args for shader let"))
-                                   if (consp (car x))
+         (let ((new-vars (nconc (loop for decl in (first args)
-                                     collect `(declare-var ,@x)
+                                      if (consp (car decl))
+                                        collect (cons (caar decl) (conv-shader-var (caar decl) t))
                                       else
-                                     collect `(declare-var ,x))
+                                        collect (cons (car decl) (conv-shader-var (car decl) t)))
-                           ,@(rest args))
+                                vars)))
-                        returnp))
+           (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)))))
+         (format nil "~:[~;return ~]~A;~%" returnp (conv-form stmt)))))))
-        ;; something else
+
-        (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
+  (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
                                  ((:in (&rest vert-inputs)) ())