chickadee/render/buffer.scm

   1 ;;; Chickadee Game Toolkit
   2 ;;; Copyright © 2016, 2017 David Thompson <davet@gnu.org>
   3 ;;;
   4 ;;; Chickadee is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published
   6 ;;; by the Free Software Foundation, either version 3 of the License,
   7 ;;; or (at your option) any later version.
   8 ;;;
   9 ;;; Chickadee is distributed in the hope that it will be useful, but
  10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19 ;;
  20 ;; GPU data buffers.
  21 ;;
  22 ;;; Code:
  23
  24 (define-module (chickadee render buffer)
  25   #:use-module (ice-9 format)
  26   #:use-module (ice-9 match)
  27   #:use-module (oop goops)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (srfi srfi-4)
  30   #:use-module (srfi srfi-9)
  31   #:use-module (srfi srfi-9 gnu)
  32   #:use-module (gl)
  33   #:use-module (system foreign)
  34   #:use-module (chickadee math matrix)
  35   #:use-module (chickadee math vector)
  36   #:use-module (chickadee render gl)
  37   #:use-module (chickadee render gpu)
  38   #:export (make-buffer
  39             make-streaming-buffer
  40             buffer?
  41             index-buffer?
  42             buffer-name
  43             buffer-length
  44             buffer-stride
  45             buffer-target
  46             buffer-usage
  47             buffer-data
  48             null-buffer
  49             map-buffer!
  50             unmap-buffer!
  51             with-mapped-buffer
  52             *buffer-state*
  53             make-typed-buffer
  54             make-streaming-typed-buffer
  55             typed-buffer?
  56             typed-buffer->buffer
  57             typed-buffer->vector
  58             typed-buffer-name
  59             typed-buffer-offset
  60             typed-buffer-component-type
  61             typed-buffer-normalized?
  62             typed-buffer-count
  63             typed-buffer-type
  64             typed-buffer-max
  65             typed-buffer-min
  66             typed-buffer-sparse
  67             typed-buffer-data
  68             typed-buffer-divisor
  69             map-typed-buffer!
  70             unmap-typed-buffer!
  71             with-mapped-typed-buffer
  72             make-vertex-array
  73             vertex-array?
  74             vertex-array-indices
  75             vertex-array-attributes
  76             vertex-array-mode
  77             null-vertex-array
  78             *vertex-array-state*
  79             render-vertices
  80             render-vertices/instanced))
  81
  82 ;;;
  83 ;;; Buffers
  84 ;;;
  85
  86 (define-record-type <buffer>
  87   (%make-buffer id name length stride target usage data)
  88   buffer?
  89   (id buffer-id)
  90   (name buffer-name)
  91   (length buffer-length)
  92   (stride buffer-stride)
  93   (target buffer-target)
  94   (usage buffer-usage)
  95   (data buffer-data set-buffer-data!))
  96
  97 (set-record-type-printer! <buffer>
  98                           (lambda (buffer port)
  99                             (format port
 100                                     "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
 101                                     (buffer-id buffer)
 102                                     (buffer-name buffer)
 103                                     (buffer-usage buffer)
 104                                     (buffer-target buffer)
 105                                     (buffer-length buffer)
 106                                     (buffer-stride buffer))))
 107
 108 (define null-buffer
 109   (%make-buffer 0 "null" 0 0 'vertex 'static #f))
 110
 111 (define <<buffer>> (class-of null-buffer))
 112
 113 (define (free-buffer buffer)
 114   (gl-delete-buffers 1 (u32vector (buffer-id buffer))))
 115
 116 (define-method (gpu-finalize (buffer <<buffer>>))
 117   (free-buffer buffer))
 118
 119 (define (apply-buffer buffer)
 120   (gl-bind-buffer (buffer-target-gl buffer)
 121                   (buffer-id buffer)))
 122
 123 (define *buffer-state*
 124   (make-gpu-state apply-buffer null-buffer))
 125
 126 (define (generate-buffer-gl)
 127   (let ((bv (u32vector 1)))
 128     (gl-gen-buffers 1 (bytevector->pointer bv))
 129     (u32vector-ref bv 0)))
 130
 131 (define (index-buffer? buffer)
 132   "Return #t if VIEW is an index buffer view."
 133   (eq? (buffer-target buffer) 'index))
 134
 135 (define (buffer-usage-gl buffer)
 136   (match (buffer-usage buffer)
 137     ('static (arb-vertex-buffer-object static-draw-arb))
 138     ('stream (arb-vertex-buffer-object stream-draw-arb))))
 139
 140 (define (buffer-target-gl buffer)
 141   (if (index-buffer? buffer)
 142       (arb-vertex-buffer-object element-array-buffer-arb)
 143       (arb-vertex-buffer-object array-buffer-arb)))
 144
 145 (define* (make-buffer data #:key
 146                       (name "anonymous")
 147                       (length (bytevector-length data))
 148                       (offset 0)
 149                       (stride 0)
 150                       (target 'vertex)
 151                       (usage 'static))
 152   "Upload DATA, a bytevector, to the GPU.  By default, the entire
 153 bytevector is uploaded.  A subset of the data may be uploaded by
 154 specifying the OFFSET, the index of the first byte to be uploaded, and
 155 LENGTH, the number of bytes to upload.
 156
 157 If DATA is #f, allocate LENGTH bytes of fresh GPU memory instead.
 158
 159 TARGET and USAGE are hints that tell the GPU how the buffer is
 160 intended to be used.
 161
 162 TARGET may be:
 163 - vertex: Vertex attribute data.
 164 - index: Index buffer data.
 165
 166 USAGE may be:
 167 - static: The buffer data will not be modified after creation.
 168 - stream: The buffer data will be modified frequently.
 169
 170 NAME is simply an arbitrary string for debugging purposes that is
 171 never sent to the GPU."
 172   ;; Weird bugs will occur when creating a new vertex buffer while a
 173   ;; vertex array is bound.
 174   (gpu-state-set! *vertex-array-state* null-vertex-array)
 175   (let ((buffer (gpu-guard
 176                  (%make-buffer (generate-buffer-gl)
 177                                name
 178                                length
 179                                stride
 180                                target
 181                                usage
 182                                #f))))
 183     (gpu-state-set! *buffer-state* buffer)
 184     (gl-buffer-data (buffer-target-gl buffer)
 185                     length
 186                     (if data
 187                         (bytevector->pointer data offset)
 188                         %null-pointer)
 189                     (buffer-usage-gl buffer))
 190     (gpu-state-set! *buffer-state* null-buffer)
 191     buffer))
 192
 193 (define* (make-streaming-buffer length #:key
 194                                 (name "anonymous")
 195                                 (target 'vertex))
 196   "Return a new vertex buffer of LENGTH bytes, named NAME, suitable
 197 for streaming data to the GPU every frame."
 198   (make-buffer #f #:usage 'stream #:length length #:name name #:target target))
 199
 200 (define (map-buffer! buffer)
 201   "Map the memory space for BUFFER from the GPU to the CPU, allowing
 202 the vertex buffer to be updated with new vertex data.  The
 203 'unmap-buffer!' procedure must be called to submit the new
 204 vertex buffer data back to the GPU."
 205   (let ((target (buffer-target-gl buffer))
 206         (length (buffer-length buffer))
 207         (usage (buffer-usage-gl buffer)))
 208     (gpu-state-set! *buffer-state* buffer)
 209     (when (eq? usage 'stream)
 210       ;; Orphan the buffer to avoid implicit synchronization.
 211       ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
 212       (gl-buffer-data target length %null-pointer usage))
 213     (let ((ptr (gl-map-buffer target (version-1-5 read-write))))
 214       (set-buffer-data! buffer (pointer->bytevector ptr length)))))
 215
 216 (define (unmap-buffer! buffer)
 217   "Return the mapped vertex buffer data for BUFFER to the GPU."
 218   (gpu-state-set! *buffer-state* buffer)
 219   (gl-unmap-buffer (buffer-target-gl buffer))
 220   (set-buffer-data! buffer #f))
 221
 222 (define-syntax-rule (with-mapped-buffer buffer body ...)
 223   (dynamic-wind
 224     (lambda ()
 225       (map-buffer! buffer))
 226     (lambda () body ...)
 227     (lambda ()
 228       (unmap-buffer! buffer))))
 229
 230 \f
 231 ;;;
 232 ;;; Typed Buffers
 233 ;;;
 234
 235 (define-record-type <typed-buffer>
 236   (%make-typed-buffer name buffer offset component-type
 237                       normalized? length type max min sparse divisor)
 238   typed-buffer?
 239   (name typed-buffer-name)
 240   (buffer typed-buffer->buffer)
 241   (offset typed-buffer-offset)
 242   (component-type typed-buffer-component-type)
 243   (normalized? typed-buffer-normalized?)
 244   (length typed-buffer-length)
 245   (type typed-buffer-type)
 246   (max typed-buffer-max)
 247   (min typed-buffer-min)
 248   (sparse typed-buffer-sparse)
 249   (divisor typed-buffer-divisor)) ; for instanced rendering
 250
 251 (define (typed-buffer-stride typed-buffer)
 252   (or (buffer-stride (typed-buffer->buffer typed-buffer))
 253       (* (type-size (typed-buffer-type typed-buffer))
 254          (component-type-size (typed-buffer-component-type typed-buffer)))))
 255
 256 (define (num-elements byte-length byte-offset type component-type)
 257   (inexact->exact
 258    (floor
 259     (/ (- byte-length byte-offset)
 260        (* (component-type-size component-type)
 261           (type-size type))))))
 262
 263
 264 (define* (make-typed-buffer #:key
 265                             (name "anonymous")
 266                             buffer
 267                             type
 268                             component-type
 269                             normalized?
 270                             (offset 0)
 271                             (length (num-elements (buffer-length buffer)
 272                                                   offset
 273                                                   type
 274                                                   component-type))
 275                             max
 276                             min
 277                             sparse
 278                             divisor)
 279   "Return a new typed buffer view for BUFFER starting at byte index
 280 OFFSET of LENGTH elements, where each element is of TYPE and composed
 281 of COMPONENT-TYPE values.
 282
 283 Valid values for TYPE are:
 284 - scalar: single number
 285 - vec2: 2D vector
 286 - vec3: 3D vector
 287 - vec4: 4D vector
 288 - mat2: 2x2 matrix
 289 - mat3: 3x3 matrix
 290 - mat4: 4x4 matrix
 291
 292 Valid values for COMPONENT-TYPE are:
 293
 294 - byte
 295 - unsigned-byte
 296 - short
 297 - unsigned-short
 298 - int
 299 - unsigned-int
 300 - float
 301 - double
 302
 303 DIVISOR is only needed for instanced rendering applications and
 304 represents how many instances each vertex element applies to.  A
 305 divisor of 0 means that a single element is used for every instance
 306 and is used for the data being instanced.  A divisor of 1 means that
 307 each element is used for 1 instance.  A divisor of 2 means that each
 308 element is used for 2 instances, and so on."
 309   (%make-typed-buffer name buffer offset component-type
 310                       normalized? length type max min sparse divisor))
 311
 312 (define (type-size type)
 313   (match type
 314     ('scalar 1)
 315     ('vec2 2)
 316     ('vec3 3)
 317     ((or 'vec4 'mat2) 4)
 318     ('mat3 9)
 319     ('mat4 16)))
 320
 321 (define (component-type-size component-type)
 322   (match component-type
 323     ('byte 1)
 324     ('unsigned-byte 1)
 325     ('short 2)
 326     ('unsigned-short 2)
 327     ('int 4)
 328     ('unsigned-int 4)
 329     ('float 4)
 330     ('double 8)))
 331
 332 (define* (make-streaming-typed-buffer type component-type length #:key
 333                                       (name "anonymous")
 334                                       (target 'vertex)
 335                                       data
 336                                       divisor)
 337   "Return a new typed buffer to hold LENGTH elements of TYPE whose
 338 components are comprised of COMPONENT-TYPE values.  The underlying
 339 untyped buffer is configured for GPU streaming.  Optonally, a NAME can
 340 be specified for the buffer.  If the buffer will be used for instanced
 341 rendering, the DIVISOR argument must be used to specify the rate at
 342 which attributes advance when rendering multiple instances."
 343   (let* ((buffer-length
 344           (* length (type-size type) (component-type-size component-type)))
 345          (buffer (if data
 346                      (make-buffer data
 347                                   #:name name
 348                                   #:length buffer-length
 349                                   #:usage 'stream
 350                                   #:target target)
 351                      (make-streaming-buffer buffer-length
 352                                             #:name name
 353                                             #:target target))))
 354     (make-typed-buffer #:name name
 355                        #:buffer buffer
 356                        #:type type
 357                        #:component-type component-type
 358                        #:length length
 359                        #:divisor divisor)))
 360
 361 (define (display-typed-buffer typed-buffer port)
 362   (format port "#<typed-buffer name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d>"
 363           (typed-buffer-name typed-buffer)
 364           (typed-buffer->buffer typed-buffer)
 365           (typed-buffer-type typed-buffer)
 366           (typed-buffer-component-type typed-buffer)
 367           (typed-buffer-length typed-buffer)
 368           (typed-buffer-offset typed-buffer)))
 369
 370 (set-record-type-printer! <typed-buffer> display-typed-buffer)
 371
 372 (define (typed-buffer-type-size typed-buffer)
 373   (type-size (typed-buffer-type typed-buffer)))
 374
 375 (define (typed-buffer-data typed-buffer)
 376   (buffer-data (typed-buffer->buffer typed-buffer)))
 377
 378 (define (typed-buffer-type-gl typed-buffer)
 379   (match (typed-buffer-component-type typed-buffer)
 380     ('byte (data-type byte))
 381     ('unsigned-byte (data-type unsigned-byte))
 382     ('short (data-type short))
 383     ('unsigned-short (data-type unsigned-short))
 384     ('int (data-type int))
 385     ('unsigned-int (data-type unsigned-int))
 386     ('float (data-type float))
 387     ('double (data-type double))))
 388
 389 (define (map-typed-buffer! typed-buffer)
 390   (map-buffer! (typed-buffer->buffer typed-buffer)))
 391
 392 (define (unmap-typed-buffer! typed-buffer)
 393   (unmap-buffer! (typed-buffer->buffer typed-buffer)))
 394
 395 (define-syntax-rule (with-mapped-typed-buffer typed-buffer body ...)
 396   (with-mapped-buffer (typed-buffer->buffer typed-buffer) body ...))
 397
 398 (define* (apply-typed-buffer typed-buffer #:optional attribute-index)
 399   (gpu-state-set! *buffer-state* (typed-buffer->buffer typed-buffer))
 400   ;; If there is no attribute-index, we assume this is being bound for
 401   ;; use as an index buffer.
 402   (when attribute-index
 403     (gl-enable-vertex-attrib-array attribute-index)
 404     (gl-vertex-attrib-pointer attribute-index
 405                               (typed-buffer-type-size typed-buffer)
 406                               (typed-buffer-type-gl typed-buffer)
 407                               (typed-buffer-normalized? typed-buffer)
 408                               (typed-buffer-stride typed-buffer)
 409                               (make-pointer (typed-buffer-offset typed-buffer)))
 410     (let ((divisor (typed-buffer-divisor typed-buffer)))
 411       (when divisor
 412         (gl-vertex-attrib-divisor attribute-index divisor)))))
 413
 414 ;; TODO: Handle 4-byte alignment rule for the types that need it.
 415 (define (typed-buffer->vector typed-buffer)
 416   (define (component-parser type)
 417     (match type
 418       ('byte bytevector-s8-ref)
 419       ('unsigned-byte bytevector-u8-ref)
 420       ('short
 421        (lambda (bv i)
 422          (bytevector-s16-ref bv i (native-endianness))))
 423       ('unsigned-short
 424        (lambda (bv i)
 425          (bytevector-u16-ref bv i (native-endianness))))
 426       ('unsigned-int
 427        (lambda (bv i)
 428          (bytevector-u32-ref bv i (native-endianness))))
 429       ('float bytevector-ieee-single-native-ref)))
 430   (define (element-parser type component-type)
 431     (let ((parse-component (component-parser component-type))
 432           (component-type-size (component-type-size component-type)))
 433       (match type
 434         ('scalar parse-component)
 435         ('vec2
 436          (lambda (bv i)
 437            (vec2 (parse-component bv i)
 438                  (parse-component bv (+ i component-type-size)))))
 439         ('vec3
 440          (lambda (bv i)
 441            (vec3 (parse-component bv i)
 442                  (parse-component bv (+ i component-type-size))
 443                  (parse-component bv (+ i (* component-type-size 2))))))
 444         ;; TODO: Use a proper vec4 type when it exists.
 445         ('vec4
 446          (lambda (bv i)
 447            (vector (parse-component bv i)
 448                    (parse-component bv (+ i component-type-size))
 449                    (parse-component bv (+ i (* component-type-size 2)))
 450                    (parse-component bv (+ i (* component-type-size 3))))))
 451         ;; TODO: Use proper matrix2 type when it exists.
 452         ('mat2
 453          (lambda (bv i)
 454            (vector (vector (parse-component bv i)
 455                            (parse-component bv (+ i component-type-size)))
 456                    (vector (parse-component bv (+ i (* component-type-size 2)))
 457                            (parse-component bv (+ i (* component-type-size 3)))))))
 458         ;; TODO: Use proper matrix3 type when it exists.
 459         ('mat3
 460          (lambda (bv i)
 461            (vector (vector (parse-component bv i)
 462                            (parse-component bv (+ i component-type-size))
 463                            (parse-component bv (+ i (* component-type-size 2))))
 464                    (vector (parse-component bv (+ i (* component-type-size 3)))
 465                            (parse-component bv (+ i (* component-type-size 4)))
 466                            (parse-component bv (+ i (* component-type-size 5)))))))
 467         ('mat4
 468          (lambda (bv i)
 469            (make-matrix4 (parse-component bv i)
 470                          (parse-component bv (+ i component-type-size))
 471                          (parse-component bv (+ i (* component-type-size 2)))
 472                          (parse-component bv (+ i (* component-type-size 3)))
 473                          (parse-component bv (+ i (* component-type-size 4)))
 474                          (parse-component bv (+ i (* component-type-size 5)))
 475                          (parse-component bv (+ i (* component-type-size 6)))
 476                          (parse-component bv (+ i (* component-type-size 7)))
 477                          (parse-component bv (+ i (* component-type-size 8)))
 478                          (parse-component bv (+ i (* component-type-size 9)))
 479                          (parse-component bv (+ i (* component-type-size 10)))
 480                          (parse-component bv (+ i (* component-type-size 11)))
 481                          (parse-component bv (+ i (* component-type-size 12)))
 482                          (parse-component bv (+ i (* component-type-size 13)))
 483                          (parse-component bv (+ i (* component-type-size 14)))
 484                          (parse-component bv (+ i (* component-type-size 15)))))))))
 485   (with-mapped-typed-buffer typed-buffer
 486     (let* ((data (typed-buffer-data typed-buffer))
 487            (length (typed-buffer-length typed-buffer))
 488            (offset (typed-buffer-offset typed-buffer))
 489            (stride (typed-buffer-stride typed-buffer))
 490            (type (typed-buffer-type typed-buffer))
 491            (component-type (typed-buffer-component-type typed-buffer))
 492            (type-byte-size (* (type-size type)
 493                               (component-type-size component-type)))
 494            (v (make-vector length))
 495            (parse-element (element-parser type component-type)))
 496       (let loop ((i 0))
 497         (when (< i length)
 498           (let ((byte-index (+ (* i stride) offset)))
 499             (vector-set! v i (parse-element data byte-index)))
 500           (loop (+ i 1))))
 501       v)))
 502
 503 \f
 504 ;;;
 505 ;;; Vertex Arrays
 506 ;;;
 507
 508 (define-record-type <vertex-array>
 509   (%make-vertex-array id indices attributes mode)
 510   vertex-array?
 511   (id vertex-array-id)
 512   (indices vertex-array-indices)
 513   (attributes vertex-array-attributes)
 514   (mode vertex-array-mode))
 515
 516 (set-record-type-printer! <vertex-array>
 517                           (lambda (array port)
 518                             (format port
 519                                     "#<vertex-array indices: ~a attributes: ~a mode: ~s>"
 520                                     (vertex-array-indices array)
 521                                     (vertex-array-attributes array)
 522                                     (vertex-array-mode array))))
 523
 524 (define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))
 525
 526 (define <<vertex-array>> (class-of null-vertex-array))
 527
 528 (define (generate-vertex-array)
 529   (let ((bv (u32vector 1)))
 530     (gl-gen-vertex-arrays 1 (bytevector->pointer bv))
 531     (u32vector-ref bv 0)))
 532
 533 (define (free-vertex-array va)
 534   (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va))))
 535
 536 (define-method (gpu-finalize (va <<vertex-array>>))
 537   (free-vertex-array va))
 538
 539 (define (apply-vertex-array va)
 540   (gl-bind-vertex-array (vertex-array-id va)))
 541
 542 (define *vertex-array-state*
 543   (make-gpu-state apply-vertex-array null-vertex-array))
 544
 545 (define* (make-vertex-array #:key indices attributes (mode 'triangles))
 546   "Return a new vertex array using the index data within the typed
 547 buffer INDICES and the vertex attribute data within ATTRIBUTES, an
 548 alist mapping shader attribute indices to typed buffers containing
 549 vertex data.
 550
 551 By default, the vertex array is interpreted as containing a series of
 552 triangles.  If another primtive type is desired, the MODE keyword
 553 argument may be overridden.  The following values are supported:
 554
 555 - points
 556 - lines
 557 - line-loop
 558 - line-strip
 559 - triangles
 560 - triangle-strip
 561 - triangle-fan"
 562   (let ((array (gpu-guard
 563                 (%make-vertex-array (generate-vertex-array)
 564                                     indices
 565                                     attributes
 566                                     mode))))
 567     (gpu-state-set! *vertex-array-state* array)
 568     (for-each (match-lambda
 569                 ((index . typed-buffer)
 570                  (apply-typed-buffer typed-buffer index)))
 571               attributes)
 572     (apply-typed-buffer indices)
 573     (gpu-state-set! *vertex-array-state* null-vertex-array)
 574     array))
 575
 576 (define (vertex-array-mode-gl array)
 577   (match (vertex-array-mode array)
 578     ('points (begin-mode points))
 579     ('lines (begin-mode lines))
 580     ('line-loop (begin-mode line-loop))
 581     ('line-strip (begin-mode line-strip))
 582     ('triangles (begin-mode triangles))
 583     ('triangle-strip (begin-mode triangle-strip))
 584     ('triangle-fan (begin-mode triangle-fan))))
 585
 586 (define* (render-vertices array #:optional count)
 587   (gpu-state-set! *vertex-array-state* array)
 588   (let ((indices (vertex-array-indices array)))
 589     (gl-draw-elements (vertex-array-mode-gl array)
 590                       (or count
 591                           (typed-buffer-length indices))
 592                       (typed-buffer-type-gl indices)
 593                       %null-pointer)))
 594
 595 (define* (render-vertices/instanced array instances #:optional count)
 596   (gpu-state-set! *vertex-array-state* array)
 597   (let ((indices (vertex-array-indices array)))
 598     (gl-draw-elements-instanced (vertex-array-mode-gl array)
 599                                 (or count
 600                                     (typed-buffer-length indices))
 601                                 (typed-buffer-type-gl indices)
 602                                 %null-pointer
 603                                 instances)))