path: root/chickadee/graphics/backend.scm

;;; Chickadee Game Toolkit
;;; Copyright © 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
;;
;; Graphics backend.
;;
;;; Code:

(define-module (chickadee graphics backend)
  #:use-module (chickadee data pool)
  #:use-module (chickadee graphics color)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (<draw-command>
            draw-command?
            draw-command-pipeline
            draw-command-pass
            draw-command-viewport
            draw-command-scissor
            draw-command-blend-constant
            draw-command-stencil-reference
            draw-command-start
            draw-command-count
            draw-command-instances
            draw-command-index-buffer
            set-draw-command-pipeline!
            set-draw-command-pass!
            set-draw-command-viewport!
            set-draw-command-scissor!
            set-draw-command-blend-constant!
            set-draw-command-stencil-reference!
            set-draw-command-start!
            set-draw-command-count!
            set-draw-command-instances!
            set-draw-command-index-buffer!
            set-draw-command-vertex-buffer!
            set-draw-command-binding!

            <begin-render-pass-command>
            begin-render-pass-command?
            begin-render-pass-command-pass
            set-begin-render-pass-command-pass!
            begin-render-pass-command-color-attachment-set!
            begin-render-pass-command-depth+stencil-attachment-set!

            <end-render-pass-command>
            end-render-pass-command?
            end-render-pass-command-pass
            set-end-render-pass-command-pass!

            make-gpu-limits
            gpu-limits?
            gpu-limits-max-texture-dimension-1d
            gpu-limits-max-texture-dimension-2d
            gpu-limits-max-texture-dimension-3d
            gpu-limits-max-texture-array-layers
            gpu-limits-max-sampled-textures-per-shader-stage
            gpu-limits-max-samplers-per-shader-stage
            gpu-limits-max-uniform-buffers-per-shader-stage
            gpu-limits-max-uniform-buffer-binding-size
            gpu-limits-max-bindings
            gpu-limits-max-vertex-buffers
            gpu-limits-max-buffer-size
            gpu-limits-max-vertex-attributes
            gpu-limits-max-vertex-buffer-array-stride
            gpu-limits-max-inter-stage-shader-components
            gpu-limits-max-inter-stage-shader-variables
            gpu-limits-max-color-attachments

            current-gpu
            make-gpu
            gpu?
            gpu-name
            gpu-description
            gpu-limits
            begin-frame
            end-frame
            make-buffer
            destroy-buffer
            map-buffer
            unmap-buffer
            write-buffer
            make-texture
            destroy-texture
            write-texture
            make-texture-view
            destroy-texture-view
            make-sampler
            destroy-sampler
            make-shader
            destroy-shader
            make-render-pipeline
            destroy-render-pipeline
            request-begin-render-pass-command
            request-end-render-pass-command
            request-draw-command
            submit))


;;;
;;; GPU commands
;;;

;; TODO: Pool commands and re-use them each frame.

(define (make-vector* k thunk)
  (let ((v (make-vector k)))
    (do ((i 0 (+ i 1)))
        ((= i (vector-length v)))
      (vector-set! v i (thunk)))
    v))

(define-record-type <begin-render-pass-command>
  (make-begin-render-pass-command color-attachments depth+stencil-attachment)
  begin-render-pass-command?
  (pass begin-render-pass-command-pass set-begin-render-pass-command-pass!)
  (color-attachments begin-render-pass-command-color-attachments)
  (depth+stencil-attachment begin-render-pass-command-depth+stencil-attachment))

