wh-engine/wh-engine/render/shader.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)))

(defparameter *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")))

(defparameter *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")))

(defparameter *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)))

(defparameter *types* '((:void . "void")
                        (:bool . "bool")
                        (:int . "int")
                        (:uint . "uint")
                        (:float . "float")
                        (:vec2 . "vec2")
                        (:vec3 . "vec3")
                        (:vec4 . "vec4")
                        (: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")))

(defparameter *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))))

;; Shader class
(defclass shader ()
  ((name :documentation "The symbol naming this shader."
         :type symbol
         :initarg :name)
   (program :documentation "The GL program associated with this shader."
            :type fixnum
            :initarg :program)
   (vertex-array :documentation "The GL vertex array associated with this shader."
                 :type fixnum
                 :initarg :vertex-array)
   (vertex-buffers :documentation "List of GL vertex buffers associated with this shader.
(handle gl-array stride current-idx)"
                   :type list
                   :initarg :vertex-buffers
                   :initform nil)
   (vertex-props :documentation "Alist of vertex property metadata.
(name handle type buffer-idx offset)"
                 :type list
                 :initarg :vertex-props)
   (uniform-props :documentation "Alist of uniform property metadata.
(name handle type)"
                  :type list
                  :initarg :uniform-props)
   (num-vertices :documentation "Number of vertices waiting to be drawn."
                 :type fixnum
                 :initform 0)
   (max-vertices :documentation "Maximum number of vertices that can be drawn at a time."
                 :type fixnum
                 :initarg :max-vertices
                 :initform 64)
   (options :documentation "Shader options."
            :type list
            :initarg :options)
   (mode :documentation "Shader mode. One of (:LINES :TRIANGLES :QUADS)"
         :type (or symbol null)
         :initform nil)
   (transpilation :documentation "Raw transpilation data for shaders which have not been initialized yet."
                  :type (or list null)
                  :initarg :transpilation
                  :initform nil)))

(defun make-glsl-program (code-plist)
  (let ((program (gl:create-program)))
    (loop for (stage code) on code-plist by #'cddr
          do (let ((s (gl:create-shader (ecase stage
                                          (:vert :vertex-shader)
                                          (:frag :fragment-shader)))))
               (gl:shader-source s code)
               (gl:compile-shader s)
               (unless (gl:get-shader s :compile-status)
                 (error (gl:get-shader-info-log s)))
               (gl:attach-shader program s)))
    (gl:link-program program)
    (unless (gl:get-program program :link-status)
      (error (gl:get-program-info-log program)))
    program))

(defun setup-vbo (type stride max-vertices props vbo-idx)
  "Create and configure a GL vertex buffer.
Returns: (VBO ARR)"
  (let* ((vbo (gl:gen-buffer))
         (arr (gl:alloc-gl-array type (* stride max-vertices)))
         (elt-size (gl::foreign-type-size (gl::gl-array-type arr))))
    (gl:bind-buffer :array-buffer vbo)
    (gl:buffer-data :array-buffer :dynamic-draw arr)
    (loop for p in props
          ;; (name handle type vbo-idx offset)
          when (eq (fourth p) type)
            do (setf (fourth p) vbo-idx)
               (gl:enable-vertex-attrib-array (second p))
               (gl:vertex-attrib-pointer (second p)
                                         (case (third p)
                                           (:vec2 2)
                                           (:vec3 3)
                                           (:vec4 4)
                                           (t 1))
                                         type nil
                                         (* elt-size stride) (* elt-size (fifth p))))
    (gl:bind-buffer :array-buffer 0)
    (values vbo arr)))

