path: root/chickadee/graphics/buffer.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016-2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; GPU data buffers.
;;
;;; Code:

(define-module (chickadee graphics buffer)
  #:use-module (chickadee data bytestruct)
  #:use-module ((chickadee graphics backend) #:prefix gpu:)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math vector)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (system foreign)
  #:export (make-buffer
            destroy-buffer
            buffer?
            buffer-available?
            buffer-destroyed?
            buffer-mapped?
            buffer-length
            buffer-usage
            buffer-write!
            map-buffer
            unmap-buffer
            bytevector->buffer

            make-dbuffer
            dbuffer?
            dbuffer-mapped?
            dbuffer-buffer
            dbuffer-capacity
            dbuffer-length
            dbuffer-clear!
            dbuffer-map!
            dbuffer-unmap!
            dbuffer-reserve!
            dbuffer-pack!
            dbuffer-append!
            dbuffer-pack-indices-quad!
            dbuffer-append-indices-quad!

            make-dynamic-buffer
            dynamic-buffer?
            dynamic-buffer-buffer
            dynamic-buffer-data
            dynamic-buffer-capacity
            dynamic-buffer-count
            dynamic-buffer-next!
            dynamic-buffer-clear!
            dynamic-buffer-map!
            dynamic-buffer-unmap!
            dynamic-buffer-import!

            define-geometry-type
            geometry-type?
            geometry-type-attributes
            geometry-type-stride

            make-geometry
            geometry?
            geometry-vertex-buffers
            geometry-index-buffer
            geometry-vertex-count
            geometry-index-count
            geometry-begin!
            geometry-begin*
            geometry-end!
            geometry-end*
            with-geometry
            with-geometry*
            geometry-index-set!
            geometry-index-append!
            geometry-import!))

(define-record-type <buffer>
  (%make-buffer gpu handle name length usage state map-state)
  buffer?
  (gpu buffer-gpu)
  (handle buffer-handle)
  (name buffer-name)
  (length buffer-length)
  (usage buffer-usage)
  (state buffer-state set-buffer-state!)
  (map-state buffer-map-state set-buffer-map-state!)
  (mapping buffer-mapping set-buffer-mapping!))

(define (print-buffer buffer port)
  (match buffer
    (($ <buffer> _ _ name length usage _)
     (format #t "#<buffer name: ~s length: ~s usage: ~s>"
             name length usage))))

(set-record-type-printer! <buffer> print-buffer)

