stoe/src/render/shader/glsl.lisp

#|
  This file is a part of stoe project.
  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(in-package :cl-user)
(defpackage stoe.shader.glsl
  (:use :cl :utils :walker :shader)
  (:nicknames :glsl)
  (:export :glsl-compile :glsl-print))
(in-package :stoe.shader.glsl)

(defvar *form-handlers* (make-hash-table)
  "Hash table for the form handlers for a glsl dsl.")

(defvar *current-indent* 0
  "Keep the number of space needed for the next directive.")

(defvar *env* nil
  "A special variable used as a container for the macro environment.")

(defvar *verbose* nil
  "Configure the verbosity of the compiler.
if non-nil, the dsl will be printed in comments together with the glsl code.")

(defvar *version-profiles* '((1.3 . "#version 130
// #extension ARB_explicit_attrib_location : require")
                             (3.3 . "#version 330 core")
                             (4.4 . "#version 440 core")))

(defvar *glsl-symbols* '(:gl-position "gl_Position"
                         :gl-fragcoord "gl_FragCoord"
                         :gl-fragcolor "gl_FragColor")
  "Keep a table of reserved glsl symbols.")

(defun glsl-name (cl-name)
  "Convert a variable name in common-lisp convention to a glsl compliant name."
  (or (getf *glsl-symbols* (intern (symbol-name cl-name) :keyword))
      (string-downcase (substitute #\_ #\- (symbol-name cl-name)))))

(defmacro noop-handler (body)
  `(format nil "/* ~((~{~a~^ ~})~) */~%" ,body))

(defhandler (declare block return-from catch load-time-value
                     macrolet symbol-macrolet flet labels let*
                     eval-when defun lambda tagbody setq function
                     the go unwind-protect progv quote) (&rest body)
  "Handle the unsupported keywords. For the time being,
the forms comprised of these keywords will be printed in comments."
  (noop-handler body))

(defhandler newshader (newshader lambda-list &rest body)
  (declare (ignore newshader lambda-list))
  (walk-list body))

(defhandler (progn locally) (progn &rest body)
  "Handle the progn special form."
  (declare (ignore progn))
  (format nil "~{~a;~%~}" (walk-list body)))

(defhandler let (let bindings &rest body)
  "Handle the variables declaration special form."
  (declare (ignore let))
  (format nil "~{~a;~%~}~%~a"
          (loop for binding in bindings
             collect (format nil "~@[~vt~]~(~a~) ~a~@[ = ~a~]"
                             (when (> *current-indent* 0)
                               *current-indent*)
                             (second binding) (glsl-name (first binding))
                             (if (and (cddr binding)
                                      (not (cdddr binding)))
                                 (walk-1 (third binding))
                                 (walk-list (cddr binding)))))
          (format nil "~{~a~^;~%~}" (walk-list body))))

(defhandler setf (setf &rest pairs)
  "Handle the assignment special form."
  (declare (ignore setf))
  (let ((vars (loop for s in pairs by #'cddr collect s)))
    (let ((expanded (loop for n in vars
                       for r in (rest pairs) by #'cddr
                       collect (glsl-name n) collect (if (symbolp r)
                                                         (glsl-name r)
                                                         (walk-1 r)))))
      (format nil "~@[~vt~]~{~a = ~a~^;~%~}"
              (when (> *current-indent* 0)
                *current-indent*)
              expanded))))

(defhandler (+ - * / %) (op &rest body)
  "Handle the standard infix operations."
  (labels ((expand (a)
           (cond
             ((listp a) (format nil "(~a)" (walk-1 a)))
             ((symbolp a) (glsl-name a))
             (t a)))
         (oper (a b)
           (format nil "~a ~(~a~) ~a"
                   (expand a) op (expand b))))
    (reduce #'oper body)))

(defhandler (x y z w xy xz xw
               yz yw zw xyz yzw xyzw) (attribs &rest rest)
  "Handle swizzle."
  (let ((symbol (first rest)))
    (format nil "~a.~(~a~)"
            (if (symbolp symbol)
                (glsl-name symbol)
                (walk-list symbol))
            attribs)))

(defun default-handler (first &rest rest)
  "Handle a simple function call."
  (format nil "~@[~vt~]~a (~{~a~^, ~})"
          (when (> *current-indent* 0)
            *current-indent*)
          (if (symbolp first)
              (glsl-name first)
              (walk-1 first)) (walk-list rest)))

(defun symbol-handler (sym)
  "Handle a single symbol."
  (glsl-name sym))

(defun handle-preamble (form)
  "Handle a preamble declaration."
  (make-var (intern (symbol-name (first form)) :keyword) (glsl-name (first form))
            (second form) (cddr form)
            (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~);~%"
                    (awhen (member :location form) (cadr it))
                    (awhen (member :interp form) (cadr it))
                    (third form) (second form) (glsl-name (first form)))))

(defun glsl-compile (lambda-list body)
  "Compile the shader defined in BODY to glsl format.
The forms contained in LAMBDA-LIST are used to define the global variables of
the shader."
  (merge-shaders (make-shader :version (cdr (assoc gl-utils:*glsl-version* *version-profiles*
                                                   :test #'equal)))
                 (flet ((merge-preamble (sh1 sh2)
                          (merge-shaders sh1 (handle-preamble sh2))))
                   (reduce #'merge-preamble (cons (handle-preamble (first lambda-list))
                                                  (rest lambda-list))))
                 (make-exp (format nil "void main ()~%{~%~a}~%"
                                   (let ((*current-indent* 2))
                                     (walk (cons 'progn body) *form-handlers* #'default-handler #'symbol-handler *env*))))))

(defun glsl-print (shader)
  "Returns a string containing the complete SHADER in glsl format."
  (format nil "~@[~a~%~%~]~{~a~}~%~a"
          (or (shader-version shader) (cdr (assoc gl-utils:*glsl-version* *version-profiles*
                                                   :test #'equal)))
          (loop for var in (shader-vars shader)
               collect (var-exp var)) (shader-exp shader)))