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

(uiop:define-package :stoe/shader/shader
  (:use :cl :stoe/core/utils :stoe/engine/gl-utils)
  (:export #:make-shader
           #:make-var
           #:make-exp
           #:merge-shaders
           #:shader-version
           #:shader-vars
           #:shader-exp
           #:var-symb
           #:var-name
           #:var-qualifiers
           #:var-target
           #:var-exp
           #:make-program
           #:program-stages
           #:program-vars
           #:program-id
           #:get-location
           #:using-program
           #:with-locations))
(in-package :stoe/shader/shader)

(defstruct shader
  "Structure containing the shader in glsl format together with metadata used to
properly handle the shader."
  (version nil)
  (vars nil)
  (exp ""))

(defstruct (var (:constructor %make-var))
  "Structure containing the shader variable in glsl format together with its
attributes to properly handle the variable."
  (symb nil)
  (name "")
  (type :none)
  (qualifiers nil)
  (exp ""))

(defun make-var (symb name type qualifiers exp)
  "Creates and returns a new shader container to keep track of the variable
defined by the arguments."
  (make-shader :vars (list (%make-var :symb symb
                                      :name name
                                      :type type
                                      :qualifiers qualifiers
                                      :exp exp))))

(defun var-target (var)
  "Returns the target type of the variable. Either :in, :out or :uniform."
  (first (member-if (lambda (x) (or (eq x :in)
                                    (eq x :out)
                                    (eq x :uniform)))
                    (var-qualifiers var))))

(defun make-exp (exp)
  "Creates and returns a new shader container to keep track of the glsl
expression."
  (make-shader :exp exp))

(defun merge-shaders (&rest shaders)
  "Merges two or more shader containers and returns the result."
  (labels ((sh-merge (sh1 sh2)
             (make-shader :version (or (shader-version sh1) (shader-version sh2))
                          :vars (append (shader-vars sh1) (shader-vars sh2))
                          :exp (concatenate 'string (shader-exp sh1) (shader-exp sh2)))))
    (reduce #'sh-merge shaders)))

(defstruct (program (:constructor %make-program))
  "Structure containing the symbols of the different stages' shaders and the
associated in/out/uniform variables.
If the program is compiled into glsl, it keeps track of the object id."
  (stages nil :read-only t)
  vars
  id)

(defun make-program (lambda-list stages)
  "Creates a new program by using and analyzing the specified shaders."
  (declare (ignore lambda-list))
  (%make-program :stages stages
                 :vars (remove-duplicates
                        (reduce #'append
                                (loop for shader in (cdr stages) by #'cddr
                                   collect (remove-if-not
                                            (lambda (var)
                                              (member-if (lambda (x) (or (eq x :in) (eq x :uniform)))
                                                         (var-qualifiers var)))
                                            (shader-vars (symbol-value shader))))))))

(defun get-location (program var)
  "Retrieve the location value of the variable in program."
  (second (member :location (var-qualifiers (first (member (intern (symbol-name var) :keyword)
                                                           (program-vars program)
                                                           :key #'var-symb))))))

(defmacro using-program ((var program) &body body)
  "Use the specified program and bind all its attributes and uniforms for use in BODY."
  `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :stoe/engine/shaders))))
     (gl-assert (gl:use-program (program-id ,var)))
     ,@body
     (gl-assert (gl:use-program 0))))

(defmacro with-locations (vars program &body body)
  "Binds the programs uniforms into the corresponding symbols of vars, using the
same syntax as `with-accessors'."
  `(let ,(mapcar (lambda (var)
                   (cond
                     ((listp var) (list (first var) `(get-location ,program ',(second var))))
                     ((symbolp var) (list var `(get-location ,program ',var)))))
                 vars)
     ,@body))