(define (fresh-begin-render-pass-command max-color-attachments)
  (make-begin-render-pass-command (make-vector* max-color-attachments
                                                (lambda () (make-vector 3 #f)))
                                  (make-vector 3 #f)))

(define (begin-render-pass-command-color-attachment-set! cmd i view
                                                         resolve-target op)
  (let ((v (vector-ref (begin-render-pass-command-color-attachments cmd) i)))
    (vector-set! v 0 view)
    (vector-set! v 1 resolve-target)
    (vector-set! v 2 op)))

(define (begin-render-pass-command-depth+stencil-attachment-set! cmd view
                                                                 depth-op
                                                                 stencil-op)
  (let ((v (begin-render-pass-command-depth+stencil-attachment cmd)))
    (vector-set! v 0 view)
    (vector-set! v 1 depth-op)
    (vector-set! v 2 stencil-op)))

(define-record-type <end-render-pass-command>
  (make-end-render-pass-command)
  end-render-pass-command?
  (pass end-render-pass-command-pass set-end-render-pass-command-pass!))

(define (fresh-end-render-pass-command)
  (make-end-render-pass-command))

(define-record-type <draw-command>
  (make-draw-command start count vertex-buffers bindings)
  draw-command?
  (pipeline draw-command-pipeline set-draw-command-pipeline!)
  (pass draw-command-pass set-draw-command-pass!)
  (viewport draw-command-viewport set-draw-command-viewport!)
  (scissor draw-command-scissor set-draw-command-scissor!)
  (blend-constant draw-command-blend-constant set-draw-command-blend-constant!)
  (stencil-reference draw-command-stencil-reference!
                     set-draw-command-stencil-reference!)
  (start draw-command-start set-draw-command-start!)
  (count draw-command-count set-draw-command-count!)
  (instances draw-command-instances set-draw-command-instances!)
  (index-buffer draw-command-index-buffer set-draw-command-index-buffer!)
  (vertex-buffers draw-command-vertex-buffers)
  (bindings draw-command-bindings))

(define (set-draw-command-vertex-buffer! cmd i buffer)
  (vector-set! (draw-command-vertex-buffers cmd) i buffer))

(define (set-draw-command-binding! cmd i obj)
  (vector-set! (draw-command-bindings cmd) i obj))


;;;
;;; GPU backend
;;;

(define-record-type <gpu-limits>
  (%make-gpu-limits max-texture-dimension-1d
                    max-texture-dimension-2d
                    max-texture-dimension-3d
                    max-texture-array-layers
                    max-sampled-textures-per-shader-stage
                    max-samplers-per-shader-stage
                    max-uniform-buffers-per-shader-stage
                    max-uniform-buffer-binding-size
                    max-bindings
                    max-vertex-buffers
                    max-buffer-size
                    max-vertex-attributes
                    max-vertex-buffer-array-stride
                    max-inter-stage-shader-components
                    max-inter-stage-shader-variables
                    max-color-attachments)
  gpu-limits?
  (max-texture-dimension-1d gpu-limits-max-texture-dimension-1d)
  (max-texture-dimension-2d gpu-limits-max-texture-dimension-2d)
  (max-texture-dimension-3d gpu-limits-max-texture-dimension-3d)
  (max-texture-array-layers gpu-limits-max-texture-array-layers)
  (max-sampled-textures-per-shader-stage
   gpu-limits-max-sampled-textures-per-shader-stage)
  (max-samplers-per-shader-stage gpu-limits-max-samplers-per-shader-stage)
  (max-uniform-buffers-per-shader-stage gpu-limits-max-uniform-buffers-per-shader-stage)
  (max-uniform-buffer-binding-size gpu-limits-max-uniform-buffer-binding-size)
  (max-bindings gpu-limits-max-bindings)
  (max-vertex-buffers gpu-limits-max-vertex-buffers)
  (max-buffer-size gpu-limits-max-buffer-size)
  (max-vertex-attributes gpu-limits-max-vertex-attributes)
  (max-vertex-buffer-array-stride gpu-limits-max-vertex-buffer-array-stride)
  (max-inter-stage-shader-components gpu-limits-max-inter-stage-shader-components)
  (max-inter-stage-shader-variables gpu-limits-max-inter-stage-shader-variables)
  (max-color-attachments gpu-limits-max-color-attachments))

(define* (make-gpu-limits #:key
                          max-texture-dimension-1d
                          max-texture-dimension-2d
                          max-texture-dimension-3d
                          max-texture-array-layers
                          max-sampled-textures-per-shader-stage
                          max-samplers-per-shader-stage
                          max-uniform-buffers-per-shader-stage
                          max-uniform-buffer-binding-size
                          max-bindings
                          max-vertex-buffers
                          max-buffer-size
                          max-vertex-attributes
                          max-vertex-buffer-array-stride
                          max-inter-stage-shader-components
                          max-inter-stage-shader-variables
                          max-color-attachments)
  (%make-gpu-limits max-texture-dimension-1d
                    max-texture-dimension-2d
                    max-texture-dimension-3d
                    max-texture-array-layers
                    max-sampled-textures-per-shader-stage
                    max-samplers-per-shader-stage
                    max-uniform-buffers-per-shader-stage
                    max-uniform-buffer-binding-size
                    max-bindings
                    max-vertex-buffers
                    max-buffer-size
                    max-vertex-attributes
                    max-vertex-buffer-array-stride
                    max-inter-stage-shader-components
                    max-inter-stage-shader-variables
                    max-color-attachments))

(define-record-type <gpu>
  (%make-gpu name
             description
             limits
             internal
             begin-frame
             end-frame
             make-buffer
             destroy-buffer
             map-buffer
             unmap-buffer
             write-buffer
             make-texture
             destroy-texture
             write-texture
             make-texture-view
             destroy-texture-view
             make-sampler
             destroy-sampler
             make-shader
             destroy-shader
             make-render-pipeline
             destroy-render-pipeline
             submit
             draw-command-pool)
  gpu?
  (name gpu-name)
  (description gpu-description)
  (limits gpu-limits)
  (internal gpu-internal)
  (begin-frame gpu-begin-frame)
  (end-frame gpu-end-frame)
  (make-buffer gpu-make-buffer)
  (destroy-buffer gpu-destroy-buffer)
  (map-buffer gpu-map-buffer)
  (unmap-buffer gpu-unmap-buffer)
  (write-buffer gpu-write-buffer)
  (make-texture gpu-make-texture)
  (destroy-texture gpu-destroy-texture)
  (write-texture gpu-write-texture)
  (make-texture-view gpu-make-texture-view)
  (destroy-texture-view gpu-destroy-texture-view)
  (make-sampler gpu-make-sampler)
  (destroy-sampler gpu-destroy-sampler)
  (make-shader gpu-make-shader)
  (destroy-shader gpu-destroy-shader)
  (make-render-pipeline gpu-make-render-pipeline)
  (destroy-render-pipeline gpu-destroy-render-pipeline)
  (submit gpu-submit)
  (draw-command-pool gpu-draw-command-pool))

(define (print-gpu gpu port)
  (format port "#<gpu ~a>" (gpu-name gpu)))

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

(define (nop1 x) #t)

(define-syntax unimplemented
  (lambda (x)
    (syntax-case x ()
      ((_ name)
       (with-syntax ((msg (string-append (symbol->string
                                          (syntax->datum #'name))
                                         " unimplemented")))
         #'(lambda args (error msg)))))))

(define* (make-gpu name description internal #:key
                   limits
                   (begin-frame nop1)
                   (end-frame nop1)
                   (make-buffer (unimplemented make-buffer))
                   (destroy-buffer (unimplemented destroy-buffer))
                   (map-buffer (unimplemented map-buffer))
                   (unmap-buffer (unimplemented unmap-buffer))
                   (write-buffer (unimplemented write-buffer))
                   (make-texture (unimplemented make-texture))
                   (destroy-texture (unimplemented destroy-texture))
                   (write-texture (unimplemented write-texture))
                   (make-texture-view (unimplemented make-texture-view))
                   (destroy-texture-view (unimplemented destroy-texture-view))
                   (make-sampler (unimplemented make-sampler))
                   (destroy-sampler (unimplemented destroy-sampler))
                   (make-shader (unimplemented make-shader))
                   (destroy-shader (unimplemented destroy-shader))
                   (make-render-pipeline (unimplemented make-render-pipeline))
                   (destroy-render-pipeline (unimplemented destroy-render-pipeline))
                   (submit (unimplemented submit)))
  (let ((max-vertex-buffers (gpu-limits-max-vertex-buffers limits))
        (max-bindings (gpu-limits-max-bindings limits)))
    (define (fresh-draw-command)
      (make-draw-command 0 0 (make-vector max-vertex-buffers)
                         (make-vector max-bindings)))
    (define (init-draw-command cmd)
      (set-draw-command-pipeline! cmd #f)
      (set-draw-command-pass! cmd #f)
      (set-draw-command-viewport! cmd #f)
      (set-draw-command-scissor! cmd #f)
      (set-draw-command-blend-constant! cmd black)
      (set-draw-command-stencil-reference! cmd #xffffFFFF)
      (set-draw-command-start! cmd 0)
      (set-draw-command-count! cmd 0)
      (set-draw-command-index-buffer! cmd #f)
      (vector-fill! (draw-command-vertex-buffers cmd) #f)
      (vector-fill! (draw-command-bindings cmd) #f))
    (%make-gpu name
               description
               limits
               internal
               begin-frame
               end-frame
               make-buffer
               destroy-buffer
               map-buffer
               unmap-buffer
               write-buffer
               make-texture
               destroy-texture
               write-texture
               make-texture-view
               destroy-texture-view
               make-sampler
               destroy-sampler
               make-shader
               destroy-shader
               make-render-pipeline
               destroy-render-pipeline
               submit
               (make-pool draw-command? fresh-draw-command init-draw-command))))

(define current-gpu (make-parameter #f))

(define-syntax-rule (define-delegate name getter args ...)
  (define (name backend args ...)
    ((getter backend) (gpu-internal backend) args ...)))

(define-delegate begin-frame gpu-begin-frame)
(define-delegate end-frame gpu-end-frame view)

(define-delegate make-buffer gpu-make-buffer length usage)
(define-delegate destroy-buffer gpu-destroy-buffer buffer)
(define-delegate map-buffer gpu-map-buffer buffer mode offset length)
(define-delegate unmap-buffer gpu-unmap-buffer buffer)
(define-delegate write-buffer gpu-write-buffer
  buffer buffer-offset data data-offset length)

(define-delegate make-texture gpu-make-texture
  width height depth mip-levels samples dimension format)
(define-delegate destroy-texture gpu-destroy-texture texture)
(define-delegate write-texture gpu-write-texture
  texture x y z width height depth mip-level format data offset)

(define-delegate make-texture-view gpu-make-texture-view
  texture format dimension aspect base-mip-level mip-levels base-layer layers)
(define-delegate destroy-texture-view gpu-destroy-texture-view view)

(define-delegate make-sampler gpu-make-sampler
  address-mode-u address-mode-v address-mode-w
  mag-filter min-filter mipmap-filter)
(define-delegate destroy-sampler gpu-destroy-sampler sampler)

(define-delegate make-shader gpu-make-shader source)
(define-delegate destroy-shader gpu-destroy-shader shader)

(define-delegate make-render-pipeline gpu-make-render-pipeline
  shader primitive color-target depth+stencil vertex-layout binding-layout)
(define-delegate destroy-render-pipeline gpu-destroy-render-pipeline pipeline)

(define (request-begin-render-pass-command gpu)
  (fresh-begin-render-pass-command
   (gpu-limits-max-color-attachments (gpu-limits gpu))))

(define (request-end-render-pass-command gpu)
  (fresh-end-render-pass-command))

(define (request-draw-command gpu)
  (pool-borrow (gpu-draw-command-pool gpu)))

(define (submit gpu command)
  ((gpu-submit gpu) (gpu-internal gpu) command)
  (cond
   ((draw-command? command)
    (pool-return (gpu-draw-command-pool gpu) command))
   (else (values))))