path: root/chickadee/graphics.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2024 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.

(define-module (chickadee graphics)
  #:use-module ((chickadee graphics backend) #:prefix gpu:)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics buffer)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics pass)
  #:use-module (chickadee graphics pipeline)
  #:use-module (chickadee graphics primitive)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics texture)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-111)
  #:export (current-projection
            current-viewport
            current-scissor
            current-pass
            with-render-pass
            draw
            stream-draw
            flush-stream
            define-graphics-variable
            graphics-variable-ref)
  #:re-export ((gpu:gpu-limits? . gpu-limits?)
               (gpu:gpu-limits-max-texture-dimension-1d . gpu-limits-max-texture-dimension-1d)
               (gpu:gpu-limits-max-texture-dimension-2d . gpu-limits-max-texture-dimension-2d)
               (gpu:gpu-limits-max-texture-dimension-3d . gpu-limits-max-texture-dimension-3d)
               (gpu:gpu-limits-max-texture-array-layers . gpu-limits-max-texture-array-layers)
               (gpu:gpu-limits-max-sampled-textures-per-shader-stage . gpu-limits-max-sampled-textures-per-shader-stage)
               (gpu:gpu-limits-max-samplers-per-shader-stage . gpu-limits-max-samplers-per-shader-stage)
               (gpu:gpu-limits-max-uniform-buffers-per-shader-stage . gpu-limits-max-uniform-buffers-per-shader-stage)
               (gpu:gpu-limits-max-uniform-buffer-binding-size . gpu-limits-max-uniform-buffer-binding-size)
               (gpu:gpu-limits-max-bindings . gpu-limits-max-bindings)
               (gpu:gpu-limits-max-vertex-buffers . gpu-limits-max-vertex-buffers)
               (gpu:gpu-limits-max-buffer-size . gpu-limits-max-buffer-size)
               (gpu:gpu-limits-max-vertex-attributes . gpu-limits-max-vertex-attributes)
               (gpu:gpu-limits-max-vertex-buffer-array-stride . gpu-limits-max-vertex-buffer-array-stride)
               (gpu:gpu-limits-max-inter-stage-shader-components . gpu-limits-max-inter-stage-shader-components)
               (gpu:gpu-limits-max-inter-stage-shader-variables . gpu-limits-max-inter-stage-shader-variables)
               (gpu:gpu-limits-max-color-attachments . gpu-limits-max-color-attachments)
               (gpu:current-gpu . current-gpu)
               (gpu:gpu? . gpu?)
               (gpu:gpu-name . gpu-name)
               (gpu:gpu-description . gpu-description)
               (gpu:gpu-limits . gpu-limits)))

;; Private API stuff shhhhhhh...
(define buffer-handle (@@ (chickadee graphics buffer) buffer-handle))
(define texture-handle (@@ (chickadee graphics texture) texture-handle))
(define texture-view-handle (@@ (chickadee graphics texture) texture-view-handle))
(define sampler-handle (@@ (chickadee graphics texture) sampler-handle))
(define render-pipeline-handle (@@ (chickadee graphics pipeline) render-pipeline-handle))
(define <render-pipeline> (@@ (chickadee graphics pipeline) <render-pipeline>))