(defmethod ensure-initialized ((shader shader))
  (when #[shader :slot transpilation]
    (let ((code (butlast #[shader :slot transpilation]))
          (vars (car (last #[shader :slot transpilation]))))
      (setf #[shader :slot transpilation] nil)
      (setf #[shader :slot program] (make-glsl-program code))
      ;; create VAO
      (setf #[shader :slot vertex-array] (gl:gen-vertex-array))
      (gl:bind-vertex-array #[shader :slot vertex-array])
      ;; create VBOs for vertex properties
      (loop for (prop-name . prop-plist) in (getf vars :in)
            for prop-type = (getf prop-plist :type)
            for prop-loc = (or (getf prop-plist :location)
                               (gl:get-attrib-location #[shader :slot program] (conv-shader-var prop-name)))
            with float-idx = 0 and int-idx = 0 and uint-idx = 0

            if (member prop-type '(:float :vec2 :vec3 :vec4))
              collect (list prop-name prop-loc prop-type :float float-idx) into props
              and do (incf float-idx (1+ (position prop-type '(:float :vec2 :vec3 :vec4))))
            else if (member prop-type '(:int :bool))
                   collect (list prop-name prop-loc prop-type :int int-idx) into props
                   and do (incf int-idx)
            else
              collect (list prop-name prop-loc prop-type :unsigned-int uint-idx) into props
              and do (incf uint-idx)

            finally
               (setf #[shader :slot vertex-props] props)
               (let ((vbo-idx 0))
                 (when (> float-idx 0)
                   (multiple-value-bind (vbo arr)
                       (setup-vbo :float float-idx #[shader :slot max-vertices] #[shader :slot vertex-props] vbo-idx)
                     (setf #[shader :slot vertex-buffers]
                           (nconc #[shader :slot vertex-buffers]
                                  `((,vbo ,arr ,float-idx 0))))
                     (incf vbo-idx)))
                 (when (> int-idx 0)
                   (multiple-value-bind (vbo arr)
                       (setup-vbo :int int-idx #[shader :slot max-vertices] #[shader :slot vertex-props] vbo-idx)
                     (setf #[shader :slot vertex-buffers]
                           (nconc #[shader :slot vertex-buffers]
                                  `((,vbo ,arr ,int-idx 0))))
                     (incf vbo-idx)))
                 (when (> uint-idx 0)
                   (multiple-value-bind (vbo arr)
                       (setup-vbo :unsigned-int uint-idx #[shader :slot max-vertices] #[shader :slot vertex-props] vbo-idx)
                     (setf #[shader :slot vertex-buffers]
                           (nconc #[shader :slot vertex-buffers]
                                  `((,vbo ,arr ,uint-idx 0))))))))
      (gl:bind-vertex-array 0)
      ;; uniform properties
      (setf #[shader :slot uniform-props]
            (loop for (prop-name . prop-plist) in (getf vars :uniform)
                  for prop-type = (getf prop-plist :type)
                  for prop-loc = (or (getf prop-plist :location)
                                     (gl:get-attrib-location #[shader :slot program] (conv-shader-var prop-name)))
                  collect (list prop-name prop-loc prop-type)))
      )))

(defmethod begin-draw ((shader shader) mode)
  (setf #[shader :slot mode] mode))

(defmethod end-draw ((shader shader))
  (when (> #[shader :slot num-vertices] 0)
    #[shader (flush-vertices)])
  (setf #[shader :slot mode] nil))

(defmethod uniform ((shader shader) name value)
  (let ((prop (assoc name #[shader :slot uniform-props])))
    (case (third prop)
      (:float (gl:uniformfv (second prop) value))
      ((:int :uint :bool) (gl:uniformiv (second prop) value))
      (:vec2 (gl:uniformf (second prop) (vx2 value) (vy2 value)))
      (:vec3 (gl:uniformf (second prop) (vx3 value) (vy3 value) (vz3 value)))
      (:vec4 (gl:uniformf (second prop) (vx4 value) (vy4 value) (vz4 value) (vw4 value)))
      (:mat2 (gl:uniform-matrix-2fv (second prop) (vector (marr2 value))))
      (:mat3 (gl:uniform-matrix-3fv (second prop) (vector (marr3 value))))
      (:mat4 (gl:uniform-matrix-4fv (second prop) (vector (marr4 value)))))))

(defmethod vertex ((shader shader) &rest rest)
  (declare (optimize (speed 3)))
  ;; apply values
  (loop for (name value) on rest by #'cddr
        for prop = (assoc name #[shader :slot vertex-props])
        for type = (third prop)
        for buf = (nth (fourth prop) #[shader :slot vertex-buffers])
        for array = (second buf)
        for idx = (+ (fourth buf) (fifth prop))

        if (eq type :vec2)
          do (setf (gl:glaref array idx) (vx2 value)
                   (gl:glaref array (+ idx 1)) (vy2 value))
        else if (eq type :vec3)
               do (setf (gl:glaref array idx) (vx3 value)
                        (gl:glaref array (+ idx 1)) (vy3 value)
                        (gl:glaref array (+ idx 2)) (vz3 value))
        else if (eq type :vec4)
               do (setf (gl:glaref array idx) (vx4 value)
                        (gl:glaref array (+ idx 1)) (vy4 value)
                        (gl:glaref array (+ idx 2)) (vz4 value)
                        (gl:glaref array (+ idx 3)) (vw4 value))
        else if (eq type :bool)
               do (setf (gl:glaref array idx) (if value 1 0))
        else
          do (setf (gl:glaref array idx) value))
  ;; increment counters
  (loop for buf in #[shader :slot vertex-buffers]
        do (incf (fourth buf) (third buf)))
  (incf #[shader :slot num-vertices])
  ;; flush
  (when (>= #[shader :slot num-vertices] #[shader :slot max-vertices])
    #[shader (flush-vertices)]))

(defmethod flush-vertices ((shader shader))
  (declare (optimize (speed 3)))
  (gl:use-program #[shader :slot program])
  (gl:bind-vertex-array #[shader :slot vertex-array])
  (gl:draw-arrays #[shader :slot mode] 0 #[shader :slot num-vertices])
  ;; reset counters
  (setf #[shader :slot num-vertices] 0)
  (loop for buf in #[shader :slot vertex-buffers]
        do (setf (fourth buf) 0)))

(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)))
       documentation
       version
       options)
  "Define a GLSL shader with Lisp code."
  `(defparameter ,name
     (make-instance 'shader
                    :name ',name
                    :options ',options
                    :transpilation
                    (transpile-shader ',name
                                      :version ,version
                                      :in ',vert-inputs
                                      :inter ',inter-vars
                                      :out ',frag-outputs
                                      :uniform ',uniform-vars
                                      :vert ',vert-body
                                      :frag ',frag-body))
     ,documentation))