From 079990422d4d426a0b510dd541068e8634bc7143 Mon Sep 17 00:00:00 2001
From: ~keith <keith@keithhacks.cyou>
Date: Thu, 24 Mar 2022 18:45:26 +0000
Subject: [PATCH] Lisp-to-GLSL translation works!

---
 wh-engine/render/shader.lisp | 436 +++++++++++++++++++++++------------
 1 file changed, 294 insertions(+), 142 deletions(-)

diff --git a/wh-engine/render/shader.lisp b/wh-engine/render/shader.lisp
index 7016d42..a3ade5a 100644
--- a/wh-engine/render/shader.lisp
+++ b/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")
@@ -42,35 +34,35 @@
                           (*viewport-index* . "gl_ViewportIndex")
                           ;; out
                           (*frag-depth* . "gl_FragDepth")
-                               (*sample-mask* . "gl_SampleMask")))
+                          (*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)
+                      (- "-" 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")
-                  (: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,95 +271,158 @@
       (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)))
-          (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))))
-            ((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*)
-             (conv-stmt `(progn
-                           ,@(loop for x in (first args)
-                                   if (consp (car x))
-                                     collect `(declare-var ,@x)
-                                   else
-                                     collect `(declare-var ,x))
-                           ,@(rest args))
-                        returnp))
-            ((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)))
-    ))
+    (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
@@ -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)) ())