path: root/chickadee/graphics/gpu.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:
;;
;; Abstraction over OpenGL state.
;;
;;; Code:

(define-module (chickadee graphics gpu)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics gl)
  #:use-module (chickadee math rect)
  #:use-module (gl)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (system foreign)
  #:export (blend-mode?
            blend-mode-equation
            blend-mode-source-function
            blend-mode-destination-function
            blend:alpha
            blend:multiply
            blend:subtract
            blend:add
            blend:lighten
            blend:darken
            blend:screen
            blend:replace

            front-face?
            front-face-winding
            front-face:cw
            front-face:ccw

            cull-face-mode?
            cull-face-mode-front?
            cull-face-mode-back?
            cull-face:none
            cull-face:back
            cull-face:front
            cull-face:front+back

            polygon-mode?
            polygon-mode-front
            polygon-mode-back
            polygon:fill
            polygon:line
            polygon:point

            make-color-mask
            color-mask?
            color-mask-red?
            color-mask-green?
            color-mask-blue?
            color-mask-alpha?
            color-mask:all
            color-mask:none
            color-mask:red
            color-mask:green
            color-mask:blue
            color-mask:alpha

            make-depth-test
            depth-test?
            depth-test-write?
            depth-test-function
            depth-test-near
            depth-test-far
            depth-test:default

            make-stencil-test
            stencil-test?
            stencil-test-mask-front
            stencil-test-mask-back
            stencil-test-function-front
            stencil-test-function-back
            stencil-test-function-mask-front
            stencil-test-function-mask-back
            stencil-test-reference-front
            stencil-test-reference-back
            stencil-test-on-fail-front
            stencil-test-on-fail-back
            stencil-test-on-depth-fail-front
            stencil-test-on-depth-fail-back
            stencil-test-on-pass-front
            stencil-test-on-pass-back
            stencil-test:default

            make-window-rect
            window-rect?
            window-rect-x
            window-rect-y
            window-rect-width
            window-rect-height
            window-rect:empty

            fresh-gpu-framebuffer
            free-gpu-framebuffer
            gpu-framebuffer?
            gpu-framebuffer-id
            gpu-framebuffer:null

            fresh-gpu-renderbuffer
            free-gpu-renderbuffer
            gpu-renderbuffer?
            gpu-renderbuffer-id
            gpu-renderbuffer:null

            fresh-gpu-buffer
            free-gpu-buffer
            gpu-buffer?
            gpu-buffer-id
            gpu-buffer-target
            gpu-buffer:null

            fresh-gpu-vertex-array
            free-gpu-vertex-array
            gpu-vertex-array?
            gpu-vertex-array-id
            gpu-vertex-array:null

            fresh-gpu-texture
            free-gpu-texture
            gpu-texture?
            gpu-texture-id
            gpu-texture-target
            gpu-texture:null

            fresh-gpu-shader
            free-gpu-shader
            gpu-shader?
            gpu-shader-id
            gpu-shader:null

            fresh-gpu-program
            free-gpu-program
            gpu-program?
            gpu-program-id
            gpu-program:null

            make-gpu
            gpu?
            gpu-gl-context
            gpu-gl-version
            gpu-glsl-version
            gpu-max-texture-size
            gpu-max-texture-units
            gpu-front-face
            gpu-blend-mode
            gpu-cull-face-mode
            gpu-polygon-mode
            gpu-color-mask
            gpu-depth-test
            gpu-stencil-test
            gpu-scissor-test
            gpu-multisample?
            gpu-viewport
            gpu-clear-color
            gpu-framebuffer
            gpu-renderbuffer
            gpu-buffer
            gpu-vertex-array
            gpu-program
            gpu-texture
            set-gpu-front-face!
            set-gpu-blend-mode!
            set-gpu-cull-face-mode!
            set-gpu-polygon-mode!
            set-gpu-color-mask!
            set-gpu-depth-test!
            set-gpu-stencil-test!
            set-gpu-scissor-test!
            set-gpu-multisample!
            set-gpu-viewport!
            set-gpu-clear-color!
            set-gpu-framebuffer!
            set-gpu-renderbuffer!
            set-gpu-buffer!
            set-gpu-vertex-array!
            set-gpu-program!
            set-gpu-texture!
            gpu-gc
            gpu-reset!))