(define (buffer-available? buffer)
  (eq? (buffer-state buffer) 'available))

(define (buffer-destroyed? buffer)
  (eq? (buffer-state buffer) 'destroyed))

(define (buffer-mapped? buffer)
  (eq? (buffer-map-state buffer) 'mapped))

;; TODO: Validate length is > 0 and < max length.
;; TODO: Validate usage flags.
(define* (make-buffer length #:key name (usage '(vertex)))
  (let* ((gpu (gpu:current-gpu))
         (handle (gpu:make-buffer gpu length usage)))
    (%make-buffer gpu handle name length usage 'available 'unmapped)))

;; TODO: Ensure buffer is unmapped first.
(define (destroy-buffer buffer)
  (unless (buffer-destroyed? buffer)
    (gpu:destroy-buffer (buffer-gpu buffer) (buffer-handle buffer))
    (set-buffer-state! buffer 'destroyed)))

(define (write-buffer buffer at data start length)
  (gpu:write-buffer (buffer-gpu buffer) (buffer-handle buffer)
                    0 data 0 length))

(define (map-buffer buffer mode offset length)
  (let ((bv (gpu:map-buffer (buffer-gpu buffer) (buffer-handle buffer)
                            mode offset length)))
    (set-buffer-mapping! buffer bv)
    (set-buffer-map-state! buffer 'mapped)
    bv))

(define (unmap-buffer buffer)
  (when (buffer-mapped? buffer)
    (gpu:unmap-buffer (buffer-gpu buffer) (buffer-handle buffer))
    (set-buffer-mapping! buffer #f)))

(define* (bytevector->buffer data #:key name (usage '(vertex)))
  (let* ((length (bytevector-length data))
         (buffer (make-buffer length #:name name #:usage usage)))
    (write-buffer buffer 0 data 0 length)
    buffer))

;; (define (render-vertices array count offset)
;;   (with-graphics-state! ((g:vertex-array array))
;;     (let ((indices (vertex-array-indices array)))
;;       (if indices
;;           (begin
;;             (apply-vertex-attribute indices #f)
;;             (gl-draw-elements (vertex-array-mode-gl array)
;;                               (or count
;;                                   (vertex-attribute-length indices))
;;                               (vertex-attribute-type-gl indices)
;;                               (vertex-attribute-offset-pointer indices)))
;;           (gl-draw-arrays (vertex-array-mode-gl array)
;;                           offset
;;                           (or count
;;                               (vertex-attribute-length
;;                                (assv-ref (vertex-array-attributes array)
;;                                          0))))))))

;; (define (render-vertices/instanced array instances count offset)
;;   (with-graphics-state! ((g:vertex-array array))
;;     (let ((indices (vertex-array-indices array)))
;;       (if indices
;;           (begin
;;             (apply-vertex-attribute indices #f)
;;             (gl-draw-elements-instanced (vertex-array-mode-gl array)
;;                                         (or count
;;                                             (vertex-attribute-length indices))
;;                                         (vertex-attribute-type-gl indices)
;;                                         (vertex-attribute-offset-pointer indices)
;;                                         instances))
;;           (gl-draw-arrays-instanced (vertex-array-mode-gl array)
;;                                     offset count instances)))))


;;;
;;; Dynamic Buffers
;;;

;; A layer on top of vertex buffers to handle buffer streaming with
;; dynamic buffer expansion.
(define-record-type <dynamic-buffer>
  (%make-dynamic-buffer buffer stride capacity count)
  dynamic-buffer?
  (buffer dynamic-buffer-buffer set-dynamic-buffer-buffer!)
  (stride dynamic-buffer-stride)
  (data dynamic-buffer-data set-dynamic-buffer-data!)
  (capacity dynamic-buffer-capacity set-dynamic-buffer-capacity!)
  (count dynamic-buffer-count set-dynamic-buffer-count!))

(define* (make-dynamic-buffer #:key name capacity stride (usage '(vertex)))
  (let* ((buffer (make-buffer (* capacity stride)
                              #:name name
                              #:usage usage)))
    (%make-dynamic-buffer buffer stride capacity 0)))

(define-inlinable (dynamic-buffer-bounds-check dbuffer i)
  (unless (< i (dynamic-buffer-count dbuffer))
    (error "index out of bounds" i)))

(define (expand-dynamic-buffer dbuffer)
  (match dbuffer
    (($ <dynamic-buffer> old-buffer stride old-data old-capacity count)
     (let* ((new-capacity (* old-capacity 2))
            (new-length (* new-capacity stride))
            (new-buffer (make-buffer new-length
                                     #:name (buffer-name old-buffer)
                                     #:usage (buffer-usage old-buffer))))
       (set-dynamic-buffer-buffer! dbuffer new-buffer)
       (set-dynamic-buffer-capacity! dbuffer new-capacity)
       (when old-data
         (unmap-buffer old-buffer)
         (let ((new-data (map-buffer new-buffer 'write 0 new-length)))
           (bytevector-copy! old-data 0 new-data 0 (bytevector-length old-data))
           (set-dynamic-buffer-data! dbuffer new-data)))))))

(define-inlinable (dynamic-buffer-next! dbuffer n)
  (let ((count (dynamic-buffer-count dbuffer)))
    (let resize ()
      (let ((capacity (dynamic-buffer-capacity dbuffer)))
        (when (> (+ count n) capacity)
          (expand-dynamic-buffer dbuffer)
          (resize))))
    (set-dynamic-buffer-count! dbuffer (+ count n))
    count))

(define (dynamic-buffer-clear! dbuffer)
  (set-dynamic-buffer-count! dbuffer 0))

(define (dynamic-buffer-map! dbuffer)
  (dynamic-buffer-clear! dbuffer)
  (let* ((buffer (dynamic-buffer-buffer dbuffer))
         (bv (map-buffer buffer 'write 0 (buffer-length buffer))))
    (set-dynamic-buffer-data! dbuffer bv)))

(define (dynamic-buffer-unmap! dbuffer)
  (unmap-buffer (dynamic-buffer-buffer dbuffer))
  (set-dynamic-buffer-data! dbuffer #f))

(define (dynamic-buffer-import! dbuffer bv start end)
  (let ((stride (dynamic-buffer-stride dbuffer))
        (copy-count (- end start)))
    (let resize ()
      (let ((capacity (dynamic-buffer-capacity dbuffer)))
        (when (< capacity copy-count)
          (begin
            (expand-dynamic-buffer dbuffer)
            (resize)))))
    (bytevector-copy! bv
                      (* start stride)
                      (dynamic-buffer-data dbuffer)
                      0
                      (* copy-count stride))
    (set-dynamic-buffer-count! dbuffer copy-count)))


;;;
;;; Builder???
;;;

(define-record-type <dbuffer>
  (%make-dbuffer buffer capacity length)
  dbuffer?
  (buffer dbuffer-buffer set-dbuffer-buffer!)
  (data dbuffer-data set-dbuffer-data!)
  (capacity dbuffer-capacity set-dbuffer-capacity!)
  (length dbuffer-length set-dbuffer-length!))

(define (dbuffer-mapped? dbuffer)
  (bytevector? (dbuffer-data dbuffer)))

(define* (make-dbuffer #:key name (capacity 128) (usage '(vertex)))
  (let* ((buffer (make-buffer capacity #:name name #:usage usage)))
    (%make-dbuffer buffer capacity 0)))

(define (expand-dbuffer dbuffer)
  (match dbuffer
    (($ <dbuffer> old-buffer old-data old-capacity old-length)
     (let* ((new-capacity (* old-capacity 2))
            (new-buffer (make-buffer new-capacity
                                     #:name (buffer-name old-buffer)
                                     #:usage (buffer-usage old-buffer))))
       (set-dbuffer-buffer! dbuffer new-buffer)
       (set-dbuffer-capacity! dbuffer new-capacity)
       (when old-data
         (unmap-buffer old-buffer)
         (let ((new-data (map-buffer new-buffer 'write 0 new-capacity)))
           (bytevector-copy! old-data 0 new-data 0 old-length)
           (set-dbuffer-data! dbuffer new-data)))))))

(define (dbuffer-reserve! dbuffer n)
  (match dbuffer
    (($ <dbuffer> _ _ capacity length)
     (if (> (+ length n) capacity)
         (begin
           (expand-dbuffer dbuffer)
           (dbuffer-reserve! dbuffer n))
         (begin
           (set-dbuffer-length! dbuffer (+ length n))
           length)))))

(define (dbuffer-clear! dbuffer)
  (set-dbuffer-length! dbuffer 0))

(define (dbuffer-map! dbuffer)
  (dbuffer-clear! dbuffer)
  (let* ((buffer (dbuffer-buffer dbuffer))
         (bv (map-buffer buffer 'write 0 (buffer-length buffer))))
    (set-dbuffer-data! dbuffer bv)))

(define (dbuffer-unmap! dbuffer)
  (unmap-buffer (dbuffer-buffer dbuffer))
  (set-dbuffer-data! dbuffer #f))

;; TODO: Add setters and define appenders as reserve + set
(define-syntax-rule (dbuffer-pack! <type> (elem ...) dbuffer offset)
  (if (exact-integer? offset)
      (bytestruct-pack! <type> (elem ...) (dbuffer-data dbuffer) offset)
      (error "expected exact integer" offset)))

(define-syntax-rule (dbuffer-append! <type> (elem ...) dbuffer)
  (let ((offset (dbuffer-reserve! dbuffer (bytestruct-sizeof <type>))))
    (dbuffer-pack! <type> (elem ...) dbuffer offset)))

(define-inlinable (dbuffer-pack-indices-quad! dbuffer offset i)
  (unless (exact-integer? offset)
    (error "expected exact integer" offset))
  (let ((bv (dbuffer-data dbuffer)))
    (bytevector-u32-native-set! bv offset i)
    (bytevector-u32-native-set! bv (+ offset 4) (+ i 2))
    (bytevector-u32-native-set! bv (+ offset 8) (+ i 3))
    (bytevector-u32-native-set! bv (+ offset 12) i)
    (bytevector-u32-native-set! bv (+ offset 16) (+ i 1))
    (bytevector-u32-native-set! bv (+ offset 20) (+ i 2))))

(define-inlinable (dbuffer-append-indices-quad! dbuffer i)
  (dbuffer-pack-indices-quad! dbuffer (dbuffer-reserve! dbuffer 24) i))


;;;
;;; Geometry Builder
;;;

(define-record-type <geometry>
  (%make-geometry vertex-buffers index-buffer)
  geometry?
  (vertex-buffers geometry-vertex-buffers)
  (index-buffer geometry-index-buffer))

(define-record-type <geometry-type>
  (make-geometry-type attributes stride)
  geometry-type?
  (attributes geometry-type-attributes)
  (stride geometry-type-stride))

(define* (make-geometry types capacity #:key (index? #t) (usage 'stream)
                        (index-usage usage) (index-capacity capacity)
                        (mode 'triangles))
  (define (scalar-type? type)
    (memq type '(float double int unsigned-int)))
  (define (make-dynamic-buffer* type . args)
    (apply make-dynamic-buffer
           #:name "vertex"
           #:capacity capacity
           #:usage '(index vertex)
           #:stride (geometry-type-stride type)
           args))
  (define (filter-kwargs l keep)
    (let loop ((l l))
      (match l
        (() '())
        ((kw arg . rest)
         (if (memq kw keep)
             (cons* kw arg (loop rest))
             (loop rest))))))
  (define (canonicalize-types)
    (if (geometry-type? types)
        (list (list types))
        (map (lambda (x)
               (match x
                 ((_ ...)
                  x)
                 (type
                  (list type))))
             types)))
  (define (build-vertex-buffers types)
    (map (match-lambda
           ((type . args)
            (cons type
                  (make-dynamic-buffer #:name "vertex"
                                       #:capacity capacity
                                       #:usage '(vertex)
                                       #:stride (geometry-type-stride type)))))
         types))
  (let* ((index-buffer (and index?
                            (make-dynamic-buffer #:name "index"
                                                 #:capacity index-capacity
                                                 #:usage '(index)
                                                 #:stride 4)))
         (types (canonicalize-types))
         (vertex-buffers (build-vertex-buffers types)))
    (%make-geometry vertex-buffers index-buffer)))

(define (geometry-vertex-buffer geometry type)
  (assq-ref (geometry-vertex-buffers geometry) type))

(define-inlinable (geometry-set-index! geometry i j)
  (let ((buffer (geometry-index-buffer geometry)))
    (dynamic-buffer-bounds-check buffer i)
    (bytevector-u32-native-set! (dynamic-buffer-data buffer) i j)))

(define-syntax-rule (geometry-index-append! geometry i ...)
  (let* ((buffer (geometry-index-buffer geometry))
         (n (length '(i ...)))
         (j (dynamic-buffer-next! buffer n))
         (bv (dynamic-buffer-data buffer)))
    (begin
      (u32vector-set! bv j i)
      (set! j (+ j 1)))
    ...))

(define (geometry-import! geometry type bv start end)
  (dynamic-buffer-import! (geometry-vertex-buffer geometry type) bv start end))

(define-inlinable (geometry-vertex-count geometry type)
  (dynamic-buffer-count (geometry-vertex-buffer geometry type)))

(define-inlinable (geometry-index-count geometry)
  (dynamic-buffer-count (geometry-index-buffer geometry)))

(define (geometry-begin* geometry type)
  (dynamic-buffer-map!
   (if (eq? type 'index)
       (geometry-index-buffer geometry)
       (geometry-vertex-buffer geometry type))))

(define (geometry-end* geometry type)
  (dynamic-buffer-unmap!
   (if (eq? type 'index)
       (geometry-index-buffer geometry)
       (geometry-vertex-buffer geometry type))))

(define-syntax-rule (with-geometry* geometry (type ...) body ...)
  (begin
    (geometry-begin* geometry type) ...
    body ...
    (geometry-end* geometry type) ...))

(define (geometry-begin! geometry)
  (define (begin:map buffer-pair)
    (dynamic-buffer-map! (cdr buffer-pair)))
  (let ((index-buffer (geometry-index-buffer geometry)))
    (for-each begin:map (geometry-vertex-buffers geometry))
    (when index-buffer
      (dynamic-buffer-map! index-buffer))))

(define (geometry-end! geometry)
  (define (end:unmap buffer-pair)
    (dynamic-buffer-unmap! (cdr buffer-pair)))
  (let ((index-buffer (geometry-index-buffer geometry)))
    (when index-buffer
      (dynamic-buffer-unmap! index-buffer))
    (for-each end:unmap (geometry-vertex-buffers geometry))))

(define-syntax-rule (with-geometry geometry body ...)
  (begin
    (geometry-begin! geometry)
    body ...
    (geometry-end! geometry)))

;; Thanks to wingo for his define-packed-struct macro in guile-opengl
;; that I used as a reference while making this.
(define-syntax-parameter g-append (syntax-rules ()))
(define-syntax define-geometry-type
  (lambda (stx)
    (define (type-size type)
      (case type
        ((float int unsigned-int) 4)
        ((double) 8)
        ((vec2) (* (type-size 'float) 2))
        ((vec3) (* (type-size 'float) 3))
        ((vec4) (* (type-size 'float) 4))))
    (define (type-getter type)
      (case type
        ((float) #'bytevector-ieee-single-native-ref)
        ((double) #'bytevector-ieee-double-native-ref)
        ((int) #'bytevector-s32-native-ref)
        ((unsigned-int) #'bytevector-u32-native-ref)))
    (define (type-setter type)
      (case type
        ((float) #'bytevector-ieee-single-native-set!)
        ((double) #'bytevector-ieee-double-native-set!)
        ((int) #'bytevector-s32-native-set!)
        ((unsigned-int) #'bytevector-u32-native-set!)))
    (define (expand-attribute name type)
      (case type
        ((float int unsigned-int)
         (list (list name type)))
        ((vec2)
         `((,(symbol-append name ':x) float)
           (,(symbol-append name ':y) float)))
        ((vec3)
         `((,(symbol-append name ':x) float)
           (,(symbol-append name ':y) float)
           (,(symbol-append name ':z) float)))
        ((vec4)
         `((,(symbol-append name ':x) float)
           (,(symbol-append name ':y) float)
           (,(symbol-append name ':z) float)
           (,(symbol-append name ':w) float)))))
    (define (expand-attributes attrs)
      (append-map (match-lambda
                    ((name type _)
                     (expand-attribute name type)))
                  attrs))
    (define* (build-fields primitives #:optional (offset 0))
      (match primitives
        (() '())
        (((name type) . rest)
         (cons (list name type offset
                     (type-getter type)
                     (type-setter type))
               (build-fields rest (+ offset (type-size type)))))))
    (define (build-attributes attrs)
      (let loop ((attrs attrs)
                 (offset 0))
        (match attrs
          (() '())
          (((name type) . rest)
           (cons (list name type offset)
                 (loop rest (+ offset (type-size type))))))))
    (define (compute-stride types)
      (fold (lambda (type sum) (+ (type-size type) sum)) 0 types))
    (syntax-case stx ()
      ((_ type-name getter setter appender (name type) ...)
       (let* ((attributes (build-attributes
                           (syntax->datum #'((name type) ...))))
              (stride* (compute-stride (syntax->datum #'(type ...))))
              (fields (build-fields (expand-attributes attributes))))
         (with-syntax ((((attr-name attr-type attr-offset) ...)
                        (datum->syntax stx attributes))
                       (((field-name field-type field-offset field-getter field-setter) ...)
                        (datum->syntax stx fields))
                       (type-stride stride*))
           #'(begin
               (define type-name
                 (make-geometry-type '((attr-name attr-type attr-offset) ...)
                                     type-stride))
               (define-syntax-rule (getter field geometry i)
                 (let ((dbuffer (geometry-vertex-buffer geometry type-name)))
                   (dynamic-buffer-bounds-check dbuffer i)
                   (case 'field
                     ((field-name)
                      (field-getter
                       (dynamic-buffer-data dbuffer (+ (* i type-stride)
                                                       field-offset))))
                     ...
                     (else (error "unknown field" 'field)))))
               (define-syntax-rule (setter geometry field i x)
                 (let ((dbuffer (geometry-vertex-buffer geometry type-name)))
                   (dynamic-buffer-bounds-check dbuffer i)
                   (case 'field
                     ((field-name)
                      (field-setter (dynamic-buffer-data dbuffer)
                                    (+ (* i type-stride) field-offset)
                                    x))
                     ...
                     (else (error "unknown field" 'field)))))
               (define-syntax appender
                 (syntax-rules ::: ()
                   ((_ geometry (field-name ...) :::)
                    (let* ((dbuffer (geometry-vertex-buffer geometry type-name))
                           (n (length '((field-name ...) :::)))
                           (i (dynamic-buffer-next! dbuffer n))
                           (bv (dynamic-buffer-data dbuffer)))
                      (let ((offset (* i type-stride)))
                        (field-setter bv (+ offset field-offset) field-name)
                        ...
                        (set! i (+ i 1)))
                      :::)))))))))))