diff options
38 files changed, 7432 insertions, 3193 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 41a954b..820ebec 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -30,6 +30,7 @@ (eval . (put 'with-geometry* 'scheme-indent-function 2)) (eval . (put 'with-graphics-state 'scheme-indent-function 1)) (eval . (put 'with-graphics-state! 'scheme-indent-function 1)) + (eval . (put 'with-render-pass 'scheme-indent-function 1)) (eval . (put 'with-error-handling 'scheme-indent-function 1)) (eval . (put 'translate 'scheme-indent-function 1)) (eval . (put 'rotate 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index b1cc139..66cc2d2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -49,6 +49,7 @@ SOURCES = \ chickadee/data/array-list.scm \ chickadee/data/queue.scm \ chickadee/data/bytestruct.scm \ + chickadee/data/pool.scm \ chickadee/data/quadtree.scm \ chickadee/data/grid.scm \ chickadee/data/path-finding.scm \ @@ -67,20 +68,21 @@ SOURCES = \ chickadee/image.scm \ chickadee/image/jpeg.scm \ chickadee/image/png.scm \ - chickadee/graphics/gl.scm \ - chickadee/graphics/engine.scm \ + chickadee/graphics/layout.scm \ + chickadee/graphics/primitive.scm \ chickadee/graphics/color.scm \ - chickadee/graphics/blend.scm \ - chickadee/graphics/polygon.scm \ - chickadee/graphics/depth.scm \ - chickadee/graphics/stencil.scm \ + chickadee/graphics/depth-stencil.scm \ chickadee/graphics/multisample.scm \ + chickadee/graphics/viewport.scm \ + chickadee/graphics/backend.scm \ + chickadee/graphics/backend/opengl.scm \ chickadee/graphics/buffer.scm \ chickadee/graphics/pixbuf.scm \ chickadee/graphics/texture.scm \ chickadee/graphics/shader.scm \ - chickadee/graphics/viewport.scm \ chickadee/graphics/framebuffer.scm \ + chickadee/graphics/pass.scm \ + chickadee/graphics/pipeline.scm \ chickadee/graphics/sprite.scm \ chickadee/graphics/9-patch.scm \ chickadee/graphics/text.scm \ @@ -93,6 +95,7 @@ SOURCES = \ chickadee/graphics/pbr.scm \ chickadee/graphics/model.scm \ chickadee/graphics/path.scm \ + chickadee/graphics.scm \ chickadee/scripting/agenda.scm \ chickadee/scripting/script.scm \ chickadee/scripting/channel.scm \ @@ -1,4 +1,6 @@ * Tasks +** TODO [#B] Bytestruct -> vertex layout conversion +** TODO [#C] Add mesh primitive for 2D/3D quads ** TODO [#C] Rename some matrix procedures matrix4-mult! -> matrix4-mul! matrix4* -> matrix4:* diff --git a/chickadee.scm b/chickadee.scm index 05f3d65..0654ea3 100644 --- a/chickadee.scm +++ b/chickadee.scm @@ -25,9 +25,12 @@ #:use-module (chickadee config) #:use-module (chickadee game-loop) #:use-module (chickadee math matrix) + #:use-module (chickadee graphics) + #:use-module ((chickadee graphics backend) #:prefix gpu:) + #:use-module (chickadee graphics backend opengl) #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics pass) + #:use-module (chickadee graphics texture) #:use-module (chickadee graphics viewport) #:use-module (chickadee utils) #:use-module (gl) @@ -74,6 +77,8 @@ mouse-button-released? warp-mouse set-show-cursor! + default-color-texture-view + default-depth+stencil-texture-view run-game) #:re-export (abort-game current-timestep)) @@ -155,21 +160,11 @@ not being pushed at all." (sdl-window unwrap-window) (gl-context window-gl-context)) +(define default-color-texture-view (make-parameter #f)) +(define default-depth+stencil-texture-view (make-parameter #f)) + (define* (make-window #:key (title "Chickadee") fullscreen? resizable? - (width 640) (height 480) (multisample? #t)) - ;; Hint that we want OpenGL 3.2 Core profile. Doesn't mean we'll - ;; get it, though! - (sdl2:set-gl-attribute! 'context-major-version 3) - (sdl2:set-gl-attribute! 'context-major-version 2) - (sdl2:set-gl-attribute! 'context-profile-mask 1) ; core profile - (sdl2:set-gl-attribute! 'stencil-size 8) ; 8-bit stencil buffer - (if multisample? - (begin - (sdl2:set-gl-attribute! 'multisample-buffers 1) - (sdl2:set-gl-attribute! 'multisample-samples 4)) - (begin - (sdl2:set-gl-attribute! 'multisample-buffers 0) - (sdl2:set-gl-attribute! 'multisample-samples 0))) + (width 640) (height 480)) (let* ((window (sdl2:make-window #:opengl? #t #:title title #:size (list width height) @@ -288,32 +283,33 @@ border is disabled, otherwise it is enabled.") (sdl-init) (start-text-input) (init-audio) - ;; We assume here that if window creation fails it is because - ;; multisampling is not supported and that we need to try again with - ;; multisampling disabled. This is obviously hacky but it solves a - ;; real world user issue and I'm not sure how to test for driver - ;; features before opening the window. SDL's display mode - ;; information doesn't seem to be enough. Help wanted! - (let* ((window (or (false-if-exception - (make-window #:title window-title - #:width window-width - #:height window-height - #:fullscreen? window-fullscreen? - #:resizable? window-resizable?)) - (make-window #:title window-title - #:width window-width - #:height window-height - #:fullscreen? window-fullscreen? - #:resizable? window-resizable? - #:multisample? #f))) - (gfx (make-graphics-engine (window-gl-context window))) - (default-viewport (make-atomic-box - (make-viewport 0 0 window-width window-height - #:clear-color clear-color))) - (default-projection (make-atomic-box - (orthographic-projection 0 window-width - window-height 0 - 0 1)))) + (let* ((window (make-window #:title window-title + #:width window-width + #:height window-height + #:fullscreen? window-fullscreen? + #:resizable? window-resizable?)) + (gpu (make-opengl-gpu (window-gl-context window) + (lambda () + (sdl2:swap-gl-window + (unwrap-window window))) + window-width window-height)) + (default-viewport (make-viewport 0 0 window-width window-height)) + (default-projection (orthographic-projection 0 window-width + window-height 0 + 0 1)) + (default-render-pass + (make-render-pass + #:color-attachments + (vector + (make-color-attachment + #:view default-color-texture-view + #:operation (make-color-operation + #:clear-color db32-viking))) + #:depth+stencil-attachment + (make-depth+stencil-attachment + #:view default-depth+stencil-texture-view)))) + (pk (gpu:gpu-description gpu)) + (pk (gpu:gpu-limits 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 +395,10 @@ 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)) + (refresh-default-texture-views! width height) + (set! default-viewport (make-viewport 0 0 width height)) + (set! default-projection + (orthographic-projection 0 width height 0 0 1)) (window-resize width height)))))) ;; Process all pending events. (let loop ((event (poll-event))) @@ -415,46 +410,60 @@ border is disabled, otherwise it is enabled.") (update dt) ;; Update audio after updating game state so that any sounds ;; 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)) - (define (render-sdl-opengl alpha) - (with-graphics-state! ((g:viewport (atomic-box-ref default-viewport))) - (clear-viewport) - (with-projection (atomic-box-ref default-projection) - (draw alpha))) - (sdl2:swap-gl-window (unwrap-window window))) + (update-audio)) + (define (draw-frame alpha) + ((@@ (chickadee graphics) begin-frame)) + (parameterize ((current-viewport default-viewport) + (current-projection default-projection) + (current-pass default-render-pass)) + (draw alpha)) + ((@@ (chickadee graphics) end-frame) (default-color-texture-view))) (define (on-error e stack) (error e stack) ;; Flush all input events that have occurred while in the error ;; state. (while (poll-event) #t)) - (dynamic-wind - (const #t) - (lambda () - (parameterize ((current-window window) - (current-graphics-engine gfx)) - ;; Attempt to activate vsync, if possible. Some systems do - ;; not support setting the OpenGL swap interval. - (catch #t - (lambda () - (sdl2:set-gl-swap-interval! 'vsync)) - (lambda args - (display "warning: could not enable vsync\n" - (current-error-port)))) - ;; Turn off multisampling by default. - (gl-disable (version-1-3 multisample)) - ;; Enable seamless cube maps. - (gl-enable (version-3-2 texture-cube-map-seamless)) - (sdl2:load-game-controller-mappings! - (scope-datadir "gamecontrollerdb.txt")) - (run-game* #:init load - #:update update-sdl - #:render render-sdl-opengl - #:error (and error on-error) - #:time elapsed-time - #:update-hz update-hz))) - (lambda () - (quit-audio) - (sdl2:delete-gl-context! (window-gl-context window)) - (sdl2:close-window! (unwrap-window window)))))) + (define (refresh-default-texture-views! width height) + (let* ((old-color (default-color-texture-view)) + (old-depth+stencil (default-depth+stencil-texture-view)) + (color-texture (make-texture #:name "Default color texture" + #:width width + #:height height)) + (color-view (make-texture-view color-texture + #:name "Default color texture view")) + (depth+stencil-texture (make-texture #:name "Default depth/stencil texture" + #:width width + #:height height + #:format 'depth24plus-stencil8)) + (depth+stencil-view (make-texture-view depth+stencil-texture + #:name "Default depth/stencil texture view"))) + (when old-color (destroy-texture-view old-color)) + (when old-depth+stencil (destroy-texture-view old-depth+stencil)) + (default-color-texture-view color-view) + (default-depth+stencil-texture-view depth+stencil-view))) + (parameterize ((current-window window) + (gpu:current-gpu gpu)) + (refresh-default-texture-views! window-width window-height) + ;; Attempt to activate vsync, if possible. Some systems do + ;; not support setting the OpenGL swap interval. + (catch #t + (lambda () + (sdl2:set-gl-swap-interval! 'vsync)) + (lambda args + (display "warning: could not enable vsync\n" + (current-error-port)))) + ;; Turn off multisampling by default. + ;; (gl-disable (version-1-3 multisample)) + ;; Enable seamless cube maps. + ;; (gl-enable (version-3-2 texture-cube-map-seamless)) + (sdl2:load-game-controller-mappings! + (scope-datadir "gamecontrollerdb.txt")) + (run-game* #:init load + #:update update-sdl + #:render draw-frame + #:error (and error on-error) + #:time elapsed-time + #:update-hz update-hz)) + (quit-audio) + (sdl2:delete-gl-context! (window-gl-context window)) + (sdl2:close-window! (unwrap-window window)))) diff --git a/chickadee/data/pool.scm b/chickadee/data/pool.scm new file mode 100644 index 0000000..9637719 --- /dev/null +++ b/chickadee/data/pool.scm @@ -0,0 +1,59 @@ +(define-module (chickadee data pool) + #:use-module (chickadee data array-list) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export (make-pool + pool? + pool-borrow + pool-return)) + +(define-record-type <pool> + (%make-pool pred fresh init free) + pool? + (pred pool-pred) + (fresh pool-fresh) + (init pool-init) + (free pool-free)) + +(define (make-pool pred fresh init) + (%make-pool pred fresh init (make-array-list))) + +(define-syntax-rule (borrow+init pool args ...) + (match pool + (($ <pool> pred fresh init free) + (let ((obj (if (array-list-empty? free) + (fresh) + (array-list-pop! free)))) + (init obj args ...) + obj)))) + +(define pool-borrow + (case-lambda + ((pool) + (borrow+init pool)) + ((pool a) + (borrow+init pool a)) + ((pool a b) + (borrow+init pool a b)) + ((pool a b c) + (borrow+init pool a b c)) + ((pool a b c d) + (borrow+init pool a b c d)) + ((pool a b c d e) + (borrow+init pool a b c d e)) + ((pool . args) + (match pool + (($ <pool> pred fresh init free) + (let ((obj (if (array-list-empty? free) + (fresh) + (array-list-pop! free)))) + (apply init obj args) + obj)))))) +(set-procedure-property! pool-borrow 'name 'pool-borrow) + +(define (pool-return pool obj) + (match pool + (($ <pool> pred fresh init free) + (unless (pred obj) + (error "invalid pool object" obj)) + (array-list-push! free obj)))) diff --git a/chickadee/graphics.scm b/chickadee/graphics.scm new file mode 100644 index 0000000..26c8515 --- /dev/null +++ b/chickadee/graphics.scm @@ -0,0 +1,343 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2024 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (chickadee graphics) + #:use-module ((chickadee graphics backend) #:prefix gpu:) + #:use-module (chickadee graphics blend) + #:use-module (chickadee graphics buffer) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics pass) + #:use-module (chickadee graphics pipeline) + #:use-module (chickadee graphics primitive) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-111) + #:export (current-projection + current-viewport + current-scissor + current-pass + with-render-pass + draw + stream-draw + flush-stream + define-graphics-variable + graphics-variable-ref) + #:re-export ((gpu:gpu-limits? . gpu-limits?) + (gpu:gpu-limits-max-texture-dimension-1d . gpu-limits-max-texture-dimension-1d) + (gpu:gpu-limits-max-texture-dimension-2d . gpu-limits-max-texture-dimension-2d) + (gpu:gpu-limits-max-texture-dimension-3d . gpu-limits-max-texture-dimension-3d) + (gpu:gpu-limits-max-texture-array-layers . gpu-limits-max-texture-array-layers) + (gpu:gpu-limits-max-sampled-textures-per-shader-stage . gpu-limits-max-sampled-textures-per-shader-stage) + (gpu:gpu-limits-max-samplers-per-shader-stage . gpu-limits-max-samplers-per-shader-stage) + (gpu:gpu-limits-max-uniform-buffers-per-shader-stage . gpu-limits-max-uniform-buffers-per-shader-stage) + (gpu:gpu-limits-max-uniform-buffer-binding-size . gpu-limits-max-uniform-buffer-binding-size) + (gpu:gpu-limits-max-bindings . gpu-limits-max-bindings) + (gpu:gpu-limits-max-vertex-buffers . gpu-limits-max-vertex-buffers) + (gpu:gpu-limits-max-buffer-size . gpu-limits-max-buffer-size) + (gpu:gpu-limits-max-vertex-attributes . gpu-limits-max-vertex-attributes) + (gpu:gpu-limits-max-vertex-buffer-array-stride . gpu-limits-max-vertex-buffer-array-stride) + (gpu:gpu-limits-max-inter-stage-shader-components . gpu-limits-max-inter-stage-shader-components) + (gpu:gpu-limits-max-inter-stage-shader-variables . gpu-limits-max-inter-stage-shader-variables) + (gpu:gpu-limits-max-color-attachments . gpu-limits-max-color-attachments) + (gpu:current-gpu . current-gpu) + (gpu:gpu? . gpu?) + (gpu:gpu-name . gpu-name) + (gpu:gpu-description . gpu-description) + (gpu:gpu-limits . gpu-limits))) + +;; Private API stuff shhhhhhh... +(define buffer-handle (@@ (chickadee graphics buffer) buffer-handle)) +(define texture-handle (@@ (chickadee graphics texture) texture-handle)) +(define texture-view-handle (@@ (chickadee graphics texture) texture-view-handle)) +(define sampler-handle (@@ (chickadee graphics texture) sampler-handle)) +(define render-pipeline-handle (@@ (chickadee graphics pipeline) render-pipeline-handle)) +(define <render-pipeline> (@@ (chickadee graphics pipeline) <render-pipeline>)) + +(define-syntax-rule (define-graphics-variable name exp) + (define name + (let ((cache '())) + (define (get-it) + (let ((gpu (gpu:current-gpu))) + (or (assq-ref cache gpu) + (let ((val exp)) + (set! cache (cons (cons gpu val) cache)) + val)))) + get-it))) + +(define-syntax-rule (graphics-variable-ref var) (var)) + +(define current-projection (make-parameter #f)) +(define current-viewport (make-parameter #f)) +(define current-scissor (make-parameter #f)) +(define current-pass (make-parameter #f)) + +(define-graphics-variable last-pass (box #f)) + +(define (begin-frame) + (set-box! (graphics-variable-ref last-pass) #f) + (begin-stream) + (gpu:begin-frame (gpu:current-gpu))) + +(define (end-frame view) + (end-stream) + (gpu:end-frame (gpu:current-gpu) (texture-view-handle view))) + +(define (begin-render-pass pass) + (define (resolve-texture-view view) + (match view + (#f #f) + ((? texture-view?) + (texture-view-handle view)) + ((? procedure?) + (texture-view-handle (view))))) + (match pass + (($ <render-pass> colors depth+stencil) + (let* ((gpu (gpu:current-gpu)) + (cmd (gpu:request-begin-render-pass-command gpu))) + (gpu:set-begin-render-pass-command-pass! cmd pass) + (do ((i 0 (+ i 1))) + ((= i (vector-length colors))) + (match (vector-ref colors i) + (($ <color-attachment> view resolve-target op) + (let ((view (resolve-texture-view view)) + (resolve-target (resolve-texture-view resolve-target))) + (gpu:begin-render-pass-command-color-attachment-set! + cmd i view resolve-target op))))) + (match depth+stencil + (#f #t) + (($ <depth+stencil-attachment> view depth-op stencil-op) + (let ((view (resolve-texture-view view))) + (gpu:begin-render-pass-command-depth+stencil-attachment-set! + cmd view depth-op stencil-op)))) + (gpu:submit gpu cmd))))) + +(define (end-render-pass pass) + (let* ((gpu (gpu:current-gpu)) + (cmd (gpu:request-end-render-pass-command gpu))) + (gpu:set-end-render-pass-command-pass! cmd pass) + (gpu:submit gpu cmd))) + +(define (draw* start count instances pipeline pass viewport scissor + blend-constant stencil-reference index-buffer vertex-buffers + bindings) + (unless (eq? count 0) + (let* ((gpu (gpu:current-gpu)) + (cmd (gpu:request-draw-command gpu)) + (pass-box (graphics-variable-ref last-pass)) + (pass* (unbox pass-box))) + (unless (eq? pass pass*) + (when pass* + (end-render-pass pass*)) + (begin-render-pass pass) + (set-box! pass-box pass)) + (gpu:set-draw-command-pass! cmd pass) + (gpu:set-draw-command-pipeline! cmd (render-pipeline-handle pipeline)) + (gpu:set-draw-command-viewport! cmd viewport) + (gpu:set-draw-command-scissor! cmd scissor) + (gpu:set-draw-command-blend-constant! cmd blend-constant) + (gpu:set-draw-command-stencil-reference! cmd stencil-reference) + (gpu:set-draw-command-start! cmd start) + (gpu:set-draw-command-count! cmd count) + (gpu:set-draw-command-instances! cmd instances) + (when index-buffer + (gpu:set-draw-command-index-buffer! cmd (buffer-handle index-buffer))) + (do ((i 0 (1+ i))) + ((= i (vector-length vertex-buffers))) + (let ((buffer (buffer-handle (vector-ref vertex-buffers i)))) + (gpu:set-draw-command-vertex-buffer! cmd i buffer))) + (do ((i 0 (1+ i))) + ((= i (vector-length bindings))) + (match (vector-ref bindings i) + ((? buffer? buffer) + (gpu:set-draw-command-binding! cmd i (buffer-handle buffer))) + ((? texture? texture) + (gpu:set-draw-command-binding! cmd i (texture-handle texture))) + ((? texture-view? texture) + (gpu:set-draw-command-binding! cmd i (texture-view-handle texture))) + ((? sampler? sampler) + (gpu:set-draw-command-binding! cmd i (sampler-handle sampler))) + (#f #f))) + (gpu:submit gpu cmd)))) + +(define* (draw count #:key + (start 0) + pipeline + (pass (current-pass)) + (viewport (current-viewport)) + (scissor (current-scissor)) + (blend-constant black) + (stencil-reference 0) + index-buffer + (vertex-buffers #()) + (bindings #()) + instances) + (unless (render-pass? pass) + (error "no render pass specified")) + (unless (eq? count 0) + (flush-stream) + (draw* start count instances pipeline pass viewport scissor blend-constant + stencil-reference index-buffer vertex-buffers bindings))) + + +;;; +;;; Immediate mode streaming +;;; + +;; This streaming interface is inspired by love2d. The way it works +;; is that the user calls 'stream-draw' and passes along all the +;; desired pipeline and texture/sampler/buffer binding details. If +;; the settings match what was used in the previous 'stream-draw' call +;; then the new data is simply appended to the current vertex/index +;; accumulation buffers. If the settings do not match, then the +;; stream is flushed. Flushing a stream issues a draw call for the +;; batch, clears the accumulation buffers and resets pipeline, +;; bindings, and counters. Furthermore, if any non-streaming draw +;; calls are made via 'draw' or if any relevant dynamic state is +;; changed between 'stream-draw' calls then the stream is also +;; flushed. +(define-record-type <stream-state> + (make-stream-state count vertices indices bindings bindings-length + pipeline-cache vertex-buffer-vec) + stream-state? + (count stream-state-count set-stream-state-count!) + (vertices stream-state-vertices) + (indices stream-state-indices) + (bindings stream-state-bindings) + (bindings-length stream-state-bindings-length set-stream-state-bindings-length!) + (pipeline stream-state-pipeline set-stream-state-pipeline!) + (pipeline-cache stream-state-pipeline-cache set-stream-state-pipeline-cache!) + (pass stream-state-pass set-stream-state-pass!) + (projection stream-state-projection set-stream-state-projection!) + (viewport stream-state-viewport set-stream-state-viewport!) + (scissor stream-state-scissor set-stream-state-scissor!) + (vertex-buffer-vec stream-state-vertex-buffer-vec)) + +(define-graphics-variable stream-state + (let ((limits (gpu:gpu-limits (gpu:current-gpu)))) + (make-stream-state 0 (make-dbuffer #:name "Stream vertices") + (make-dbuffer #:name "Stream indices" #:usage '(index)) + (make-vector (gpu:gpu-limits-max-vertex-buffers limits)) + 0 '() (vector #f)))) + +(define %default-primitive-mode (make-primitive-mode)) +(define %default-color-target (make-color-target)) + +(define (begin-stream) + (match (graphics-variable-ref stream-state) + ((and state ($ <stream-state> count vertices indices bindings)) + (dbuffer-map! vertices) + (dbuffer-map! indices) + (set-stream-state-count! state 0) + (set-stream-state-pipeline! state #f) + (set-stream-state-pass! state #f) + (set-stream-state-projection! state #f) + (set-stream-state-viewport! state #f) + (set-stream-state-scissor! state #f) + (vector-fill! bindings #f)))) + +(define (end-stream) + (match (graphics-variable-ref stream-state) + ((and state ($ <stream-state> count vertices indices bindings _ pipeline _ + pass projection viewport scissor vertex-vec)) + (dbuffer-unmap! vertices) + (dbuffer-unmap! indices) + (vector-set! vertex-vec 0 (dbuffer-buffer vertices)) + (unless (eq? count 0) + (draw* 0 (/ (dbuffer-length indices) 4) #f pipeline pass + viewport scissor black #xffffFFFF (dbuffer-buffer indices) + vertex-vec bindings) + (set-stream-state-count! state 0))))) + +(define (flush-stream) + (end-stream) + (begin-stream)) + +(define* (stream-draw #:key + count + shader + (primitive %default-primitive-mode) + (color-target %default-color-target) + depth+stencil + (vertex-layout #()) + (binding-layout #()) + (bindings #())) + (match (graphics-variable-ref stream-state) + ((and state + ($ <stream-state> _ vertices indices bindings* bindings-length + pipeline cache pass projection viewport scissor)) + (define-inlinable (pipeline-equal? pipeline) + (match pipeline + (($ <render-pipeline> _ _ _ _ shader* primitive* color-target* + depth+stencil* vertex-layout* binding-layout*) + (and (eq? shader shader*) + (equal? primitive primitive*) + (equal? color-target color-target*) + (equal? depth+stencil depth+stencil*) + (equal? vertex-layout vertex-layout*) + (equal? binding-layout binding-layout*))))) + (let ((pass* (current-pass)) + (projection* (current-projection)) + (viewport* (current-viewport)) + (scissor* (current-scissor))) + ;; Check if *all* settings are the same as the previous stream + ;; draw call, including various bits of dynamic state. If + ;; anything is different, draw the batch, clear it, and start + ;; over with the new settings. + (unless (and pipeline + (pipeline-equal? pipeline) + (= (vector-length bindings) bindings-length) + (let loop ((i 0)) + (or (= i (vector-length bindings)) + (and (eq? (vector-ref bindings i) + (vector-ref bindings* i)) + (loop (+ i 1))))) + (eq? pass pass*) + (eq? viewport viewport*) + (eq? scissor scissor*) + (eq? projection projection*)) + (let ((pipeline + (let loop ((pipelines cache)) + (match pipelines + (() + (let ((new (make-render-pipeline + #:name "Stream render pipeline" + #:shader shader + #:primitive primitive + #:color-target color-target + #:depth+stencil depth+stencil + #:vertex-layout vertex-layout + #:binding-layout binding-layout))) + (set-stream-state-pipeline-cache! state (cons new cache)) + new)) + ((pipeline . rest) + (if (pipeline-equal? pipeline) + pipeline + (loop rest))))))) + (flush-stream) + (set-stream-state-pipeline! state pipeline) + (set-stream-state-pass! state pass*) + (set-stream-state-projection! state projection*) + (set-stream-state-viewport! state viewport*) + (set-stream-state-scissor! state scissor*) + (set-stream-state-bindings-length! state (vector-length bindings)) + (vector-fill! bindings* #f) + (do ((i 0 (+ i 1))) + ((= i (vector-length bindings))) + (vector-set! bindings* i (vector-ref bindings i)))))) + (let ((count* (stream-state-count state))) + (set-stream-state-count! state (+ count* count)) + (values vertices indices count*))))) diff --git a/chickadee/graphics/9-patch.scm b/chickadee/graphics/9-patch.scm index c023b25..dc5f0e7 100644 --- a/chickadee/graphics/9-patch.scm +++ b/chickadee/graphics/9-patch.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2021, 2024 David Thompson <dthompson2@worcester.edu> ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. @@ -14,74 +14,136 @@ ;;; limitations under the License. (define-module (chickadee graphics 9-patch) - #:use-module (ice-9 match) - #:use-module (chickadee math matrix) - #:use-module (chickadee math rect) - #:use-module (chickadee math vector) - #:use-module (chickadee graphics blend) + #:use-module (chickadee data bytestruct) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics buffer) #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) + #:use-module (chickadee graphics pipeline) #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics sprite) #:use-module (chickadee graphics texture) - #:use-module (chickadee graphics buffer) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) #:export (draw-9-patch* draw-9-patch)) -(define-geometry-type <9-patch-vertex> - 9-patch-vertex-ref - 9-patch-vertex-set! - 9-patch-vertex-append! - (position vec2) - (distance vec2)) - -(define-graphics-variable 9-patch-geometry - (make-geometry <9-patch-vertex> 4 #:index-capacity 6)) -(define-graphics-variable 9-patch-model-matrix (make-null-matrix4)) -(define-graphics-variable 9-patch-mvp-matrix (make-null-matrix4)) -(define-graphics-variable 9-patch-margins (make-null-rect)) -(define-graphics-variable 9-patch-shader - (strings->shader - " +(define-bytestruct <9-patch-vertex> + (struct (position <vec2>) + (distance <vec2>) + (color <color>))) + +(define-bytestruct <9-patch-uniforms> + (struct (matrix <matrix4>) + (uv <rect>) + (margins <rect>) + (width f32) + (height f32) + (mode s32))) + +(define-record-type <9-patch-state> + (make-9-patch-state shader uniforms sampler margins bindings + color-target-cache) + 9-patch-state? + (shader 9-patch-state-shader) + (uniforms 9-patch-state-uniforms) + (sampler 9-patch-state-sampler) + (margins 9-patch-state-margins) + (bindings 9-patch-state-bindings) + (prev-sprite 9-patch-state-prev-sprite) + (color-target-cache 9-patch-state-color-target-cache)) + +;; TODO: This same type of cache is also in the sprite module. +;; Probably the streaming API should provide a central cache for these +;; things instead. +(define (9-patch-color-target state blend-mode) + (let ((cache (9-patch-state-color-target-cache state))) + (or (hashq-ref cache blend-mode) + (let ((color-target (make-color-target #:blend-mode blend-mode))) + (hashq-set! cache blend-mode color-target) + color-target)))) + +(define-graphics-variable 9-patch-state + (make-9-patch-state + (make-shader + (lambda (lang) + (values " #ifdef GLSL330 layout (location = 0) in vec2 position; layout (location = 1) in vec2 distance; +layout (location = 2) in vec4 tint; #elif defined(GLSL130) in vec2 position; in vec2 distance; +in vec4 tint; #elif defined(GLSL120) attribute vec2 position; attribute vec2 distance; +attribtue vec4 tint; #endif #ifdef GLSL120 varying vec2 fragDistance; +varying vec4 fragTint; #else out vec2 fragDistance; +out vec4 fragTint; +#endif +#ifdef GLSL120 +uniform mat4 matrix; +#else +layout (std140) uniform NinePatch { + mat4 matrix; + vec4 subtexture; + vec4 margins; + float width; + float height; + int mode; +}; #endif -uniform mat4 mvp; void main(void) { fragDistance = distance; - gl_Position = mvp * vec4(position.xy, 0.0, 1.0); + fragTint = tint; + gl_Position = matrix * vec4(position.xy, 0.0, 1.0); } -" - " +" " #ifdef GLSL120 varying vec2 fragDistance; +varying vec4 fragTint; #else in vec2 fragDistance; +in vec4 fragTint; #endif #ifdef GLSL330 out vec4 fragColor; +#else +#define fragColor gl_FragColor +#define texture texture2D #endif +#ifdef GLSL120 uniform vec4 subtexture; uniform vec4 margins; uniform float width; uniform float height; -uniform sampler2D colorTexture; uniform vec4 tint; uniform int mode; +uniform sampler2D colorTexture; +#else +layout (std140) uniform NinePatch { + mat4 matrix; + vec4 subtexture; + vec4 margins; + float width; + float height; + int mode; +}; +uniform sampler2D colorTexture; +#endif float patch(float d, float m0, float m1, float length, float texLength) { + int mode = 0; if(d <= m0) { // inside the left/bottom margin. return d * texLength; } else if(d >= length - m1) { // inside the right/top margin. @@ -97,18 +159,36 @@ void main (void) { vec2 texcoord = subtexture.xy; texcoord.x += patch(fragDistance.x, margins.x, margins.y, width, subtexture.z); texcoord.y += patch(fragDistance.y, margins.z, margins.w, height, subtexture.w); - -#ifdef GLSL330 - fragColor = texture(colorTexture, texcoord) * tint; -#else - gl_FragColor = texture2D(colorTexture, texcoord) * tint; -#endif + fragColor = texture(colorTexture, texcoord) * fragTint; } -")) +"))) + (make-buffer (* 16 4) + #:name "9-patch uniform buffer" + #:usage '(uniform)) + (make-sampler #:name "9-patch sampler") + (make-null-rect) + (make-vector 3 #f) + (make-hash-table))) + +(define %9-patch-vertex-layout + (vector (make-vertex-buffer-layout + #:stride (* 8 4) + #:attributes (vector + (make-vertex-attribute ; position + #:format 'float32x2) + (make-vertex-attribute ; distance + #:format 'float32x2 + #:offset (* 2 4)) + (make-vertex-attribute ; color + #:format 'float32x4 + #:offset (* 4 4)))))) + +(define %9-patch-binding-layout + (vector (make-texture-layout) + (make-sampler-layout) + (make-buffer-layout))) -(define* (draw-9-patch* texture - rect - matrix +(define* (draw-9-patch* sprite rect matrix #:key (margin 0.0) (top-margin margin) @@ -117,58 +197,101 @@ void main (void) { (right-margin margin) (mode 'stretch) (tint white) - (blend-mode blend:alpha) - (texcoords (texture-gl-tex-rect texture))) - (let ((shader (graphics-variable-ref 9-patch-shader)) - (geometry (graphics-variable-ref 9-patch-geometry)) - (mvp (graphics-variable-ref 9-patch-mvp-matrix)) - (margins (graphics-variable-ref 9-patch-margins))) - (let* ((w (rect-width rect)) - (h (rect-height rect)) - (tex-rect (texture-gl-rect texture)) - (tw (rect-width tex-rect)) - (th (rect-height tex-rect)) - ;; Convert pixel coordinates to GL texture coordinates. - (w* (/ w tw)) - (h* (/ h th))) - (with-geometry geometry - (let* ((x1 (rect-x rect)) - (y1 (rect-y rect)) - (x2 (+ x1 w)) - (y2 (+ y1 h)) - (s1 0.0) - (t1 0.0) - (s2 w*) - (t2 h*)) - (9-patch-vertex-append! geometry - (x1 y1 s1 t1) - (x2 y1 s2 t1) - (x2 y2 s2 t2) - (x1 y2 s1 t2)) - (geometry-index-append! geometry 0 3 2 0 2 1))) - ;; 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)) - (shader-apply shader - (geometry-vertex-array geometry) - #:width w* - #:height h* - #:subtexture texcoords - #:margins margins - #:mode (match mode - ('stretch 0) - ('tile 1)) - #:tint tint - #:mvp (if matrix - (begin - (matrix4-mult! mvp matrix - (current-projection)) - mvp) - (current-projection))))))) + (blend-mode blend:alpha)) + (match (graphics-variable-ref 9-patch-state) + ((and state ($ <9-patch-state> shader uniforms sampler margins bindings + prev-sprite)) + (let* ((w (rect-width rect)) + (h (rect-height rect)) + (minx (rect-x rect)) + (miny (rect-y rect)) + (maxx (+ minx w)) + (maxy (+ miny h)) + (x1 (matrix4-transform-x matrix minx miny)) + (y1 (matrix4-transform-y matrix minx miny)) + (x2 (matrix4-transform-x matrix maxx miny)) + (y2 (matrix4-transform-y matrix maxx miny)) + (x3 (matrix4-transform-x matrix maxx maxy)) + (y3 (matrix4-transform-y matrix maxx maxy)) + (x4 (matrix4-transform-x matrix minx maxy)) + (y4 (matrix4-transform-y matrix minx maxy)) + (tex-rect (sprite-rect sprite)) + (tw (rect-width tex-rect)) + (th (rect-height tex-rect)) + ;; Convert pixel coordinates to UV coordinates. + (w* (/ w tw)) + (h* (/ h th))) + ;; Convert pixel margin values to UV 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)) + (vector-set! bindings 0 (sprite-texture-view sprite)) + (vector-set! bindings 1 sampler) + (vector-set! bindings 2 uniforms) + ;; Flush stream if sprite is different than the previous call. + ;; This could be a no-op if the previous stream draw call was + ;; for something other than a 9-patch, or if the previous call + ;; was last frame. + ;; + ;; TODO: Redesign this so we don't flush if the texture view + ;; hasn't changed. We should be able to support many different + ;; 9-patches packed into the same texture that can be drawn in + ;; a batch. + (unless (eq? sprite prev-sprite) + (flush-stream)) + (call-with-values + (lambda () + (stream-draw #:count 4 + #:shader shader + #:color-target (9-patch-color-target state blend-mode) + #:vertex-layout %9-patch-vertex-layout + #:binding-layout %9-patch-binding-layout + #:bindings bindings)) + (lambda (vertices indices i) + ;; TODO: Figure out how to include uniform buffer init in + ;; stream API. + (when (eq? i 0) + (let ((bv (map-buffer uniforms 'write 0 + (bytestruct-sizeof <9-patch-uniforms>)))) + (bytestruct-pack! <9-patch-uniforms> + (((matrix) (current-projection)) + ((uv) (sprite-rect-uv sprite)) + ((margins) margins) + ((width) w*) + ((height) h*) + ((mode) (match mode + ('stretch 0) + ('tile 1)))) + bv 0))) + (let* ((u1 0.0) + (v1 0.0) + (u2 w*) + (v2 h*) + (r (color-r tint)) + (g (color-g tint)) + (b (color-b tint)) + (a (color-a tint)) + (vsize (bytestruct-sizeof <9-patch-vertex>)) + (voffset (dbuffer-reserve! vertices (* vsize 4))) + (ioffset (dbuffer-reserve! indices (* 6 4)))) + (define-syntax-rule (set-vertex! j px py dx dy cr cg cb ca) + (dbuffer-pack! <9-patch-vertex> + (((position x) px) + ((position y) py) + ((distance x) dx) + ((distance y) dy) + ((color r) cr) + ((color g) cg) + ((color b) cb) + ((color a) ca)) + vertices + (+ voffset (* j vsize)))) + (set-vertex! 0 x1 y1 u1 v1 r g b a) + (set-vertex! 1 x2 y2 u2 v1 r g b a) + (set-vertex! 2 x3 y3 u2 v2 r g b a) + (set-vertex! 3 x4 y4 u1 v2 r g b a) + (dbuffer-pack-indices-quad! indices ioffset i)))))))) (define %null-vec2 (vec2 0.0 0.0)) (define %default-scale (vec2 1.0 1.0)) diff --git a/chickadee/graphics/backend.scm b/chickadee/graphics/backend.scm new file mode 100644 index 0000000..e08fdb0 --- /dev/null +++ b/chickadee/graphics/backend.scm @@ -0,0 +1,442 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary +;; +;; Graphics backend. +;; +;;; Code: + +(define-module (chickadee graphics backend) + #:use-module (chickadee data pool) + #:use-module (chickadee graphics color) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (<draw-command> + draw-command? + draw-command-pipeline + draw-command-pass + draw-command-viewport + draw-command-scissor + draw-command-blend-constant + draw-command-stencil-reference + draw-command-start + draw-command-count + draw-command-instances + draw-command-index-buffer + set-draw-command-pipeline! + set-draw-command-pass! + set-draw-command-viewport! + set-draw-command-scissor! + set-draw-command-blend-constant! + set-draw-command-stencil-reference! + set-draw-command-start! + set-draw-command-count! + set-draw-command-instances! + set-draw-command-index-buffer! + set-draw-command-vertex-buffer! + set-draw-command-binding! + + <begin-render-pass-command> + begin-render-pass-command? + begin-render-pass-command-pass + set-begin-render-pass-command-pass! + begin-render-pass-command-color-attachment-set! + begin-render-pass-command-depth+stencil-attachment-set! + + <end-render-pass-command> + end-render-pass-command? + end-render-pass-command-pass + set-end-render-pass-command-pass! + + make-gpu-limits + gpu-limits? + gpu-limits-max-texture-dimension-1d + gpu-limits-max-texture-dimension-2d + gpu-limits-max-texture-dimension-3d + gpu-limits-max-texture-array-layers + gpu-limits-max-sampled-textures-per-shader-stage + gpu-limits-max-samplers-per-shader-stage + gpu-limits-max-uniform-buffers-per-shader-stage + gpu-limits-max-uniform-buffer-binding-size + gpu-limits-max-bindings + gpu-limits-max-vertex-buffers + gpu-limits-max-buffer-size + gpu-limits-max-vertex-attributes + gpu-limits-max-vertex-buffer-array-stride + gpu-limits-max-inter-stage-shader-components + gpu-limits-max-inter-stage-shader-variables + gpu-limits-max-color-attachments + + current-gpu + make-gpu + gpu? + gpu-name + gpu-description + gpu-limits + begin-frame + end-frame + make-buffer + destroy-buffer + map-buffer + unmap-buffer + write-buffer + make-texture + destroy-texture + write-texture + make-texture-view + destroy-texture-view + make-sampler + destroy-sampler + make-shader + destroy-shader + make-render-pipeline + destroy-render-pipeline + request-begin-render-pass-command + request-end-render-pass-command + request-draw-command + submit)) + + +;;; +;;; GPU commands +;;; + +;; TODO: Pool commands and re-use them each frame. + +(define (make-vector* k thunk) + (let ((v (make-vector k))) + (do ((i 0 (+ i 1))) + ((= i (vector-length v))) + (vector-set! v i (thunk))) + v)) + +(define-record-type <begin-render-pass-command> + (make-begin-render-pass-command color-attachments depth+stencil-attachment) + begin-render-pass-command? + (pass begin-render-pass-command-pass set-begin-render-pass-command-pass!) + (color-attachments begin-render-pass-command-color-attachments) + (depth+stencil-attachment begin-render-pass-command-depth+stencil-attachment)) + +(define (fresh-begin-render-pass-command max-color-attachments) + (make-begin-render-pass-command (make-vector* max-color-attachments + (lambda () (make-vector 3 #f))) + (make-vector 3 #f))) + +(define (begin-render-pass-command-color-attachment-set! cmd i view + resolve-target op) + (let ((v (vector-ref (begin-render-pass-command-color-attachments cmd) i))) + (vector-set! v 0 view) + (vector-set! v 1 resolve-target) + (vector-set! v 2 op))) + +(define (begin-render-pass-command-depth+stencil-attachment-set! cmd view + depth-op + stencil-op) + (let ((v (begin-render-pass-command-depth+stencil-attachment cmd))) + (vector-set! v 0 view) + (vector-set! v 1 depth-op) + (vector-set! v 2 stencil-op))) + +(define-record-type <end-render-pass-command> + (make-end-render-pass-command) + end-render-pass-command? + (pass end-render-pass-command-pass set-end-render-pass-command-pass!)) + +(define (fresh-end-render-pass-command) + (make-end-render-pass-command)) + +(define-record-type <draw-command> + (make-draw-command start count vertex-buffers bindings) + draw-command? + (pipeline draw-command-pipeline set-draw-command-pipeline!) + (pass draw-command-pass set-draw-command-pass!) + (viewport draw-command-viewport set-draw-command-viewport!) + (scissor draw-command-scissor set-draw-command-scissor!) + (blend-constant draw-command-blend-constant set-draw-command-blend-constant!) + (stencil-reference draw-command-stencil-reference! + set-draw-command-stencil-reference!) + (start draw-command-start set-draw-command-start!) + (count draw-command-count set-draw-command-count!) + (instances draw-command-instances set-draw-command-instances!) + (index-buffer draw-command-index-buffer set-draw-command-index-buffer!) + (vertex-buffers draw-command-vertex-buffers) + (bindings draw-command-bindings)) + +(define (set-draw-command-vertex-buffer! cmd i buffer) + (vector-set! (draw-command-vertex-buffers cmd) i buffer)) + +(define (set-draw-command-binding! cmd i obj) + (vector-set! (draw-command-bindings cmd) i obj)) + + +;;; +;;; GPU backend +;;; + +(define-record-type <gpu-limits> + (%make-gpu-limits max-texture-dimension-1d + max-texture-dimension-2d + max-texture-dimension-3d + max-texture-array-layers + max-sampled-textures-per-shader-stage + max-samplers-per-shader-stage + max-uniform-buffers-per-shader-stage + max-uniform-buffer-binding-size + max-bindings + max-vertex-buffers + max-buffer-size + max-vertex-attributes + max-vertex-buffer-array-stride + max-inter-stage-shader-components + max-inter-stage-shader-variables + max-color-attachments) + gpu-limits? + (max-texture-dimension-1d gpu-limits-max-texture-dimension-1d) + (max-texture-dimension-2d gpu-limits-max-texture-dimension-2d) + (max-texture-dimension-3d gpu-limits-max-texture-dimension-3d) + (max-texture-array-layers gpu-limits-max-texture-array-layers) + (max-sampled-textures-per-shader-stage + gpu-limits-max-sampled-textures-per-shader-stage) + (max-samplers-per-shader-stage gpu-limits-max-samplers-per-shader-stage) + (max-uniform-buffers-per-shader-stage gpu-limits-max-uniform-buffers-per-shader-stage) + (max-uniform-buffer-binding-size gpu-limits-max-uniform-buffer-binding-size) + (max-bindings gpu-limits-max-bindings) + (max-vertex-buffers gpu-limits-max-vertex-buffers) + (max-buffer-size gpu-limits-max-buffer-size) + (max-vertex-attributes gpu-limits-max-vertex-attributes) + (max-vertex-buffer-array-stride gpu-limits-max-vertex-buffer-array-stride) + (max-inter-stage-shader-components gpu-limits-max-inter-stage-shader-components) + (max-inter-stage-shader-variables gpu-limits-max-inter-stage-shader-variables) + (max-color-attachments gpu-limits-max-color-attachments)) + +(define* (make-gpu-limits #:key + max-texture-dimension-1d + max-texture-dimension-2d + max-texture-dimension-3d + max-texture-array-layers + max-sampled-textures-per-shader-stage + max-samplers-per-shader-stage + max-uniform-buffers-per-shader-stage + max-uniform-buffer-binding-size + max-bindings + max-vertex-buffers + max-buffer-size + max-vertex-attributes + max-vertex-buffer-array-stride + max-inter-stage-shader-components + max-inter-stage-shader-variables + max-color-attachments) + (%make-gpu-limits max-texture-dimension-1d + max-texture-dimension-2d + max-texture-dimension-3d + max-texture-array-layers + max-sampled-textures-per-shader-stage + max-samplers-per-shader-stage + max-uniform-buffers-per-shader-stage + max-uniform-buffer-binding-size + max-bindings + max-vertex-buffers + max-buffer-size + max-vertex-attributes + max-vertex-buffer-array-stride + max-inter-stage-shader-components + max-inter-stage-shader-variables + max-color-attachments)) + +(define-record-type <gpu> + (%make-gpu name + description + limits + internal + begin-frame + end-frame + make-buffer + destroy-buffer + map-buffer + unmap-buffer + write-buffer + make-texture + destroy-texture + write-texture + make-texture-view + destroy-texture-view + make-sampler + destroy-sampler + make-shader + destroy-shader + make-render-pipeline + destroy-render-pipeline + submit + draw-command-pool) + gpu? + (name gpu-name) + (description gpu-description) + (limits gpu-limits) + (internal gpu-internal) + (begin-frame gpu-begin-frame) + (end-frame gpu-end-frame) + (make-buffer gpu-make-buffer) + (destroy-buffer gpu-destroy-buffer) + (map-buffer gpu-map-buffer) + (unmap-buffer gpu-unmap-buffer) + (write-buffer gpu-write-buffer) + (make-texture gpu-make-texture) + (destroy-texture gpu-destroy-texture) + (write-texture gpu-write-texture) + (make-texture-view gpu-make-texture-view) + (destroy-texture-view gpu-destroy-texture-view) + (make-sampler gpu-make-sampler) + (destroy-sampler gpu-destroy-sampler) + (make-shader gpu-make-shader) + (destroy-shader gpu-destroy-shader) + (make-render-pipeline gpu-make-render-pipeline) + (destroy-render-pipeline gpu-destroy-render-pipeline) + (submit gpu-submit) + (draw-command-pool gpu-draw-command-pool)) + +(define (print-gpu gpu port) + (format port "#<gpu ~a>" (gpu-name gpu))) + +(set-record-type-printer! <gpu> print-gpu) + +(define (nop1 x) #t) + +(define-syntax unimplemented + (lambda (x) + (syntax-case x () + ((_ name) + (with-syntax ((msg (string-append (symbol->string + (syntax->datum #'name)) + " unimplemented"))) + #'(lambda args (error msg))))))) + +(define* (make-gpu name description internal #:key + limits + (begin-frame nop1) + (end-frame nop1) + (make-buffer (unimplemented make-buffer)) + (destroy-buffer (unimplemented destroy-buffer)) + (map-buffer (unimplemented map-buffer)) + (unmap-buffer (unimplemented unmap-buffer)) + (write-buffer (unimplemented write-buffer)) + (make-texture (unimplemented make-texture)) + (destroy-texture (unimplemented destroy-texture)) + (write-texture (unimplemented write-texture)) + (make-texture-view (unimplemented make-texture-view)) + (destroy-texture-view (unimplemented destroy-texture-view)) + (make-sampler (unimplemented make-sampler)) + (destroy-sampler (unimplemented destroy-sampler)) + (make-shader (unimplemented make-shader)) + (destroy-shader (unimplemented destroy-shader)) + (make-render-pipeline (unimplemented make-render-pipeline)) + (destroy-render-pipeline (unimplemented destroy-render-pipeline)) + (submit (unimplemented submit))) + (let ((max-vertex-buffers (gpu-limits-max-vertex-buffers limits)) + (max-bindings (gpu-limits-max-bindings limits))) + (define (fresh-draw-command) + (make-draw-command 0 0 (make-vector max-vertex-buffers) + (make-vector max-bindings))) + (define (init-draw-command cmd) + (set-draw-command-pipeline! cmd #f) + (set-draw-command-pass! cmd #f) + (set-draw-command-viewport! cmd #f) + (set-draw-command-scissor! cmd #f) + (set-draw-command-blend-constant! cmd black) + (set-draw-command-stencil-reference! cmd #xffffFFFF) + (set-draw-command-start! cmd 0) + (set-draw-command-count! cmd 0) + (set-draw-command-index-buffer! cmd #f) + (vector-fill! (draw-command-vertex-buffers cmd) #f) + (vector-fill! (draw-command-bindings cmd) #f)) + (%make-gpu name + description + limits + internal + begin-frame + end-frame + make-buffer + destroy-buffer + map-buffer + unmap-buffer + write-buffer + make-texture + destroy-texture + write-texture + make-texture-view + destroy-texture-view + make-sampler + destroy-sampler + make-shader + destroy-shader + make-render-pipeline + destroy-render-pipeline + submit + (make-pool draw-command? fresh-draw-command init-draw-command)))) + +(define current-gpu (make-parameter #f)) + +(define-syntax-rule (define-delegate name getter args ...) + (define (name backend args ...) + ((getter backend) (gpu-internal backend) args ...))) + +(define-delegate begin-frame gpu-begin-frame) +(define-delegate end-frame gpu-end-frame view) + +(define-delegate make-buffer gpu-make-buffer length usage) +(define-delegate destroy-buffer gpu-destroy-buffer buffer) +(define-delegate map-buffer gpu-map-buffer buffer mode offset length) +(define-delegate unmap-buffer gpu-unmap-buffer buffer) +(define-delegate write-buffer gpu-write-buffer + buffer buffer-offset data data-offset length) + +(define-delegate make-texture gpu-make-texture + width height depth mip-levels samples dimension format) +(define-delegate destroy-texture gpu-destroy-texture texture) +(define-delegate write-texture gpu-write-texture + texture x y z width height depth mip-level format data offset) + +(define-delegate make-texture-view gpu-make-texture-view + texture format dimension aspect base-mip-level mip-levels base-layer layers) +(define-delegate destroy-texture-view gpu-destroy-texture-view view) + +(define-delegate make-sampler gpu-make-sampler + address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter) +(define-delegate destroy-sampler gpu-destroy-sampler sampler) + +(define-delegate make-shader gpu-make-shader source) +(define-delegate destroy-shader gpu-destroy-shader shader) + +(define-delegate make-render-pipeline gpu-make-render-pipeline + shader primitive color-target depth+stencil multisample vertex-layout binding-layout) +(define-delegate destroy-render-pipeline gpu-destroy-render-pipeline pipeline) + +(define (request-begin-render-pass-command gpu) + (fresh-begin-render-pass-command + (gpu-limits-max-color-attachments (gpu-limits gpu)))) + +(define (request-end-render-pass-command gpu) + (fresh-end-render-pass-command)) + +(define (request-draw-command gpu) + (pool-borrow (gpu-draw-command-pool gpu))) + +(define (submit gpu command) + ((gpu-submit gpu) (gpu-internal gpu) command) + (cond + ((draw-command? command) + (pool-return (gpu-draw-command-pool gpu) command)) + (else (values)))) diff --git a/chickadee/graphics/backend/opengl.scm b/chickadee/graphics/backend/opengl.scm new file mode 100644 index 0000000..c1753f3 --- /dev/null +++ b/chickadee/graphics/backend/opengl.scm @@ -0,0 +1,2173 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary: +;; +;; OpenGL graphics backend. +;; +;;; Code: + +(define-module (chickadee graphics backend opengl) + #:use-module (chickadee graphics backend) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics depth-stencil) + #:use-module (chickadee graphics layout) + #:use-module (chickadee graphics multisample) + #:use-module (chickadee graphics primitive) + #:use-module (chickadee graphics viewport) + #:use-module (gl) + #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%)) + #:use-module (gl runtime) + #:use-module (gl types) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module ((system foreign) #:select (%null-pointer + bytevector->pointer + make-pointer + pointer->string + pointer->bytevector + pointer-address)) + #:export (make-opengl-gpu)) + + +;;; +;;; Additional OpenGL wrappers +;;; + +;; TODO: Upstream these to guile-opengl + +(define gl-clear-color %glClearColor) +(define gl-clear-depth %glClearDepth) +(define gl-clear-stencil %glClearStencil) +(define gl-scissor %glScissor) +(define gl-blend-func-separate %glBlendFuncSeparate) +(define gl-blend-equation-separate %glBlendEquationSeparate) +(define gl-blend-color %glBlendColor) +(define gl-active-texture %glActiveTexture) +(define gl-tex-image-3d %glTexImage3D) +(define gl-tex-image-2d %glTexImage2D) +(define gl-tex-image-1d %glTexImage1D) +(define gl-copy-tex-image-2d %glCopyTexImage2D) +(define gl-copy-tex-image-1d %glCopyTexImage1D) +(define gl-copy-tex-sub-image-3d %glCopyTexSubImage3D) +(define gl-copy-tex-sub-image-2d %glCopyTexSubImage2D) +(define gl-copy-tex-sub-image-1d %glCopyTexSubImage1D) +(define gl-tex-sub-image-3d %glTexSubImage3D) +(define gl-tex-sub-image-2d %glTexSubImage2D) +(define gl-tex-sub-image-1d %glTexSubImage1D) +(define gl-compressed-tex-image-1d %glCompressedTexImage1D) +(define gl-compressed-tex-image-2d %glCompressedTexImage2D) +(define gl-compressed-tex-image-3d %glCompressedTexImage3D) +(define gl-compressed-tex-sub-image-1d %glCompressedTexSubImage1D) +(define gl-compressed-tex-sub-image-2d %glCompressedTexSubImage2D) +(define gl-compressed-tex-sub-image-3d %glCompressedTexSubImage3D) +(define gl-tex-parameter %glTexParameteri) +(define gl-get-tex-parameter %glGetTexParameteriv) +(define gl-bind-texture %glBindTexture) +(define gl-get-tex-image %glGetTexImage) +(define gl-buffer-data %glBufferData) +(define gl-buffer-sub-data %glBufferSubData) +(define gl-map-buffer %glMapBuffer) +(define gl-unmap-buffer %glUnmapBuffer) +(define gl-draw-buffers %glDrawBuffers) +(define gl-draw-buffer %glDrawBuffer) +(define gl-use-program %glUseProgram) +(define gl-link-program %glLinkProgram) +(define gl-bind-attrib-location %glBindAttribLocation) +(define gl-attach-shader %glAttachShader) +(define gl-detach-shader %glDetachShader) +(define gl-get-attrib-location %glGetAttribLocation) +(define gl-get-uniform-location %glGetUniformLocation) +(define gl-create-program %glCreateProgram) +(define gl-get-program-info-log %glGetProgramInfoLog) +(define gl-get-programiv %glGetProgramiv) +(define gl-delete-program %glDeleteProgram) +(define gl-delete-shader %glDeleteShader) +(define gl-get-shaderiv %glGetShaderiv) +(define gl-get-shader-info-log %glGetShaderInfoLog) +(define gl-compile-shader %glCompileShader) +(define gl-shader-source %glShaderSource) +(define gl-create-shader %glCreateShader) +(define gl-get-active-uniform %glGetActiveUniform) +(define gl-get-active-attrib %glGetActiveAttrib) +(define gl-uniform1i %glUniform1i) +(define gl-uniform1iv %glUniform1iv) +(define gl-uniform2i %glUniform2i) +(define gl-uniform3i %glUniform3i) +(define gl-uniform4i %glUniform4i) +(define gl-uniform1f %glUniform1f) +(define gl-uniform1fv %glUniform1fv) +(define gl-uniform2f %glUniform2f) +(define gl-uniform2fv %glUniform2fv) +(define gl-uniform3f %glUniform3f) +(define gl-uniform3fv %glUniform3fv) +(define gl-uniform4f %glUniform4f) +(define gl-uniform4fv %glUniform4fv) +(define gl-uniform-matrix3fv %glUniformMatrix3fv) +(define gl-uniform-matrix4fv %glUniformMatrix4fv) +(define gl-point-size %glPointSize) +(define %gl-get-string %glGetString) +(define gl-get-integerv %glGetIntegerv) +(define gl-depth-func %glDepthFunc) +(define gl-depth-mask %glDepthMask) +(define gl-depth-range %glDepthRange) +(define gl-stencil-mask %glStencilMask) +(define gl-stencil-mask-separate %glStencilMaskSeparate) +(define gl-stencil-func %glStencilFunc) +(define gl-stencil-func-separate %glStencilFuncSeparate) +(define gl-stencil-op %glStencilOp) +(define gl-stencil-op-separate %glStencilOpSeparate) +(define gl-polygon-mode %glPolygonMode) +(define gl-cull-face %glCullFace) +(define gl-front-face %glFrontFace) +(define gl-color-mask %glColorMask) +(define gl-get-error %glGetError) + +;; TODO: Upstream these to guile-opengl +(define-gl-procedure (glTexImage2DMultisample (target GLenum) + (samples GLsizei) + (internalformat GLenum) + (width GLsizei) + (height GLsizei) + (fixed-sample-locations GLboolean) + -> void) + "Establish the data storage, format, dimensions, and number of samples +of a multisample texture's image.") + +(define-gl-procedure (glTexStorage1D (target GLenum) + (levels GLsizei) + (internalformat GLenum) + (width GLsizei) + -> void) + "Simultaneously specify storage for all levels of a one-dimensional texture.") + +(define-gl-procedure (glTexStorage2D (target GLenum) + (levels GLsizei) + (internalformat GLenum) + (width GLsizei) + (height GLsizei) + -> void) + "Simultaneously specify storage for all levels of a two-dimensional or +one-dimensional array texture.") + +(define-gl-procedure (glTexStorage2DMultisample (target GLenum) + (samples GLsizei) + (internalformat GLenum) + (width GLsizei) + (height GLsizei) + (fixed-sample-locations GLboolean) + -> void) + "Specify storage for a two-dimensional multisample texture.") + +(define-gl-procedure (glTexStorage3D (target GLenum) + (levels GLsizei) + (internalformat GLenum) + (width GLsizei) + (height GLsizei) + (depth GLsizei) + -> void) + "Simultaneously specify storage for all levels of a three-dimensional, +two-dimensional array or cube-map array texture.") + +(define-gl-procedure (glGenerateMipmap (target GLenum) -> void) + "Generate mipmaps for the texture attached to target of the active +texture unit.") + +(define-gl-procedure (glTextureView (texture GLuint) + (target GLenum) + (origtexture GLuint) + (internalformat GLenum) + (minlevel GLuint) + (numlevels GLuint) + (minlayer GLuint) + (numlayers GLuint) + -> void) + "Initialize a texture as a data alias of another texture's data +store.") + +(define-gl-procedure (glGenSamplers (n GLsizei) + (ids GLuint-*) + -> void) + "Generate sampler object names.") + +(define-gl-procedure (glDeleteSamplers (n GLsizei) + (ids GLuint-*) + -> void) + "Delete named sampler objects.") + +(define-gl-procedure (glSamplerParameteri (sampler GLuint) + (pname GLenum) + (param GLint) + -> void) + "Set sampler parameters.") + +(define-gl-procedure (glBindSampler (unit GLuint) + (sampler GLuint) + -> void) + "Bind sampler.") + +(define-gl-procedure (glDrawArraysInstanced (mode GLenum) + (first GLint) + (count GLsizei) + (primcount GLsizei) + -> void) + "Draw multiple instances of a set of arrays.") + +(define-gl-procedure (glDrawElementsInstanced (mode GLenum) + (count GLsizei) + (type GLenum) + (indices void-*) + (primcount GLsizei) + -> void) + "Draw multiple instances of a set of elements.") + +(define-gl-procedure (glVertexAttribDivisor (index GLuint) + (divisor GLuint) + -> void) + "Modify the rate at which generic vertex attributes advance during +instanced rendering.") + +(define-gl-procedure (glBindBufferBase (target GLenum) + (index GLuint) + (buffer GLuint) + -> void) + "Bind a buffer object to an indexed buffer target.") + +(define-gl-procedure (glBindBufferRange (target GLenum) + (index GLuint) + (buffer GLuint) + (offset GLint-*) + (size GLsizei-*) + -> void) + "Bind a buffer object to an indexed buffer target.") + +(define-gl-procedure (glGenVertexArrays (n GLsizei) + (arrays GLuint-*) + -> void) + "Generate N vertex arrays.") + +(define-gl-procedure (glDeleteVertexArrays (n GLsizei) + (arrays GLuint-*) + -> void) + "Delete vertex array objects.") + +(define-gl-procedure (glBindVertexArray (array GLuint) + -> void) + "Bind vertex array object ARRAY.") + +(define-gl-procedure (glEnableVertexAttribArray (index GLuint) + -> void) + "Enable or disable a generic vertex attribute array.") + +(define-gl-procedure (glVertexAttribPointer (index GLuint) + (size GLint) + (type GLenum) + (normalized GLboolean) + (stride GLsizei) + (pointer GLvoid-*) + -> void) + "Define an array of generic vertex attribute data.") + +(define-gl-procedure (glDrawElements (mode GLenum) + (count GLsizei) + (type GLenum) + (indices GLvoid-*) + -> void) + "Render primitives from array data.") + +(define-gl-procedure (glGenFramebuffers (n GLsizei) + (ids GLuint-*) + -> void) + "Generate framebuffer object names.") + +(define-gl-procedure (glDeleteFramebuffers (n GLsizei) + (framebuffers GLuint-*) + -> void) + "Delete framebuffer objects.") + +(define-gl-procedure (glBindFramebuffer (target GLenum) + (framebuffer GLuint) + -> void) + "Bind a framebuffer to a framebuffer target.") + +(define-gl-procedure (glGetFramebufferAttachmentParameteriv (target GLenum) + (attachment GLenum) + (pname GLenum) + (params GLint-*) + -> void) + "Return attachment parameters of a framebuffer object.") + +(define-gl-procedure (glFramebufferTexture2D (target GLenum) + (attachment GLenum) + (textarget GLenum) + (texture GLuint) + (level GLint) + -> void) + "Attach a level of a texture object as a logical buffer to the +currently bound framebuffer object.") + +(define-gl-procedure (glCheckFramebufferStatus (target GLenum) + -> GLenum) + "Return the framebuffer completeness status of a framebuffer +object.") + +(define-gl-procedure (glGenRenderbuffers (n GLsizei) + (ids GLuint-*) + -> void) + "Generate renderbuffer object names.") + +(define-gl-procedure (glDeleteRenderbuffers (n GLsizei) + (renderbuffers GLuint-*) + -> void) + "Delete renderbuffer objects.") + +(define-gl-procedure (glBindRenderbuffer (target GLenum) + (renderbuffer GLuint) + -> void) + "Bind a named renderbuffer object.") + +(define-gl-procedure (glRenderbufferStorage (target GLenum) + (internalformat GLenum) + (width GLsizei) + (height GLsizei) + -> void) + "Create and initialize a renderbuffer object's data store.") + +(define-gl-procedure (glFramebufferRenderbuffer (target GLenum) + (attachment GLenum) + (renderbuffertarget GLenum) + (renderbuffer GLuint) + -> void) + "Attach a renderbuffer object to a framebuffer object.") + +(define-gl-procedure (glUniform1ui (location GLint) + (v0 GLuint) + -> void) + "Specify the value of a uniform variable for the current program object") + +(define-gl-procedure (glUniform1uiv (location GLint) + (count GLint) + (ptr GLvoid-*) + -> void) + "Specify the value of a uniform variable for the current program object") + +(define gl-tex-storage-1d glTexStorage1D) +(define gl-tex-storage-2d glTexStorage2D) +(define gl-tex-storage-2d-multisample glTexStorage2DMultisample) +(define gl-tex-storage-3d glTexStorage3D) +(define gl-tex-image-2d-multisample glTexImage2DMultisample) +(define gl-generate-mipmap glGenerateMipmap) +(define gl-texture-view glTextureView) +(define gl-gen-samplers glGenSamplers) +(define gl-sampler-parameter glSamplerParameteri) +(define gl-bind-sampler glBindSampler) +(define gl-draw-arrays-instanced glDrawArraysInstanced) +(define gl-draw-elements-instanced glDrawElementsInstanced) +(define gl-vertex-attrib-divisor glVertexAttribDivisor) +(define gl-bind-buffer-base glBindBufferBase) +(define gl-bind-buffer-range glBindBufferRange) +(define gl-gen-vertex-arrays glGenVertexArrays) +(define gl-delete-vertex-arrays glDeleteVertexArrays) +(define gl-bind-vertex-array glBindVertexArray) +(define gl-enable-vertex-attrib-array glEnableVertexAttribArray) +(define gl-vertex-attrib-pointer glVertexAttribPointer) +(define gl-draw-elements glDrawElements) +(define gl-gen-framebuffers glGenFramebuffers) +(define gl-bind-framebuffer glBindFramebuffer) +(define gl-get-framebuffer-attachment-parameteriv + glGetFramebufferAttachmentParameteriv) +(define gl-framebuffer-texture-2d glFramebufferTexture2D) +(define gl-check-framebuffer-status glCheckFramebufferStatus) +(define gl-gen-renderbuffers glGenRenderbuffers) +(define gl-delete-renderbuffers glDeleteRenderbuffers) +(define gl-bind-renderbuffer glBindRenderbuffer) +(define gl-renderbuffer-storage glRenderbufferStorage) +(define gl-framebuffer-renderbuffer glFramebufferRenderbuffer) +(define gl-uniform1ui glUniform1ui) +(define gl-uniform1uiv glUniform1uiv) + +(define (gl-generate-sampler) + (let ((bv (u32vector 0))) + (glGenSamplers 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-sampler n) + (let ((bv (u32vector n))) + (glDeleteSamplers 1 bv))) + +(define (gl-generate-vertex-array) + (let ((bv (u32vector 0))) + (glGenVertexArrays 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-vertex-array n) + (let ((bv (u32vector n))) + (glDeleteVertexArrays 1 bv))) + +(define (gl-generate-framebuffer) + (let ((bv (u32vector 0))) + (glGenFramebuffers 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-framebuffer n) + (let ((bv (u32vector n))) + (glDeleteFramebuffers 1 bv))) + +(define (gl-generate-renderbuffer) + (let ((bv (u32vector 0))) + (glGenRenderbuffers 1 bv) + (u32vector-ref bv 0))) + +(define (gl-delete-renderbuffer n) + (let ((bv (u32vector n))) + (glDeleteRenderbuffers 1 bv))) + +(define (gl-get-integer id) + (let ((bv (s32vector 0))) + (gl-get-integerv id (bytevector->pointer bv)) + (s32vector-ref bv 0))) + +(define (gl-get-string id) + (pointer->string (%gl-get-string id))) + + +;;; +;;; Types +;;; + +(define-record-type <gl-buffer> + (%make-gl-buffer id map-cache) + gl-buffer? + (id gl-buffer-id) + (map-cache gl-buffer-map-cache) + (destroyed? gl-buffer-destroyed? set-gl-buffer-destroyed!)) + +(define-record-type <gl-texture> + (%make-gl-texture id target width height depth mip-levels samples format) + gl-texture? + (id gl-texture-id) + (target gl-texture-target) + (width gl-texture-width) + (height gl-texture-height) + (depth gl-texture-depth) + (mip-levels gl-texture-mip-levels) + (samples gl-texture-samples) + (format gl-texture-format) + (destroyed? gl-texture-destroyed? set-gl-texture-destroyed!)) + +(define-record-type <gl-texture-view> + (%make-gl-texture-view id target parent) + gl-texture-view? + (id gl-texture-view-id) + (target gl-texture-view-target) + (parent gl-texture-view-parent) + (destroyed? gl-texture-view-destroyed? set-gl-texture-view-destroyed!)) + +(define-record-type <gl-sampler> + (%make-gl-sampler id) + gl-sampler? + (id gl-sampler-id) + (destroyed? gl-sampler-destroyed? set-gl-sampler-destroyed!)) + +;; When sampler objects are not available. +(define-record-type <gl-sampler-fallback> + (make-gl-sampler-fallback wrap-s wrap-t wrap-r mag-filter min-filter) + gl-sampler-fallback? + (wrap-s gl-sampler-fallback-wrap-s) + (wrap-t gl-sampler-fallback-wrap-t) + (wrap-r gl-sampler-fallback-wrap-r) + (mag-filter gl-sampler-fallback-mag-filter) + (min-filter gl-sampler-fallback-min-filter)) + +(define-record-type <gl-shader> + (%make-gl-shader id) + gl-shader? + (id gl-shader-id) + (destroyed? gl-shader-destroyed? set-gl-shader-destroyed!)) + +(define-record-type <gl-framebuffer> + (%make-gl-framebuffer id color-views depth+stencil-view destroyed?) + gl-framebuffer? + (id gl-framebuffer-id) + (color-views gl-framebuffer-color-views) + (depth+stencil-view gl-framebuffer-depth+stencil-view) + (destroyed? gl-framebuffer-destroyed? set-gl-framebuffer-destroyed!)) + +(define-record-type <gl-vertex-attribute> + (make-gl-vertex-attribute index size type normalized? stride pointer divisor) + gl-vertex-attribute? + (index gl-vertex-attribute-index) + (size gl-vertex-attribute-size) + (type gl-vertex-attribute-type) + (normalized? gl-vertex-attribute-normalized?) + (stride gl-vertex-attribute-stride) + (pointer gl-vertex-attribute-pointer) + (divisor gl-vertex-attribute-divisor)) + +(define-record-type <gl-blend-op> + (make-gl-blend-op rgb alpha) + gl-blend-op? + (rgb gl-blend-op-rgb) + (alpha gl-blend-op-alpha)) + +(define-record-type <gl-blend-func> + (make-gl-blend-func src-rgb src-alpha dst-rgb dst-alpha) + gl-blend-func? + (src-rgb gl-blend-func-src-rgb) + (src-alpha gl-blend-func-src-alpha) + (dst-rgb gl-blend-func-dst-rgb) + (dst-alpha gl-blend-func-dst-alpha)) + +(define-record-type <gl-blend-mode> + (make-gl-blend-mode op func) + gl-blend-mode? + (op gl-blend-mode-op) + (func gl-blend-mode-func)) + +(define-record-type <gl-depth-test> + (make-gl-depth-test func mask) + gl-depth-test? + (func gl-depth-test-func) + (mask gl-depth-test-mask)) + +(define-record-type <gl-stencil-op> + (make-gl-stencil-op on-fail on-depth-fail on-pass) + gl-stencil-op? + (on-fail gl-stencil-op-on-fail) + (on-depth-fail gl-stencil-op-on-depth-fail) + (on-pass gl-stencil-op-on-pass)) + +(define-record-type <gl-stencil-test> + (make-gl-stencil-test read-mask write-mask func-front func-back op-front op-back) + gl-stencil-test? + (read-mask gl-stencil-test-read-mask) + (write-mask gl-stencil-test-write-mask) + (func-front gl-stencil-test-func-front) + (func-back gl-stencil-test-func-back) + (op-front gl-stencil-test-op-front) + (op-back gl-stencil-test-op-back)) + +(define-record-type <gl-render-pipeline> + (%make-gl-render-pipeline shader begin-mode polygon-mode cull-face-mode + front-face color-format blend-mode color-mask + depth-test stencil-test multisample vertex-attributes + binding-layout) + gl-render-pipeline? + (shader gl-render-pipeline-shader) + (begin-mode gl-render-pipeline-begin-mode) + (polygon-mode gl-render-pipeline-polygon-mode) + (cull-face-mode gl-render-pipeline-cull-face-mode) + (front-face gl-render-pipeline-front-face) + (color-format gl-render-pipeline-color-format) + (blend-mode gl-render-pipeline-blend-mode) + (color-mask gl-render-pipeline-color-mask) + (depth-test gl-render-pipeline-depth-test) + (stencil-test gl-render-pipeline-stencil-test) + (multisample gl-render-pipeline-multisample) + (vertex-attributes gl-render-pipeline-vertex-attributes) + (binding-layout gl-render-pipeline-binding-layout)) + +;; Cache driver state locally so we only talk to the GPU when +;; necessary. This allows us to efficiently implement "stateless" +;; draw calls on top of the stateful GL context without a ton of round +;; trips to the driver/GPU to set redundant state. +(define-record-type <gl-state> + (%make-gl-state gl-context + swap + guardian + gl-version + glsl-version + vendor + renderer + limits + texture-views-supported? + samplers-supported? + uniform-buffers-supported? + blending? + face-culling? + depth-test? + stencil-test? + scissor-test? + viewport + scissor-rect + polygon-mode + cull-face + front-face + blend-op + blend-func + color-mask + depth-func + depth-write? + depth-range + stencil-write-mask + stencil-func-front + stencil-func-back + stencil-op-front + stencil-op-back + clear-color + clear-depth + clear-stencil + buffer-index + buffer-vertex + buffer-copy-read + buffer-copy-write + buffer-uniforms + textures + samplers + shader + draw-framebuffer + read-framebuffer + mode + framebuffer-cache) + gl-state? + (gl-context gl-state-gl-context) + (swap gl-state-swap) + ;; GC guardian for finalizing GPU objects. + (guardian gl-state-guardian) + ;; Metadata + (gl-version gl-state-gl-version) + (glsl-version gl-state-glsl-version) + (vendor gl-state-vendor) + (renderer gl-state-renderer) + (limits gl-state-limits) + ;; Feature flags + (texture-views-supported? gl-state-texture-views-supported?) + (samplers-supported? gl-state-samplers-supported?) + (uniform-buffers-supported? gl-state-uniform-buffers-supported?) + ;; Capability flags + (blending? gl-state-blending? %set-gl-state-blending!) + (face-culling? gl-state-face-culling? %set-gl-state-face-culling!) + (depth-test? gl-state-depth-test? %set-gl-state-depth-test!) + (stencil-test? gl-state-stencil-test? %set-gl-state-stencil-test!) + (scissor-test? gl-state-scissor-test? %set-gl-state-scissor-test!) + (multisample? gl-state-multisample? %set-gl-state-multisample!) + ;; Driver state + (viewport gl-state-viewport %set-gl-state-viewport!) + (scissor-rect gl-state-scissor-rect %set-gl-state-scissor-rect!) + (polygon-mode gl-state-polygon-mode %set-gl-state-polygon-mode!) + (cull-face gl-state-cull-face %set-gl-state-cull-face!) + (front-face gl-state-front-face %set-gl-state-front-face!) + (blend-op gl-state-blend-op %set-gl-state-blend-op!) + (blend-func gl-state-blend-func %set-gl-state-blend-func!) + (blend-constant gl-state-blend-constant %set-gl-state-blend-constant!) + (color-mask gl-state-color-mask %set-gl-state-color-mask!) + (depth-func gl-state-depth-func %set-gl-state-depth-func!) + (depth-write? gl-state-depth-write? %set-gl-state-depth-write!) + (depth-range gl-state-depth-range) + (stencil-write-mask gl-state-stencil-write-mask %set-gl-state-stencil-write-mask!) + (stencil-func-front gl-state-stencil-func-front) + (stencil-func-back gl-state-stencil-func-back) + (stencil-op-front gl-state-stencil-op-front %set-gl-state-stencil-op-front!) + (stencil-op-back gl-state-stencil-op-back %set-gl-state-stencil-op-back!) + (clear-color gl-state-clear-color %set-gl-state-clear-color!) + (clear-depth gl-state-clear-depth %set-gl-state-clear-depth!) + (clear-stencil gl-state-clear-stencil %set-gl-state-clear-stencil!) + (buffer-index gl-state-buffer-index %set-gl-state-buffer-index!) + (buffer-vertex gl-state-buffer-vertex %set-gl-state-buffer-vertex!) + (buffer-copy-read gl-state-buffer-copy-read %set-gl-state-buffer-copy-read!) + (buffer-copy-write gl-state-buffer-copy-write %set-gl-state-buffer-copy-write!) + (buffer-uniforms gl-state-buffer-uniforms) ; vector + (textures gl-state-textures) ; vector + (samplers gl-state-samplers) ; vector + (shader gl-state-shader %set-gl-state-shader!) + (draw-framebuffer gl-state-draw-framebuffer %set-gl-state-draw-framebuffer!) + (read-framebuffer gl-state-read-framebuffer %set-gl-state-read-framebuffer!) + ;; Command state + (mode gl-state-mode set-gl-state-mode!) ; default, render-pass, etc. + ;; Render pass state + (framebuffer-cache gl-state-framebuffer-cache) + ;; State for drawing to default framebuffer + (screen-indices gl-state-screen-indices set-gl-state-screen-indices!) + (screen-vertices gl-state-screen-vertices set-gl-state-screen-vertices!) + (screen-shader gl-state-screen-shader set-gl-state-screen-shader!)) + +(define (print-gl-state state port) + (match state + (($ <gl-state> context _ _ gl-version glsl-version vendor renderer) + (format port "#<gl-state context: ~a gl-version: ~a glsl-version: ~a vendor: ~a renderer: ~a>" + context gl-version glsl-version vendor renderer)))) + +(set-record-type-printer! <gl-state> print-gl-state) + + +;;; +;;; Screen state +;;; + +(define (set-gl-state-viewport! state viewport) + (match viewport + (($ <viewport> new-x new-y new-width new-height) + (match (gl-state-viewport state) + (($ <viewport> old-x old-y old-width old-height) + (unless (and (= old-x new-x) + (= old-y new-y) + (= old-width new-width) + (= old-height new-height)) + (gl-viewport new-x new-y new-width new-height) + (%set-gl-state-viewport! state viewport))))))) + +(define (set-gl-state-scissor-test! state scissor-test?) + (unless (eq? (gl-state-scissor-test? state) scissor-test?) + (if scissor-test? + (gl-enable (enable-cap scissor-test)) + (gl-disable (enable-cap scissor-test))) + (%set-gl-state-scissor-test! state scissor-test?))) + +(define (set-gl-state-scissor-rect! state rect) + (unless (equal? (gl-state-scissor-rect state) rect) + (match rect + (($ <scissor-rect> x y w h) + (gl-scissor x y w h))) + (%set-gl-state-scissor-rect! state rect))) + + +;;; +;;; Primitive state +;;; + +(define (set-gl-state-face-culling! state cull?) + (unless (eq? (gl-state-face-culling? state) cull?) + (if cull? + (gl-enable (enable-cap cull-face)) + (gl-disable (enable-cap cull-face))) + (%set-gl-state-face-culling! state cull?))) + +(define (set-gl-state-polygon-mode! state mode) + (unless (eqv? (gl-state-polygon-mode state) mode) + (gl-polygon-mode (cull-face-mode front-and-back) mode) + (%set-gl-state-polygon-mode! state mode))) + +(define (set-gl-state-cull-face! state face) + (unless (eqv? (gl-state-cull-face state) face) + (gl-cull-face face) + (%set-gl-state-cull-face! state face))) + +(define (set-gl-state-front-face! state face) + (unless (eq? (gl-state-front-face state) face) + (gl-front-face face) + (%set-gl-state-front-face! state face))) + + +;;; +;;; Color/blend state +;;; + +(define (set-gl-state-blending! state blend?) + (unless (eq? (gl-state-blending? state) blend?) + (if blend? + (gl-enable (enable-cap blend)) + (gl-disable (enable-cap blend))) + (%set-gl-state-blending! state blend?))) + +(define %default-color-mask (make-color-mask #t #t #t #t)) + +(define (set-gl-state-color-mask! state color-mask) + (unless (equal? (gl-state-color-mask state) color-mask) + (match color-mask + (($ <color-mask> red? green? blue? alpha?) + (gl-color-mask red? green? blue? alpha?) + (%set-gl-state-color-mask! state color-mask))))) + +(define (set-gl-state-blend-op! state op) + (unless (equal? (gl-state-blend-op state) op) + (match op + (($ <gl-blend-op> rgb alpha) + (gl-blend-equation-separate rgb alpha) + (%set-gl-state-blend-op! state op))))) + +(define (set-gl-state-blend-func! state func) + (unless (equal? (gl-state-blend-func state) func) + (match func + (($ <gl-blend-func> src-rgb src-alpha dst-rgb dst-alpha) + (gl-blend-func-separate src-rgb dst-rgb src-alpha dst-alpha) + (%set-gl-state-blend-func! state func))))) + +(define (set-gl-state-blend-constant! state color) + (unless (equal? (gl-state-blend-constant state) color) + (gl-blend-color (color-r color) (color-g color) (color-b color) (color-a color)) + (%set-gl-state-blend-constant! state color))) + +(define (set-gl-state-clear-color! state color) + (unless (equal? (gl-state-clear-color state) color) + (gl-clear-color (color-r color) (color-g color) (color-b color) (color-a color)) + (%set-gl-state-clear-color! state color))) + + +;;; +;;; Depth test +;;; + +(define (set-gl-state-depth-test! state depth-test?) + (unless (eq? (gl-state-depth-test? state) depth-test?) + (if depth-test? + (gl-enable (enable-cap depth-test)) + (gl-disable (enable-cap depth-test))) + (%set-gl-state-depth-test! state depth-test?))) + +(define (set-gl-state-depth-func! state func) + (unless (equal? (gl-state-depth-func state) func) + (gl-depth-func func) + (%set-gl-state-depth-func! state func))) + +(define (set-gl-state-depth-write! state write?) + (unless (eq? (gl-state-depth-write? state) write?) + (gl-depth-mask write?) + (%set-gl-state-depth-write! state write?))) + +(define (set-gl-state-depth-range! state near far) + (let ((range (gl-state-depth-range state))) + (unless (and (= (f64vector-ref range 0) near) + (= (f64vector-ref range 1) far)) + (gl-depth-range near far) + (f64vector-set! range 0 near) + (f64vector-set! range 1 far)))) + +(define (set-gl-state-clear-depth! state depth) + (unless (eqv? (gl-state-clear-depth state) depth) + (gl-clear-depth depth) + (%set-gl-state-clear-depth! state depth))) + + +;;; +;;; Stencil test +;;; + +(define (set-gl-state-stencil-test! state stencil-test?) + (unless (eq? (gl-state-stencil-test? state) stencil-test?) + (if stencil-test? + (gl-enable (enable-cap stencil-test)) + (gl-disable (enable-cap stencil-test))) + (%set-gl-state-stencil-test! state stencil-test?))) + +(define (set-gl-state-stencil-write-mask! state mask) + (unless (eqv? (gl-state-stencil-write-mask state) mask) + (gl-stencil-mask mask) + (%set-gl-state-stencil-write-mask! state mask))) + +(define (set-gl-state-stencil-func-front! state func ref mask) + (match (gl-state-stencil-func-front state) + ((and v #(old-func old-ref old-mask)) + (unless (and (eqv? func old-func) + (eqv? ref old-ref) + (eqv? mask old-mask)) + (gl-stencil-func-separate (material-face front) func ref mask) + (vector-set! v 0 func) + (vector-set! v 1 ref) + (vector-set! v 2 mask))))) + +(define (set-gl-state-stencil-func-back! state func ref mask) + (match (gl-state-stencil-func-back state) + ((and v #(old-func old-ref old-mask)) + (unless (and (eqv? func old-func) + (eqv? ref old-ref) + (eqv? mask old-mask)) + (gl-stencil-func-separate (material-face back) func ref mask) + (vector-set! v 0 func) + (vector-set! v 1 ref) + (vector-set! v 2 mask))))) + +(define (set-gl-state-stencil-op-front! state op) + (unless (equal? (gl-state-stencil-op-front state) op) + (match op + (($ <gl-stencil-op> on-fail on-depth-fail on-pass) + (gl-stencil-op-separate (cull-face-mode front) on-fail on-depth-fail on-pass))) + (%set-gl-state-stencil-op-front! state op))) + +(define (set-gl-state-stencil-op-back! state op) + (unless (equal? (gl-state-stencil-op-back state) op) + (match op + (($ <gl-stencil-op> on-fail on-depth-fail on-pass) + (gl-stencil-op-separate (cull-face-mode back) on-fail on-depth-fail on-pass))) + (%set-gl-state-stencil-op-back! state op))) + +(define (set-gl-state-clear-stencil! state s) + (unless (eqv? (gl-state-clear-stencil state) s) + (gl-clear-stencil s) + (%set-gl-state-clear-stencil! state s))) + + +;;; +;;; Multisampling +;;; + +(define (set-gl-state-multisample! state multisample?) + (unless (eq? (gl-state-multisample? state) multisample?) + (if multisample? + (gl-enable (version-1-3 multisample)) + (gl-disable (version-1-3 multisample))) + (%set-gl-state-multisample! state multisample?))) + + +;;; +;;; Buffers +;;; + +;; TODO: Think about compatibility issues. +;; +;; The copy-src and uniform usages are available only if the GL +;; version is 3.1 or greater. The indirect and storage usages targets +;; are available only if the GL version is 4.3 or greater. The +;; query-resolve target is available only if the GL version is 4.4 or +;; greater. +;; +;; Some of these things just can't be emulated on GL 2 or 3, but we +;; need a solution for uniforms on GL 2 because the frontend +;; rightfully requires the use of uniform buffers. A possible +;; solution is to keep a CPU-side buffer and when the buffer is bound +;; in a draw call, make the appropriate glUniform calls instead. It's +;; slow, but that's what you've gotta deal with on old GL. This +;; requires introspecting the shader to get uniform locations. + +(define (set-gl-state-buffer-vertex! state buffer) + (unless (eq? (gl-state-buffer-vertex state) buffer) + (gl-bind-buffer (version-1-5 array-buffer) (gl-buffer-id buffer)) + (%set-gl-state-buffer-vertex! state buffer))) + +(define (set-gl-state-buffer-index! state buffer) + (unless (eq? (gl-state-buffer-index state) buffer) + (gl-bind-buffer (version-1-5 element-array-buffer) (gl-buffer-id buffer)) + (%set-gl-state-buffer-index! state buffer))) + +(define (set-gl-state-buffer-copy-read! state buffer) + (unless (eq? (gl-state-buffer-copy-read state) buffer) + (gl-bind-buffer (version-3-1 copy-read-buffer) (gl-buffer-id buffer)) + (%set-gl-state-buffer-copy-read! state buffer))) + +(define (set-gl-state-buffer-copy-write! state buffer) + (unless (eq? (gl-state-buffer-copy-write state) buffer) + (gl-bind-buffer (version-3-1 copy-write-buffer) (gl-buffer-id buffer)) + (%set-gl-state-buffer-copy-write! state buffer))) + +(define (set-gl-state-buffer-uniform! state i buffer) + (let ((ubos (gl-state-buffer-uniforms state))) + (unless (eq? (vector-ref ubos i) buffer) + (gl-bind-buffer-base (version-3-1 uniform-buffer) i (gl-buffer-id buffer)) + (vector-set! ubos i buffer)))) + +(define null-gl-buffer (%make-gl-buffer 0 #f)) + +;; TODO: Respect usage flags. +(define (make-gl-buffer state length usage) + (let ((buffer (%make-gl-buffer (gl-generate-buffer) (make-hash-table)))) + (gl-state-guard state buffer) + ;; Allocate buffer memory. + (set-gl-state-buffer-vertex! state buffer) + (gl-buffer-data (version-1-5 array-buffer) + length %null-pointer + ;; TODO: Set hints based on usage flags. + (version-1-5 static-draw)) + buffer)) + +(define (destroy-gl-buffer state buffer) + (unless (gl-buffer-destroyed? buffer) + (gl-delete-buffer (gl-buffer-id buffer)) + (set-gl-buffer-destroyed! buffer #t))) + +(define (map-gl-buffer state buffer mode offset length) + ;; Mapping a buffer repeatedly tends to return the same pointers over + ;; and over, even when the buffer re-specification trick is used. By + ;; caching bytevectors for those memory regions we avoid bytevector + ;; allocation after some frames of warmup, reducing GC pressure. + (define (pointer->bytevector* pointer length offset) + (let ((cache (gl-buffer-map-cache buffer)) + (address (pointer-address pointer))) + (or (let ((cached (hashv-ref cache address))) + (and cached + (= length (bytevector-length cached)) + cached)) + (let ((bv (pointer->bytevector pointer length))) + (hashv-set! cache address bv) + bv)))) + (let ((target (version-1-5 array-buffer)) + (access (match mode + ('read (version-1-5 read-only)) + ('write (version-1-5 write-only))))) + (set-gl-state-buffer-vertex! state buffer) + ;; For write-only buffers, we abandon the original buffer storage + ;; to avoid the performance hit of implicit synchronization. + ;; + ;; This is not the right thing to do generally but it's what *I* + ;; want to happen when I am filling sprite batches so... + ;; + ;; See: + ;; https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification + (when (eq? mode 'write) + ;; Assuming for now that mapping for write means streaming. + (gl-buffer-data target length %null-pointer (version-1-5 stream-draw))) + ;; HACK: flush error since I'm not checking for errors everywhere. + (gl-get-error) + (let ((ptr (gl-map-buffer target access))) + (unless (eq? (gl-get-error) 0) + (error "failed to map buffer" buffer)) + (pointer->bytevector* ptr length offset)))) + +(define (unmap-gl-buffer state buffer) + (set-gl-state-buffer-vertex! state buffer) + ;; HACK: flush error since I'm not checking for errors everywhere. + (gl-get-error) + (gl-unmap-buffer (version-1-5 array-buffer)) + (unless (eq? (gl-get-error) 0) + (error "failed to unmap buffer" buffer))) + +(define (write-gl-buffer state buffer buffer-offset data data-offset length) + (set-gl-state-buffer-vertex! state buffer) + (gl-buffer-sub-data (version-1-5 array-buffer) + buffer-offset length + (bytevector->pointer data data-offset))) + + +;;; +;;; Textures and views +;;; + +(define (gl-state-texture-ref state i) + (vector-ref (gl-state-textures state) i)) + +(define (set-gl-state-texture! state i texture) + (gl-active-texture (+ (version-1-3 texture0) i)) + (let ((textures (gl-state-textures state))) + (unless (eq? (vector-ref textures i) texture) + (match texture + (($ <gl-texture> id target) + (gl-bind-texture target id)) + (($ <gl-texture-view> id target) + (gl-bind-texture target id) + ;; If we're using fallback samplers, we need to modify the + ;; texture parameters of the newly bound texture. + (unless (gl-state-samplers-supported? state) + (match (gl-state-sampler-ref state i) + ((? gl-sampler-fallback? sampler) + (apply-sampler-fallback i sampler texture)) + (_ #t))))) + (vector-set! textures i texture)))) + +(define null-gl-texture (%make-gl-texture 0 #f 0 0 0 0 0 #f)) + +(define (lower-texture-format format) + (match format + ('rgba8 (pixel-internal-format rgba8)) + ('depth24plus-stencil8 (version-3-0 depth24-stencil8)))) + +;; TODO: layers for 2D textures (should use 3d storage) +(define (make-gl-texture state width height depth mip-levels samples + dimension format) + (let* ((id (gl-generate-texture)) + (multisample? (> samples 1)) + (target (match dimension + ('1d (texture-target texture-1d)) + ('2d (if multisample? + (version-3-2 texture-2d-multisample) + (texture-target texture-2d))) + ('3d (texture-target texture-3d-ext)))) + (format (lower-texture-format format)) + (texture (%make-gl-texture id target width height depth mip-levels + samples format))) + (gl-state-guard state texture) + (set-gl-state-texture! state 0 texture) + (gl-tex-parameter target (version-1-2 texture-max-level) mip-levels) + (let ((levels (+ mip-levels 1))) + (if (gl-state-texture-views-supported? state) + ;; Setup immutable storage parameters. + (match dimension + ('1d (gl-tex-storage-1d target levels format width)) + ('2d + (if multisample? + (gl-tex-storage-2d-multisample target samples format width height #t) + (gl-tex-storage-2d target levels format width height))) + ('3d (gl-tex-storage-3d target levels format width height depth))) + ;; Manually setup all layers and mip levels. + ;; + ;; Dummy format/type. Doesn't matter because we aren't + ;; sending over any pixel data. + (let ((fmt (pixel-internal-format rgba8)) + (type (color-pointer-type unsigned-byte))) + (match dimension + ('1d + (let loop ((i 0) (width width)) + (when (< i levels) + (gl-tex-image-1d target i format width 0 fmt type + %null-pointer) + (loop (+ i 1) (quotient width 2))))) + ('2d + (if multisample? + (gl-tex-image-2d-multisample target samples fmt width height #t) + (let loop ((i 0) (width width) (height height)) + (when (< i levels) + (gl-tex-image-2d target i format width height 0 fmt type + %null-pointer) + (loop (+ i 1) (quotient width 2) (quotient height 2)))))) + ('3d + (let loop ((i 0) (width width) (height height) (depth depth)) + (when (< i levels) + (gl-tex-image-3d target i format width height depth 0 fmt + type %null-pointer) + (loop (+ i 1) (quotient width 2) (quotient height 2) + (quotient depth 3))))))))) + texture)) + +(define (destroy-gl-texture state texture) + (unless (gl-texture-destroyed? texture) + (gl-delete-texture (gl-texture-id texture)) + (set-gl-texture-destroyed! texture #t))) + +;; TODO: When texture views aren't supported, update all emulated +;; (copied) faux view textures after write completes. +(define (write-gl-texture state texture x y z width height depth mip-level + format data offset) + (let ((ptr (bytevector->pointer data offset))) + ;; TODO: Support additional formats. + (let ((format (match format + ('rgba8 (pixel-format rgba)))) + (type (match format + ('rgba8 (color-pointer-type unsigned-byte))))) + (match texture + (($ <gl-texture> id target) + (set-gl-state-texture! state 0 texture) + (cond + ((eqv? target (texture-target texture-1d)) + (gl-tex-sub-image-1d target mip-level x width format type ptr)) + ((eqv? target (texture-target texture-2d)) + (gl-tex-sub-image-2d target mip-level x y width height format + type ptr)) + ((eqv? target (texture-target texture-3d-ext)) + (gl-tex-sub-image-3d target mip-level x y z width height depth + format type ptr)))))))) + +(define null-gl-texture-view + (%make-gl-texture-view 0 (texture-target texture-1d) 0)) + +;; Texture views are only supported in OpenGL >= 4.3 so older versions +;; have to fall back to copying data into a new texture. +(define (make-gl-texture-view state texture format dimension aspect base-mip-level + mip-levels base-layer layers) + (let ((target (match dimension + ('1d (texture-target texture-1d)) + ('2d (texture-target texture-2d)) + ('2d-array (version-3-0 texture-2d-array)) + ('cube (version-1-3 texture-cube-map)) + ('cube-array (arb-texture-cube-map-array texture-cube-map-array)) + ('3d (texture-target texture-3d-ext)))) + (format (lower-texture-format format))) + (match texture + (($ <gl-texture> pid ptarget pwidth pheight pdepth pmip-levels psamples pformat) + ;; Is the view using the same settings as the parent texture? + ;; If so, there's no need to make an alias. + (if (and (= target ptarget) + (= format pformat) + (= base-mip-level 0) + (= mip-levels pmip-levels) + (= base-layer 0) + (= layers pdepth) + (eq? aspect 'all)) + ;; Re-use the parent texture id. No need to guard it from + ;; GC since no new texture was allocated. + (%make-gl-texture-view pid target texture) + ;; Create a new texture view. + (let* ((levels (+ mip-levels 1)) + (id (gl-generate-texture)) + (view (%make-gl-texture-view id target texture))) + (gl-state-guard state view) + (if (gl-state-texture-views-supported? state) + ;; Ah, so simple. + (gl-texture-view id target pid format base-mip-level + levels base-layer layers) + ;; Emulate texture view with a slow copy. Gross. + (let* ((copy-format (pixel-format rgba)) + (copy-type (color-pointer-type unsigned-byte)) + (bv (make-bytevector (* pwidth pheight pdepth 4))) + (ptr (bytevector->pointer bv))) + (set-gl-state-texture! state 1 view) + (gl-tex-parameter target (version-1-2 texture-max-level) + mip-levels) + ;; For each mip level, copy the pixels from the + ;; parent texture to the CPU then back over into + ;; the view texture. + (match dimension + ('1d + (let loop ((i 0) (w pwidth)) + (when (< i levels) + (set-gl-state-texture! state 0 texture) + (gl-get-tex-image ptarget i copy-format copy-type ptr) + (set-gl-state-texture! state 0 view) + (gl-tex-image-1d target i format w 0 + copy-format copy-type ptr) + (loop (+ i 1) (quotient w 2))))) + ('2d + (let loop ((i 0) (w pwidth) (h pheight)) + (when (< i levels) + (set-gl-state-texture! state 0 texture) + (gl-get-tex-image ptarget i copy-format copy-type ptr) + (set-gl-state-texture! state 0 view) + (gl-tex-image-2d target i format w h 0 + copy-format copy-type ptr) + (loop (+ i 1) (quotient w 2) (quotient h 2))))) + ((or '2d-array '3d) + (let loop ((i 0) (w pwidth) (h pheight) (d pdepth)) + (when (< i levels) + (set-gl-state-texture! state 0 texture) + (gl-get-tex-image ptarget i copy-format copy-type ptr) + (set-gl-state-texture! state 0 view) + (gl-tex-image-3d target i format w h d 0 + copy-format copy-type ptr) + (loop (+ i 1) (quotient w 2) (quotient h 2) + (quotient d 2))))) + ('cube + (let loop ((i 0) (w pwidth) (h pheight)) + (when (< i levels) + (set-gl-state-texture! state 0 texture) + (gl-get-tex-image ptarget i copy-format copy-type ptr) + (set-gl-state-texture! state 0 view) + ;; Annoyingly, we have to do a separate upload + ;; for each cube map face + (gl-tex-image-2d (version-1-3 texture-cube-map-positive-x) + i format w h 0 copy-format copy-type ptr) + (gl-tex-image-2d (version-1-3 texture-cube-map-negative-x) + i format w h 0 copy-format copy-type + (bytevector->pointer bv (* w h))) + (gl-tex-image-2d (version-1-3 texture-cube-map-positive-y) + i format w h 0 copy-format copy-type + (bytevector->pointer bv (* w h 2))) + (gl-tex-image-2d (version-1-3 texture-cube-map-negative-y) + i format w h 0 copy-format copy-type + (bytevector->pointer bv (* w h 3))) + (gl-tex-image-2d (version-1-3 texture-cube-map-positive-z) + i format w h 0 copy-format copy-type + (bytevector->pointer bv (* w h 4))) + (gl-tex-image-2d (version-1-3 texture-cube-map-negative-z) + i format w h 0 copy-format copy-type + (bytevector->pointer bv (* w h 5))) + (loop (+ i 1) (quotient w 2) (quotient h 2))))) + ('cube-array (error "cube map array unsupported"))))) + view)))))) + +(define (destroy-gl-texture-view state view) + (unless (gl-texture-view-destroyed? view) + (gl-delete-texture (gl-texture-view-id view)) + (set-gl-texture-view-destroyed! view #t))) + + +;;; +;;; Samplers +;;; + +;; Samplers are supported in OpenGL >= 3.3 so older versions have to +;; fall back to manipulating the texture parameters each time the +;; sampler is bound. This simple approach has the limitation that +;; it's not possible to sample the same texture in two different ways +;; in the same shader. I don't currently do this anywhere, so it's a +;; limitation I can live with right now. + +(define (gl-state-sampler-ref state i) + (vector-ref (gl-state-samplers state) i)) + +(define (apply-sampler-fallback i sampler texture) + (match sampler + (($ <gl-sampler-fallback> wrap-s wrap-t wrap-r mag-filter min-filter) + (match texture + (($ <gl-texture-view> id target) + (gl-active-texture i) + (gl-tex-parameter target + (texture-parameter-name texture-wrap-s) + wrap-s) + (gl-tex-parameter target + (texture-parameter-name texture-wrap-t) + wrap-t) + (gl-tex-parameter target + (texture-parameter-name texture-wrap-t) + wrap-t) + (gl-tex-parameter target + (texture-parameter-name texture-mag-filter) + mag-filter) + (gl-tex-parameter target + (texture-parameter-name texture-min-filter) + min-filter)) + ;; Do nothing if a view isn't bound. + (_ #f))))) + +(define (set-gl-state-sampler! state i sampler) + (let ((samplers (gl-state-samplers state))) + (unless (eq? (vector-ref samplers i) sampler) + (match sampler + (($ <gl-sampler> id) + (gl-bind-sampler i id)) + ((? gl-sampler-fallback?) + (apply-sampler-fallback i sampler (gl-state-texture-ref state i)))) + (vector-set! samplers i sampler)))) + +(define null-gl-sampler (%make-gl-sampler 0)) + +(define (make-gl-sampler state address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter) + (define (gl-wrap-mode mode) + (match mode + ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis)) + ('repeat (texture-wrap-mode repeat)) + ('mirror-repeat (version-1-4 mirrored-repeat)))) + (let ((wrap-s (gl-wrap-mode address-mode-u)) + (wrap-t (gl-wrap-mode address-mode-v)) + (wrap-r (gl-wrap-mode address-mode-w)) + (mag-filter (match mag-filter + ('nearest (texture-min-filter nearest)) + ('linear (texture-min-filter linear)))) + (min-filter (match min-filter + ('nearest + (match mipmap-filter + ('nearest (texture-min-filter nearest-mipmap-nearest)) + ('linear (texture-min-filter nearest-mipmap-linear)))) + ('linear + (match mipmap-filter + ('nearest (texture-min-filter linear-mipmap-nearest)) + ('linear (texture-min-filter linear-mipmap-linear))))))) + (if (gl-state-samplers-supported? state) + (let* ((id (gl-generate-sampler)) + (sampler (gl-state-guard state (%make-gl-sampler id)))) + (gl-sampler-parameter id (texture-parameter-name texture-wrap-s) wrap-s) + (gl-sampler-parameter id (texture-parameter-name texture-wrap-t) wrap-t) + (gl-sampler-parameter id (texture-parameter-name texture-wrap-r-ext) wrap-r) + (gl-sampler-parameter id (texture-parameter-name texture-min-filter) + min-filter) + (gl-sampler-parameter id (texture-parameter-name texture-mag-filter) + mag-filter) + sampler) + (make-gl-sampler-fallback wrap-s wrap-t wrap-r mag-filter min-filter)))) + +(define (destroy-gl-sampler state sampler) + (unless (gl-sampler-destroyed? sampler) + (gl-delete-sampler (gl-sampler-id sampler)) + (set-gl-sampler-destroyed! sampler #t))) + + +;;; +;;; Shaders +;;; + +(define (set-gl-state-shader! state shader) + (unless (eq? (gl-state-shader state) shader) + (gl-use-program (gl-shader-id shader)) + (%set-gl-state-shader! state shader))) + +(define null-gl-shader (%make-gl-shader 0)) + +(define (make-gl-shader state source) + (define-values (vertex-source fragment-source) (source 'glsl)) + (define header + ;; 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 ((version (gl-state-glsl-version state))) + (cond + ((string>= version "3.3") + "#version 330 +#define GLSL330 +") + ((string>= version "1.3") + "#version 130 +#define GLSL130 +") + ((string>= version "1.2") + "#version 120 +#define GLSL120 +") + (else + (error "incompatible GLSL version" version))))) + (define (info-log shader) + (let ((log-length-bv (make-u32vector 1 0))) + (gl-get-shaderiv shader (version-2-0 info-log-length) + (bytevector->pointer log-length-bv)) + ;; 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) 0))) + (gl-get-shader-info-log shader log-length %null-pointer + (bytevector->pointer log)) + (utf8->string log)))) + (define (compiled? id) + (let ((status (make-u32vector 1))) + (gl-get-shaderiv id + (version-2-0 compile-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + (define (linked? id) + (let ((status (make-u32vector 1 0))) + (gl-get-programiv id (version-2-0 link-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + (define (compile-stage source type) + (let ((id (gl-create-shader type)) + (bv (string->utf8 (string-append header source)))) + (gl-shader-source id 1 + (bytevector->pointer + (u64vector + (pointer-address (bytevector->pointer bv)))) + (bytevector->pointer + (u32vector (bytevector-length bv)))) + (gl-compile-shader id) + (if (compiled? id) + id + (let ((msg (info-log id))) + (gl-delete-shader id) + (error (format #f "failed to compile shader: ~a" msg)))))) + (let ((vert (compile-stage vertex-source (version-2-0 vertex-shader))) + (frag (compile-stage fragment-source (version-2-0 fragment-shader))) + (id (gl-create-program))) + (gl-attach-shader id vert) + (gl-attach-shader id frag) + (gl-link-program id) + (gl-detach-shader id vert) + (gl-detach-shader id frag) + (gl-delete-shader vert) + (gl-delete-shader frag) + (unless (linked? id) + (let ((msg (info-log id))) + (gl-delete-program id) + (error (format #f "failed to link shader: ~a" msg)))) + (gl-state-guard state (%make-gl-shader id)))) + +(define (destroy-gl-shader state shader) + (unless (gl-shader-destroyed? shader) + (gl-delete-program (gl-shader-id shader)) + (set-gl-shader-destroyed! shader #t))) + + +;;; +;;; Framebuffers +;;; + +(define (set-gl-state-draw-framebuffer! state fbo) + (unless (eq? (gl-state-draw-framebuffer state) fbo) + (gl-bind-framebuffer (version-3-0 framebuffer) + (gl-framebuffer-id fbo)) + (%set-gl-state-draw-framebuffer! state fbo))) + +(define (set-gl-state-read-framebuffer! state fbo) + (unless (eq? (gl-state-read-framebuffer state) fbo) + (gl-bind-framebuffer (version-3-0 framebuffer) + (gl-framebuffer-id fbo)) + (%set-gl-state-read-framebuffer! state fbo))) + +(define null-gl-framebuffer (%make-gl-framebuffer 0 #() #f #f)) + +(define (make-gl-framebuffer state) + (let ((id (gl-generate-framebuffer)) + (colors (make-vector (gpu-limits-max-color-attachments + (gl-state-limits state)) + #f))) + (gl-state-guard state (%make-gl-framebuffer id colors #f #f)))) + +(define (destroy-gl-framebuffer fbo) + (unless (gl-framebuffer-destroyed? fbo) + (gl-delete-framebuffer (gl-framebuffer-id fbo)) + (set-gl-framebuffer-destroyed! fbo #t))) + +(define (gl-state-framebuffer-ref state key) + (hashq-ref (gl-state-framebuffer-cache state) key)) + +;; Find or create framebuffer and update attachments. +(define (gl-state-framebuffer-build state key colors depth+stencil) + (let* ((fbo-cache (gl-state-framebuffer-cache state)) + (fbo (or (hashq-ref fbo-cache key) + (let ((new (make-gl-framebuffer state))) + (hashq-set! fbo-cache key new) + new)))) + (set-gl-state-draw-framebuffer! state fbo) + (do ((i 0 (+ i 1))) + ((= i (vector-length colors))) + (match (vector-ref colors i) + (#(#f _ _) + (gl-framebuffer-texture-2d (version-3-0 framebuffer) + (+ (version-3-0 color-attachment0) i) + (texture-target texture-2d) 0 0)) + (#(($ <gl-texture-view> id target) _ _) + (gl-framebuffer-texture-2d (version-3-0 framebuffer) + (+ (version-3-0 color-attachment0) i) + target id 0)))) + (match depth+stencil + (#(#f _ _) + (gl-framebuffer-texture-2d (version-3-0 framebuffer) + (arb-framebuffer-object depth-stencil-attachment) + (texture-target texture-2d) 0 0)) + (#(($ <gl-texture-view> id target) _ _) + (gl-framebuffer-texture-2d (version-3-0 framebuffer) + (arb-framebuffer-object depth-stencil-attachment) + target id 0))) + fbo)) + + +;;; +;;; Render pipelines +;;; + +(define (make-gl-render-pipeline state shader primitive color-target + depth+stencil multisample vertex-layout + binding-layout) + (define (format-component-count format) + (match format + ((or 'uint32 'float32) 1) + ((or 'uint8x2 'sint8x2 'unorm8x2 'snorm8x2 'uint16x2 'sint16x2 + 'unorm16x2 'snorm16x2 'float16x2 'float32x2 'uint32x2 'sint32 + 'sint32x2) + 2) + ((or 'float32x3 'uint32x3 'sint32x3) 3) + ((or 'uint8x4 'sint8x4 'unorm8x4 'snorm8x4 'uint16x4 'sint16x4 + 'unorm16x4 'snorm16x4 'float16x4 'float32x4 'uint32x4 'sint32x4) + 4))) + (define (format-type format) + (match format + ((or 'uint8x2 'uint8x4) + (data-type unsigned-byte)) + ((or 'uint16x2 'uint16x4) + (data-type unsigned-short)) + ((or 'uint32 'uint32x2 'uint32x3 'uint32x4) + (data-type unsigned-int)) + ((or 'sint8x2 'sint8x4) + (data-type byte)) + ((or 'sint16x2 'sint16x4) + (data-type short)) + ((or 'sint32 'sint32x2 'sint32x3 'sint32x4) + (data-type int)) + ((or 'float16x2 'float16x4) + (oes-vertex-half-float half-float-oes)) + ((or 'float32 'float32x2 'float32x3 'float32x4 'unorm8x2 'unorm8x4 + 'snorm8x2 'snorm8x4 'unorm16x2 'unorm16x4 'snorm16x2 'snorm16x4) + (data-type float)))) + (define (format-normalized? format) + (match format + ((or 'uint8x2 'uint8x4 'sint8x2 'sint8x4 'uint16x2 'uint16x4 'sint16x2 + 'sint16x4 'float16x2 'float16x4 'float32 'float32x2 'float32x3 + 'float32x4 'uint32 'uint32x2 'uint32x3 'uint32x4 'sint32 'sint32x2 + 'sint32x3 'sint32x4) + #f) + ((or 'unorm8x2 'unorm8x4 'snorm8x2 'snorm8x4 'unorm16x2 'unorm16x4 + 'snorm16x2 'snorm16x4) + #t))) + (define vertex-attributes + (let* ((k (vector-length vertex-layout)) + (layout (make-vector k))) + (let loop ((i 0) (attr-count 0)) + (when (< i k) + (match (vector-ref vertex-layout i) + (($ <vertex-buffer-layout> stride step-mode attributes) + (let* ((k (vector-length attributes)) + (attrs (make-vector k))) + (do ((j 0 (+ j 1))) + ((= j k)) + (match (vector-ref attributes j) + (($ <vertex-attribute> format offset) + (vector-set! attrs j + (make-gl-vertex-attribute (+ attr-count j) + (format-component-count format) + (format-type format) + (format-normalized? format) + stride + (offset->pointer offset) + (and (eq? step-mode 'instance) 1)))))) + (vector-set! layout i attrs) + (loop (+ i 1) (+ attr-count k))))))) + layout)) + (define (blend-equation op) + (match op + ('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)))) + (define (blend-src-func func) + (match func + ('zero (blending-factor-src zero)) + ('one (blending-factor-src one)) + ('src-alpha (blending-factor-src src-alpha)) + ('one-minus-src-alpha (blending-factor-src one-minus-src-alpha)) + ('dst (blending-factor-src dst-color)) + ('one-minus-dst (blending-factor-src one-minus-dst-color)) + ('dst-alpha (blending-factor-src dst-alpha)) + ('one-minus-dst-alpha (blending-factor-src one-minus-dst-alpha)) + ('src-alpha-saturated (blending-factor-src src-alpha-saturate)) + ('constant (blending-factor-src constant-color-ext)) + ('one-minus-constant (blending-factor-src one-minus-constant-color-ext)))) + (define (blend-dst-func func) + (match func + ('zero (blending-factor-dest zero)) + ('one (blending-factor-dest one)) + ('src (blending-factor-dest src-alpha)) + ('one-minus-src (blending-factor-dest one-minus-src-color)) + ('src-alpha (blending-factor-dest src-alpha)) + ('one-minus-src-alpha (blending-factor-dest one-minus-src-alpha)) + ('dst-alpha (blending-factor-dest dst-alpha)) + ('one-minus-dst-alpha (blending-factor-dest one-minus-dst-alpha)) + ('constant (blending-factor-dest constant-color-ext)) + ('one-minus-constant (blending-factor-src one-minus-constant-color-ext)))) + (define (depth-func func) + (match func + ('never (depth-function never)) + ('less (depth-function less)) + ('equal (depth-function equal)) + ('less-equal (depth-function lequal)) + ('greater (depth-function greater)) + ('not-equal (depth-function notequal)) + ('greater-equal (depth-function gequal)) + ('always (depth-function always)))) + (define (stencil-op* op) + (match op + ('keep (stencil-op keep)) + ('zero (stencil-op zero)) + ('replace (stencil-op replace)) + ('invert (stencil-op invert)) + ('increment-clamp (stencil-op incr)) + ('decrement-clamp (stencil-op decr)) + ('increment-wrap (version-1-4 incr-wrap)) + ('decrement-wrap (version-1-4 decr-wrap)))) + (define (stencil-func func) + (match func + ('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)))) + (%make-gl-render-pipeline + shader + (match (primitive-mode-topology primitive) + ('point-list (begin-mode points)) + ('line-list (begin-mode lines)) + ('line-strip (begin-mode line-strip)) + ('triangle-list (begin-mode triangles)) + ('triangle-strip (begin-mode triangle-strip)) + ;; FIXME: Triangle fans are not supported by WebGPU. + ('triangle-fan (begin-mode triangle-fan))) + (match (primitive-mode-topology primitive) + ('point-list (polygon-mode point)) + ((or 'line-list 'line-strip) (polygon-mode line)) + ((or 'triangle-list 'triangle-strip 'triangle-fan) (polygon-mode fill))) + (match (primitive-mode-cull-face primitive) + (#f #f) + ('front (cull-face-mode front)) + ('back (cull-face-mode back))) + (match (primitive-mode-front-face primitive) + ('ccw (front-face-direction ccw)) + ('cw (front-face-direction cw))) + (color-target-format color-target) + (match (color-target-blend-mode color-target) + (#f #f) + (($ <blend-mode> + ($ <blend-component> op-rgb src-rgb dst-rgb) + ($ <blend-component> op-alpha src-alpha dst-alpha)) + (make-gl-blend-mode (make-gl-blend-op (blend-equation op-rgb) + (blend-equation op-alpha)) + (make-gl-blend-func (blend-src-func src-rgb) + (blend-src-func src-alpha) + (blend-dst-func dst-rgb) + (blend-dst-func dst-alpha))))) + (color-target-mask color-target) + (match depth+stencil + ((or #f ($ <depth+stencil> _ #f)) #f) + (($ <depth+stencil> _ ($ <depth-test> compare write?)) + (make-gl-depth-test (depth-func compare) write?))) + (match depth+stencil + ((or #f ($ <depth+stencil> _ _ #f #f)) #f) + (($ <depth+stencil> _ _ + ($ <stencil-face> compare-front fail-front depth-fail-front pass-front) + ($ <stencil-face> compare-back fail-back depth-fail-back pass-back) + read-mask write-mask) + (make-gl-stencil-test read-mask write-mask + (stencil-func compare-front) + (stencil-func compare-back) + (make-gl-stencil-op (stencil-op* fail-front) + (stencil-op* depth-fail-front) + (stencil-op* pass-front)) + (make-gl-stencil-op (stencil-op* fail-back) + (stencil-op* depth-fail-back) + (stencil-op* pass-back)))) + (($ <depth+stencil> _ _ + ($ <stencil-face> compare-front fail-front depth-fail-front pass-front) + #f read-mask write-mask) + (make-gl-stencil-test read-mask write-mask + (stencil-func compare-front) + (stencil-func 'never) + (make-gl-stencil-op (stencil-op* fail-front) + (stencil-op* depth-fail-front) + (stencil-op* pass-front)) + (make-gl-stencil-op (stencil-op* 'keep) + (stencil-op* 'keep) + (stencil-op* 'keep)))) + (($ <depth+stencil> _ _ #f + ($ <stencil-face> compare-back fail-back depth-fail-back pass-back) + read-mask write-mask) + (make-gl-stencil-test read-mask write-mask + (stencil-func 'never) + (stencil-func compare-back) + (make-gl-stencil-op (stencil-op* 'keep) + (stencil-op* 'keep) + (stencil-op* 'keep)) + (make-gl-stencil-op (stencil-op* fail-back) + (stencil-op* depth-fail-back) + (stencil-op* pass-back))))) + (match multisample + (#f #f) + ;; TODO: Figure out what to do with multisample settings. + (($ <multisample> count mask alpha-to-coverage?) + #f)) + vertex-attributes + binding-layout)) + +(define (destroy-gl-render-pipeline state pipeline) + ;; No GPU resources allocated, so nothing to do. + (values)) + + +;;; +;;; General GL state stuff +;;; + +(define (gl-state-init! state) + (let* ((verts (f32vector -1.0 -1.0 0.0 0.0 + +1.0 -1.0 1.0 0.0 + +1.0 +1.0 1.0 1.0 + -1.0 +1.0 0.0 1.0)) + (is (u32vector 0 2 3 0 1 2)) + (vlength (bytevector-length verts)) + (ilength (bytevector-length is)) + (vertices (make-gl-buffer state vlength '(vertex))) + (indices (make-gl-buffer state ilength '(index))) + (shader (make-gl-shader state + (lambda (lang) + (values " +#ifdef GLSL330 +layout (location = 0) in vec2 position; +layout (location = 1) in vec2 tex; +#elif defined(GLSL130) +in vec2 position; +in vec2 tex; +#elif defined(GLSL120) +attribute vec2 position; +attribute vec2 tex; +#endif +#ifdef GLSL120 +varying vec2 fragTex; +#else +out vec2 fragTex; +#endif + +void main(void) { + fragTex = tex; + gl_Position = vec4(position, 0.0, 1.0); +} +" " +#ifdef GLSL120 +varying vec2 fragTex; +#else +in vec2 fragTex; +#endif +#ifdef GLSL330 +out vec4 outFragColor; +#else +#define outFragColor gl_FragColor +#define texture texture2D +#endif + +uniform sampler2D sampler; + +void main (void) { + outFragColor = texture(sampler, fragTex); +} +"))))) + (write-gl-buffer state vertices 0 verts 0 vlength) + (write-gl-buffer state indices 0 is 0 ilength) + (set-gl-state-screen-vertices! state vertices) + (set-gl-state-screen-indices! state indices) + (set-gl-state-screen-shader! state shader))) + +(define (gl-state-guard state obj) + ((gl-state-guardian state) obj) + obj) + +(define (gl-state-gc state) + (let ((guardian (gl-state-guardian state))) + (let loop ((obj (guardian))) + (when obj + (match obj + ((? gl-buffer?) (destroy-gl-buffer state obj)) + ((? gl-texture?) (destroy-gl-texture state obj)) + ((? gl-texture-view?) (destroy-gl-texture-view state obj)) + ((? gl-sampler?) (destroy-gl-sampler state obj)) + ((? gl-shader?) (destroy-gl-shader state obj))) + (loop (guardian)))))) + +(define (swap-gl-state state view) + (set-gl-state-draw-framebuffer! state null-gl-framebuffer) + (set-gl-state-read-framebuffer! state null-gl-framebuffer) + (set-gl-state-buffer-index! state (gl-state-screen-indices state)) + (set-gl-state-buffer-vertex! state (gl-state-screen-vertices state)) + (set-gl-state-shader! state (gl-state-screen-shader state)) + (set-gl-state-texture! state 0 view) + (set-gl-state-sampler! state 0 null-gl-sampler) + (set-gl-state-blending! state #f) + (set-gl-state-scissor-test! state #f) + (set-gl-state-depth-test! state #f) + (set-gl-state-stencil-test! state #f) + (set-gl-state-face-culling! state #t) + (set-gl-state-cull-face! state (cull-face-mode back)) + (set-gl-state-front-face! state (front-face-direction ccw)) + (set-gl-state-color-mask! state %default-color-mask) + (gl-enable-vertex-attrib-array 0) + (gl-vertex-attrib-pointer 0 2 (data-type float) #f 16 (offset->pointer 0)) + (gl-enable-vertex-attrib-array 1) + (gl-vertex-attrib-pointer 1 2 (data-type float) #f 16 (offset->pointer 8)) + (gl-draw-elements (begin-mode triangles) 6 (data-type unsigned-int) %null-pointer) + ((gl-state-swap state))) + +(define (gl-state-begin-frame state) + (set-gl-state-draw-framebuffer! state null-gl-framebuffer) + (set-gl-state-read-framebuffer! state null-gl-framebuffer)) + +(define (gl-state-end-frame state view) + (swap-gl-state state view) + (gl-state-gc state)) + +(define offset->pointer + (let ((cache (make-hash-table))) + (define (offset->pointer offset) + (if (eq? offset 0) + %null-pointer + (or (hashv-ref cache offset) + (let ((ptr (make-pointer offset))) + (hashv-set! cache offset ptr) + ptr)))) + offset->pointer)) + +(define (gl-begin-render-pass state cmd) + (match cmd + (($ <begin-render-pass-command> pass colors depth+stencil) + (let ((fbo (gl-state-framebuffer-build state pass colors depth+stencil))) + (set-gl-state-draw-framebuffer! state fbo) + ;; Disable scissor test so gl-clear will clear the entire + ;; framebuffer. + (set-gl-state-scissor-test! state #f) + ;; Clear all attachments that have a load op of 'clear'. + (let loop ((i 0)) + (when (< i (vector-length colors)) + (match (vector-ref colors i) + (#(#f _ _) #f) + (#(view resolve-target ($ <color-operation> clear-color 'clear)) + (set-gl-state-color-mask! state %default-color-mask) + (set-gl-state-clear-color! state clear-color) + ;; FIXME: Need to use glDrawBuffers for multiple color attachments. + (gl-draw-buffer (+ (version-3-0 color-attachment0) i)) + (gl-clear (clear-buffer-mask color-buffer)) + (loop (1+ i))) + (_ (loop (1+ i)))))) + (match depth+stencil + (#(#f _ _) #f) + (#(view depth-op stencil-op) + (match depth-op + (($ <depth-operation> clear-value 'clear) + (set-gl-state-depth-write! state #t) + (set-gl-state-clear-depth! state clear-value) + (gl-clear (clear-buffer-mask depth-buffer))) + (_ #t)) + (match stencil-op + (($ <stencil-operation> clear-value 'clear) + (set-gl-state-stencil-write-mask! state #xff) + (set-gl-state-clear-stencil! state clear-value) + (gl-clear (clear-buffer-mask stencil-buffer))) + (_ #t)))))))) + +(define (gl-end-render-pass state) + ;;(set-gl-state-render-pass! state #f) + #t) + +(define (gl-state-draw state cmd) + (match cmd + (($ <draw-command> + ($ <gl-render-pipeline> shader begin-mode polygon-mode cull-face + front-face color-format blend-mode color-mask depth-test + stencil-test multisample vattrs binding-layout) + pass viewport scissor blend-constant stencil-reference + start count instances index-buffer vertex-buffers bindings) + (set-gl-state-draw-framebuffer! state (gl-state-framebuffer-ref state pass)) + (set-gl-state-viewport! state viewport) + (match scissor + (#f (set-gl-state-scissor-test! state #f)) + (_ + (set-gl-state-scissor-test! state #t) + (set-gl-state-scissor-rect! state scissor))) + (set-gl-state-shader! state shader) + (set-gl-state-polygon-mode! state polygon-mode) + (set-gl-state-front-face! state front-face) + (set-gl-state-color-mask! state color-mask) + (match cull-face + (#f (set-gl-state-face-culling! state #f)) + (face + (set-gl-state-face-culling! state #t) + (set-gl-state-cull-face! state face))) + (match blend-mode + (#f (set-gl-state-blending! state #f)) + (($ <gl-blend-mode> op func) + (set-gl-state-blending! state #t) + (set-gl-state-blend-op! state op) + (set-gl-state-blend-func! state func) + (set-gl-state-blend-constant! state blend-constant))) + (match depth-test + (#f (set-gl-state-depth-test! state #f)) + (($ <gl-depth-test> func write?) + (set-gl-state-depth-test! state #t) + (set-gl-state-depth-func! state func) + (set-gl-state-depth-write! state write?) + (match viewport + (($ <viewport> _ _ _ _ depth-near depth-far) + (set-gl-state-depth-range! state depth-near depth-far))))) + (match stencil-test + (#f (set-gl-state-stencil-test! state #f)) + (($ <gl-stencil-test> read-mask write-mask func-front func-back + op-front op-back) + (set-gl-state-stencil-test! state #t) + (set-gl-state-stencil-write-mask! state write-mask) + (set-gl-state-stencil-op-front! state op-front) + (set-gl-state-stencil-op-front! state op-back) + (set-gl-state-stencil-func-front! state func-front stencil-reference + read-mask) + (set-gl-state-stencil-func-back! state func-back stencil-reference + read-mask))) + ;; TODO: Setup multisample state. + ;; Setup vertex attributes. + (do ((i 0 (+ i 1))) + ((= i (vector-length vattrs))) + (let ((attrs (vector-ref vattrs i))) + (set-gl-state-buffer-vertex! state (vector-ref vertex-buffers i)) + (do ((j 0 (+ j 1))) + ((= j (vector-length attrs))) + (match (vector-ref attrs j) + (($ <gl-vertex-attribute> index size type normalized? stride + pointer divisor) + (gl-enable-vertex-attrib-array index) + (gl-vertex-attrib-pointer index size type normalized? stride pointer) + (when divisor + (gl-vertex-attrib-divisor index divisor))))))) + ;; Setup textures, samplers, and uniforms. + ;; + ;; Lots of loop variables here: + ;; i: bindings vector index, the main loop iterator + ;; s: current sampler unit + ;; t: current texture unit + ;; l: current shader location, used for sampler bindings + ;; b: current uniform block index, used for uniform buffer bindings + (let loop ((i 0) (s 0) (t 0) (l 0) (b 0)) + (when (< i (vector-length binding-layout)) + (match (vector-ref binding-layout i) + (($ <texture-layout> sample-type dimension multisample?) + (match (vector-ref bindings i) + (#f (set-gl-state-texture! state t null-gl-texture)) + ((? gl-texture-view? view) + (set-gl-state-texture! state t view)) + (obj (error "expected texture view binding" i obj))) + (loop (+ i 1) s (+ t 1) l b)) + (($ <sampler-layout> type) + (match (vector-ref bindings i) + (#f (set-gl-state-sampler! state t null-gl-sampler)) + ((? gl-sampler? sampler) + (set-gl-state-sampler! state s sampler)) + (obj (error "expected sampler binding" i obj))) + ;; A sampler binding uses 1 shader location. + (gl-uniform1i l s) + (loop (+ i 1) (+ s 1) t (+ l 1) b)) + (($ <buffer-layout> type min-size) + ;; A uniform buffer binding uses one uniform block binding + ;; point. + (match (vector-ref bindings i) + ((? gl-buffer? buffer) + (set-gl-state-buffer-uniform! state b buffer)) + (obj (error "expected uniform buffer binding" obj))) + (loop (+ i 1) s t l (+ b 1)))))) + (if instances + (cond + ;; Instanced + indexed + (index-buffer + (set-gl-state-buffer-index! state index-buffer) + (gl-draw-elements-instanced begin-mode count + (data-type unsigned-int) + (offset->pointer (* start 4)) + instances)) + ;; Instanced + unindexed + (else + (gl-draw-arrays-instanced begin-mode start count instances))) + (cond + ;; Uninstanced + indexed + (index-buffer + (set-gl-state-buffer-index! state index-buffer) + (gl-draw-elements begin-mode count + (data-type unsigned-int) + (offset->pointer (* start 4)))) + ;; Uninstanced + unindexed + (else (gl-draw-arrays begin-mode start count))))))) + +(define (gl-state-submit state cmd) + (cond + ((draw-command? cmd) + (gl-state-draw state cmd)) + ((begin-render-pass-command? cmd) + (gl-begin-render-pass state cmd)) + ((end-render-pass-command? cmd) + (gl-end-render-pass state)))) + + +;;; +;;; OpenGL backend +;;; + +(define (make-opengl-gpu gl-context swap init-width init-height) + (define (parse-version str) + (match (string-split str #\space) + ((version . _) version))) + (let* ((gl-version (gl-get-string (string-name version))) + (glsl-version (gl-get-string (version-2-0 shading-language-version))) + (vendor (gl-get-string (string-name vendor))) + (renderer (gl-get-string (string-name renderer))) + (extensions + (let ((table (make-hash-table))) + (for-each (lambda (name) + (hash-set! table name #t)) + (string-split (gl-get-string (string-name extensions)) + #\space)) + table)) + (max-texture-size + (gl-get-integer (get-p-name max-texture-size))) + (max-3d-texture-size + (gl-get-integer (version-1-2 max-3d-texture-size))) + (max-array-texture-layers + (gl-get-integer (version-3-0 max-array-texture-layers))) + (max-textures + (gl-get-integer (version-2-0 max-combined-texture-image-units))) + (max-ubos + (gl-get-integer (version-3-1 max-uniform-buffer-bindings))) + (max-uniform-block-size + (gl-get-integer (version-3-1 max-uniform-block-size))) + (max-vertex-attrib-bindings + (gl-get-integer (arb-vertex-attrib-binding max-vertex-attrib-bindings))) + (max-vertex-attribs + (gl-get-integer (version-2-0 max-vertex-attribs))) + (max-varying-components + (gl-get-integer (version-3-0 max-varying-components))) + (max-varying-vectors + (gl-get-integer (arb-es2-compatibility max-varying-vectors))) + (max-color-attachments + (gl-get-integer (version-3-0 max-color-attachments))) + (limits + (make-gpu-limits #:max-texture-dimension-1d max-texture-size + #:max-texture-dimension-2d max-texture-size + #:max-texture-dimension-3d max-3d-texture-size + #:max-texture-array-layers max-array-texture-layers + #:max-sampled-textures-per-shader-stage max-textures + #:max-samplers-per-shader-stage max-textures + #:max-uniform-buffers-per-shader-stage max-ubos + #:max-uniform-buffer-binding-size max-uniform-block-size + #:max-bindings 128 + #:max-vertex-buffers max-vertex-attrib-bindings + #:max-buffer-size (* 2 1024 1024 1024) ; 2 GiB + #:max-vertex-attributes (* max-vertex-attrib-bindings + max-vertex-attribs) + #:max-vertex-buffer-array-stride 2048 + #:max-inter-stage-shader-components max-varying-components + #:max-inter-stage-shader-variables max-varying-vectors + #:max-color-attachments max-color-attachments)) + (gl-state + (%make-gl-state gl-context swap + (make-guardian) + gl-version + (parse-version glsl-version) + vendor renderer + limits + (hash-ref extensions "GL_ARB_texture_view") + (hash-ref extensions "GL_ARB_sampler_objects") + (hash-ref extensions "GL_ARB_uniform_buffer_object") + #f ; blending + #f ; face culling + #f ; depth test + #f ; stencil test + #f ; scissor test + (make-viewport 0 0 init-width init-height) + (make-scissor-rect 0 0 init-width init-height) + (polygon-mode fill) + (cull-face-mode back) + (front-face-direction ccw) + (make-gl-blend-op (blend-equation-mode-ext func-add-ext) + (blend-equation-mode-ext func-add-ext)) + (make-gl-blend-func (blending-factor-src one) + (blending-factor-dest zero) + (blending-factor-src one) + (blending-factor-dest zero)) + %default-color-mask + (depth-function less) + #t ; depth write + (f64vector 0.0 1.0) ; depth range + #xffffFFFF ; stencil write mask + ;; front/back stencil funcs + (vector (stencil-function always) 0 #xffffFFFF) + (vector (stencil-function always) 0 #xffffFFFF) + (make-gl-stencil-op (stencil-op keep) + (stencil-op keep) + (stencil-op keep)) + (make-gl-stencil-op (stencil-op keep) + (stencil-op keep) + (stencil-op keep)) + (make-color 0.0 0.0 0.0 0.0) ; clear color + 1 ; clear depth + 0 ; clear stencil + null-gl-buffer + null-gl-buffer + null-gl-buffer + null-gl-buffer + (make-vector max-ubos null-gl-buffer) + (make-vector max-textures null-gl-texture) + (make-vector max-textures null-gl-sampler) + null-gl-shader + null-gl-framebuffer + null-gl-framebuffer + 'default ; mode + (make-weak-key-hash-table)))) + (gl-state-init! gl-state) + ;; Enable seamless cubemaps. There's never a need to disable it + ;; so we don't need to track it in the GL state object. It only + ;; makes things better for skyboxes and such. Some old hardware + ;; might not support it, in which case this does nothign. + (gl-enable (arb-seamless-cube-map texture-cube-map-seamless)) + (make-gpu "OpenGL" + ;; Helpful description of driver details. + (string-append "OpenGL version " (gl-state-gl-version gl-state) + ", GLSL version " (gl-state-glsl-version gl-state) + ", vendor: " (gl-state-vendor gl-state) + ", renderer: " (gl-state-renderer gl-state)) + gl-state + #:limits limits + #:begin-frame gl-state-begin-frame + #:end-frame gl-state-end-frame + #:make-buffer make-gl-buffer + #:destroy-buffer destroy-gl-buffer + #:map-buffer map-gl-buffer + #:unmap-buffer unmap-gl-buffer + #:write-buffer write-gl-buffer + #:make-texture make-gl-texture + #:destroy-texture destroy-gl-texture + #:write-texture write-gl-texture + #:make-texture-view make-gl-texture-view + #:destroy-texture-view destroy-gl-texture-view + #:make-sampler make-gl-sampler + #:destroy-sampler destroy-gl-sampler + #:make-shader make-gl-shader + #:destroy-shader destroy-gl-shader + #:make-render-pipeline make-gl-render-pipeline + #:destroy-render-pipeline destroy-gl-render-pipeline + #:submit gl-state-submit))) diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm index 625a9e0..050433f 100644 --- a/chickadee/graphics/buffer.scm +++ b/chickadee/graphics/buffer.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016-2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2016-2023 David Thompson <dthompson2@worcester.edu> ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. @@ -20,6 +20,10 @@ ;;; Code: (define-module (chickadee graphics buffer) + #:use-module (chickadee data bytestruct) + #:use-module ((chickadee graphics backend) #:prefix gpu:) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (rnrs bytevectors) @@ -27,56 +31,38 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module (gl) #:use-module (system foreign) - #:use-module (chickadee math matrix) - #:use-module (chickadee math vector) - #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) #:export (make-buffer + destroy-buffer buffer? - index-buffer? + buffer-available? + buffer-destroyed? buffer-mapped? - buffer-name buffer-length - buffer-stride - buffer-target buffer-usage - buffer-data - null-buffer - g:buffer - current-buffer - map-buffer! - unmap-buffer! - resize-buffer! - - make-vertex-attribute - vertex-attribute? - vertex-attribute->buffer - vertex-attribute-name - vertex-attribute-offset - vertex-attribute-component-type - vertex-attribute-normalized? - vertex-attribute-length - vertex-attribute-type - vertex-attribute-data - vertex-attribute-divisor - - make-vertex-array - vertex-array? - vertex-array-indices - vertex-array-attributes - vertex-array-mode - null-vertex-array - g:vertex-array - current-vertex-array - render-vertices - render-vertices/instanced + buffer-write! + map-buffer + unmap-buffer + bytevector->buffer + + make-dbuffer + dbuffer? + dbuffer-mapped? + dbuffer-buffer + dbuffer-capacity + dbuffer-length + dbuffer-clear! + dbuffer-map! + dbuffer-unmap! + dbuffer-reserve! + dbuffer-pack! + dbuffer-append! + dbuffer-pack-indices-quad! + dbuffer-append-indices-quad! make-dynamic-buffer dynamic-buffer? - dynamic-buffer->buffer + dynamic-buffer-buffer dynamic-buffer-data dynamic-buffer-capacity dynamic-buffer-count @@ -93,7 +79,8 @@ make-geometry geometry? - geometry-vertex-array + geometry-vertex-buffers + geometry-index-buffer geometry-vertex-count geometry-index-count geometry-begin! @@ -106,460 +93,102 @@ geometry-index-append! geometry-import!)) -;;; -;;; Vertex Buffers -;;; - (define-record-type <buffer> - (%make-buffer id name length stride target usage data stream-cache) + (%make-buffer gpu handle name length usage state map-state) buffer? - (id buffer-id) + (gpu buffer-gpu) + (handle buffer-handle) (name buffer-name) - (length buffer-length set-buffer-length!) - (stride buffer-stride) - (target buffer-target) + (length buffer-length) (usage buffer-usage) - (data buffer-data set-buffer-data!) - (stream-cache buffer-stream-cache)) + (state buffer-state set-buffer-state!) + (map-state buffer-map-state set-buffer-map-state!) + (mapping buffer-mapping set-buffer-mapping!)) (define (print-buffer buffer port) - (format port - "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>" - (buffer-id buffer) - (buffer-name buffer) - (buffer-usage buffer) - (buffer-target buffer) - (buffer-length buffer) - (buffer-stride buffer))) + (match buffer + (($ <buffer> _ _ name length usage _) + (format #t "#<buffer name: ~s length: ~s usage: ~s>" + name length usage)))) (set-record-type-printer! <buffer> print-buffer) -(define null-buffer - (%make-buffer 0 "null" 0 0 'vertex 'static #f #f)) - -(define (free-buffer buffer) - (gl-delete-buffers 1 (u32vector (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) - (let ((bv (u32vector 1))) - (gl-gen-buffers 1 (bytevector->pointer bv)) - (u32vector-ref bv 0))) - -(define (index-buffer? buffer) - "Return #t if VIEW is an index buffer view." - (eq? (buffer-target buffer) 'index)) - -(define (buffer-usage-gl buffer) - (case (buffer-usage buffer) - ((static) - (version-1-5 static-draw)) - ((stream) - (version-1-5 stream-draw)))) - -(define (buffer-target-gl buffer) - (if (index-buffer? buffer) - (version-1-5 element-array-buffer) - (version-1-5 array-buffer))) - -(define* (make-buffer data #:key - (name "anonymous") - (length (if data (bytevector-length data) 0)) - (offset 0) - (stride 0) - (target 'vertex) - (usage 'static)) - "Upload DATA, a bytevector, to the GPU. By default, the entire -bytevector is uploaded. A subset of the data may be uploaded by -specifying the OFFSET, the index of the first byte to be uploaded, and -LENGTH, the number of bytes to upload. - -If DATA is #f, allocate LENGTH bytes of fresh GPU memory instead. - -TARGET and USAGE are hints that tell the GPU how the buffer is -intended to be used. - -TARGET may be: -- vertex: Vertex attribute data. -- index: Index buffer data. - -USAGE may be: -- static: The buffer data will not be modified after creation. -- stream: The buffer data will be modified frequently. - -NAME is simply an arbitrary string for debugging purposes that is -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 - (and (eq? usage 'stream) - (make-hash-table))))) - (graphics-engine-guard! buffer) - (with-graphics-state! ((g:buffer buffer)) - (gl-buffer-data (buffer-target-gl buffer) - length - (if data - (bytevector->pointer data offset) - %null-pointer) - (buffer-usage-gl buffer))) - buffer))) +(define (buffer-available? buffer) + (eq? (buffer-state buffer) 'available)) -(define (buffer-mapped? buffer) - "Return #t if buffer data has been mapped from GPU." - (if (buffer-data buffer) #t #f)) - -;; For streaming buffers, we use buffer re-specification to achieve -;; 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. -(define (pointer->bytevector/cached buffer pointer length) - (let* ((cache (buffer-stream-cache buffer)) - (address (pointer-address pointer)) - (cached (hashv-ref cache address))) - (if (and cached (= (bytevector-length cached) length)) - cached - (let ((bv (pointer->bytevector pointer length))) - (hashv-set! cache address bv) - bv)))) - -(define* (map-buffer! buffer #:optional (mode 'read-write)) - "Map the memory space for BUFFER from the GPU to the CPU, allowing -the vertex buffer to be updated with new vertex data. The -'unmap-buffer!' procedure must be called to submit the new -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)) - (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 - (gl-buffer-data target length %null-pointer (buffer-usage-gl buffer))) - (let* ((ptr (gl-map-buffer target - (case mode - ((read-write) - (version-1-5 read-write)) - ((read-only) - (version-1-5 read-only)) - ((write-only) - (version-1-5 write-only))))) - (bv (pointer->bytevector/cached buffer ptr length))) - (set-buffer-data! buffer bv)))))) - -(define (unmap-buffer! buffer) - "Return the mapped vertex buffer data for BUFFER to the GPU." - (with-graphics-state! ((g:buffer buffer)) - (gl-unmap-buffer (buffer-target-gl buffer)) - (set-buffer-data! buffer #f))) - -(define (resize-buffer! buffer length) - "Resize BUFFER to LENGTH bytes, preserving all existing mapped data -that that fits into the resized buffer. Only streaming buffers can be -resized." - (if (eq? (buffer-usage buffer) 'stream) - ;; Remap the buffer and copy old contents - (let ((old-bv (buffer-data buffer))) - (set-buffer-length! buffer length) - (when old-bv - ;; Need to make a copy of the data. - (let ((old-bv (bytevector-copy old-bv))) - (unmap-buffer! buffer) - ;; TODO: Set map mode in record - (map-buffer! buffer 'write-only) - (let ((new-bv (buffer-data buffer))) - (bytevector-copy! old-bv 0 new-bv 0 - (min (bytevector-length old-bv) - (bytevector-length new-bv))))))) - (error "cannot resize static buffer"))) +(define (buffer-destroyed? buffer) + (eq? (buffer-state buffer) 'destroyed)) - -;;; -;;; Vertex Attributes -;;; - -(define (type-size type) - (case type - ((scalar) 1) - ((vec2) 2) - ((vec3) 3) - ((color vec4 mat2) 4) - ((mat3) 9) - ((mat4) 16))) - -(define (component-type-size component-type) - (case component-type - ((byte) 1) - ((unsigned-byte) 1) - ((short) 2) - ((unsigned-short) 2) - ((int) 4) - ((unsigned-int) 4) - ((float) 4) - ((double) 8))) - -(define-record-type <vertex-attribute> - (%make-vertex-attribute name buffer offset offset-pointer component-type - normalized? length type divisor) - vertex-attribute? - (name vertex-attribute-name) - (buffer vertex-attribute->buffer) - (offset vertex-attribute-offset) - (offset-pointer vertex-attribute-offset-pointer) - (component-type vertex-attribute-component-type) - (normalized? vertex-attribute-normalized?) - (length vertex-attribute-length) - (type vertex-attribute-type) - (divisor vertex-attribute-divisor)) ; for instanced rendering - -(define (vertex-attribute-stride vertex-attribute) - (or (buffer-stride (vertex-attribute->buffer vertex-attribute)) - (* (type-size (vertex-attribute-type vertex-attribute)) - (component-type-size (vertex-attribute-component-type vertex-attribute))))) - -(define (num-elements byte-length byte-offset type component-type) - (inexact->exact - (floor - (/ (- byte-length byte-offset) - (* (component-type-size component-type) - (type-size type)))))) - -(define* (make-vertex-attribute #:key - (name "anonymous") - buffer - type - component-type - normalized? - (offset 0) - (length (num-elements (buffer-length buffer) - offset - type - component-type)) - (divisor 0)) - "Return a new typed buffer view for BUFFER starting at byte index -OFFSET of LENGTH elements, where each element is of TYPE and composed -of COMPONENT-TYPE values. - -Valid values for TYPE are: -- scalar: single number -- vec2: 2D vector -- vec3: 3D vector -- vec4: 4D vector -- color: RGBA color -- mat2: 2x2 matrix -- mat3: 3x3 matrix -- mat4: 4x4 matrix - -Valid values for COMPONENT-TYPE are: - -- byte -- unsigned-byte -- short -- unsigned-short -- int -- unsigned-int -- float -- double - -DIVISOR is only needed for instanced rendering applications and -represents how many instances each vertex element applies to. A -divisor of 0 means that a single element is used for every instance -and is used for the data being instanced. A divisor of 1 means that -each element is used for 1 instance. A divisor of 2 means that each -element is used for 2 instances, and so on." - (let ((offset-ptr (make-pointer offset))) - (%make-vertex-attribute name buffer offset offset-ptr component-type - normalized? length type divisor))) - -(define (display-vertex-attribute vertex-attribute port) - (format port "#<vertex-attribute name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d divisor: ~d>" - (vertex-attribute-name vertex-attribute) - (vertex-attribute->buffer vertex-attribute) - (vertex-attribute-type vertex-attribute) - (vertex-attribute-component-type vertex-attribute) - (vertex-attribute-length vertex-attribute) - (vertex-attribute-offset vertex-attribute) - (vertex-attribute-divisor vertex-attribute))) - -(set-record-type-printer! <vertex-attribute> display-vertex-attribute) - -(define (vertex-attribute-type-size vertex-attribute) - (type-size (vertex-attribute-type vertex-attribute))) - -(define (vertex-attribute-data vertex-attribute) - (buffer-data (vertex-attribute->buffer vertex-attribute))) - -(define (vertex-attribute-type-gl vertex-attribute) - (case (vertex-attribute-component-type vertex-attribute) - ((byte) (data-type byte)) - ((unsigned-byte) (data-type unsigned-byte)) - ((short) (data-type short)) - ((unsigned-short) (data-type unsigned-short)) - ((int) (data-type int)) - ((unsigned-int) (data-type unsigned-int)) - ((float) (data-type float)) - ((double) (data-type double)))) - -(define (apply-vertex-attribute vertex-attribute attribute-index) - (with-graphics-state! ((g:buffer (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 - (gl-enable-vertex-attrib-array attribute-index) - (gl-vertex-attrib-pointer attribute-index - (vertex-attribute-type-size vertex-attribute) - (vertex-attribute-type-gl vertex-attribute) - (vertex-attribute-normalized? vertex-attribute) - (vertex-attribute-stride vertex-attribute) - (vertex-attribute-offset-pointer vertex-attribute)) - (let ((divisor (vertex-attribute-divisor vertex-attribute))) - (when divisor - (gl-vertex-attrib-divisor attribute-index divisor)))))) - - -;;; -;;; Vertex Arrays -;;; - -(define-record-type <vertex-array> - (%make-vertex-array id indices attributes mode) - vertex-array? - (id vertex-array-id) - (indices vertex-array-indices) - (attributes vertex-array-attributes) - (mode vertex-array-mode)) - -(set-record-type-printer! <vertex-array> - (lambda (array port) - (format port - "#<vertex-array indices: ~a attributes: ~a mode: ~s>" - (vertex-array-indices array) - (vertex-array-attributes array) - (vertex-array-mode array)))) - -(define null-vertex-array (%make-vertex-array 0 #f '() 'triangles)) - -(define (generate-vertex-array) - (let ((bv (u32vector 1))) - (gl-gen-vertex-arrays 1 (bytevector->pointer bv)) - (u32vector-ref bv 0))) - -(define (free-vertex-array va) - (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va)))) - -(define (apply-vertex-array va) - (gl-bind-vertex-array (vertex-array-id va))) - -(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 -alist mapping shader attribute indices to typed buffers containing -vertex data. - -By default, the vertex array is interpreted as containing a series of -triangles. If another primtive type is desired, the MODE keyword -argument may be overridden. The following values are supported: - -- points -- lines -- line-loop -- line-strip -- triangles -- triangle-strip -- triangle-fan" - (assert-current-graphics-engine) - (let ((array (%make-vertex-array (generate-vertex-array) - indices - attributes - mode))) - (graphics-engine-guard! array) - (with-graphics-state! ((g:vertex-array 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)) - -(define (vertex-array-mode-gl array) - (case (vertex-array-mode array) - ((points) (begin-mode points)) - ((lines) (begin-mode lines)) - ((line-loop) (begin-mode line-loop)) - ((line-strip) (begin-mode line-strip)) - ((triangles) (begin-mode triangles)) - ((triangle-strip) (begin-mode triangle-strip)) - ((triangle-fan) (begin-mode triangle-fan)))) - -(define (render-vertices array count offset) - (with-graphics-state! ((g:vertex-array array)) - (let ((indices (vertex-array-indices array))) - (if indices - (begin - (apply-vertex-attribute indices #f) - (gl-draw-elements (vertex-array-mode-gl array) - (or count - (vertex-attribute-length indices)) - (vertex-attribute-type-gl indices) - (vertex-attribute-offset-pointer indices))) - (gl-draw-arrays (vertex-array-mode-gl array) - offset - (or count - (vertex-attribute-length - (assv-ref (vertex-array-attributes array) - 0)))))))) - -(define (render-vertices/instanced array instances count offset) - (with-graphics-state! ((g:vertex-array array)) - (let ((indices (vertex-array-indices array))) - (if indices - (begin - (apply-vertex-attribute indices #f) - (gl-draw-elements-instanced (vertex-array-mode-gl array) - (or count - (vertex-attribute-length indices)) - (vertex-attribute-type-gl indices) - (vertex-attribute-offset-pointer indices) - instances)) - (gl-draw-arrays-instanced (vertex-array-mode-gl array) - offset count instances))))) +(define (buffer-mapped? buffer) + (eq? (buffer-map-state buffer) 'mapped)) + +;; TODO: Validate length is > 0 and < max length. +;; TODO: Validate usage flags. +(define* (make-buffer length #:key name (usage '(vertex))) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-buffer gpu length usage))) + (%make-buffer gpu handle name length usage 'available 'unmapped))) + +;; TODO: Ensure buffer is unmapped first. +(define (destroy-buffer buffer) + (unless (buffer-destroyed? buffer) + (gpu:destroy-buffer (buffer-gpu buffer) (buffer-handle buffer)) + (set-buffer-state! buffer 'destroyed))) + +(define (write-buffer buffer at data start length) + (gpu:write-buffer (buffer-gpu buffer) (buffer-handle buffer) + 0 data 0 length)) + +(define (map-buffer buffer mode offset length) + (let ((bv (gpu:map-buffer (buffer-gpu buffer) (buffer-handle buffer) + mode offset length))) + (set-buffer-mapping! buffer bv) + (set-buffer-map-state! buffer 'mapped) + bv)) + +(define (unmap-buffer buffer) + (when (buffer-mapped? buffer) + (gpu:unmap-buffer (buffer-gpu buffer) (buffer-handle buffer)) + (set-buffer-mapping! buffer #f))) + +(define* (bytevector->buffer data #:key name (usage '(vertex))) + (let* ((length (bytevector-length data)) + (buffer (make-buffer length #:name name #:usage usage))) + (write-buffer buffer 0 data 0 length) + buffer)) + +;; (define (render-vertices array count offset) +;; (with-graphics-state! ((g:vertex-array array)) +;; (let ((indices (vertex-array-indices array))) +;; (if indices +;; (begin +;; (apply-vertex-attribute indices #f) +;; (gl-draw-elements (vertex-array-mode-gl array) +;; (or count +;; (vertex-attribute-length indices)) +;; (vertex-attribute-type-gl indices) +;; (vertex-attribute-offset-pointer indices))) +;; (gl-draw-arrays (vertex-array-mode-gl array) +;; offset +;; (or count +;; (vertex-attribute-length +;; (assv-ref (vertex-array-attributes array) +;; 0)))))))) + +;; (define (render-vertices/instanced array instances count offset) +;; (with-graphics-state! ((g:vertex-array array)) +;; (let ((indices (vertex-array-indices array))) +;; (if indices +;; (begin +;; (apply-vertex-attribute indices #f) +;; (gl-draw-elements-instanced (vertex-array-mode-gl array) +;; (or count +;; (vertex-attribute-length indices)) +;; (vertex-attribute-type-gl indices) +;; (vertex-attribute-offset-pointer indices) +;; instances)) +;; (gl-draw-arrays-instanced (vertex-array-mode-gl array) +;; offset count instances))))) ;;; @@ -569,33 +198,39 @@ argument may be overridden. The following values are supported: ;; A layer on top of vertex buffers to handle buffer streaming with ;; dynamic buffer expansion. (define-record-type <dynamic-buffer> - (%make-dynamic-buffer buffer capacity count) + (%make-dynamic-buffer buffer stride capacity count) dynamic-buffer? - (buffer dynamic-buffer->buffer) + (buffer dynamic-buffer-buffer set-dynamic-buffer-buffer!) + (stride dynamic-buffer-stride) (data dynamic-buffer-data set-dynamic-buffer-data!) (capacity dynamic-buffer-capacity set-dynamic-buffer-capacity!) (count dynamic-buffer-count set-dynamic-buffer-count!)) -(define* (make-dynamic-buffer #:key name capacity stride usage (target 'vertex)) - (let* ((buffer (make-buffer #f +(define* (make-dynamic-buffer #:key name capacity stride (usage '(vertex))) + (let* ((buffer (make-buffer (* capacity stride) #:name name - #:length (* capacity stride) - #:stride stride - #:usage usage - #:target target))) - (%make-dynamic-buffer buffer capacity 0))) + #:usage usage))) + (%make-dynamic-buffer buffer stride capacity 0))) (define-inlinable (dynamic-buffer-bounds-check dbuffer i) (unless (< i (dynamic-buffer-count dbuffer)) (error "index out of bounds" i))) (define (expand-dynamic-buffer dbuffer) - (let ((new-capacity (inexact->exact - (round (* (dynamic-buffer-capacity dbuffer) 1.5)))) - (buffer (dynamic-buffer->buffer dbuffer))) - (resize-buffer! buffer (* new-capacity (buffer-stride buffer))) - (set-dynamic-buffer-capacity! dbuffer new-capacity) - (set-dynamic-buffer-data! dbuffer (buffer-data buffer)))) + (match dbuffer + (($ <dynamic-buffer> old-buffer stride old-data old-capacity count) + (let* ((new-capacity (* old-capacity 2)) + (new-length (* new-capacity stride)) + (new-buffer (make-buffer new-length + #:name (buffer-name old-buffer) + #:usage (buffer-usage old-buffer)))) + (set-dynamic-buffer-buffer! dbuffer new-buffer) + (set-dynamic-buffer-capacity! dbuffer new-capacity) + (when old-data + (unmap-buffer old-buffer) + (let ((new-data (map-buffer new-buffer 'write 0 new-length))) + (bytevector-copy! old-data 0 new-data 0 (bytevector-length old-data)) + (set-dynamic-buffer-data! dbuffer new-data))))))) (define-inlinable (dynamic-buffer-next! dbuffer n) (let ((count (dynamic-buffer-count dbuffer))) @@ -611,20 +246,17 @@ argument may be overridden. The following values are supported: (set-dynamic-buffer-count! dbuffer 0)) (define (dynamic-buffer-map! dbuffer) - (let ((buffer (dynamic-buffer->buffer dbuffer))) - (dynamic-buffer-clear! dbuffer) - (map-buffer! buffer 'write-only) - ;; Stashing the bytevector here turns out to be a *huge* performance - ;; booster. Probably because it's avoiding another layer of record - ;; type checks and stuff? I dunno. - (set-dynamic-buffer-data! dbuffer (buffer-data buffer)))) + (dynamic-buffer-clear! dbuffer) + (let* ((buffer (dynamic-buffer-buffer dbuffer)) + (bv (map-buffer buffer 'write 0 (buffer-length buffer)))) + (set-dynamic-buffer-data! dbuffer bv))) (define (dynamic-buffer-unmap! dbuffer) - (unmap-buffer! (dynamic-buffer->buffer dbuffer)) + (unmap-buffer (dynamic-buffer-buffer dbuffer)) (set-dynamic-buffer-data! dbuffer #f)) (define (dynamic-buffer-import! dbuffer bv start end) - (let ((stride (buffer-stride (dynamic-buffer->buffer dbuffer))) + (let ((stride (dynamic-buffer-stride dbuffer)) (copy-count (- end start))) (let resize () (let ((capacity (dynamic-buffer-capacity dbuffer))) @@ -641,15 +273,97 @@ argument may be overridden. The following values are supported: ;;; +;;; Builder??? +;;; + +(define-record-type <dbuffer> + (%make-dbuffer buffer capacity length) + dbuffer? + (buffer dbuffer-buffer set-dbuffer-buffer!) + (data dbuffer-data set-dbuffer-data!) + (capacity dbuffer-capacity set-dbuffer-capacity!) + (length dbuffer-length set-dbuffer-length!)) + +(define (dbuffer-mapped? dbuffer) + (bytevector? (dbuffer-data dbuffer))) + +(define* (make-dbuffer #:key name (capacity 128) (usage '(vertex))) + (let* ((buffer (make-buffer capacity #:name name #:usage usage))) + (%make-dbuffer buffer capacity 0))) + +(define (expand-dbuffer dbuffer) + (match dbuffer + (($ <dbuffer> old-buffer old-data old-capacity old-length) + (let* ((new-capacity (* old-capacity 2)) + (new-buffer (make-buffer new-capacity + #:name (buffer-name old-buffer) + #:usage (buffer-usage old-buffer)))) + (set-dbuffer-buffer! dbuffer new-buffer) + (set-dbuffer-capacity! dbuffer new-capacity) + (when old-data + (unmap-buffer old-buffer) + (let ((new-data (map-buffer new-buffer 'write 0 new-capacity))) + (bytevector-copy! old-data 0 new-data 0 old-length) + (set-dbuffer-data! dbuffer new-data))))))) + +(define (dbuffer-reserve! dbuffer n) + (match dbuffer + (($ <dbuffer> _ _ capacity length) + (if (> (+ length n) capacity) + (begin + (expand-dbuffer dbuffer) + (dbuffer-reserve! dbuffer n)) + (begin + (set-dbuffer-length! dbuffer (+ length n)) + length))))) + +(define (dbuffer-clear! dbuffer) + (set-dbuffer-length! dbuffer 0)) + +(define (dbuffer-map! dbuffer) + (dbuffer-clear! dbuffer) + (let* ((buffer (dbuffer-buffer dbuffer)) + (bv (map-buffer buffer 'write 0 (buffer-length buffer)))) + (set-dbuffer-data! dbuffer bv))) + +(define (dbuffer-unmap! dbuffer) + (unmap-buffer (dbuffer-buffer dbuffer)) + (set-dbuffer-data! dbuffer #f)) + +;; TODO: Add setters and define appenders as reserve + set +(define-syntax-rule (dbuffer-pack! <type> (elem ...) dbuffer offset) + (if (exact-integer? offset) + (bytestruct-pack! <type> (elem ...) (dbuffer-data dbuffer) offset) + (error "expected exact integer" offset))) + +(define-syntax-rule (dbuffer-append! <type> (elem ...) dbuffer) + (let ((offset (dbuffer-reserve! dbuffer (bytestruct-sizeof <type>)))) + (dbuffer-pack! <type> (elem ...) dbuffer offset))) + +(define-inlinable (dbuffer-pack-indices-quad! dbuffer offset i) + (unless (exact-integer? offset) + (error "expected exact integer" offset)) + (let ((bv (dbuffer-data dbuffer))) + (bytevector-u32-native-set! bv offset i) + (bytevector-u32-native-set! bv (+ offset 4) (+ i 2)) + (bytevector-u32-native-set! bv (+ offset 8) (+ i 3)) + (bytevector-u32-native-set! bv (+ offset 12) i) + (bytevector-u32-native-set! bv (+ offset 16) (+ i 1)) + (bytevector-u32-native-set! bv (+ offset 20) (+ i 2)))) + +(define-inlinable (dbuffer-append-indices-quad! dbuffer i) + (dbuffer-pack-indices-quad! dbuffer (dbuffer-reserve! dbuffer 24) i)) + + +;;; ;;; Geometry Builder ;;; (define-record-type <geometry> - (%make-geometry vertex-buffers index-buffer vertex-array) + (%make-geometry vertex-buffers index-buffer) geometry? (vertex-buffers geometry-vertex-buffers) - (index-buffer geometry-index-buffer) - (vertex-array geometry-vertex-array)) + (index-buffer geometry-index-buffer)) (define-record-type <geometry-type> (make-geometry-type attributes stride) @@ -666,7 +380,7 @@ argument may be overridden. The following values are supported: (apply make-dynamic-buffer #:name "vertex" #:capacity capacity - #:usage usage + #:usage '(index vertex) #:stride (geometry-type-stride type) args)) (define (filter-kwargs l keep) @@ -677,18 +391,6 @@ argument may be overridden. The following values are supported: (if (memq kw keep) (cons* kw arg (loop rest)) (loop rest)))))) - (define (make-vertex-attribute* name type attr-type dbuffer offset args) - (apply make-vertex-attribute - #:name (format #f "~s view" name) - #:buffer (dynamic-buffer->buffer dbuffer) - #:type (if (scalar-type? attr-type) - 'scalar - attr-type) - #:component-type (if (scalar-type? attr-type) - attr-type - 'float) - #:offset offset - args)) (define (canonicalize-types) (if (geometry-type? types) (list (list types)) @@ -703,49 +405,19 @@ argument may be overridden. The following values are supported: (map (match-lambda ((type . args) (cons type - (apply make-dynamic-buffer* - type - (filter-kwargs args '(#:capacity #:usage)))))) + (make-dynamic-buffer #:name "vertex" + #:capacity capacity + #:usage '(vertex) + #:stride (geometry-type-stride type))))) types)) - (define (build-views types buffers) - (let loop ((types types) - (location 0)) - (match types - (() '()) - (((type . args) . rest) - (let inner ((attrs (geometry-type-attributes type)) - (location location)) - (match attrs - (() - (loop rest location)) - (((name attr-type offset) . rest) - (cons (cons location - (make-vertex-attribute* name - type - attr-type - (assq-ref buffers type) - offset - (filter-kwargs args '(#:divisor)))) - (inner rest (+ location 1)))))))))) (let* ((index-buffer (and index? (make-dynamic-buffer #:name "index" #:capacity index-capacity - #:usage index-usage - #:stride 4 - #:target 'index))) - (index-view (and index? - (make-vertex-attribute #:name "index view" - #:buffer (dynamic-buffer->buffer - index-buffer) - #:type 'scalar - #:component-type 'unsigned-int))) + #:usage '(index) + #:stride 4))) (types (canonicalize-types)) - (vertex-buffers (build-vertex-buffers types)) - (vertex-views (build-views types vertex-buffers)) - (vertex-array (make-vertex-array #:indices index-view - #:attributes vertex-views - #:mode mode))) - (%make-geometry vertex-buffers index-buffer vertex-array))) + (vertex-buffers (build-vertex-buffers types))) + (%make-geometry vertex-buffers index-buffer))) (define (geometry-vertex-buffer geometry type) (assq-ref (geometry-vertex-buffers geometry) type)) @@ -753,7 +425,7 @@ argument may be overridden. The following values are supported: (define-inlinable (geometry-set-index! geometry i j) (let ((buffer (geometry-index-buffer geometry))) (dynamic-buffer-bounds-check buffer i) - (u32vector-set! (dynamic-buffer-data buffer) i j))) + (bytevector-u32-native-set! (dynamic-buffer-data buffer) i j))) (define-syntax-rule (geometry-index-append! geometry i ...) (let* ((buffer (geometry-index-buffer geometry)) @@ -792,19 +464,17 @@ argument may be overridden. The following values are supported: body ... (geometry-end* geometry type) ...)) -(define (begin:map buffer-pair) - (dynamic-buffer-map! (cdr buffer-pair))) - (define (geometry-begin! geometry) + (define (begin:map buffer-pair) + (dynamic-buffer-map! (cdr buffer-pair))) (let ((index-buffer (geometry-index-buffer geometry))) (for-each begin:map (geometry-vertex-buffers geometry)) (when index-buffer (dynamic-buffer-map! index-buffer)))) -(define (end:unmap buffer-pair) - (dynamic-buffer-unmap! (cdr buffer-pair))) - (define (geometry-end! geometry) + (define (end:unmap buffer-pair) + (dynamic-buffer-unmap! (cdr buffer-pair))) (let ((index-buffer (geometry-index-buffer geometry))) (when index-buffer (dynamic-buffer-unmap! index-buffer)) @@ -899,8 +569,9 @@ argument may be overridden. The following values are supported: (dynamic-buffer-bounds-check dbuffer i) (case 'field ((field-name) - (field-getter (dynamic-buffer-data dbuffer - (+ (* i type-stride) field-offset)))) + (field-getter + (dynamic-buffer-data dbuffer (+ (* i type-stride) + field-offset)))) ... (else (error "unknown field" 'field))))) (define-syntax-rule (setter geometry field i x) @@ -915,13 +586,13 @@ argument may be overridden. The following values are supported: (else (error "unknown field" 'field))))) (define-syntax appender (syntax-rules ::: () - ((_ geometry (field-name ...) :::) - (let* ((dbuffer (geometry-vertex-buffer geometry type-name)) - (n (length '((field-name ...) :::))) - (i (dynamic-buffer-next! dbuffer n)) - (bv (dynamic-buffer-data dbuffer))) - (let ((offset (* i type-stride))) - (field-setter bv (+ offset field-offset) field-name) - ... - (set! i (+ i 1))) - :::))))))))))) + ((_ geometry (field-name ...) :::) + (let* ((dbuffer (geometry-vertex-buffer geometry type-name)) + (n (length '((field-name ...) :::))) + (i (dynamic-buffer-next! dbuffer n)) + (bv (dynamic-buffer-data dbuffer))) + (let ((offset (* i type-stride))) + (field-setter bv (+ offset field-offset) field-name) + ... + (set! i (+ i 1))) + :::))))))))))) diff --git a/chickadee/graphics/color.scm b/chickadee/graphics/color.scm index ed89082..e30f7b0 100644 --- a/chickadee/graphics/color.scm +++ b/chickadee/graphics/color.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2018, 2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2016, 2018, 2021, 2023 David Thompson <dthompson2@worcester.edu> ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. @@ -21,8 +21,6 @@ (define-module (chickadee graphics color) #:use-module (chickadee data bytestruct) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) #:use-module (chickadee math) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -120,15 +118,51 @@ db32-rain-forest db32-stinger - default-color-mask - null-color-mask - g:color-mask - current-color-mask + %default-clear-color + + <blend-component> + make-blend-component + blend-component? + blend-component-op + blend-component-src-factor + blend-component-dst-factor + + <blend-mode> + make-blend-mode + blend-mode? + blend-mode-color + blend-mode-alpha + + blend:alpha + blend:multiply + blend:subtract + blend:add + blend:lighten + blend:darken + blend:screen + blend:replace + + <color-mask> + make-color-mask color-mask? color-mask-red? color-mask-green? color-mask-blue? - color-mask-alpha?)) + color-mask-alpha? + + <color-target> + make-color-target + color-target? + color-target-format + color-target-blend-mode + color-target-mask + + <color-operation> + make-color-operation + color-operation? + color-operation-clear-color + color-operation-load-op + color-operation-store-op)) (define-byterecord-type <color> (%make-color r g b a) @@ -358,11 +392,74 @@ a color object." (define db32-rain-forest (make-color8 143 151 74)) (define db32-stinger (make-color8 138 111 48)) +(define %default-clear-color (make-color 0.0 0.0 0.0 0.0)) + ;;; -;;; Color Masks +;;; Color target ;;; +(define-record-type <blend-component> + (%make-blend-component op src-factor dst-factor) + blend-component? + (op blend-component-op) + (src-factor blend-component-src-factor) + (dst-factor blend-component-dst-factor)) + +(define* (make-blend-component #:key (op 'add) (src-factor 'one) + (dst-factor 'zero)) + (%make-blend-component op src-factor dst-factor)) + +(define-record-type <blend-mode> + (%make-blend-mode color alpha) + blend-mode? + (color blend-state-color) + (alpha blend-state-alpha)) + +(define* (make-blend-mode color #:optional (alpha color)) + (%make-blend-mode color alpha)) + +(define blend:alpha + (make-blend-mode + (make-blend-component #:op 'add + #:src-factor 'src-alpha + #:dst-factor 'one-minus-src-alpha))) +(define blend:multiply + (make-blend-mode + (make-blend-component #:op 'add + #:src-factor 'dst + #:dst-factor 'zero))) +(define blend:subtract + (make-blend-mode + (make-blend-component #:op 'reverse-subtract + #:src-factor 'one + #:dst-factor 'zero))) +(define blend:add + (make-blend-mode + (make-blend-component #:op 'add + #:src-factor 'one + #:dst-factor 'one))) +(define blend:lighten + (make-blend-mode + (make-blend-component #:op 'max + #:src-factor 'one + #:dst-factor 'zero))) +(define blend:darken + (make-blend-mode + (make-blend-component #:op 'min + #:src-factor 'one + #:dst-factor 'zero))) +(define blend:screen + (make-blend-mode + (make-blend-component #:op 'add + #:src-factor 'one + #:dst-factor 'one-minus-src))) +(define blend:replace + (make-blend-mode + (make-blend-component #:op 'add + #:src-factor 'one + #:dst-factor 'zero))) + (define-record-type <color-mask> (make-color-mask red? green? blue? alpha?) color-mask? @@ -371,16 +468,26 @@ a color object." (blue? color-mask-blue?) (alpha? color-mask-alpha?)) -(define default-color-mask (make-color-mask #t #t #t #t)) -(define null-color-mask (make-color-mask #f #f #f #f)) +(define-record-type <color-target> + (%make-color-target format blend-mode mask) + color-target? + (format color-target-format) + (blend-mode color-target-blend-mode) + (mask color-target-mask)) + +(define* (make-color-target #:key (format 'rgba8) blend-mode + (mask (make-color-mask #t #t #t #t))) + (%make-color-target format blend-mode mask)) -(define (bind-color-mask mask) - (gl-color-mask (color-mask-red? mask) - (color-mask-green? mask) - (color-mask-blue? mask) - (color-mask-alpha? mask))) +(define-record-type <color-operation> + (%make-color-operation clear-color load-op store-op) + color-operation? + (clear-color color-operation-clear-color) + (load-op color-operation-load-op) + (store-op color-operation-store-op)) -(define-graphics-state g:color-mask - current-color-mask - #:default default-color-mask - #:bind bind-color-mask) +(define* (make-color-operation #:key + (clear-color %default-clear-color) + (load-op 'clear) + (store-op 'store)) + (%make-color-operation clear-color load-op store-op)) diff --git a/chickadee/graphics/depth-stencil.scm b/chickadee/graphics/depth-stencil.scm new file mode 100644 index 0000000..a3fac63 --- /dev/null +++ b/chickadee/graphics/depth-stencil.scm @@ -0,0 +1,137 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary +;; +;; Depth/stencil buffer configuration. +;; +;;; Code: + +(define-module (chickadee graphics depth-stencil) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export (<stencil-face> + make-stencil-face + stencil-face? + stencil-face-compare + stencil-face-fail-op + stencil-face-depth-fail-op + stencil-face-pass-op + + <depth-test> + make-depth-test + depth-test + depth-test-compare + depth-test-write? + + <depth+stencil> + make-depth+stencil + depth+stencil? + depth+stencil-format + depth+stencil-depth-write-enabled? + depth+stencil-compare-function + depth+stencil-stencil-front + depth+stencil-stencil-back + depth+stencil-stencil-read-mask + depth+stencil-stencil-write-mask + + <depth-operation> + make-depth-operation + depth-operation? + depth-operation-clear-value + depth-operation-load-op + depth-operation-store-op + depth-operation-read-only? + + <stencil-operation> + make-stencil-operation + stencil-operation? + stencil-operation-clear-value + stencil-operation-load-op + stencil-operation-store-op + stencil-operation-read-only?)) + +(define-record-type <stencil-face> + (%make-stencil-face compare fail-op depth-fail-op pass-op) + stencil-face? + (compare stencil-face-compare) + (fail-op stencil-face-fail-op) + (depth-fail-op stencil-face-depth-fail-op) + (pass-op stencil-face-pass-op)) + +(define* (make-stencil-face #:key (compare 'always) (fail-op 'keep) + (depth-fail-op 'keep) (pass-op 'keep)) + (%make-stencil-face compare fail-op depth-fail-op pass-op)) + +(define-record-type <depth-test> + (%make-depth-test compare write?) + depth-test? + (compare depth-test-compare) + (write? depth-test-write?)) + +(define* (make-depth-test #:key (compare 'less) write?) + (%make-depth-test compare write?)) + +(define-record-type <depth+stencil> + (%make-depth+stencil format depth-test stencil-front + stencil-back stencil-read-mask stencil-write-mask) + depth+stencil? + (format depth+stencil-format) + (depth-test depth+stencil-depth-test) + (stencil-front depth+stencil-stencil-front) + (stencil-back depth+stencil-stencil-back) + (stencil-read-mask depth+stencil-stencil-read-mask) + (stencil-write-mask depth+stencil-stencil-write-mask)) + +(define* (make-depth+stencil #:key + (format 'depth24plus-stencil8) + depth-test + stencil-face + (stencil-front stencil-face) + (stencil-back stencil-face) + (stencil-read-mask #xffffFFFF) + (stencil-write-mask #xffffFFFF)) + (%make-depth+stencil format depth-test stencil-front + stencil-back stencil-read-mask stencil-write-mask)) + +(define-record-type <depth-operation> + (%make-depth-operation clear-value load-op store-op read-only?) + depth-operation? + (clear-value depth-operation-clear-value) + (load-op depth-operation-load-op) + (store-op depth-operation-store-op) + (read-only? depth-operation-read-only?)) + +(define* (make-depth-operation #:key + (clear-value 0.0) + (load-op 'clear) + (store-op 'store) + read-only?) + (%make-depth-operation clear-value load-op store-op read-only?)) + +(define-record-type <stencil-operation> + (%make-stencil-operation clear-value load-op store-op read-only?) + stencil-operation? + (clear-value stencil-operation-clear-value) + (load-op stencil-operation-load-op) + (store-op stencil-operation-store-op) + (read-only? stencil-operation-read-only?)) + +(define* (make-stencil-operation #:key + (clear-value #x00000000) + (load-op 'clear) + (store-op 'store) + read-only?) + (%make-stencil-operation clear-value load-op store-op read-only?)) diff --git a/chickadee/graphics/framebuffer.scm b/chickadee/graphics/framebuffer.scm index bee4b7d..35e16c5 100644 --- a/chickadee/graphics/framebuffer.scm +++ b/chickadee/graphics/framebuffer.scm @@ -30,7 +30,7 @@ #:use-module (chickadee graphics engine) #:use-module (chickadee graphics gl) #:use-module (chickadee graphics pixbuf) - #:use-module ((chickadee graphics texture) #:select (make-texture null-texture)) + #:use-module ((chickadee graphics texture) #:select (make-texture)) #:use-module (chickadee graphics viewport) #:export (make-framebuffer framebuffer? @@ -63,6 +63,9 @@ (viewport framebuffer-viewport) (projection framebuffer-projection)) +(define null-texture #f) +(define null-viewport #f) + (define null-framebuffer (%make-framebuffer 0 0 null-texture null-viewport (make-identity-matrix4))) diff --git a/chickadee/graphics/layout.scm b/chickadee/graphics/layout.scm new file mode 100644 index 0000000..04a42b0 --- /dev/null +++ b/chickadee/graphics/layout.scm @@ -0,0 +1,102 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary: +;; +;; Pipeline layout specifications. +;; +;;; Code: + +(define-module (chickadee graphics layout) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export (<vertex-attribute> + make-vertex-attribute + vertex-attribute? + vertex-attribute-format + vertex-attribute-offset + + <vertex-buffer-layout> + make-vertex-buffer-layout + vertex-buffer-layout? + vertex-buffer-layout-stride + vertex-buffer-layout-step-mode + vertex-buffer-layout-attributes + + <texture-layout> + make-texture-layout + texture-layout? + texture-layout-sample-type + texture-layout-dimension + texture-layout-multisample? + + <sampler-layout> + make-sampler-layout + sampler-layout? + sampler-layout-type + + <buffer-layout> + make-buffer-layout + buffer-layout? + buffer-layout-type + buffer-layout-min-size)) + +(define-record-type <vertex-attribute> + (%make-vertex-attribute format offset) + vertex-attribute? + (format vertex-attribute-format) + (offset vertex-attribute-offset)) + +(define* (make-vertex-attribute #:key format (offset 0)) + (%make-vertex-attribute format offset)) + +(define-record-type <vertex-buffer-layout> + (%make-vertex-buffer-layout stride step-mode attributes) + vertex-buffer-layout? + (stride vertex-buffer-layout-stride) + (step-mode vertex-buffer-layout-step-mode) + (attributes vertex-buffer-layout-attributes)) + +(define* (make-vertex-buffer-layout #:key stride (step-mode 'vertex) + (attributes #())) + (%make-vertex-buffer-layout stride step-mode attributes)) + +(define-record-type <texture-layout> + (%make-texture-layout sample-type dimension multisample?) + texture-layout? + (sample-type texture-layout-sample-type) + (dimension texture-layout-dimension) + (multisample? texture-layout-multisample?)) + +(define* (make-texture-layout #:key (sample-type 'float) (dimension '2d) + multisample?) + (%make-texture-layout sample-type dimension multisample?)) + +(define-record-type <sampler-layout> + (%make-sampler-layout type) + sampler-layout? + (type sampler-layout-type)) + +(define* (make-sampler-layout #:key (type 'filtering)) + (%make-sampler-layout type)) + +(define-record-type <buffer-layout> + (%make-buffer-layout type min-size) + buffer-layout? + (type buffer-layout-type) + (min-size buffer-layout-min-size)) + +(define* (make-buffer-layout #:key (type 'uniform) (min-size 0)) + (%make-buffer-layout type min-size)) diff --git a/chickadee/graphics/light.scm b/chickadee/graphics/light.scm index e941052..910581c 100644 --- a/chickadee/graphics/light.scm +++ b/chickadee/graphics/light.scm @@ -49,16 +49,18 @@ ;; Maximum number of lights supported by our shaders. (define %max-lights 4) -(define-shader-type <light> - make-light - light? - (bool enabled light-enabled?) - (int type %light-type) - (float-vec3 position light-position set-light-position!) - (float-vec3 direction light-direction set-light-direction!) - (float-vec4 color light-color set-light-color!) - (float intensity light-intensity set-light-intensity!) - (float cut-off light-cut-off %set-light-cut-off!)) +(define <light> #f) +(define (make-light . args) #f) +;; (define-shader-type <light> +;; make-light +;; light? +;; (bool enabled light-enabled?) +;; (int type %light-type) +;; (float-vec3 position light-position set-light-position!) +;; (float-vec3 direction light-direction set-light-direction!) +;; (float-vec4 color light-color set-light-color!) +;; (float intensity light-intensity set-light-intensity!) +;; (float cut-off light-cut-off %set-light-cut-off!)) (define %disabled-light (make-light #:enabled #f)) diff --git a/chickadee/graphics/multisample.scm b/chickadee/graphics/multisample.scm index cd54d55..5ecfdc0 100644 --- a/chickadee/graphics/multisample.scm +++ b/chickadee/graphics/multisample.scm @@ -20,17 +20,22 @@ ;;; Code: (define-module (chickadee graphics multisample) - #:use-module (chickadee graphics engine) - #:use-module (gl) - #:export (g:multisample? + #:use-module (srfi srfi-9) + #:export (<multisample> + make-multisample + multisample? + multisample-count + multisample-mask + multisample-alpha-to-coverage? current-multisample)) -(define (bind-multisample multisample?) - (if multisample? - (gl-enable (version-1-3 multisample)) - (gl-disable (version-1-3 multisample)))) +(define-record-type <multisample> + (%make-multisample count mask alpha-to-coverage?) + multisample? + (count multisample-count) ; either 1 or 4 + (mask multisample-mask) + (alpha-to-coverage? multisample-alpha-to-coverage?)) -(define-graphics-state g:multisample? - current-multisample - #:default #f - #:bind bind-multisample) +(define* (make-multisample #:key (count 1) (mask #xffffffff) + alpha-to-coverage?) + (%make-multisample count mask alpha-to-coverage?)) diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm index d8bd1b2..4d4b251 100644 --- a/chickadee/graphics/particles.scm +++ b/chickadee/graphics/particles.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2018, 2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2018, 2021, 2024 David Thompson <dthompson2@worcester.edu> ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. @@ -14,22 +14,24 @@ ;;; limitations under the License. (define-module (chickadee graphics particles) + #:use-module (chickadee data bytestruct) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics buffer) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics pipeline) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (chickadee math) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (system foreign) - #:use-module (chickadee math) - #: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 shader) - #:use-module (chickadee graphics texture) #:export (make-particle-emitter particle-emitter? particle-emitter-spawn-area @@ -40,7 +42,7 @@ particles? particles-capacity particles-size - particles-texture + particles-texture-view particles-blend-mode particles-color particles-spawn-area @@ -75,45 +77,55 @@ indefinitely." (let ((life (particle-emitter-life emitter))) (and life (<= life 0)))) -(define-geometry-type <quad-vertex> - quad-vertex-ref - quad-vertex-set! - quad-vertex-append! - (position vec2) - (texture vec2)) - -(define-geometry-type <particle-vertex> - particle-vertex-ref - particle-vertex-set! - particle-vertex-append! - (position vec2) - (velocity vec2) - (acceleration vec2) - (life int)) - -(define-graphics-variable particles-shader - (strings->shader - " +(define-bytestruct <particle-vertex> + (struct (position <vec2>) + (velocity <vec2>) + (accel <vec2>) + (life s32))) + +(define-bytestruct <quad-vertex> + (struct (position <vec2>) + (uv <vec2>))) + +(define-bytestruct <particle-uniforms> + (struct (matrix <matrix4>) + (lifetime s32) + (animation-rows s32) + (animation-columns s32) + (start-color <color>) + (end-color <color>))) + +(define-record-type <particle-state> + (make-particle-state uniforms sampler pipeline bindings matrix) + particle-state? + (uniforms particle-state-uniforms) + (sampler particle-state-sampler) + (pipeline particle-state-pipeline) + (bindings particle-state-bindings) + (matrix particle-state-matrix)) + +(define-graphics-variable particle-state + (let ((shader (make-shader + (lambda (lang) + (values + " #ifdef GLSL330 layout (location = 0) in vec2 position; layout (location = 1) in vec2 tex; layout (location = 2) in vec2 offset; layout (location = 3) in vec2 velocity; -layout (location = 4) in vec2 acceleration; -layout (location = 5) in float life; +layout (location = 4) in float life; #elif defined(GLSL130) in vec2 position; in vec2 tex; in vec2 offset; in vec2 velocity; -in vec2 acceleration; in float life; #elif defined(GLSL120) attribute vec2 position; attribute vec2 tex; attribute vec2 offset; attribute vec2 velocity; -attribute vec2 acceleration; attribute float life; #endif #ifdef GLSL120 @@ -123,10 +135,23 @@ varying float t; out vec2 fragTex; out float t; #endif -uniform mat4 mvp; + +#ifdef GLSL120 +uniform mat4 matrix; uniform int lifetime; uniform int animationRows; uniform int animationColumns; +#else +layout (std140) uniform Particles +{ + mat4 matrix; + int lifetime; + int animationRows; + int animationColumns; + vec4 startColor; + vec4 endColor; +}; +#endif void main(void) { t = life / lifetime; @@ -137,10 +162,10 @@ void main(void) { float tw = 1.0 / animationColumns; float th = 1.0 / animationRows; fragTex = vec2(tx, ty) + tex * vec2(tw, th); - gl_Position = mvp * vec4(position.xy + offset, 0.0, 1.0); + gl_Position = matrix * vec4(position + offset, 0.0, 1.0); } " - " + " #ifdef GLSL120 varying vec2 fragTex; varying float t; @@ -150,24 +175,75 @@ in float t; #endif #ifdef GLSL330 out vec4 fragColor; +#else +#define fragColor gl_FragColor +#define texture texture2D #endif -uniform sampler2D color_texture; + +uniform sampler2D colorTexture; +#ifdef GLSL120 uniform vec4 startColor; uniform vec4 endColor; - -void main (void) { -#ifdef GLSL330 - fragColor = mix(endColor, startColor, t) * texture(color_texture, fragTex); #else - gl_FragColor = mix(endColor, startColor, t) * texture2D(color_texture, fragTex); +layout (std140) uniform Particles +{ + mat4 matrix; + int lifetime; + int animationRows; + int animationColumns; + vec4 startColor; + vec4 endColor; +}; #endif -} -")) -(define-graphics-variable mvp-matrix (make-null-matrix4)) +void main (void) { + fragColor = mix(endColor, startColor, t) * texture(colorTexture, fragTex); +} +"))))) + (make-particle-state + (make-buffer (bytestruct-sizeof <particle-uniforms>) + #:name "Particle uniform buffer" + #:usage '(uniform)) + (make-sampler #:name "Particle sampler") + (make-render-pipeline + #:name "Particles" + #:shader shader + #:color-target (make-color-target #:blend-mode blend:alpha) + #:vertex-layout + (vector + (make-vertex-buffer-layout + #:stride (* 4 4) + #:attributes (vector + ;; Position + (make-vertex-attribute + #:format 'float32x2) + ;; Texture + (make-vertex-attribute + #:format 'float32x2 + #:offset (* 2 4)))) + (make-vertex-buffer-layout + #:stride (* 7 4) + #:step-mode 'instance + #:attributes (vector + ;; Position + (make-vertex-attribute + #:format 'float32x2) + ;; Velocity + (make-vertex-attribute + #:format 'float32x2 + #:offset (* 2 4)) + ;; Life + (make-vertex-attribute + #:format 'sint32 + #:offset (* 6 4))))) + #:binding-layout (vector (make-texture-layout) + (make-sampler-layout) + (make-buffer-layout))) + (make-vector 3 #f) + (make-null-matrix4)))) (define-record-type <particles> - (%make-particles capacity size bv geometry + (%make-particles capacity size bv vertex-buffers index-buffer texture animation-rows animation-columns speed-range acceleration-range direction-range blend-mode start-color end-color lifetime @@ -176,7 +252,8 @@ void main (void) { (capacity particles-capacity) (size particles-size set-particles-size!) (bv particles-bv) - (geometry particles-geometry) + (vertex-buffers particles-vertex-buffers) + (index-buffer particles-index-buffer) (texture particles-texture set-particles-texture!) (animation-rows particles-animation-rows) (animation-columns particles-animation-columns) @@ -205,21 +282,21 @@ void main (void) { (blend-mode blend:alpha) (start-color white) (end-color (make-color 0.0 0.0 0.0 0.0)) - (texture null-texture) + texture-view (animation-rows 1) (animation-columns 1) - (width (if (texture-null? texture) - 8.0 + (width (if texture-view (inexact->exact (floor - (/ (texture-width texture) - animation-columns))))) - (height (if (texture-null? texture) - 8.0 + (/ (texture-view-width texture-view) + animation-columns))) + 8.0)) + (height (if texture-view (inexact->exact (floor - (/ (texture-height texture) - animation-rows))))) + (/ (texture-view-height texture-view) + animation-rows))) + 8.0)) (speed-range (vec2 0.1 1.0)) (acceleration-range (vec2 0.0 0.1)) (direction-range (vec2 0.0 (* 2 pi))) @@ -239,8 +316,8 @@ Completely transparent by default for a fade-out effect. The color in the middle of a particle's life will be an interpolation of START-COLOR and END-COLOR. -- TEXTURE: The texture applied to the particles. The texture may be -subdivided into many animation frames. +- TEXTURE-VIEW: The 2D texture applied to the particles. The texture +may be subdivided into many animation frames. - ANIMATION-ROWS: How many animation frame rows there are in the texture. Default is 1. @@ -273,27 +350,54 @@ default. - SORT: 'youngest' if youngest particle should be drawn last or 'oldest' for the reverse. By default, no sorting is applied at all." - (let ((geometry (make-geometry (list (list <quad-vertex> #:capacity 4) - (list <particle-vertex> #:divisor 1)) - capacity - #:index-capacity 6))) - (with-geometry* geometry (<quad-vertex> 'index) - (let ((hw (/ width 2.0)) - (hh (/ height 2.0))) - (quad-vertex-append! geometry - ((- hw) (- hh) 0.0 0.0) - (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)) + (let* ((hw (/ width 2.0)) + (hh (/ height 2.0)) + (size (bytestruct-sizeof <quad-vertex>)) + (quad-vertex + (bytevector->buffer + ;; TODO: Add some syntax for declaratively generating a + ;; bytevector of packed bytestructs. + (let ((bv (make-bytevector (* size 4)))) + (bytestruct-pack! <quad-vertex> + (((position x) (- hw)) + ((position y) (- hh)) + ((uv x) 0.0) + ((uv y) 0.0)) + bv 0) + (bytestruct-pack! <quad-vertex> + (((position x) hw) + ((position y) (- hh)) + ((uv x) 1.0) + ((uv y) 0.0)) + bv size) + (bytestruct-pack! <quad-vertex> + (((position x) hw) + ((position y) hh) + ((uv x) 1.0) + ((uv y) 1.0)) + bv (* size 2)) + (bytestruct-pack! <quad-vertex> + (((position x) (- hw)) + ((position y) hh) + ((uv x) 0.0) + ((uv y) 1.0)) + bv (* size 3)) + bv) + #:name "Particles quad vertex buffer")) + (quad-index + (bytevector->buffer (u32vector 0 2 3 0 1 2) + #:name "Particles quad index buffer" + #:usage '(index))) + ;; 1 extra element as swap space for sorting. + (k (* (+ capacity 1) (bytestruct-sizeof <particle-vertex>))) + (particles (make-bytevector k)) + (particles-vertex (make-buffer k #:name "Particles vertex buffer"))) (%make-particles capacity - 0 - ;; 1 extra element as swap space for sorting. - (make-bytevector (* (+ capacity 1) - (geometry-type-stride - <particle-vertex>))) - geometry - texture + 0 ; initial size + particles + (vector quad-vertex particles-vertex) + quad-index + texture-view animation-rows animation-columns speed-range @@ -304,152 +408,158 @@ default. end-color lifetime sort + ;; No emitters initially. '()))) (define (update-particles particles) "Advance the simulation of PARTICLES." - (let* ((speed-range (particles-speed-range particles)) - (acceleration-range (particles-acceleration-range particles)) - (direction-range (particles-direction-range particles)) - (sort (particles-sort particles)) - (lifetime (particles-lifetime particles)) - (float-ref bytevector-ieee-single-native-ref) - (float-set! bytevector-ieee-single-native-set!) - (int-ref bytevector-s32-native-ref) - (int-set! bytevector-s32-native-set!) - (y-offset 4) - (dx-offset 8) - (dy-offset 12) - (ddx-offset 16) - (ddy-offset 20) - (life-offset 24)) - (let* ((bv (particles-bv particles)) - (stride (geometry-type-stride <particle-vertex>)) - (capacity (particles-capacity particles))) - ;; Update existing particles, removing dead ones. - (let loop ((i 0) - (size (particles-size particles))) - (if (< i size) - (let* ((offset (* i stride)) - (life (- (int-ref bv (+ offset life-offset)) 1))) - (if (<= life 0) - (let ((new-size (- size 1))) - (bytevector-copy! bv (* new-size stride) bv offset stride) - (loop i new-size)) - (let ((x (float-ref bv offset)) - (y (float-ref bv (+ offset y-offset))) - (dx (float-ref bv (+ offset dx-offset))) - (dy (float-ref bv (+ offset dy-offset))) - (ddx (float-ref bv (+ offset ddx-offset))) - (ddy (float-ref bv (+ offset ddy-offset)))) - (int-set! bv (+ offset life-offset) life) - (float-set! bv offset (+ x dx)) - (float-set! bv (+ offset y-offset) (+ y dy)) - (float-set! bv (+ offset dx-offset) (+ dx ddx)) - (float-set! bv (+ offset dy-offset) (+ dy ddy)) - (loop (+ i 1) size)))) - (set-particles-size! particles size))) - ;; Add particles from each active emitter and then remove - ;; emitters that have completed. - (let ((sx (vec2-x speed-range)) - (sy (vec2-y speed-range)) - (ax (vec2-x acceleration-range)) - (ay (vec2-y acceleration-range)) - (dx (vec2-x direction-range)) - (dy (vec2-y direction-range)) - (emitters (particles-emitters particles))) - (define (emit emitter any-done?) - (let* ((spawn-area (particle-emitter-spawn-area emitter)) - (rate (particle-emitter-rate emitter)) - (rx (rect-x spawn-area)) - (ry (rect-y spawn-area)) - (rw (rect-width spawn-area)) - (rh (rect-height spawn-area)) - (start (particles-size particles)) - (end (min (+ start rate) capacity))) - (let loop ((i start)) - (if (< i end) - (let* ((offset (* i stride)) - (speed (+ (* (random:uniform) (- sy sx)) sx)) - (accel (+ (* (random:uniform) (- ay ax)) ax)) - (dir (+ (* (random:uniform) (- dy dx)) dx)) - (dir-x (cos dir)) - (dir-y (sin dir))) - (float-set! bv offset (+ rx (* (random:uniform) rw))) - (float-set! bv (+ offset y-offset) - (+ ry (* (random:uniform) rh))) - (float-set! bv (+ offset dx-offset) (* dir-x speed)) - (float-set! bv (+ offset dy-offset) (* dir-y speed)) - (float-set! bv (+ offset ddx-offset) (* dir-x accel)) - (float-set! bv (+ offset ddy-offset) (* dir-y accel)) - (int-set! bv (+ offset life-offset) lifetime) - (loop (+ i 1))) - (begin - (set-particles-size! particles end) - (update-particle-emitter emitter) - (or any-done? (particle-emitter-done? emitter))))))) - (when (fold emit #f emitters) - (set-particles-emitters! particles - (remove particle-emitter-done? emitters)))) - ;; Sort particles. - (when sort - (let ((compare (cond - ((eq? sort 'young) - (lambda (i j) - (< (int-ref bv (+ i life-offset)) - (int-ref bv (+ j life-offset))))) - ((eq? sort 'old) - (lambda (i j) - (> (int-ref bv (+ i life-offset)) - (int-ref bv (+ j life-offset))))) - (else - (error "unknown particle sorting method" sort)))) - (tmp (* (particles-capacity particles) stride))) - (define (swap i j) - (bytevector-copy! bv i bv tmp stride) - (bytevector-copy! bv j bv i stride) - (bytevector-copy! bv tmp bv j stride)) - ;; In the benchmarks I've done, insertion sort has - ;; performed much better than quicksort here. The number - ;; of comparisons and swaps is much fewer. - (define (sort start end) - (let outer ((i (+ start stride))) - (when (< i end) - (let inner ((j i)) - (when (and (> j start) - (compare j (- j stride))) - (swap (- j stride) j) - (inner (- j stride)))) - (outer (+ i stride))))) - (sort 0 (* (particles-size particles) stride)))) - (with-geometry* (particles-geometry particles) (<particle-vertex>) - (geometry-import! (particles-geometry particles) <particle-vertex> bv 0 - (particles-size particles)))))) + (match particles + (($ <particles> capacity (? exact-integer? size) bv #(_ vertex) _ _ _ _ + speed-range acceleration-range direction-range + _ _ _ lifetime sort emitters) + (let ((stride (bytestruct-sizeof <particle-vertex>))) + ;; Update existing particles, removing dead ones. + (let loop ((i 0) (size size)) + (if (< i size) + (let ((offset (* i stride))) + (call-with-values (lambda () + (bytestruct-unpack <particle-vertex> + ((position x) + (position y) + (velocity x) + (velocity y) + (accel x) + (accel y) + (life)) + bv offset)) + (lambda (x y dx dy ddx ddy life) + (let ((life (- life 1))) + (if (<= life 0) + (let ((size (- size 1))) + (bytevector-copy! bv (* size stride) bv offset stride) + (loop i size)) + (begin + (bytestruct-pack! <particle-vertex> + (((position x) (+ x dx)) + ((position y) (+ y dy)) + ((velocity x) (+ dx ddx)) + ((velocity y) (+ dy ddy)) + ((life) life)) + bv offset) + (loop (+ i 1) size))))))) + (set-particles-size! particles size))) + ;; Add particles from each active emitter and then remove + ;; emitters that have completed. + (let ((sx (vec2-x speed-range)) + (sy (vec2-y speed-range)) + (ax (vec2-x acceleration-range)) + (ay (vec2-y acceleration-range)) + (dx (vec2-x direction-range)) + (dy (vec2-y direction-range)) + (emitters (particles-emitters particles))) + (define (emit emitter any-done?) + (let* ((spawn-area (particle-emitter-spawn-area emitter)) + (rate (particle-emitter-rate emitter)) + (rx (rect-x spawn-area)) + (ry (rect-y spawn-area)) + (rw (rect-width spawn-area)) + (rh (rect-height spawn-area)) + (start (particles-size particles)) + (end (min (+ start rate) capacity))) + (let loop ((i start)) + (if (< i end) + (let* ((offset (* i stride)) + (speed (+ (* (random:uniform) (- sy sx)) sx)) + (accel (+ (* (random:uniform) (- ay ax)) ax)) + (dir (+ (* (random:uniform) (- dy dx)) dx)) + (dir-x (cos dir)) + (dir-y (sin dir))) + (bytestruct-pack! <particle-vertex> + (((position x) (+ rx (* (random:uniform) rw))) + ((position y) (+ ry (* (random:uniform) rh))) + ((velocity x) (* dir-x speed)) + ((velocity y) (* dir-y speed)) + ((accel x) (* dir-x accel)) + ((accel y) (* dir-y accel)) + ((life) lifetime)) + bv offset) + (loop (+ i 1))) + (begin + (set-particles-size! particles end) + (update-particle-emitter emitter) + (or any-done? (particle-emitter-done? emitter))))))) + (when (fold emit #f emitters) + (set-particles-emitters! particles + (remove particle-emitter-done? emitters)))) + ;; Sort particles. + (when sort + (let ((compare + (match sort + ('young + (lambda (i j) + (< (bytestruct-unpack <particle-vertex> ((life)) bv i) + (bytestruct-unpack <particle-vertex> ((life)) bv j)))) + ('old + (lambda (i j) + (> (bytestruct-unpack <particle-vertex> ((life)) bv i) + (bytestruct-unpack <particle-vertex> ((life)) bv j)))) + (_ + (error "invalid particle sorting method" sort)))) + (tmp (* (particles-capacity particles) stride))) + (define (swap i j) + (bytevector-copy! bv i bv tmp stride) + (bytevector-copy! bv j bv i stride) + (bytevector-copy! bv tmp bv j stride)) + ;; In the benchmarks I've done, insertion sort has + ;; performed much better than quicksort here. The number + ;; of comparisons and swaps is much fewer. + (define (sort start end) + (let outer ((i (+ start stride))) + (when (< i end) + (let inner ((j i)) + (when (and (> j start) + (compare j (- j stride))) + (swap (- j stride) j) + (inner (- j stride)))) + (outer (+ i stride))))) + (sort 0 (* (particles-size particles) stride)))) + (let* ((k (* stride (particles-size particles))) + (dst (map-buffer vertex 'write 0 k))) + (bytevector-copy! bv 0 dst 0 k) + (unmap-buffer vertex)))))) +;; TODO: Blend mode (define (draw-particles* particles matrix) "Render PARTICLES with MATRIX applied." - (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))) - (shader-apply/instanced shader - (geometry-vertex-array geometry) - (particles-size particles) - #:mvp (if matrix - (begin - (matrix4-mult! mvp matrix - (current-projection)) - mvp) - (current-projection)) - #:start-color (particles-start-color particles) - #:end-color (particles-end-color particles) - #:lifetime (particles-lifetime particles) - #:animation-rows - (particles-animation-rows particles) - #:animation-columns - (particles-animation-columns particles))))) + (match particles + (($ <particles> _ size _ vertex-buffers index-buffer texture-view + rows columns _ _ _ blend-mode start-color end-color + lifetime) + (match (graphics-variable-ref particle-state) + (($ <particle-state> uniforms sampler pipeline bindings mvp) + (matrix4-mult! mvp matrix (current-projection)) + (let ((bv (map-buffer uniforms 'write 0 + (bytestruct-sizeof <particle-uniforms>)))) + (bytestruct-pack! <particle-uniforms> + (((matrix) mvp) + ((lifetime) lifetime) + ((animation-rows) rows) + ((animation-columns) columns) + ((start-color) start-color) + ((end-color) end-color)) + bv 0) + (unmap-buffer uniforms)) + (vector-set! bindings 0 texture-view) + (vector-set! bindings 1 sampler) + (vector-set! bindings 2 uniforms) + (draw 6 + #:instances size + #:pipeline pipeline + #:index-buffer index-buffer + #:vertex-buffers vertex-buffers + #:bindings bindings)))))) +(define %default-matrix (make-identity-matrix4)) (define (draw-particles particles) "Render PARTICLES." - (draw-particles* particles #f)) + (draw-particles* particles %default-matrix)) diff --git a/chickadee/graphics/pass.scm b/chickadee/graphics/pass.scm new file mode 100644 index 0000000..889d28d --- /dev/null +++ b/chickadee/graphics/pass.scm @@ -0,0 +1,85 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary: +;; +;; GPU render passes. +;; +;;; Code: + +(define-module (chickadee graphics pass) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics depth-stencil) + #:use-module (srfi srfi-9) + #:export (<color-attachment> + make-color-attachment + color-attachment? + color-attachment-view + color-attachment-resolve-target + color-attachment-clear-color + color-attachment-load-op + color-attachment-store-op + + <depth+stencil-attachment> + make-depth+stencil-attachment + depth+stencil-attachment? + depth+stencil-attachment-view + depth+stencil-attachment-depth-clear-value + depth+stencil-attachment-depth-load-op + depth+stencil-attachment-depth-store-op + depth+stencil-attachment-depth-read-only? + depth+stencil-attachment-stencil-clear-value + depth+stencil-attachment-stencil-load-op + depth+stencil-attachment-stencil-store-op + depth+stencil-attachment-stencil-read-only? + + <render-pass> + make-render-pass + render-pass? + render-pass-color-attachments + render-pass-depth+stencil-attachment)) + +(define-record-type <color-attachment> + (%make-color-attachment view resolve-target operation) + color-attachment? + (view color-attachment-view) + (resolve-target color-attachment-resolve-target) + (operation color-attachment-operation)) + +(define* (make-color-attachment #:key view resolve-target + (operation (make-color-operation))) + (%make-color-attachment view resolve-target operation)) + +(define-record-type <depth+stencil-attachment> + (%make-depth+stencil-attachment view depth-operation stencil-operation) + depth+stencil-attachment? + (view depth+stencil-attachment-view) + (depth-operation depth+stencil-attachment-depth-operation) + (stencil-operation depth+stencil-attachment-stencil-operation)) + +(define* (make-depth+stencil-attachment #:key view + (depth-operation (make-depth-operation)) + (stencil-operation (make-stencil-operation))) + (%make-depth+stencil-attachment view depth-operation stencil-operation)) + +(define-record-type <render-pass> + (%make-render-pass color-attachments depth+stencil-attachment) + render-pass? + (color-attachments render-pass-color-attachments) + (depth+stencil-attachment render-pass-depth+stencil-attachment)) + +(define* (make-render-pass #:key (color-attachments #()) + depth+stencil-attachment) + (%make-render-pass color-attachments depth+stencil-attachment)) diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm index a6e27e9..435123a 100644 --- a/chickadee/graphics/path.scm +++ b/chickadee/graphics/path.scm @@ -22,16 +22,15 @@ (define-module (chickadee graphics path) #:use-module (chickadee config) #:use-module (chickadee data array-list) - #:use-module (chickadee graphics blend) + #:use-module (chickadee data bytestruct) + #:use-module (chickadee graphics) #: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 depth-stencil) #:use-module (chickadee graphics multisample) - #:use-module (chickadee graphics polygon) + #:use-module (chickadee graphics pipeline) + #:use-module (chickadee graphics primitive) #:use-module (chickadee graphics shader) - #:use-module (chickadee graphics stencil) #:use-module (chickadee graphics texture) #:use-module (chickadee image) #:use-module (chickadee math) @@ -41,6 +40,7 @@ #:use-module (chickadee math vector) #:use-module (chickadee utils) #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) #:use-module ((rnrs base) #:select (mod)) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -892,30 +892,50 @@ ;;; Stroked path ;;; -(define-geometry-type <stroke-vertex> - stroke-vertex-ref - stroke-vertex-set! - stroke-vertex-append! - (position vec2) - (texture vec2) - (length float)) +(define-bytestruct <stroke-vertex> + (struct (position <vec2>) + (texture <vec2>) + (length f32))) + +(define-bytestruct <stroke-index> + (struct (a s32) (b s32) (c s32) (d s32) (e s32) (f s32))) + +(define-bytestruct <stroke-uniforms> + (struct (mvp <matrix4>) + (color <color>) + (feather f32) + (stroke-width f32) + (stroke-miter-limit f32) + (stroke-closed? s32) + (stroke-cap s32) + (stroke-miter-style s32))) ;; TODO: Allow for multiple path styles to be rendered in a single ;; draw call. This will probably involve abusing textures to store ;; the per-path style info. We can cross that bridge if we ever need ;; the extra performance. (define-record-type <stroked-path> - (%make-stroked-path geometry) + (%make-stroked-path vertices indices vertex-bindings bindings) stroked-path? (blend-mode stroked-path-blend-mode set-stroked-path-blend-mode!) (color stroked-path-color set-stroked-path-color!) (width stroked-path-width set-stroked-path-width!) (feather stroked-path-feather set-stroked-path-feather!) (cap stroked-path-cap set-stroked-path-cap!) - (geometry stroked-path-geometry)) + (vertices stroked-path-vertices) + (indices stroked-path-indices) + (vertex-bindings stroked-path-vertex-bindings) + (bindings stroked-path-bindings)) (define (make-stroked-path) - (%make-stroked-path (make-geometry <stroke-vertex> 32))) + (%make-stroked-path (make-dbuffer #:name "Stroked path vertex buffer") + (make-dbuffer #:name "Stroked path index buffer" + #:usage '(index)) + (make-vector 1) + (vector + (make-buffer (bytestruct-sizeof <stroke-uniforms>) + #:name "Stroked path uniform buffer" + #:usage '(uniform))))) ;; Tesselation of stroked paths involves building rectangles composed ;; of 2 triangles for each line segment in the path. This @@ -936,218 +956,260 @@ (counts (compiled-path-counts compiled-path)) (path-count (compiled-path-count compiled-path)) (padding (/ (ceiling (+ width (* feather 2.5))) 2.0)) - (geometry (stroked-path-geometry stroked-path))) + (vertices (stroked-path-vertices stroked-path)) + (indices (stroked-path-indices stroked-path))) (define (add-points first? lx ly rx ry distance) - (let ((vert-count (geometry-vertex-count geometry <stroke-vertex>))) - ;; Each vertex has the following data: - ;; - x - ;; - y - ;; - distance from starting point - ;; - distance from true line segment (used for antialising) - ;; - ;; First vertex is the left hand side, second is the right. - (stroke-vertex-append! geometry - (lx ly distance padding 0.0) - (rx ry distance (- padding) 0.0)) - ;; On the first iteration we only have 2 points which is - ;; not enough to create line segment geometry which - ;; 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))))) + ;; Each vertex has the following data: + ;; - x + ;; - y + ;; - distance from starting point + ;; - distance from true line segment (used for antialising) + ;; + ;; First vertex is the left hand side, second is the right. + (dbuffer-append! <stroke-vertex> + (((position x) lx) + ((position y) ly) + ((texture x) distance) + ((texture y) padding)) + vertices) + (dbuffer-append! <stroke-vertex> + (((position x) rx) + ((position y) ry) + ((texture x) distance) + ((texture y) (- padding))) + vertices) + ;; On the first iteration we only have 2 points which is + ;; not enough to create line segment geometry which + ;; requires looking at the newest 2 points + the 2 + ;; previous points. + (unless first? + (let ((vert-count (/ (dbuffer-length vertices) (bytestruct-sizeof <stroke-vertex>)))) + (dbuffer-append! <stroke-index> + (((a) (- vert-count 2)) + ((b) (- vert-count 4)) + ((c) (- vert-count 3)) + ((d) (- vert-count 1)) + ((e) (- vert-count 2)) + ((f) (- vert-count 3))) + indices)))) (define (set-length i length) - (stroke-vertex-set! geometry length (* i 2) length) - (stroke-vertex-set! geometry length (+ (* i 2) 1) length)) - (with-geometry geometry - (let path-loop ((i 0)) - (when (< i path-count) - (let* ((count (u32vector-ref counts i)) - (first (u32vector-ref offsets i)) - (last (+ first count -1)) - (open? (or (not (= (f32vector-ref points (* first 2)) - (f32vector-ref points (* last 2)))) - (not (= (f32vector-ref points (+ (* first 2) 1)) - (f32vector-ref points (+ (* last 2) 1)))))) - (last* (- last 1))) - (let point-loop ((j first) - ;; How far along the line segment we are. - (distance 0.0)) - (when (<= j last) - (let ((x (f32vector-ref points (* j 2))) - (y (f32vector-ref points (+ (* j 2) 1)))) - (cond - ;; Beginning cap. - ((and open? (= j first)) - (let* ((next-offset (* (+ j 1) 2)) - (next-x (f32vector-ref points next-offset)) - (next-y (f32vector-ref points (+ next-offset 1))) - (dx (- x next-x)) - (dy (- y next-y)) - (mag (sqrt (+ (* dx dx) (* dy dy)))) - (norm-x (/ dx mag)) - (norm-y (/ dy mag)) - (pad-x (* norm-x padding)) - (pad-y (* norm-y padding)) - (lx (+ x pad-x pad-y)) - (ly (- (+ y pad-y) pad-x)) - (rx (- (+ x pad-x) pad-y)) - (ry (+ y pad-y pad-x))) - (add-points #t lx ly rx ry (- padding)) - (point-loop (+ j 1) mag))) - ;; End cap. - ((and open? (= j last)) - (let* ((prev-offset (* (- j 1) 2)) - (prev-x (f32vector-ref points prev-offset)) - (prev-y (f32vector-ref points (+ prev-offset 1))) - (dx (- x prev-x)) - (dy (- y prev-y)) - (mag (sqrt (+ (* dx dx) (* dy dy)))) - (norm-x (/ dx mag)) - (norm-y (/ dy mag)) - (pad-x (* norm-x padding)) - (pad-y (* norm-y padding)) - (lx (- (+ x pad-x) pad-y)) - (ly (+ y pad-y pad-x)) - (rx (+ x pad-x pad-y)) - (ry (- (+ y pad-y) pad-x))) - (add-points #f lx ly rx ry (+ distance padding)))) - ;; Point is somewhere in the middle of the path - ;; (or the first/last point within a closed loop) - ;; and needs to be mitered. - ;; - ;; The vector math used to make a miter joint for - ;; a polyline is based on this informative forum - ;; thread: - ;; - ;; https://forum.libcinder.org/topic/smooth-thick-lines-using-geometry-shader - (else - ;; For the prev/next offsets, we need to account - ;; for closed loops. When j = last, we need the - ;; next index to be 1. Likewise, when j = - ;; first, we need the previous index to be - ;; offset + count - 1, in other words: the - ;; second to last point. This is because the - ;; first and last points of a closed loop are - ;; the same, so in order to know how to miter - ;; the first and last line segments we need to - ;; know about the second and second to last - ;; points in the compiled path buffer. The - ;; modulo operator is our best friend when it - ;; comes to wrapping values to a range. - (let* ((prev-offset (* (+ (modulo (- j first 1) - (- count 1)) - first) - 2)) - (prev-x (f32vector-ref points prev-offset)) - (prev-y (f32vector-ref points (+ prev-offset 1))) - (next-offset (* (+ (modulo (- j first) - (- count 1)) - first 1) - 2)) - (next-x (f32vector-ref points next-offset)) - (next-y (f32vector-ref points (+ next-offset 1))) - ;; Vector from (x, y) to (next-x next-y). - (ndx (- next-x x)) - (ndy (- next-y y)) - ;; Normalized form. - (nmag (sqrt (+ (* ndx ndx) (* ndy ndy)))) - (nx (if (zero? nmag) 0.0 (/ ndx nmag))) - (ny (if (zero? nmag) 0.0 (/ ndy nmag))) - ;; Vector from (prev-x, prev-y) to (x, y). - (pdx (- x prev-x)) - (pdy (- y prev-y)) - ;; Normalized form. - (pmag (sqrt (+ (* pdx pdx) (* pdy pdy)))) - (px (if (zero? pmag) 0.0 (/ pdx pmag))) - (py (if (zero? pmag) 0.0 (/ pdy pmag))) - ;; Tangent of the 2 vectors. - (tanx (+ nx px)) - (tany (+ ny py)) - ;; Normalized form. - (tanmag (sqrt (+ (* tanx tanx) (* tany tany)))) - (ntanx (if (zero? tanmag) 0.0 (/ tanx tanmag))) - (ntany (if (zero? tanmag) 0.0 (/ tany tanmag))) - ;; In order to join 2 line segments - ;; together neatly, they must have - ;; mitered corners. The miter direction - ;; is perpendicular to the tangent of the - ;; 2 line segments. - (miterx (- ntany)) - (mitery ntanx) - ;; In order to compute the proper length - ;; of the miter line, we need to project - ;; the miter vector (which is in - ;; normalized form) onto the normalized - ;; form of a vector for one of the line - ;; segments. It doesn't matter which - ;; vector is used, so I chose the vector - ;; from the current point to the - ;; previous. - (miter-dot (+ (* miterx (- py)) (* mitery px))) - (miter-length (abs (/ padding miter-dot))) - ;; The vector that will thicken the line. - (padx (* miterx miter-length)) - (pady (* mitery miter-length)) - ;; Figure out the extra distance +/- that - ;; the mitering has caused so the - ;; vertices distance attribute can be - ;; adjusted accordingly. - (padmag (sqrt (+ (* padx padx) (* pady pady)))) - ;; (npadx (if (zero? padmag) 0.0 (/ padx padmag))) - ;; (npady (if (zero? padmag) 0.0 (/ pady padmag))) - (miter-distance (sqrt (- (* padmag padmag) (* padding padding)))) - ;; Left side - (lx (+ x padx)) - (ly (+ y pady)) - ;; Right side - (rx (- x padx)) - (ry (- y pady))) - (add-points (= j first) lx ly rx ry distance) - (point-loop (+ j 1) (+ distance nmag))))))) - (when (= j last) - ;; Go over the points one more time to set the total - ;; length in each vertex. - (let length-loop ((k first)) - (when (<= k last) - (set-length k distance) - (length-loop (+ k 1))))))) - (path-loop (+ i 1))))))) + (dbuffer-pack! <stroke-vertex> + (((length) length)) + vertices + (* (bytestruct-sizeof <stroke-vertex>) (* i 2))) + (dbuffer-pack! <stroke-vertex> + (((length) length)) + vertices + (* (bytestruct-sizeof <stroke-vertex>) (1+ (* i 2))))) + (dbuffer-map! vertices) + (dbuffer-map! indices) + (let path-loop ((i 0)) + (when (< i path-count) + (let* ((count (u32vector-ref counts i)) + (first (u32vector-ref offsets i)) + (last (+ first count -1)) + (open? (or (not (= (f32vector-ref points (* first 2)) + (f32vector-ref points (* last 2)))) + (not (= (f32vector-ref points (+ (* first 2) 1)) + (f32vector-ref points (+ (* last 2) 1)))))) + (last* (- last 1))) + (let point-loop ((j first) + ;; How far along the line segment we are. + (distance 0.0)) + (when (<= j last) + (let ((x (f32vector-ref points (* j 2))) + (y (f32vector-ref points (+ (* j 2) 1)))) + (cond + ;; Beginning cap. + ((and open? (= j first)) + (let* ((next-offset (* (+ j 1) 2)) + (next-x (f32vector-ref points next-offset)) + (next-y (f32vector-ref points (+ next-offset 1))) + (dx (- x next-x)) + (dy (- y next-y)) + (mag (sqrt (+ (* dx dx) (* dy dy)))) + (norm-x (/ dx mag)) + (norm-y (/ dy mag)) + (pad-x (* norm-x padding)) + (pad-y (* norm-y padding)) + (lx (+ x pad-x pad-y)) + (ly (- (+ y pad-y) pad-x)) + (rx (- (+ x pad-x) pad-y)) + (ry (+ y pad-y pad-x))) + (add-points #t lx ly rx ry (- padding)) + (point-loop (+ j 1) mag))) + ;; End cap. + ((and open? (= j last)) + (let* ((prev-offset (* (- j 1) 2)) + (prev-x (f32vector-ref points prev-offset)) + (prev-y (f32vector-ref points (+ prev-offset 1))) + (dx (- x prev-x)) + (dy (- y prev-y)) + (mag (sqrt (+ (* dx dx) (* dy dy)))) + (norm-x (/ dx mag)) + (norm-y (/ dy mag)) + (pad-x (* norm-x padding)) + (pad-y (* norm-y padding)) + (lx (- (+ x pad-x) pad-y)) + (ly (+ y pad-y pad-x)) + (rx (+ x pad-x pad-y)) + (ry (- (+ y pad-y) pad-x))) + (add-points #f lx ly rx ry (+ distance padding)))) + ;; Point is somewhere in the middle of the path + ;; (or the first/last point within a closed loop) + ;; and needs to be mitered. + ;; + ;; The vector math used to make a miter joint for + ;; a polyline is based on this informative forum + ;; thread: + ;; + ;; https://forum.libcinder.org/topic/smooth-thick-lines-using-geometry-shader + (else + ;; For the prev/next offsets, we need to account + ;; for closed loops. When j = last, we need the + ;; next index to be 1. Likewise, when j = + ;; first, we need the previous index to be + ;; offset + count - 1, in other words: the + ;; second to last point. This is because the + ;; first and last points of a closed loop are + ;; the same, so in order to know how to miter + ;; the first and last line segments we need to + ;; know about the second and second to last + ;; points in the compiled path buffer. The + ;; modulo operator is our best friend when it + ;; comes to wrapping values to a range. + (let* ((prev-offset (* (+ (modulo (- j first 1) + (- count 1)) + first) + 2)) + (prev-x (f32vector-ref points prev-offset)) + (prev-y (f32vector-ref points (+ prev-offset 1))) + (next-offset (* (+ (modulo (- j first) + (- count 1)) + first 1) + 2)) + (next-x (f32vector-ref points next-offset)) + (next-y (f32vector-ref points (+ next-offset 1))) + ;; Vector from (x, y) to (next-x next-y). + (ndx (- next-x x)) + (ndy (- next-y y)) + ;; Normalized form. + (nmag (sqrt (+ (* ndx ndx) (* ndy ndy)))) + (nx (if (zero? nmag) 0.0 (/ ndx nmag))) + (ny (if (zero? nmag) 0.0 (/ ndy nmag))) + ;; Vector from (prev-x, prev-y) to (x, y). + (pdx (- x prev-x)) + (pdy (- y prev-y)) + ;; Normalized form. + (pmag (sqrt (+ (* pdx pdx) (* pdy pdy)))) + (px (if (zero? pmag) 0.0 (/ pdx pmag))) + (py (if (zero? pmag) 0.0 (/ pdy pmag))) + ;; Tangent of the 2 vectors. + (tanx (+ nx px)) + (tany (+ ny py)) + ;; Normalized form. + (tanmag (sqrt (+ (* tanx tanx) (* tany tany)))) + (ntanx (if (zero? tanmag) 0.0 (/ tanx tanmag))) + (ntany (if (zero? tanmag) 0.0 (/ tany tanmag))) + ;; In order to join 2 line segments + ;; together neatly, they must have + ;; mitered corners. The miter direction + ;; is perpendicular to the tangent of the + ;; 2 line segments. + (miterx (- ntany)) + (mitery ntanx) + ;; In order to compute the proper length + ;; of the miter line, we need to project + ;; the miter vector (which is in + ;; normalized form) onto the normalized + ;; form of a vector for one of the line + ;; segments. It doesn't matter which + ;; vector is used, so I chose the vector + ;; from the current point to the + ;; previous. + (miter-dot (+ (* miterx (- py)) (* mitery px))) + (miter-length (abs (/ padding miter-dot))) + ;; The vector that will thicken the line. + (padx (* miterx miter-length)) + (pady (* mitery miter-length)) + ;; Figure out the extra distance +/- that + ;; the mitering has caused so the + ;; vertices distance attribute can be + ;; adjusted accordingly. + (padmag (sqrt (+ (* padx padx) (* pady pady)))) + ;; (npadx (if (zero? padmag) 0.0 (/ padx padmag))) + ;; (npady (if (zero? padmag) 0.0 (/ pady padmag))) + (miter-distance (sqrt (- (* padmag padmag) (* padding padding)))) + ;; Left side + (lx (+ x padx)) + (ly (+ y pady)) + ;; Right side + (rx (- x padx)) + (ry (- y pady))) + (add-points (= j first) lx ly rx ry distance) + (point-loop (+ j 1) (+ distance nmag))))))) + (when (= j last) + ;; Go over the points one more time to set the total + ;; length in each vertex. + (let length-loop ((k first)) + (when (<= k last) + (set-length k distance) + (length-loop (+ k 1))))))) + (path-loop (+ i 1)))) + (dbuffer-unmap! indices) + (dbuffer-unmap! vertices))) ;;; ;;; Filled path ;;; -(define-geometry-type <fill-vertex> - fill-vertex-ref - fill-vertex-set! - fill-vertex-append! - (position vec2)) +(define-bytestruct <fill-vertex> + (struct (position <vec2>))) + +;; TODO: There's something broken with padding here. I want mode to +;; go *before* color but that seems to mess things up. +(define-bytestruct <fill-uniforms> + (struct (mvp <matrix4>) + (color <color>) + (mode s32) + (end-color <color>) + (gradient-matrix <matrix3>) + (gradient-range <vec2>) + (radial-gradient-ratio f32))) (define-record-type <filled-path> - (%make-filled-path count quad-geometry stencil-geometry) + (%make-filled-path count quad-vertices quad-indices + stencil-vertices stencil-indices + vertex-bindings bindings) filled-path? (blend-mode filled-path-blend-mode set-filled-path-blend-mode!) (color filled-path-color set-filled-path-color!) (counts filled-path-counts set-filled-path-counts!) (offsets filled-path-offsets set-filled-path-offsets!) (count filled-path-count set-filled-path-count!) - (stencil-geometry filled-path-stencil-geometry) - (quad-geometry filled-path-quad-geometry)) + (quad-vertices filled-path-quad-vertices) + (quad-indices filled-path-quad-indices) + (stencil-vertices filled-path-stencil-vertices) + (stencil-indices filled-path-stencil-indices) + (vertex-bindings filled-path-vertex-bindings) + (bindings filled-path-bindings)) (define (make-filled-path) - (let* ((quad-geometry (make-geometry <fill-vertex> 4 - #:index-capacity 6)) - (stencil-geometry (make-geometry <fill-vertex> 32 - #:index? #f - #:mode 'triangle-fan))) - (%make-filled-path 0 quad-geometry stencil-geometry))) + (%make-filled-path 0 + (make-buffer (* (bytestruct-sizeof <fill-vertex>) 4) + #:name "Filled path quad vertex buffer") + (bytevector->buffer (u32vector 0 2 3 0 1 2) + #:name "Filled path quad index buffer" + #:usage '(index)) + (make-dbuffer #:name "Filled path stencil vertex buffer") + (make-dbuffer #:name "Filled path stencil index buffer" + #:usage '(index)) + (make-vector 1) + (vector + (make-buffer (bytestruct-sizeof <fill-uniforms>) + #:name "Filled path uniform buffer" + #:usage '(uniform))))) (define* (fill-path filled-path compiled-path #:key blend-mode color) (let* ((points (compiled-path-points compiled-path)) @@ -1164,8 +1226,9 @@ ;; a sensible location. (ref-x (rect-center-x bbox)) (ref-y (rect-center-y bbox)) - (quad-geometry (filled-path-quad-geometry filled-path)) - (stencil-geometry (filled-path-stencil-geometry filled-path))) + (quad-vertices (filled-path-quad-vertices filled-path)) + (stencil-vertices (filled-path-stencil-vertices filled-path)) + (stencil-indices (filled-path-stencil-indices filled-path))) ;; Setup style. (set-filled-path-color! filled-path color) (set-filled-path-blend-mode! filled-path blend-mode) @@ -1182,7 +1245,10 @@ (u32vector-set! bv i (+ (u32vector-ref offsets i) i))) (set-filled-path-offsets! filled-path bv)) ;; Create geometry for the stencil buffer. - (geometry-begin! stencil-geometry) + ;; + ;; TODO: Convert triangle fan to strip because WebGPU does not + ;; support triangle fans. + (dbuffer-map! stencil-vertices) (for-range ((i path-count)) (let* ((count (u32vector-ref counts i)) (first (u32vector-ref offsets i))) @@ -1194,142 +1260,228 @@ ;; ;; Add reference point as the basis for each triangle in ;; the fan. - (fill-vertex-append! stencil-geometry (ref-x ref-y)) + (dbuffer-append! <fill-vertex> + (((position x) ref-x) + ((position y) ref-y)) + stencil-vertices) ;; Now simply copy all the points in the path into the ;; buffer. (for-range ((j (+ first count) first)) - (fill-vertex-append! stencil-geometry - ((f32vector-ref points (* j 2)) - (f32vector-ref points (+ (* j 2) 1))))))) - (geometry-end! stencil-geometry) + (let ((j (* j 2))) + (dbuffer-append! <fill-vertex> + (((position x) (f32vector-ref points j)) + ((position y) (f32vector-ref points (1+ j)))) + stencil-vertices))))) + (dbuffer-unmap! stencil-vertices) ;; Create simple quad covering the bounding box to be used for the ;; final render pass with stencil applied. ;; - ;; TODO: A convex hull would result in less fragments to process. - (geometry-begin! quad-geometry) + ;; TODO: Would computing a convex hull be worth it in order to + ;; process fewer fragments on the GPU? (let ((x1 (rect-x bbox)) (y1 (rect-y bbox)) (x2 (rect-right bbox)) - (y2 (rect-top bbox))) - (fill-vertex-append! quad-geometry (x1 y1) (x2 y1) (x2 y2) (x1 y2)) - (geometry-index-append! quad-geometry 0 2 3 0 1 2)) - (geometry-end! quad-geometry))) + (y2 (rect-top bbox)) + (size (bytestruct-sizeof <fill-vertex>)) + (bv (map-buffer quad-vertices 'write 0 (buffer-length quad-vertices)))) + (bytestruct-pack! <fill-vertex> + (((position x) x1) + ((position y) y1)) + bv 0) + (bytestruct-pack! <fill-vertex> + (((position x) x2) + ((position y) y1)) + bv size) + (bytestruct-pack! <fill-vertex> + (((position x) x2) + ((position y) y2)) + bv (* size 2)) + (bytestruct-pack! <fill-vertex> + (((position x) x1) + ((position y) y2)) + bv (* size 3)) + (unmap-buffer quad-vertices)))) ;;; ;;; Rendering ;;; +(define (load-file file-name) + (call-with-input-file file-name get-string-all)) + (define-graphics-variable stroke-shader - (load-shader (scope-datadir "shaders/path-stroke-vert.glsl") - (scope-datadir "shaders/path-stroke-frag.glsl"))) + (make-shader + (lambda (lang) + (values (load-file (scope-datadir "shaders/path-stroke-vert.glsl")) + (load-file (scope-datadir "shaders/path-stroke-frag.glsl")))))) (define-graphics-variable fill-shader - (load-shader (scope-datadir "shaders/path-fill-vert.glsl") - (scope-datadir "shaders/path-fill-frag.glsl"))) + (make-shader + (lambda (lang) + (values (load-file (scope-datadir "shaders/path-fill-vert.glsl")) + (load-file (scope-datadir "shaders/path-fill-frag.glsl")))))) (define-graphics-variable mvp-matrix (make-null-matrix4)) -(define stencil-flip - (make-stencil-test #:on-pass 'invert)) - -(define stencil-cover-and-clear - (make-stencil-test #:on-fail 'zero #:on-depth-fail 'zero #:on-pass 'zero - #:function 'not-equal)) - -(define *debug?* #f) +(define-graphics-variable fill-stencil-pipeline + (make-render-pipeline + #:name "Filled path stencil pipeline" + #:shader (graphics-variable-ref fill-shader) + #:color-target (make-color-target #:mask (make-color-mask #f #f #f #f)) + #:primitive (make-primitive-mode #:topology 'triangle-fan + #:front-face 'cw) + #:depth+stencil (make-depth+stencil + #:stencil-face (make-stencil-face #:pass-op 'invert)) + #:vertex-layout (vector (make-vertex-buffer-layout + #:stride (bytestruct-sizeof <fill-vertex>) + #:attributes (vector + (make-vertex-attribute + #:format 'float32x2)))) + #:binding-layout (vector (make-buffer-layout)))) + +;; TODO: This needs to be part of the <filled-path> struct so we can +;; build a pipeline with the desired blend mode! +(define-graphics-variable fill-quad-pipeline + (make-render-pipeline + #:name "Filled path quad pipeline" + #:shader (graphics-variable-ref fill-shader) + ;; Anti-alias the edges of the fill with multisampling. + #:multisample (make-multisample #:count 4) + #:depth+stencil (make-depth+stencil + #:stencil-face (make-stencil-face #:compare 'not-equal + #:fail-op 'zero + #:depth-fail-op 'zero + #:pass-op 'zero)) + #:vertex-layout (vector (make-vertex-buffer-layout + #:stride (bytestruct-sizeof <fill-vertex>) + #:attributes (vector + (make-vertex-attribute + #:format 'float32x2)))) + #:binding-layout (vector (make-buffer-layout)))) (define* (draw-filled-path filled-path matrix) - (let ((shader (graphics-variable-ref fill-shader)) - (mvp (graphics-variable-ref mvp-matrix)) - (counts (filled-path-counts filled-path)) - (offsets (filled-path-offsets filled-path)) - (n (filled-path-count filled-path)) - (quad-geometry (filled-path-quad-geometry filled-path)) - (stencil-geometry (filled-path-stencil-geometry filled-path))) - (matrix4-mult! mvp matrix (current-projection)) - ;; Wireframe debug mode. - (when *debug?* - (with-graphics-state ((g:polygon-mode line-polygon-mode)) - (for-range ((i n)) - (shader-apply* shader - (geometry-vertex-array stencil-geometry) - (u32vector-ref offsets i) - (u32vector-ref counts i) - #:mvp (current-projection))))) - ;; Anti-alias the edges of the fill. - (with-graphics-state ((g: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, - ;; it sets the stencil bits for all fragments to 1. Then, when - ;; an overlapping triangle is rendered, it sets all the stencil - ;; bits for the overlapped fragments back to 0. This neat hack - ;; implements the non-zero rule for determining whether or not a - ;; point is inside a closed path. - ;; - ;; 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)) - (for-range ((i n)) - (shader-apply* shader - (geometry-vertex-array stencil-geometry) - (u32vector-ref offsets i) - (u32vector-ref counts i) - #:mvp mvp))) - ;; 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))) - (let ((color (filled-path-color filled-path))) - (if (gradient? color) - ;; Linear/radial gradient fill. - (shader-apply shader - (geometry-vertex-array quad-geometry) - #:mvp mvp - #:color (gradient-start-color color) - #:end-color (gradient-end-color color) - #:gradient-matrix (gradient-matrix color) - #:gradient-range (gradient-range color) - #:radial-gradient-ratio (gradient-radial-ratio color) - #:mode (case (gradient-type color) - ((linear) 1) - ((radial) 2))) - ;; Solid fill. - (shader-apply shader - (geometry-vertex-array quad-geometry) - #:mvp mvp - #:color (filled-path-color filled-path) - #:mode 0))))))) + (match filled-path + (($ <filled-path> blend-mode color counts offsets n + quad-vertices quad-indices + stencil-vertices stencil-indices vertex-bindings + (and bindings #(uniforms))) + (let ((stencil-pipeline (graphics-variable-ref fill-stencil-pipeline)) + (quad-pipeline (graphics-variable-ref fill-quad-pipeline)) + (mvp (graphics-variable-ref mvp-matrix))) + (matrix4-mult! mvp matrix (current-projection)) + (let ((bv (map-buffer uniforms 'write 0 + (bytestruct-sizeof <fill-uniforms>)))) + (bytestruct-pack! <fill-uniforms> + (((mvp) mvp)) + bv 0) + (match color + ;; Linear/radial gradient fill. + (($ <gradient> type matrix start-color end-color range radial-ratio) + (bytestruct-pack! <fill-uniforms> + (((mode) + (match type + ('linear 1) + ('radial 2))) + ((color) start-color) + ((end-color) end-color) + ((gradient-matrix) matrix) + ((gradient-range) range) + ((radial-gradient-ratio) radial-ratio)) + bv 0)) + ;; Solid fill. + (_ + (bytestruct-pack! <fill-uniforms> + (((mode) 0) + ((color) color)) + bv 0))) + (unmap-buffer uniforms)) + ;; 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, + ;; it sets the stencil bits for all fragments to 1. Then, when + ;; an overlapping triangle is rendered, it sets all the stencil + ;; bits for the overlapped fragments back to 0. This neat hack + ;; implements the non-zero rule for determining whether or not a + ;; point is inside a closed path. + ;; + ;; For more information, see: + ;; http://developer.download.nvidia.com/devzone/devcenter/gamegraphics/files/opengl/gpupathrender.pdf + (vector-set! vertex-bindings 0 (dbuffer-buffer stencil-vertices)) + (for-range ((i n)) + ;; TODO: Use a different shader for this pass because we + ;; don't care about color so using the fill shader is just + ;; wasted cycles. + (draw (u32vector-ref counts i) + #:start (u32vector-ref offsets i) + #:pipeline stencil-pipeline + #:vertex-buffers vertex-bindings + ;; #:index-buffer (dbuffer-buffer stencil-indices) + #:bindings bindings)) + ;; 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. + (vector-set! vertex-bindings 0 quad-vertices) + (draw 6 + #:pipeline quad-pipeline + #:vertex-buffers vertex-bindings + #:index-buffer quad-indices + #:bindings bindings))))) + +;; TODO: Make part of <stroked-path> to accomodate blend mode. +(define-graphics-variable stroke-pipeline + (make-render-pipeline + #:name "Stroked path pipeline" + #:shader (graphics-variable-ref stroke-shader) + #:color-target (make-color-target #:blend-mode blend:alpha) + #:vertex-layout (vector (make-vertex-buffer-layout + #:stride (bytestruct-sizeof <stroke-vertex>) + #:attributes (vector + (make-vertex-attribute + #:format 'float32x2) + (make-vertex-attribute + #:format 'float32x2 + #:offset (* 2 4)) + (make-vertex-attribute + #:format 'float32 + #:offset (* 4 4))))) + #:binding-layout (vector (make-buffer-layout)))) ;; TODO: dashed stroke ;; TODO: miter styles and miter limit (define* (draw-stroked-path stroked-path matrix) - (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))) - (let ((geometry (stroked-path-geometry stroked-path))) - (shader-apply* shader - (geometry-vertex-array geometry) - 0 - (geometry-index-count geometry) - #:mvp mvp - #:color (stroked-path-color stroked-path) - #:feather (stroked-path-feather stroked-path) - #:stroke-cap (case (stroked-path-cap stroked-path) - ((#f) 0) ; no cap - ((butt) 1) - ((square) 2) - ((round) 3) - ((triangle-out) 4) - ((triangle-in) 5) - (else - (error "unsupported line cap style" - (stroked-path-cap stroked-path)))) - #:stroke-width (stroked-path-width stroked-path)))))) + (match stroked-path + (($ <stroked-path> blend-mode color width feather cap vertices indices + vertex-bindings (and bindings #(uniforms))) + (let ((mvp (graphics-variable-ref mvp-matrix)) + (pipeline (graphics-variable-ref stroke-pipeline))) + (matrix4-mult! mvp matrix (current-projection)) + (let ((bv (map-buffer uniforms 'write 0 + (bytestruct-sizeof <stroke-uniforms>)))) + (bytestruct-pack! <stroke-uniforms> + (((mvp) mvp) + ((color) color) + ((feather) feather) + ((stroke-closed?) 0) + ((stroke-width) width) + ((stroke-cap) + (match cap + (#f 0) ; no cap + ('butt 1) + ('square 2) + ('round 3) + ('triangle-out 4) + ('triangle-in 5))) + ((stroke-miter-style) 0) + ((stroke-miter-limit) 0)) + bv 0) + (unmap-buffer uniforms)) + (vector-set! vertex-bindings 0 (dbuffer-buffer vertices)) + (draw (/ (dbuffer-length indices) 4) + #:pipeline pipeline + #:index-buffer (dbuffer-buffer indices) + #:vertex-buffers vertex-bindings + #:bindings bindings))))) ;;; @@ -1638,18 +1790,18 @@ (define (draw-canvas canvas) (draw-canvas* canvas %identity-matrix)) -(define (canvas->pixbuf canvas) - "Return a new pixbuf containing the rasterized CANVAS." - (let* ((bb (painter-bounding-box (canvas-painter canvas))) - (width (inexact->exact (ceiling (rect-width bb)))) - (height (inexact->exact (ceiling (rect-height bb)))) - (framebuffer (make-framebuffer width height))) - (with-framebuffer framebuffer - (draw-canvas* canvas (make-identity-matrix4))) - (texture->pixbuf (framebuffer-texture framebuffer)))) - -(define* (write-canvas canvas - #:optional (file-name (temp-image-file-name 'png)) - #:key (format 'png)) - "Write CANVAS to FILE-NAME using FORMAT ('png' by default.)" - (write-image (canvas->pixbuf canvas) file-name #:format format)) +;; (define (canvas->pixbuf canvas) +;; "Return a new pixbuf containing the rasterized CANVAS." +;; (let* ((bb (painter-bounding-box (canvas-painter canvas))) +;; (width (inexact->exact (ceiling (rect-width bb)))) +;; (height (inexact->exact (ceiling (rect-height bb)))) +;; (framebuffer (make-framebuffer width height))) +;; (with-framebuffer framebuffer +;; (draw-canvas* canvas (make-identity-matrix4))) +;; (texture->pixbuf (framebuffer-texture framebuffer)))) + +;; (define* (write-canvas canvas +;; #:optional (file-name (temp-image-file-name 'png)) +;; #:key (format 'png)) +;; "Write CANVAS to FILE-NAME using FORMAT ('png' by default.)" +;; (write-image (canvas->pixbuf canvas) file-name #:format format)) diff --git a/chickadee/graphics/pbr.scm b/chickadee/graphics/pbr.scm index a2c7251..0abb9eb 100644 --- a/chickadee/graphics/pbr.scm +++ b/chickadee/graphics/pbr.scm @@ -49,20 +49,21 @@ pbr-shader make-pbr-material)) -(define-shader-type <pbr-properties> - make-pbr-properties - pbr-properties? - (float-vec3 base-color-factor pbr-properties-base-color-factor) - (int base-color-texcoord pbr-properties-base-color-texcoord) - (float metallic-factor pbr-properties-metallic-factor) - (float roughness-factor pbr-properties-roughness-factor) - (int metallic-roughness-texcoord pbr-properties-metallic-roughness-texcoord) - (int normal-texcoord pbr-properties-normal-texcoord) - (int occlusion-texcoord pbr-properties-occlusion-texcoord) - (float-vec3 emissive-factor pbr-properties-emissive-factor) - (int emissive-texcoord pbr-properties-emissive-texcoord) - (int alpha-mode pbr-properties-alpha-mode) - (float alpha-cutoff pbr-properties-alpha-cutoff)) +(define <pbr-properties> #f) +;; (define-shader-type <pbr-properties> +;; make-pbr-properties +;; pbr-properties? +;; (float-vec3 base-color-factor pbr-properties-base-color-factor) +;; (int base-color-texcoord pbr-properties-base-color-texcoord) +;; (float metallic-factor pbr-properties-metallic-factor) +;; (float roughness-factor pbr-properties-roughness-factor) +;; (int metallic-roughness-texcoord pbr-properties-metallic-roughness-texcoord) +;; (int normal-texcoord pbr-properties-normal-texcoord) +;; (int occlusion-texcoord pbr-properties-occlusion-texcoord) +;; (float-vec3 emissive-factor pbr-properties-emissive-factor) +;; (int emissive-texcoord pbr-properties-emissive-texcoord) +;; (int alpha-mode pbr-properties-alpha-mode) +;; (float alpha-cutoff pbr-properties-alpha-cutoff)) (define %pbr-shader (delay (load-shader (scope-datadir "shaders/pbr-vert.glsl") diff --git a/chickadee/graphics/phong.scm b/chickadee/graphics/phong.scm index 8812a9a..5c00d60 100644 --- a/chickadee/graphics/phong.scm +++ b/chickadee/graphics/phong.scm @@ -42,13 +42,14 @@ phong-shader make-phong-material)) -(define-shader-type <phong-properties> - make-phong-properties - phong-properties? - (float-vec3 ambient phong-properties-ambient) - (float-vec3 diffuse phong-properties-diffuse) - (float-vec3 specular phong-properties-specular) - (float shininess phong-properties-shininess)) +(define <phong-properties> #f) +;; (define-shader-type <phong-properties> +;; make-phong-properties +;; phong-properties? +;; (float-vec3 ambient phong-properties-ambient) +;; (float-vec3 diffuse phong-properties-diffuse) +;; (float-vec3 specular phong-properties-specular) +;; (float shininess phong-properties-shininess)) (define %phong-shader (delay (load-shader (scope-datadir "shaders/phong-vert.glsl") diff --git a/chickadee/graphics/pipeline.scm b/chickadee/graphics/pipeline.scm new file mode 100644 index 0000000..a24feb2 --- /dev/null +++ b/chickadee/graphics/pipeline.scm @@ -0,0 +1,110 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary: +;; +;; GPU pipelines. +;; +;;; Code: + +(define-module (chickadee graphics pipeline) + #:use-module ((chickadee graphics backend) #:prefix gpu:) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics depth-stencil) + #:use-module (chickadee graphics layout) + #:use-module (chickadee graphics primitive) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (make-render-pipeline + destroy-render-pipeline + render-pipeline? + render-pipeline-name + render-pipeline-shader + render-pipeline-primitive + render-pipeline-color-target + render-pipeline-depth+stencil + render-pipeline-vertex-layout + render-pipeline-binding-layout) + #:re-export (make-vertex-attribute + vertex-attribute? + vertex-attribute-format + vertex-attribute-offset + + make-vertex-buffer-layout + vertex-buffer-layout? + vertex-buffer-layout-stride + vertex-buffer-layout-step-mode + vertex-buffer-layout-attributes + + make-texture-layout + texture-layout? + texture-layout-sample-type + texture-layout-dimension + texture-layout-multisample? + + make-sampler-layout + sampler-layout? + sampler-layout-type + + make-buffer-layout + buffer-layout? + buffer-layout-type + buffer-layout-min-size)) + +(define shader-handle (@@ (chickadee graphics shader) shader-handle)) + +(define-record-type <render-pipeline> + (%make-render-pipeline gpu handle name shader primitive color-target + depth+stencil multisample vertex-layout binding-layout) + render-pipeline? + (gpu render-pipeline-gpu) + (handle render-pipeline-handle) + (name render-pipeline-name) + (destroyed? render-pipeline-destroyed? set-render-pipeline-destroyed!) + (shader render-pipeline-shader) + (primitive render-pipeline-primitive) + (color-target render-pipeline-color-target) + (depth+stencil render-pipeline-depth+stencil) + (multisample render-pipeline-multisample) + (vertex-layout render-pipeline-vertex-layout) + (binding-layout render-pipeline-binding-layout)) + +(define (print-render-pipeline pipeline port) + (format port "#<render-pipeline name: ~a>" + (render-pipeline-name pipeline))) + +(set-record-type-printer! <render-pipeline> print-render-pipeline) + +(define* (make-render-pipeline #:key name shader + (primitive (make-primitive-mode)) + (color-target (make-color-target)) + depth+stencil + multisample + (vertex-layout #()) + (binding-layout #())) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-render-pipeline gpu (shader-handle shader) + primitive color-target depth+stencil + multisample vertex-layout + binding-layout))) + (%make-render-pipeline gpu handle name shader primitive color-target + multisample depth+stencil vertex-layout binding-layout))) + +(define (destroy-render-pipeline pipeline) + (unless (render-pipeline-destroyed? pipeline) + (gpu:destroy-render-pipeline (gpu:current-gpu) + (render-pipeline-handle pipeline)) + (set-render-pipeline-destroyed! pipeline #t))) diff --git a/chickadee/graphics/primitive.scm b/chickadee/graphics/primitive.scm new file mode 100644 index 0000000..d63aed2 --- /dev/null +++ b/chickadee/graphics/primitive.scm @@ -0,0 +1,41 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary +;; +;; Primitive rendering configuration. +;; +;;; Code: + +(define-module (chickadee graphics primitive) + #:use-module (srfi srfi-9) + #:export (make-primitive-mode + primitive-mode? + primitive-mode-topology + primitive-mode-front-face + primitive-mode-cull-face)) + +(define-record-type <primitive-mode> + (%make-primitive-mode topology front-face cull-face) + primitive-mode? + (topology primitive-mode-topology) + (front-face primitive-mode-front-face) + (cull-face primitive-mode-cull-face)) + +(define* (make-primitive-mode #:key + (topology 'triangle-list) + (front-face 'ccw) + (cull-face 'back)) + (%make-primitive-mode topology front-face cull-face)) diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm index ab0a8cf..4990487 100644 --- a/chickadee/graphics/shader.scm +++ b/chickadee/graphics/shader.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2019, 2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2016-2023 David Thompson <dthompson2@worcester.edu> ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. @@ -25,881 +25,923 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module (gl) #:use-module (chickadee data bytestruct) #:use-module (chickadee math matrix) #:use-module (chickadee math vector) #:use-module (chickadee math rect) - #:use-module (chickadee graphics buffer) - #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) - #:use-module (chickadee graphics texture) + #:use-module ((chickadee graphics backend) #:prefix gpu:) + ;; #:use-module (chickadee graphics buffer) + ;; #:use-module (chickadee graphics color) + ;; #:use-module (chickadee graphics texture) #:use-module (chickadee utils) - #:export (shader-data-type? - bool - int - unsigned-int - float - float-vec2 - float-vec3 - float-vec4 - mat3 - mat4 - sampler-2d - sampler-cube - local-field - define-shader-type - uniform-namespace? - uniform-namespace-ref - uniform-namespace-for-each - make-shader + #:export (make-shader + destroy-shader shader? - null-shader - g:shader - current-shader - load-shader - strings->shader - shader-uniform - shader-uniforms - shader-attributes - shader-uniform-set! - shader-uniform-for-each - set-uniform-value! - uniform? - uniform-name - uniform-type - uniform-value - attribute? - attribute-name - attribute-location - attribute-type - shader-apply - shader-apply* - shader-apply/instanced* - shader-apply/instanced)) - - -;;; -;;; Primitive Shader Data Types -;;; - -(define-record-type <shader-primitive-type> - (%make-shader-primitive-type name size validator serializer setter null) - shader-primitive-type? - (name shader-primitive-type-name) - (size shader-primitive-type-size) - (validator shader-primitive-type-validator) - (serializer shader-primitive-type-serializer) - (setter shader-primitive-type-setter) - (null shader-primitive-type-null)) - -(define (display-shader-primitive-type type port) - (format port "#<shader-primitive-type name: ~a size: ~d null: ~a>" - (shader-primitive-type-name type) - (shader-primitive-type-size type) - (shader-primitive-type-null type))) - -(set-record-type-printer! <shader-primitive-type> display-shader-primitive-type) - -(define* (make-shader-primitive-type #:key name size validator serializer setter null) - (%make-shader-primitive-type name size validator serializer setter null)) - -(define (shader-primitive-type-serialize type bv data) - (let ((serialize (shader-primitive-type-serializer type))) - (if (vector? data) - (let ((size (shader-primitive-type-size type))) - (for-range ((i (vector-length data))) - (serialize bv (* i size) (vector-ref data i)))) - (serialize bv 0 data)))) - -(define (shader-primitive-type-apply-uniform type location count pointer) - ((shader-primitive-type-setter type) location count pointer)) - -(define (shader-primitive-type-validate type data) - (let ((valid? (shader-primitive-type-validator type))) - (if (vector? data) - (let loop ((i 0)) - (if (and (< i (vector-length data)) - (valid? (vector-ref data i))) - (loop (+ i 1)) - #t)) - (valid? data)))) - -(define-syntax-rule (define-shader-primitive-type var . args) - (define var (make-shader-primitive-type . args))) - -;; Primitive types: -(define-shader-primitive-type bool - #:name 'bool - #:size 4 - #:validator boolean? - #:serializer - (lambda (bv i bool) - (bytevector-s32-native-set! bv i (if bool 1 0))) - #:setter gl-uniform1iv - #:null #false) - -(define-shader-primitive-type int - #:name 'int - #:size 4 - #:validator integer? - #:serializer - (lambda (bv i n) - (bytevector-s32-native-set! bv i n)) - #:setter gl-uniform1iv - #:null 0) - -(define-shader-primitive-type unsigned-int - #:name 'unsigned-int - #:size 4 - #:validator - (lambda (i) - (and (integer? i) (>= i 0))) - #:serializer - (lambda (bv i u) - (bytevector-u32-native-set! bv i u)) - #:setter gl-uniform1uiv - #:null 0) - -(define-shader-primitive-type float - #:name 'float - #:size 4 - #:validator number? - #:serializer - (lambda (bv i f) - (bytevector-ieee-single-native-set! bv i f)) - #:setter gl-uniform1fv - #:null 0.0) - -(define-shader-primitive-type float-vec2 - #:name 'float-vec2 - #:size 8 ; 8 bytes = 2 floats = 1 vec2 - #:validator vec2? - #:serializer - (lambda (bv i v) - (bytestruct-pack! <vec2> ((() v)) bv i)) - #:setter gl-uniform2fv - #:null (vec2 0.0 0.0)) - -(define-shader-primitive-type float-vec3 - #:name 'float-vec3 - #:size 12 ; 12 bytes = 3 floats = 1 vec3 - #:validator vec3? - #:serializer - (lambda (bv i v) - (bytestruct-pack! <vec3> ((() v)) bv i)) - #:setter gl-uniform3fv - #:null (vec3 0.0 0.0 0.0)) - -(define-shader-primitive-type float-vec4 - #:name 'float-vec4 - #:size 16 ; 16 bytes = 4 floats = 1 vec4 - #:validator (lambda (x) (or (rect? x) (color? x))) - #:serializer - (lambda (bv i x) - ;; As of now, there is no vec4 Scheme type, but we do want to - ;; accept colors and rects as vec4s since there is no special - ;; color or rect type in GLSL. - (if (rect? x) - (bytestruct-pack! <rect> ((() x)) bv i) - (bytestruct-pack! <color> ((() x)) bv i))) - #:setter gl-uniform4fv - #:null (make-null-rect)) - -(define-shader-primitive-type mat3 - #:name 'mat3 - #:size (* 3 3 4) ; 3 rows x 3 columns x 4 byte floats - #:validator matrix3? - #:serializer - (lambda (bv i m) - (bytestruct-pack! <matrix3> ((() m)) bv i)) - #:setter (lambda (location count ptr) - (gl-uniform-matrix3fv location count #f ptr)) - #:null (make-identity-matrix3)) - -(define-shader-primitive-type mat4 - #:name 'mat4 - #:size (bytestruct-sizeof <matrix4>) ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes - #:validator matrix4? - #:serializer - (lambda (bv i m) - ;; (match m - ;; (($ <matrix4> src offset) - ;; (bytevector-copy! src offset bv i - ;; (bytestruct-sizeof <matrix4>)))) - (bytestruct-pack! <matrix4> ((() m)) bv i) - ) - #:setter (lambda (location count ptr) - (gl-uniform-matrix4fv location count #f ptr)) - #:null (make-identity-matrix4)) - -(define-shader-primitive-type sampler-2d - #:name 'sampler-2d - #:size 4 - #:validator integer? - #:serializer - (lambda (bv i texture-unit) - (bytevector-s32-native-set! bv i texture-unit)) - #:setter gl-uniform1iv - #:null 0) - -(define-shader-primitive-type sampler-cube - #:name 'sampler-cube - #:size 4 - #:validator integer? - #:serializer - (lambda (bv i texture-unit) - (bytevector-s32-native-set! bv i texture-unit)) - #:setter gl-uniform1iv - #:null 0) - - -;;; -;;; Compound Shader Data Types -;;; - -;; A meta-vtable that has two additional slots: one for the struct -;; name, and another for the lookup table that maps struct field names -;; to their respective struct index and shader data type. -(define <shader-struct> - (make-vtable (string-append standard-vtable-fields "pwpw") - (lambda (vt port) - (format port "#<shader-struct ~a>" - (shader-struct-fields vt))))) - -(define local-field (gensym "local-shader-field-")) - -(define (shader-struct? struct) - (eq? (struct-vtable (struct-vtable struct)) <shader-struct>)) - -(define shader-struct-name-index vtable-offset-user) -(define shader-struct-fields-index (+ vtable-offset-user 1)) - -(define (shader-struct-name vtable) - (struct-ref vtable shader-struct-name-index)) - -(define (shader-struct-fields vtable) - (struct-ref vtable shader-struct-fields-index)) - -(define (shader-struct-type-check vtable field value) - (match (assq-ref (shader-struct-fields vtable) field) - ((_ type size) - (define (validate value) - (unless (or (and (struct? value) (eq? (struct-vtable value) type)) - (shader-primitive-type-validate type value)) - (error "invalid type for shader struct field" field value))) - (cond - ((eq? type local-field) - #t) - ((= size 1) - (validate value)) - ((and (vector? value) - (= (vector-length value) size)) - (for-range ((i (vector-length value))) - (validate (vector-ref value i)))) - ((vector? value) - (error "incorrect vector size" value)) - (else - (error "expected vector, got" value)))))) - -(define (shader-struct-default vtable field) - (match (assq-ref (shader-struct-fields vtable) field) - ((_ type size) - (let ((default (cond - ((eq? type local-field) - #f) - ((eq? (struct-vtable type) <shader-struct>) - (apply make-struct/no-tail type - (map (match-lambda - ((sub-field _ _ _) - (shader-struct-default type sub-field))) - (shader-struct-fields type)))) - (else - (shader-primitive-type-null type))))) - (if (= size 1) - default - (make-vector size default)))))) - -(define (make-shader-struct-field-table fields+types) - ;; Map field names to their struct indices and shader types. - (let loop ((i 0) - (fields+types fields+types)) - (match fields+types - (() '()) - (((name #(type size)) . rest) - (cons (list name i type size) - (loop (+ i 1) rest))) - (((name type) . rest) - (cons (list name i type 1) - (loop (+ i 1) rest)))))) - -(define (display-shader-struct-instance obj port) - (let ((vtable (struct-vtable obj))) - (format port "#<~a" (shader-struct-name vtable)) - (let loop ((fields (shader-struct-fields vtable))) - (match fields - (() #f) - (((name index type size) . rest) - (format port " ~a[~d ~a]: ~a" - name size - (if (eq? type local-field) - 'local - (shader-primitive-type-name type)) - (struct-ref obj index)) - (loop rest)))) - (display ">" port))) - -(define (make-display-name sym) - (let ((str (symbol->string sym))) - (if (and (string-prefix? "<" str) - (string-suffix? ">" str)) - (substring str 1 (- (string-length str) 1)) - str))) - -(define (make-shader-struct name fields+types) - (make-struct/no-tail <shader-struct> - (make-struct-layout - (string-concatenate - (map (const "pw") fields+types))) - display-shader-struct-instance - (make-display-name name) - (make-shader-struct-field-table fields+types))) - -(define (shader-struct-ref struct field) - (match (assq-ref (shader-struct-fields (struct-vtable struct)) field) - (#f - (error "unknown struct field" field)) - ((index _ _) - (struct-ref struct index)))) - -(define-syntax define-accessors - (syntax-rules () - ((_ <struct> field getter) - (define getter - (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field) - ((i _ _) i)))) - (lambda (obj) - (struct-ref obj index))))) - ((_ <struct> field getter setter) - (begin - (define-accessors <struct> field getter) - (define setter - (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field) - ((i _ _) i)))) - (lambda (obj value) - (shader-struct-type-check <struct> 'field value) - (struct-set! obj index value)))))))) - -(define-syntax define-shader-type - (syntax-rules () - ((_ <name> constructor predicate (field-type field-name . field-rest) ...) - (begin - (define <name> - (make-shader-struct '<name> (list (list 'field-name field-type) ...))) - (define* (constructor #:key (field-name (shader-struct-default <name> 'field-name)) ...) - (shader-struct-type-check <name> 'field-name field-name) ... - (make-struct/no-tail <name> field-name ...)) - (define (predicate obj) - (and (struct? obj) (eq? (struct-vtable obj) <name>))) - (define-accessors <name> field-name . field-rest) ...)))) - - -;;; -;;; Shaders -;;; + shader-vertex + shader-fragment + shader-destroyed? + + ;; shader-data-type? + ;; bool + ;; int + ;; unsigned-int + ;; float + ;; float-vec2 + ;; float-vec3 + ;; float-vec4 + ;; mat3 + ;; mat4 + ;; sampler-2d + ;; sampler-cube + ;; local-field + ;; define-shader-type + ;; uniform-namespace? + ;; uniform-namespace-ref + ;; uniform-namespace-for-each + ;; make-shader + ;; shader? + ;; null-shader + ;; g:shader + ;; current-shader + ;; load-shader + ;; strings->shader + ;; shader-uniform + ;; shader-uniforms + ;; shader-attributes + ;; shader-uniform-set! + ;; shader-uniform-for-each + ;; set-uniform-value! + ;; uniform? + ;; uniform-name + ;; uniform-type + ;; uniform-value + ;; attribute? + ;; attribute-name + ;; attribute-location + ;; attribute-type + ;; shader-apply + ;; shader-apply* + ;; shader-apply/instanced* + ;; shader-apply/instanced + )) (define-record-type <shader> - (%make-shader id attributes uniforms scratch scratch-pointer) + (%make-shader gpu handle name state) shader? - (id shader-id) - (attributes shader-attributes) - (uniforms shader-uniforms) - ;; Scratch space for serializing uniform values. - (scratch shader-scratch) - ;; Create the pointer once and hold onto it to reduce needless - ;; garbage creation. - (scratch-pointer shader-scratch-pointer)) - -;; Represents a single active uniform location in a shader program. -(define-record-type <uniform> - (make-uniform name location type size value) - uniform? - (name uniform-name) - (location uniform-location) - (type uniform-type) - (size uniform-size) - (value uniform-value %set-uniform-value!)) - -(define (sampler? uniform) - (or (eq? (uniform-type uniform) sampler-2d) - (eq? (uniform-type uniform) sampler-cube))) - -;; variable name -> {uniform, namespace, uniform array} map -(define-record-type <uniform-namespace> - (make-uniform-namespace name members) - uniform-namespace? - (name uniform-namespace-name) - (members uniform-namespace-members)) - -(define (fresh-uniform-namespace name) - (make-uniform-namespace name (make-hash-table))) - -(define (uniform-namespace-set! namespace name value) - (hashq-set! (uniform-namespace-members namespace) name value)) - -(define (uniform-namespace-ref namespace name) - (hashq-ref (uniform-namespace-members namespace) name)) - -(define (uniform-namespace-ref-or-create-namespace namespace name) - (or (uniform-namespace-ref namespace name) - (let ((new-ns (fresh-uniform-namespace name))) - (uniform-namespace-set! namespace name new-ns) - new-ns))) - -(define (uniform-namespace-ref-or-create-array namespace name) - (or (uniform-namespace-ref namespace name) - (let ((new-arr (fresh-uniform-array name))) - (uniform-namespace-set! namespace name new-arr) - new-arr))) - -(define (uniform-namespace-for-each proc namespace) - (hash-for-each proc (uniform-namespace-members namespace))) - -;; variable name -> {uniform, namespace} map -(define-record-type <uniform-array> - (make-uniform-array name namespaces size) - uniform-array? - (name uniform-array-name) - (namespaces uniform-array-namespaces) - (size uniform-array-size set-uniform-array-size!)) - -(define (fresh-uniform-array name) - (make-uniform-array name (make-hash-table) 0)) - -(define (uniform-array-namespace-ref array i) - (hashv-ref (uniform-array-namespaces array) i)) - -(define (uniform-array-namespace-add! array i) - (let ((ns (fresh-uniform-namespace (uniform-array-name array)))) - (hashv-set! (uniform-array-namespaces array) i ns) - (set-uniform-array-size! array (max (uniform-array-size array) (+ i 1))) - ns)) - -(define (uniform-array-ref-or-create array i) - (or (uniform-array-namespace-ref array i) - (uniform-array-namespace-add! array i))) - -(define-record-type <attribute> - (make-attribute name location type) - attribute? - (name attribute-name) - (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 (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) - (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) - (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) - (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)) - (utf8->string log)))) - (define (compilation-error id) - (info-log gl-get-shaderiv gl-get-shader-info-log id)) - (define (linking-error id) - (info-log gl-get-programiv gl-get-program-info-log id)) - (define (glsl-preprocessor-source) - ;; 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))) - (cond - ((string>= glsl-version "3.3") - "#version 330 -#define GLSL330 -") - ((string>= glsl-version "1.3") - "#version 130 -#define GLSL130 -") - ((string>= glsl-version "1.2") - "#version 120 -#define GLSL120 -") - (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 - (bytevector->pointer - (u64vector - (pointer-address (bytevector->pointer source)))) - (bytevector->pointer - (u32vector (bytevector-length source)))) - (gl-compile-shader id) - (unless (shader-compiled? id) - (let ((error-log (compilation-error id))) - (gl-delete-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 - (arb-shader-objects active-uniforms) - (bytevector->pointer bv)) - (u32vector-ref bv 0))) - (define (utf8->string* bv length) - (let ((bv* (make-bytevector length))) - (bytevector-copy! bv 0 bv* 0 length) - (utf8->string bv*))) - (define (parse-data-type type) - (cond - ((= type (version-2-0 bool)) bool) - ((= type (data-type int)) int) - ((= type (data-type unsigned-int)) unsigned-int) - ((= type (data-type float)) float) - ((= type (version-2-0 float-vec2)) float-vec2) - ((= type (version-2-0 float-vec3)) float-vec3) - ((= type (version-2-0 float-vec4)) float-vec4) - ((= type (version-2-0 float-mat3)) mat3) - ((= type (version-2-0 float-mat4)) mat4) - ((= type (version-2-0 sampler-2d)) sampler-2d) - ((= type (version-2-0 sampler-cube)) sampler-cube) - (else - (error "unsupported OpenGL type" type)))) - (define (camel->snake str) - (list->string - (let loop ((i 0)) - (if (< i (string-length str)) - (let ((c (string-ref str i))) - (if (char-set-contains? char-set:upper-case c) - (cons* #\- (char-downcase c) (loop (+ i 1))) - (cons c (loop (+ i 1))))) - '())))) - (define (uniform-name->symbol name) - ;; array uniform names have a suffix like "[0]" that needs to be - ;; removed to produce the actual uniform variable name that our - ;; shader interface will recognize. - (string->symbol - (let ((i (string-contains name "["))) - (camel->snake - (if i (substring name 0 i) name))))) - (define (parse-array-index name) - (let* ((start (string-contains name "[")) - (end (- (string-length name) 1))) - (and start (string->number (substring name (+ start 1) end))))) - (define (struct? name) - (string-contains name ".")) - (define (parse-struct name uniform namespace) - ;; Deconstruct the uniform name to produce a path through the - ;; namespace tree, follow it to the end and add the uniform as a - ;; leaf node in the tree. - (let inner ((path (string-split name #\.)) - (namespace namespace)) - (match path - ;; Yay, we're done! - ((leaf) - (uniform-namespace-set! namespace (uniform-name->symbol leaf) uniform)) - ((branch . rest) - (let ((new-name (uniform-name->symbol branch)) - (index (parse-array-index branch))) - ;; If there is an index included in the branch name like - ;; "[1]" then that means we have a nested array of structs - ;; within the struct. Otherwise, it's just a single nested - ;; struct. - (if index - (let ((new-namespace - (uniform-array-ref-or-create - (uniform-namespace-ref-or-create-array namespace - new-name) - index))) - (inner rest new-namespace)) - (let ((new-namespace - (uniform-namespace-ref-or-create-namespace namespace - new-name))) - (inner rest new-namespace)))))))) - (define (extract-uniforms id) - (let ((total (uniform-count id)) - (namespace (fresh-uniform-namespace "root"))) - ;; OpenGL has an API for shader program introspection that we - ;; use to extract all active uniforms. This uniform data must - ;; then be parsed and turned into a data structure that can be - ;; used to translate Scheme data (either primitives or compound - ;; structures) to the GPU when it comes time to actually render - ;; something with the shader. - (let loop ((i 0) - (texture-unit 0) - (scratch-size 0)) - (if (< i total) - (let ((length-bv (make-u32vector 1)) - (size-bv (make-u32vector 1)) - (type-bv (make-u32vector 1)) - (name-bv (make-bytevector 255))) - (gl-get-active-uniform id i - (bytevector-length name-bv) - (bytevector->pointer length-bv) - (bytevector->pointer size-bv) - (bytevector->pointer type-bv) - (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)) - (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))) - (default (cond - (sampler? - texture-unit) - ((= size 1) - (shader-primitive-type-null type)) - (else - (make-vector size (shader-primitive-type-null type))))) - (uniform (make-uniform name location type size default))) - (if (struct? name) - ;; The complicated path: Parse struct name and - ;; build a branch of a tree structure. - (parse-struct name uniform namespace) - ;; The easy path: A top-level primitive. - (uniform-namespace-set! namespace - (uniform-name->symbol name) - uniform)) - (loop (1+ i) - ;; A sampler uniform uses up one texture unit, - ;; so move on to the next one in that case. - (if sampler? - (1+ texture-unit) - texture-unit) - ;; Ensure we have enough space to serialize the - ;; largest bit of data we send to the shader. - (max scratch-size - (* size - (shader-primitive-type-size type)))))) - (values namespace scratch-size))))) - (define (attribute-count id) - (let ((bv (make-u32vector 1))) - (gl-get-programiv id - (arb-shader-objects active-attributes) - (bytevector->pointer bv)) - (u32vector-ref bv 0))) - (define (extract-attributes id) - (let ((total (attribute-count id)) - (table (make-hash-table))) - (for-range ((i total)) - (let ((length-bv (make-u32vector 1)) - (size-bv (make-u32vector 1)) - (type-bv (make-u32vector 1)) - (name-bv (make-bytevector 255))) - (gl-get-active-attrib id i - (bytevector-length name-bv) - (bytevector->pointer length-bv) - (bytevector->pointer size-bv) - (bytevector->pointer type-bv) - (bytevector->pointer name-bv)) - (let* ((length (u32vector-ref length-bv 0)) - (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))) - (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) - (unless (shader-linked? id) - (let ((error-log (linking-error id))) - (gl-delete-program id) - (error "failed to link shader" error-log))) - (gl-delete-shader vertex-id) - (gl-delete-shader fragment-id) - (call-with-values - (lambda () (extract-uniforms id)) - (lambda (namespace scratch-size) - (let* ((scratch (make-bytevector scratch-size)) - (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) - "Compile the GLSL source code within VERTEX-SOURCE-FILE and -FRAGMENT-SOURCE-FILE into a GPU shader program." - (call-with-input-file vertex-source-file - (lambda (vertex-port) - (call-with-input-file fragment-source-file - (lambda (fragment-port) - (make-shader vertex-port fragment-port)))))) - -(define (strings->shader vertex-source fragment-source) - "Compile VERTEX-SOURCE, the GLSL code for the vertex shader, -and FRAGMENT-SOURCE, the GLSL code for the fragment shader, into a GPU -shader program." - (call-with-input-string vertex-source - (lambda (vertex-port) - (call-with-input-string fragment-source - (lambda (fragment-port) - (make-shader vertex-port fragment-port)))))) - -(define (shader-uniform shader name) - "Return the metadata for the uniform NAME in SHADER." - (let ((uniform (uniform-namespace-ref (shader-uniforms shader) name))) - (or uniform (error "no such uniform" name)))) - -(define (set-uniform-value! shader uniform value) - ;; TODO: Figure out a way to avoid unnecessary uniform - ;; updates. Maybe UBOs would help address this? - (let ((type (uniform-type uniform))) - (shader-primitive-type-serialize type (shader-scratch shader) value) - (shader-primitive-type-apply-uniform type (uniform-location uniform) 1 - (shader-scratch-pointer shader)) - (%set-uniform-value! uniform value))) - -(define (shader-uniform-for-each* proc shader thing) - (cond - ((uniform? thing) - (proc thing)) - ((uniform-namespace? thing) - (uniform-namespace-for-each - (lambda (key uniform) - (shader-uniform-for-each* proc shader uniform)) - thing)) - ((uniform-array? thing) - (for-range ((i (uniform-array-size thing))) - (shader-uniform-for-each* proc shader (uniform-array-namespace-ref thing i)))))) - -(define (shader-uniform-for-each proc shader) - (shader-uniform-for-each* proc shader (shader-uniforms shader))) - -;; TODO: This walks the entire tree every time, but it should instead -;; stop traversing once it finds the correct leaf node. -(define (%shader-uniform-set shader uniform value) - (cond - ;; A leaf node of the uniform tree representing a single uniform - ;; location as determined by OpenGL. - ((uniform? uniform) - ;; A vector of a primitive type must be the exact size that - ;; the shader expects. - (when (and (> (uniform-size uniform) 1) - (not (= (uniform-size uniform) (vector-length value)))) - (error "vector size mismatch for uniform" uniform-name)) - (set-uniform-value! shader uniform value)) - ;; A nested namespace indicates that this must be a struct. - ((uniform-namespace? uniform) - (if (shader-struct? value) - (uniform-namespace-for-each - (lambda (key uniform) - ;; Samplers are opaque types and you cannot pass them - ;; into the shader as uniform values like you can with - ;; most other values. In the case of samplers, they are - ;; mapped to OpenGL's "texture units", so we need to - ;; ignore them here. - (unless (sampler? uniform) - (%shader-uniform-set shader uniform - (shader-struct-ref value key)))) - uniform) - (error "expected shader struct" value))) - ;; A nested array namespace indicates that this must be an array - ;; of structs. - ((uniform-array? uniform) - (let ((size (uniform-array-size uniform))) - ;; Vector size must match what the shader expects. - (if (and (vector? value) - (= size (vector-length value))) - (for-range ((i size)) - (%shader-uniform-set shader - (uniform-array-namespace-ref uniform i) - (vector-ref value i))) - (error "vector size mismatch for uniform" - (uniform-array-name uniform))))))) - -(define (shader-uniform-set! shader uniform-name x) - ;; Walk the uniform namespace tree until we get to a leaf node or - ;; nodes. - (%shader-uniform-set shader (shader-uniform shader uniform-name) x)) - -(define-syntax uniform-apply - (lambda (x) - (syntax-case x () - ((_ shader ()) (datum->syntax x #t)) - ((_ shader (name value . rest)) - (with-syntax ((sname (datum->syntax x (keyword->symbol - (syntax->datum #'name))))) - #'(begin - (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) - ;; 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. - (shader-uniform-for-each - (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*) - exp)) - -(define-syntax-rule (shader-apply* shader vertex-array offset count . uniforms) - (shader-apply** shader vertex-array uniforms - (render-vertices vertex-array count offset))) - -(define-syntax-rule (shader-apply shader vertex-array uniforms ...) - (shader-apply* shader vertex-array 0 #f uniforms ...)) - -(define-syntax-rule (shader-apply/instanced* shader vertex-array offset count instances . - uniforms) - (shader-apply** shader vertex-array uniforms - (render-vertices/instanced vertex-array instances count offset))) - -(define-syntax-rule (shader-apply/instanced shader vertex-array instances - uniforms ...) - (shader-apply/instanced* shader vertex-array 0 #f instances uniforms ...)) + (gpu shader-gpu) + (handle shader-handle) + (name shader-name) + (state shader-state set-shader-state!)) + +(define (print-shader shader port) + (match shader + (($ <shader> _ _ name) + (format #t "#<shader name: ~s>" name)))) + +(set-record-type-printer! <shader> print-shader) + +(define (shader-available? shader) + (eq? (shader-state shader) 'available)) + +(define (shader-destroyed? shader) + (eq? (shader-state shader) 'destroyed)) + +(define* (make-shader source #:key name) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-shader gpu source))) + (%make-shader gpu handle name 'available))) + +(define (destroy-shader module) + (unless (shader-destroyed? module) + (gpu:destroy-shader (shader-gpu module) (shader-handle module)) + (set-shader-state! module 'destroyed))) + +;; +;; ;;; +;; ;;; Primitive Shader Data Types +;; ;;; + +;; (define-record-type <shader-primitive-type> +;; (%make-shader-primitive-type name size validator serializer setter null) +;; shader-primitive-type? +;; (name shader-primitive-type-name) +;; (size shader-primitive-type-size) +;; (validator shader-primitive-type-validator) +;; (serializer shader-primitive-type-serializer) +;; (setter shader-primitive-type-setter) +;; (null shader-primitive-type-null)) + +;; (define (display-shader-primitive-type type port) +;; (format port "#<shader-primitive-type name: ~a size: ~d null: ~a>" +;; (shader-primitive-type-name type) +;; (shader-primitive-type-size type) +;; (shader-primitive-type-null type))) + +;; (set-record-type-printer! <shader-primitive-type> display-shader-primitive-type) + +;; (define* (make-shader-primitive-type #:key name size validator serializer setter null) +;; (%make-shader-primitive-type name size validator serializer setter null)) + +;; (define (shader-primitive-type-serialize type bv data) +;; (let ((serialize (shader-primitive-type-serializer type))) +;; (if (vector? data) +;; (let ((size (shader-primitive-type-size type))) +;; (for-range ((i (vector-length data))) +;; (serialize bv (* i size) (vector-ref data i)))) +;; (serialize bv 0 data)))) + +;; (define (shader-primitive-type-apply-uniform type location count pointer) +;; ((shader-primitive-type-setter type) location count pointer)) + +;; (define (shader-primitive-type-validate type data) +;; (let ((valid? (shader-primitive-type-validator type))) +;; (if (vector? data) +;; (let loop ((i 0)) +;; (if (and (< i (vector-length data)) +;; (valid? (vector-ref data i))) +;; (loop (+ i 1)) +;; #t)) +;; (valid? data)))) + +;; (define-syntax-rule (define-shader-primitive-type var . args) +;; (define var (make-shader-primitive-type . args))) + +;; ;; Primitive types: +;; (define-shader-primitive-type bool +;; #:name 'bool +;; #:size 4 +;; #:validator boolean? +;; #:serializer +;; (lambda (bv i bool) +;; (bytevector-s32-native-set! bv i (if bool 1 0))) +;; #:setter gl-uniform1iv +;; #:null #false) + +;; (define-shader-primitive-type int +;; #:name 'int +;; #:size 4 +;; #:validator integer? +;; #:serializer +;; (lambda (bv i n) +;; (bytevector-s32-native-set! bv i n)) +;; #:setter gl-uniform1iv +;; #:null 0) + +;; (define-shader-primitive-type unsigned-int +;; #:name 'unsigned-int +;; #:size 4 +;; #:validator +;; (lambda (i) +;; (and (integer? i) (>= i 0))) +;; #:serializer +;; (lambda (bv i u) +;; (bytevector-u32-native-set! bv i u)) +;; #:setter gl-uniform1uiv +;; #:null 0) + +;; (define-shader-primitive-type float +;; #:name 'float +;; #:size 4 +;; #:validator number? +;; #:serializer +;; (lambda (bv i f) +;; (bytevector-ieee-single-native-set! bv i f)) +;; #:setter gl-uniform1fv +;; #:null 0.0) + +;; (define-shader-primitive-type float-vec2 +;; #:name 'float-vec2 +;; #:size 8 ; 8 bytes = 2 floats = 1 vec2 +;; #:validator vec2? +;; #:serializer +;; (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2))) +;; (lambda (bv i v) +;; (bytevector-copy! (unwrap-vec2 v) 0 bv i 8))) +;; #:setter gl-uniform2fv +;; #:null (vec2 0.0 0.0)) + +;; (define-shader-primitive-type float-vec3 +;; #:name 'float-vec3 +;; #:size 12 ; 12 bytes = 3 floats = 1 vec3 +;; #:validator vec3? +;; #:serializer +;; (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3))) +;; (lambda (bv i v) +;; (bytevector-copy! (unwrap-vec3 v) 0 bv i 12))) +;; #:setter gl-uniform3fv +;; #:null (vec3 0.0 0.0 0.0)) + +;; (define-shader-primitive-type float-vec4 +;; #:name 'float-vec4 +;; #:size 16 ; 16 bytes = 4 floats = 1 vec4 +;; #:validator (lambda (x) (or (rect? x) (color? x))) +;; #:serializer +;; (let ((unwrap-rect (@@ (chickadee math rect) unwrap-rect))) +;; (lambda (bv i v) +;; ;; As of now, there is no vec4 Scheme type, but we do want to +;; ;; accept colors and rects as vec4s since there is no special +;; ;; color or rect type in GLSL. +;; (if (rect? v) +;; (bytevector-copy! (unwrap-rect v) 0 bv i 16) +;; (begin +;; (bytevector-ieee-single-native-set! bv i (color-r v)) +;; (bytevector-ieee-single-native-set! bv (+ i 4) (color-g v)) +;; (bytevector-ieee-single-native-set! bv (+ i 8) (color-b v)) +;; (bytevector-ieee-single-native-set! bv (+ i 12) (color-a v)))))) +;; #:setter gl-uniform4fv +;; #:null (make-null-rect)) + +;; (define-shader-primitive-type mat3 +;; #:name 'mat3 +;; #:size (* 3 3 4) ; 3 rows x 3 columns x 4 byte floats +;; #:validator matrix3? +;; #:serializer +;; (let ((matrix3-bv (@@ (chickadee math matrix) matrix3-bv))) +;; (lambda (bv i m) +;; (bytevector-copy! (matrix3-bv m) 0 bv i (* 3 3 4)))) +;; #:setter (lambda (location count ptr) +;; (gl-uniform-matrix3fv location count #f ptr)) +;; #:null (make-identity-matrix3)) + +;; (define-shader-primitive-type mat4 +;; #:name 'mat4 +;; #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes +;; #:validator matrix4? +;; #:serializer +;; (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv))) +;; (lambda (bv i m) +;; ;; 4 rows x 4 columns x 4 bytes per float = 4^3 +;; (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4)))) +;; #:setter (lambda (location count ptr) +;; (gl-uniform-matrix4fv location count #f ptr)) +;; #:null (make-identity-matrix4)) + +;; (define-shader-primitive-type sampler-2d +;; #:name 'sampler-2d +;; #:size 4 +;; #:validator integer? +;; #:serializer +;; (lambda (bv i texture-unit) +;; (bytevector-s32-native-set! bv i texture-unit)) +;; #:setter gl-uniform1iv +;; #:null 0) + +;; (define-shader-primitive-type sampler-cube +;; #:name 'sampler-cube +;; #:size 4 +;; #:validator integer? +;; #:serializer +;; (lambda (bv i texture-unit) +;; (bytevector-s32-native-set! bv i texture-unit)) +;; #:setter gl-uniform1iv +;; #:null 0) + +;; +;; ;;; +;; ;;; Compound Shader Data Types +;; ;;; + +;; ;; A meta-vtable that has two additional slots: one for the struct +;; ;; name, and another for the lookup table that maps struct field names +;; ;; to their respective struct index and shader data type. +;; (define <shader-struct> +;; (make-vtable (string-append standard-vtable-fields "pwpw") +;; (lambda (vt port) +;; (format port "#<shader-struct ~a>" +;; (shader-struct-fields vt))))) + +;; (define local-field (gensym "local-shader-field-")) + +;; (define (shader-struct? struct) +;; (eq? (struct-vtable (struct-vtable struct)) <shader-struct>)) + +;; (define shader-struct-name-index vtable-offset-user) +;; (define shader-struct-fields-index (+ vtable-offset-user 1)) + +;; (define (shader-struct-name vtable) +;; (struct-ref vtable shader-struct-name-index)) + +;; (define (shader-struct-fields vtable) +;; (struct-ref vtable shader-struct-fields-index)) + +;; (define (shader-struct-type-check vtable field value) +;; (match (assq-ref (shader-struct-fields vtable) field) +;; ((_ type size) +;; (define (validate value) +;; (unless (or (and (struct? value) (eq? (struct-vtable value) type)) +;; (shader-primitive-type-validate type value)) +;; (error "invalid type for shader struct field" field value))) +;; (cond +;; ((eq? type local-field) +;; #t) +;; ((= size 1) +;; (validate value)) +;; ((and (vector? value) +;; (= (vector-length value) size)) +;; (for-range ((i (vector-length value))) +;; (validate (vector-ref value i)))) +;; ((vector? value) +;; (error "incorrect vector size" value)) +;; (else +;; (error "expected vector, got" value)))))) + +;; (define (shader-struct-default vtable field) +;; (match (assq-ref (shader-struct-fields vtable) field) +;; ((_ type size) +;; (let ((default (cond +;; ((eq? type local-field) +;; #f) +;; ((eq? (struct-vtable type) <shader-struct>) +;; (apply make-struct/no-tail type +;; (map (match-lambda +;; ((sub-field _ _ _) +;; (shader-struct-default type sub-field))) +;; (shader-struct-fields type)))) +;; (else +;; (shader-primitive-type-null type))))) +;; (if (= size 1) +;; default +;; (make-vector size default)))))) + +;; (define (make-shader-struct-field-table fields+types) +;; ;; Map field names to their struct indices and shader types. +;; (let loop ((i 0) +;; (fields+types fields+types)) +;; (match fields+types +;; (() '()) +;; (((name #(type size)) . rest) +;; (cons (list name i type size) +;; (loop (+ i 1) rest))) +;; (((name type) . rest) +;; (cons (list name i type 1) +;; (loop (+ i 1) rest)))))) + +;; (define (display-shader-struct-instance obj port) +;; (let ((vtable (struct-vtable obj))) +;; (format port "#<~a" (shader-struct-name vtable)) +;; (let loop ((fields (shader-struct-fields vtable))) +;; (match fields +;; (() #f) +;; (((name index type size) . rest) +;; (format port " ~a[~d ~a]: ~a" +;; name size +;; (if (eq? type local-field) +;; 'local +;; (shader-primitive-type-name type)) +;; (struct-ref obj index)) +;; (loop rest)))) +;; (display ">" port))) + +;; (define (make-display-name sym) +;; (let ((str (symbol->string sym))) +;; (if (and (string-prefix? "<" str) +;; (string-suffix? ">" str)) +;; (substring str 1 (- (string-length str) 1)) +;; str))) + +;; (define (make-shader-struct name fields+types) +;; (make-struct/no-tail <shader-struct> +;; (make-struct-layout +;; (string-concatenate +;; (map (const "pw") fields+types))) +;; display-shader-struct-instance +;; (make-display-name name) +;; (make-shader-struct-field-table fields+types))) + +;; (define (shader-struct-ref struct field) +;; (match (assq-ref (shader-struct-fields (struct-vtable struct)) field) +;; (#f +;; (error "unknown struct field" field)) +;; ((index _ _) +;; (struct-ref struct index)))) + +;; (define-syntax define-accessors +;; (syntax-rules () +;; ((_ <struct> field getter) +;; (define getter +;; (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field) +;; ((i _ _) i)))) +;; (lambda (obj) +;; (struct-ref obj index))))) +;; ((_ <struct> field getter setter) +;; (begin +;; (define-accessors <struct> field getter) +;; (define setter +;; (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field) +;; ((i _ _) i)))) +;; (lambda (obj value) +;; (shader-struct-type-check <struct> 'field value) +;; (struct-set! obj index value)))))))) + +;; (define-syntax define-shader-type +;; (syntax-rules () +;; ((_ <name> constructor predicate (field-type field-name . field-rest) ...) +;; (begin +;; (define <name> +;; (make-shader-struct '<name> (list (list 'field-name field-type) ...))) +;; (define* (constructor #:key (field-name (shader-struct-default <name> 'field-name)) ...) +;; (shader-struct-type-check <name> 'field-name field-name) ... +;; (make-struct/no-tail <name> field-name ...)) +;; (define (predicate obj) +;; (and (struct? obj) (eq? (struct-vtable obj) <name>))) +;; (define-accessors <name> field-name . field-rest) ...)))) + +;; +;; ;;; +;; ;;; Shaders +;; ;;; + +;; (define-record-type <shader> +;; (%make-shader id attributes uniforms scratch scratch-pointer) +;; shader? +;; (id shader-id) +;; (attributes shader-attributes) +;; (uniforms shader-uniforms) +;; ;; Scratch space for serializing uniform values. +;; (scratch shader-scratch) +;; ;; Create the pointer once and hold onto it to reduce needless +;; ;; garbage creation. +;; (scratch-pointer shader-scratch-pointer)) + +;; ;; Represents a single active uniform location in a shader program. +;; (define-record-type <uniform> +;; (make-uniform name location type size value) +;; uniform? +;; (name uniform-name) +;; (location uniform-location) +;; (type uniform-type) +;; (size uniform-size) +;; (value uniform-value %set-uniform-value!)) + +;; (define (sampler? uniform) +;; (or (eq? (uniform-type uniform) sampler-2d) +;; (eq? (uniform-type uniform) sampler-cube))) + +;; ;; variable name -> {uniform, namespace, uniform array} map +;; (define-record-type <uniform-namespace> +;; (make-uniform-namespace name members) +;; uniform-namespace? +;; (name uniform-namespace-name) +;; (members uniform-namespace-members)) + +;; (define (fresh-uniform-namespace name) +;; (make-uniform-namespace name (make-hash-table))) + +;; (define (uniform-namespace-set! namespace name value) +;; (hashq-set! (uniform-namespace-members namespace) name value)) + +;; (define (uniform-namespace-ref namespace name) +;; (hashq-ref (uniform-namespace-members namespace) name)) + +;; (define (uniform-namespace-ref-or-create-namespace namespace name) +;; (or (uniform-namespace-ref namespace name) +;; (let ((new-ns (fresh-uniform-namespace name))) +;; (uniform-namespace-set! namespace name new-ns) +;; new-ns))) + +;; (define (uniform-namespace-ref-or-create-array namespace name) +;; (or (uniform-namespace-ref namespace name) +;; (let ((new-arr (fresh-uniform-array name))) +;; (uniform-namespace-set! namespace name new-arr) +;; new-arr))) + +;; (define (uniform-namespace-for-each proc namespace) +;; (hash-for-each proc (uniform-namespace-members namespace))) + +;; ;; variable name -> {uniform, namespace} map +;; (define-record-type <uniform-array> +;; (make-uniform-array name namespaces size) +;; uniform-array? +;; (name uniform-array-name) +;; (namespaces uniform-array-namespaces) +;; (size uniform-array-size set-uniform-array-size!)) + +;; (define (fresh-uniform-array name) +;; (make-uniform-array name (make-hash-table) 0)) + +;; (define (uniform-array-namespace-ref array i) +;; (hashv-ref (uniform-array-namespaces array) i)) + +;; (define (uniform-array-namespace-add! array i) +;; (let ((ns (fresh-uniform-namespace (uniform-array-name array)))) +;; (hashv-set! (uniform-array-namespaces array) i ns) +;; (set-uniform-array-size! array (max (uniform-array-size array) (+ i 1))) +;; ns)) + +;; (define (uniform-array-ref-or-create array i) +;; (or (uniform-array-namespace-ref array i) +;; (uniform-array-namespace-add! array i))) + +;; (define-record-type <attribute> +;; (make-attribute name location type) +;; attribute? +;; (name attribute-name) +;; (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 (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) +;; (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) +;; (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) +;; (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)) +;; (utf8->string log)))) +;; (define (compilation-error id) +;; (info-log gl-get-shaderiv gl-get-shader-info-log id)) +;; (define (linking-error id) +;; (info-log gl-get-programiv gl-get-program-info-log id)) +;; (define (glsl-preprocessor-source) +;; ;; 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))) +;; (cond +;; ((string>= glsl-version "3.3") +;; "#version 330 +;; #define GLSL330 +;; ") +;; ((string>= glsl-version "1.3") +;; "#version 130 +;; #define GLSL130 +;; ") +;; ((string>= glsl-version "1.2") +;; "#version 120 +;; #define GLSL120 +;; ") +;; (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 +;; (bytevector->pointer +;; (u64vector +;; (pointer-address (bytevector->pointer source)))) +;; (bytevector->pointer +;; (u32vector (bytevector-length source)))) +;; (gl-compile-shader id) +;; (unless (shader-compiled? id) +;; (let ((error-log (compilation-error id))) +;; (gl-delete-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 +;; (arb-shader-objects active-uniforms) +;; (bytevector->pointer bv)) +;; (u32vector-ref bv 0))) +;; (define (utf8->string* bv length) +;; (let ((bv* (make-bytevector length))) +;; (bytevector-copy! bv 0 bv* 0 length) +;; (utf8->string bv*))) +;; (define (parse-data-type type) +;; (cond +;; ((= type (version-2-0 bool)) bool) +;; ((= type (data-type int)) int) +;; ((= type (data-type unsigned-int)) unsigned-int) +;; ((= type (data-type float)) float) +;; ((= type (version-2-0 float-vec2)) float-vec2) +;; ((= type (version-2-0 float-vec3)) float-vec3) +;; ((= type (version-2-0 float-vec4)) float-vec4) +;; ((= type (version-2-0 float-mat3)) mat3) +;; ((= type (version-2-0 float-mat4)) mat4) +;; ((= type (version-2-0 sampler-2d)) sampler-2d) +;; ((= type (version-2-0 sampler-cube)) sampler-cube) +;; (else +;; (error "unsupported OpenGL type" type)))) +;; (define (camel->snake str) +;; (list->string +;; (let loop ((i 0)) +;; (if (< i (string-length str)) +;; (let ((c (string-ref str i))) +;; (if (char-set-contains? char-set:upper-case c) +;; (cons* #\- (char-downcase c) (loop (+ i 1))) +;; (cons c (loop (+ i 1))))) +;; '())))) +;; (define (uniform-name->symbol name) +;; ;; array uniform names have a suffix like "[0]" that needs to be +;; ;; removed to produce the actual uniform variable name that our +;; ;; shader interface will recognize. +;; (string->symbol +;; (let ((i (string-contains name "["))) +;; (camel->snake +;; (if i (substring name 0 i) name))))) +;; (define (parse-array-index name) +;; (let* ((start (string-contains name "[")) +;; (end (- (string-length name) 1))) +;; (and start (string->number (substring name (+ start 1) end))))) +;; (define (struct? name) +;; (string-contains name ".")) +;; (define (parse-struct name uniform namespace) +;; ;; Deconstruct the uniform name to produce a path through the +;; ;; namespace tree, follow it to the end and add the uniform as a +;; ;; leaf node in the tree. +;; (let inner ((path (string-split name #\.)) +;; (namespace namespace)) +;; (match path +;; ;; Yay, we're done! +;; ((leaf) +;; (uniform-namespace-set! namespace (uniform-name->symbol leaf) uniform)) +;; ((branch . rest) +;; (let ((new-name (uniform-name->symbol branch)) +;; (index (parse-array-index branch))) +;; ;; If there is an index included in the branch name like +;; ;; "[1]" then that means we have a nested array of structs +;; ;; within the struct. Otherwise, it's just a single nested +;; ;; struct. +;; (if index +;; (let ((new-namespace +;; (uniform-array-ref-or-create +;; (uniform-namespace-ref-or-create-array namespace +;; new-name) +;; index))) +;; (inner rest new-namespace)) +;; (let ((new-namespace +;; (uniform-namespace-ref-or-create-namespace namespace +;; new-name))) +;; (inner rest new-namespace)))))))) +;; (define (extract-uniforms id) +;; (let ((total (uniform-count id)) +;; (namespace (fresh-uniform-namespace "root"))) +;; ;; OpenGL has an API for shader program introspection that we +;; ;; use to extract all active uniforms. This uniform data must +;; ;; then be parsed and turned into a data structure that can be +;; ;; used to translate Scheme data (either primitives or compound +;; ;; structures) to the GPU when it comes time to actually render +;; ;; something with the shader. +;; (let loop ((i 0) +;; (texture-unit 0) +;; (scratch-size 0)) +;; (if (< i total) +;; (let ((length-bv (make-u32vector 1)) +;; (size-bv (make-u32vector 1)) +;; (type-bv (make-u32vector 1)) +;; (name-bv (make-bytevector 255))) +;; (gl-get-active-uniform id i +;; (bytevector-length name-bv) +;; (bytevector->pointer length-bv) +;; (bytevector->pointer size-bv) +;; (bytevector->pointer type-bv) +;; (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)) +;; (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))) +;; (default (cond +;; (sampler? +;; texture-unit) +;; ((= size 1) +;; (shader-primitive-type-null type)) +;; (else +;; (make-vector size (shader-primitive-type-null type))))) +;; (uniform (make-uniform name location type size default))) +;; (if (struct? name) +;; ;; The complicated path: Parse struct name and +;; ;; build a branch of a tree structure. +;; (parse-struct name uniform namespace) +;; ;; The easy path: A top-level primitive. +;; (uniform-namespace-set! namespace +;; (uniform-name->symbol name) +;; uniform)) +;; (loop (1+ i) +;; ;; A sampler uniform uses up one texture unit, +;; ;; so move on to the next one in that case. +;; (if sampler? +;; (1+ texture-unit) +;; texture-unit) +;; ;; Ensure we have enough space to serialize the +;; ;; largest bit of data we send to the shader. +;; (max scratch-size +;; (* size +;; (shader-primitive-type-size type)))))) +;; (values namespace scratch-size))))) +;; (define (attribute-count id) +;; (let ((bv (make-u32vector 1))) +;; (gl-get-programiv id +;; (arb-shader-objects active-attributes) +;; (bytevector->pointer bv)) +;; (u32vector-ref bv 0))) +;; (define (extract-attributes id) +;; (let ((total (attribute-count id)) +;; (table (make-hash-table))) +;; (for-range ((i total)) +;; (let ((length-bv (make-u32vector 1)) +;; (size-bv (make-u32vector 1)) +;; (type-bv (make-u32vector 1)) +;; (name-bv (make-bytevector 255))) +;; (gl-get-active-attrib id i +;; (bytevector-length name-bv) +;; (bytevector->pointer length-bv) +;; (bytevector->pointer size-bv) +;; (bytevector->pointer type-bv) +;; (bytevector->pointer name-bv)) +;; (let* ((length (u32vector-ref length-bv 0)) +;; (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))) +;; (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) +;; (unless (shader-linked? id) +;; (let ((error-log (linking-error id))) +;; (gl-delete-program id) +;; (error "failed to link shader" error-log))) +;; (gl-delete-shader vertex-id) +;; (gl-delete-shader fragment-id) +;; (call-with-values +;; (lambda () (extract-uniforms id)) +;; (lambda (namespace scratch-size) +;; (let* ((scratch (make-bytevector scratch-size)) +;; (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) +;; "Compile the GLSL source code within VERTEX-SOURCE-FILE and +;; FRAGMENT-SOURCE-FILE into a GPU shader program." +;; (call-with-input-file vertex-source-file +;; (lambda (vertex-port) +;; (call-with-input-file fragment-source-file +;; (lambda (fragment-port) +;; (make-shader vertex-port fragment-port)))))) + +;; (define (strings->shader vertex-source fragment-source) +;; "Compile VERTEX-SOURCE, the GLSL code for the vertex shader, +;; and FRAGMENT-SOURCE, the GLSL code for the fragment shader, into a GPU +;; shader program." +;; (call-with-input-string vertex-source +;; (lambda (vertex-port) +;; (call-with-input-string fragment-source +;; (lambda (fragment-port) +;; (make-shader vertex-port fragment-port)))))) + +;; (define (shader-uniform shader name) +;; "Return the metadata for the uniform NAME in SHADER." +;; (let ((uniform (uniform-namespace-ref (shader-uniforms shader) name))) +;; (or uniform (error "no such uniform" name)))) + +;; (define (set-uniform-value! shader uniform value) +;; ;; TODO: Figure out a way to avoid unnecessary uniform +;; ;; updates. Maybe UBOs would help address this? +;; (let ((type (uniform-type uniform))) +;; (shader-primitive-type-serialize type (shader-scratch shader) value) +;; (shader-primitive-type-apply-uniform type (uniform-location uniform) 1 +;; (shader-scratch-pointer shader)) +;; (%set-uniform-value! uniform value))) + +;; (define (shader-uniform-for-each* proc shader thing) +;; (cond +;; ((uniform? thing) +;; (proc thing)) +;; ((uniform-namespace? thing) +;; (uniform-namespace-for-each +;; (lambda (key uniform) +;; (shader-uniform-for-each* proc shader uniform)) +;; thing)) +;; ((uniform-array? thing) +;; (for-range ((i (uniform-array-size thing))) +;; (shader-uniform-for-each* proc shader (uniform-array-namespace-ref thing i)))))) + +;; (define (shader-uniform-for-each proc shader) +;; (shader-uniform-for-each* proc shader (shader-uniforms shader))) + +;; ;; TODO: This walks the entire tree every time, but it should instead +;; ;; stop traversing once it finds the correct leaf node. +;; (define (%shader-uniform-set shader uniform value) +;; (cond +;; ;; A leaf node of the uniform tree representing a single uniform +;; ;; location as determined by OpenGL. +;; ((uniform? uniform) +;; ;; A vector of a primitive type must be the exact size that +;; ;; the shader expects. +;; (when (and (> (uniform-size uniform) 1) +;; (not (= (uniform-size uniform) (vector-length value)))) +;; (error "vector size mismatch for uniform" uniform-name)) +;; (set-uniform-value! shader uniform value)) +;; ;; A nested namespace indicates that this must be a struct. +;; ((uniform-namespace? uniform) +;; (if (shader-struct? value) +;; (uniform-namespace-for-each +;; (lambda (key uniform) +;; ;; Samplers are opaque types and you cannot pass them +;; ;; into the shader as uniform values like you can with +;; ;; most other values. In the case of samplers, they are +;; ;; mapped to OpenGL's "texture units", so we need to +;; ;; ignore them here. +;; (unless (sampler? uniform) +;; (%shader-uniform-set shader uniform +;; (shader-struct-ref value key)))) +;; uniform) +;; (error "expected shader struct" value))) +;; ;; A nested array namespace indicates that this must be an array +;; ;; of structs. +;; ((uniform-array? uniform) +;; (let ((size (uniform-array-size uniform))) +;; ;; Vector size must match what the shader expects. +;; (if (and (vector? value) +;; (= size (vector-length value))) +;; (for-range ((i size)) +;; (%shader-uniform-set shader +;; (uniform-array-namespace-ref uniform i) +;; (vector-ref value i))) +;; (error "vector size mismatch for uniform" +;; (uniform-array-name uniform))))))) + +;; (define (shader-uniform-set! shader uniform-name x) +;; ;; Walk the uniform namespace tree until we get to a leaf node or +;; ;; nodes. +;; (%shader-uniform-set shader (shader-uniform shader uniform-name) x)) + +;; (define-syntax uniform-apply +;; (lambda (x) +;; (syntax-case x () +;; ((_ shader ()) (datum->syntax x #t)) +;; ((_ shader (name value . rest)) +;; (with-syntax ((sname (datum->syntax x (keyword->symbol +;; (syntax->datum #'name))))) +;; #'(begin +;; (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) +;; ;; 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. +;; (shader-uniform-for-each +;; (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*) +;; exp)) + +;; (define-syntax-rule (shader-apply* shader vertex-array offset count . uniforms) +;; (shader-apply** shader vertex-array uniforms +;; (render-vertices vertex-array count offset))) + +;; (define-syntax-rule (shader-apply shader vertex-array uniforms ...) +;; (shader-apply* shader vertex-array 0 #f uniforms ...)) + +;; (define-syntax-rule (shader-apply/instanced* shader vertex-array offset count instances . +;; uniforms) +;; (shader-apply** shader vertex-array uniforms +;; (render-vertices/instanced vertex-array instances count offset))) + +;; (define-syntax-rule (shader-apply/instanced shader vertex-array instances +;; uniforms ...) +;; (shader-apply/instanced* shader vertex-array 0 #f instances uniforms ...)) diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm index 29c1088..26bd8d7 100644 --- a/chickadee/graphics/sprite.scm +++ b/chickadee/graphics/sprite.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2019, 2020, 2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2016, 2019, 2020, 2021, 2024 David Thompson <dthompson2@worcester.edu> ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. @@ -13,21 +13,46 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. +;;; Commentary: +;; +;; 2D sprite rendering. +;; +;;; Code: + (define-module (chickadee graphics sprite) + #:use-module (chickadee data bytestruct) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics buffer) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics pipeline) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) - #: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 shader) - #:use-module (chickadee graphics texture) - #:use-module (chickadee graphics buffer) - #:export (draw-sprite* + #:export (make-sprite + sprite? + sprite-texture-view + sprite-rect + sprite-rect-uv + + list->sprite-sheet + sprite-sheet + tileset + load-tileset + sprite-sheet? + sprite-sheet-length + sprite-sheet-ref + + draw-sprite* draw-sprite make-sprite-batch @@ -35,108 +60,325 @@ sprite-batch-texture set-sprite-batch-texture! sprite-batch-clear! + sprite-batch-end! sprite-batch-add* + sprite-batch-set!* sprite-batch-add! + sprite-batch-set! draw-sprite-batch* - draw-sprite-batch - - with-batched-sprites - draw-nine-patch* - draw-nine-patch)) - -(define-geometry-type <sprite-vertex> - sprite-vertex-ref - sprite-vertex-set! - sprite-vertex-append! - (position vec2) - (texture vec2)) - -(define-graphics-variable sprite-geometry - (make-geometry <sprite-vertex> 4 #:index-capacity 6)) -(define-graphics-variable sprite-model-matrix (make-null-matrix4)) -(define-graphics-variable sprite-mvp-matrix (make-null-matrix4)) -(define-graphics-variable sprite-shader - (strings->shader - " + draw-sprite-batch)) + + +;;; +;;; Sprite sheets +;;; + +(define-record-type <sprite> + (%make-sprite texture-view rect rect-uv) + sprite? + (texture-view sprite-texture-view) + (rect sprite-rect) + (rect-uv sprite-rect-uv)) + +(define (make-sprite texture-view rect) + (unless (texture-view-2d? texture-view) + (error "expected 2D texture view" texture-view)) + (let* ((width (texture-view-width texture-view)) + (height (texture-view-height texture-view)) + (uv (make-rect (/ (rect-x rect) width) + (/ (rect-y rect) height) + (/ (rect-width rect) width) + (/ (rect-height rect) height)))) + (%make-sprite texture-view rect uv))) + +(define-record-type <sprite-sheet> + (%make-sprite-sheet texture-view sprites) + sprite-sheet? + (texture-view sprite-sheet-texture-view) + (sprites sprite-sheet-sprites)) + +(define (print-sprite-sheet sheet port) + (format port + "#<sprite-sheet texture-view: ~a size: ~d>" + (sprite-sheet-texture-view sheet) + (vector-length (sprite-sheet-sprites sheet)))) + +(set-record-type-printer! <sprite-sheet> print-sprite-sheet) + +(define (list->sprite-sheet texture-view rects) + "Return a new sprite sheet containing RECTS, a list of +rectangles describing the various sprites within TEXTURE-VIEW." + (let ((v (make-vector (length rects)))) + (let loop ((i 0) (rects rects)) + (match rects + (() (%make-sprite-sheet texture-view v)) + ((rect . rest) + (vector-set! v i (make-sprite texture-view rect)) + (loop (1+ i) rest)))))) + +(define (sprite-sheet texture-view . rects) + "Return a new sprite sheet containing RECTS, a list of +rectangles describing the various sprites within TEXTURE-VIEW." + (list->sprite-sheet texture-view rects)) + +(define (sprite-sheet-length sprite-sheet) + "Return the number of sprites in the SPRITE-SHEET." + (vector-length (sprite-sheet-sprites sprite-sheet))) + +(define (sprite-sheet-ref sprite-sheet index) + "Return the sprite associated with INDEX in +SPRITE-SHEET." + (vector-ref (sprite-sheet-sprites sprite-sheet) index)) + +(define* (texture-tileset-dimensions texture-view tile-width tile-height + #:key (margin 0) (spacing 0)) + (values (inexact->exact + (ceiling (/ (- (texture-view-width texture-view) margin) + (+ tile-width spacing)))) + (inexact->exact + (ceiling (/ (- (texture-view-height texture-view) margin) + (+ tile-height spacing)))))) + +(define* (tileset texture-view tile-width tile-height + #:key (margin 0) (spacing 0)) + "Return a new sprite sheet that splits TEXTURE-VIEW into a grid of +TILE-WIDTH by TILE-HEIGHT sprites. Optionally, each tile may have +SPACING pixels of horizontal and vertical space between surrounding +tiles and the entire image may have MARGIN pixels of empty space +around its border." + (call-with-values (lambda () + (texture-tileset-dimensions texture-view tile-width tile-height + #:margin margin + #:spacing spacing)) + (lambda (columns rows) + (let ((v (make-vector (* rows columns)))) + (define (make-tile tx ty) + (let* ((x (+ (* tx (+ tile-width spacing)) margin)) + (y (+ (* ty (+ tile-height spacing)) margin))) + (make-sprite texture-view (make-rect x y tile-width tile-height)))) + (for-range ((x columns) + (y rows)) + (vector-set! v (+ x (* y columns)) (make-tile x y))) + (%make-sprite-sheet texture-view v))))) + +(define* (load-tileset file-name tile-width tile-height #:key + (margin 0) + (spacing 0) + transparent-color) + "Return a new texture atlas that splits the texture loaded from the +file FILE-NAME into a grid of TILE-WIDTH by TILE-HEIGHT rectangles. +See load-image and split-texture for information about all keyword +arguments." + (tileset (texture-view + (load-image file-name #:transparent-color transparent-color)) + tile-width + tile-height + #:margin margin + #:spacing spacing)) + + +;;; +;;; Sprite streaming +;;; + +(define-record-type <sprite-state> + (make-sprite-state shader uniforms sampler matrix + color-target-cache bindings rect-cache) + sprite-state? + (shader sprite-state-shader) + (uniforms sprite-state-uniforms) + (sampler sprite-state-sampler) + (matrix sprite-state-matrix) + (color-target-cache sprite-state-color-target-cache) + (bindings sprite-state-bindings) + (rect-cache sprite-state-rect-cache)) + +(define (sprite-color-target state blend-mode) + (let ((cache (sprite-state-color-target-cache state))) + (or (hashq-ref cache blend-mode) + (let ((color-target (make-color-target #:blend-mode blend-mode))) + (hashq-set! cache blend-mode color-target) + color-target)))) + +(define (%sprite-rect state texture) + (let ((cache (sprite-state-rect-cache state))) + (or (hashq-ref cache texture) + (let ((rect (make-rect 0.0 0.0 + (texture-width texture) + (texture-height texture)))) + (hashq-set! cache texture rect) + rect)))) + +(define-bytestruct <sprite-vertex> + (struct (position <vec2>) + (texture <vec2>) + (color <color>))) + +(define-bytestruct <sprite-uniforms> + (struct (mvp <matrix4>))) + +(define %sprite-vertex-layout + (vector (make-vertex-buffer-layout + #:stride (bytestruct-sizeof <sprite-vertex>) + #:attributes (vector + (make-vertex-attribute + #:format 'float32x2) + (make-vertex-attribute + #:format 'float32x2 + #:offset (* 2 4)) + (make-vertex-attribute + #:format 'float32x4 + #:offset (* 4 4)))))) + +(define %sprite-binding-layout + (vector (make-texture-layout) + (make-sampler-layout) + (make-buffer-layout))) + +(define-graphics-variable sprite-state + (make-sprite-state + (make-shader + (lambda (lang) + (values " #ifdef GLSL330 layout (location = 0) in vec2 position; layout (location = 1) in vec2 tex; +layout (location = 2) in vec4 tint; #elif defined(GLSL130) in vec2 position; in vec2 tex; +in vec4 tint; #elif defined(GLSL120) attribute vec2 position; attribute vec2 tex; +attribute vec4 tint; #endif #ifdef GLSL120 varying vec2 fragTex; +varying vec4 fragTint; #else out vec2 fragTex; +out vec4 fragTint; +#endif + +#ifdef GLSL120 +uniform mat4 matrix; +#else +layout (std140) uniform Sprite +{ + mat4 matrix; +}; #endif -uniform mat4 mvp; void main(void) { fragTex = tex; - gl_Position = mvp * vec4(position.xy, 0.0, 1.0); + fragTint = tint; + gl_Position = matrix * vec4(position.xy, 0.0, 1.0); } " - " + " #ifdef GLSL120 varying vec2 fragTex; +varying vec4 fragTint; #else in vec2 fragTex; +in vec4 fragTint; #endif #ifdef GLSL330 out vec4 fragColor; +#else +#define fragColor gl_FragColor +#define texture texture2D #endif + uniform sampler2D colorTexture; -uniform vec4 tint; void main (void) { -#ifdef GLSL330 - fragColor = texture(colorTexture, fragTex) * tint; -#else - gl_FragColor = texture2D(colorTexture, fragTex) * tint; -#endif + fragColor = texture(colorTexture, fragTex) * fragTint; } ")) + #:name "Sprite shader") + (make-buffer (* 16 4) + #:name "Sprite uniform buffer" + #:usage '(uniform)) + (make-sampler #:name "Sprite sampler") + (make-null-matrix4) + (make-hash-table) + (make-vector 3 #f) + (make-hash-table))) + +(define %default-texcoords (make-rect 0.0 0.0 1.0 1.0)) + +(define-inlinable (sprite-set! vertices voffset indices ioffset i rect texcoords tint matrix) + (let* ((minx (rect-x rect)) + (miny (rect-y rect)) + (maxx (+ minx (rect-width rect))) + (maxy (+ miny (rect-height rect))) + (x1 (matrix4-transform-x matrix minx miny)) + (y1 (matrix4-transform-y matrix minx miny)) + (x2 (matrix4-transform-x matrix maxx miny)) + (y2 (matrix4-transform-y matrix maxx miny)) + (x3 (matrix4-transform-x matrix maxx maxy)) + (y3 (matrix4-transform-y matrix maxx maxy)) + (x4 (matrix4-transform-x matrix minx maxy)) + (y4 (matrix4-transform-y matrix minx maxy)) + (s1 (rect-x texcoords)) + (t1 (rect-y texcoords)) + (s2 (+ s1 (rect-width texcoords))) + (t2 (+ t1 (rect-height texcoords))) + (r (color-r tint)) + (g (color-g tint)) + (b (color-b tint)) + (a (color-a tint))) + (define-syntax-rule (set-vertex! j x* y* u v r* g* b* a*) + (dbuffer-pack! <sprite-vertex> + (((position x) x*) + ((position y) y*) + ((texture x) u) + ((texture y) v) + ((color r) r*) + ((color g) g*) + ((color b) b*) + ((color a) a*)) + vertices + (+ voffset (* j (bytestruct-sizeof <sprite-vertex>))))) + (set-vertex! 0 x1 y1 s1 t1 r g b a) + (set-vertex! 1 x2 y2 s2 t1 r g b a) + (set-vertex! 2 x3 y3 s2 t2 r g b a) + (set-vertex! 3 x4 y4 s1 t2 r g b a) + (dbuffer-pack-indices-quad! indices ioffset i))) -(define* (draw-sprite* texture - rect - matrix - #:key +(define-inlinable (sprite-append! vertices indices i rect texcoords tint matrix) + (let ((voffset (dbuffer-reserve! vertices (* (bytestruct-sizeof <sprite-vertex>) 4))) + (ioffset (dbuffer-reserve! indices (* 6 4)))) + (sprite-set! vertices voffset indices ioffset i rect texcoords tint matrix))) + +(define* (draw-sprite* texture-view 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)) - (x2 (+ x1 (rect-width rect))) - (y2 (+ y1 (rect-height rect))) - (s1 (rect-x texcoords)) - (t1 (rect-y texcoords)) - (s2 (+ (rect-x texcoords) (rect-width texcoords))) - (t2 (+ (rect-y texcoords) (rect-height texcoords)))) - (sprite-vertex-append! geometry - (x1 y1 s1 t1) - (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)) - (shader-apply shader - (geometry-vertex-array geometry) - #:tint tint - #:mvp (if matrix - (begin - (matrix4-mult! mvp matrix - (current-projection)) - mvp) - (current-projection)))))) + (texcoords %default-texcoords)) + (match (graphics-variable-ref sprite-state) + ((and state ($ <sprite-state> shader uniforms sampler _ _ bindings)) + (vector-set! bindings 0 texture-view) + (vector-set! bindings 1 sampler) + (vector-set! bindings 2 uniforms) + (call-with-values + (lambda () + (stream-draw #:count 4 + #:shader shader + #:color-target (sprite-color-target state blend-mode) + #:vertex-layout %sprite-vertex-layout + #:binding-layout %sprite-binding-layout + #:bindings bindings)) + (lambda (vertices indices i) + (when (eq? i 0) + (let ((bv (map-buffer uniforms 'write 0 + (bytestruct-sizeof <sprite-uniforms>)))) + (bytestruct-pack! <sprite-uniforms> + (((mvp) (current-projection))) + bv 0) + (unmap-buffer uniforms))) + (sprite-append! vertices indices i rect texcoords tint matrix)))))) (define %null-vec2 (vec2 0.0 0.0)) (define %default-scale (vec2 1.0 1.0)) @@ -147,12 +389,12 @@ void main (void) { #:key (blend-mode blend:alpha) (origin %null-vec2) - (rect (texture-gl-rect texture)) + rect (rotation 0.0) (scale %default-scale) (shear %default-shear) (tint white)) - "Draw TEXTURE at POSITION. + "Draw TEXTURE, a 2D texture or texture view, at POSITION. Optionally, other transformations may be applied to the sprite. ROTATION specifies the angle to rotate the sprite, in radians. SCALE @@ -164,14 +406,17 @@ By default white is used, which does no tinting at all. By default, alpha blending is used but can be changed by specifying BLEND-MODE." - (let ((matrix (graphics-variable-ref sprite-model-matrix))) + (let* ((state (graphics-variable-ref sprite-state)) + (matrix (sprite-state-matrix state)) + (rect (or rect (%sprite-rect state texture)))) (matrix4-2d-transform! matrix #:origin origin #:position position #:rotation rotation #:scale scale #:shear shear) - (draw-sprite* texture rect matrix + (draw-sprite* (if (texture? texture) (texture-view texture) texture) + rect matrix #:tint tint #:blend-mode blend-mode))) @@ -180,152 +425,101 @@ BLEND-MODE." ;;; Sprite Batches ;;; -(define-geometry-type <batched-sprite-vertex> - batched-sprite-ref - batched-sprite-set! - batched-sprite-append! - (position vec2) - (texture vec2) - (tint vec4)) - -(define-graphics-variable sprite-batch-shader - (strings->shader - " -#ifdef GLSL330 -layout (location = 0) in vec2 position; -layout (location = 1) in vec2 tex; -layout (location = 2) in vec4 tint; -#elif defined(GLSL130) -in vec2 position; -in vec2 tex; -in vec4 tint; -#elif defined(GLSL120) -attribute vec2 position; -attribute vec2 tex; -attribute vec4 tint; -#endif -#ifdef GLSL120 -varying vec2 fragTex; -varying vec4 fragTint; -#else -out vec2 fragTex; -out vec4 fragTint; -#endif -uniform mat4 mvp; - -void main(void) { - fragTex = tex; - fragTint = tint; - gl_Position = mvp * vec4(position.xy, 0.0, 1.0); -} -" - " -#ifdef GLSL120 -varying vec2 fragTex; -varying vec4 fragTint; -#else -in vec2 fragTex; -in vec4 fragTint; -#endif -#ifdef GLSL330 -out vec4 fragColor; -#endif -uniform sampler2D colorTexture; - -void main (void) { -#ifdef GLSL330 - fragColor = texture(colorTexture, fragTex) * fragTint; -#else - gl_FragColor = texture2D(colorTexture, fragTex) * fragTint; -#endif -} -")) - (define-record-type <sprite-batch> - (%make-sprite-batch texture geometry size) + (%make-sprite-batch size texture vertices indices buffers pipeline + uniforms sampler bindings matrix) sprite-batch? + (size sprite-batch-size set-sprite-batch-size!) (texture sprite-batch-texture set-sprite-batch-texture!) - (geometry sprite-batch-geometry) - (size sprite-batch-size set-sprite-batch-size!)) + (vertices sprite-batch-vertices) + (indices sprite-batch-indices) + ;; A vector of 1 to vector-set! before each draw. + (buffers sprite-batch-buffers) + (pipeline sprite-batch-pipeline) + (uniforms sprite-batch-uniforms) + (sampler sprite-batch-sampler) + (bindings sprite-batch-bindings) + (matrix sprite-batch-matrix)) -(define* (make-sprite-batch texture #:key (capacity 256)) - "Make a sprite batch that can hold CAPACITY sprites before needing -to resize." - (%make-sprite-batch texture - (make-geometry <batched-sprite-vertex> (* capacity 4) - #:index-capacity (* capacity 6)) - 0)) +(define* (make-sprite-batch texture #:key + (capacity 256) + (blend-mode blend:alpha)) + "Make a sprite batch with enough storage to hold CAPACITY sprites +initially. By default, alpha blending is used when rendering but can +be changed by specifying BLEND-MODE." + (let ((shader (sprite-state-shader (graphics-variable-ref sprite-state))) + (color-target (make-color-target #:blend-mode blend-mode))) + (%make-sprite-batch 0 texture + (make-dbuffer + #:name "Sprite batch vertices" + #:capacity (* capacity 4)) + (make-dbuffer + #:name "Sprite batch indices" + #:capacity (* capacity 6)) + (vector #f) + (make-render-pipeline + #:name "Sprite batch" + #:shader shader + #:color-target color-target + #:vertex-layout %sprite-vertex-layout + #:binding-layout %sprite-binding-layout) + (make-buffer (* 16 4) + #:name "Sprite batch uniform buffer" + #:usage '(uniform)) + (make-sampler #:name "Sprite batch sampler") + (make-vector 3 #f) + (make-null-matrix4)))) (define (sprite-batch-clear! batch) "Reset BATCH to size 0." - (set-sprite-batch-size! batch 0) - (geometry-begin! (sprite-batch-geometry batch))) + (set-sprite-batch-size! batch 0)) -(define (sprite-batch-flush! batch) - "Submit the contents of BATCH to the GPU." - (geometry-end! (sprite-batch-geometry batch))) +(define* (sprite-batch-set!* batch i rect matrix + #:key + (tint white) + (texcoords %default-texcoords)) + (match batch + (($ <sprite-batch> size texture vertices indices) + (unless (< -1 i size) + (error "sprite batch index out of range" i)) + (unless (dbuffer-mapped? vertices) + (dbuffer-map! vertices) + (dbuffer-map! indices)) + (let ((voffset (* i (bytestruct-sizeof <sprite-vertex>) 4)) + (ioffset (* i 6 4))) + (sprite-set! vertices voffset indices ioffset (* i 4) rect texcoords tint matrix))))) (define* (sprite-batch-add* batch rect matrix #:key (tint white) - texture-region) + (texcoords %default-texcoords)) "Add RECT, transformed by MATRIX, to BATCH. To render a subsection -of the batch's texture, a texture object whose parent is the batch -texture may be specified via the TEXTURE-REGION argument." - (let* ((geometry (sprite-batch-geometry batch)) - (vertex-offset (geometry-vertex-count geometry <batched-sprite-vertex>)) - (minx (rect-x rect)) - (miny (rect-y rect)) - (maxx (+ minx (rect-width rect))) - (maxy (+ miny (rect-height rect))) - (x1 (matrix4-transform-x matrix minx miny)) - (y1 (matrix4-transform-y matrix minx miny)) - (x2 (matrix4-transform-x matrix maxx miny)) - (y2 (matrix4-transform-y matrix maxx miny)) - (x3 (matrix4-transform-x matrix maxx maxy)) - (y3 (matrix4-transform-y matrix maxx maxy)) - (x4 (matrix4-transform-x matrix minx maxy)) - (y4 (matrix4-transform-y matrix minx maxy)) - (texcoords (texture-gl-tex-rect - (or texture-region - (sprite-batch-texture batch)))) - (s1 (rect-x texcoords)) - (t1 (rect-y texcoords)) - (s2 (+ (rect-x texcoords) (rect-width texcoords))) - (t2 (+ (rect-y texcoords) (rect-height texcoords))) - (r (color-r tint)) - (g (color-g tint)) - (b (color-b tint)) - (a (color-a tint))) - (batched-sprite-append! geometry - (x1 y1 s1 t1 r g b a) - (x2 y2 s2 t1 r g b a) - (x3 y3 s2 t2 r g b a) - (x4 y4 s1 t2 r g b a)) - (geometry-index-append! geometry - vertex-offset - (+ vertex-offset 3) - (+ vertex-offset 2) - vertex-offset - (+ vertex-offset 2) - (+ vertex-offset 1)) - (set-sprite-batch-size! batch (+ (sprite-batch-size batch) 1)))) - -(define* (sprite-batch-add! batch - position +of the batch's texture, specify a TEXCOORDS rect in texture uv +coordinates." + (match batch + (($ <sprite-batch> size texture vertices indices) + (unless (dbuffer-mapped? vertices) + (dbuffer-map! vertices) + (dbuffer-map! indices)) + (sprite-append! vertices indices (* size 4) rect texcoords tint matrix) + (set-sprite-batch-size! batch (+ size 1))))) + +;; TODO: Specify sub-region in pixel coordinates. +(define* (sprite-batch-add! batch position #:key (origin %null-vec2) (rotation 0.0) (scale %default-scale) (shear %null-vec2) - texture-region - (tint white)) - "Add sprite to BATCH at POSITION. To render a subsection of the -batch's texture, a texture object whose parent is the batch texture -may be specified via the TEXTURE-REGION argument." - (let ((matrix (graphics-variable-ref sprite-model-matrix)) - (rect (texture-gl-rect - (or texture-region (sprite-batch-texture batch))))) + (tint white) + rect + (texcoords %default-texcoords)) + "Add sprite to BATCH at POSITION. To render a subsection +of the batch's texture, specify a TEXCOORDS rect in texture uv +coordinates." + (let* ((state (graphics-variable-ref sprite-state)) + (matrix (sprite-state-matrix state)) + (rect (or rect (%sprite-rect state (sprite-batch-texture batch))))) (matrix4-2d-transform! matrix #:origin origin #:position position @@ -334,35 +528,74 @@ may be specified via the TEXTURE-REGION argument." #:shear shear) (sprite-batch-add* batch rect matrix #:tint tint - #:texture-region texture-region))) + #:texcoords texcoords))) + +(define* (sprite-batch-set! batch i position + #:key + (origin %null-vec2) + (rotation 0.0) + (scale %default-scale) + (shear %null-vec2) + (tint white) + rect + (texcoords %default-texcoords)) + "Overwrite sprite I in BATCH with a new sprite at POSITION. To render +a subsection of the batch's texture, specify a TEXCOORDS rect in +texture uv coordinates." + (let* ((state (graphics-variable-ref sprite-state)) + (matrix (sprite-state-matrix state)) + (rect (or rect (%sprite-rect state (sprite-batch-texture batch))))) + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale + #:shear shear) + (sprite-batch-set!* batch i rect matrix + #:tint tint + #:texcoords texcoords))) -(define* (draw-sprite-batch* batch matrix #:key (blend-mode blend:alpha)) +(define (draw-sprite-batch* batch matrix) "Render the contents of BATCH." - (let ((shader (graphics-variable-ref sprite-batch-shader)) - (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))) - (let ((geometry (sprite-batch-geometry batch))) - (shader-apply* shader - (geometry-vertex-array geometry) - 0 - (geometry-index-count geometry) - #:mvp mvp))))) + (match batch + (($ <sprite-batch> size texture vertices indices vertex-buffers pipeline + uniforms sampler bindings mvp) + (when (dbuffer-mapped? vertices) + (dbuffer-unmap! vertices) + (dbuffer-unmap! indices)) + (unless (eq? size 0) + (let ((view (if (texture-view? texture) + texture + (texture-view texture)))) + (matrix4-mult! mvp matrix (current-projection)) + (let ((bv (map-buffer uniforms 'write 0 + (bytestruct-sizeof <sprite-uniforms>)))) + (bytestruct-pack! <sprite-uniforms> + (((mvp) mvp)) + bv 0) + (unmap-buffer uniforms)) + (vector-set! vertex-buffers 0 (dbuffer-buffer vertices)) + (vector-set! bindings 0 view) + (vector-set! bindings 1 sampler) + (vector-set! bindings 2 uniforms) + (draw (* size 6) + #:pipeline pipeline + #:index-buffer (dbuffer-buffer indices) + #:vertex-buffers vertex-buffers + #:bindings bindings)))))) (define* (draw-sprite-batch batch #:key (position %null-vec2) (origin %null-vec2) (scale %default-scale) - (rotation 0.0) - (blend-mode blend:alpha)) + (rotation 0.0)) "Render the contents of BATCH." - (let ((matrix (graphics-variable-ref sprite-model-matrix))) + (let* ((state (graphics-variable-ref sprite-state)) + (matrix (sprite-state-matrix state))) (matrix4-2d-transform! matrix #:origin origin #:position position #:rotation rotation #:scale scale) - (draw-sprite-batch* batch matrix #:blend-mode blend-mode))) + (draw-sprite-batch* batch matrix))) diff --git a/chickadee/graphics/text.scm b/chickadee/graphics/text.scm index 20b8ca5..15caf85 100644 --- a/chickadee/graphics/text.scm +++ b/chickadee/graphics/text.scm @@ -33,17 +33,17 @@ #:use-module (chickadee config) #:use-module (chickadee data array-list) #:use-module (chickadee freetype) - #:use-module (chickadee math) - #:use-module (chickadee math matrix) - #:use-module (chickadee math rect) - #:use-module (chickadee math vector) - #:use-module (chickadee graphics blend) + #:use-module (chickadee graphics) #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) + #:use-module (chickadee graphics pipeline) #:use-module (chickadee graphics pixbuf) #:use-module (chickadee graphics shader) #:use-module (chickadee graphics sprite) #:use-module (chickadee graphics texture) + #:use-module (chickadee math) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) #:use-module (chickadee utils) #:use-module (rnrs bytevectors) #:export (load-tile-font @@ -63,7 +63,7 @@ glyph? glyph-id - glyph-texture-region + glyph-sprite glyph-offset glyph-dimensions glyph-advance @@ -89,10 +89,10 @@ ;;; (define-record-type <glyph> - (make-glyph id texture-region offset dimensions advance) + (make-glyph id sprite offset dimensions advance) glyph? (id glyph-id) - (texture-region glyph-texture-region) + (sprite glyph-sprite) (offset glyph-offset) (dimensions glyph-dimensions) (advance glyph-advance)) @@ -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 (gpu-limits-max-texture-dimension-2d + (gpu-limits (current-gpu))) + 2048))) ;; TODO: Use actual screen DPI. (set-char-size! face (* point-size 64) 0 96 96) (let ((glyph (face-glyph-slot face)) @@ -197,10 +199,9 @@ non-smooth scaling will be used." char-set)) (texture-filter (if smooth? 'linear 'nearest)) ;; TODO: Use multiple textures if needed. - (texture (make-texture texture-size texture-size - #:pixels pixels - #:min-filter texture-filter - #:mag-filter texture-filter))) + (texture (pixbuf->texture + (bytevector->pixbuf pixels texture-size texture-size))) + (texture-view (texture-view texture))) ;; Process kernings. (char-set-for-each (lambda (left) @@ -225,14 +226,13 @@ non-smooth scaling will be used." ;; Build chars. (for-each (match-lambda ((char x y width height left top advance) - (hashv-set! chars char - (make-glyph char - (and x y - (make-texture-region texture - (make-rect x y width height))) - (vec2 left (- top height)) - (vec2 width height) - (vec2 advance 0.0))))) + (let* ((rect (and x y (make-rect x y width height))) + (sprite (and rect (make-sprite texture-view rect)))) + (hashv-set! chars char + (make-glyph char sprite + (vec2 left (- top height)) + (vec2 width height) + (vec2 advance 0.0)))))) specs))) (let ((style (face-style-name face))) (match (size-metrics (face-size face)) @@ -255,17 +255,17 @@ order that they are specified in the character set or text will not render properly. Optionally, each tile may have SPACING pixels of horizontal and vertical space between surrounding tiles and the entire image may have MARGIN pixels of empty space around its border." - (let* ((texture (load-image file)) - (atlas (split-texture texture tile-width tile-height - #:margin margin - #:spacing spacing)) + (let* ((texture (texture-view (load-image file))) + (sheet (tileset texture tile-width tile-height + #:margin margin + #:spacing spacing)) (chars (let ((table (make-hash-table))) (string-for-each-index (lambda (i) (hashv-set! table (string-ref characters i) (make-glyph (string-ref characters i) - (texture-atlas-ref atlas i) + (sprite-sheet-ref sheet i) (vec2 0.0 0.0) (vec2 tile-width tile-height) (vec2 tile-width 0.0)))) @@ -425,10 +425,9 @@ extension must be either .xml or .fnt." (attr node 'yoffset string->number))) (x-advance (attr node 'xadvance string->number)) (page (or (attr node 'page string->number) 0)) - (region (make-texture-region (hashv-ref pages page) - (make-rect x y width height))) - (char (make-glyph id - region + (sprite (make-sprite (hashv-ref pages page) + (make-rect x y width height))) + (char (make-glyph id sprite (vec2 x-offset y-offset) (vec2 width height) (vec2 x-advance 0.0)))) @@ -624,7 +623,7 @@ is not represented in FONT." (define (page-free-batch page) (let ((free-batches (page-free-batches page))) (if (array-list-empty? free-batches) - (make-sprite-batch null-texture) + (make-sprite-batch #f) (array-list-pop! free-batches)))) (define (make-page-batch page texture) @@ -651,13 +650,13 @@ is not represented in FONT." (offset (glyph-offset glyph)) (dimensions (glyph-dimensions glyph)) (advance (glyph-advance glyph)) - (texture (glyph-texture-region glyph)) + (sprite (glyph-sprite glyph)) (x (vec2-x position)) (y (- (vec2-y size) (vec2-y position))) ;; Not all glyphs have a visual representation, such as ;; the space character. - (batch (and texture - (page-batch page (texture-parent texture))))) + (batch (and sprite + (page-batch page (sprite-texture-view sprite))))) ;; Setup bounding box. (set-rect-x! rect x) (set-rect-y! rect y) @@ -672,13 +671,13 @@ is not represented in FONT." (sprite-batch-add* batch rect (or (composited-glyph-matrix cglyph) %identity-matrix) - #:texture-region texture + #:texcoords (sprite-rect-uv sprite) #:tint (composited-glyph-color cglyph))))) (array-list-for-each write-glyph (compositor-cglyphs compositor)))) (define* (draw-page page matrix #:key (blend-mode blend:alpha)) (hash-for-each (lambda (texture batch) - (draw-sprite-batch* batch matrix #:blend-mode blend-mode)) + (draw-sprite-batch* batch matrix)) (page-batches page))) (define draw-text* diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm index 952cfe0..9d24bf3 100644 --- a/chickadee/graphics/texture.scm +++ b/chickadee/graphics/texture.scm @@ -23,411 +23,191 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (system foreign) - #:use-module (gl) - #:use-module ((gl enums) #:prefix gl:) #:use-module (chickadee math rect) #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) + #:use-module ((chickadee graphics backend) #:prefix gpu:) #:use-module (chickadee graphics pixbuf) #:use-module (chickadee image) #:use-module (chickadee utils) #:export (make-texture - make-texture-region - make-cube-map - pixbuf->texture - load-image - load-cube-map - texture-copy-pixbuf! - texture->pixbuf - write-texture + destroy-texture texture? - texture-region? - cube-map? - texture-null? - texture-type - texture-parent - texture-min-filter - texture-mag-filter - texture-wrap-s - texture-wrap-t - texture-x - texture-y + texture-destroyed? + texture-1d? + texture-2d? + texture-3d? + texture-destroyed? + texture-name texture-width texture-height - texture-gl-rect - texture-gl-tex-rect - null-texture + texture-depth + texture-mip-levels + texture-samples + texture-dimension + texture-format + texture-view black-texture white-texture gray-texture flat-texture - g:texture-0 - g:texture-1 - g:texture-2 - g:texture-3 - g:texture-4 - g:texture-5 - current-texture-0 - current-texture-1 - current-texture-2 - current-texture-3 - current-texture-4 - current-texture-5 - - texture-atlas - list->texture-atlas - split-texture - texture-tileset-dimensions - texture-atlas? - texture-atlas-size - texture-atlas-texture - texture-atlas-ref - load-tileset)) + pixbuf->texture + load-image + + make-texture-view + destroy-texture-view + texture-view? + texture-view-1d? + texture-view-2d? + texture-view-2d-array? + texture-view-3d? + texture-view-cube? + texture-view-cube-array? + texture-view-destroyed? + texture-view-texture + texture-view-name + texture-view-format + texture-view-dimension + texture-view-aspect + texture-view-base-mip-level + texture-view-mip-levels + texture-view-base-layer + texture-view-layers + texture-view-width + texture-view-height + texture-view-depth + + make-sampler + destroy-sampler + sampler? + sampler-destroyed? + sampler-name + sampler-address-mode-u + sampler-address-mode-v + sampler-address-mode-w + sampler-mag-filter + sampler-min-filter + sampler-mipmap-filter)) ;;; ;;; Textures ;;; -;; The <texture> object is a simple wrapper around an OpenGL texture -;; id. (define-record-type <texture> - (%make-texture id type parent min-filter mag-filter wrap-s wrap-t - x y width height gl-rect gl-tex-rect) + (%make-texture gpu handle name destroyed? width height depth mip-levels + samples dimension format) texture? - (id texture-id) - (type texture-type) - (parent texture-parent) - (min-filter texture-min-filter) - (mag-filter texture-mag-filter) - (wrap-s texture-wrap-s) - (wrap-t texture-wrap-t) - (x texture-x) - (y texture-y) + (gpu texture-gpu) + (handle texture-handle) + (name texture-name) + (destroyed? texture-destroyed? set-texture-destroyed!) (width texture-width) (height texture-height) - (gl-rect texture-gl-rect) - (gl-tex-rect texture-gl-tex-rect)) - -(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 texture) - (texture-region? texture) - (texture-x texture) - (texture-y texture) - (texture-width texture) - (texture-height texture) - (texture-min-filter texture) - (texture-mag-filter texture) - (texture-wrap-s texture) - (texture-wrap-t texture)))) - -(define null-texture - (%make-texture 0 '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) - "Return #t if TEXTURE is the null texture." - (eq? texture null-texture)) - -(define (texture-region? texture) - (texture? (texture-parent texture))) - -(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) - (texture-target texture-2d)) - ((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) - (texture-wrap-mode repeat)) - ('mirrored-repeat (version-1-4 mirrored-repeat)) - ((clamp) - (texture-wrap-mode clamp)) - ((clamp-to-border) - (texture-wrap-mode clamp-to-border-sgis)) - ((clamp-to-edge) - (texture-wrap-mode clamp-to-edge-sgis)))) - -(define (gl-min-filter min-filter) - (case min-filter - ((nearest) - (gl:texture-min-filter nearest)) - ((linear) - (gl:texture-min-filter linear)) - ((nearest-mipmap-nearest) - (gl:texture-min-filter nearest-mipmap-nearest)) - ((linear-mipmap-nearest) - (gl:texture-min-filter linear-mipmap-nearest)) - ((nearest-mipmap-linear) - (gl:texture-min-filter nearest-mipmap-linear)) - ((linear-mipmap-linear) - (gl:texture-min-filter linear-mipmap-linear)))) - -(define (gl-mag-filter mag-filter) - (case mag-filter - ((nearest) - (gl:texture-mag-filter nearest)) - ((linear) - (gl:texture-mag-filter linear)))) - -(define (gl-pixel-format format) - (case format - ((rgba) - (pixel-format rgba)))) - -(define* (make-texture width height #:key - pixels flip? - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) - (format 'rgba)) - "Return a new GPU texture of WIDTH x HEIGHT pixels in size. PIXELS -may be a bytevector of WIDTH x HEIGHT pixels in 32-bit RGBA format, in -which case the texture will contain a copy of that data. If PIXELS is -not provided, the texture data will not be initialized. If FLIP? is -#t then the texture coordinates will be flipped vertically. The -generated texture uses MIN-FILTER for downscaling and MAG-FILTER for -upscaling. WRAP-S and WRAP-T are symbols that control how texture -access is handled for texture coordinates outside the [0, 1] range. -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 - 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)) - ;; Ensure that we are using texture unit 0 because - ;; with-graphics-state! doesn't guarantee it. - (set-gl-active-texture (version-1-3 texture0)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (gl-min-filter min-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (gl-mag-filter mag-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-s) - (gl-wrap-mode wrap-s)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-t) - (gl-wrap-mode wrap-t)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (or pixels %null-pointer)) - ;; Generate mipmaps, if needed. - (when (memq min-filter - '(nearest-mipmap-nearest - linear-mipmap-nearest - nearest-mipmap-linear - linear-mipmap-linear)) - (gl-generate-mipmap (texture-target texture-2d)))) - texture)) + (depth texture-depth) + (mip-levels texture-mip-levels) + (samples texture-samples) + (dimension texture-dimension) + (format texture-format) + (view %texture-view set-texture-view!)) + +(define (print-texture texture port) + (match texture + (($ <texture> _ _ name _ width height depth _ _ dimension format*) + (format #t "#<texture name: ~s width: ~s height: ~s depth: ~s dimension: ~s format: ~s>" + name width height depth dimension format*)))) + +(set-record-type-printer! <texture> print-texture) + +(define* (make-texture #:key + name + (width 1) + (height 1) + (depth 1) + (mip-levels 0) + (samples 1) + (dimension '2d) + (format 'rgba8)) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-texture gpu width height depth mip-levels + samples dimension format))) + (%make-texture gpu handle name #f width height depth mip-levels samples + dimension format))) + +(define (destroy-texture texture) + (unless (texture-destroyed? texture) + (gpu:destroy-texture (texture-gpu texture) (texture-handle texture)) + (set-texture-destroyed! texture #t))) + +(define (texture-1d? texture) + "Return #t if TEXTURE is a one-dimensional texture." + (eq? (texture-dimension texture) '1d)) + +(define (texture-2d? texture) + "Return #t if TEXTURE is a two-dimensional texture." + (eq? (texture-dimension texture) '2d)) + +(define (texture-3d? texture) + "Return #t if TEXTURE is a three-dimensional texture." + (eq? (texture-dimension texture) '3d)) + +;; TODO: This should be temporary??? +(define (texture-view texture) + (or (%texture-view texture) + (let ((view (make-texture-view texture))) + (set-texture-view! texture view) + view))) + +(define* (texture-write! texture data #:key + (x 0) (y 0) (z 0) + (width 0) (height 0) (depth 0) + (mip-level 0) (offset 0) + (format 'rgba8)) + (gpu:write-texture (texture-gpu texture) (texture-handle texture) + x y z width height depth mip-level format data offset)) -(define* (pixbuf->texture pixbuf #:key - flip? - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) - (format 'rgba)) - "Translate PIXBUF into a texture stored on the GPU. See -'make-texture' for documentation of all keyword arguments." - (assert-current-graphics-engine) - (let* ((width (pixbuf-width pixbuf)) - (height (pixbuf-height pixbuf)) - (texture (%make-texture (gl-generate-texture) '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)) - ;; Ensure that we are using texture unit 0 because - ;; with-graphics-state! doesn't guarantee it. - (set-gl-active-texture (version-1-3 texture0)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (gl-min-filter min-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (gl-mag-filter mag-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-s) - (gl-wrap-mode wrap-s)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-t) - (gl-wrap-mode wrap-t)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf)) - ;; Generate mipmaps, if needed. - (when (memq min-filter - '(nearest-mipmap-nearest - linear-mipmap-nearest - nearest-mipmap-linear - linear-mipmap-linear)) - (gl-generate-mipmap (texture-target texture-2d)))) +(define (texture-copy-pixbuf! texture pixbuf) + "Copy the contents of PIXBUF to TEXTURE." + (texture-write! texture (pixbuf-pixels pixbuf) + #:width (pixbuf-width pixbuf) + #:height (pixbuf-height pixbuf))) + +(define* (pixbuf->texture pixbuf #:key name) + "Return a new 2D texture loaded with the contents of PIXBUF and the +debug name NAME." + (let ((texture (make-texture #:name name + #:width (pixbuf-width pixbuf) + #:height (pixbuf-height pixbuf)))) + (texture-copy-pixbuf! texture pixbuf) texture)) -(define* (make-cube-map #:key - right left top bottom front back - (min-filter 'linear) - (mag-filter 'linear) - (format 'rgba)) - (define (set-face name pixbuf) - (gl-texture-image-2d (case name - ((right) - (version-1-3 texture-cube-map-positive-x)) - ((left) - (version-1-3 texture-cube-map-negative-x)) - ((top) - (version-1-3 texture-cube-map-positive-y)) - ((bottom) - (version-1-3 texture-cube-map-negative-y)) - ((front) - (version-1-3 texture-cube-map-positive-z)) - ((back) - (version-1-3 texture-cube-map-negative-z))) - 0 - (pixel-format rgba) - (pixbuf-width pixbuf) - (pixbuf-height pixbuf) - 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf))) - (assert-current-graphics-engine) - (let ((texture (%make-texture (gl-generate-texture) '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)) - ;; Ensure that we are using texture unit 0 because - ;; with-graphics-state! doesn't guarantee it. - (set-gl-active-texture (version-1-3 texture0)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-min-filter) - (gl-min-filter min-filter)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-mag-filter) - (gl-mag-filter mag-filter)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-wrap-s) - (gl-wrap-mode 'clamp-to-edge)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-wrap-t) - (gl-wrap-mode 'clamp-to-edge)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-wrap-r-ext) - (gl-wrap-mode 'clamp-to-edge)) - (set-face 'right right) - (set-face 'left left) - (set-face 'top top) - (set-face 'bottom bottom) - (set-face 'front front) - (set-face 'back back) - ;; Generate mipmaps, if needed. - (when (memq min-filter - '(nearest-mipmap-nearest - linear-mipmap-nearest - nearest-mipmap-linear - linear-mipmap-linear)) - (gl-generate-mipmap (gl-texture-target 'cube-map)))) - texture)) +(define (make-simple-texture name width height pixels) + (pixbuf->texture (bytevector->pixbuf pixels width height) + #:name name)) + +(define-syntax-rule (define-simple-texture name name* width height pixels) + (define name + (let ((promise (delay (make-simple-texture name* width height pixels)))) + (define (name) (force promise)) + name))) -(define (make-texture-region texture rect) - "Create a new texture region covering a section of TEXTURE defined -by the bounding box RECT." - (let* ((pw (texture-width texture)) - (ph (texture-height texture)) - (x (rect-x rect)) - (y (rect-y rect)) - (w (rect-width rect)) - (h (rect-height rect)) - (vert-rect (make-rect 0.0 0.0 w h)) - (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph)))) - (case (texture-type texture) - ((2d) - (%make-texture (texture-id texture) - '2d - texture - (texture-min-filter texture) - (texture-mag-filter texture) - (texture-wrap-s texture) - (texture-wrap-t texture) - x y w h - vert-rect - tex-rect)) - (else - (error "regions can only be made from 2d textures"))))) +(define-simple-texture black-texture "Black texture" 2 2 (u32vector 0 0 0 0)) + +(define-simple-texture white-texture "White texture" 2 2 + (u32vector #xffffffff #xffffffff #xffffffff #xffffffff)) + +(define-simple-texture gray-texture "Gray texture" 2 2 + (u32vector #xff808080 #xff808080 #xff808080 #xff808080)) + +;; A "flat" normal map, in tangent space. It's like the identity +;; property for normals. The colors are used to store 3D tangent space +;; vectors, with positive Z being "up". Each coordinate is in the +;; [-1,1] range and then remapped to an 8-bit color channel in the +;; 0-255 range. Thus, 0 maps to 127 or #x80, -1 maps to 0, and 1 maps +;; to 255. A flat tangent normal is (0, 0, 1), which is encoded as +;; the color #xffff8080. Such a value means that a mesh's vertex +;; normals remain completely unchanged by this normal map. +(define-simple-texture flat-texture "Flat texture" 2 2 + (u32vector #xffff8080 #xffff8080 #xffff8080 #xffff8080)) (define (%load-image image transparent-color flip?) (let ((pixbuf (read-image image))) @@ -443,203 +223,404 @@ by the bounding box RECT." ((? string?) (make-image obj)))) (define* (load-image image #:key - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) + name transparent-color (flip? #t)) "Load a texture from an image in IMAGE, which can be an image object -or a file name string. MIN-FILTER and MAG-FILTER describe the method -that should be used for minification and magnification. Valid values -are 'nearest and 'linear. By default, 'nearest is used." +or a file name string." (let ((pixbuf (%load-image (->image image) transparent-color flip?))) - (pixbuf->texture pixbuf - #:min-filter min-filter - #:mag-filter mag-filter - #:wrap-s wrap-s - #:wrap-t wrap-t))) - -(define* (load-cube-map #:key right left top bottom front back - (min-filter 'linear-mipmap-linear) - (mag-filter 'linear)) - (make-cube-map #:right (%load-image (->image right) #f #f) - #:left (%load-image (->image left) #f #f) - #:top (%load-image (->image top) #f #f) - #:bottom (%load-image (->image bottom) #f #f) - #:front (%load-image (->image front) #f #f) - #:back (%load-image (->image back) #f #f) - #:min-filter min-filter - #:mag-filter mag-filter)) + (pixbuf->texture pixbuf #:name name))) -(define (texture-copy-pixbuf! texture pixbuf) - "Copy the contents of PIXBUF to TEXTURE." - (with-graphics-state! ((g:texture-0 texture)) - (gl-texture-sub-image-2d (texture-target texture-2d) 0 - (texture-x texture) (texture-y texture) - (pixbuf-width pixbuf) (pixbuf-height pixbuf) - (gl-pixel-format 'rgba) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf)))) - -(define (texture->pixbuf texture) - "Return a new pixbuf with the contents of TEXTURE." - (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))) - (let ((pixbuf (bytevector->pixbuf pixels w h - #:format 'rgba - #:bit-depth 8))) - (pixbuf-flip-vertically! pixbuf) - pixbuf))) - -(define* (write-texture texture - #:optional (file-name (temp-image-file-name 'png)) - #:key (format 'png)) - "Write TEXTURE to FILE-NAME using FORMAT ('png' by default.)" - (write-image (texture->pixbuf texture) file-name #:format format)) - -(define (black-texture) - null-texture) - -(define %white-texture - (delay - (make-texture 2 2 #:pixels (u32vector #xffffffff #xffffffff - #xffffffff #xffffffff)))) - -(define (white-texture) - (force %white-texture)) - -(define %gray-texture - (delay - (make-texture 2 2 #:pixels (u32vector #xff808080 #xff808080 - #xff808080 #xff808080)))) - -(define (gray-texture) - (force %gray-texture)) + +;;; +;;; Texture views +;;; -;; A "flat" normal map, in tangent space. It's like the identity -;; property for normals. The colors are used to store 3D tangent space -;; vectors, with positive Z being "up". Each coordinate is in the -;; [-1,1] range and then remapped to an 8-bit color channel in the -;; 0-255 range. Thus, 0 maps to 127 or #x80, -1 maps to 0, and 1 maps -;; to 255. The color values are in ABGR ordering. A flat tangent -;; normal is (0, 0, 1), which is encoded as the color #xffff8080. -;; Such a value means that a mesh's vertex normals remain completely -;; unchanged by this normal map. -(define %flat-texture - (delay - (make-texture 2 2 #:pixels (u32vector #xffff8080 #xffff8080 - #xffff8080 #xffff8080)))) - -(define (flat-texture) - (force %flat-texture)) +(define-record-type <texture-view> + (%make-texture-view gpu handle name destroyed? texture format dimension + aspect base-mip-level mip-levels base-layer layers) + texture-view? + (gpu texture-view-gpu) + (handle texture-view-handle) + (name texture-view-name) + (destroyed? texture-view-destroyed? set-texture-view-destroyed!) + (texture texture-view-texture) + (format texture-view-format) + (dimension texture-view-dimension) + (aspect texture-view-aspect) + (base-mip-level texture-view-base-mip-level) + (mip-levels texture-view-mip-levels) + (base-layer texture-view-base-layer) + (layers texture-view-layers)) + +(define (print-texture-view view port) + (match view + (($ <texture-view> _ _ name _ texture format* dimension aspect) + (format port "#<texture-view name: ~s texture: ~s format: ~s dimension: ~s aspect: ~s>" + name texture format* dimension aspect)))) + +(set-record-type-printer! <texture-view> print-texture-view) + +(define* (make-texture-view texture #:key + name + (format (texture-format texture)) + (dimension (texture-dimension texture)) + (aspect 'all) + (base-mip-level 0) + (mip-levels (texture-mip-levels texture)) + (base-layer 0) + (layers (match dimension + ((or 'cube 'cube-array) 6) + (_ 1)))) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-texture-view gpu (texture-handle texture) format + dimension aspect + base-mip-level mip-levels + base-layer layers))) + (%make-texture-view gpu handle name #f texture format dimension aspect + base-mip-level mip-levels base-layer layers))) + +(define (destroy-texture-view view) + (unless (texture-view-destroyed? view) + (gpu:destroy-texture-view (texture-view-gpu view) (texture-view-handle view)) + (set-texture-view-destroyed! view #t))) + +(define (texture-view-1d? view) + "Return #t if TEXTURE-VIEW is a one-dimensional texture view." + (eq? (texture-view-dimension view) '1d)) + +(define (texture-view-2d? view) + "Return #t if TEXTURE-VIEW is a two-dimensional texture view." + (eq? (texture-view-dimension view) '2d)) + +(define (texture-view-2d-array? view) + "Return #t if TEXTURE-VIEW is a two-dimensional array texture view." + (eq? (texture-view-dimension view) '2d-array)) + +(define (texture-view-3d? view) + "Return #t if TEXTURE-VIEW is a three-dimensional texture view." + (eq? (texture-view-dimension view) '3d)) + +(define (texture-view-cube? view) + "Return #t if TEXTURE-VIEW is a cube texture view." + (eq? (texture-view-dimension view) 'cube)) + +(define (texture-view-cube-array? view) + "Return #t if TEXTURE-VIEW is a cube array texture view." + (eq? (texture-view-dimension view) 'cube-array)) + +(define (texture-view-width view) + (texture-width (texture-view-texture view))) + +(define (texture-view-height view) + (texture-height (texture-view-texture view))) + +(define (texture-view-depth view) + (texture-depth (texture-view-texture view))) ;;; -;;; Texture Atlas +;;; Samplers ;;; -(define-record-type <texture-atlas> - (%make-texture-atlas texture vector) - texture-atlas? - (texture texture-atlas-texture) - (vector texture-atlas-vector)) - -(define (display-texture-atlas atlas port) - (format port - "#<texture-atlas texture: ~a size: ~d>" - (texture-atlas-texture atlas) - (vector-length (texture-atlas-vector atlas)))) - -(set-record-type-printer! <texture-atlas> display-texture-atlas) - -(define (list->texture-atlas texture rects) - "Return a new atlas for TEXTURE containing RECTS, a list of texture -coordinate rects denoting the various regions within." - (let ((v (make-vector (length rects)))) - (let loop ((i 0) - (rects rects)) - (match rects - (() (%make-texture-atlas texture v)) - (((x y width height) . rest) - (vector-set! v i (make-texture-region texture (make-rect x y width height))) - (loop (1+ i) rest)))))) - -(define (texture-atlas texture . rects) - "Return a new atlas for TEXTURE containing RECTS, a series of -4-tuples in the form (x y width height) describing the various tiles -within." - (list->texture-atlas texture rects)) - -(define (texture-atlas-size atlas) - "Return the size of ATLAS." - (vector-length (texture-atlas-vector atlas))) - -(define (texture-atlas-ref atlas index) - "Return the texture region associated with INDEX in -ATLAS." - (vector-ref (texture-atlas-vector atlas) index)) - -(define* (texture-tileset-dimensions texture tile-width tile-height #:key - (margin 0) (spacing 0)) - (values (inexact->exact - (ceiling (/ (- (texture-width texture) margin) - (+ tile-width spacing)))) - (inexact->exact - (ceiling (/ (- (texture-height texture) margin) - (+ tile-height spacing)))))) - -(define* (split-texture texture tile-width tile-height #:key - (margin 0) (spacing 0)) - "Return a new texture atlas that splits TEXTURE into a grid of -TILE-WIDTH by TILE-HEIGHT rectangles. Optionally, each tile may have -SPACING pixels of horizontal and vertical space between surrounding -tiles and the entire image may have MARGIN pixels of empty space -around its border. - -This type of texture atlas layout is very common for tile map -terrain." - (call-with-values (lambda () - (texture-tileset-dimensions texture tile-width tile-height - #:margin margin - #:spacing spacing)) - (lambda (columns rows) - (let ((v (make-vector (* rows columns)))) - (define (make-tile tx ty) - (let* ((x (+ (* tx (+ tile-width spacing)) margin)) - (y (+ (* ty (+ tile-height spacing)) margin))) - (make-texture-region texture (make-rect x y tile-width tile-height)))) - (for-range ((x columns) - (y rows)) - (vector-set! v (+ x (* y columns)) (make-tile x y))) - (%make-texture-atlas texture v))))) - -(define* (load-tileset file-name tile-width tile-height #:key - (margin 0) - (spacing 0) - (min-filter 'nearest) +(define-record-type <sampler> + (%make-sampler gpu handle name destroyed? + address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter) + sampler? + (gpu sampler-gpu) + (handle sampler-handle) + (name sampler-name) + (destroyed? sampler-destroyed? set-sampler-destroyed!) + (address-mode-u sampler-address-mode-u) + (address-mode-v sampler-address-mode-v) + (address-mode-w sampler-address-mode-w) + (mag-filter sampler-mag-filter) + (min-filter sampler-min-filter) + (mipmap-filter sampler-mipmap-filter)) + +(define (print-sampler sampler port) + (match sampler + (($ <sampler> _ _ name _ u v w mag min mip) + (format port + "#<sampler name: ~s address-mode: (u: ~s v: ~s w: ~s) filter: (mag: ~s min: ~s: mipmap: ~s)>" + name u v w mag min mip)))) + +(set-record-type-printer! <sampler> print-sampler) + +(define* (make-sampler #:key name + (address-mode-u 'clamp-to-edge) + (address-mode-v 'clamp-to-edge) + (address-mode-w 'clamp-to-edge) (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) - transparent-color) - "Return a new texture atlas that splits the texture loaded from the -file FILE-NAME into a grid of TILE-WIDTH by TILE-HEIGHT rectangles. -See load-image and split-texture for information about all keyword -arguments." - (split-texture (load-image file-name - #:min-filter min-filter - #:mag-filter mag-filter - #:wrap-s wrap-s - #:wrap-t wrap-t - #:transparent-color transparent-color) - tile-width - tile-height - #:margin margin - #:spacing spacing)) + (min-filter 'nearest) + (mipmap-filter 'nearest)) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-sampler gpu address-mode-u address-mode-v + address-mode-w mag-filter min-filter + mipmap-filter))) + (%make-sampler gpu handle name #f + address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter))) + +(define (destroy-sampler sampler) + (unless (sampler-destroyed? sampler) + (gpu:destroy-sampler (sampler-gpu sampler) (sampler-handle sampler)) + (set-sampler-destroyed! sampler #t))) + +;; +;; ;;; +;; ;;; Textures +;; ;;; + +;; ;; The <texture> object is a simple wrapper around an OpenGL texture +;; ;; id. +;; (define-record-type <texture> +;; (%make-texture id type parent min-filter mag-filter wrap-s wrap-t +;; x y width height gl-rect gl-tex-rect) +;; texture? +;; (id texture-id) +;; (type texture-type) +;; (parent texture-parent) +;; (min-filter texture-min-filter) +;; (mag-filter texture-mag-filter) +;; (wrap-s texture-wrap-s) +;; (wrap-t texture-wrap-t) +;; (x texture-x) +;; (y texture-y) +;; (width texture-width) +;; (height texture-height) +;; (gl-rect texture-gl-rect) +;; (gl-tex-rect texture-gl-tex-rect)) + +;; (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 texture) +;; (texture-region? texture) +;; (texture-x texture) +;; (texture-y texture) +;; (texture-width texture) +;; (texture-height texture) +;; (texture-min-filter texture) +;; (texture-mag-filter texture) +;; (texture-wrap-s texture) +;; (texture-wrap-t texture)))) + +;; (define null-texture +;; (%make-texture 0 '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) +;; "Return #t if TEXTURE is the null texture." +;; (eq? texture null-texture)) + +;; (define (texture-region? texture) +;; (texture? (texture-parent texture))) + +;; (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) +;; (texture-target texture-2d)) +;; ((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* (make-texture width height #:key +;; pixels flip? +;; (min-filter 'nearest) +;; (mag-filter 'nearest) +;; (wrap-s 'repeat) +;; (wrap-t 'repeat) +;; (format 'rgba)) +;; "Return a new GPU texture of WIDTH x HEIGHT pixels in size. PIXELS +;; may be a bytevector of WIDTH x HEIGHT pixels in 32-bit RGBA format, in +;; which case the texture will contain a copy of that data. If PIXELS is +;; not provided, the texture data will not be initialized. If FLIP? is +;; #t then the texture coordinates will be flipped vertically. The +;; generated texture uses MIN-FILTER for downscaling and MAG-FILTER for +;; upscaling. WRAP-S and WRAP-T are symbols that control how texture +;; access is handled for texture coordinates outside the [0, 1] range. +;; 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 +;; 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)) +;; ;; Ensure that we are using texture unit 0 because +;; ;; with-graphics-state! doesn't guarantee it. +;; (set-gl-active-texture (version-1-3 texture0)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-min-filter) +;; (gl-min-filter min-filter)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-mag-filter) +;; (gl-mag-filter mag-filter)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-wrap-s) +;; (gl-wrap-mode wrap-s)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-wrap-t) +;; (gl-wrap-mode wrap-t)) +;; (gl-texture-image-2d (texture-target texture-2d) +;; 0 (pixel-format rgba) width height 0 +;; (gl-pixel-format format) +;; (color-pointer-type unsigned-byte) +;; (or pixels %null-pointer)) +;; ;; Generate mipmaps, if needed. +;; (when (memq min-filter +;; '(nearest-mipmap-nearest +;; linear-mipmap-nearest +;; nearest-mipmap-linear +;; linear-mipmap-linear)) +;; (gl-generate-mipmap (texture-target texture-2d)))) +;; texture)) + +;; (define* (make-cube-map #:key +;; right left top bottom front back +;; (min-filter 'linear) +;; (mag-filter 'linear) +;; (format 'rgba)) +;; (define (set-face name pixbuf) +;; (gl-texture-image-2d (case name +;; ((right) +;; (version-1-3 texture-cube-map-positive-x)) +;; ((left) +;; (version-1-3 texture-cube-map-negative-x)) +;; ((top) +;; (version-1-3 texture-cube-map-positive-y)) +;; ((bottom) +;; (version-1-3 texture-cube-map-negative-y)) +;; ((front) +;; (version-1-3 texture-cube-map-positive-z)) +;; ((back) +;; (version-1-3 texture-cube-map-negative-z))) +;; 0 +;; (pixel-format rgba) +;; (pixbuf-width pixbuf) +;; (pixbuf-height pixbuf) +;; 0 +;; (gl-pixel-format format) +;; (color-pointer-type unsigned-byte) +;; (pixbuf-pixels pixbuf))) +;; (assert-current-graphics-engine) +;; (let ((texture (%make-texture (gl-generate-texture) '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)) +;; ;; Ensure that we are using texture unit 0 because +;; ;; with-graphics-state! doesn't guarantee it. +;; (set-gl-active-texture (version-1-3 texture0)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-min-filter) +;; (gl-min-filter min-filter)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-mag-filter) +;; (gl-mag-filter mag-filter)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-wrap-s) +;; (gl-wrap-mode 'clamp-to-edge)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-wrap-t) +;; (gl-wrap-mode 'clamp-to-edge)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-wrap-r-ext) +;; (gl-wrap-mode 'clamp-to-edge)) +;; (set-face 'right right) +;; (set-face 'left left) +;; (set-face 'top top) +;; (set-face 'bottom bottom) +;; (set-face 'front front) +;; (set-face 'back back) +;; ;; Generate mipmaps, if needed. +;; (when (memq min-filter +;; '(nearest-mipmap-nearest +;; linear-mipmap-nearest +;; nearest-mipmap-linear +;; linear-mipmap-linear)) +;; (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 +;; by the bounding box RECT." +;; (let* ((pw (texture-width texture)) +;; (ph (texture-height texture)) +;; (x (rect-x rect)) +;; (y (rect-y rect)) +;; (w (rect-width rect)) +;; (h (rect-height rect)) +;; (vert-rect (make-rect 0.0 0.0 w h)) +;; (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph)))) +;; (case (texture-type texture) +;; ((2d) +;; (%make-texture (texture-id texture) +;; '2d +;; texture +;; (texture-min-filter texture) +;; (texture-mag-filter texture) +;; (texture-wrap-s texture) +;; (texture-wrap-t texture) +;; x y w h +;; vert-rect +;; tex-rect)) +;; (else +;; (error "regions can only be made from 2d textures"))))) + +;; (define* (load-cube-map #:key right left top bottom front back +;; (min-filter 'linear-mipmap-linear) +;; (mag-filter 'linear)) +;; (make-cube-map #:right (%load-image right #f #f) +;; #:left (%load-image left #f #f) +;; #:top (%load-image top #f #f) +;; #:bottom (%load-image bottom #f #f) +;; #:front (%load-image front #f #f) +;; #:back (%load-image back #f #f) +;; #:min-filter min-filter +;; #:mag-filter mag-filter)) + +;; (define (texture->pixbuf texture) +;; "Return a new pixbuf with the contents of TEXTURE." +;; (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))) +;; (let ((pixbuf (bytevector->pixbuf pixels w h +;; #:format 'rgba +;; #:bit-depth 8))) +;; (pixbuf-flip-vertically! pixbuf) +;; pixbuf))) + +;; (define* (write-texture texture +;; #:optional (file-name (temp-image-file-name 'png)) +;; #:key (format 'png)) +;; "Write TEXTURE to FILE-NAME using FORMAT ('png' by default.)" +;; (write-image (texture->pixbuf texture) file-name #:format format)) diff --git a/chickadee/graphics/viewport.scm b/chickadee/graphics/viewport.scm index e305c19..998e23a 100644 --- a/chickadee/graphics/viewport.scm +++ b/chickadee/graphics/viewport.scm @@ -20,110 +20,128 @@ ;;; Code: (define-module (chickadee graphics viewport) - #:use-module (ice-9 match) #:use-module (srfi srfi-9) - #:use-module (gl) - #:use-module (chickadee utils) - #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) - #:export (make-viewport + #:export (<viewport> + make-viewport viewport? viewport-x viewport-y viewport-width viewport-height - viewport-clear-color - viewport-clear-flags - null-viewport - clear-viewport - g:viewport - current-viewport - %default-clear-flags - %default-clear-color)) + viewport-min-depth + viewport-max-depth + + <scissor-rect> + make-scissor-rect + scissor-rect? + scissor-rect-x + scissor-rect-y + scissor-rect-width + scissor-rect-height)) (define-record-type <viewport> - (%make-viewport x y width height clear-color clear-flags) + (%make-viewport x y width height min-depth max-depth) viewport? (x viewport-x) (y viewport-y) (width viewport-width) (height viewport-height) - (clear-color viewport-clear-color) - (clear-flags viewport-clear-flags)) - -(define %default-clear-flags '(color-buffer depth-buffer stencil-buffer)) -;; Just a fun color from the Dawnbringer 32-color palette instead of -;; boring old black. -(define %default-clear-color tango-light-sky-blue) - -(define (assert-non-negative-integer n) - (if (and (integer? n) (>= n 0)) - n - (error "expecting non-negative integer:" n))) - -(define* (make-viewport x y width height #:key - (clear-color %default-clear-color) - (clear-flags %default-clear-flags)) - "Create a viewport that covers an area of the window starting from -coordinates (X, Y) and spanning WIDTH x HEIGHT pixels. Fill the -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) - clear-color - 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 (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) + (min-depth viewport-min-depth) + (max-depth viewport-max-depth)) + +(define* (make-viewport x y width height #:key (min-depth 0.0) (max-depth 1.0)) + (%make-viewport x y width height min-depth max-depth)) + +(define-record-type <scissor-rect> + (make-scissor-rect x y width height) + scissor-rect? + (x scissor-rect-x) + (y scissor-rect-y) + (width scissor-rect-width) + (height scissor-rect-height)) + +;; (define-record-type <viewport> +;; (%make-viewport x y width height clear-color clear-flags) +;; viewport? +;; (x viewport-x) +;; (y viewport-y) +;; (width viewport-width) +;; (height viewport-height) +;; (clear-color viewport-clear-color) +;; (clear-flags viewport-clear-flags)) + +;; (define %default-clear-flags '(color-buffer depth-buffer stencil-buffer)) +;; ;; Just a fun color from the Dawnbringer 32-color palette instead of +;; ;; boring old black. +;; (define %default-clear-color tango-light-sky-blue) + +;; (define (assert-non-negative-integer n) +;; (if (and (integer? n) (>= n 0)) +;; n +;; (error "expecting non-negative integer:" n))) + +;; (define* (make-viewport x y width height #:key +;; (clear-color %default-clear-color) +;; (clear-flags %default-clear-flags)) +;; "Create a viewport that covers an area of the window starting from +;; coordinates (X, Y) and spanning WIDTH x HEIGHT pixels. Fill the +;; 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) +;; clear-color +;; 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 (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) diff --git a/data/shaders/path-fill-frag.glsl b/data/shaders/path-fill-frag.glsl index e839318..3e10bf0 100644 --- a/data/shaders/path-fill-frag.glsl +++ b/data/shaders/path-fill-frag.glsl @@ -12,11 +12,25 @@ varying vec2 fragPosition; in vec2 fragPosition; #endif +#ifdef GLSL120 uniform int mode; uniform vec4 color; uniform vec4 endColor; +uniform mat3 gradientMatrix; uniform vec2 gradientRange; uniform float radialGradientRatio; +#else +layout (std140) uniform Fill +{ + mat4 mvp; + vec4 color; + int mode; + vec4 endColor; + mat3 gradientMatrix; + vec2 gradientRange; + float radialGradientRatio; +}; +#endif vec4 gradientMix(float x) { float start = gradientRange.x; diff --git a/data/shaders/path-fill-vert.glsl b/data/shaders/path-fill-vert.glsl index d66bb14..f8bcace 100644 --- a/data/shaders/path-fill-vert.glsl +++ b/data/shaders/path-fill-vert.glsl @@ -14,9 +14,22 @@ varying vec2 fragPosition; out vec2 fragPosition; #endif +#ifdef GLSL120 uniform mat4 mvp; uniform vec4 color; uniform mat3 gradientMatrix; +#else +layout (std140) uniform Fill +{ + mat4 mvp; + vec4 color; + int mode; + vec4 endColor; + mat3 gradientMatrix; + vec2 gradientRange; + float radialGradientRatio; +}; +#endif void main(void) { // Short-circuit because the fragments will just be discarded diff --git a/data/shaders/path-stroke-frag.glsl b/data/shaders/path-stroke-frag.glsl index 9682c8f..324e3cf 100644 --- a/data/shaders/path-stroke-frag.glsl +++ b/data/shaders/path-stroke-frag.glsl @@ -14,6 +14,7 @@ in vec2 fragTex; in float fragStrokeLength; #endif +#ifdef GLSL120 uniform vec4 color; uniform float feather; uniform int strokeClosed; @@ -21,6 +22,19 @@ uniform float strokeWidth; uniform int strokeCap; uniform int strokeMiterStyle; uniform float strokeMiterLimit; +#else +layout (std140) uniform Stroke +{ + mat4 mvp; + vec4 color; + float feather; + float strokeWidth; + float strokeMiterLimit; + int strokeClosed; + int strokeCap; + int strokeMiterStyle; +}; +#endif float infinity = 1.0 / 0.0; @@ -47,7 +61,7 @@ void main(void) { if (strokeCap == 0) { // none d = infinity; - } else if (strokeCap == 1) { // butt + } else if (strokeCap == 1) { // butt (huh huh) d = max(dx + hw - 2 * feather, dy); } else if (strokeCap == 2) { // square d = max(dx, dy); @@ -58,7 +72,7 @@ void main(void) { } else if (strokeCap == 5) { // triangle in d = max(dy, hw - feather + dx - dy); } - // Stroke inner/join + // Stroke inner/join } else { d = abs(v); } diff --git a/data/shaders/path-stroke-vert.glsl b/data/shaders/path-stroke-vert.glsl index 5915010..f1c7e3a 100644 --- a/data/shaders/path-stroke-vert.glsl +++ b/data/shaders/path-stroke-vert.glsl @@ -22,10 +22,24 @@ out vec2 fragTex; out float fragStrokeLength; #endif +#ifdef GLSL120 uniform mat4 mvp; uniform vec4 color; uniform int mode; uniform int strokeClosed; +#else +layout (std140) uniform Stroke +{ + mat4 mvp; + vec4 color; + float feather; + float strokeWidth; + float strokeMiterLimit; + int strokeClosed; + int strokeCap; + int strokeMiterStyle; +}; +#endif void main(void) { // Short-circuit because the fragments will just be discarded anyway. diff --git a/examples/9-patch.scm b/examples/9-patch.scm index 518ef89..1fa5b85 100644 --- a/examples/9-patch.scm +++ b/examples/9-patch.scm @@ -2,24 +2,25 @@ (chickadee math rect) (chickadee math vector) (chickadee graphics 9-patch) + (chickadee graphics sprite) (chickadee graphics text) (chickadee graphics texture)) -(define image #f) -(define region1 #f) -(define region2 #f) +(define texture #f) +(define sprite1 #f) +(define sprite2 #f) (define area1 (make-rect 192.0 192.0 256.0 96.0)) (define area2 (make-rect 192.0 50.0 256.0 96.0)) (define text-position (vec2 204.0 266.0)) (define (load) - (set! image (load-image "images/dialog-box.png")) - (set! region1 (make-texture-region image (make-rect 0.0 0.0 78.0 39.0))) - (set! region2 (make-texture-region image (make-rect 78.0 0.0 41.0 18.0)))) + (set! texture (texture-view (load-image "images/dialog-box.png"))) + (set! sprite1 (make-sprite texture (make-rect 0.0 0.0 78.0 39.0))) + (set! sprite2 (make-sprite texture (make-rect 78.0 0.0 41.0 18.0)))) (define (draw alpha) - (draw-9-patch region1 area1 #:margin 7.0) - (draw-9-patch region2 area2 #:margin 4.0) + (draw-9-patch sprite1 area1 #:margin 7.0) + (draw-9-patch sprite2 area2 #:margin 4.0) (draw-text "This is the 9-patch test." text-position)) (run-game #:load load #:draw draw) diff --git a/examples/particles.scm b/examples/particles.scm index cab390b..c046fa8 100644 --- a/examples/particles.scm +++ b/examples/particles.scm @@ -17,7 +17,7 @@ (define sprite-texture #f) (define start-time 0.0) (define avg-frame-time 0) -(define stats-text "") +(define stats-text "particles: 0 fps: 0.0") (define (center-x w) (- (/ window-width 2.0) (/ w 2.0))) @@ -27,10 +27,10 @@ (define (load) (set! *random-state* (random-state-from-platform)) - (set! particle-texture (load-image "images/explosion.png")) + (set! particle-texture (texture-view (load-image "images/explosion.png"))) (set! sprite-texture (load-image "images/chickadee.png")) - (set! particles (make-particles 2000 - #:texture particle-texture + (set! particles (make-particles 512 + #:texture-view particle-texture #:end-color (make-color 1.0 1.0 1.0 0.8) #:end-color (make-color 1.0 1.0 1.0 0.0) #:speed-range (vec2 1.0 5.0) @@ -72,9 +72,13 @@ (set-rect-y! area y) (set-vec2! sprite-position (- x 64.0) (- y 64.0)))) +(define (key-press key modifiers repeat?) + (when (eq? key 'q) (abort-game))) + (run-game #:load load #:draw draw #:update update + #:key-press key-press #:mouse-move mouse-move #:window-width window-width #:window-height window-height) diff --git a/examples/path.scm b/examples/path.scm index 44cabdb..8f155e1 100644 --- a/examples/path.scm +++ b/examples/path.scm @@ -4,13 +4,13 @@ (chickadee graphics text) (chickadee math) (chickadee math vector) - (chickadee scripting)) + (chickadee scripting) + (ice-9 format)) (set! *random-state* (random-state-from-platform)) (define (stats-message) - (format #f "fps: ~1,2f" - (/ 1.0 avg-frame-time))) + (format #f "fps: ~1,2f" (/ 1.0 avg-frame-time))) (define start-time 0.0) (define avg-frame-time 0.0) (define stats-text (stats-message)) diff --git a/examples/sprite-autobatch.scm b/examples/sprite-autobatch.scm new file mode 100644 index 0000000..bbae02a --- /dev/null +++ b/examples/sprite-autobatch.scm @@ -0,0 +1,78 @@ +(use-modules (chickadee) + (chickadee math matrix) + (chickadee math rect) + (chickadee math vector) + (chickadee graphics sprite) + (chickadee graphics texture) + + (chickadee graphics) + (chickadee graphics color) + (chickadee scripting) + (ice-9 match) + (statprof)) + +(define start-time 0.0) +(define avg-frame-time 16.0) +(define texture #f) +(define view #f) +(define rect #f) +(define matrix (make-identity-matrix4)) + +(define (load) + (set! texture (load-image "images/shot.png")) + (set! view (make-texture-view texture)) + (set! rect (make-rect 0.0 0.0 + (texture-width texture) + (texture-height texture))) + (script + (forever + (sleep 60) + (pk 'fps (/ 1.0 avg-frame-time))))) + +(define (frand x) + (* (random:uniform) x)) +(define sprites + (map (lambda (i) + (vec2 (- (frand 640.0) 8.0) + (- (frand 480.0) 8.0))) + (iota 30000))) + +(define (draw alpha) + (let loop ((sprites sprites)) + (match sprites + (() (values)) + ((p . rest) + (set-rect-x! rect (vec2-x p)) + (set-rect-y! rect (vec2-y p)) + (draw-sprite* view rect matrix) + (loop rest)))) + (let ((current-time (elapsed-time))) + (set! avg-frame-time + (+ (* (- current-time start-time) 0.1) + (* avg-frame-time 0.9))) + (set! start-time current-time))) + +(define (update dt) + (update-agenda 1)) + +(define (key-press key modifiers repeat) + (when (eq? key 'q) (abort-game))) + +(define (print-gc-stats) + (let ((stats (gc-stats))) + (pk 'gc + (assq-ref stats 'gc-times) + (exact->inexact + (/ (get-internal-real-time) + internal-time-units-per-second)) + (exact->inexact + (/ (assq-ref stats 'gc-time-taken) + 1000000000))))) + +(add-hook! after-gc-hook print-gc-stats) + +(define (start) + (run-game #:load load #:draw draw #:update update #:key-press key-press)) + +;; (statprof start) +(start) diff --git a/examples/sprite-batch.scm b/examples/sprite-batch.scm index e62d1e4..f310092 100644 --- a/examples/sprite-batch.scm +++ b/examples/sprite-batch.scm @@ -64,4 +64,4 @@ (update-agenda 1)) (run-game #:load load #:draw draw #:update update - #:window-title "sprite batch stress test") + #:window-title "sprite batch example") diff --git a/examples/triangle.scm b/examples/triangle.scm new file mode 100644 index 0000000..9249677 --- /dev/null +++ b/examples/triangle.scm @@ -0,0 +1,146 @@ +(use-modules (chickadee) + (chickadee data bytestruct) + (chickadee math vector) + (chickadee graphics) + (chickadee graphics buffer) + (chickadee graphics color) + (chickadee graphics pipeline) + (chickadee graphics shader) + (chickadee graphics texture) + (chickadee graphics viewport) + (rnrs base)) + +(define window-width 800) +(define window-height 600) +(define index-buffer #f) +(define vertex-buffers #f) +(define uniforms #f) +(define texture #f) +(define view #f) +(define sampler #f) +(define shader #f) +(define pipeline #f) +(define pass #f) +(define bindings #f) + +(define-bytestruct <uniforms> + (struct (time f32))) + +(define (load) + (set! index-buffer + (bytevector->buffer (u32vector 0 1 2) + #:name "Triangle indices")) + (set! vertex-buffers + (vector + (bytevector->buffer (f32vector -1.0 -1.0 0.0 0.0 1.0 0.0 0.0 1.0 + +1.0 -1.0 1.0 0.0 0.0 1.0 0.0 1.0 + +0.0 +1.0 0.5 1.0 0.0 0.0 1.0 1.0) + #:name "Triangle position, texture, color"))) + (set! uniforms (make-buffer 4 #:name "Uniform buffer" #:usage '(uniform))) + (set! texture (load-image "images/wall.png" #:name "Wall texture")) + (set! view (make-texture-view texture #:name "Wall texture view")) + (set! sampler (make-sampler #:name "Nearest neighbor sampler" + #:address-mode-u 'repeat + #:address-mode-v 'repeat)) + (set! shader (make-shader + (lambda (lang) + (if (eq? lang 'glsl) + (values " +#ifdef GLSL330 +layout (location = 0) in vec2 position; +layout (location = 1) in vec2 tex; +layout (location = 2) in vec4 color; +#elif defined(GLSL130) +in vec2 position; +in vec2 tex; +in vec4 color; +#elif defined(GLSL120) +attribute vec2 position; +attribute vec2 tex; +attribute vec4 color; +#endif +#ifdef GLSL120 +varying vec2 fragTex; +varying vec4 fragColor; +#else +out vec2 fragTex; +out vec4 fragColor; +#endif + +layout (std140) uniform Time +{ + float time; +}; + +void main(void) { + fragTex = vec2(tex.x, tex.y) + mod(time / 3.0, 1.0); + fragColor = color; + gl_Position = vec4(position, 0.0, 1.0); +} +" + " +#ifdef GLSL120 +varying vec2 fragTex; +varying vec4 fragColor; +#else +in vec2 fragTex; +in vec4 fragColor; +#endif +#ifdef GLSL330 +out vec4 outFragColor; +#else +#define outFragColor gl_FragColor +#define texture texture2D +#endif + +uniform sampler2D sampler; + +void main (void) { + outFragColor = texture(sampler, fragTex) + fragColor; +} +") + (error "unsupported shader language" lang))) + #:name "Triangle shader")) + (set! pipeline + (make-render-pipeline + #:name "Triangle" + #:shader shader + #:vertex-layout + (vector (make-vertex-buffer-layout + #:stride (* 4 8) + #:attributes (vector + (make-vertex-attribute + #:format 'float32x2) + (make-vertex-attribute + #:format 'float32x2 + #:offset (* 2 4)) + (make-vertex-attribute + #:format 'float32x4 + #:offset (* 4 4))))) + #:binding-layout (vector (make-texture-layout) + (make-sampler-layout) + (make-buffer-layout)))) + (set! bindings (vector view sampler uniforms))) + +(define (draw* alpha) + (let ((bv (map-buffer uniforms 'write 0 4))) + (bytestruct-pack! <uniforms> (((time) (mod (elapsed-time) 1000.0))) bv 0) + (unmap-buffer uniforms)) + (draw 3 + #:pipeline pipeline + #:index-buffer index-buffer + #:vertex-buffers vertex-buffers + #:bindings bindings)) + +(define (key-press key modifiers repeat) + (when (eq? key 'q) (abort-game))) + +;; (add-hook! after-gc-hook (lambda () (pk (gc-stats)))) + +(run-game #:load load + #:draw draw* + #:key-press key-press + #:window-width window-width + #:window-height window-height + #:window-fullscreen? #f + #:window-resizable? #t) |