;;; Sly
;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
;;;
;;; Sly 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.
;;;
;;; Sly 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:
;;
;; Manages the OpenGL state machine.
;;
;;; Code:

(define-module (sly render)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 q)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-42)
  #:use-module (gl)
  #:use-module (gl enums)
  #:use-module (gl low-level)
  #:use-module (sly signal)
  #:use-module (sly wrappers gl)
  #:use-module ((sly math transform) #:prefix t:)
  #:use-module (sly render color)
  #:use-module (sly render shader)
  #:use-module (sly render texture)
  #:use-module (sly render utils)
  #:use-module (sly render mesh)
  #:use-module (sly render framebuffer)
  #:use-module (sly render viewport)
  #:export (make-graphics
            graphics?
            graphics-blend-mode
            set-graphics-blend-mode!
            graphics-depth-test?
            set-graphics-depth-test!
            graphics-texture
            set-graphics-texture!
            graphics-shader
            set-graphics-shader!
            graphics-mesh
            set-graphics-mesh!
            graphics-framebuffer
            set-graphics-framebuffer!
            graphics-viewport
            set-graphics-viewport!
            graphics-alpha
            set-graphics-alpha!
            graphics-model-view-transform
            graphics-model-view-mul!
            graphics-model-view-identity!
            graphics-model-view-excursion
            graphics-projection-transform
            graphics-projection-mul!
            graphics-projection-identity!
            graphics-projection-excursion
            graphics-blend-mode-excursion
            graphics-depth-test-excursion
            graphics-texture-excursion
            graphics-shader-excursion
            graphics-mesh-excursion
            graphics-framebuffer-excursion
            graphics-viewport excursion
            graphics-uniform-excursion
            with-graphics

            render-lift
            render-lift1
            render-nothing
            list->renderer
            render-begin
            blend-mode-excursion
            depth-test-excursion
            texture-excursion
            shader-excursion
            mesh-excursion
            framebuffer-excursion
            viewport-excursion
            projection-excursion
            model-view-excursion
            set-blend-mode
            set-depth-test
            set-texture
            set-shader
            set-mesh
            set-framebuffer
            set-viewport
            projection-mul
            projection-identity
            model-view-mul
            model-view-identity
            with-blend-mode
            with-depth-test
            with-texture
            with-shader
            with-mesh
            with-framebuffer
            with-viewport
            with-projection-mul
            with-model-view-mul
            move
            scale
            rotate-x
            rotate-y
            rotate-z
            rotate
            clear-screen
            uniform-let
            with-color
            render-mesh
            render/signal))

;;;
;;; Transformation matrix stack.
;;;

(define (make-null-transform)
  (t:make-transform 0 0 0 0
                    0 0 0 0
                    0 0 0 0
                    0 0 0 0))

(define (make-transform-stack size)
  (let ((stack (make-q)))
    (do-ec (: i size) (q-push! stack (make-null-transform)))
    stack))

(define (copy-transform! src dest)
  (bytevector-copy! (t:transform-matrix src) 0
                    (t:transform-matrix dest) 0
                    64))

(define (call-with-transform-excursion stack thunk)
  (let ((t (q-pop! stack)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (copy-transform! t (q-front stack))
        (thunk))
      (lambda ()
        (q-push! stack t)))))

(define (stack-transform-mul! stack t)
  (let ((dest (q-front stack)))
    (call-with-transform-excursion stack
      (lambda ()
        (t:transform*! dest (q-front stack) t)))))

(define (stack-transform-identity! stack)
  (copy-transform! t:identity-transform (q-front stack)))

;;;
;;; Graphics context.
;;;

