path: root/chickadee/graphics/gpu.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2019 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/>.

(define-module (chickadee graphics gpu)
  #:use-module (chickadee graphics gl)
  #:use-module (gl)
  #:use-module (gl enums)
  #:use-module (oop goops)
  #:use-module (srfi srfi-9)
  #:use-module (system foreign)
  #:export (make-gpu-state
            gpu-state-ref
            gpu-state-set!

            gpu-finalize
            gpu-guard
            gpu-reap!

            make-gpu
            current-gpu
            gpu?
            gpu-gl-context
            gpu-gl-version
            gpu-glsl-version
            gpu-max-texture-size
            gpu-blend-mode
            gpu-depth-test
            gpu-stencil-test
            gpu-framebuffer
            gpu-shader
            gpu-texture
            gpu-vertex-buffer
            gpu-vertex-array
            gpu-viewport
            gpu-multisample
            gpu-color-mask
            set-gpu-blend-mode!
            set-gpu-depth-test!
            set-gpu-stencil-test!
            set-gpu-framebuffer!
            set-gpu-shader!
            set-gpu-texture!
            set-gpu-vertex-buffer!
            set-gpu-vertex-array!
            set-gpu-viewport!
            set-gpu-multisample!
            set-gpu-color-mask!))


;;;
;;; GPU state
;;;

(define-record-type <gpu-state>
  (make-gpu-state bind value)
  gpu-state?
  (bind gpu-state-bind)
  (value gpu-state-ref %gpu-state-set!))

(define (gpu-state-set! state new-value)
  (unless (eq? new-value (gpu-state-ref state))
    ((gpu-state-bind state) new-value)
    (%gpu-state-set! state new-value)))

;;;
;;; GPU finalizers
;;;

(define-generic gpu-finalize)

(define *gpu-guardian* (make-guardian))

(define (gpu-guard obj)
  "Protect OBJ for the garbage collector until OBJ has been deleted
from the GPU's memory."
  (*gpu-guardian* obj)
  obj)

(define (gpu-reap!)
  "Delete all GPU objects that are no longer being referenced."
  (let loop ((obj (*gpu-guardian*)))
    (when obj
      (gpu-finalize obj)
      (loop (*gpu-guardian*)))))


;;;
;;; GPU
;;;

(define-record-type <gpu>
  (%make-gpu gl-context
             gl-version
             glsl-version
             max-texture-size
             blend-mode
             depth-test
             stencil-test
             framebuffer
             shader
             textures
             vertex-buffer
             vertex-array
             viewport
             multisample
             color-mask)
  gpu?
  (gl-context gpu-gl-context)
  (gl-version gpu-gl-version)
  (glsl-version gpu-glsl-version)
  (max-texture-size gpu-max-texture-size)
  (blend-mode %gpu-blend-mode)
  (depth-test %gpu-depth-test)
  (stencil-test %gpu-stencil-test)
  (framebuffer %gpu-framebuffer)
  (shader %gpu-shader)
  (textures gpu-textures)
  (vertex-buffer %gpu-vertex-buffer)
  (vertex-array %gpu-vertex-array)
  (viewport %gpu-viewport)
  (multisample %gpu-multisample)
  (color-mask %gpu-color-mask))

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

(define (max-texture-size)
  (let ((bv (make-s32vector 1)))
    (gl-get-integer-v (get-p-name max-texture-size)
                      (bytevector->pointer bv))
    (s32vector-ref bv 0)))

(define (apply-multisample multisample?)
  (if multisample?
      (gl-enable (version-1-3 multisample))
      (gl-disable (version-1-3 multisample))))

