;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2017 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:
;;
;; GPU data buffers.
;;
;;; Code:

(define-module (chickadee render buffer)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (gl)
  #:use-module (system foreign)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render gl)
  #:use-module (chickadee render gpu)
  #:export (make-buffer
            make-streaming-buffer
            buffer?
            index-buffer?
            buffer-name
            buffer-length
            buffer-stride
            buffer-target
            buffer-usage
            buffer-data
            null-buffer
            map-buffer!
            unmap-buffer!
            with-mapped-buffer
            *buffer-state*
            make-typed-buffer
            make-streaming-typed-buffer
            typed-buffer?
            typed-buffer->buffer
            typed-buffer->vector
            typed-buffer-name
            typed-buffer-view
            typed-buffer-offset
            typed-buffer-component-type
            typed-buffer-normalized?
            typed-buffer-count
            typed-buffer-type
            typed-buffer-max
            typed-buffer-min
            typed-buffer-sparse
            typed-buffer-data
            map-typed-buffer!
            unmap-typed-buffer!
            with-mapped-typed-buffer
            make-vertex-array
            vertex-array?
            vertex-array-indices
            vertex-array-attributes
            vertex-array-mode
            null-vertex-array
            *vertex-array-state*
            render-vertices))

;;;
;;; Buffers
;;;

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

(set-record-type-printer! <buffer>
                          (lambda (buffer port)
                            (format port
                                    "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
                                    (buffer-id buffer)
                                    (buffer-name buffer)
                                    (buffer-usage buffer)
                                    (buffer-target buffer)
                                    (buffer-length buffer)
                                    (buffer-stride buffer))))