(define-syntax-rule (define-graphics-variable name exp)
  (define name
    (let ((cache '()))
      (define (get-it)
        (let ((gpu (gpu:current-gpu)))
          (or (assq-ref cache gpu)
              (let ((val exp))
                (set! cache (cons (cons gpu val) cache))
                val))))
      get-it)))

(define-syntax-rule (graphics-variable-ref var) (var))

(define current-projection (make-parameter #f))
(define current-viewport (make-parameter #f))
(define current-scissor (make-parameter #f))
(define current-pass (make-parameter #f))

(define-graphics-variable last-pass (box #f))

(define (begin-frame)
  (set-box! (graphics-variable-ref last-pass) #f)
  (begin-stream)
  (gpu:begin-frame (gpu:current-gpu)))

(define (end-frame view)
  (end-stream)
  (gpu:end-frame (gpu:current-gpu) (texture-view-handle view)))

(define (begin-render-pass pass)
  (define (resolve-texture-view view)
    (match view
      (#f #f)
      ((? texture-view?)
       (texture-view-handle view))
      ((? procedure?)
       (texture-view-handle (view)))))
  (match pass
    (($ <render-pass> colors depth+stencil)
     (let* ((gpu (gpu:current-gpu))
            (cmd (gpu:request-begin-render-pass-command gpu)))
       (gpu:set-begin-render-pass-command-pass! cmd pass)
       (do ((i 0 (+ i 1)))
           ((= i (vector-length colors)))
         (match (vector-ref colors i)
           (($ <color-attachment> view resolve-target op)
            (let ((view (resolve-texture-view view))
                  (resolve-target (resolve-texture-view resolve-target)))
              (gpu:begin-render-pass-command-color-attachment-set!
               cmd i view resolve-target op)))))
       (match depth+stencil
         (#f #t)
         (($ <depth+stencil-attachment> view depth-op stencil-op)
          (let ((view (resolve-texture-view view)))
            (gpu:begin-render-pass-command-depth+stencil-attachment-set!
             cmd view depth-op stencil-op))))
       (gpu:submit gpu cmd)))))

(define (end-render-pass pass)
  (let* ((gpu (gpu:current-gpu))
         (cmd (gpu:request-end-render-pass-command gpu)))
    (gpu:set-end-render-pass-command-pass! cmd pass)
    (gpu:submit gpu cmd)))

(define (draw* count instances pipeline pass viewport scissor blend-constant
               stencil-reference index-buffer vertex-buffers bindings)
  (unless (eq? count 0)
    (let* ((gpu (gpu:current-gpu))
           (cmd (gpu:request-draw-command gpu))
           (pass-box (graphics-variable-ref last-pass))
           (pass* (unbox pass-box)))
      (unless (eq? pass pass*)
        (when pass*
          (end-render-pass pass*))
        (begin-render-pass pass)
        (set-box! pass-box pass))
      (gpu:set-draw-command-pass! cmd pass)
      (gpu:set-draw-command-pipeline! cmd (render-pipeline-handle pipeline))
      (gpu:set-draw-command-viewport! cmd viewport)
      (gpu:set-draw-command-scissor! cmd scissor)
      (gpu:set-draw-command-blend-constant! cmd blend-constant)
      (gpu:set-draw-command-stencil-reference! cmd stencil-reference)
      (gpu:set-draw-command-count! cmd count)
      (gpu:set-draw-command-instances! cmd instances)
      (when index-buffer
        (gpu:set-draw-command-index-buffer! cmd (buffer-handle index-buffer)))
      (do ((i 0 (+ i 1)))
          ((= i (vector-length vertex-buffers)))
        (let ((buffer (buffer-handle (vector-ref vertex-buffers i))))
          (gpu:set-draw-command-vertex-buffer! cmd i buffer)))
      (do ((i 0 (+ i 1)))
          ((= i (vector-length bindings)))
        (match (vector-ref bindings i)
          ((? buffer? buffer)
           (gpu:set-draw-command-binding! cmd i (buffer-handle buffer)))
          ((? texture? texture)
           (gpu:set-draw-command-binding! cmd i (texture-handle texture)))
          ((? texture-view? texture)
           (gpu:set-draw-command-binding! cmd i (texture-view-handle texture)))
          ((? sampler? sampler)
           (gpu:set-draw-command-binding! cmd i (sampler-handle sampler)))
          (#f #f)))
      (gpu:submit gpu cmd))))

(define* (draw count #:key
               pipeline
               (pass (current-pass))
               (viewport (current-viewport))
               (scissor (current-scissor))
               (blend-constant black)
               (stencil-reference #xffffFFFF)
               index-buffer
               (vertex-buffers #())
               (bindings #())
               instances)
  (unless (render-pass? pass)
    (error "no render pass specified"))
  (unless (eq? count 0)
    (flush-stream)
    (draw* count instances pipeline pass viewport scissor blend-constant
           stencil-reference index-buffer vertex-buffers bindings)))


;;;
;;; Immediate mode streaming
;;;

;; This streaming interface is inspired by love2d.  The way it works
;; is that the user calls 'stream-draw' and passes along all the
;; desired pipeline and texture/sampler/buffer binding details.  If
;; the settings match what was used in the previous 'stream-draw' call
;; then the new data is simply appended to the current vertex/index
;; accumulation buffers.  If the settings do not match, then the
;; stream is flushed.  Flushing a stream issues a draw call for the
;; batch, clears the accumulation buffers and resets pipeline,
;; bindings, and counters.  Furthermore, if any non-streaming draw
;; calls are made via 'draw' or if any relevant dynamic state is
;; changed between 'stream-draw' calls then the stream is also
;; flushed.
(define-record-type <stream-state>
  (make-stream-state count vertices indices bindings bindings-length
                     pipeline-cache vertex-buffer-vec)
  stream-state?
  (count stream-state-count set-stream-state-count!)
  (vertices stream-state-vertices)
  (indices stream-state-indices)
  (bindings stream-state-bindings)
  (bindings-length stream-state-bindings-length set-stream-state-bindings-length!)
  (pipeline stream-state-pipeline set-stream-state-pipeline!)
  (pipeline-cache stream-state-pipeline-cache set-stream-state-pipeline-cache!)
  (pass stream-state-pass set-stream-state-pass!)
  (projection stream-state-projection set-stream-state-projection!)
  (viewport stream-state-viewport set-stream-state-viewport!)
  (scissor stream-state-scissor set-stream-state-scissor!)
  (vertex-buffer-vec stream-state-vertex-buffer-vec))

(define-graphics-variable stream-state
  (let ((limits (gpu:gpu-limits (gpu:current-gpu))))
    (make-stream-state 0 (make-dbuffer #:name "Stream vertices")
                       (make-dbuffer #:name "Stream indices" #:usage '(index))
                       (make-vector (gpu:gpu-limits-max-vertex-buffers limits))
                       0 '() (vector #f))))

(define %default-primitive-mode (make-primitive-mode))
(define %default-color-target (make-color-target))

(define (begin-stream)
  (match (graphics-variable-ref stream-state)
    ((and state ($ <stream-state> count vertices indices bindings))
     (dbuffer-map! vertices)
     (dbuffer-map! indices)
     (set-stream-state-count! state 0)
     (set-stream-state-pipeline! state #f)
     (set-stream-state-pass! state #f)
     (set-stream-state-projection! state #f)
     (set-stream-state-viewport! state #f)
     (set-stream-state-scissor! state #f)
     (vector-fill! bindings #f))))

(define (end-stream)
  (match (graphics-variable-ref stream-state)
    ((and state ($ <stream-state> count vertices indices bindings _ pipeline _
                                  pass projection viewport scissor vertex-vec))
     (dbuffer-unmap! vertices)
     (dbuffer-unmap! indices)
     (vector-set! vertex-vec 0 (dbuffer-buffer vertices))
     (unless (eq? count 0)
       (draw* (/ (dbuffer-length indices) 4) #f pipeline pass
              viewport scissor black #xffffFFFF (dbuffer-buffer indices)
              vertex-vec bindings)
       (set-stream-state-count! state 0)))))

(define (flush-stream)
  (end-stream)
  (begin-stream))

(define* (stream-draw #:key
                      count
                      shader
                      (primitive %default-primitive-mode)
                      (color-target %default-color-target)
                      depth+stencil
                      (vertex-layout #())
                      (binding-layout #())
                      (bindings #()))
  (match (graphics-variable-ref stream-state)
    ((and state
          ($ <stream-state> _ vertices indices bindings* bindings-length
                            pipeline cache pass projection viewport scissor))
     (define-inlinable (pipeline-equal? pipeline)
       (match pipeline
         (($ <render-pipeline> _ _ _ _ shader* primitive* color-target*
                               depth+stencil* vertex-layout* binding-layout*)
          (and (eq? shader shader*)
               (equal? primitive primitive*)
               (equal? color-target color-target*)
               (equal? depth+stencil depth+stencil*)
               (equal? vertex-layout vertex-layout*)
               (equal? binding-layout binding-layout*)))))
     (let ((pass* (current-pass))
           (projection* (current-projection))
           (viewport* (current-viewport))
           (scissor* (current-scissor)))
       ;; Check if *all* settings are the same as the previous stream
       ;; draw call, including various bits of dynamic state.  If
       ;; anything is different, draw the batch, clear it, and start
       ;; over with the new settings.
       (unless (and pipeline
                    (pipeline-equal? pipeline)
                    (= (vector-length bindings) bindings-length)
                    (let loop ((i 0))
                      (or (= i (vector-length bindings))
                          (and (eq? (vector-ref bindings i)
                                    (vector-ref bindings* i))
                               (loop (+ i 1)))))
                    (eq? pass pass*)
                    (eq? viewport viewport*)
                    (eq? scissor scissor*)
                    (eq? projection projection*))
         (let ((pipeline
                (let loop ((pipelines cache))
                  (match pipelines
                    (()
                     (let ((new (make-render-pipeline
                                 #:name "Stream render pipeline"
                                 #:shader shader
                                 #:primitive primitive
                                 #:color-target color-target
                                 #:depth+stencil depth+stencil
                                 #:vertex-layout vertex-layout
                                 #:binding-layout binding-layout)))
                       (set-stream-state-pipeline-cache! state (cons new cache))
                       new))
                    ((pipeline . rest)
                     (if (pipeline-equal? pipeline)
                         pipeline
                         (loop rest)))))))
           (flush-stream)
           (set-stream-state-pipeline! state pipeline)
           (set-stream-state-pass! state pass*)
           (set-stream-state-projection! state projection*)
           (set-stream-state-viewport! state viewport*)
           (set-stream-state-scissor! state scissor*)
           (set-stream-state-bindings-length! state (vector-length bindings))
           (vector-fill! bindings* #f)
           (do ((i 0 (+ i 1)))
               ((= i (vector-length bindings)))
             (vector-set! bindings* i (vector-ref bindings i))))))
     (let ((count* (stream-state-count state)))
       (set-stream-state-count! state (+ count* count))
       (values vertices indices count*)))))