(define-record-type <graphics>
  (%make-graphics blend-mode depth-test? texture shader mesh framebuffer
                  viewport projection model-view uniforms)
  graphics?
  (blend-mode graphics-blend-mode %set-graphics-blend-mode!)
  (depth-test? graphics-depth-test? %set-graphics-depth-test!)
  (texture graphics-texture %set-graphics-texture!)
  (shader graphics-shader %set-graphics-shader!)
  (mesh graphics-mesh %set-graphics-mesh!)
  (framebuffer graphics-framebuffer %set-graphics-framebuffer!)
  (viewport graphics-viewport %set-graphics-viewport!)
  (projection graphics-projection)
  (model-view graphics-model-view)
  (uniforms graphics-uniforms set-graphics-uniforms!)
  (alpha graphics-alpha set-graphics-alpha!))

(define (graphics-uniform-ref gfx uniform)
  (hashq-ref (graphics-uniforms gfx) uniform))

(define (graphics-uniform-set! gfx uniform value)
  (uniform-set! (graphics-shader gfx) uniform value)
  (hashq-set! (graphics-uniforms gfx) uniform value))

(define (graphics-uniform-excursion gfx uniforms proc)
  (define (set-uniforms uniforms)
    (for-each (match-lambda
               ((name value)
                (graphics-uniform-set! gfx name value)))
              uniforms))

  (let* ((old (map (match-lambda
                    ((name _)
                     (list name (graphics-uniform-ref gfx name))))
                   uniforms)))
    (set-uniforms uniforms)
    (proc gfx)
    (set-uniforms old)))

(define (switch-shader gfx shader)
  (%set-graphics-shader! gfx shader)
  (hash-clear! (graphics-uniforms gfx))
  (for-each (lambda (uniform)
              (graphics-uniform-set! gfx
                                     (uniform-name uniform)
                                     (uniform-default uniform)))
            (shader-uniforms shader)))