(define null-buffer
  (%make-buffer 0 "null" 0 0 'vertex 'static #f))

(define <<buffer>> (class-of null-buffer))

(define (free-buffer buffer)
  (gl-delete-buffers 1 (u32vector (buffer-id buffer))))

(define-method (gpu-finalize (buffer <<buffer>>))
  (free-buffer buffer))

(define (apply-buffer buffer)
  (gl-bind-buffer (buffer-target-gl buffer)
                  (buffer-id buffer)))

(define *buffer-state*
  (make-gpu-state apply-buffer null-buffer))

(define (generate-buffer-gl)
  (let ((bv (u32vector 1)))
    (gl-gen-buffers 1 (bytevector->pointer bv))
    (u32vector-ref bv 0)))

(define (index-buffer? buffer)
  "Return #t if VIEW is an index buffer view."
  (eq? (buffer-target buffer) 'index))

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

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

(define* (make-buffer data #:key
                      (name "anonymous")
                      (length (bytevector-length data))
                      (offset 0)
                      (stride 0)
                      (target 'vertex)
                      (usage 'static))
  "Upload BV, a bytevector of TYPE elements, to the GPU as a vertex
buffer.

USAGE provides a hint to the GPU as to how the vertex buffer will be
used:

- static: The vertex buffer will not be modified after creation.
- stream: The vertex buffer will be modified frequently."
  ;; Weird bugs will occur when creating a new vertex buffer while a
  ;; vertex array is bound.
  (gpu-state-set! *vertex-array-state* null-vertex-array)
  (let ((buffer (gpu-guard
                 (%make-buffer (generate-buffer-gl)
                               name
                               length
                               stride
                               target
                               usage
                               #f))))
    (gpu-state-set! *buffer-state* buffer)
    (gl-buffer-data (buffer-target-gl buffer)
                    length
                    (if data
                        (bytevector->pointer data offset)
                        %null-pointer)
                    (buffer-usage-gl buffer))
    (gpu-state-set! *buffer-state* null-buffer)
    buffer))

(define* (make-streaming-buffer length #:key
                                (name "anonymous")
                                (target 'vertex))
  "Return a new vertex buffer of LENGTH bytes, named NAME, suitable
for streaming data to the GPU every frame."
  (make-buffer #f #:usage 'stream #:length length #:name name #:target target))

(define (map-buffer! buffer)
  "Map the memory space for BUFFER from the GPU to the CPU, allowing
the vertex buffer to be updated with new vertex data.  The
'unmap-buffer!' procedure must be called to submit the new
vertex buffer data back to the GPU."
  (let ((target (buffer-target-gl buffer))
        (length (buffer-length buffer))
        (usage (buffer-usage-gl buffer)))
    (gpu-state-set! *buffer-state* buffer)
    (when (eq? usage 'stream)
      ;; Orphan the buffer to avoid implicit synchronization.
      ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
      (gl-buffer-data target length %null-pointer usage))
    (let ((ptr (gl-map-buffer target (version-1-5 read-write))))
      (set-buffer-data! buffer (pointer->bytevector ptr length)))))

(define (unmap-buffer! buffer)
  "Return the mapped vertex buffer data for BUFFER to the GPU."
  (gpu-state-set! *buffer-state* buffer)
  (gl-unmap-buffer (buffer-target-gl buffer))
  (set-buffer-data! buffer #f))

(define-syntax-rule (with-mapped-buffer buffer body ...)
  (dynamic-wind
    (lambda ()
      (map-buffer! buffer))
    (lambda () body ...)
    (lambda ()
      (unmap-buffer! buffer))))


;;;
;;; Typed Buffers
;;;

(define-record-type <typed-buffer>
  (%make-typed-buffer name buffer offset component-type
                      normalized? length type max min sparse)
  typed-buffer?
  (name typed-buffer-name)
  (buffer typed-buffer->buffer)
  (offset typed-buffer-offset)
  (component-type typed-buffer-component-type)
  (normalized? typed-buffer-normalized?)
  (length typed-buffer-length)
  (type typed-buffer-type)
  (max typed-buffer-max)
  (min typed-buffer-min)
  (sparse typed-buffer-sparse))

(define (typed-buffer-stride typed-buffer)
  (or (buffer-stride (typed-buffer->buffer typed-buffer))
      (* (type-size (typed-buffer-type typed-buffer))
         (component-type-size (typed-buffer-component-type typed-buffer)))))

(define (num-elements byte-length byte-offset type component-type)
  (inexact->exact
   (floor
    (/ (- byte-length byte-offset)
       (* (component-type-size component-type)
          (type-size type))))))


(define* (make-typed-buffer #:key
                            (name "anonymous")
                            buffer
                            type
                            component-type
                            normalized?
                            (offset 0)
                            (length (num-elements (buffer-length buffer)
                                                  offset
                                                  type
                                                  component-type))
                            max
                            min
                            sparse)
  (%make-typed-buffer name buffer offset component-type
                      normalized? length type max min sparse))

(define (type-size type)
  (match type
    ('scalar 1)
    ('vec2 2)
    ('vec3 3)
    ((or 'vec4 'mat2) 4)
    ('mat3 9)
    ('mat4 16)))

(define (component-type-size component-type)
  (match component-type
    ('byte 1)
    ('unsigned-byte 1)
    ('short 2)
    ('unsigned-short 2)
    ('unsigned-int 4)
    ('float 4)))

(define* (make-streaming-typed-buffer type component-type length #:key
                                      (name "anonymous")
                                      (target 'vertex)
                                      data)
  "Return a new typed buffer to hold LENGTH elements of TYPE whose
components are comprised of COMPONENT-TYPE values.  The underlying
untyped buffer is configured for GPU streaming.  Optonally, a NAME can
be specified for the buffer."
  (let* ((buffer-length
          (* length (type-size type) (component-type-size component-type)))
         (buffer (if data
                     (make-buffer data
                                  #:name name
                                  #:length buffer-length
                                  #:usage 'stream
                                  #:target target)
                     (make-streaming-buffer buffer-length
                                            #:name name
                                            #:target target))))
    (make-typed-buffer #:name name
                       #:buffer buffer
                       #:type type
                       #:component-type component-type
                       #:length length)))

(define (display-typed-buffer typed-buffer port)
  (format port "#<typed-buffer name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d>"
          (typed-buffer-name typed-buffer)
          (typed-buffer->buffer typed-buffer)
          (typed-buffer-type typed-buffer)
          (typed-buffer-component-type typed-buffer)
          (typed-buffer-length typed-buffer)
          (typed-buffer-offset typed-buffer)))

(set-record-type-printer! <typed-buffer> display-typed-buffer)

(define (typed-buffer-type-size typed-buffer)
  (type-size (typed-buffer-type typed-buffer)))

(define (typed-buffer-data typed-buffer)
  (buffer-data (typed-buffer->buffer typed-buffer)))

(define (typed-buffer-type-gl typed-buffer)
  (match (typed-buffer-component-type typed-buffer)
    ('byte (data-type byte))
    ('unsigned-byte (data-type unsigned-byte))
    ('short (data-type short))
    ('unsigned-short (data-type unsigned-short))
    ('unsigned-int (data-type unsigned-int))
    ('float (data-type float))))

(define (map-typed-buffer! typed-buffer)
  (map-buffer! (typed-buffer->buffer typed-buffer)))

(define (unmap-typed-buffer! typed-buffer)
  (unmap-buffer! (typed-buffer->buffer typed-buffer)))

(define-syntax-rule (with-mapped-typed-buffer typed-buffer body ...)
  (with-mapped-buffer (typed-buffer->buffer typed-buffer) body ...))

(define* (apply-typed-buffer typed-buffer #:optional attribute-index)
  (gpu-state-set! *buffer-state* (typed-buffer->buffer typed-buffer))
  ;; If there is no attribute-index, we assume this is being bound for
  ;; use as an index buffer.
  (when attribute-index
    (gl-enable-vertex-attrib-array attribute-index)
    (gl-vertex-attrib-pointer attribute-index
                              (typed-buffer-type-size typed-buffer)
                              (typed-buffer-type-gl typed-buffer)
                              (typed-buffer-normalized? typed-buffer)
                              (typed-buffer-stride typed-buffer)
                              (make-pointer (typed-buffer-offset typed-buffer)))))

;; TODO: Handle 4-byte alignment rule for the types that need it.
(define (typed-buffer->vector typed-buffer)
  (define (component-parser type)
    (match type
      ('byte bytevector-s8-ref)
      ('unsigned-byte bytevector-u8-ref)
      ('short
       (lambda (bv i)
         (bytevector-s16-ref bv i (native-endianness))))
      ('unsigned-short
       (lambda (bv i)
         (bytevector-u16-ref bv i (native-endianness))))
      ('unsigned-int
       (lambda (bv i)
         (bytevector-u32-ref bv i (native-endianness))))
      ('float bytevector-ieee-single-native-ref)))
  (define (element-parser type component-type)
    (let ((parse-component (component-parser component-type))
          (component-type-size (component-type-size component-type)))
      (match type
        ('scalar parse-component)
        ('vec2
         (lambda (bv i)
           (vec2 (parse-component bv i)
                 (parse-component bv (+ i component-type-size)))))
        ('vec3
         (lambda (bv i)
           (vec3 (parse-component bv i)
                 (parse-component bv (+ i component-type-size))
                 (parse-component bv (+ i (* component-type-size 2))))))
        ;; TODO: Use a proper vec4 type when it exists.
        ('vec4
         (lambda (bv i)
           (vector (parse-component bv i)
                   (parse-component bv (+ i component-type-size))
                   (parse-component bv (+ i (* component-type-size 2)))
                   (parse-component bv (+ i (* component-type-size 3))))))
        ;; TODO: Use proper matrix2 type when it exists.
        ('mat2
         (lambda (bv i)
           (vector (vector (parse-component bv i)
                           (parse-component bv (+ i component-type-size)))
                   (vector (parse-component bv (+ i (* component-type-size 2)))
                           (parse-component bv (+ i (* component-type-size 3)))))))
        ;; TODO: Use proper matrix3 type when it exists.
        ('mat3
         (lambda (bv i)
           (vector (vector (parse-component bv i)
                           (parse-component bv (+ i component-type-size))
                           (parse-component bv (+ i (* component-type-size 2))))
                   (vector (parse-component bv (+ i (* component-type-size 3)))
                           (parse-component bv (+ i (* component-type-size 4)))
                           (parse-component bv (+ i (* component-type-size 5)))))))
        ('mat4
         (lambda (bv i)
           (make-matrix4 (parse-component bv i)
                         (parse-component bv (+ i component-type-size))
                         (parse-component bv (+ i (* component-type-size 2)))
                         (parse-component bv (+ i (* component-type-size 3)))
                         (parse-component bv (+ i (* component-type-size 4)))
                         (parse-component bv (+ i (* component-type-size 5)))
                         (parse-component bv (+ i (* component-type-size 6)))
                         (parse-component bv (+ i (* component-type-size 7)))
                         (parse-component bv (+ i (* component-type-size 8)))
                         (parse-component bv (+ i (* component-type-size 9)))
                         (parse-component bv (+ i (* component-type-size 10)))
                         (parse-component bv (+ i (* component-type-size 11)))
                         (parse-component bv (+ i (* component-type-size 12)))
                         (parse-component bv (+ i (* component-type-size 13)))
                         (parse-component bv (+ i (* component-type-size 14)))
                         (parse-component bv (+ i (* component-type-size 15)))))))))
  (with-mapped-typed-buffer typed-buffer
    (let* ((data (typed-buffer-data typed-buffer))
           (length (typed-buffer-length typed-buffer))
           (offset (typed-buffer-offset typed-buffer))
           (stride (typed-buffer-stride typed-buffer))
           (type (typed-buffer-type typed-buffer))
           (component-type (typed-buffer-component-type typed-buffer))
           (type-byte-size (* (type-size type)
                              (component-type-size component-type)))
           (v (make-vector length))
           (parse-element (element-parser type component-type)))
      (let loop ((i 0))
        (when (< i length)
          (let ((byte-index (+ (* i stride) offset)))
            (vector-set! v i (parse-element data byte-index)))
          (loop (+ i 1))))
      v)))


;;;
;;; Vertex Arrays
;;;

(define-record-type <vertex-array>
  (%make-vertex-array id indices attributes mode)
  vertex-array?
  (id vertex-array-id)
  (indices vertex-array-indices)
  (attributes vertex-array-attributes)
  (mode vertex-array-mode))

(set-record-type-printer! <vertex-array>
                          (lambda (array port)
                            (format port
                                    "#<vertex-array indices: ~a attributes: ~a mode: ~s>"
                                    (vertex-array-indices array)
                                    (vertex-array-attributes array)
                                    (vertex-array-mode array))))

(define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))

(define <<vertex-array>> (class-of null-vertex-array))

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

(define (free-vertex-array va)
  (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va))))

(define-method (gpu-finalize (va <<vertex-array>>))
  (free-vertex-array va))

(define (apply-vertex-array va)
  (gl-bind-vertex-array (vertex-array-id va)))

(define *vertex-array-state*
  (make-gpu-state apply-vertex-array null-vertex-array))

(define* (make-vertex-array #:key indices attributes (mode 'triangles))
  (let ((array (gpu-guard
                (%make-vertex-array (generate-vertex-array)
                                    indices
                                    attributes
                                    mode))))
    (gpu-state-set! *vertex-array-state* array)
    (for-each (match-lambda
                ((index . typed-buffer)
                 (apply-typed-buffer typed-buffer index)))
              attributes)
    (apply-typed-buffer indices)
    (gpu-state-set! *vertex-array-state* null-vertex-array)
    array))

(define (vertex-array-mode-gl array)
  (match (vertex-array-mode array)
    ('points (begin-mode points))
    ('lines (begin-mode lines))
    ('line-loop (begin-mode line-loop))
    ('line-strip (begin-mode line-strip))
    ('triangles (begin-mode triangles))
    ('triangle-strip (begin-mode triangle-strip))
    ('triangle-fan (begin-mode triangle-fan))))

(define* (render-vertices array #:optional count)
  (gpu-state-set! *vertex-array-state* array)
  (let ((indices (vertex-array-indices array)))
    (gl-draw-elements (vertex-array-mode-gl array)
                      (or count
                          (typed-buffer-length indices))
                      (typed-buffer-type-gl indices)
                      %null-pointer)))