;;;
;;; GPU settings
;;;

(define-syntax symbol->enum
  (syntax-rules ()
    ((_ (x enum)) (error "symbol->enum: no match for" x))
    ((_ (x enum) (sym name override-enum) . rest)
     (if (eq? x 'sym) (override-enum name) (symbol->enum (x enum) . rest)))
    ((_ (x enum) (sym name) . rest)
     (if (eq? x 'sym) (enum name) (symbol->enum (x enum) . rest)))
    ((_ (x enum) (sym) . rest)
     (symbol->enum (x enum) (sym sym) . rest))))

(define-syntax enum->symbol
  (syntax-rules ()
    ((_ (n enum)) (error "enum->symbol: no match for" n))
    ((_ (n enum) (sym name override-enum) . rest)
     (if (eqv? n (override-enum name)) 'sym (enum->symbol (n enum) . rest)))
    ((_ (n enum) (sym name) . rest)
     (if (eqv? n (enum name)) 'sym (enum->symbol (n enum) . rest)))
    ((_ (n enum) (name) . rest)
     (enum->symbol (n enum) (name name) . rest))))

(define-syntax-rule (define-enum-converters enum ->enum ->symbol clause ...)
  (begin
    (define (->enum sym)
      (symbol->enum (sym enum) clause ...))
    (define (->symbol n)
      (enum->symbol (n enum) clause ...))))

(define-syntax-rule (define-config-type name
                      constructor
                      pred
                      ((raw-field raccessor) ...)
                      ((enum-field %eaccessor eaccessor ->gl ->scheme) ...))
  (begin
    (define-record-type name
      (%make raw-field ... enum-field ...)
      pred
      (raw-field raccessor) ...
      (enum-field %eaccessor) ...)
    (define (constructor raw-field ... enum-field ...)
      (%make raw-field ... (->gl enum-field) ...))
    (define (eaccessor obj)
      (->scheme (%eaccessor obj)))
    ...))

(define-enum-converters blend-equation-mode-ext
  symbol->blend-equation
  blend-equation->symbol
  (add func-add-ext)
  (subtract func-subtract-ext)
  (reverse-subtract func-reverse-subtract-ext)
  (min min-ext)
  (max max-ext)
  (alpha-min alpha-min-sgix)
  (alpha-max alpha-max-sgix))

(define-enum-converters blending-factor-src
  symbol->blend-factor-source
  blend-factor-source->symbol
  (zero)
  (one)
  (destination-color dst-color)
  (one-minus-destination-color one-minus-dst-color)
  (source-alpha-saturate src-alpha-saturate)
  (source-alpha src-alpha)
  (one-minus-source-alpha one-minus-src-alpha)
  (destination-alpha dst-alpha)
  (one-minus-destination-alpha one-minus-dst-alpha)
  (constant-color constant-color-ext)
  (one-minus-constant-color one-minus-constant-color-ext)
  (contstant-alpha constant-alpha-ext)
  (one-minus-constant-alpha one-minus-constant-alpha-ext))

(define-enum-converters blending-factor-dest
  symbol->blend-factor-destination
  blend-factor-destination->symbol
  (zero)
  (one)
  (source-color src-color)
  (one-minus-source-color one-minus-src-color)
  (source-alpha src-alpha)
  (one-minus-source-alpha one-minus-src-alpha)
  (destination-alpha dst-alpha)
  (one-minus-destination-alpha one-minus-dst-alpha)
  (constant-color constant-color-ext)
  (one-minus-constant-color one-minus-constant-color-ext)
  (contstant-alpha constant-alpha-ext)
  (one-minus-constant-alpha one-minus-constant-alpha-ext))

(define-config-type <blend-mode>
  make-blend-mode
  blend-mode?
  ()
  ((equation %blend-mode-equation
             blend-mode-equation
             symbol->blend-equation
             blend-equation->symbol)
   (source %blend-mode-source-function
           blend-mode-source-function
           symbol->blend-factor-source
           blend-factor-source->symbol)
   (destination %blend-mode-destination-function
                blend-mode-destination-function
                symbol->blend-factor-destination
                blend-factor-destination->symbol)))

(define (bind-blend-mode blend-mode)
  (match blend-mode
    (#f (gl-disable (enable-cap blend)))
    (($ <blend-mode> equation src dest)
     (gl-enable (enable-cap blend))
     (gl-blend-equation equation)
     (gl-blend-func src dest))))

(define blend:alpha (make-blend-mode 'add 'source-alpha 'one-minus-source-alpha))
(define blend:multiply (make-blend-mode 'add 'destination-color 'zero))
(define blend:subtract (make-blend-mode 'reverse-subtract 'one 'zero))
(define blend:add (make-blend-mode 'add 'one 'one))
(define blend:lighten (make-blend-mode 'max 'one 'zero))
(define blend:darken (make-blend-mode 'min 'one 'zero))
(define blend:screen (make-blend-mode 'add 'one 'one-minus-source-color))
(define blend:replace (make-blend-mode 'add 'one 'zero))

(define-enum-converters front-face-direction
  symbol->front-face-direction
  front-face-direction->symbol
  (cw)
  (ccw))

(define-config-type <front-face>
  make-front-face
  front-face
  ()
  ((winding %front-face-winding
            front-face-winding
            symbol->front-face-direction
            front-face-direction->symbol)))

(define (bind-front-face front-face)
  (gl-front-face (%front-face-winding front-face)))

(define front-face:cw (make-front-face 'cw))
(define front-face:ccw (make-front-face 'ccw))

(define-config-type <cull-face-mode>
  make-cull-face-mode
  cull-face-mode?
  ((front? cull-face-mode-front?)
   (back? cull-face-mode-back?))
  ())

(define (bind-cull-face-mode mode)
  (match mode
    (($ <cull-face-mode> #t #t)
     (gl-enable (enable-cap cull-face))
     (gl-cull-face (cull-face-mode front-and-back)))
    (($ <cull-face-mode> #t #f)
     (gl-enable (enable-cap cull-face))
     (gl-cull-face (cull-face-mode front)))
    (($ <cull-face-mode> #f #t)
     (gl-enable (enable-cap cull-face))
     (gl-cull-face (cull-face-mode back)))
    (_
     (gl-disable (enable-cap cull-face)))))

(define cull-face:none (make-cull-face-mode #f #f))
(define cull-face:back (make-cull-face-mode #f #t))
(define cull-face:front (make-cull-face-mode #t #f))
(define cull-face:front+back (make-cull-face-mode #t #t))

(define-enum-converters polygon-mode
  symbol->polygon-mode
  polygon-mode->symbol
  (fill)
  (line)
  (point))

(define-config-type <polygon-mode>
  make-polygon-mode
  polygon-mode?
  ()
  ((front %polygon-mode-front
          polygon-mode-front
          symbol->polygon-mode
          polygon-mode->symbol)
   (back %polygon-mode-back
         polygon-mode-back
         symbol->polygon-mode
         polygon-mode->symbol)))

(define (bind-polygon-mode mode)
  (match mode
    (($ <polygon-mode> front back)
     (if (= front back)
         (gl-polygon-mode (cull-face-mode front-and-back) front)
         (begin
           (gl-polygon-mode (cull-face-mode front) front)
           (gl-polygon-mode (cull-face-mode back) back))))))

(define polygon:fill (make-polygon-mode 'fill 'fill))
(define polygon:line (make-polygon-mode 'line 'line))
(define polygon:point (make-polygon-mode 'point 'point))

(define-config-type <color-mask>
  make-color-mask
  color-mask?
  ((red? color-mask-red?)
   (green? color-mask-green?)
   (blue? color-mask-blue?)
   (alpha? color-mask-alpha?))
  ())

(define (bind-color-mask mask)
  (gl-color-mask (color-mask-red? mask)
                 (color-mask-green? mask)
                 (color-mask-blue? mask)
                 (color-mask-alpha? mask)))

(define color-mask:all (make-color-mask #t #t #t #t))
(define color-mask:none (make-color-mask #f #f #f #f))
(define color-mask:red (make-color-mask #t #f #f #f))
(define color-mask:green (make-color-mask #f #t #f #f))
(define color-mask:blue (make-color-mask #f #f #t #f))
(define color-mask:alpha (make-color-mask #f #f #f #t))

(define-enum-converters depth-function
  symbol->depth-function
  depth-function->symbol
  (always)
  (never)
  (= equal)
  (!= notequal)
  (< less)
  (<= lequal)
  (> greater)
  (>= gequal))

(define-config-type <depth-test>
  %make-depth-test
  depth-test?
  ((near depth-test-near)
   (far depth-test-far)
   (write? depth-test-write?))
  ((function %depth-test-function
             depth-test-function
             symbol->depth-function
             depth-function->symbol)))

(define* (make-depth-test #:key (near 0.0) (far 1.0) (write? #t) (function '<))
  (%make-depth-test near far write? function))

(define (bind-depth-test depth-test)
  (match depth-test
    (#f (gl-disable (enable-cap depth-test)))
    (($ <depth-test> near far write? func)
     (gl-enable (enable-cap depth-test))
     (gl-depth-func func)
     (gl-depth-mask write?)
     (gl-depth-range near far))))

(define depth-test:default (make-depth-test))

(define-enum-converters stencil-op
  symbol->stencil-op
  stencil-op->symbol
  (zero)
  (keep)
  (replace)
  (invert)
  (increment incr)
  (decrement decr)
  (increment-wrap incr-wrap version-1-4)
  (decrement-wrap decr-wrap version-1-4))

(define-enum-converters stencil-function
  symbol->stencil-function
  stencil-function->symbol
  (always)
  (never)
  (= equal)
  (!= notequal)
  (< less)
  (<= lequal)
  (> greater)
  (>= gequal))

(define-config-type <stencil-test>
  %make-stencil-test
  stencil-test?
  ((mask-front stencil-test-mask-front)
   (mask-back stencil-test-mask-back)
   (function-mask-front stencil-test-function-mask-front)
   (function-mask-back stencil-test-function-mask-back)
   (reference-front stencil-test-reference-front)
   (reference-back stencil-test-reference-back))
  ((function-front %stencil-test-function-front
                   stencil-test-function-front
                   symbol->stencil-function
                   stencil-function->symbol)
   (function-back %stencil-test-function-back
                  stencil-test-function-back
                  symbol->stencil-function
                  stencil-function->symbol)
   (on-fail-front %stencil-test-on-fail-front
                  stencil-test-on-fail-front
                  symbol->stencil-op
                  stencil-op->symbol)
   (on-fail-back %stencil-test-on-fail-back
                 stencil-test-on-fail-back
                 symbol->stencil-op
                 stencil-op->symbol)
   (on-depth-fail-front %stencil-test-on-depth-fail-front
                        stencil-test-on-depth-fail-front
                        symbol->stencil-op
                        stencil-op->symbol)
   (on-depth-fail-back %stencil-test-on-depth-fail-back
                       stencil-test-on-depth-fail-back
                       symbol->stencil-op
                       stencil-op->symbol)
   (on-pass-front %stencil-test-on-pass-front
                  stencil-test-on-pass-front
                  symbol->stencil-op
                  stencil-op->symbol)
   (on-pass-back %stencil-test-on-pass-back
                 stencil-test-on-pass-back
                 symbol->stencil-op
                 stencil-op->symbol)))

(define* (make-stencil-test #:key (mask #xff) (function 'always)
                            (function-mask #xff) (reference 0)
                            (on-fail 'keep) (on-depth-fail 'keep) (on-pass 'keep)
                            (mask-front mask) (mask-back mask)
                            (function-front function) (function-back function)
                            (function-mask-front function-mask)
                            (function-mask-back function-mask)
                            (reference-front reference)
                            (reference-back reference)
                            (on-fail-front on-fail) (on-fail-back on-fail)
                            (on-depth-fail-front on-depth-fail)
                            (on-depth-fail-back on-depth-fail)
                            (on-pass-front on-pass) (on-pass-back on-pass))
  (%make-stencil-test mask-front mask-back
                      function-mask-front function-mask-back
                      reference-front reference-back
                      function-front function-back
                      on-fail-front on-fail-back
                      on-depth-fail-front on-depth-fail-back
                      on-pass-front on-pass-back))

(define (bind-stencil-test stencil-test)
  (match stencil-test
    (#f (gl-disable (enable-cap stencil-test)))
    (($ <stencil-test> mask-front mask-back
                       function-mask-front function-mask-back
                       reference-front reference-back
                       function-front function-back
                       on-fail-front on-fail-back
                       on-depth-fail-front on-depth-fail-back
                       on-pass-front on-pass-back)
     (gl-enable (enable-cap stencil-test))
     ;; Mask
     (gl-stencil-mask-separate (cull-face-mode front) mask-front)
     (gl-stencil-mask-separate (cull-face-mode back) mask-back)
     ;; Function
     (gl-stencil-func-separate (cull-face-mode front)
                               function-front reference-front mask-front)
     (gl-stencil-func-separate (cull-face-mode back)
                               function-back reference-back mask-back)
     ;; Operation
     (gl-stencil-op-separate (cull-face-mode front)
                             on-fail-front on-depth-fail-front on-pass-front)
     (gl-stencil-op-separate (cull-face-mode back)
                             on-fail-back on-depth-fail-back on-pass-back))))

(define stencil-test:default (make-stencil-test))

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

(define (bind-clear-color color)
  (gl-clear-color (color-r color)
                  (color-g color)
                  (color-b color)
                  (color-a color)))

(define-record-type <window-rect>
  (make-window-rect x y width height)
  window-rect?
  (x window-rect-x)
  (y window-rect-y)
  (width window-rect-width)
  (height window-rect-height))

(define window-rect:empty (make-window-rect 0 0 0 0))

(define (bind-scissor-test rect)
  (match rect
    (#f (gl-disable (enable-cap scissor-test)))
    (($ <window-rect> x y width height)
     (gl-enable (enable-cap scissor-test))
     (gl-scissor x y width height))))

(define (bind-viewport rect)
  (match rect
    (($ <window-rect> x y width height)
     (gl-viewport x y width height))))


;;;
;;; GPU objects
;;;

(define-syntax-rule (define-gpu-type name
                      (constructor (cparams ...) cargs ...)
                      (free free-exp)
                      (bind bind-exp)
                      (null null-args ...)
                      pred
                      (field accessor) ...)
  (begin
    (define-record-type name
      (%make field ... deleted?)
      pred
      (field accessor) ...
      (deleted? %deleted? %set-deleted!))
    (define (constructor cparams ...)
      (%make cargs ... #f))
    (define null (%make null-args ... #f))
    (define (free obj)
      (match obj
        (($ name field ... deleted?)
         (unless deleted?
           free-exp
           (%set-deleted! obj #t)))))
    (define (bind obj)
      (match obj
        (($ name field ... deleted?)
         (if deleted?
             (error "GPU object has been deleted" obj)
             bind-exp))))))

(define-gpu-type <gpu-framebuffer>
  (make-gpu-framebuffer () (gl-generate-framebuffer))
  (free-gpu-framebuffer (gl-delete-framebuffer id))
  (bind-gpu-framebuffer (gl-bind-framebuffer (version-3-0 framebuffer) id))
  (gpu-framebuffer:null 0)
  gpu-framebuffer?
  (id gpu-framebuffer-id))

(define-gpu-type <gpu-renderbuffer>
  (make-gpu-renderbuffer () (gl-generate-renderbuffer))
  (free-gpu-renderbuffer (gl-delete-renderbuffer id))
  (bind-gpu-renderbuffer (gl-bind-renderbuffer (version-3-0 renderbuffer) id))
  (gpu-renderbuffer:null 0)
  gpu-renderbuffer?
  (id gpu-renderbuffer-id))

(define-gpu-type <gpu-buffer>
  (make-gpu-buffer (target)
                   (gl-generate-buffer)
                   (match target
                     ('index (version-1-5 element-array-buffer))
                     ('vertex (version-1-5 array-buffer))))
  (free-gpu-buffer (gl-delete-buffer id))
  (bind-gpu-buffer (gl-bind-buffer target id))
  (gpu-buffer:null 0 (version-1-5 array-buffer))
  gpu-buffer?
  (id gpu-buffer-id)
  (target gpu-buffer-target))

(define-gpu-type <gpu-vertex-array>
  (make-gpu-vertex-array () (gl-generate-vertex-array))
  (free-gpu-vertex-array (gl-delete-vertex-array id))
  (bind-gpu-vertex-array (gl-bind-vertex-array id))
  (gpu-vertex-array:null 0)
  gpu-vertex-array?
  (id gpu-vertex-array-id))

(define-gpu-type <gpu-texture>
  (make-gpu-texture (target)
                   (gl-generate-texture)
                   (match target
                     ('2d (texture-target texture-2d))
                     ('cube-map (version-1-3 texture-cube-map))))
  (free-gpu-texture (gl-delete-texture id))
  (bind-gpu-texture (gl-bind-texture target id))
  (gpu-texture:null 0 (texture-target texture-2d))
  gpu-texture?
  (id gpu-texture-id)
  (target gpu-texture-target))

(define-gpu-type <gpu-shader>
  (make-gpu-shader (type)
                   (gl-create-shader
                    (match type
                      ('vertex (version-2-0 vertex-shader))
                      ('fragment (version-2-0 fragment-shader)))))
  (free-gpu-shader (gl-delete-shader id))
  ;; Shaders are not bound but rather attached to a program, which is
  ;; bound, so this is a stub.
  (bind-gpu-shader #t)
  (gpu-shader:null 0)
  gpu-shader?
  (id gpu-shader-id))

(define-gpu-type <gpu-program>
  (make-gpu-program () (gl-create-program))
  (free-gpu-program (gl-delete-program id))
  (bind-gpu-program (gl-use-program id))
  (gpu-program:null 0)
  gpu-program?
  (id gpu-program-id))


;;;
;;; State management
;;;

;; An abstraction over the annoying OpenGL context state.  Minimizes
;; GPU calls by keeping a local cache.
(define-record-type <gpu>
  (%make-gpu gl-context gl-version glsl-version max-texture-size
             max-texture-units guardian textures)
  gpu?
  ;; Metadata:
  (gl-context gpu-gl-context)
  (gl-version gpu-gl-version)
  (glsl-version gpu-glsl-version)
  (max-texture-size gpu-max-texture-size)
  (max-texture-units gpu-max-texture-units)
  ;; GC integration for GPU data.
  (guardian gpu-guardian)
  ;; OpenGL state:
  (front-face gpu-front-face %set-gpu-front-face!)
  (blend-mode gpu-blend-mode %set-gpu-blend-mode!)
  (cull-face-mode gpu-cull-face-mode %set-gpu-cull-face-mode!)
  (polygon-mode gpu-polygon-mode %set-gpu-polygon-mode!)
  (color-mask gpu-color-mask %set-gpu-color-mask!)
  (depth-test gpu-depth-test %set-gpu-depth-test!)
  (stencil-test gpu-stencil-test %set-gpu-stencil-test!)
  (scissor-test gpu-scissor-test %set-gpu-scissor-test!)
  (viewport gpu-viewport %set-gpu-viewport!)
  (clear-color gpu-clear-color %set-gpu-clear-color!)
  (multisample? gpu-multisample? %set-gpu-multisample!)
  (framebuffer gpu-framebuffer %set-gpu-framebuffer!)
  (renderbuffer gpu-renderbuffer %set-gpu-renderbuffer!)
  (buffer gpu-buffer %set-gpu-buffer!)
  (vertex-array gpu-vertex-array %set-gpu-vertex-array!)
  (program gpu-program %set-gpu-program!)
  ;; Unlike the other state, many textures can be bound to different
  ;; units, and the maximum number of texture units varies from
  ;; machine to machine.  So, we use a vector to hold the state of
  ;; this unknown (until runtime) amount of textures.
  (textures gpu-textures))

(define (make-gpu gl-context)
  (define (get-param name)
    (let ((bv (make-s32vector 1)))
      (gl-get-integer-v name (bytevector->pointer bv))
      (s32vector-ref bv 0)))
  (define (extract-version attr)
    (match (string-split (pointer->string (gl-get-string attr)) #\space)
      ((version . _) version)
      (_ "unknown")))
  (let* ((gl-version (extract-version (string-name version)))
         (glsl-version (extract-version (version-2-0 shading-language-version)))
         (max-texture-size (get-param (get-p-name max-texture-size)))
         (max-texture-units (get-param (version-1-3 max-texture-units)))
         (guardian (make-guardian))
         (textures (make-vector max-texture-units #f)))
    (%make-gpu gl-context gl-version glsl-version max-texture-size
               max-texture-units guardian textures)))

(define-syntax-rule (define-gpu-setter name %set! ref bind pred)
  (define (name gpu obj)
    (unless (pred obj (ref gpu))
      (bind obj)
      (%set! gpu obj))))

(define-gpu-setter set-gpu-front-face!
  %set-gpu-front-face! gpu-front-face bind-front-face eq?)
(define-gpu-setter set-gpu-blend-mode!
  %set-gpu-blend-mode! gpu-blend-mode bind-blend-mode eq?)
(define-gpu-setter set-gpu-cull-face-mode!
  %set-gpu-cull-face-mode! gpu-cull-face-mode bind-cull-face-mode eq?)
(define-gpu-setter set-gpu-polygon-mode!
  %set-gpu-polygon-mode! gpu-polygon-mode bind-polygon-mode eq?)
(define-gpu-setter set-gpu-color-mask!
  %set-gpu-color-mask! gpu-color-mask bind-color-mask equal?)
(define-gpu-setter set-gpu-depth-test!
  %set-gpu-depth-test! gpu-depth-test bind-depth-test equal?)
(define-gpu-setter set-gpu-stencil-test!
  %set-gpu-stencil-test! gpu-stencil-test bind-stencil-test equal?)
(define-gpu-setter set-gpu-scissor-test!
  %set-gpu-scissor-test! gpu-scissor-test bind-scissor-test equal?)
(define-gpu-setter set-gpu-viewport!
  %set-gpu-viewport! gpu-viewport bind-viewport equal?)
(define-gpu-setter set-gpu-clear-color!
  %set-gpu-clear-color! gpu-clear-color bind-clear-color equal?)
(define-gpu-setter set-gpu-multisample!
  %set-gpu-multisample! gpu-multisample? bind-multisample eq?)
(define-gpu-setter set-gpu-framebuffer!
  %set-gpu-framebuffer! gpu-framebuffer bind-gpu-framebuffer eq?)
(define-gpu-setter set-gpu-renderbuffer!
  %set-gpu-renderbuffer! gpu-renderbuffer bind-gpu-renderbuffer eq?)
(define-gpu-setter set-gpu-buffer!
  %set-gpu-buffer! gpu-buffer bind-gpu-buffer eq?)
(define-gpu-setter set-gpu-vertex-array!
  %set-gpu-vertex-array! gpu-vertex-array bind-gpu-vertex-array eq?)
(define-gpu-setter set-gpu-program!
  %set-gpu-program! gpu-program bind-gpu-program eq?)

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

(define (set-gpu-texture! gpu unit texture)
  (unless (eq? texture (gpu-texture gpu unit))
    (set-gl-active-texture (+ (version-1-3 texture0) unit))
    (bind-gpu-texture texture)
    (vector-set! (gpu-textures gpu) unit texture)))

(define (gpu-gc gpu)
  (let ((guardian (gpu-guardian gpu)))
    (let loop ()
      (match (guardian)
        (#f *unspecified*)
        ((? gpu-framebuffer? fb)
         (free-gpu-framebuffer fb)
         (loop))
        ((? gpu-renderbuffer? rb)
         (free-gpu-renderbuffer rb)
         (loop))
        ((? gpu-buffer? buf)
         (free-gpu-buffer buf)
         (loop))
        ((? gpu-vertex-array? va)
         (free-gpu-vertex-array va)
         (loop))
        ((? gpu-texture? t)
         (free-gpu-texture t)
         (loop))
        ((? gpu-shader? s)
         (free-gpu-shader s)
         (loop))
        ((? gpu-program? p)
         (free-gpu-program p)
         (loop))))))

(define (guard! gpu obj)
  ((gpu-guardian gpu) obj)
  obj)

(define-syntax-rule (define-fresh name constructor params ...)
  (define (name gpu params ...)
    (guard! gpu (constructor params ...))))

(define-fresh fresh-gpu-framebuffer make-gpu-framebuffer)
(define-fresh fresh-gpu-renderbuffer make-gpu-renderbuffer)
(define-fresh fresh-gpu-buffer make-gpu-buffer target)
(define-fresh fresh-gpu-vertex-array make-gpu-vertex-array)
(define-fresh fresh-gpu-texture make-gpu-texture target)
(define-fresh fresh-gpu-shader make-gpu-shader type)
(define-fresh fresh-gpu-program make-gpu-program)

(define (gpu-reset! gpu)
  (set-gpu-front-face! gpu front-face:ccw)
  (set-gpu-blend-mode! gpu blend:replace)
  (set-gpu-cull-face-mode! gpu cull-face:back)
  (set-gpu-polygon-mode! gpu polygon:fill)
  (set-gpu-color-mask! gpu color-mask:all)
  (set-gpu-depth-test! gpu #f)
  (set-gpu-stencil-test! gpu #f)
  (set-gpu-scissor-test! gpu #f)
  (set-gpu-viewport! gpu window-rect:empty)
  (set-gpu-clear-color! gpu black)
  (set-gpu-multisample! gpu #f)
  (set-gpu-framebuffer! gpu gpu-framebuffer:null)
  (set-gpu-renderbuffer! gpu gpu-renderbuffer:null)
  (set-gpu-buffer! gpu gpu-buffer:null)
  (set-gpu-vertex-array! gpu gpu-vertex-array:null)
  (set-gpu-program! gpu gpu-program:null)
  (let ((textures (gpu-textures gpu)))
    (let loop ((i 0))
      (when (< i (vector-length textures))
        (set-gpu-texture! gpu i gpu-texture:null)
        (loop (+ i 1))))))