(define (make-gpu gl-context)
  (define (extract-version attr)
    (car (string-split (pointer->string (gl-get-string attr)) #\space)))
  (let ((textures (make-vector 32))
        ;; Lazily resolve bindings to avoid circular dependencies.
        (blend-module (resolve-interface '(chickadee graphics blend)))
        (depth-module (resolve-interface '(chickadee graphics depth)))
        (stencil-module (resolve-interface '(chickadee graphics stencil)))
        (buffer-module (resolve-interface '(chickadee graphics buffer)))
        (framebuffer-module (resolve-interface '(chickadee graphics framebuffer)))
        (shader-module (resolve-interface '(chickadee graphics shader)))
        (texture-module (resolve-interface '(chickadee graphics texture)))
        (viewport-module (resolve-interface '(chickadee graphics viewport)))
        (color-module (resolve-interface '(chickadee graphics color)))
        (gl-version (extract-version (string-name version)))
        (glsl-version (extract-version (version-2-0 shading-language-version))))
    ;; Create state for 32 texture units.
    (let loop ((i 0))
      (when (< i 32)
        (vector-set! textures i
                     (let ((apply-texture (module-ref texture-module 'apply-texture)))
                       (make-gpu-state (lambda (texture)
                                         (apply-texture i texture))
                                       (module-ref texture-module 'null-texture))))
        (loop (+ i 1))))
    (%make-gpu gl-context
               gl-version
               glsl-version
               (max-texture-size)
               (make-gpu-state (module-ref blend-module 'apply-blend-mode)
                               'replace)
               (make-gpu-state (module-ref depth-module 'apply-depth-test) #f)
               (make-gpu-state (module-ref stencil-module 'apply-stencil-test) #f)
               (make-gpu-state (module-ref framebuffer-module 'apply-framebuffer)
                               (module-ref framebuffer-module 'null-framebuffer))
               (make-gpu-state (module-ref shader-module 'apply-shader)
                               (module-ref shader-module 'null-shader))
               textures
               (make-gpu-state (module-ref buffer-module 'apply-buffer)
                               (module-ref buffer-module 'null-buffer))
               (make-gpu-state (module-ref buffer-module 'apply-vertex-array)
                               (module-ref buffer-module 'null-vertex-array))
               (make-gpu-state (module-ref viewport-module 'apply-viewport)
                               (module-ref viewport-module 'null-viewport))
               (make-gpu-state apply-multisample #f)
               (make-gpu-state (module-ref color-module 'apply-color-mask)
                               (module-ref color-module 'default-color-mask)))))

(define-syntax-rule (define-gpu-getter name ref)
  (define (name gpu)
    (gpu-state-ref (ref gpu))))

(define-gpu-getter gpu-blend-mode %gpu-blend-mode)
(define-gpu-getter gpu-depth-test %gpu-depth-test)
(define-gpu-getter gpu-stencil-test %gpu-stencil-test)
(define-gpu-getter gpu-framebuffer %gpu-framebuffer)
(define-gpu-getter gpu-shader %gpu-shader)
(define-gpu-getter gpu-vertex-buffer %gpu-vertex-buffer)
(define-gpu-getter gpu-vertex-array %gpu-vertex-array)
(define-gpu-getter gpu-viewport %gpu-viewport)
(define-gpu-getter gpu-multisample %gpu-multisample)
(define-gpu-getter gpu-color-mask %gpu-color-mask)

(define-syntax-rule (define-gpu-setter name ref)
  (define (name gpu x)
    (gpu-state-set! (ref gpu) x)))

(define-gpu-setter set-gpu-blend-mode! %gpu-blend-mode)
(define-gpu-setter set-gpu-depth-test! %gpu-depth-test)
(define-gpu-setter set-gpu-stencil-test! %gpu-stencil-test)
(define-gpu-setter set-gpu-framebuffer! %gpu-framebuffer)
(define-gpu-setter set-gpu-shader! %gpu-shader)
(define-gpu-setter set-gpu-vertex-buffer! %gpu-vertex-buffer)
(define-gpu-setter set-gpu-vertex-array! %gpu-vertex-array)
(define-gpu-setter set-gpu-viewport! %gpu-viewport)
(define-gpu-setter set-gpu-multisample! %gpu-multisample)
(define-gpu-setter set-gpu-color-mask! %gpu-color-mask)

(define (gpu-texture gpu texture-unit)
  (gpu-state-ref (vector-ref (gpu-textures gpu) texture-unit)))

(define (set-gpu-texture! gpu texture-unit texture)
  (gpu-state-set! (vector-ref (gpu-textures gpu) texture-unit) texture))