;;; Sly
;;; Copyright (C) 2016 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program 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.
;;;
;;; This program 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:
;;
;; Deferred sprite rendering for improved performance.
;;
;;; Code:

(define-module (sly render sprite-batch)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (system foreign)
  #:use-module (gl)
  #:use-module (gl low-level)
  #:use-module (sly agenda)
  #:use-module (sly utils)
  #:use-module (sly render)
  #:use-module (sly render color)
  #:use-module (sly render mesh)
  #:use-module (sly render shader)
  #:use-module (sly render texture)
  #:use-module (sly render utils)
  #:use-module (sly math vector)
  #:use-module (sly math rect)
  #:use-module (sly wrappers gl)
  #:export (make-sprite-batch
            sprite-batch?
            sprite-batch-capacity
            sprite-batch-size
            sprite-batch-add!
            sprite-batch-reset!
            sprite-batch-flush!
            with-sprite-batch))


;;;
;;; Sprite Batch
;;;

(define-record-type <sprite-batch>
  (%make-sprite-batch texture size capacity index-buffer
                      position-buffer texture-buffer mesh)
  sprite-batch?
  (texture sprite-batch-texture set-sprite-batch-texture!)
  (size sprite-batch-size set-sprite-batch-size!)
  (capacity sprite-batch-capacity)
  (index-buffer sprite-batch-index-buffer)
  (position-buffer sprite-batch-position-buffer)
  (texture-buffer sprite-batch-texture-buffer)
  (mesh sprite-batch-mesh))