(define (make-context-switcher getter setter switch)
  (lambda* (gfx x #:optional force)
    (when (or force (not (equal? (getter gfx) x)))
      ;; It's important that we change OpenGL context first, because
      ;; the setter procedure may do things that depend on it.
      (switch x)
      (setter gfx x))))

(define set-graphics-blend-mode!
  (make-context-switcher graphics-blend-mode
                         %set-graphics-blend-mode!
                         apply-blend-mode))

(define set-graphics-depth-test!
  (make-context-switcher graphics-depth-test?
                         %set-graphics-depth-test!
                         apply-depth-test))

(define set-graphics-texture!
  (make-context-switcher graphics-texture
                         %set-graphics-texture!
                         apply-texture))

(define set-graphics-shader!
  (make-context-switcher graphics-shader
                         switch-shader
                         apply-shader))

(define set-graphics-mesh!
  (make-context-switcher graphics-mesh
                         %set-graphics-mesh!
                         apply-mesh))

(define set-graphics-framebuffer!
  (make-context-switcher graphics-framebuffer
                         %set-graphics-framebuffer!
                         apply-framebuffer))

(define set-graphics-viewport!
  (make-context-switcher graphics-viewport
                         %set-graphics-viewport!
                         apply-viewport))

(define (draw-graphics-mesh! graphics)
  (let ((mesh (graphics-mesh graphics)))
    (glDrawElements (begin-mode triangles)
                    (mesh-length mesh)
                    (data-type unsigned-int)
                    %null-pointer)))

(define* (make-graphics #:optional (transform-stack-size 32))
  (%make-graphics #f #f #f #f #f #f #f
                  (make-transform-stack transform-stack-size)
                  (make-transform-stack transform-stack-size)
                  (make-hash-table)))

(define (graphics-reset! gfx)
  (let ((shader (load-default-shader)))
    (set-graphics-blend-mode!  gfx default-blend-mode #t)
    (set-graphics-depth-test!  gfx #f #t)
    (set-graphics-texture!     gfx null-texture #t)
    (set-graphics-shader!      gfx shader #t)
    (set-graphics-mesh!        gfx null-mesh #t)
    (set-graphics-framebuffer! gfx null-framebuffer #t)
    (set-graphics-viewport!    gfx null-viewport #t)
    (stack-transform-identity! (graphics-projection gfx))
    (stack-transform-identity! (graphics-model-view gfx))))

(define-syntax-rule (with-graphics gfx body ...)
  (begin
    (graphics-reset! gfx)
    body ...
    (graphics-reset! gfx)))

(define (graphics-model-view-transform gfx)
  (q-front (graphics-model-view gfx)))

(define (graphics-model-view-mul! gfx t)
  (stack-transform-mul! (graphics-model-view gfx) t))

(define (graphics-model-view-identity! gfx)
  (stack-transform-identity! (graphics-model-view gfx)))

(define (graphics-model-view-excursion gfx proc)
  (call-with-transform-excursion (graphics-model-view gfx)
    (lambda () (proc gfx))))

(define (graphics-projection-transform gfx)
  (q-front (graphics-projection gfx)))

(define (graphics-projection-mul! gfx t)
  (stack-transform-mul! (graphics-projection gfx) t))

(define (graphics-projection-identity! gfx)
  (stack-transform-identity! (graphics-projection gfx)))

(define (graphics-projection-excursion gfx proc)
  (call-with-transform-excursion (graphics-projection gfx)
    (lambda () (proc gfx))))

(define (make-excursion getter setter)
  (lambda (gfx proc)
    (let ((old (getter gfx)))
      (dynamic-wind
        (const #t)
        (lambda () (proc gfx))
        (lambda ()
          (setter gfx old))))))

(define graphics-blend-mode-excursion
  (make-excursion graphics-blend-mode set-graphics-blend-mode!))

(define graphics-depth-test-excursion
  (make-excursion graphics-depth-test? set-graphics-depth-test!))

(define graphics-texture-excursion
  (make-excursion graphics-texture set-graphics-texture!))

(define graphics-shader-excursion
  (make-excursion graphics-shader set-graphics-shader!))

(define graphics-mesh-excursion
  (make-excursion graphics-mesh set-graphics-mesh!))

(define graphics-framebuffer-excursion
  (make-excursion graphics-framebuffer set-graphics-framebuffer!))

(define graphics-viewport-excursion
  (make-excursion graphics-viewport set-graphics-viewport!))

;;;
;;; Render Combinators
;;;

(define (render-lift proc)
  "Lift PROC, a procedure whose first argument is the graphics
context, into the rendering monad."
  (lambda args
    (lambda (gfx)
      (apply proc gfx args))))

(define (render-lift1 proc)
  "Lift PROC, a procedure that accepts two arguments whose first
argument is a graphics context, into the rendering monad."
  (lambda (arg)
    (lambda (gfx)
      (proc gfx arg))))

(define (render-nothing gfx)
  "Render nothing at all."
  *unspecified*)

(define (list->renderer renderers)
  "Create a new renderer that applies RENDERERS in order."
  (lambda (gfx)
    (for-each (lambda (render) (render gfx)) renderers)))

(define (render-begin . renderers)
  "Create a new renderer that applies RENDERERS in order."
  (list->renderer renderers))

(define blend-mode-excursion
  (render-lift1 graphics-blend-mode-excursion))

(define depth-test-excursion
  (render-lift1 graphics-depth-test-excursion))

(define texture-excursion
  (render-lift1 graphics-texture-excursion))

(define shader-excursion
  (render-lift1 graphics-shader-excursion))

(define mesh-excursion
  (render-lift1 graphics-mesh-excursion))

(define framebuffer-excursion
  (render-lift1 graphics-framebuffer-excursion))

(define viewport-excursion
  (render-lift1 graphics-viewport-excursion))

(define projection-excursion
  (render-lift1 graphics-projection-excursion))

(define model-view-excursion
  (render-lift1 graphics-model-view-excursion))

(define set-blend-mode
  (render-lift1 set-graphics-blend-mode!))

(define set-depth-test
  (render-lift1 set-graphics-depth-test!))

(define set-texture
  (render-lift1 set-graphics-texture!))

(define set-shader
  (render-lift1 set-graphics-shader!))

(define set-mesh
  (render-lift1 set-graphics-shader!))

(define set-framebuffer
  (render-lift1 set-graphics-framebuffer!))

(define set-viewport
  (render-lift1 set-graphics-viewport!))

(define projection-mul
  (render-lift1 graphics-projection-mul!))

(define projection-identity
  (render-lift1 graphics-projection-identity!))

(define model-view-mul
  (render-lift1 graphics-model-view-mul!))

(define model-view-identity
  (render-lift1 graphics-model-view-identity!))

(define (with-blend-mode blend-mode renderer)
  (blend-mode-excursion
   (render-begin (set-blend-mode blend-mode) renderer)))

(define (with-depth-test depth-test renderer)
  (depth-test-excursion
   (render-begin (set-depth-test depth-test) renderer)))

(define (with-texture texture renderer)
  (texture-excursion
   (render-begin (set-texture texture) renderer)))

(define (with-shader shader renderer)
  (shader-excursion
   (render-begin (set-shader shader) renderer)))

(define (with-mesh mesh renderer)
  (mesh-excursion
   (render-begin (set-mesh mesh) renderer)))

(define (with-framebuffer framebuffer renderer)
  (framebuffer-excursion
   (render-begin (set-framebuffer framebuffer) renderer)))

(define (with-viewport viewport renderer)
  (viewport-excursion
   (render-begin (set-viewport viewport) renderer)))

(define (with-projection-mul transform renderer)
  (projection-excursion
   (render-begin (projection-mul transform) renderer)))

(define (with-model-view-mul transform renderer)
  (model-view-excursion
   (render-begin (model-view-mul transform) renderer)))

(define (move v renderer)
  "Create a new renderer that moves the scene by the vector V and
applies RENDERER."
  (with-model-view-mul (t:translate v) renderer))

(define (scale s renderer)
  "Create a new renderer that scales the scene by S and applies
RENDERER."
  (with-model-view-mul (t:scale s) renderer))

(define (rotate-x theta renderer)
  "Create a new renderer that rotates the scene by THETA about the X
axis and applies RENDERER."
  (with-model-view-mul (t:rotate-x theta) renderer))

(define (rotate-y theta renderer)
  "Create a new renderer that rotates the scene by THETA about the Y
axis and applies RENDERER."
  (with-model-view-mul (t:rotate-y theta) renderer))

(define (rotate-z theta renderer)
  "Create a new renderer that rotates the scene by THETA about the Z
axis and applies RENDERER."
  (with-model-view-mul (t:rotate-z theta) renderer))

(define (rotate quaternion renderer)
  "Create a new renderer that rotates the scene by QUATERNION and
applies RENDERER."
  (with-model-view-mul (t:rotate quaternion) renderer))

(define (clear-screen gfx)
  "Clear the current viewport bound to GFX."
  (clear-viewport (graphics-viewport gfx)))

(define-syntax-rule (uniform-let ((uniform value) ...) renderer ...)
  "Bind each UNIFORM to its respective VALUE in the curently bound
shader program, then apply each RENDERER."
  (lambda (gfx)
    (graphics-uniform-excursion gfx `((uniform ,value) ...)
      (lambda (gfx)
        (renderer gfx) ...))))

(define (with-color color renderer)
  "Create a new renderer that sets the 'color' uniform variable to
COLOR and applies RENDERER."
  (uniform-let ((color color))
    renderer))

(define (render-mesh mesh)
  "Create a new renderer that render MESH to the framebuffer."
  (lambda (gfx)
    (graphics-model-view-excursion gfx
      (lambda (gfx)
        (graphics-model-view-mul! gfx (graphics-projection-transform gfx))
        (set-graphics-mesh! gfx mesh)
        (graphics-uniform-excursion gfx
            `((mvp ,(graphics-model-view-transform gfx))
              (texture? ,(not (texture-null? (graphics-texture gfx)))))
          draw-graphics-mesh!)))))

(define-syntax-rule (render/signal ((name signal) ...) renderer)
  "Evaluate RENDERER whenever a bound signal changes."
  (let ((s (signal-let ((name signal) ...) renderer)))
    (lambda (gfx)
      ((signal-ref s) gfx))))