From d969c19756227899b39967989fa971fa3452e872 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 26 Jul 2023 12:09:47 -0400 Subject: Rewrite GPU state management layer. --- Makefile.am | 1 + chickadee/graphics/buffer.scm | 15 +- chickadee/graphics/engine.scm | 8 +- chickadee/graphics/gl.scm | 44 ++- chickadee/graphics/gpu.scm | 879 ++++++++++++++++++++++++++++++++++++++++++ chickadee/math.scm | 6 +- examples/sprite.scm | 3 + 7 files changed, 932 insertions(+), 24 deletions(-) create mode 100644 chickadee/graphics/gpu.scm diff --git a/Makefile.am b/Makefile.am index 420b46e..a0bf9dd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -67,6 +67,7 @@ SOURCES = \ chickadee/image/jpeg.scm \ chickadee/image/png.scm \ chickadee/graphics/gl.scm \ + chickadee/graphics/gpu.scm \ chickadee/graphics/engine.scm \ chickadee/graphics/color.scm \ chickadee/graphics/blend.scm \ diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm index f2fbfe0..d16ab09 100644 --- a/chickadee/graphics/buffer.scm +++ b/chickadee/graphics/buffer.scm @@ -138,7 +138,7 @@ (%make-buffer 0 "null" 0 0 'vertex 'static #f #f)) (define (free-buffer buffer) - (gl-delete-buffers 1 (u32vector (buffer-id buffer)))) + (gl-delete-buffer (buffer-id buffer))) (define (bind-buffer buffer) (gl-bind-buffer (buffer-target-gl buffer) @@ -154,9 +154,7 @@ #:bind bind-buffer) (define (generate-buffer-gl) - (let ((bv (u32vector 1))) - (gl-gen-buffers 1 (bytevector->pointer bv)) - (u32vector-ref bv 0))) + (gl-generate-buffer)) (define (index-buffer? buffer) "Return #t if VIEW is an index buffer view." @@ -461,15 +459,10 @@ element is used for 2 instances, and so on." (define null-vertex-array (%make-vertex-array 0 #f '() 'triangles)) (define (generate-vertex-array) - (let ((bv (u32vector 1))) - (gl-gen-vertex-arrays 1 (bytevector->pointer bv)) - (u32vector-ref bv 0))) + (gl-generate-vertex-array)) (define (free-vertex-array va) - (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va)))) - -(define (apply-vertex-array va) - (gl-bind-vertex-array (vertex-array-id va))) + (gl-delete-vertex-array (vertex-array-id va))) (define (bind-vertex-array va) (gl-bind-vertex-array (vertex-array-id va))) diff --git a/chickadee/graphics/engine.scm b/chickadee/graphics/engine.scm index 2bc6463..9598e91 100644 --- a/chickadee/graphics/engine.scm +++ b/chickadee/graphics/engine.scm @@ -207,14 +207,20 @@ (gl-get-integer-v (get-p-name max-texture-size) (bytevector->pointer bv)) (s32vector-ref bv 0))) + (define (max-texture-units) + (let ((bv (make-s32vector 1))) + (gl-get-integer-v (version-1-3 max-texture-units) + (bytevector->pointer bv)) + (s32vector-ref bv 0))) (define (extract-version attr) (car (string-split (pointer->string (gl-get-string attr)) #\space))) (define (glsl-version) (extract-version (version-2-0 shading-language-version))) + (pk 'max-texture-units (max-texture-units)) (let ((engine (%make-graphics-engine gl-context (extract-version (string-name version)) (glsl-version) - (max-texture-size) + (pk 'max-texture-size (max-texture-size)) (make-identity-matrix4) (make-guardian) (make-array-list) diff --git a/chickadee/graphics/gl.scm b/chickadee/graphics/gl.scm index 508f244..27872dd 100644 --- a/chickadee/graphics/gl.scm +++ b/chickadee/graphics/gl.scm @@ -121,9 +121,7 @@ instanced rendering.") ;;; VBOs ;;; -(re-export (%glGenBuffers . gl-gen-buffers) - (%glDeleteBuffers . gl-delete-buffers) - (%glBufferData . gl-buffer-data) +(re-export (%glBufferData . gl-buffer-data) (%glBufferSubData . gl-buffer-sub-data) (%glMapBuffer . gl-map-buffer) (%glUnmapBuffer . gl-unmap-buffer)) @@ -142,6 +140,15 @@ instanced rendering.") -> void) "Delete vertex array objects.") +(define (gl-generate-vertex-array) + (let ((bv (u32vector 0))) + (glGenVertexArrays 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-vertex-array n) + (let ((bv (u32vector n))) + (glDeleteVertexArrays 1 bv))) + (define-gl-procedure (glBindVertexArray (array GLuint) -> void) "Bind vertex array object ARRAY.") @@ -166,8 +173,8 @@ instanced rendering.") -> void) "Render primitives from array data.") -(export (glGenVertexArrays . gl-gen-vertex-arrays) - (glDeleteVertexArrays . gl-delete-vertex-arrays) +(export gl-generate-vertex-array + gl-delete-vertex-array (glBindVertexArray . gl-bind-vertex-array) (glEnableVertexAttribArray . gl-enable-vertex-attrib-array) (glVertexAttribPointer . gl-vertex-attrib-pointer) @@ -195,6 +202,15 @@ instanced rendering.") -> void) "Delete framebuffer objects.") +(define (gl-generate-framebuffer) + (let ((bv (u32vector 0))) + (glGenFramebuffers 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-framebuffer n) + (let ((bv (u32vector n))) + (glDeleteFramebuffers 1 bv))) + (define-gl-procedure (glBindFramebuffer (target GLenum) (framebuffer GLuint) -> void) @@ -224,6 +240,15 @@ object.") -> void) "Delete renderbuffer objects.") +(define (gl-generate-renderbuffer) + (let ((bv (u32vector 0))) + (glGenRenderbuffers 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-renderbuffer n) + (let ((bv (u32vector n))) + (glDeleteRenderbuffers 1 bv))) + (define-gl-procedure (glBindRenderbuffer (target GLenum) (renderbuffer GLuint) -> void) @@ -243,13 +268,13 @@ object.") -> void) "Attach a renderbuffer object to a framebuffer object.") -(export (glGenFramebuffers . gl-gen-framebuffers) - (glDeleteFramebuffers . gl-delete-framebuffers) +(export gl-generate-framebuffer + gl-delete-framebuffer (glBindFramebuffer . gl-bind-framebuffer) (glFramebufferTexture2D . gl-framebuffer-texture-2d) (glCheckFramebufferStatus . gl-check-framebuffer-status) - (glGenRenderbuffers . gl-gen-renderbuffers) - (glDeleteRenderbuffers . gl-delete-renderbuffers) + gl-generate-renderbuffer + gl-delete-renderbuffer (glBindRenderbuffer . gl-bind-renderbuffer) (glRenderbufferStorage . gl-renderbuffer-storage) (glFramebufferRenderbuffer . gl-framebuffer-renderbuffer)) @@ -350,6 +375,7 @@ object.") (re-export (%glPolygonMode . gl-polygon-mode) (%glCullFace . gl-cull-face) + (%glFrontFace . gl-front-face) (%glColorMask . gl-color-mask)) diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm new file mode 100644 index 0000000..c63cc4d --- /dev/null +++ b/chickadee/graphics/gpu.scm @@ -0,0 +1,879 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson +;;; +;;; 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 + + 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 + + make-window-rect + window-rect? + window-rect-x + window-rect-y + window-rect-width + window-rect-height + + 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! + + current-gpu)) + + +;;; +;;; 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 + 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))) + (($ 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 + 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 + 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 + (($ #t #t) + (gl-enable (enable-cap cull-face)) + (gl-cull-face (cull-face-mode front-and-back))) + (($ #t #f) + (gl-enable (enable-cap cull-face)) + (gl-cull-face (cull-face-mode front))) + (($ #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 + 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 + (($ 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 + 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 + %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))) + (($ write? near far func) + (gl-enable (enable-cap depth-test)) + (gl-depth-func func) + (gl-depth-mask write?) + (gl-depth-range near far)))) + +(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 + %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))) + (($ 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 (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 + (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 (bind-scissor-test rect) + (match rect + (#f (gl-disable (enable-cap scissor-test))) + (($ x y width height) + (gl-enable (enable-cap scissor-test)) + (gl-scissor x y width height)))) + +(define (bind-viewport rect) + (match 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 + (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 + (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 + (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 + (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 + (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 + (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 + (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 + (%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 current-gpu (make-parameter #f)) + +(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-shader? s) + (free-gpu-shader s) + (loop)) + ((? gpu-program? p) + (free-gpu-program p) + (loop)))))) + +(define (guard! gpu obj) + ((gpu-guardian gpu) 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-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) + ;; TODO: Need current window dimensions. + ;; (set-gpu-viewport! gpu ...) + (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)))))) diff --git a/chickadee/math.scm b/chickadee/math.scm index aa96ba8..cbdf4b9 100644 --- a/chickadee/math.scm +++ b/chickadee/math.scm @@ -26,9 +26,9 @@ radians->degrees) #:replace (min max)) -(define pi 3.1415926535897932) -(define pi/2 1.5707963267948966) -(define tau 6.283185307179586) ;; AKA 2pi +(define pi (* 4.0 (atan 1.0))) +(define pi/2 (/ pi 2.0)) +(define tau (* pi 2.0)) (define-inlinable (cotan z) "Return the cotangent of Z." diff --git a/examples/sprite.scm b/examples/sprite.scm index eb79161..24b7a24 100644 --- a/examples/sprite.scm +++ b/examples/sprite.scm @@ -3,9 +3,12 @@ (chickadee graphics sprite) (chickadee graphics texture)) +(use-modules (gl enums)) + (define sprite #f) (define (load) + (pk (blending-factor-src 2)) (set! sprite (load-image "images/chickadee.png"))) (define (draw alpha) -- cgit v1.2.3