;;; Chickadee Game Toolkit
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; High-level rendering API.
;;
;;; Code:

(define-module (chickadee render)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee render gpu)
  #:use-module (chickadee render blend)
  #:use-module (chickadee render framebuffer)
  #:use-module (chickadee render shader)
  #:use-module (chickadee render texture)
  #:use-module (chickadee render buffer)
  #:use-module (chickadee render viewport)
  #:use-module (srfi srfi-9)
  #:export (current-viewport
            current-framebuffer
            current-blend-mode
            current-depth-test
            current-texture
            current-projection
            with-viewport
            with-framebuffer
            with-blend-mode
            with-depth-test
            with-texture
            with-projection
            gpu-apply
            gpu-apply*
            gpu-apply/instanced*
            gpu-apply/instanced))

(define-record-type <render-context>
  (make-render-context viewport framebuffer blend-mode depth-test?
                        projection textures)
  render-context?
  (viewport render-context-viewport set-render-context-viewport!)
  (framebuffer render-context-framebuffer set-render-context-framebuffer!)
  (blend-mode render-context-blend-mode set-render-context-blend-mode!)
  (depth-test? render-context-depth-test? set-render-context-depth-test!)
  (projection render-context-projection set-render-context-projection!)
  (textures render-context-textures))

(define render-context
  (make-render-context null-viewport
                       null-framebuffer
                       'replace
                       #f
                       (make-identity-matrix4)
                       (make-vector 32 null-texture)))

(define (current-viewport)
  (render-context-viewport render-context))

(define (current-framebuffer)
  (render-context-framebuffer render-context))

(define (current-blend-mode)
  (render-context-blend-mode render-context))

(define (current-depth-test)
  (render-context-depth-test? render-context))

(define (current-texture i)
  (vector-ref (render-context-textures render-context) i))

(define (current-projection)
  (render-context-projection render-context))

(define-syntax-rule (with (getter setter value) body ...)
  (let ((prev (getter render-context)))
    (setter render-context value)
    body ...
    (setter render-context prev)))

(define-syntax-rule (with-viewport viewport body ...)
  (with (render-context-viewport set-render-context-viewport! viewport)
        body ...))

(define-syntax-rule (with-framebuffer framebuffer body ...)
  (with (render-context-framebuffer set-render-context-framebuffer! framebuffer)
        ;; As a convenience, initialize the viewport and projection
        ;; matrix as well so that the user doesn't have to explicitly
        ;; make a viewport and/or projection matrix unless they
        ;; actually want to do fancy viewport manipulations.
        (with-viewport (framebuffer-viewport framebuffer)
          (with-projection (framebuffer-projection framebuffer)
            body ...))))

(define-syntax-rule (with-blend-mode blend-mode body ...)
  (with (render-context-blend-mode set-render-context-blend-mode! blend-mode)
        body ...))

(define-syntax-rule (with-depth-test depth-test body ...)
  (with (render-context-depth-test? set-render-context-depth-test! depth-test)
        body ...))

(define-syntax-rule (with-texture n texture body ...)
  (let* ((textures (render-context-textures render-context))
         (prev (vector-ref textures n)))
    (dynamic-wind
      (lambda () (vector-set! textures n texture))
      (lambda () body ...)
      (lambda () (vector-set! textures n prev)))))

(define-syntax-rule (with-projection matrix body ...)
  (with (render-context-projection set-render-context-projection! matrix)
        body ...))

(define (keyword->string kw)
  (symbol->string (keyword->symbol kw)))

(define-syntax uniform-apply
  (lambda (x)
    (syntax-case x ()
      ((_ shader ()) (datum->syntax x #t))
      ((_ shader (name value . rest))
       (with-syntax ((sname (datum->syntax x (keyword->symbol
                                              (syntax->datum #'name)))))
         #'(begin
             (shader-uniform-set! shader 'sname value)
             (uniform-apply shader rest)))))))

(define-syntax-rule (gpu-prepare shader vertex-array uniforms)
  (let ((gpu (current-gpu)))
    ;; It's important that the framebuffer is set before setting the
    ;; viewport because applying a new viewport will clear the current
    ;; framebuffer.
    (set-gpu-framebuffer! gpu (current-framebuffer))
    (set-gpu-viewport! gpu (current-viewport))
    (set-gpu-blend-mode! gpu (current-blend-mode))
    (set-gpu-depth-test! gpu (current-depth-test))
    (set-gpu-shader! gpu shader)
    (let loop ((i 0))
      (when (< i 32)
        (set-gpu-texture! gpu i (current-texture i))
        (loop (1+ i))))
    (uniform-apply shader uniforms)
    ;; Sampler2D values aren't explicitly passed as uniform values via
    ;; gpu-apply, so we have to bind them to the proper texture units
    ;; behind the scenes.
    (shader-uniform-for-each
     (lambda (uniform)
       (when (eq? (uniform-type uniform) sampler-2d)
         (set-uniform-value! shader uniform (uniform-value uniform))))
     shader)))

(define-syntax-rule (gpu-apply* shader vertex-array count . uniforms)
  (begin
    (gpu-prepare shader vertex-array uniforms)
    (render-vertices vertex-array count)))

(define-syntax-rule (gpu-apply shader vertex-array uniforms ...)
  (gpu-apply* shader vertex-array #f uniforms ...))

(define-syntax-rule (gpu-apply/instanced* shader vertex-array count instances .
                                          uniforms)
  (begin
    (gpu-prepare shader vertex-array uniforms)
    (render-vertices/instanced vertex-array instances count)))

(define-syntax-rule (gpu-apply/instanced shader vertex-array instances
                                         uniforms ...)
  (gpu-apply/instanced* shader vertex-array #f instances uniforms ...))