(define (make-sprite-batch capacity)
  "Make a sprite batch that can hold CAPACITY sprites."
  (let* ((index (make-streaming-vertex-buffer 'index (* capacity 6)))
         (pos   (make-streaming-vertex-buffer 'vec3  (* capacity 4)))
         (tex   (make-streaming-vertex-buffer 'vec2  (* capacity 4)))
         (mesh  (make-mesh index pos tex)))
    (%make-sprite-batch #f 0 capacity index pos tex mesh)))

(define (same-texture? t1 t2)
  (define (maybe-parent-texture t)
    (if (texture-region? t)
        (texture-parent t)
        t))

  (= (texture-id (maybe-parent-texture t1))
     (texture-id (maybe-parent-texture t2))))

(define* (sprite-batch-add! batch context texture rect)
  ;; Draw batch if we are at capacity or the texture is changing.
  (when (or (= (sprite-batch-capacity batch) (sprite-batch-size batch))
            (and (sprite-batch-texture batch)
                 (not (same-texture? texture (sprite-batch-texture batch)))))
    (sprite-batch-flush! batch context)
    (sprite-batch-begin! batch))

  ;; Establish the texture to use if this is the first sprite in the
  ;; current batch.
  (when (texture-null? (sprite-batch-texture batch))
    (set-sprite-batch-texture! batch texture))

  (let ((size (sprite-batch-size batch)))
    (let ((index-offset  (* size 6))
          (index-vertex-offset (* size 4))
          (vertex-offset (* size 12)) ; 4 vertices, 3 floats per vertex
          (texture-offset (* size 8))
          (index-buffer (vertex-buffer-data
                         (sprite-batch-index-buffer batch)))
          (pos-buffer (vertex-buffer-data
                       (sprite-batch-position-buffer batch)))
          (tex-buffer (vertex-buffer-data
                       (sprite-batch-texture-buffer batch)))
          (s1 (texture-s1 texture))
          (t1 (texture-t1 texture))
          (s2 (texture-s2 texture))
          (t2 (texture-t2 texture))
          (top (rect-top rect))
          (bottom (rect-bottom rect))
          (left (rect-left rect))
          (right (rect-right rect)))

      ;; Add indices.
      (u32vector-set! index-buffer index-offset index-vertex-offset)
      (u32vector-set! index-buffer (+ index-offset 1) (+ index-vertex-offset 3))
      (u32vector-set! index-buffer (+ index-offset 2) (+ index-vertex-offset 2))
      (u32vector-set! index-buffer (+ index-offset 3) index-vertex-offset)
      (u32vector-set! index-buffer (+ index-offset 4) (+ index-vertex-offset 2))
      (u32vector-set! index-buffer (+ index-offset 5) (+ index-vertex-offset 1))

      ;; Add vertices.
      ;; Bottom-left
      (f32vector-set! pos-buffer vertex-offset left)
      (f32vector-set! pos-buffer (+ vertex-offset 1) bottom)
      (f32vector-set! pos-buffer (+ vertex-offset 2) 0.0)
      ;; Bottom-right
      (f32vector-set! pos-buffer (+ vertex-offset 3) right)
      (f32vector-set! pos-buffer (+ vertex-offset 4) bottom)
      (f32vector-set! pos-buffer (+ vertex-offset 5) 0.0)
      ;; Top-right
      (f32vector-set! pos-buffer (+ vertex-offset 6) right)
      (f32vector-set! pos-buffer (+ vertex-offset 7) top)
      (f32vector-set! pos-buffer (+ vertex-offset 8) 0.0)
      ;; Top-left
      (f32vector-set! pos-buffer (+ vertex-offset 9) left)
      (f32vector-set! pos-buffer (+ vertex-offset 10) top)
      (f32vector-set! pos-buffer (+ vertex-offset 11) 0.0)

      ;; Add texture coordinates.
      ;; Bottom-left
      (f32vector-set! tex-buffer texture-offset s1)
      (f32vector-set! tex-buffer (+ texture-offset 1) t1)
      ;; Bottom-right
      (f32vector-set! tex-buffer (+ texture-offset 2) s2)
      (f32vector-set! tex-buffer (+ texture-offset 3) t1)
      ;; Top-right
      (f32vector-set! tex-buffer (+ texture-offset 4) s2)
      (f32vector-set! tex-buffer (+ texture-offset 5) t2)
      ;; Top-left
      (f32vector-set! tex-buffer (+ texture-offset 6) s1)
      (f32vector-set! tex-buffer (+ texture-offset 7) t2)

      (set-sprite-batch-size! batch (1+ size)))))

(define (sprite-batch-reset! batch)
  "Reset BATCH to size 0."
  (set-sprite-batch-texture! batch null-texture)
  (set-sprite-batch-size! batch 0))

(define (sprite-batch-begin! batch)
  (map-vertex-buffer! (sprite-batch-index-buffer batch))
  (map-vertex-buffer! (sprite-batch-position-buffer batch))
  (map-vertex-buffer! (sprite-batch-texture-buffer batch)))

(define (sprite-batch-flush! batch context)
  "Render the contents of BATCH and clear the cache."
  (unless (zero? (sprite-batch-size batch))
    (graphics-texture-excursion context
      (lambda (context)
        (set-graphics-texture! context (sprite-batch-texture batch))
        (graphics-model-view-excursion context
          (lambda (context)
            (graphics-model-view-mul! context
                                      (graphics-projection-transform context))
            (graphics-uniform-excursion context
                `((mvp ,(graphics-model-view-transform context))
                  (texture? ,(not (texture-null? (graphics-texture context)))))
              (lambda (context)
                (unmap-vertex-buffer! (sprite-batch-index-buffer batch))
                (unmap-vertex-buffer! (sprite-batch-position-buffer batch))
                (unmap-vertex-buffer! (sprite-batch-texture-buffer batch))

                (set-graphics-mesh! context (sprite-batch-mesh batch))
                (glDrawElements (begin-mode triangles)
                                ;; 6 indices per sprite.
                                (* (sprite-batch-size batch) 6)
                                (data-type unsigned-int)
                                %null-pointer)

                (sprite-batch-reset! batch)))))))))

(define-syntax-rule (with-sprite-batch batch context body ...)
  ;; IMPORTANT! We need to make sure that the current VAO is unbound
  ;; before we start mapping/unmapping vertex buffers.  Not doing this
  ;; created a nasty bug that took me a long time to find.
  (graphics-mesh-excursion context
    (lambda (context)
      (set-graphics-mesh! context null-mesh)
      (sprite-batch-reset! batch)
      (sprite-batch-begin! batch)
      body ...
      (sprite-batch-flush! batch context))))