summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am5
-rw-r--r--TODO.org2
-rw-r--r--chickadee.scm27
-rw-r--r--chickadee/graphics/9-patch.scm8
-rw-r--r--chickadee/graphics/blend.scm139
-rw-r--r--chickadee/graphics/buffer.scm100
-rw-r--r--chickadee/graphics/color.scm6
-rw-r--r--chickadee/graphics/depth.scm65
-rw-r--r--chickadee/graphics/engine.scm595
-rw-r--r--chickadee/graphics/framebuffer.scm97
-rw-r--r--chickadee/graphics/gpu.scm30
-rw-r--r--chickadee/graphics/mesh.scm38
-rw-r--r--chickadee/graphics/model.scm14
-rw-r--r--chickadee/graphics/multisample.scm36
-rw-r--r--chickadee/graphics/particles.scm8
-rw-r--r--chickadee/graphics/path.scm34
-rw-r--r--chickadee/graphics/pbr.scm13
-rw-r--r--chickadee/graphics/phong.scm13
-rw-r--r--chickadee/graphics/polygon.scm107
-rw-r--r--chickadee/graphics/shader.scm94
-rw-r--r--chickadee/graphics/skybox.scm6
-rw-r--r--chickadee/graphics/sprite.scm38
-rw-r--r--chickadee/graphics/stencil.scm141
-rw-r--r--chickadee/graphics/text.scm6
-rw-r--r--chickadee/graphics/texture.scm92
-rw-r--r--chickadee/graphics/tile-map.scm16
-rw-r--r--chickadee/graphics/viewport.scm96
-rw-r--r--doc/api.texi11
-rw-r--r--examples/model.scm2
-rw-r--r--examples/path.scm3
-rw-r--r--examples/sprite-batch.scm16
-rw-r--r--examples/sprite.scm5
-rw-r--r--examples/text.scm6
-rw-r--r--examples/triangle.scm84
34 files changed, 742 insertions, 1211 deletions
diff --git a/Makefile.am b/Makefile.am
index a0bf9dd..09eff46 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -70,11 +70,6 @@ SOURCES = \
chickadee/graphics/gpu.scm \
chickadee/graphics/engine.scm \
chickadee/graphics/color.scm \
- chickadee/graphics/blend.scm \
- chickadee/graphics/polygon.scm \
- chickadee/graphics/depth.scm \
- chickadee/graphics/stencil.scm \
- chickadee/graphics/multisample.scm \
chickadee/graphics/buffer.scm \
chickadee/graphics/pixbuf.scm \
chickadee/graphics/texture.scm \
diff --git a/TODO.org b/TODO.org
index 4aee1a3..be19d88 100644
--- a/TODO.org
+++ b/TODO.org
@@ -31,7 +31,7 @@ And of course on native targets we will now have the option of using
whatever graphics API makes the most sense.
Some big subtasks here:
-- [ ] Decouple OpenGL state management from dynamic render context
+- [X] Decouple OpenGL state management from dynamic render context
- [ ] Refactor all OpenGL calls into a single module
- [ ] Add generic WebGPU-like graphics API
- [ ] Implement that API for OpenGL backend
diff --git a/chickadee.scm b/chickadee.scm
index 05f3d65..88928e1 100644
--- a/chickadee.scm
+++ b/chickadee.scm
@@ -28,6 +28,7 @@
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics viewport)
#:use-module (chickadee utils)
#:use-module (gl)
@@ -306,14 +307,15 @@ border is disabled, otherwise it is enabled.")
#:fullscreen? window-fullscreen?
#:resizable? window-resizable?
#:multisample? #f)))
- (gfx (make-graphics-engine (window-gl-context window)))
- (default-viewport (make-atomic-box
+ (default-viewport (vector
(make-viewport 0 0 window-width window-height
#:clear-color clear-color)))
- (default-projection (make-atomic-box
+ (default-projection (vector
(orthographic-projection 0 window-width
window-height 0
- 0 1))))
+ 0 1)))
+ (gpu (make-gpu (window-gl-context window)))
+ (gfx (make-graphics-engine gpu)))
(define (invert-y y)
;; SDL's origin is the top-left, but our origin is the bottom
;; left so we need to invert Y coordinates that SDL gives us.
@@ -399,11 +401,11 @@ border is disabled, otherwise it is enabled.")
((width height)
(set! window-width width)
(set! window-height height)
- (atomic-box-set! default-viewport
- (make-viewport 0 0 width height
- #:clear-color clear-color))
- (atomic-box-set! default-projection
- (orthographic-projection 0 width height 0 0 1))
+ (vector-set! default-viewport 0
+ (make-viewport 0 0 width height
+ #:clear-color clear-color))
+ (vector-set! default-projection 0
+ (orthographic-projection 0 width height 0 0 1))
(window-resize width height))))))
;; Process all pending events.
(let loop ((event (poll-event)))
@@ -417,11 +419,12 @@ border is disabled, otherwise it is enabled.")
;; that were queued to play this frame start playing immediately.
(update-audio)
;; Free any GPU resources that have been GC'd.
- (graphics-engine-reap! gfx))
+ (graphics-engine-gc gfx))
(define (render-sdl-opengl alpha)
- (with-graphics-state! ((g:viewport (atomic-box-ref default-viewport)))
+ (graphics-engine-reset! gfx)
+ (with-viewport (vector-ref default-viewport 0)
(clear-viewport)
- (with-projection (atomic-box-ref default-projection)
+ (with-graphics-state ((projection (vector-ref default-projection 0)))
(draw alpha)))
(sdl2:swap-gl-window (unwrap-window window)))
(define (on-error e stack)
diff --git a/chickadee/graphics/9-patch.scm b/chickadee/graphics/9-patch.scm
index c023b25..5b74585 100644
--- a/chickadee/graphics/9-patch.scm
+++ b/chickadee/graphics/9-patch.scm
@@ -18,9 +18,9 @@
#:use-module (chickadee math matrix)
#:use-module (chickadee math rect)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics texture)
#:use-module (chickadee graphics buffer)
@@ -145,14 +145,14 @@ void main (void) {
(x2 y1 s2 t1)
(x2 y2 s2 t2)
(x1 y2 s1 t2))
- (geometry-index-append! geometry 0 3 2 0 2 1)))
+ (geometry-index-append! geometry 0 2 3 0 1 2)))
;; Convert pixel margin values to GL texture values.
(set-rect-x! margins (/ left-margin tw))
(set-rect-y! margins (/ right-margin tw))
(set-rect-width! margins (/ bottom-margin th))
(set-rect-height! margins (/ top-margin th))
- (with-graphics-state ((g:blend-mode blend-mode)
- (g:texture-0 texture))
+ (with-graphics-state ((blend-mode blend-mode)
+ (texture 0 (texture-id texture)))
(shader-apply shader
(geometry-vertex-array geometry)
#:width w*
diff --git a/chickadee/graphics/blend.scm b/chickadee/graphics/blend.scm
deleted file mode 100644
index 7450c52..0000000
--- a/chickadee/graphics/blend.scm
+++ /dev/null
@@ -1,139 +0,0 @@
-;;; Chickadee Game Toolkit
-;;; Copyright © 2016, 2021 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 blend)
- #:use-module (chickadee graphics engine)
- #:use-module (chickadee graphics gl)
- #:use-module (gl)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-9)
- #:export (make-blend-mode
- 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
- g:blend-mode
- current-blend-mode))
-
-(define-record-type <blend-mode>
- (make-blend-mode equation source-function destination-function)
- blend-mode?
- (equation blend-mode-equation)
- (source-function blend-mode-source-function)
- (destination-function blend-mode-destination-function))
-
-(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 (bind-blend-mode blend-mode)
- (if blend-mode
- (begin
- (gl-enable (enable-cap blend))
- (gl-blend-equation
- (match (blend-mode-equation blend-mode)
- ('add
- (blend-equation-mode-ext func-add-ext))
- ('subtract
- (blend-equation-mode-ext func-subtract-ext))
- ('reverse-subtract
- (blend-equation-mode-ext func-reverse-subtract-ext))
- ('min
- (blend-equation-mode-ext min-ext))
- ('max
- (blend-equation-mode-ext max-ext))
- ('alpha-min
- (blend-equation-mode-ext alpha-min-sgix))
- ('alpha-max
- (blend-equation-mode-ext alpha-min-sgix))))
- (gl-blend-func (match (blend-mode-source-function blend-mode)
- ('zero
- (blending-factor-src zero))
- ('one
- (blending-factor-src one))
- ('destination-color
- (blending-factor-src dst-color))
- ('one-minus-destination-color
- (blending-factor-src one-minus-dst-color))
- ('source-alpha-saturate
- (blending-factor-src src-alpha-saturate))
- ('source-alpha
- (blending-factor-src src-alpha))
- ('one-minus-source-alpha
- (blending-factor-src one-minus-src-alpha))
- ('destination-alpha
- (blending-factor-src dst-alpha))
- ('one-minus-destination-alpha
- (blending-factor-src one-minus-dst-alpha))
- ('constant-color
- (blending-factor-src constant-color-ext))
- ('one-minus-constant-color
- (blending-factor-src one-minus-constant-color-ext))
- ('contstant-alpha
- (blending-factor-src constant-alpha-ext))
- ('one-minus-constant-alpha
- (blending-factor-src one-minus-constant-alpha-ext)))
- (match (blend-mode-destination-function blend-mode)
- ('zero
- (blending-factor-dest zero))
- ('one
- (blending-factor-dest one))
- ('source-color
- (blending-factor-dest src-color))
- ('one-minus-source-color
- (blending-factor-dest one-minus-src-color))
- ('source-alpha
- (blending-factor-dest src-alpha))
- ('one-minus-source-alpha
- (blending-factor-dest one-minus-src-alpha))
- ('destination-alpha
- (blending-factor-dest dst-alpha))
- ('one-minus-destination-alpha
- (blending-factor-dest one-minus-dst-alpha))
- ('constant-color
- (blending-factor-dest constant-color-ext))
- ('one-minus-constant-color
- (blending-factor-dest one-minus-constant-color-ext))
- ('contstant-alpha
- (blending-factor-dest constant-alpha-ext))
- ('one-minus-constant-alpha
- (blending-factor-dest one-minus-constant-alpha-ext)))))
- (gl-disable (enable-cap blend))))
-
-(define-graphics-state g:blend-mode
- current-blend-mode
- #:default blend:replace
- #:bind bind-blend-mode)
diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm
index d16ab09..50b6d1c 100644
--- a/chickadee/graphics/buffer.scm
+++ b/chickadee/graphics/buffer.scm
@@ -34,6 +34,7 @@
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics gpu)
#:export (make-buffer
buffer?
index-buffer?
@@ -124,7 +125,7 @@
(define (print-buffer buffer port)
(format port
- "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
+ "#<buffer id: ~s name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
(buffer-id buffer)
(buffer-name buffer)
(buffer-usage buffer)
@@ -137,25 +138,6 @@
(define null-buffer
(%make-buffer 0 "null" 0 0 'vertex 'static #f #f))
-(define (free-buffer buffer)
- (gl-delete-buffer (buffer-id buffer)))
-
-(define (bind-buffer buffer)
- (gl-bind-buffer (buffer-target-gl buffer)
- (buffer-id buffer)))
-
-(define-graphics-finalizer buffer-finalizer
- #:predicate buffer?
- #:free free-buffer)
-
-(define-graphics-state g:buffer
- current-buffer
- #:default null-buffer
- #:bind bind-buffer)
-
-(define (generate-buffer-gl)
- (gl-generate-buffer))
-
(define (index-buffer? buffer)
"Return #t if VIEW is an index buffer view."
(eq? (buffer-target buffer) 'index))
@@ -202,25 +184,19 @@ never sent to the GPU."
(assert-current-graphics-engine)
;; Weird bugs will occur when creating a new vertex buffer while a
;; vertex array is bound.
- (with-graphics-state! ((g:vertex-array null-vertex-array))
- (let ((buffer (%make-buffer (generate-buffer-gl)
- name
- length
- stride
- target
- usage
- #f
+ (with-graphics-state! ((vertex-array gpu-vertex-array:null))
+ (let ((buffer (%make-buffer (fresh-gpu-buffer (current-gpu) target)
+ name length stride target usage #f
(and (eq? usage 'stream)
(make-hash-table)))))
- (graphics-engine-guard! buffer)
- (with-graphics-state! ((g:buffer buffer))
+ (with-graphics-state! ((buffer (buffer-id buffer)))
(gl-buffer-data (buffer-target-gl buffer)
length
(if data
(bytevector->pointer data offset)
%null-pointer)
- (buffer-usage-gl buffer)))
- buffer)))
+ (buffer-usage-gl buffer))
+ buffer))))
(define (buffer-mapped? buffer)
"Return #t if buffer data has been mapped from GPU."
@@ -230,14 +206,19 @@ never sent to the GPU."
;; good throughput. However, it requires getting a new data pointer
;; every frame and allocating a Scheme bytevector for that memory
;; region. Allocating this bytevector every frame causes significant
-;; GC pressure. It turns out that, GPU drivers tend to return the
-;; same set of pointers over and over. So, by caching bytevectors for
-;; those memory regions we avoid bytevector allocation after a frame
-;; or two of warmup.
+;; GC pressure. It turns out that GPU drivers tend to return the same
+;; set of pointers over and over, or at least the driver I'm using
+;; does this. So, by caching bytevectors for those memory regions we
+;; avoid bytevector allocation after a frame or two of warmup.
(define (pointer->bytevector/cached buffer pointer length)
- (let ((cache (buffer-stream-cache buffer))
- (address (pointer-address pointer)))
- (or (hashv-ref cache address)
+ (let* ((cache (buffer-stream-cache buffer))
+ (address (pointer-address pointer))
+ (cached (hashv-ref cache address)))
+ ;; It could be that there is a cached bytevector for the address,
+ ;; but the bytevector is a different length. We must treat this
+ ;; as a cache miss and allocate a new bytevector.
+ (if (and cached (= (bytevector-length cached) length))
+ cached
(let ((bv (pointer->bytevector pointer length)))
(hashv-set! cache address bv)
bv))))
@@ -250,7 +231,7 @@ vertex buffer data back to the GPU."
(unless (buffer-mapped? buffer) ;; Don't map a buffer that is already mapped!
(let ((target (buffer-target-gl buffer))
(length (buffer-length buffer)))
- (with-graphics-state! ((g:buffer buffer))
+ (with-graphics-state! ((buffer (buffer-id buffer)))
(when (eq? (buffer-usage buffer) 'stream)
;; Orphan the buffer to avoid implicit synchronization.
;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
@@ -268,7 +249,7 @@ vertex buffer data back to the GPU."
(define (unmap-buffer! buffer)
"Return the mapped vertex buffer data for BUFFER to the GPU."
- (with-graphics-state! ((g:buffer buffer))
+ (with-graphics-state! ((buffer (buffer-id buffer)))
(gl-unmap-buffer (buffer-target-gl buffer))
(set-buffer-data! buffer #f)))
@@ -420,7 +401,7 @@ element is used for 2 instances, and so on."
((double) (data-type double))))
(define (apply-vertex-attribute vertex-attribute attribute-index)
- (with-graphics-state! ((g:buffer (vertex-attribute->buffer vertex-attribute)))
+ (with-graphics-state! ((buffer (buffer-id (vertex-attribute->buffer vertex-attribute))))
;; If there is no attribute-index, we assume this is being bound for
;; use as an index buffer.
(when attribute-index
@@ -458,24 +439,6 @@ element is used for 2 instances, and so on."
(define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))
-(define (generate-vertex-array)
- (gl-generate-vertex-array))
-
-(define (free-vertex-array va)
- (gl-delete-vertex-array (vertex-array-id va)))
-
-(define (bind-vertex-array va)
- (gl-bind-vertex-array (vertex-array-id va)))
-
-(define-graphics-finalizer vertex-array-finalizer
- #:predicate vertex-array?
- #:free free-vertex-array)
-
-(define-graphics-state g:vertex-array
- current-vertex-array
- #:default null-vertex-array
- #:bind bind-vertex-array)
-
(define* (make-vertex-array #:key indices attributes (mode 'triangles))
"Return a new vertex array using the index data within the typed
buffer INDICES and the vertex attribute data within ATTRIBUTES, an
@@ -494,20 +457,17 @@ argument may be overridden. The following values are supported:
- triangle-strip
- triangle-fan"
(assert-current-graphics-engine)
- (let ((array (%make-vertex-array (generate-vertex-array)
+ (let ((array (%make-vertex-array (fresh-gpu-vertex-array (current-gpu))
indices
attributes
mode)))
- (graphics-engine-guard! array)
- (with-graphics-state! ((g:vertex-array array))
+ (with-graphics-state! ((vertex-array (vertex-array-id array)))
(for-each (match-lambda
((index . vertex-attribute)
(apply-vertex-attribute vertex-attribute index)))
attributes)
- (when indices (apply-vertex-attribute indices #f)))
- ;; Restore the old array. Is this needed?
- ;; (graphics-engine-commit!)
- array))
+ (when indices (apply-vertex-attribute indices #f))
+ array)))
(define (vertex-array-mode-gl array)
(case (vertex-array-mode array)
@@ -520,10 +480,12 @@ argument may be overridden. The following values are supported:
((triangle-fan) (begin-mode triangle-fan))))
(define (render-vertices array count offset)
- (with-graphics-state! ((g:vertex-array array))
+ (with-graphics-state! ((vertex-array (vertex-array-id array)))
(let ((indices (vertex-array-indices array)))
(if indices
(begin
+ ;; This shouldn't be here but I get weird rendering issues
+ ;; otherwise whyyyyyy??
(apply-vertex-attribute indices #f)
(gl-draw-elements (vertex-array-mode-gl array)
(or count
@@ -538,7 +500,7 @@ argument may be overridden. The following values are supported:
0))))))))
(define (render-vertices/instanced array instances count offset)
- (with-graphics-state! ((g:vertex-array array))
+ (with-graphics-state! ((vertex-array (vertex-array-id array)))
(let ((indices (vertex-array-indices array)))
(if indices
(begin
diff --git a/chickadee/graphics/color.scm b/chickadee/graphics/color.scm
index 78e4c75..5548c87 100644
--- a/chickadee/graphics/color.scm
+++ b/chickadee/graphics/color.scm
@@ -20,7 +20,6 @@
;;; Code:
(define-module (chickadee graphics color)
- #:use-module (chickadee graphics engine)
#:use-module (chickadee graphics gl)
#:use-module (chickadee math)
#:use-module (ice-9 format)
@@ -391,8 +390,3 @@ a color object."
(color-mask-green? mask)
(color-mask-blue? mask)
(color-mask-alpha? mask)))
-
-(define-graphics-state g:color-mask
- current-color-mask
- #:default default-color-mask
- #:bind bind-color-mask)
diff --git a/chickadee/graphics/depth.scm b/chickadee/graphics/depth.scm
deleted file mode 100644
index 2c1e901..0000000
--- a/chickadee/graphics/depth.scm
+++ /dev/null
@@ -1,65 +0,0 @@
-;;; Chickadee Game Toolkit
-;;; Copyright © 2020, 2021 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 depth)
- #:use-module (ice-9 match)
- #:use-module (gl)
- #:use-module (chickadee graphics engine)
- #:use-module (chickadee graphics gl)
- #:use-module (srfi srfi-9)
- #:export (make-depth-test
- depth-test?
- depth-test-write?
- depth-test-function
- depth-test-near
- depth-test-far
- basic-depth-test
- g:depth-test
- current-depth-test))
-
-(define-record-type <depth-test>
- (%make-depth-test write? function near far)
- depth-test?
- (write? depth-test-write?)
- (function depth-test-function)
- (near depth-test-near)
- (far depth-test-far))
-
-(define* (make-depth-test #:key (write? #t) (function 'less-than) (near 0.0) (far 1.0))
- (%make-depth-test write? function near far))
-
-(define basic-depth-test (make-depth-test))
-
-(define (bind-depth-test depth-test)
- (if depth-test
- (let ((glfunc (match (depth-test-function depth-test)
- ('always (depth-function always))
- ('never (depth-function never))
- ('equal (depth-function equal))
- ('not-equal (depth-function notequal))
- ('less-than (depth-function less))
- ('less-than-or-equal (depth-function lequal))
- ('greater-than (depth-function greater))
- ('greater-than-or-equal (depth-function gequal)))))
- (gl-enable (enable-cap depth-test))
- (gl-depth-func glfunc)
- (gl-depth-mask (depth-test-write? depth-test))
- (gl-depth-range (depth-test-near depth-test) (depth-test-far depth-test)))
- (gl-disable (enable-cap depth-test))))
-
-(define-graphics-state g:depth-test
- current-depth-test
- #:default #f
- #:bind bind-depth-test)
diff --git a/chickadee/graphics/engine.scm b/chickadee/graphics/engine.scm
index 9598e91..8759ee6 100644
--- a/chickadee/graphics/engine.scm
+++ b/chickadee/graphics/engine.scm
@@ -1,6 +1,7 @@
(define-module (chickadee graphics engine)
#:use-module (chickadee data array-list)
- #:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics color)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee math matrix)
#:use-module (gl)
#:use-module (ice-9 atomic)
@@ -9,136 +10,28 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
- #:export (define-graphics-state
- define-graphics-finalizer
- define-graphics-variable
+ #:export (define-graphics-variable
make-graphics-engine
graphics-engine?
- graphics-engine-gl-context
- graphics-engine-gl-version
+ graphics-engine-gpu
graphics-engine-glsl-version
graphics-engine-max-texture-size
- graphics-engine-state-ref
+ graphics-engine-context
graphics-variable-ref
graphics-variable-set!
+ graphics-engine-reset!
graphics-engine-commit!
- graphics-engine-guard!
- graphics-engine-reap!
+ graphics-engine-gc
current-graphics-engine
- assert-current-graphics-engine
+ current-gpu
current-projection
- with-projection
+ current-viewport
+ assert-current-graphics-engine
with-graphics-state
with-graphics-state!))
;;;
-;;; States
-;;;
-
-;; A "graphics state" is CPU-side storage for GPU-side state. The
-;; goal is to track changes and minimize the number of GPU state
-;; changes (because they are expensive) by only communicating with the
-;; GPU when the value really needs updating.
-
-(define-record-type <graphics-state-spec>
- (%make-graphics-state-spec id name default binder)
- graphics-state-spec?
- (id graphics-state-spec-id)
- (name graphics-state-spec-name)
- (default graphics-state-spec-default)
- (binder graphics-state-spec-binder))
-
-(define* (make-graphics-state-spec id name #:key default bind)
- (%make-graphics-state-spec id name default bind))
-
-(define-record-type <graphics-state>
- (%make-graphics-state binder value bound-value dirty? stack)
- graphics-state?
- (binder graphics-state-binder)
- (value graphics-state-ref %graphics-state-set!)
- (bound-value graphics-state-bound-value set-graphics-state-bound-value!)
- (dirty? graphics-state-dirty? set-graphics-state-dirty!)
- (stack graphics-state-stack))
-
-(define (make-graphics-state bind default)
- (%make-graphics-state bind default default #f (make-array-list)))
-
-(define (graphics-state-set! state new-value)
- (graphics-state-binder state) new-value
- (let ((current-value (graphics-state-bound-value state)))
- (%graphics-state-set! state new-value)
- (set-graphics-state-dirty! state (not (eq? new-value current-value)))))
-
-(define (graphics-state-push! state new-value)
- (array-list-push! (graphics-state-stack state) (graphics-state-ref state))
- (graphics-state-set! state new-value))
-
-(define (graphics-state-pop! state)
- (graphics-state-set! state (array-list-pop! (graphics-state-stack state))))
-
-(define (graphics-state-bind-maybe state)
- (when (graphics-state-dirty? state)
- (let ((x (graphics-state-ref state)))
- ((graphics-state-binder state) x)
- (set-graphics-state-bound-value! state x)
- (set-graphics-state-dirty! state #f))))
-
-(define *graphics-states* (make-array-list))
-
-;; Box the counter so the compiler doesn't do constant propagation on
-;; it and screw everything up.
-(define *graphics-state-id-counter* (vector 0))
-
-(define (next-graphics-state-id)
- (let ((id (vector-ref *graphics-state-id-counter* 0)))
- (vector-set! *graphics-state-id-counter* 0 (+ id 1))
- id))
-
-(define-syntax-rule (define-graphics-state name getter args ...)
- (begin
- (define name
- (let* ((id (next-graphics-state-id))
- (spec (make-graphics-state-spec id 'name args ...)))
- (array-list-push! *graphics-states* spec)
- (when (current-graphics-engine)
- (install-graphics-state (current-graphics-engine) spec))
- spec))
- (define* (getter #:optional (engine (current-graphics-engine)))
- (graphics-engine-state-ref name engine))))
-
-
-;;;
-;;; Finalizers
-;;;
-
-;; Graphics finalizers delete GPU-side resources when Guile is ready
-;; to GC them.
-
-(define-record-type <graphics-finalizer>
- (%make-graphics-finalizer name predicate free)
- graphics-finalizer?
- (name graphics-finalizer-name)
- (predicate graphics-finalizer-predicate)
- (free graphics-finalizer-free))
-
-(define* (make-graphics-finalizer name #:key predicate free)
- (%make-graphics-finalizer name predicate free))
-
-;; Need to box this value so that the compiler doesn't inline the
-;; initial value everywhere.
-(define *graphics-finalizers* (make-atomic-box '()))
-
-(define-syntax-rule (define-graphics-finalizer name args ...)
- (define name
- (let ((finalizer (make-graphics-finalizer 'name args ...)))
- (atomic-box-set! *graphics-finalizers*
- (cons (cons 'name finalizer)
- (atomic-box-ref *graphics-finalizers*)))
- finalizer)))
-
-
-;;;
;;; Variables
;;;
@@ -167,124 +60,142 @@
;;;
+;;; Render Context
+;;;
+
+(define-record-type <render-context>
+ (%make-render-context textures)
+ render-context?
+ (projection render-context-projection set-render-context-projection!)
+ (front-face render-context-front-face set-render-context-front-face!)
+ (blend-mode render-context-blend-mode set-render-context-blend-mode!)
+ (cull-face-mode render-context-cull-face-mode set-render-context-cull-face-mode!)
+ (polygon-mode render-context-polygon-mode set-render-context-polygon-mode!)
+ (color-mask render-context-color-mask set-render-context-color-mask!)
+ (depth-test render-context-depth-test set-render-context-depth-test!)
+ (stencil-test render-context-stencil-test set-render-context-stencil-test!)
+ (scissor-test render-context-scissor-test set-render-context-scissor-test!)
+ (viewport render-context-viewport set-render-context-viewport!)
+ (clear-color render-context-clear-color set-render-context-clear-color!)
+ (multisample? render-context-multisample? set-render-context-multisample!)
+ (framebuffer render-context-framebuffer set-render-context-framebuffer!)
+ (vertex-array render-context-vertex-array set-render-context-vertex-array!)
+ (buffer render-context-buffer set-render-context-buffer!)
+ (program render-context-program set-render-context-program!)
+ (textures render-context-textures))
+
+(define (make-render-context n-textures)
+ (let ((context (%make-render-context (make-vector n-textures))))
+ (render-context-reset! context)
+ context))
+
+(define (render-context-texture context i)
+ (vector-ref (render-context-textures context) i))
+
+(define (set-render-context-texture! context i texture)
+ (vector-set! (render-context-textures context) i texture))
+
+(define %identity-matrix (make-identity-matrix4))
+
+(define (render-context-reset! context)
+ (set-render-context-projection! context %identity-matrix)
+ (set-render-context-front-face! context front-face:ccw)
+ (set-render-context-blend-mode! context blend:replace)
+ (set-render-context-cull-face-mode! context cull-face:back)
+ (set-render-context-polygon-mode! context polygon:fill)
+ (set-render-context-color-mask! context color-mask:all)
+ (set-render-context-depth-test! context #f)
+ (set-render-context-stencil-test! context #f)
+ (set-render-context-scissor-test! context #f)
+ (set-render-context-viewport! context window-rect:empty)
+ (set-render-context-clear-color! context black)
+ (set-render-context-multisample! context #f)
+ (set-render-context-framebuffer! context gpu-framebuffer:null)
+ (set-render-context-buffer! context gpu-buffer:null)
+ (set-render-context-vertex-array! context gpu-vertex-array:null)
+ (set-render-context-program! context gpu-program:null)
+ (let ((textures (render-context-textures context)))
+ (let loop ((i 0))
+ (when (< i (vector-length textures))
+ (set-render-context-texture! context i gpu-texture:null)
+ (loop (+ i 1))))))
+
+(define (render-context-apply! context gpu)
+ (set-gpu-front-face! gpu (render-context-front-face context))
+ (set-gpu-blend-mode! gpu (render-context-blend-mode context))
+ (set-gpu-cull-face-mode! gpu (render-context-cull-face-mode context))
+ (set-gpu-polygon-mode! gpu (render-context-polygon-mode context))
+ (set-gpu-color-mask! gpu (render-context-color-mask context))
+ (set-gpu-depth-test! gpu (render-context-depth-test context))
+ (set-gpu-stencil-test! gpu (render-context-stencil-test context))
+ (set-gpu-scissor-test! gpu (render-context-scissor-test context))
+ (set-gpu-viewport! gpu (render-context-viewport context))
+ (set-gpu-clear-color! gpu (render-context-clear-color context))
+ (set-gpu-multisample! gpu (render-context-multisample? context))
+ (set-gpu-framebuffer! gpu (render-context-framebuffer context))
+ (set-gpu-buffer! gpu (render-context-buffer context))
+ (set-gpu-vertex-array! gpu (render-context-vertex-array context))
+ (set-gpu-program! gpu (render-context-program context))
+ (let ((textures (render-context-textures context)))
+ (let loop ((i 0))
+ (when (< i (vector-length textures))
+ (set-gpu-texture! gpu i (vector-ref textures i))
+ (loop (+ i 1))))))
+
+
+;;;
;;; Engine
;;;
(define-record-type <graphics-engine>
- (%make-graphics-engine gl-context gl-version glsl-version max-texture-size
- projection-matrix guardian states variables)
+ (%make-graphics-engine gpu context variables)
graphics-engine?
- (gl-context %graphics-engine-gl-context)
- (gl-version %graphics-engine-gl-version)
- (glsl-version %graphics-engine-glsl-version)
- (max-texture-size %graphics-engine-max-texture-size)
- (projection-matrix %graphics-engine-projection-matrix
- %set-graphics-engine-projection-matrix!)
- (guardian graphics-engine-guardian)
- (states graphics-engine-states)
+ (gpu graphics-engine-gpu)
+ (context graphics-engine-context)
(variables graphics-engine-variables))
-(define (install-graphics-state engine spec)
- (let ((binder (graphics-state-spec-binder spec))
- (default (graphics-state-spec-default spec))
- (states (graphics-engine-states engine))
- (id (graphics-state-spec-id spec)))
- (unless (> (array-list-size states) id)
- (let loop ((i (array-list-size states)))
- (unless (> i id)
- (array-list-push! states #f)
- (loop (+ i 1)))))
- (array-list-set! states id (make-graphics-state binder default))))
+(define (graphics-engine-glsl-version engine)
+ (gpu-glsl-version (graphics-engine-gpu engine)))
+
+(define (graphics-engine-max-texture-size engine)
+ (gpu-max-texture-size (graphics-engine-gpu engine)))
(define (install-graphics-variable engine var)
(hashq-set! (graphics-engine-variables engine)
var
(eval-graphics-variable var)))
-(define (make-graphics-engine gl-context)
- (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 (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)
- (pk 'max-texture-size (max-texture-size))
- (make-identity-matrix4)
- (make-guardian)
- (make-array-list)
- (make-hash-table))))
+(define current-graphics-engine (make-parameter #f))
+
+(define (current-gpu)
+ (graphics-engine-gpu (current-graphics-engine)))
+
+(define (current-projection)
+ (render-context-projection
+ (graphics-engine-context
+ (current-graphics-engine))))
+
+(define (current-viewport)
+ (render-context-viewport
+ (graphics-engine-context
+ (current-graphics-engine))))
+
+(define-syntax-rule (assert-current-graphics-engine)
+ (unless (current-graphics-engine)
+ (error "No active graphics engine. Make sure the game loop is running before calling this procedure.")))
+
+(define (make-graphics-engine gpu)
+ (let* ((context (make-render-context (gpu-max-texture-units gpu)))
+ (engine (%make-graphics-engine gpu context (make-hash-table))))
;; Variable initialization must be delayed until after engine
;; creation because variable initializers may modify graphics
;; engine state to create shaders, textures, etc.
(parameterize ((current-graphics-engine engine))
- (array-list-for-each (lambda (i spec)
- (install-graphics-state engine spec))
- *graphics-states*)
(hash-for-each (lambda (key var)
(install-graphics-variable engine var))
*graphics-variables*))
engine))
-(define current-graphics-engine (make-parameter #f))
-
-(define-syntax-rule (assert-current-graphics-engine)
- (unless (current-graphics-engine)
- (error "No active graphics engine. Make sure the game loop is running before calling this procedure.")))
-
-(define* (graphics-engine-gl-context #:optional (engine (current-graphics-engine)))
- (%graphics-engine-gl-context engine))
-
-(define* (graphics-engine-gl-version #:optional (engine (current-graphics-engine)))
- (%graphics-engine-gl-version engine))
-
-(define* (graphics-engine-glsl-version #:optional (engine (current-graphics-engine)))
- (%graphics-engine-glsl-version engine))
-
-(define* (graphics-engine-max-texture-size #:optional (engine (current-graphics-engine)))
- (%graphics-engine-max-texture-size engine))
-
-(define* (current-projection #:optional (engine (current-graphics-engine)))
- (%graphics-engine-projection-matrix engine))
-
-(define-syntax-rule (with-projection matrix body ...)
- (let ((old (current-projection)))
- (set-graphics-engine-projection-matrix! matrix)
- (let ((result (begin body ...)))
- (set-graphics-engine-projection-matrix! old)
- result)))
-
-(define* (set-graphics-engine-projection-matrix! matrix #:optional (engine (current-graphics-engine)))
- (%set-graphics-engine-projection-matrix! engine matrix))
-
-(define (graphics-engine-lookup-state engine spec)
- (array-list-ref (graphics-engine-states engine)
- (graphics-state-spec-id spec)))
-
-(define* (graphics-engine-state-ref spec #:optional
- (engine (current-graphics-engine)))
- (let ((state (graphics-engine-lookup-state engine spec)))
- (and state (graphics-state-ref state))))
-
-(define* (graphics-engine-state-push! spec value #:optional
- (engine (current-graphics-engine)))
- (graphics-state-push! (graphics-engine-lookup-state engine spec) value))
-
-(define* (graphics-engine-state-pop! spec #:optional
- (engine (current-graphics-engine)))
- (graphics-state-pop! (graphics-engine-lookup-state engine spec)))
-
(define* (graphics-variable-ref var #:optional
(engine (current-graphics-engine)))
(hashq-ref (graphics-engine-variables engine) var))
@@ -293,43 +204,221 @@
(engine (current-graphics-engine)))
(hashq-set! (graphics-engine-variables engine) var value))
-
-;; HACK: This *should* be in graphics-engine-commit! but for some
-;; reason Guile's compiler is generating inefficient bytecode that
-;; allocates a closure even though it should be completely
-;; unnecessary. Defining this procedure at the top-level fixes it.
-(define (maybe-bind _id state)
- (graphics-state-bind-maybe state))
-
-(define (graphics-engine-commit!)
- (array-list-for-each maybe-bind
- (graphics-engine-states (current-graphics-engine))))
-
-(define* (graphics-engine-guard! obj #:optional
- (engine (current-graphics-engine)))
- ((graphics-engine-guardian engine) obj))
-
-(define* (graphics-engine-reap! #:optional (engine (current-graphics-engine)))
- (let ((guardian (graphics-engine-guardian engine)))
- (let loop ((obj (guardian)))
- (when obj
- (unless (find (match-lambda
- ((name . f)
- (and ((graphics-finalizer-predicate f) obj)
- ((graphics-finalizer-free f) obj)
- #t)))
- (atomic-box-ref *graphics-finalizers*))
- (error "no finalizer for graphics engine object" obj))
- (loop (guardian))))))
-
-(define-syntax-rule (with-graphics-state ((spec value) ...) body ...)
- (begin
- (graphics-engine-state-push! spec value) ...
- (let ((result (begin body ...)))
- (graphics-engine-state-pop! spec) ...
- result) ))
-
-(define-syntax-rule (with-graphics-state! ((spec value) ...) body ...)
- (with-graphics-state ((spec value) ...)
- (graphics-engine-commit!)
- body ...))
+(define (graphics-engine-reset! engine)
+ (gpu-reset! (graphics-engine-gpu engine))
+ (render-context-reset! (graphics-engine-context engine)))
+
+(define (graphics-engine-commit! engine)
+ (render-context-apply! (graphics-engine-context engine)
+ (graphics-engine-gpu engine)))
+
+(define (graphics-engine-gc engine)
+ (gpu-gc (graphics-engine-gpu engine)))
+
+;; (define-syntax context-getter
+;; (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
+;; color-mask depth-test stencil-test scissor-test
+;; viewport clear-color multisample? framebuffer
+;; vertex-array program)
+;; ((_ projection) render-context-projection)
+;; ((_ front-face) render-context-front-face)
+;; ((_ blend-mode) render-context-blend-mode)
+;; ((_ cull-face-mode) render-context-cull-face-mode)
+;; ((_ polygon-mode) render-context-polygon-mode)
+;; ((_ color-mask) render-context-color-mask)
+;; ((_ depth-test) render-context-depth-test)
+;; ((_ stencil-test) render-context-stencil-test)
+;; ((_ scissor-test) render-context-scissor-test)
+;; ((_ viewport) render-context-viewport)
+;; ((_ clear-color) render-context-clear-color)
+;; ((_ multisample?) render-context-multisample?)
+;; ((_ framebuffer) render-context-framebuffer)
+;; ((_ vertex-array) render-context-vertex-array)
+;; ((_ program) render-context-program)))
+
+;; (define-syntax context-setter
+;; (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
+;; color-mask depth-test stencil-test scissor-test
+;; viewport clear-color multisample? framebuffer
+;; vertex-array program)
+;; ((_ projection) set-render-context-projection!)
+;; ((_ front-face) set-render-context-front-face!)
+;; ((_ blend-mode) set-render-context-blend-mode!)
+;; ((_ cull-face-mode) set-render-context-cull-face-mode!)
+;; ((_ polygon-mode) set-render-context-polygon-mode!)
+;; ((_ color-mask) set-render-context-color-mask!)
+;; ((_ depth-test) set-render-context-depth-test!)
+;; ((_ stencil-test) set-render-context-stencil-test!)
+;; ((_ scissor-test) set-render-context-scissor-test!)
+;; ((_ viewport) set-render-context-viewport!)
+;; ((_ clear-color) set-render-context-clear-color!)
+;; ((_ multisample?) set-render-context-multisample!)
+;; ((_ framebuffer) set-render-context-framebuffer!)
+;; ((_ vertex-array) set-render-context-vertex-array!)
+;; ((_ program) set-render-context-program!)))
+
+;; (define-syntax current-state
+;; (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
+;; color-mask depth-test stencil-test scissor-test
+;; viewport clear-color multisample? framebuffer
+;; vertex-array program)
+;; ((_ context projection)
+;; (render-context-projection context))
+;; ((_ context front-face)
+;; (render-context-front-face context))
+;; ((_ context blend-mode)
+;; (render-context-blend-mode context))
+;; ((_ context cull-face-mode)
+;; (render-context-cull-face-mode context))
+;; ((_ context polygon-mode)
+;; (render-context-polygon-mode context))
+;; ((_ context color-mask)
+;; (render-context-color-mask context))
+;; ((_ context depth-test)
+;; (render-context-depth-test context))
+;; ((_ context stencil-test)
+;; (render-context-stencil-test context))
+;; ((_ context scissor-test)
+;; (render-context-scissor-test context))
+;; ((_ context viewport)
+;; (render-context-viewport context))
+;; ((_ context clear-color)
+;; (render-context-clear-color context))
+;; ((_ context multisample?)
+;; (render-context-multisample? context))
+;; ((_ context framebuffer)
+;; (render-context-framebuffer context))
+;; ((_ context vertex-array)
+;; (render-context-vertex-array context))
+;; ((_ context program)
+;; (render-context-program context))))
+
+;; (define-syntax change-state
+;; (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
+;; color-mask depth-test stencil-test scissor-test
+;; viewport clear-color multisample? framebuffer
+;; vertex-array program)
+;; ((_ context projection new)
+;; (set-render-context-projection! context new))
+;; ((_ context front-face new)
+;; (set-render-context-front-face! context new))
+;; ((_ context blend-mode new)
+;; (set-render-context-blend-mode! context new))
+;; ((_ context cull-face-mode new)
+;; (set-render-context-cull-face-mode! context new))
+;; ((_ context polygon-mode new)
+;; (set-render-context-polygon-mode! context new))
+;; ((_ context color-mask new)
+;; (set-render-context-color-mask! context new))
+;; ((_ context depth-test new)
+;; (set-render-context-depth-test! context new))
+;; ((_ context stencil-test new)
+;; (set-render-context-stencil-test! context new))
+;; ((_ context scissor-test new)
+;; (set-render-context-scissor-test! context new))
+;; ((_ context viewport new)
+;; (set-render-context-viewport! context new))
+;; ((_ context clear-color new)
+;; (set-render-context-clear-color! context new))
+;; ((_ context multisample? new)
+;; (set-render-context-multisample?! context new))
+;; ((_ context framebuffer new)
+;; (set-render-context-framebuffer! context new))
+;; ((_ context vertex-array new)
+;; (set-render-context-vertex-array! context new))
+;; ((_ context program new)
+;; (set-render-context-program! context new))))
+
+;; (define-syntax %with-graphics-state
+;; (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
+;; color-mask depth-test stencil-test scissor-test
+;; viewport clear-color multisample? framebuffer
+;; vertex-array program texture)
+;; ((_ context () body ...)
+;; (begin body ...))
+;; ((_ context ((texture i new) . rest) body ...)
+;; (let ((old (render-context-texture context i)))
+;; (set-render-context-texture! context i new)
+;; (%with-graphics-state context rest body ...)
+;; (set-render-context-texture! context i old)))
+;; ((_ context ((param new) . rest) body ...)
+;; (let ((old ((context-getter param) context)))
+;; ((context-setter param) context new)
+;; (%with-graphics-state context rest body ...)
+;; ((context-setter param) context old)))))
+
+(define-syntax context-getter
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name)
+ (match (syntax->datum #'name)
+ ('projection #'render-context-projection)
+ ('front-face #'render-context-front-face)
+ ('blend-mode #'render-context-blend-mode)
+ ('cull-face-mode #'render-context-cull-face-mode)
+ ('polygon-mode #'render-context-polygon-mode)
+ ('color-mask #'render-context-color-mask)
+ ('depth-test #'render-context-depth-test)
+ ('stencil-test #'render-context-stencil-test)
+ ('scissor-test #'render-context-scissor-test)
+ ('viewport #'render-context-viewport)
+ ('clear-color #'render-context-clear-color)
+ ('multisample? #'render-context-multisample?)
+ ('framebuffer #'render-context-framebuffer)
+ ('buffer #'render-context-buffer)
+ ('vertex-array #'render-context-vertex-array)
+ ('program #'render-context-program))))))
+
+(define-syntax context-setter
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name)
+ (match (syntax->datum #'name)
+ ('projection #'set-render-context-projection!)
+ ('front-face #'set-render-context-front-face!)
+ ('blend-mode #'set-render-context-blend-mode!)
+ ('cull-face-mode #'set-render-context-cull-face-mode!)
+ ('polygon-mode #'set-render-context-polygon-mode!)
+ ('color-mask #'set-render-context-color-mask!)
+ ('depth-test #'set-render-context-depth-test!)
+ ('stencil-test #'set-render-context-stencil-test!)
+ ('scissor-test #'set-render-context-scissor-test!)
+ ('viewport #'set-render-context-viewport!)
+ ('clear-color #'set-render-context-clear-color!)
+ ('multisample? #'set-render-context-multisample!)
+ ('framebuffer #'set-render-context-framebuffer!)
+ ('buffer #'set-render-context-buffer!)
+ ('vertex-array #'set-render-context-vertex-array!)
+ ('program #'set-render-context-program!))))))
+
+(define-syntax %with-graphics-state
+ (lambda (x)
+ (syntax-case x ()
+ ((_ context () body ...)
+ #'(let () body ...))
+ ((_ context ((name i new) . rest) body ...)
+ (and (identifier? #'name) (eq? (syntax->datum #'name) 'texture))
+ #'(let ((old (render-context-texture context i)))
+ (set-render-context-texture! context i new)
+ (let ((result (%with-graphics-state context rest body ...)))
+ (set-render-context-texture! context i old)
+ result)))
+ ((_ context ((name new) . rest) body ...)
+ (identifier? #'name)
+ #'(let ((old ((context-getter name) context)))
+ ((context-setter name) context new)
+ (let ((result (%with-graphics-state context rest body ...)))
+ ((context-setter name) context old)
+ result))))))
+
+(define-syntax-rule (with-graphics-state settings body ...)
+ (let ((context (graphics-engine-context (current-graphics-engine))))
+ (%with-graphics-state context settings body ...)))
+
+(define-syntax-rule (with-graphics-state! settings body ...)
+ (let* ((engine (current-graphics-engine))
+ (context (graphics-engine-context engine)))
+ (%with-graphics-state context settings
+ (let ()
+ (graphics-engine-commit! engine)
+ body ...))))
diff --git a/chickadee/graphics/framebuffer.scm b/chickadee/graphics/framebuffer.scm
index bee4b7d..f4f3100 100644
--- a/chickadee/graphics/framebuffer.scm
+++ b/chickadee/graphics/framebuffer.scm
@@ -29,6 +29,7 @@
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics pixbuf)
#:use-module ((chickadee graphics texture) #:select (make-texture null-texture))
#:use-module (chickadee graphics viewport)
@@ -42,18 +43,6 @@
current-framebuffer
with-framebuffer))
-(define (generate-framebuffer)
- "Generate a new OpenGL framebuffer object."
- (let ((bv (u32vector 1)))
- (gl-gen-framebuffers 1 (bytevector->pointer bv))
- (u32vector-ref bv 0)))
-
-(define (generate-renderbuffer)
- "Generate a new OpenGL renderbuffer object."
- (let ((bv (u32vector 1)))
- (gl-gen-renderbuffers 1 (bytevector->pointer bv))
- (u32vector-ref bv 0)))
-
(define-record-type <framebuffer>
(%make-framebuffer id renderbuffer-id texture viewport projection)
framebuffer?
@@ -66,33 +55,6 @@
(define null-framebuffer
(%make-framebuffer 0 0 null-texture null-viewport (make-identity-matrix4)))
-(define (free-framebuffer framebuffer)
- (gl-delete-renderbuffers 1
- (bytevector->pointer
- (u32vector
- (framebuffer-renderbuffer-id framebuffer))))
- (gl-delete-framebuffers 1
- (bytevector->pointer
- (u32vector
- (framebuffer-id framebuffer)))))
-
-(define (apply-framebuffer framebuffer)
- (gl-bind-framebuffer (version-3-0 framebuffer)
- (framebuffer-id framebuffer)))
-
-(define (bind-framebuffer framebuffer)
- (gl-bind-framebuffer (version-3-0 framebuffer)
- (framebuffer-id framebuffer)))
-
-(define-graphics-finalizer framebuffer-finalizer
- #:predicate framebuffer?
- #:free free-framebuffer)
-
-(define-graphics-state g:framebuffer
- current-framebuffer
- #:default null-framebuffer
- #:bind bind-framebuffer)
-
(define %clear-color (transparency 0.0))
(define %draw-buffers (bytevector->pointer (u32vector (version-3-0 color-attachment0))))
@@ -101,8 +63,9 @@
"Create a new framebuffer that renders to a texture with
dimensions WIDTH x HEIGHT."
(assert-current-graphics-engine)
- (let* ((framebuffer-id (generate-framebuffer))
- (renderbuffer-id (generate-renderbuffer))
+ (let* ((gpu (current-gpu))
+ (framebuffer-id (fresh-gpu-framebuffer gpu))
+ (renderbuffer-id (fresh-gpu-renderbuffer gpu))
(texture (make-texture width height
#:min-filter min-filter
#:mag-filter mag-filter
@@ -120,28 +83,28 @@ dimensions WIDTH x HEIGHT."
texture
viewport
projection)))
- (graphics-engine-guard! framebuffer)
- (with-graphics-state! ((g:framebuffer framebuffer))
- ;; Setup depth buffer.
- (gl-bind-renderbuffer (version-3-0 renderbuffer)
- renderbuffer-id)
- (gl-renderbuffer-storage (version-3-0 renderbuffer)
- (arb-framebuffer-object depth24-stencil8)
- width
- height)
- (gl-bind-renderbuffer (version-3-0 renderbuffer) 0)
- (gl-framebuffer-renderbuffer (version-3-0 framebuffer)
- (arb-framebuffer-object depth-stencil-attachment)
- (version-3-0 renderbuffer)
- renderbuffer-id)
- ;; Setup framebuffer.
- (gl-framebuffer-texture-2d (version-3-0 framebuffer)
- (version-3-0 color-attachment0)
- (texture-target texture-2d)
- ((@@ (chickadee graphics texture) texture-id)
- texture)
- 0)
- (gl-draw-buffers 1 %draw-buffers))
+ (set-gpu-renderbuffer! gpu renderbuffer-id)
+ (set-gpu-framebuffer! gpu framebuffer-id)
+ ;; Setup depth buffer.
+ (gl-bind-renderbuffer (version-3-0 renderbuffer)
+ renderbuffer-id)
+ (gl-renderbuffer-storage (version-3-0 renderbuffer)
+ (arb-framebuffer-object depth24-stencil8)
+ width
+ height)
+ (gl-bind-renderbuffer (version-3-0 renderbuffer) 0)
+ (gl-framebuffer-renderbuffer (version-3-0 framebuffer)
+ (arb-framebuffer-object depth-stencil-attachment)
+ (version-3-0 renderbuffer)
+ renderbuffer-id)
+ ;; Setup framebuffer.
+ (gl-framebuffer-texture-2d (version-3-0 framebuffer)
+ (version-3-0 color-attachment0)
+ (texture-target texture-2d)
+ ((@@ (chickadee graphics texture) texture-id)
+ texture)
+ 0)
+ (gl-draw-buffers 1 %draw-buffers)
;; Check for errors.
(unless (= (gl-check-framebuffer-status (version-3-0 framebuffer))
(version-3-0 framebuffer-complete))
@@ -153,8 +116,8 @@ dimensions WIDTH x HEIGHT."
;; as well so that the user doesn't have to explicitly make a
;; viewport and/or projection matrix unless they actually want to do
;; fancy viewport manipulations.
- (with-graphics-state! ((g:framebuffer framebuffer)
- (g:viewport (framebuffer-viewport framebuffer)))
- (clear-viewport)
- (with-projection (framebuffer-projection framebuffer)
+ (with-graphics-state ((framebuffer (framebuffer-id framebuffer))
+ (projection (framebuffer-projection framebuffer)))
+ (with-viewport (framebuffer-viewport framebuffer)
+ (clear-viewport)
body ...)))
diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm
index c63cc4d..5549266 100644
--- a/chickadee/graphics/gpu.scm
+++ b/chickadee/graphics/gpu.scm
@@ -79,6 +79,7 @@
depth-test-function
depth-test-near
depth-test-far
+ depth-test:default
make-stencil-test
stencil-test?
@@ -96,6 +97,7 @@
stencil-test-on-depth-fail-back
stencil-test-on-pass-front
stencil-test-on-pass-back
+ stencil-test:default
make-window-rect
window-rect?
@@ -103,6 +105,7 @@
window-rect-y
window-rect-width
window-rect-height
+ window-rect:empty
fresh-gpu-framebuffer
free-gpu-framebuffer
@@ -190,9 +193,7 @@
set-gpu-program!
set-gpu-texture!
gpu-gc
- gpu-reset!
-
- current-gpu))
+ gpu-reset!))
;;;
@@ -337,7 +338,7 @@
front-face-direction->symbol)))
(define (bind-front-face front-face)
- (gl-front-face (front-face-winding 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))
@@ -452,12 +453,14 @@
(define (bind-depth-test depth-test)
(match depth-test
(#f (gl-disable (enable-cap depth-test)))
- (($ <depth-test> write? near far func)
+ (($ <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
@@ -570,6 +573,8 @@
(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))
@@ -589,6 +594,8 @@
(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)))
@@ -767,8 +774,6 @@
(%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))
@@ -834,6 +839,9 @@
((? 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))
@@ -842,7 +850,8 @@
(loop))))))
(define (guard! gpu obj)
- ((gpu-guardian gpu) obj))
+ ((gpu-guardian gpu) obj)
+ obj)
(define-syntax-rule (define-fresh name constructor params ...)
(define (name gpu params ...)
@@ -852,6 +861,7 @@
(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)
@@ -864,8 +874,8 @@
(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-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)
diff --git a/chickadee/graphics/mesh.scm b/chickadee/graphics/mesh.scm
index 8bf4f8f..ba9bb3d 100644
--- a/chickadee/graphics/mesh.scm
+++ b/chickadee/graphics/mesh.scm
@@ -23,17 +23,13 @@
#:use-module (chickadee math)
#:use-module (chickadee math matrix)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics buffer)
#:use-module (chickadee graphics color)
- #:use-module (chickadee graphics depth)
#:use-module (chickadee graphics engine)
- #:use-module (chickadee graphics multisample)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics light)
- #:use-module (chickadee graphics polygon)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics skybox)
- #:use-module (chickadee graphics stencil)
#:use-module (chickadee graphics texture)
#:use-module (chickadee utils)
#:use-module (ice-9 match)
@@ -104,10 +100,10 @@
(name "anonymous")
(shader null-shader)
(blend-mode blend:replace)
- (polygon-mode fill-polygon-mode)
- (cull-face-mode back-cull-face-mode)
- (depth-test basic-depth-test)
- (stencil-test default-stencil-test)
+ (polygon-mode polygon:fill)
+ (cull-face-mode cull-face:back)
+ (depth-test depth-test:default)
+ (stencil-test stencil-test:default)
multisample?
(texture-0 null-texture)
(texture-1 null-texture)
@@ -123,18 +119,18 @@
(define (material-apply material vertex-array model-matrix view-matrix
camera-position skybox light-vector)
- (with-graphics-state ((g:blend-mode (material-blend-mode material))
- (g:cull-face-mode (material-cull-face-mode material))
- (g:depth-test (material-depth-test material))
- (g:multisample? (material-multisample? material))
- (g:polygon-mode (material-polygon-mode material))
- (g:stencil-test (material-stencil-test material))
- (g:texture-0 (skybox-cube-map skybox))
- (g:texture-1 (material-texture-0 material))
- (g:texture-2 (material-texture-1 material))
- (g:texture-3 (material-texture-2 material))
- (g:texture-4 (material-texture-3 material))
- (g:texture-5 (material-texture-4 material)))
+ (with-graphics-state ((blend-mode (material-blend-mode material))
+ (cull-face-mode (material-cull-face-mode material))
+ (depth-test (material-depth-test material))
+ (multisample? (material-multisample? material))
+ (polygon-mode (material-polygon-mode material))
+ (stencil-test (material-stencil-test material))
+ (texture 0 (texture-id (skybox-cube-map skybox)))
+ (texture 1 (texture-id (material-texture-0 material)))
+ (texture 2 (texture-id (material-texture-1 material)))
+ (texture 3 (texture-id (material-texture-2 material)))
+ (texture 4 (texture-id (material-texture-3 material)))
+ (texture 5 (texture-id (material-texture-4 material))))
(shader-apply (material-shader material) vertex-array
#:model model-matrix
#:view view-matrix
diff --git a/chickadee/graphics/model.scm b/chickadee/graphics/model.scm
index 5746e5a..737748f 100644
--- a/chickadee/graphics/model.scm
+++ b/chickadee/graphics/model.scm
@@ -27,16 +27,13 @@
#:use-module (chickadee math quaternion)
#:use-module (chickadee math vector)
#:use-module (chickadee graphics buffer)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics color)
- #:use-module (chickadee graphics depth)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics light)
#:use-module (chickadee graphics mesh)
- #:use-module (chickadee graphics multisample)
#:use-module (chickadee graphics pbr)
#:use-module (chickadee graphics phong)
- #:use-module (chickadee graphics polygon)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics skybox)
#:use-module (chickadee graphics texture)
@@ -147,7 +144,6 @@
(define* (make-model #:key name scenes (default-scene (car scenes)) render-state)
(%make-model name scenes default-scene render-state))
-(define %depth-test (make-depth-test))
(define %identity-matrix (make-identity-matrix4))
(define %origin (vec3 0.0 0.0 0.0))
@@ -157,8 +153,8 @@
(camera-position %origin)
(skybox (default-skybox))
(lights '()))
- (with-graphics-state ((g:depth-test %depth-test)
- (g:multisample? #t))
+ (with-graphics-state ((depth-test depth-test:default)
+ (multisample? #t))
(let ((state (model-render-state model)))
(render-state-reset! state)
(render-state-model-matrix-mult! state model-matrix)
@@ -877,9 +873,7 @@
(make-pbr-material
#:name name
#:blend-mode (if (eq? alpha-mode 'opaque) blend:alpha blend:replace)
- #:cull-face-mode (if double-sided?
- no-cull-face-mode
- back-cull-face-mode)
+ #:cull-face-mode (if double-sided? cull-face:none cull-face:back)
#:base-color-texture base-color-texture
#:metallic-roughness-texture metal-rough-texture
#:normal-texture normal-texture
diff --git a/chickadee/graphics/multisample.scm b/chickadee/graphics/multisample.scm
deleted file mode 100644
index cd54d55..0000000
--- a/chickadee/graphics/multisample.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-;;; Chickadee Game Toolkit
-;;; Copyright © 2021 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:
-;;
-;; Multisampling.
-;;
-;;; Code:
-
-(define-module (chickadee graphics multisample)
- #:use-module (chickadee graphics engine)
- #:use-module (gl)
- #:export (g:multisample?
- current-multisample))
-
-(define (bind-multisample multisample?)
- (if multisample?
- (gl-enable (version-1-3 multisample))
- (gl-disable (version-1-3 multisample))))
-
-(define-graphics-state g:multisample?
- current-multisample
- #:default #f
- #:bind bind-multisample)
diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm
index d8bd1b2..35aa6fc 100644
--- a/chickadee/graphics/particles.scm
+++ b/chickadee/graphics/particles.scm
@@ -24,10 +24,10 @@
#:use-module (chickadee math matrix)
#:use-module (chickadee math rect)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics buffer)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics texture)
#:export (make-particle-emitter
@@ -285,7 +285,7 @@ default.
(hw (- hh) 1.0 0.0)
(hw hh 1.0 1.0)
((- hw) hh 0.0 1.0)))
- (geometry-index-append! geometry 0 3 2 0 2 1))
+ (geometry-index-append! geometry 0 2 3 0 1 2))
(%make-particles capacity
0
;; 1 extra element as swap space for sorting.
@@ -431,8 +431,8 @@ default.
(let ((shader (graphics-variable-ref particles-shader))
(mvp (graphics-variable-ref mvp-matrix))
(geometry (particles-geometry particles)))
- (with-graphics-state ((g:blend-mode (particles-blend-mode particles))
- (g:texture-0 (particles-texture particles)))
+ (with-graphics-state ((blend-mode (particles-blend-mode particles))
+ (texture 0 (texture-id (particles-texture particles))))
(shader-apply/instanced shader
(geometry-vertex-array geometry)
(particles-size particles)
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 30d4c7c..f98e038 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -22,16 +22,13 @@
(define-module (chickadee graphics path)
#:use-module (chickadee config)
#:use-module (chickadee data array-list)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics buffer)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics framebuffer)
#:use-module (chickadee graphics gl)
- #:use-module (chickadee graphics multisample)
- #:use-module (chickadee graphics polygon)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics shader)
- #:use-module (chickadee graphics stencil)
#:use-module (chickadee graphics texture)
#:use-module (chickadee image)
#:use-module (chickadee math)
@@ -954,13 +951,11 @@
;; requires looking at the newest 2 points + the 2
;; previous points.
(unless first?
- (geometry-index-append! geometry
- (- vert-count 1)
- (- vert-count 2)
- vert-count
- (- vert-count 1)
- vert-count
- (+ vert-count 1)))))
+ (let ((l1 (- vert-count 2))
+ (r1 (- vert-count 1))
+ (l2 vert-count)
+ (r2 (+ vert-count 1)))
+ (geometry-index-append! geometry r1 l2 l1 r1 r2 l2)))))
(define (set-length i length)
(stroke-vertex-set! geometry length (* i 2) length)
(stroke-vertex-set! geometry length (+ (* i 2) 1) length))
@@ -1235,7 +1230,7 @@
(define stencil-cover-and-clear
(make-stencil-test #:on-fail 'zero #:on-depth-fail 'zero #:on-pass 'zero
- #:function 'not-equal))
+ #:function '!=))
(define *debug?* #f)
@@ -1250,7 +1245,7 @@
(matrix4-mult! mvp matrix (current-projection))
;; Wireframe debug mode.
(when *debug?*
- (with-graphics-state ((g:polygon-mode line-polygon-mode))
+ (with-graphics-state ((polygon-mode polygon:line))
(for-range ((i n))
(shader-apply* shader
(geometry-vertex-array stencil-geometry)
@@ -1258,7 +1253,7 @@
(u32vector-ref counts i)
#:mvp (current-projection)))))
;; Anti-alias the edges of the fill.
- (with-graphics-state ((g:multisample? #t))
+ (with-graphics-state ((multisample? #t))
;; Render fan to stencil buffer. Each time a triangle is
;; rasterized, it flips the values in the stencil buffer for
;; those fragments. So, the first time a triangle is rendered,
@@ -1270,8 +1265,9 @@
;;
;; For more information, see:
;; http://developer.download.nvidia.com/devzone/devcenter/gamegraphics/files/opengl/gpupathrender.pdf
- (with-graphics-state ((g:color-mask null-color-mask)
- (g:stencil-test stencil-flip))
+ (with-graphics-state ((color-mask color-mask:none)
+ (stencil-test stencil-flip)
+ (cull-face-mode cull-face:none))
(for-range ((i n))
(shader-apply* shader
(geometry-vertex-array stencil-geometry)
@@ -1281,8 +1277,8 @@
;; Render a quad with the stencil applied. The quad is the size
;; of the path's bounding box. The stencil test will make it so
;; we only draw fragments that are part of the filled path.
- (with-graphics-state ((g:stencil-test stencil-cover-and-clear)
- (g:blend-mode (filled-path-blend-mode filled-path)))
+ (with-graphics-state ((stencil-test stencil-cover-and-clear)
+ (blend-mode (filled-path-blend-mode filled-path)))
(let ((color (filled-path-color filled-path)))
(if (gradient? color)
;; Linear/radial gradient fill.
@@ -1310,7 +1306,7 @@
(let ((shader (graphics-variable-ref stroke-shader))
(mvp (graphics-variable-ref mvp-matrix)))
(matrix4-mult! mvp matrix (current-projection))
- (with-graphics-state ((g:blend-mode (stroked-path-blend-mode stroked-path)))
+ (with-graphics-state ((blend-mode (stroked-path-blend-mode stroked-path)))
(let ((geometry (stroked-path-geometry stroked-path)))
(shader-apply* shader
(geometry-vertex-array geometry)
diff --git a/chickadee/graphics/pbr.scm b/chickadee/graphics/pbr.scm
index a2c7251..e7e4333 100644
--- a/chickadee/graphics/pbr.scm
+++ b/chickadee/graphics/pbr.scm
@@ -22,15 +22,12 @@
(define-module (chickadee graphics pbr)
#:use-module (chickadee config)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics buffer)
#:use-module (chickadee graphics color)
- #:use-module (chickadee graphics depth)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics mesh)
- #:use-module (chickadee graphics polygon)
#:use-module (chickadee graphics shader)
- #:use-module (chickadee graphics stencil)
#:use-module (chickadee graphics texture)
#:use-module (srfi srfi-9)
#:export (make-pbr-properties
@@ -73,10 +70,10 @@
(define* (make-pbr-material #:key (name "anonymous")
(blend-mode blend:replace)
- (polygon-mode fill-polygon-mode)
- (cull-face-mode back-cull-face-mode)
- (depth-test basic-depth-test)
- (stencil-test default-stencil-test)
+ (polygon-mode polygon:fill)
+ (cull-face-mode cull-face:back)
+ (depth-test depth-test:default)
+ (stencil-test stencil-test:default)
multisample?
(base-color-factor (vec3 1.0 1.0 1.0))
(base-color-texcoord 0)
diff --git a/chickadee/graphics/phong.scm b/chickadee/graphics/phong.scm
index 8812a9a..2e3fafc 100644
--- a/chickadee/graphics/phong.scm
+++ b/chickadee/graphics/phong.scm
@@ -22,15 +22,12 @@
(define-module (chickadee graphics phong)
#:use-module (chickadee config)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics color)
- #:use-module (chickadee graphics depth)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics light)
#:use-module (chickadee graphics mesh)
- #:use-module (chickadee graphics polygon)
#:use-module (chickadee graphics shader)
- #:use-module (chickadee graphics stencil)
#:use-module (chickadee graphics texture)
#:use-module (srfi srfi-9)
#:export (make-phong-properties
@@ -59,10 +56,10 @@
(define* (make-phong-material #:key (name "anonymous")
(blend-mode blend:replace)
- (polygon-mode fill-polygon-mode)
- (cull-face-mode back-cull-face-mode)
- (depth-test basic-depth-test)
- (stencil-test default-stencil-test)
+ (polygon-mode polygon:fill)
+ (cull-face-mode cull-face:back)
+ (depth-test depth-test:default)
+ (stencil-test stencil-test:default)
multisample?
(ambient-factor (vec3 1.0 1.0 1.0))
(diffuse-factor (vec3 1.0 1.0 1.0))
diff --git a/chickadee/graphics/polygon.scm b/chickadee/graphics/polygon.scm
deleted file mode 100644
index 0e05018..0000000
--- a/chickadee/graphics/polygon.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-;;; Chickadee Game Toolkit
-;;; Copyright © 2020, 2021 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
-;;
-;; Polygon face rendering configuration.
-;;
-;;; Code:
-
-(define-module (chickadee graphics polygon)
- #:use-module (chickadee graphics engine)
- #:use-module (chickadee graphics gl)
- #:use-module (gl)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-9)
- #:export (make-polygon-mode
- polygon-mode?
- polygon-mode-front
- polygon-mode-back
- fill-polygon-mode
- line-polygon-mode
- point-polygon-mode
- g:polygon-mode
- current-polygon-mode
-
- cull-face-mode?
- cull-face-mode-front?
- cull-face-mode-back?
- no-cull-face-mode
- back-cull-face-mode
- front-cull-face-mode
- front-and-back-cull-face-mode
- g:cull-face-mode
- current-cull-face-mode))
-
-(define-record-type <polygon-mode>
- (make-polygon-mode front back)
- polygon-mode?
- (front polygon-mode-front)
- (back polygon-mode-back))
-
-(define fill-polygon-mode (make-polygon-mode 'fill 'fill))
-(define line-polygon-mode (make-polygon-mode 'line 'line))
-(define point-polygon-mode (make-polygon-mode 'point 'point))
-
-(define (bind-polygon-mode mode)
- (define (glmode sym)
- (match sym
- ('fill (polygon-mode fill))
- ('line (polygon-mode line))
- ('point (polygon-mode point))))
- (let ((front (polygon-mode-front mode))
- (back (polygon-mode-back mode)))
- (if (eq? front back)
- (gl-polygon-mode (cull-face-mode front-and-back) (glmode front))
- (begin
- (gl-polygon-mode (cull-face-mode front) (glmode front))
- (gl-polygon-mode (cull-face-mode back) (glmode back))))))
-
-(define-graphics-state g:polygon-mode
- current-polygon-mode
- #:default fill-polygon-mode
- #:bind bind-polygon-mode)
-
-(define-record-type <cull-face-mode>
- (make-cull-face-mode front? back?)
- cull-face-mode?
- (front? cull-face-mode-front?)
- (back? cull-face-mode-back?))
-
-(define no-cull-face-mode (make-cull-face-mode #f #f))
-(define back-cull-face-mode (make-cull-face-mode #f #t))
-(define front-cull-face-mode (make-cull-face-mode #t #f))
-(define front-and-back-cull-face-mode (make-cull-face-mode #t #t))
-
-(define (bind-cull-face-mode mode)
- (let ((front? (cull-face-mode-front? mode))
- (back? (cull-face-mode-back? mode)))
- (cond
- ((and front? back?)
- (gl-enable (enable-cap cull-face))
- (gl-cull-face (cull-face-mode front-and-back)))
- (front?
- (gl-enable (enable-cap cull-face))
- (gl-cull-face (cull-face-mode front)))
- (back?
- (gl-enable (enable-cap cull-face))
- (gl-cull-face (cull-face-mode back)))
- (else
- (gl-disable (enable-cap cull-face))))))
-
-(define-graphics-state g:cull-face-mode
- current-cull-face-mode
- #:default back-cull-face-mode
- #:bind bind-cull-face-mode)
diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm
index 94c6bfc..f1e930f 100644
--- a/chickadee/graphics/shader.scm
+++ b/chickadee/graphics/shader.scm
@@ -33,6 +33,7 @@
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics texture)
#:use-module (chickadee utils)
#:export (shader-data-type?
@@ -501,45 +502,33 @@
(location attribute-location)
(type attribute-type))
-(define null-shader (%make-shader 0 (make-hash-table) (make-hash-table) #f #f))
-
-(define (bind-shader shader)
- (gl-use-program (shader-id shader)))
-
-(define (free-shader shader)
- (gl-delete-program (shader-id shader)))
-
-(define-graphics-finalizer shader-finalizer
- #:predicate shader?
- #:free free-shader)
-
-(define-graphics-state g:shader
- current-shader
- #:default null-shader
- #:bind bind-shader)
+(define null-shader (%make-shader gpu-program:null (make-hash-table) (make-hash-table) #f #f))
(define (make-shader vertex-port fragment-port)
"Read GLSL source from VERTEX-PORT and FRAGMENT-PORT and compile
them into a GPU shader program."
(define (shader-compiled? id)
(let ((status (make-u32vector 1)))
- (gl-get-shaderiv id (version-2-0 compile-status)
+ (gl-get-shaderiv (gpu-shader-id id)
+ (version-2-0 compile-status)
(bytevector->pointer status))
(= (u32vector-ref status 0) 1)))
(define (shader-linked? id)
(let ((status (make-u32vector 1)))
- (gl-get-programiv id (version-2-0 link-status)
+ (gl-get-programiv (gpu-program-id id)
+ (version-2-0 link-status)
(bytevector->pointer status))
(= (u32vector-ref status 0) 1)))
(define (info-log length-proc log-proc id)
(let ((log-length-bv (make-u32vector 1)))
- (length-proc id (version-2-0 info-log-length)
+ (length-proc (gpu-shader-id id) (version-2-0 info-log-length)
(bytevector->pointer log-length-bv))
(u32vector-ref log-length-bv 0)
;; Add one byte to account for the null string terminator.
(let* ((log-length (u32vector-ref log-length-bv 0))
(log (make-u8vector (1+ log-length))))
- (log-proc id log-length %null-pointer (bytevector->pointer log))
+ (log-proc (gpu-shader-id id) log-length %null-pointer
+ (bytevector->pointer log))
(utf8->string log))))
(define (compilation-error id)
(info-log gl-get-shaderiv gl-get-shader-info-log id))
@@ -549,7 +538,8 @@ them into a GPU shader program."
;; Set up preprocessor directives dynamically based on the current
;; OpenGL context's GLSL version so that we can write shaders that
;; are compatible with as many systems as possible.
- (let ((glsl-version (graphics-engine-glsl-version)))
+ (let ((glsl-version (graphics-engine-glsl-version
+ (current-graphics-engine))))
(cond
((string>= glsl-version "3.3")
"#version 330
@@ -566,27 +556,28 @@ them into a GPU shader program."
(else
(error "incompatible GLSL version" glsl-version)))))
(define (make-shader-stage type port)
- (let ((id (gl-create-shader type))
- (source (string->utf8
- (string-append (glsl-preprocessor-source)
- (get-string-all port)))))
- (gl-shader-source id 1
+ (let* ((gpu (current-gpu))
+ (id (fresh-gpu-shader gpu type))
+ (source (string->utf8
+ (string-append (glsl-preprocessor-source)
+ (get-string-all port)))))
+ (gl-shader-source (gpu-shader-id id) 1
(bytevector->pointer
(u64vector
(pointer-address (bytevector->pointer source))))
(bytevector->pointer
(u32vector (bytevector-length source))))
- (gl-compile-shader id)
+ (gl-compile-shader (gpu-shader-id id))
(unless (shader-compiled? id)
(let ((error-log (compilation-error id)))
- (gl-delete-shader id) ; clean up GPU resource.
+ (free-gpu-shader id) ; clean up GPU resource.
(display "shader compilation failed:\n")
(display error-log (current-error-port))
(error "failed to compile shader")))
id))
(define (uniform-count id)
(let ((bv (make-u32vector 1)))
- (gl-get-programiv id
+ (gl-get-programiv (gpu-program-id id)
(arb-shader-objects active-uniforms)
(bytevector->pointer bv))
(u32vector-ref bv 0)))
@@ -677,7 +668,8 @@ them into a GPU shader program."
(size-bv (make-u32vector 1))
(type-bv (make-u32vector 1))
(name-bv (make-bytevector 255)))
- (gl-get-active-uniform id i
+ (gl-get-active-uniform (gpu-program-id id)
+ i
(bytevector-length name-bv)
(bytevector->pointer length-bv)
(bytevector->pointer size-bv)
@@ -685,7 +677,7 @@ them into a GPU shader program."
(bytevector->pointer name-bv))
(let* ((name-length (u32vector-ref length-bv 0))
(name (utf8->string* name-bv name-length))
- (location (gl-get-uniform-location id name))
+ (location (gl-get-uniform-location (gpu-program-id id) name))
(size (u32vector-ref size-bv 0))
(type (parse-data-type (u32vector-ref type-bv 0)))
(sampler? (or (eq? type sampler-2d) (eq? type sampler-cube)))
@@ -719,7 +711,7 @@ them into a GPU shader program."
(values namespace scratch-size)))))
(define (attribute-count id)
(let ((bv (make-u32vector 1)))
- (gl-get-programiv id
+ (gl-get-programiv (gpu-program-id id)
(arb-shader-objects active-attributes)
(bytevector->pointer bv))
(u32vector-ref bv 0)))
@@ -731,7 +723,8 @@ them into a GPU shader program."
(size-bv (make-u32vector 1))
(type-bv (make-u32vector 1))
(name-bv (make-bytevector 255)))
- (gl-get-active-attrib id i
+ (gl-get-active-attrib (gpu-program-id id)
+ i
(bytevector-length name-bv)
(bytevector->pointer length-bv)
(bytevector->pointer size-bv)
@@ -741,26 +734,25 @@ them into a GPU shader program."
(name (utf8->string* name-bv length))
(size (u32vector-ref size-bv 0))
(type (parse-data-type (u32vector-ref type-bv 0)))
- (location (gl-get-attrib-location id name)))
+ (location (gl-get-attrib-location (gpu-program-id id) name)))
(unless (= size 1)
(error "unsupported attribute size" name size))
(hash-set! table name (make-attribute name location type)))))
table))
(assert-current-graphics-engine)
- (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
- vertex-port))
- (fragment-id (make-shader-stage (version-2-0 fragment-shader)
- fragment-port))
- (id (gl-create-program)))
- (gl-attach-shader id vertex-id)
- (gl-attach-shader id fragment-id)
- (gl-link-program id)
+ (let* ((gpu (current-gpu))
+ (vertex-id (make-shader-stage 'vertex vertex-port))
+ (fragment-id (make-shader-stage 'fragment fragment-port))
+ (id (fresh-gpu-program gpu)))
+ (gl-attach-shader (gpu-program-id id) (gpu-shader-id vertex-id))
+ (gl-attach-shader (gpu-program-id id) (gpu-shader-id fragment-id))
+ (gl-link-program (gpu-program-id id))
(unless (shader-linked? id)
(let ((error-log (linking-error id)))
- (gl-delete-program id)
+ (free-gpu-program id)
(error "failed to link shader" error-log)))
- (gl-delete-shader vertex-id)
- (gl-delete-shader fragment-id)
+ (free-gpu-shader vertex-id)
+ (free-gpu-shader fragment-id)
(call-with-values
(lambda () (extract-uniforms id))
(lambda (namespace scratch-size)
@@ -768,7 +760,6 @@ them into a GPU shader program."
(scratch-ptr (bytevector->pointer scratch))
(shader (%make-shader id (extract-attributes id) namespace
scratch scratch-ptr)))
- (graphics-engine-guard! shader)
shader)))))
(define (load-shader vertex-source-file fragment-source-file)
@@ -878,9 +869,10 @@ shader program."
(shader-uniform-set! shader 'sname value)
(uniform-apply shader rest)))))))
-(define-syntax-rule (shader-apply** shader* vertex-array uniforms exp)
- (with-graphics-state! ((g:shader shader*))
- (uniform-apply shader* uniforms)
+(define-syntax-rule (shader-apply** shader vertex-array uniforms exp)
+ (with-graphics-state ((program (shader-id shader)))
+ (graphics-engine-commit! (current-graphics-engine))
+ (uniform-apply shader uniforms)
;; Sampler2D values aren't explicitly passed as uniform values via
;; shader-apply, so we have to bind them to the proper texture units
;; behind the scenes.
@@ -888,8 +880,8 @@ shader program."
(lambda (uniform)
(when (or (eq? (uniform-type uniform) sampler-2d)
(eq? (uniform-type uniform) sampler-cube))
- (set-uniform-value! shader* uniform (uniform-value uniform))))
- shader*)
+ (set-uniform-value! shader uniform (uniform-value uniform))))
+ shader)
exp))
(define-syntax-rule (shader-apply* shader vertex-array offset count . uniforms)
diff --git a/chickadee/graphics/skybox.scm b/chickadee/graphics/skybox.scm
index 31fcd76..d94c13e 100644
--- a/chickadee/graphics/skybox.scm
+++ b/chickadee/graphics/skybox.scm
@@ -22,12 +22,10 @@
(define-module (chickadee graphics skybox)
#:use-module (chickadee config)
#:use-module (chickadee graphics buffer)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics color)
- #:use-module (chickadee graphics depth)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics pixbuf)
- #:use-module (chickadee graphics polygon)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics texture)
#:use-module (srfi srfi-9)
@@ -112,7 +110,7 @@
(force %skybox-shader))
(define (draw-skybox skybox view)
- (with-graphics-state ((g:texture-0 (skybox-cube-map skybox)))
+ (with-graphics-state ((texture 0 (texture-id (skybox-cube-map skybox))))
(shader-apply (skybox-shader) (skybox-vertex-array skybox)
#:view view
#:projection (current-projection))))
diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm
index 29c1088..8fdabfd 100644
--- a/chickadee/graphics/sprite.scm
+++ b/chickadee/graphics/sprite.scm
@@ -21,12 +21,12 @@
#:use-module (chickadee math matrix)
#:use-module (chickadee math rect)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
+ #:use-module (chickadee graphics buffer)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics texture)
- #:use-module (chickadee graphics buffer)
#:export (draw-sprite*
draw-sprite
@@ -94,9 +94,9 @@ uniform vec4 tint;
void main (void) {
#ifdef GLSL330
- fragColor = texture(colorTexture, fragTex) * tint;
+ fragColor = (texture(colorTexture, fragTex) * tint);
#else
- gl_FragColor = texture2D(colorTexture, fragTex) * tint;
+ gl_FragColor = (texture2D(colorTexture, fragTex) * tint);
#endif
}
"))
@@ -111,6 +111,20 @@ void main (void) {
(let ((shader (graphics-variable-ref sprite-shader))
(geometry (graphics-variable-ref sprite-geometry))
(mvp (graphics-variable-ref sprite-mvp-matrix)))
+ (with-graphics-state ((blend-mode blend-mode)
+ (texture 0 texture))
+ #t)))
+
+(define* (draw-sprite* texture
+ rect
+ matrix
+ #:key
+ (tint white)
+ (blend-mode blend:alpha)
+ (texcoords (texture-gl-tex-rect texture)))
+ (let ((shader (graphics-variable-ref sprite-shader))
+ (geometry (graphics-variable-ref sprite-geometry))
+ (mvp (graphics-variable-ref sprite-mvp-matrix)))
(with-geometry geometry
(let* ((x1 (rect-x rect))
(y1 (rect-y rect))
@@ -125,9 +139,9 @@ void main (void) {
(x2 y1 s2 t1)
(x2 y2 s2 t2)
(x1 y2 s1 t2))
- (geometry-index-append! geometry 0 3 2 0 2 1)))
- (with-graphics-state ((g:blend-mode blend-mode)
- (g:texture-0 texture))
+ (geometry-index-append! geometry 0 2 3 0 1 2)))
+ (with-graphics-state ((blend-mode blend-mode)
+ (texture 0 (texture-id texture)))
(shader-apply shader
(geometry-vertex-array geometry)
#:tint tint
@@ -304,11 +318,11 @@ texture may be specified via the TEXTURE-REGION argument."
(x4 y4 s1 t2 r g b a))
(geometry-index-append! geometry
vertex-offset
- (+ vertex-offset 3)
(+ vertex-offset 2)
+ (+ vertex-offset 3)
vertex-offset
- (+ vertex-offset 2)
- (+ vertex-offset 1))
+ (+ vertex-offset 1)
+ (+ vertex-offset 2))
(set-sprite-batch-size! batch (+ (sprite-batch-size batch) 1))))
(define* (sprite-batch-add! batch
@@ -342,8 +356,8 @@ may be specified via the TEXTURE-REGION argument."
(mvp (graphics-variable-ref sprite-mvp-matrix)))
(sprite-batch-flush! batch)
(matrix4-mult! mvp matrix (current-projection))
- (with-graphics-state ((g:blend-mode blend-mode)
- (g:texture-0 (sprite-batch-texture batch)))
+ (with-graphics-state ((blend-mode blend-mode)
+ (texture 0 (texture-id (sprite-batch-texture batch))))
(let ((geometry (sprite-batch-geometry batch)))
(shader-apply* shader
(geometry-vertex-array geometry)
diff --git a/chickadee/graphics/stencil.scm b/chickadee/graphics/stencil.scm
deleted file mode 100644
index bc4cef2..0000000
--- a/chickadee/graphics/stencil.scm
+++ /dev/null
@@ -1,141 +0,0 @@
-;;; Chickadee Game Toolkit
-;;; Copyright © 2020, 2021 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 stencil)
- #:use-module (ice-9 match)
- #:use-module (gl)
- #:use-module (chickadee graphics engine)
- #:use-module (chickadee graphics gl)
- #:use-module (srfi srfi-9)
- #:export (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
- default-stencil-test
- g:stencil-test
- current-stencil-test))
-
-(define-record-type <stencil-test>
- (%make-stencil-test mask-front mask-back function-front function-back
- function-mask-front function-mask-back
- reference-front reference-back
- on-fail-front on-fail-back
- on-depth-fail-front on-depth-fail-back
- on-pass-front on-pass-back)
- stencil-test?
- (mask-front stencil-test-mask-front)
- (mask-back stencil-test-mask-back)
- (function-front stencil-test-function-front)
- (function-back stencil-test-function-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)
- (on-fail-front stencil-test-on-fail-front)
- (on-fail-back stencil-test-on-fail-back)
- (on-depth-fail-front stencil-test-on-depth-fail-front)
- (on-depth-fail-back stencil-test-on-depth-fail-back)
- (on-pass-front stencil-test-on-pass-front)
- (on-pass-back stencil-test-on-pass-back))
-
-(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-front function-back
- function-mask-front function-mask-back
- reference-front reference-back
- on-fail-front on-fail-back
- on-depth-fail-front on-depth-fail-back
- on-pass-front on-pass-back))
-
-(define default-stencil-test (make-stencil-test))
-
-(define* (bind-stencil-test stencil)
- (define (symbol->op sym)
- (match sym
- ('zero (stencil-op zero))
- ('keep (stencil-op keep))
- ('replace (stencil-op replace))
- ('increment (stencil-op incr))
- ('increment-wrap (version-1-4 incr-wrap))
- ('decrement (stencil-op decr))
- ('decrement-wrap (version-1-4 decr-wrap))
- ('invert (stencil-op invert))))
- (define (symbol->function sym)
- (match sym
- ('always (stencil-function always))
- ('never (stencil-function never))
- ('less-than (stencil-function less))
- ('equal (stencil-function equal))
- ('less-than-or-equal (stencil-function lequal))
- ('greater-than (stencil-function greater))
- ('greater-than-or-equal (stencil-function gequal))
- ('not-equal (stencil-function notequal))))
- (if stencil
- (begin
- (gl-enable (enable-cap stencil-test))
- ;; Mask
- (gl-stencil-mask-separate (cull-face-mode front)
- (stencil-test-mask-front stencil))
- (gl-stencil-mask-separate (cull-face-mode back)
- (stencil-test-mask-back stencil))
- ;; Function
- (gl-stencil-func-separate (cull-face-mode front)
- (symbol->function
- (stencil-test-function-front stencil))
- (stencil-test-reference-front stencil)
- (stencil-test-function-mask-front stencil))
- (gl-stencil-func-separate (cull-face-mode back)
- (symbol->function
- (stencil-test-function-back stencil))
- (stencil-test-reference-back stencil)
- (stencil-test-function-mask-back stencil))
- ;; Operation
- (gl-stencil-op-separate (cull-face-mode front)
- (symbol->op (stencil-test-on-fail-front stencil))
- (symbol->op (stencil-test-on-depth-fail-front stencil))
- (symbol->op (stencil-test-on-pass-front stencil)))
- (gl-stencil-op-separate (cull-face-mode back)
- (symbol->op (stencil-test-on-fail-back stencil))
- (symbol->op (stencil-test-on-depth-fail-back stencil))
- (symbol->op (stencil-test-on-pass-back stencil))))
- (gl-disable (enable-cap stencil-test))))
-
-(define-graphics-state g:stencil-test
- current-stencil-test
- #:default default-stencil-test
- #:bind bind-stencil-test)
diff --git a/chickadee/graphics/text.scm b/chickadee/graphics/text.scm
index 20b8ca5..8efa7ae 100644
--- a/chickadee/graphics/text.scm
+++ b/chickadee/graphics/text.scm
@@ -37,9 +37,9 @@
#:use-module (chickadee math matrix)
#:use-module (chickadee math rect)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics pixbuf)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics sprite)
@@ -146,7 +146,9 @@ non-smooth scaling will be used."
(let ((face (load-face (force freetype-handle) file-name))
(chars (make-hash-table))
(kernings (make-hash-table))
- (texture-size (min (graphics-engine-max-texture-size) 2048)))
+ (texture-size (min (graphics-engine-max-texture-size
+ (current-graphics-engine))
+ 2048)))
;; TODO: Use actual screen DPI.
(set-char-size! face (* point-size 64) 0 96 96)
(let ((glyph (face-glyph-slot face))
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm
index 65b7300..86702a3 100644
--- a/chickadee/graphics/texture.scm
+++ b/chickadee/graphics/texture.scm
@@ -29,6 +29,7 @@
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics gl)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics pixbuf)
#:use-module (chickadee image)
#:use-module (chickadee utils)
@@ -45,6 +46,7 @@
texture-region?
cube-map?
texture-null?
+ texture-id
texture-type
texture-parent
texture-min-filter
@@ -113,7 +115,7 @@
(set-record-type-printer! <texture>
(lambda (texture port)
(format port
- "#<texture id: ~d region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
+ "#<texture id: ~s region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
(texture-id texture)
(texture-region? texture)
(texture-x texture)
@@ -126,7 +128,7 @@
(texture-wrap-t texture))))
(define null-texture
- (%make-texture 0 '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0
+ (%make-texture gpu-texture:null '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0
(make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))
(define (texture-null? texture)
@@ -139,9 +141,6 @@
(define (cube-map? texture)
(and (texture? texture) (eq? (texture-type texture) 'cube-map)))
-(define (free-texture texture)
- (gl-delete-texture (texture-id texture)))
-
(define (gl-texture-target type)
(case type
((2d)
@@ -149,47 +148,6 @@
((cube-map)
(version-1-3 texture-cube-map))))
-(define (make-bind-texture n)
- (lambda (texture)
- (let ((texture-unit (+ (version-1-3 texture0) n)))
- (set-gl-active-texture texture-unit)
- (gl-bind-texture (gl-texture-target (texture-type texture))
- (texture-id texture)))))
-
-(define-graphics-finalizer texture-finalizer
- #:predicate texture?
- #:free free-texture)
-
-(define-graphics-state g:texture-0
- current-texture-0
- #:default null-texture
- #:bind (make-bind-texture 0))
-
-(define-graphics-state g:texture-1
- current-texture-1
- #:default null-texture
- #:bind (make-bind-texture 1))
-
-(define-graphics-state g:texture-2
- current-texture-2
- #:default null-texture
- #:bind (make-bind-texture 2))
-
-(define-graphics-state g:texture-3
- current-texture-3
- #:default null-texture
- #:bind (make-bind-texture 3))
-
-(define-graphics-state g:texture-4
- current-texture-4
- #:default null-texture
- #:bind (make-bind-texture 4))
-
-(define-graphics-state g:texture-5
- current-texture-5
- #:default null-texture
- #:bind (make-bind-texture 5))
-
(define (gl-wrap-mode mode)
(case mode
((repeat)
@@ -248,15 +206,15 @@ Allowed symbols are: repeat (the default), mirrored-repeat, clamp,
clamp-to-border, clamp-to-edge. FORMAT specifies the pixel format.
Currently only 32-bit RGBA format is supported."
(assert-current-graphics-engine)
- (let ((texture (%make-texture (gl-generate-texture) '2d #f
+ (let ((texture (%make-texture (fresh-gpu-texture (current-gpu) '2d)
+ '2d #f
min-filter mag-filter wrap-s wrap-t
0 0 width height
(make-rect 0.0 0.0 width height)
(if flip?
(make-rect 0.0 1.0 1.0 -1.0)
(make-rect 0.0 0.0 1.0 1.0)))))
- (graphics-engine-guard! texture)
- (with-graphics-state! ((g:texture-0 texture))
+ (with-graphics-state! ((texture 0 (texture-id texture)))
;; Ensure that we are using texture unit 0 because
;; with-graphics-state! doesn't guarantee it.
(set-gl-active-texture (version-1-3 texture0))
@@ -283,8 +241,8 @@ Currently only 32-bit RGBA format is supported."
linear-mipmap-nearest
nearest-mipmap-linear
linear-mipmap-linear))
- (gl-generate-mipmap (texture-target texture-2d))))
- texture))
+ (gl-generate-mipmap (texture-target texture-2d)))
+ texture)))
(define* (pixbuf->texture pixbuf #:key
flip?
@@ -298,15 +256,15 @@ Currently only 32-bit RGBA format is supported."
(assert-current-graphics-engine)
(let* ((width (pixbuf-width pixbuf))
(height (pixbuf-height pixbuf))
- (texture (%make-texture (gl-generate-texture) '2d #f
+ (texture (%make-texture (fresh-gpu-texture (current-gpu) '2d)
+ '2d #f
min-filter mag-filter wrap-s wrap-t
0 0 width height
(make-rect 0.0 0.0 width height)
(if flip?
(make-rect 0.0 1.0 1.0 -1.0)
(make-rect 0.0 0.0 1.0 1.0)))))
- (graphics-engine-guard! texture)
- (with-graphics-state! ((g:texture-0 texture))
+ (with-graphics-state! ((texture 0 (texture-id texture)))
;; Ensure that we are using texture unit 0 because
;; with-graphics-state! doesn't guarantee it.
(set-gl-active-texture (version-1-3 texture0))
@@ -333,8 +291,8 @@ Currently only 32-bit RGBA format is supported."
linear-mipmap-nearest
nearest-mipmap-linear
linear-mipmap-linear))
- (gl-generate-mipmap (texture-target texture-2d))))
- texture))
+ (gl-generate-mipmap (texture-target texture-2d)))
+ texture)))
(define* (make-cube-map #:key
right left top bottom front back
@@ -364,12 +322,12 @@ Currently only 32-bit RGBA format is supported."
(color-pointer-type unsigned-byte)
(pixbuf-pixels pixbuf)))
(assert-current-graphics-engine)
- (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f
+ (let ((texture (%make-texture (fresh-gpu-texture (current-gpu) 'cube-map)
+ 'cube-map #f
min-filter mag-filter
'clamp-to-edge 'clamp-to-edge
0 0 0 0 #f #f)))
- (graphics-engine-guard! texture)
- (with-graphics-state! ((g:texture-0 texture))
+ (with-graphics-state! ((texture 0 (texture-id texture)))
;; Ensure that we are using texture unit 0 because
;; with-graphics-state! doesn't guarantee it.
(set-gl-active-texture (version-1-3 texture0))
@@ -400,8 +358,8 @@ Currently only 32-bit RGBA format is supported."
linear-mipmap-nearest
nearest-mipmap-linear
linear-mipmap-linear))
- (gl-generate-mipmap (gl-texture-target 'cube-map))))
- texture))
+ (gl-generate-mipmap (gl-texture-target 'cube-map)))
+ texture)))
(define (make-texture-region texture rect)
"Create a new texture region covering a section of TEXTURE defined
@@ -483,12 +441,12 @@ are 'nearest and 'linear. By default, 'nearest is used."
(let* ((w (texture-width texture))
(h (texture-height texture))
(pixels (make-bytevector (* w h 4) 0)))
- (with-graphics-state! ((g:texture-0 texture))
- (gl-get-tex-image (texture-target texture-2d)
- 0
- (gl-pixel-format 'rgba)
- (color-pointer-type unsigned-byte)
- (bytevector->pointer pixels)))
+ (set-gpu-texture! (current-gpu) 0 texture)
+ (gl-get-tex-image (texture-target texture-2d)
+ 0
+ (gl-pixel-format 'rgba)
+ (color-pointer-type unsigned-byte)
+ (bytevector->pointer pixels))
(let ((pixbuf (bytevector->pixbuf pixels w h
#:format 'rgba
#:bit-depth 8)))
diff --git a/chickadee/graphics/tile-map.scm b/chickadee/graphics/tile-map.scm
index 84213eb..48ed914 100644
--- a/chickadee/graphics/tile-map.scm
+++ b/chickadee/graphics/tile-map.scm
@@ -24,10 +24,10 @@
#:use-module (chickadee math matrix)
#:use-module (chickadee math rect)
#:use-module (chickadee math vector)
- #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics buffer)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics texture)
#:use-module (chickadee graphics viewport)
@@ -423,11 +423,11 @@
(x1 y2 ds dt))
(geometry-index-append! geometry
vertex-offset
- (+ vertex-offset 3)
(+ vertex-offset 2)
+ (+ vertex-offset 3)
vertex-offset
- (+ vertex-offset 2)
- (+ vertex-offset 1))))))
+ (+ vertex-offset 1)
+ (+ vertex-offset 2))))))
(hash-for-each (lambda (texture geometry)
(geometry-end! geometry))
t)))
@@ -479,7 +479,7 @@ void main (void) {
"))
(define (draw-chunk-geometry texture geometry matrix tint)
- (with-graphics-state ((g:texture-0 texture))
+ (with-graphics-state ((texture 0 (texture-id texture)))
(shader-apply* (graphics-variable-ref tile-map-chunk-shader)
(geometry-vertex-array geometry)
0
@@ -500,7 +500,7 @@ void main (void) {
(when (chunk-rebuild-geometry? chunk)
(chunk-rebuild-geometry! chunk)
(set-chunk-rebuild-geometry! chunk #f))
- (with-graphics-state ((g:blend-mode blend-mode))
+ (with-graphics-state ((blend-mode blend-mode))
(hash-for-each (lambda (texture geometry)
(draw-chunk-geometry texture geometry matrix tint))
(chunk-geometry chunk))))
@@ -904,8 +904,8 @@ argument may be used to specify a list of layers to draw, instead."
(let ((vp (current-viewport)))
(set-rect-x! *region* (vec2-x camera))
(set-rect-y! *region* (vec2-y camera))
- (set-rect-width! *region* (viewport-width vp))
- (set-rect-height! *region* (viewport-height vp)))
+ (set-rect-width! *region* (window-rect-width vp))
+ (set-rect-height! *region* (window-rect-height vp)))
;; Translation must be adjusted by inverse of camera.
(vec2-copy! camera *position*)
(vec2-mult! *position* -1.0)
diff --git a/chickadee/graphics/viewport.scm b/chickadee/graphics/viewport.scm
index e305c19..4258e05 100644
--- a/chickadee/graphics/viewport.scm
+++ b/chickadee/graphics/viewport.scm
@@ -26,31 +26,26 @@
#:use-module (chickadee utils)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics gpu)
#:use-module (chickadee graphics gl)
#:export (make-viewport
viewport?
- viewport-x
- viewport-y
- viewport-width
- viewport-height
+ viewport-rect
viewport-clear-color
viewport-clear-flags
null-viewport
clear-viewport
- g:viewport
- current-viewport
+ with-viewport
%default-clear-flags
%default-clear-color))
(define-record-type <viewport>
- (%make-viewport x y width height clear-color clear-flags)
+ (%make-viewport rect clear-color clear-flags clear-mask)
viewport?
- (x viewport-x)
- (y viewport-y)
- (width viewport-width)
- (height viewport-height)
+ (rect viewport-rect)
(clear-color viewport-clear-color)
- (clear-flags viewport-clear-flags))
+ (clear-flags viewport-clear-flags)
+ (clear-mask viewport-clear-mask))
(define %default-clear-flags '(color-buffer depth-buffer stencil-buffer))
;; Just a fun color from the Dawnbringer 32-color palette instead of
@@ -62,6 +57,19 @@
n
(error "expecting non-negative integer:" n)))
+;; TODO: This is gross. Get rid of it.
+(define clear-buffer-mask
+ (memoize
+ (lambda (flags)
+ (apply logior
+ ;; Map symbols to OpenGL constants.
+ (map (match-lambda
+ ('depth-buffer 256)
+ ('accum-buffer 512)
+ ('stencil-buffer 1024)
+ ('color-buffer 16384))
+ flags)))))
+
(define* (make-viewport x y width height #:key
(clear-color %default-clear-color)
(clear-flags %default-clear-flags))
@@ -71,59 +79,23 @@ viewport with CLEAR-COLOR when clearing the screen. Clear the buffers
denoted by the list of symbols in CLEAR-FLAGS. Possible values for
CLEAR-FLAGS are 'color-buffer', 'depth-buffer', 'accum-buffer', and
'stencil-buffer'."
- (%make-viewport (assert-non-negative-integer x)
- (assert-non-negative-integer y)
- (assert-non-negative-integer width)
- (assert-non-negative-integer height)
+ (%make-viewport (make-window-rect (assert-non-negative-integer x)
+ (assert-non-negative-integer y)
+ (assert-non-negative-integer width)
+ (assert-non-negative-integer height))
clear-color
- clear-flags))
+ clear-flags
+ (clear-buffer-mask clear-flags)))
(define null-viewport (make-viewport 0 0 0 0))
-(define clear-buffer-mask
- (memoize
- (lambda (flags)
- (apply logior
- ;; Map symbols to OpenGL constants.
- (map (match-lambda
- ('depth-buffer 256)
- ('accum-buffer 512)
- ('stencil-buffer 1024)
- ('color-buffer 16384))
- flags)))))
+(define-syntax-rule (with-viewport v body ...)
+ (let ((viewport v))
+ (with-graphics-state ((viewport (viewport-rect viewport))
+ (clear-color (viewport-clear-color viewport)))
+ body ...)))
+;; TODO: Add clear buffer mask to managed gpu state.
(define (clear-viewport)
- (gl-clear (clear-buffer-mask (viewport-clear-flags (current-viewport)))))
-
-(define (apply-viewport viewport)
- "Set the OpenGL state for VIEWPORT. Clip rendering to the viewport
-area, set the clear color, and clear necessary buffers."
- (unless (eq? viewport null-viewport)
- (let ((x (viewport-x viewport))
- (y (viewport-y viewport))
- (w (viewport-width viewport))
- (h (viewport-height viewport))
- (c (viewport-clear-color viewport)))
- (gl-enable (enable-cap scissor-test))
- (gl-viewport x y w h)
- (gl-scissor x y w h)
- (gl-clear-color (color-r c) (color-g c) (color-b c) (color-a c)))))
-
-(define (bind-viewport viewport)
- "Set the OpenGL state for VIEWPORT. Clip rendering to the viewport
-area, and set the clear color.."
- (unless (eq? viewport null-viewport)
- (let ((x (viewport-x viewport))
- (y (viewport-y viewport))
- (w (viewport-width viewport))
- (h (viewport-height viewport))
- (c (viewport-clear-color viewport)))
- (gl-enable (enable-cap scissor-test))
- (gl-viewport x y w h)
- (gl-scissor x y w h)
- (gl-clear-color (color-r c) (color-g c) (color-b c) (color-a c)))))
-
-(define-graphics-state g:viewport
- current-viewport
- #:default null-viewport
- #:bind bind-viewport)
+ (graphics-engine-commit! (current-graphics-engine))
+ (gl-clear (clear-buffer-mask %default-clear-flags)))
diff --git a/doc/api.texi b/doc/api.texi
index 50ce301..b6aef7b 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -4483,8 +4483,8 @@ and state changes happen within the context of this engine.
Performing a custom draw call could look something like this:
@lisp
-(with-graphics-state ((g:blend-mode blend:alpha)
- (g:texture-0 my-texture))
+(with-graphics-state ((blend-mode blend:alpha)
+ (texture 0 my-texture))
(shader-apply my-shader #:foo 1))
@end lisp
@@ -4502,17 +4502,12 @@ values afterwards.
@end deffn
One additional piece of state that the rendering engine has, that is
-not part of the GPU state, is the current projection matrix:
+not strictly part of the GPU state, is the current projection matrix:
@deffn {Procedure} current-projection
Return the currently bound projection matrix (@pxref{Matrices}).
@end deffn
-@deffn {Syntax} with-projection projection body @dots{}
-Evaluate @var{body} with the current projection matrix bound to
-@var{projection} (@pxref{Matrices}).
-@end deffn
-
@subsubsection Rendering
Chickadee likens a GPU draw call to a Scheme procedure call. A shader
diff --git a/examples/model.scm b/examples/model.scm
index 4fa42c7..35aceb5 100644
--- a/examples/model.scm
+++ b/examples/model.scm
@@ -26,7 +26,7 @@
(reset-position))
(define (draw alpha)
- (with-projection projection
+ (with-graphics-state ((projection projection))
(draw-model model
#:model-matrix model-matrix
#:view-matrix view-matrix
diff --git a/examples/path.scm b/examples/path.scm
index 44cabdb..ef9bf8f 100644
--- a/examples/path.scm
+++ b/examples/path.scm
@@ -4,7 +4,8 @@
(chickadee graphics text)
(chickadee math)
(chickadee math vector)
- (chickadee scripting))
+ (chickadee scripting)
+ (ice-9 format))
(set! *random-state* (random-state-from-platform))
diff --git a/examples/sprite-batch.scm b/examples/sprite-batch.scm
index e62d1e4..cf79565 100644
--- a/examples/sprite-batch.scm
+++ b/examples/sprite-batch.scm
@@ -3,6 +3,7 @@
(chickadee math rect)
(chickadee math vector)
(chickadee graphics color)
+ (chickadee graphics path)
(chickadee graphics sprite)
(chickadee graphics text)
(chickadee graphics texture)
@@ -28,22 +29,28 @@
(define matrix (make-identity-matrix4))
(define (stats-message)
- (format #f "sprites: ~d fps: ~1,2f"
+ (format #f "sprites: ~d fps: ~1,2f"
num-sprites
(/ 1.0 avg-frame-time)))
-
+(define stats-text-pos (vec2 8.0 462.0))
(define stats-text (stats-message))
+(define stats-background
+ (with-style ((fill-color tango-light-plum))
+ (fill
+ (rounded-rectangle (vec2- stats-text-pos (vec2 4.0 4.0))
+ 212.0 18.0 #:radius 4.0))))
+(define stats-canvas (make-empty-canvas))
(define (load)
(set! *random-state* (random-state-from-platform))
(set! texture (load-image "images/shot.png"))
(set! batch (make-sprite-batch texture #:capacity num-sprites))
+ (set-canvas-painter! stats-canvas stats-background)
(script
(forever
(sleep 60)
(set! stats-text (pk 'stats (stats-message))))))
-(define stats-text-pos (vec2 4.0 464.0))
(define (draw alpha)
(sprite-batch-clear! batch)
(for-each (match-lambda
@@ -53,7 +60,8 @@
(sprite-batch-add* batch r matrix)))
sprites)
(draw-sprite-batch batch)
- (draw-text stats-text stats-text-pos #:color black)
+ (draw-canvas stats-canvas)
+ (draw-text stats-text stats-text-pos #:color tango-aluminium-6)
(let ((current-time (elapsed-time)))
(set! avg-frame-time
(+ (* (- current-time start-time) 0.1)
diff --git a/examples/sprite.scm b/examples/sprite.scm
index 24b7a24..753be4d 100644
--- a/examples/sprite.scm
+++ b/examples/sprite.scm
@@ -8,10 +8,11 @@
(define sprite #f)
(define (load)
- (pk (blending-factor-src 2))
(set! sprite (load-image "images/chickadee.png")))
(define (draw alpha)
- (draw-sprite sprite (vec2 256.0 176.0)))
+ (draw-sprite sprite (vec2 256.0 176.0))
+ ;;(abort-game)
+ )
(run-game #:load load #:draw draw)
diff --git a/examples/text.scm b/examples/text.scm
index be79edc..81e4021 100644
--- a/examples/text.scm
+++ b/examples/text.scm
@@ -7,7 +7,7 @@
(define avg-frame-time 16.0)
(define stats-text "")
(define stats-position (vec2 4.0 704.0))
-(define position (vec2 140.0 0.0))
+(define position (vec2 140.0 240.0))
(define text "The quick brown fox jumps over the lazy dog.\nFive hexing wizard bots jump quickly.")
(define (stats-message)
@@ -40,6 +40,4 @@
#:key-press key-press
#:load load
#:update update
- #:window-title "text rendering"
- #:window-width 1280
- #:window-height 720)
+ #:window-title "text rendering")
diff --git a/examples/triangle.scm b/examples/triangle.scm
new file mode 100644
index 0000000..2debc85
--- /dev/null
+++ b/examples/triangle.scm
@@ -0,0 +1,84 @@
+(use-modules (chickadee)
+ (chickadee math vector)
+ (chickadee graphics buffer)
+ (chickadee graphics engine)
+ (chickadee graphics shader))
+
+(use-modules (gl enums))
+
+(define vertex-array #f)
+(define shader #f)
+
+(define (load)
+ (define verts
+ (make-buffer #f32(0.0 0.0
+ 640.0 0.0
+ 320.0 480.0)))
+ (define colors
+ (make-buffer #f32(1.0 0.0 0.0 1.0
+ 0.0 1.0 0.0 1.0
+ 0.0 0.0 1.0 1.0)))
+ ;; This isn't necessary for a single triangle, but we're doing it
+ ;; anyway just to exercise that code.
+ (define indices (make-buffer #u32(0 1 2) #:target 'index))
+ (set! vertex-array
+ (make-vertex-array
+ #:indices (make-vertex-attribute
+ #:buffer indices
+ #:type 'scalar
+ #:component-type 'unsigned-int)
+ #:attributes `((0 . ,(make-vertex-attribute
+ #:buffer verts
+ #:type 'vec2
+ #:component-type 'float))
+ (1 . ,(make-vertex-attribute
+ #:buffer colors
+ #:type 'color
+ #:component-type 'float)))))
+ (set! shader (strings->shader
+ "
+#ifdef GLSL330
+layout (location = 0) in vec2 position;
+layout (location = 1) in vec4 color;
+#elif defined(GLSL130)
+in vec2 position;
+in vec4 color;
+#elif defined(GLSL120)
+attribute vec2 position;
+attribute vec4 color;
+#endif
+#ifdef GLSL120
+varying vec4 fragColor;
+#else
+out vec4 fragColor;
+#endif
+uniform mat4 mvp;
+
+void main(void) {
+ fragColor = color;
+ gl_Position = mvp * vec4(position, 0.0, 1.0);
+}
+"
+ "
+#ifdef GLSL120
+varying vec4 fragColor;
+#else
+in vec4 fragColor;
+ #endif
+#ifdef GLSL330
+out vec4 outFragColor;
+#endif
+
+void main (void) {
+#ifdef GLSL330
+ outFragColor = fragColor;
+#else
+ gl_FragColor = fragColor;
+#endif
+}
+")))
+
+(define (draw alpha)
+ (shader-apply shader vertex-array #:mvp (current-projection)))
+
+(run-game #:load load #:draw draw)