;;; 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:
;;
;; Meshes encapsulate the geometry for a single OpenGL draw call.
;;
;;; Code:

(define-module (sly render mesh)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-43)
  #:use-module (system foreign)
  #:use-module (gl)
  #:use-module (gl low-level)
  #:use-module (gl enums)
  #:use-module (sly utils)
  #:use-module (sly guardian)
  #:use-module (sly wrappers gl)
  #:use-module (sly math vector)
  #:use-module (sly render color)
  #:use-module (sly render shader)
  #:export (make-streaming-vertex-buffer
            make-vertex-buffer
            bytevector->vertex-buffer
            vector->vertex-buffer
            vertex-buffer?
            index-buffer?
            vertex-buffer-id
            vertex-buffer-type
            vertex-buffer-usage
            vertex-buffer-data
            vertex-buffer-length
            vertex-buffer-element-length
            vertex-buffer-attribute-size
            apply-vertex-buffer
            map-vertex-buffer!
            unmap-vertex-buffer!

            generate-vertex-array
            vertex-attrib-pointer

            make-mesh
            build-mesh
            null-mesh
            mesh?
            mesh-id
            mesh-vertex-buffers
            mesh-length
            mesh-ref
            apply-mesh
            with-mesh))

;;;
;;; Vertex Buffer
;;;

(define-record-type <vertex-buffer>
  (%make-vertex-buffer id type usage length data)
  vertex-buffer?
  (id vertex-buffer-id)
  (type vertex-buffer-type)
  (usage vertex-buffer-usage)
  (length vertex-buffer-length)
  (data vertex-buffer-data set-vertex-buffer-data!))

(set-record-type-printer! <vertex-buffer>
  (lambda (vbo port)
    (format port
            "#<vertex-buffer id: ~d type: ~a usage: ~a>"
            (vertex-buffer-id vbo)
            (vertex-buffer-type vbo)
            (vertex-buffer-usage vbo))))

(define (generate-vertex-buffer)
  (let ((bv (u32vector 1)))
    (glGenBuffers 1 (bytevector->pointer bv))
    (u32vector-ref bv 0)))

(define (apply-vertex-buffer vbo)
  (glBindBuffer (vertex-buffer-target vbo)
                (vertex-buffer-id vbo)))

(define-syntax-rule (with-vertex-buffer vbo body ...)
  (let ((target (vertex-buffer-target vbo)))
    (glBindBuffer target (vertex-buffer-id vbo))
    body ...
    (glBindBuffer target 0)))

(define attribute-type
  (match-lambda
   ((? number? _) 'float)
   ((? vector2? _) 'vec2)
   ((? vector3? _) 'vec3)
   ((or (? vector4? _)
        (? color? _))
    'vec4)
   (attr
    (error "Unsupported vertex buffer attribute: " attr))))

(define attribute-size
  (match-lambda
   ((? number? _) 1)
   ((? vector2? _) 2)
   ((? vector3? _) 3)
   ((or (? vector4? _)
        (? color? _))
    4)
   (attr
    (error "Unsupported vertex buffer attribute: " attr))))

(define (vertices-bytevector vertices index?)
  (let* ((elem (vector-ref vertices 0))
         (bv (if index?
                 (make-u32vector (vector-length vertices))
                 (make-f32vector (* (vector-length vertices)
                                    (attribute-size elem)))))
         (setter (if index? u32vector-set! f32vector-set!)))
    (vector-for-each
     (match-lambda*
      ((i (? number? k))
       (setter bv i k))
      ((i ($ <vector2> x y))
       (let ((offset (* i 2)))
         (setter bv offset x)
         (setter bv (1+ offset) y)))
      ((i ($ <vector3> x y z))
       (let ((offset (* i 3)))
         (setter bv offset x)
         (setter bv (1+ offset) y)
         (setter bv (+ offset 2) z)))
      ((i ($ <vector4> x y z w))
       (let ((offset (* i 4)))
         (setter bv offset x)
         (setter bv (1+ offset) y)
         (setter bv (+ offset 2) z)
         (setter bv (+ offset 3) w)))
      ((i (color? c))
       (let ((offset (* i 4)))
         (setter bv offset (color-r c))
         (setter bv (1+ offset) (color-g c))
         (setter bv (+ offset 2) (color-b c))
         (setter bv (+ offset 3) (color-a c)))))
     vertices)
    bv))

(define (type-size type)
  (match type
    ((or 'float 'index) 1)
    ('vec2 2)
    ('vec3 3)
    ('vec4 4)))

(define (vertex-buffer-attribute-size vbo)
  (type-size (vertex-buffer-type vbo)))

(define (index-buffer? vbo)
  (eq? (vertex-buffer-type vbo) 'index))

(define (vertex-buffer-target vbo)
  (if (index-buffer? vbo)
      (arb-vertex-buffer-object element-array-buffer-arb)
      (arb-vertex-buffer-object array-buffer-arb)))

(define (vertex-buffer-element-length vbo)
  (/ (vertex-buffer-length vbo)
     (* (vertex-buffer-attribute-size vbo) 4)))

(define (vertex-buffer-usage-gl vbo)
  (match (vertex-buffer-usage vbo)
    ('static
     (arb-vertex-buffer-object static-draw-arb))
    ('stream
     (arb-vertex-buffer-object stream-draw-arb))))

(define (make-streaming-vertex-buffer type length)
  "Return a new vertex buffer of LENGTH elements suitable for
streaming data to the GPU every frame.  TYPE is a symbol specifying
the element type, either 'float', 'index', 'vec2', 'vec3', or 'vec4'."
  (let ((vbo (%make-vertex-buffer (generate-vertex-buffer)
                                  type
                                  'stream
                                  ;; All numbers are 32 bits e.g. 4 bytes
                                  (* (type-size type) length 4)
                                  #f)))
    (with-vertex-buffer vbo
      (glBufferData (vertex-buffer-target vbo)
                    length
                    %null-pointer
                    (vertex-buffer-usage-gl vbo)))
    vbo))

(define (make-vertex-buffer type usage length)
  (let ((data (if (eq? type 'index)
                  (make-u32vector length)
                  (make-f32vector (* (type-size type) length)))))
    (bytevector->vertex-buffer type usage data)))

(define (bytevector->vertex-buffer type usage bv)
  (let ((vbo (%make-vertex-buffer (generate-vertex-buffer)
                                  type
                                  usage
                                  (bytevector-length bv)
                                  bv)))
    (with-vertex-buffer vbo
      (glBufferData (vertex-buffer-target vbo)
                    (bytevector-length bv)
                    (bytevector->pointer bv)
                    (vertex-buffer-usage-gl vbo)))
    vbo))

(define* (vector->vertex-buffer vertices #:optional (index? #f) (usage 'static))
  (let ((data (vertices-bytevector vertices index?))
        (type (if index?
                  'index
                  (attribute-type (vector-ref vertices 0)))))
    (bytevector->vertex-buffer type usage data)))

(define (map-vertex-buffer! vbo)
  "Map the memory space for VBO from GPU to the CPU, which is then
accessible via the vertex-buffer-data procedure.  This technique
allows vertex buffers to be updated with new vertex data."
  (let ((target (vertex-buffer-target vbo))
        (length (vertex-buffer-length vbo))
        (usage (vertex-buffer-usage-gl vbo)))
    (with-vertex-buffer vbo
      ;; Orphan the buffer to avoid implicit synchronization.
      ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
      (glBufferData target length %null-pointer usage)
      (let ((ptr (glMapBuffer target (version-1-5 read-write))))
        (set-vertex-buffer-data! vbo (pointer->bytevector ptr length))))))

(define (unmap-vertex-buffer! vbo)
  "Return the mapped vertex data for VBO to the GPU."
  (with-vertex-buffer vbo
    (glUnmapBuffer (vertex-buffer-target vbo))))

;;;
;;; Mesh
;;;

(define-record-type <mesh>
  (%make-mesh id length vertex-buffers)
  mesh?
  (id mesh-id)
  (length mesh-length)
  (vertex-buffers mesh-vertex-buffers))

(define (free-mesh mesh)
  ;; Delete vertex array and vertex buffers.
  (glDeleteVertexArrays 1 (u32vector (mesh-id mesh)))
  (let ((buffers (mesh-vertex-buffers mesh)))
    (glDeleteBuffers (length buffers)
                     (list->u32vector
                      (map (match-lambda
                             ((_ . vbo)
                              (vertex-buffer-id vbo)))
                           buffers)))))

(register-finalizer mesh? free-mesh)

(define null-mesh (%make-mesh 0 0 '()))

(define (generate-vertex-array)
  (let ((bv (u32vector 1)))
    (glGenVertexArrays 1 (bytevector->pointer bv))
    (u32vector-ref bv 0)))

(define (apply-mesh vao)
  (glBindVertexArray (mesh-id vao)))

;; emacs: (put 'with-mesh 'scheme-indent-function 1)
(define-syntax-rule (with-mesh vao body ...)
  (begin
    (apply-mesh vao)
    body ...
    (apply-mesh null-mesh)))

(define (vertex-attrib-pointer location vbo)
  (glEnableVertexAttribArray location)
  (with-vertex-buffer vbo
    (glVertexAttribPointer location (vertex-buffer-attribute-size vbo)
                           (data-type float) #f 0 %null-pointer)))

(define (make-mesh index-buffer position-buffer texture-buffer)
  (let ((mesh (%make-mesh (generate-vertex-array)
                          (vertex-buffer-element-length index-buffer)
                          `((index . ,index-buffer)
                            (position . ,position-buffer)
                            (texture . ,texture-buffer)))))
    (with-mesh mesh
      (vertex-attrib-pointer vertex-position-location position-buffer)
      (vertex-attrib-pointer vertex-texture-location texture-buffer)
      (apply-vertex-buffer index-buffer))
    (guard mesh)))

(define (build-mesh indices positions textures)
  (let ((index-buffer (vector->vertex-buffer indices #t))
        (position-buffer (vector->vertex-buffer positions))
        (texture-buffer (vector->vertex-buffer textures)))
    (make-mesh index-buffer position-buffer texture-buffer)))

(define (mesh-ref mesh key)
  (assq-ref (mesh-vertex-buffers mesh) key))