From 85c32e4c1302a3c37a1ebb4cf7b4888affdc4f61 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 3 Oct 2020 22:29:27 -0400 Subject: Rename 'render' subdirectory to 'graphics'. --- Makefile.am | 40 +- README | 4 +- chickadee.scm | 10 +- chickadee/graphics.scm | 201 +++++++ chickadee/graphics/blend.scm | 63 +++ chickadee/graphics/buffer.scm | 605 ++++++++++++++++++++ chickadee/graphics/color.scm | 220 ++++++++ chickadee/graphics/depth.scm | 61 ++ chickadee/graphics/font.scm | 513 +++++++++++++++++ chickadee/graphics/framebuffer.scm | 137 +++++ chickadee/graphics/gl.scm | 330 +++++++++++ chickadee/graphics/gpu.scm | 211 +++++++ chickadee/graphics/model.scm | 1073 ++++++++++++++++++++++++++++++++++++ chickadee/graphics/particles.scm | 490 ++++++++++++++++ chickadee/graphics/pbr.scm | 150 +++++ chickadee/graphics/phong.scm | 253 +++++++++ chickadee/graphics/shader.scm | 826 +++++++++++++++++++++++++++ chickadee/graphics/shapes.scm | 408 ++++++++++++++ chickadee/graphics/sprite.scm | 611 ++++++++++++++++++++ chickadee/graphics/stencil.scm | 137 +++++ chickadee/graphics/texture.scm | 329 +++++++++++ chickadee/graphics/tiled.scm | 497 +++++++++++++++++ chickadee/graphics/viewport.scm | 111 ++++ chickadee/render.scm | 201 ------- chickadee/render/blend.scm | 63 --- chickadee/render/buffer.scm | 605 -------------------- chickadee/render/color.scm | 220 -------- chickadee/render/depth.scm | 61 -- chickadee/render/font.scm | 513 ----------------- chickadee/render/framebuffer.scm | 137 ----- chickadee/render/gl.scm | 330 ----------- chickadee/render/gpu.scm | 211 ------- chickadee/render/model.scm | 1073 ------------------------------------ chickadee/render/particles.scm | 490 ---------------- chickadee/render/pbr.scm | 150 ----- chickadee/render/phong.scm | 253 --------- chickadee/render/shader.scm | 826 --------------------------- chickadee/render/shapes.scm | 408 -------------- chickadee/render/sprite.scm | 611 -------------------- chickadee/render/stencil.scm | 137 ----- chickadee/render/texture.scm | 329 ----------- chickadee/render/tiled.scm | 497 ----------------- chickadee/render/viewport.scm | 111 ---- doc/api.texi | 28 +- examples/audio.scm | 2 +- examples/game-controller.scm | 8 +- examples/grid.scm | 10 +- examples/lines.scm | 4 +- examples/model.scm | 6 +- examples/nine-patch.scm | 6 +- examples/particles.scm | 12 +- examples/sprite-batch.scm | 8 +- examples/sprite.scm | 4 +- examples/text.scm | 2 +- examples/tiled.scm | 4 +- 55 files changed, 7300 insertions(+), 7300 deletions(-) create mode 100644 chickadee/graphics.scm create mode 100644 chickadee/graphics/blend.scm create mode 100644 chickadee/graphics/buffer.scm create mode 100644 chickadee/graphics/color.scm create mode 100644 chickadee/graphics/depth.scm create mode 100644 chickadee/graphics/font.scm create mode 100644 chickadee/graphics/framebuffer.scm create mode 100644 chickadee/graphics/gl.scm create mode 100644 chickadee/graphics/gpu.scm create mode 100644 chickadee/graphics/model.scm create mode 100644 chickadee/graphics/particles.scm create mode 100644 chickadee/graphics/pbr.scm create mode 100644 chickadee/graphics/phong.scm create mode 100644 chickadee/graphics/shader.scm create mode 100644 chickadee/graphics/shapes.scm create mode 100644 chickadee/graphics/sprite.scm create mode 100644 chickadee/graphics/stencil.scm create mode 100644 chickadee/graphics/texture.scm create mode 100644 chickadee/graphics/tiled.scm create mode 100644 chickadee/graphics/viewport.scm delete mode 100644 chickadee/render.scm delete mode 100644 chickadee/render/blend.scm delete mode 100644 chickadee/render/buffer.scm delete mode 100644 chickadee/render/color.scm delete mode 100644 chickadee/render/depth.scm delete mode 100644 chickadee/render/font.scm delete mode 100644 chickadee/render/framebuffer.scm delete mode 100644 chickadee/render/gl.scm delete mode 100644 chickadee/render/gpu.scm delete mode 100644 chickadee/render/model.scm delete mode 100644 chickadee/render/particles.scm delete mode 100644 chickadee/render/pbr.scm delete mode 100644 chickadee/render/phong.scm delete mode 100644 chickadee/render/shader.scm delete mode 100644 chickadee/render/shapes.scm delete mode 100644 chickadee/render/sprite.scm delete mode 100644 chickadee/render/stencil.scm delete mode 100644 chickadee/render/texture.scm delete mode 100644 chickadee/render/tiled.scm delete mode 100644 chickadee/render/viewport.scm diff --git a/Makefile.am b/Makefile.am index cec9e82..ffd4731 100644 --- a/Makefile.am +++ b/Makefile.am @@ -61,26 +61,26 @@ SOURCES = \ chickadee/audio/vorbis.scm \ chickadee/audio/wav.scm \ chickadee/audio.scm \ - chickadee/render/color.scm \ - chickadee/render/gl.scm \ - chickadee/render/gpu.scm \ - chickadee/render/blend.scm \ - chickadee/render/depth.scm \ - chickadee/render/stencil.scm \ - chickadee/render/texture.scm \ - chickadee/render/shader.scm \ - chickadee/render/buffer.scm \ - chickadee/render/viewport.scm \ - chickadee/render/framebuffer.scm \ - chickadee/render.scm \ - chickadee/render/shapes.scm \ - chickadee/render/sprite.scm \ - chickadee/render/font.scm \ - chickadee/render/tiled.scm \ - chickadee/render/particles.scm \ - chickadee/render/phong.scm \ - chickadee/render/pbr.scm \ - chickadee/render/model.scm \ + chickadee/graphics/color.scm \ + chickadee/graphics/gl.scm \ + chickadee/graphics/gpu.scm \ + chickadee/graphics/blend.scm \ + chickadee/graphics/depth.scm \ + chickadee/graphics/stencil.scm \ + chickadee/graphics/texture.scm \ + chickadee/graphics/shader.scm \ + chickadee/graphics/buffer.scm \ + chickadee/graphics/viewport.scm \ + chickadee/graphics/framebuffer.scm \ + chickadee/graphics.scm \ + chickadee/graphics/shapes.scm \ + chickadee/graphics/sprite.scm \ + chickadee/graphics/font.scm \ + chickadee/graphics/tiled.scm \ + chickadee/graphics/particles.scm \ + chickadee/graphics/phong.scm \ + chickadee/graphics/pbr.scm \ + chickadee/graphics/model.scm \ chickadee/scripting/agenda.scm \ chickadee/scripting/script.scm \ chickadee/scripting/channel.scm \ diff --git a/README b/README index 55ce8d6..0886740 100644 --- a/README +++ b/README @@ -15,8 +15,8 @@ #+BEGIN_SRC scheme (use-modules (chickadee) (chickadee math vector) - (chickadee render sprite) - (chickadee render texture)) + (chickadee graphics sprite) + (chickadee graphics texture)) (define sprite #f) diff --git a/chickadee.scm b/chickadee.scm index 7b43888..e974b9f 100644 --- a/chickadee.scm +++ b/chickadee.scm @@ -27,11 +27,11 @@ #:use-module (chickadee config) #:use-module (chickadee game-loop) #:use-module (chickadee math matrix) - #:use-module (chickadee render) - #:use-module (chickadee render color) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:use-module (chickadee render viewport) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:use-module (chickadee graphics viewport) #:use-module (chickadee utils) #:use-module (gl) #:use-module (gl enums) diff --git a/chickadee/graphics.scm b/chickadee/graphics.scm new file mode 100644 index 0000000..a41739e --- /dev/null +++ b/chickadee/graphics.scm @@ -0,0 +1,201 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; High-level rendering API. +;; +;;; Code: + +(define-module (chickadee graphics) + #:use-module (chickadee math matrix) + #:use-module (chickadee graphics gpu) + #:use-module (chickadee graphics blend) + #:use-module (chickadee graphics framebuffer) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (chickadee graphics buffer) + #:use-module (chickadee graphics viewport) + #:use-module (srfi srfi-9) + #:export (current-viewport + current-framebuffer + current-blend-mode + current-depth-test + current-stencil-test + current-texture + current-projection + with-viewport + with-framebuffer + with-blend-mode + with-depth-test + with-stencil-test + with-texture + with-projection + clear-screen + gpu-apply + gpu-apply* + gpu-apply/instanced* + gpu-apply/instanced)) + +(define-record-type + (make-render-context viewport framebuffer blend-mode depth-test + stencil-test projection textures) + render-context? + (viewport render-context-viewport set-render-context-viewport!) + (framebuffer render-context-framebuffer set-render-context-framebuffer!) + (blend-mode render-context-blend-mode set-render-context-blend-mode!) + (depth-test render-context-depth-test set-render-context-depth-test!) + (stencil-test render-context-stencil-test set-render-context-stencil-test!) + (projection render-context-projection set-render-context-projection!) + (textures render-context-textures)) + +(define render-context + (make-render-context null-viewport + null-framebuffer + 'replace + #f + #f + (make-identity-matrix4) + (make-vector 32 null-texture))) + +(define (current-viewport) + (render-context-viewport render-context)) + +(define (current-framebuffer) + (render-context-framebuffer render-context)) + +(define (current-blend-mode) + (render-context-blend-mode render-context)) + +(define (current-depth-test) + (render-context-depth-test render-context)) + +(define (current-stencil-test) + (render-context-stencil-test render-context)) + +(define (current-texture i) + (vector-ref (render-context-textures render-context) i)) + +(define (current-projection) + (render-context-projection render-context)) + +(define-syntax-rule (with (getter setter value) body ...) + (let ((prev (getter render-context))) + (setter render-context value) + body ... + (setter render-context prev))) + +(define-syntax-rule (with-viewport viewport body ...) + (with (render-context-viewport set-render-context-viewport! viewport) + body ...)) + +(define (clear-screen) + (let ((viewport (current-viewport))) + (set-gpu-framebuffer! (current-gpu) (current-framebuffer)) + (set-gpu-viewport! (current-gpu) viewport) + (clear-viewport viewport))) + +(define-syntax-rule (with-framebuffer framebuffer body ...) + (with (render-context-framebuffer set-render-context-framebuffer! framebuffer) + ;; As a convenience, initialize the viewport and projection + ;; matrix as well so that the user doesn't have to explicitly + ;; make a viewport and/or projection matrix unless they + ;; actually want to do fancy viewport manipulations. + (with-viewport (framebuffer-viewport framebuffer) + (with-projection (framebuffer-projection framebuffer) + body ...)))) + +(define-syntax-rule (with-blend-mode blend-mode body ...) + (with (render-context-blend-mode set-render-context-blend-mode! blend-mode) + body ...)) + +(define-syntax-rule (with-depth-test depth-test body ...) + (with (render-context-depth-test set-render-context-depth-test! depth-test) + body ...)) + +(define-syntax-rule (with-stencil-test stencil-test body ...) + (with (render-context-stencil-test set-render-context-stencil-test! stencil-test) + body ...)) + +(define-syntax-rule (with-texture n texture body ...) + (let* ((textures (render-context-textures render-context)) + (prev (vector-ref textures n))) + (dynamic-wind + (lambda () (vector-set! textures n texture)) + (lambda () body ...) + (lambda () (vector-set! textures n prev))))) + +(define-syntax-rule (with-projection matrix body ...) + (with (render-context-projection set-render-context-projection! matrix) + body ...)) + +(define (keyword->string kw) + (symbol->string (keyword->symbol kw))) + +(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 (gpu-prepare shader vertex-array uniforms) + (let ((gpu (current-gpu))) + ;; It's important that the framebuffer is set before setting the + ;; viewport because applying a new viewport will clear the current + ;; framebuffer. + (set-gpu-framebuffer! gpu (current-framebuffer)) + (set-gpu-viewport! gpu (current-viewport)) + (set-gpu-blend-mode! gpu (current-blend-mode)) + (set-gpu-depth-test! gpu (current-depth-test)) + (set-gpu-stencil-test! gpu (current-stencil-test)) + (set-gpu-shader! gpu shader) + (let loop ((i 0)) + (when (< i 32) + (set-gpu-texture! gpu i (current-texture i)) + (loop (1+ i)))) + (uniform-apply shader uniforms) + ;; Sampler2D values aren't explicitly passed as uniform values via + ;; gpu-apply, so we have to bind them to the proper texture units + ;; behind the scenes. + (shader-uniform-for-each + (lambda (uniform) + (when (eq? (uniform-type uniform) sampler-2d) + (set-uniform-value! shader uniform (uniform-value uniform)))) + shader))) + +(define-syntax-rule (gpu-apply* shader vertex-array count . uniforms) + (begin + (gpu-prepare shader vertex-array uniforms) + (render-vertices vertex-array count))) + +(define-syntax-rule (gpu-apply shader vertex-array uniforms ...) + (gpu-apply* shader vertex-array #f uniforms ...)) + +(define-syntax-rule (gpu-apply/instanced* shader vertex-array count instances . + uniforms) + (begin + (gpu-prepare shader vertex-array uniforms) + (render-vertices/instanced vertex-array instances count))) + +(define-syntax-rule (gpu-apply/instanced shader vertex-array instances + uniforms ...) + (gpu-apply/instanced* shader vertex-array #f instances uniforms ...)) diff --git a/chickadee/graphics/blend.scm b/chickadee/graphics/blend.scm new file mode 100644 index 0000000..465a449 --- /dev/null +++ b/chickadee/graphics/blend.scm @@ -0,0 +1,63 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics blend) + #:use-module (ice-9 match) + #:use-module (gl) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:export (apply-blend-mode)) + +(define (apply-blend-mode blend-mode) + (if blend-mode + (begin + (gl-enable (enable-cap blend)) + (match blend-mode + ('alpha + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src src-alpha) + (blending-factor-dest one-minus-src-alpha))) + ('multiply + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src dst-color) + (blending-factor-dest zero))) + ('subtract + (gl-blend-equation + (blend-equation-mode-ext func-reverse-subtract-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('add + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest one))) + ('lighten + (gl-blend-equation (blend-equation-mode-ext max-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('darken + (gl-blend-equation (blend-equation-mode-ext min-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('screen + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest one-minus-src-color))) + ('replace + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))))) + (gl-disable (enable-cap blend)))) diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm new file mode 100644 index 0000000..cfb541f --- /dev/null +++ b/chickadee/graphics/buffer.scm @@ -0,0 +1,605 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2017, 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; GPU data buffers. +;; +;;; Code: + +(define-module (chickadee graphics buffer) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (rnrs bytevectors) + #: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 gl) + #:use-module (chickadee graphics gpu) + #:export (make-buffer + make-streaming-buffer + buffer? + index-buffer? + buffer-mapped? + buffer-name + buffer-length + buffer-stride + buffer-target + buffer-usage + buffer-data + null-buffer + apply-buffer + map-buffer! + unmap-buffer! + with-mapped-buffer + make-buffer-view + make-streaming-buffer-view + buffer-view? + buffer-view->buffer + buffer-view->vector + buffer-view-name + buffer-view-offset + buffer-view-component-type + buffer-view-normalized? + buffer-view-count + buffer-view-type + buffer-view-max + buffer-view-min + buffer-view-sparse + buffer-view-data + buffer-view-divisor + map-buffer-view! + unmap-buffer-view! + with-mapped-buffer-view + make-vertex-array + apply-vertex-array + vertex-array? + vertex-array-indices + vertex-array-attributes + vertex-array-mode + null-vertex-array + render-vertices + render-vertices/instanced)) + +;;; +;;; Buffers +;;; + +(define-record-type + (%make-buffer id name length stride target usage data) + buffer? + (id buffer-id) + (name buffer-name) + (length buffer-length) + (stride buffer-stride) + (target buffer-target) + (usage buffer-usage) + (data buffer-data set-buffer-data!)) + +(set-record-type-printer! + (lambda (buffer port) + (format port + "#" + (buffer-id buffer) + (buffer-name buffer) + (buffer-usage buffer) + (buffer-target buffer) + (buffer-length buffer) + (buffer-stride buffer)))) + +(define null-buffer + (%make-buffer 0 "null" 0 0 'vertex 'static #f)) + +(define <> (class-of null-buffer)) + +(define (free-buffer buffer) + (gl-delete-buffers 1 (u32vector (buffer-id buffer)))) + +(define-method (gpu-finalize (buffer <>)) + (free-buffer buffer)) + +(define (apply-buffer buffer) + (gl-bind-buffer (buffer-target-gl buffer) + (buffer-id 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) + (match (buffer-usage buffer) + ('static (arb-vertex-buffer-object static-draw-arb)) + ('stream (arb-vertex-buffer-object stream-draw-arb)))) + +(define (buffer-target-gl buffer) + (if (index-buffer? buffer) + (arb-vertex-buffer-object element-array-buffer-arb) + (arb-vertex-buffer-object array-buffer-arb))) + +(define* (make-buffer data #:key + (name "anonymous") + (length (bytevector-length data)) + (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." + ;; Weird bugs will occur when creating a new vertex buffer while a + ;; vertex array is bound. + (set-gpu-vertex-array! (current-gpu) null-vertex-array) + (let ((buffer (gpu-guard + (%make-buffer (generate-buffer-gl) + name + length + stride + target + usage + #f)))) + (set-gpu-vertex-buffer! (current-gpu) buffer) + (gl-buffer-data (buffer-target-gl buffer) + length + (if data + (bytevector->pointer data offset) + %null-pointer) + (buffer-usage-gl buffer)) + (set-gpu-vertex-buffer! (current-gpu) null-buffer) + buffer)) + +(define* (make-streaming-buffer length #:key + (name "anonymous") + (target 'vertex)) + "Return a new vertex buffer of LENGTH bytes, named NAME, suitable +for streaming data to the GPU every frame." + (make-buffer #f #:usage 'stream #:length length #:name name #:target target)) + +(define (buffer-mapped? buffer) + "Return #t if buffer data has been mapped from GPU." + (if (buffer-data buffer) #t #f)) + +(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))) + (set-gpu-vertex-buffer! (current-gpu) 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 (match mode + ('read-write (version-1-5 read-write)) + ('read-only (version-1-5 read-only)) + ('write-only (version-1-5 write-only)))))) + (set-buffer-data! buffer (pointer->bytevector ptr length)))))) + +(define (unmap-buffer! buffer) + "Return the mapped vertex buffer data for BUFFER to the GPU." + (set-gpu-vertex-buffer! (current-gpu) buffer) + (gl-unmap-buffer (buffer-target-gl buffer)) + (set-buffer-data! buffer #f)) + +(define-syntax-rule (with-mapped-buffer buffer body ...) + (dynamic-wind + (lambda () + (map-buffer! buffer)) + (lambda () body ...) + (lambda () + (unmap-buffer! buffer)))) + + +;;; +;;; Buffer Views +;;; + +(define-record-type + (%make-buffer-view name buffer offset component-type + normalized? length type max min sparse divisor) + buffer-view? + (name buffer-view-name) + (buffer buffer-view->buffer) + (offset buffer-view-offset) + (component-type buffer-view-component-type) + (normalized? buffer-view-normalized?) + (length buffer-view-length) + (type buffer-view-type) + (max buffer-view-max) + (min buffer-view-min) + (sparse buffer-view-sparse) + (divisor buffer-view-divisor)) ; for instanced rendering + +(define (buffer-view-stride buffer-view) + (or (buffer-stride (buffer-view->buffer buffer-view)) + (* (type-size (buffer-view-type buffer-view)) + (component-type-size (buffer-view-component-type buffer-view))))) + +(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-buffer-view #:key + (name "anonymous") + buffer + type + component-type + normalized? + (offset 0) + (length (num-elements (buffer-length buffer) + offset + type + component-type)) + max + min + sparse + divisor) + "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 +- 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." + (%make-buffer-view name buffer offset component-type + normalized? length type max min sparse divisor)) + +(define (type-size type) + (match type + ('scalar 1) + ('vec2 2) + ('vec3 3) + ((or 'vec4 'mat2) 4) + ('mat3 9) + ('mat4 16))) + +(define (component-type-size component-type) + (match component-type + ('byte 1) + ('unsigned-byte 1) + ('short 2) + ('unsigned-short 2) + ('int 4) + ('unsigned-int 4) + ('float 4) + ('double 8))) + +(define* (make-streaming-buffer-view type component-type length #:key + (name "anonymous") + (target 'vertex) + data + divisor) + "Return a new typed buffer to hold LENGTH elements of TYPE whose +components are comprised of COMPONENT-TYPE values. The underlying +untyped buffer is configured for GPU streaming. Optonally, a NAME can +be specified for the buffer. If the buffer will be used for instanced +rendering, the DIVISOR argument must be used to specify the rate at +which attributes advance when rendering multiple instances." + (let* ((buffer-length + (* length (type-size type) (component-type-size component-type))) + (buffer (if data + (make-buffer data + #:name name + #:length buffer-length + #:usage 'stream + #:target target) + (make-streaming-buffer buffer-length + #:name name + #:target target)))) + (make-buffer-view #:name name + #:buffer buffer + #:type type + #:component-type component-type + #:length length + #:divisor divisor))) + +(define (display-buffer-view buffer-view port) + (format port "#" + (buffer-view-name buffer-view) + (buffer-view->buffer buffer-view) + (buffer-view-type buffer-view) + (buffer-view-component-type buffer-view) + (buffer-view-length buffer-view) + (buffer-view-offset buffer-view))) + +(set-record-type-printer! display-buffer-view) + +(define (buffer-view-type-size buffer-view) + (type-size (buffer-view-type buffer-view))) + +(define (buffer-view-data buffer-view) + (buffer-data (buffer-view->buffer buffer-view))) + +(define (buffer-view-type-gl buffer-view) + (match (buffer-view-component-type buffer-view) + ('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 (map-buffer-view! buffer-view) + (map-buffer! (buffer-view->buffer buffer-view))) + +(define (unmap-buffer-view! buffer-view) + (unmap-buffer! (buffer-view->buffer buffer-view))) + +(define-syntax-rule (with-mapped-buffer-view buffer-view body ...) + (with-mapped-buffer (buffer-view->buffer buffer-view) body ...)) + +(define* (apply-buffer-view buffer-view #:optional attribute-index) + (set-gpu-vertex-buffer! (current-gpu) (buffer-view->buffer buffer-view)) + ;; 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 + (buffer-view-type-size buffer-view) + (buffer-view-type-gl buffer-view) + (buffer-view-normalized? buffer-view) + (buffer-view-stride buffer-view) + (make-pointer (buffer-view-offset buffer-view))) + (let ((divisor (buffer-view-divisor buffer-view))) + (when divisor + (gl-vertex-attrib-divisor attribute-index divisor))))) + +;; TODO: Handle 4-byte alignment rule for the types that need it. +(define (buffer-view->vector buffer-view) + (define (component-parser type) + (match type + ('byte bytevector-s8-ref) + ('unsigned-byte bytevector-u8-ref) + ('short + (lambda (bv i) + (bytevector-s16-ref bv i (native-endianness)))) + ('unsigned-short + (lambda (bv i) + (bytevector-u16-ref bv i (native-endianness)))) + ('unsigned-int + (lambda (bv i) + (bytevector-u32-ref bv i (native-endianness)))) + ('float bytevector-ieee-single-native-ref))) + (define (element-parser type component-type) + (let ((parse-component (component-parser component-type)) + (component-type-size (component-type-size component-type))) + (match type + ('scalar parse-component) + ('vec2 + (lambda (bv i) + (vec2 (parse-component bv i) + (parse-component bv (+ i component-type-size))))) + ('vec3 + (lambda (bv i) + (vec3 (parse-component bv i) + (parse-component bv (+ i component-type-size)) + (parse-component bv (+ i (* component-type-size 2)))))) + ;; TODO: Use a proper vec4 type when it exists. + ('vec4 + (lambda (bv i) + (vector (parse-component bv i) + (parse-component bv (+ i component-type-size)) + (parse-component bv (+ i (* component-type-size 2))) + (parse-component bv (+ i (* component-type-size 3)))))) + ;; TODO: Use proper matrix2 type when it exists. + ('mat2 + (lambda (bv i) + (vector (vector (parse-component bv i) + (parse-component bv (+ i component-type-size))) + (vector (parse-component bv (+ i (* component-type-size 2))) + (parse-component bv (+ i (* component-type-size 3))))))) + ;; TODO: Use proper matrix3 type when it exists. + ('mat3 + (lambda (bv i) + (vector (vector (parse-component bv i) + (parse-component bv (+ i component-type-size)) + (parse-component bv (+ i (* component-type-size 2)))) + (vector (parse-component bv (+ i (* component-type-size 3))) + (parse-component bv (+ i (* component-type-size 4))) + (parse-component bv (+ i (* component-type-size 5))))))) + ('mat4 + (lambda (bv i) + (make-matrix4 (parse-component bv i) + (parse-component bv (+ i component-type-size)) + (parse-component bv (+ i (* component-type-size 2))) + (parse-component bv (+ i (* component-type-size 3))) + (parse-component bv (+ i (* component-type-size 4))) + (parse-component bv (+ i (* component-type-size 5))) + (parse-component bv (+ i (* component-type-size 6))) + (parse-component bv (+ i (* component-type-size 7))) + (parse-component bv (+ i (* component-type-size 8))) + (parse-component bv (+ i (* component-type-size 9))) + (parse-component bv (+ i (* component-type-size 10))) + (parse-component bv (+ i (* component-type-size 11))) + (parse-component bv (+ i (* component-type-size 12))) + (parse-component bv (+ i (* component-type-size 13))) + (parse-component bv (+ i (* component-type-size 14))) + (parse-component bv (+ i (* component-type-size 15))))))))) + (with-mapped-buffer-view buffer-view + (let* ((data (buffer-view-data buffer-view)) + (length (buffer-view-length buffer-view)) + (offset (buffer-view-offset buffer-view)) + (stride (buffer-view-stride buffer-view)) + (type (buffer-view-type buffer-view)) + (component-type (buffer-view-component-type buffer-view)) + (type-byte-size (* (type-size type) + (component-type-size component-type))) + (v (make-vector length)) + (parse-element (element-parser type component-type))) + (let loop ((i 0)) + (when (< i length) + (let ((byte-index (+ (* i stride) offset))) + (vector-set! v i (parse-element data byte-index))) + (loop (+ i 1)))) + v))) + + +;;; +;;; Vertex Arrays +;;; + +(define-record-type + (%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! + (lambda (array port) + (format port + "#" + (vertex-array-indices array) + (vertex-array-attributes array) + (vertex-array-mode array)))) + +(define null-vertex-array (%make-vertex-array 0 #f '() 'triangles)) + +(define <> (class-of null-vertex-array)) + +(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-method (gpu-finalize (va <>)) + (free-vertex-array va)) + +(define (apply-vertex-array va) + (gl-bind-vertex-array (vertex-array-id va))) + +(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" + (let ((array (gpu-guard + (%make-vertex-array (generate-vertex-array) + indices + attributes + mode)))) + (set-gpu-vertex-array! (current-gpu) array) + (for-each (match-lambda + ((index . buffer-view) + (apply-buffer-view buffer-view index))) + attributes) + (apply-buffer-view indices) + (set-gpu-vertex-array! (current-gpu) null-vertex-array) + array)) + +(define (vertex-array-mode-gl array) + (match (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 #:optional count) + (set-gpu-vertex-array! (current-gpu) array) + (let ((indices (vertex-array-indices array))) + (gl-draw-elements (vertex-array-mode-gl array) + (or count + (buffer-view-length indices)) + (buffer-view-type-gl indices) + %null-pointer))) + +(define* (render-vertices/instanced array instances #:optional count) + (set-gpu-vertex-array! (current-gpu) array) + (let ((indices (vertex-array-indices array))) + (gl-draw-elements-instanced (vertex-array-mode-gl array) + (or count + (buffer-view-length indices)) + (buffer-view-type-gl indices) + %null-pointer + instances))) diff --git a/chickadee/graphics/color.scm b/chickadee/graphics/color.scm new file mode 100644 index 0000000..1a0be6d --- /dev/null +++ b/chickadee/graphics/color.scm @@ -0,0 +1,220 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2018 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Colors! +;; +;;; Code: + +(define-module (chickadee graphics color) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-1) + #:use-module (chickadee math) + #:export (color make-color + color? + color-r color-g color-b color-a + rgba rgb transparency string->color + color* color+ color- color-inverse color-lerp + + white black red green blue yellow magenta cyan transparent + tango-light-butter tango-butter tango-dark-butter + tango-light-orange tango-orange tango-dark-orange + tango-light-chocolate tango-chocolate tango-dark-chocolate + tango-light-chameleon tango-chameleon tango-dark-chameleon + tango-light-sky-blue tango-sky-blue tango-dark-sky-blue + tango-light-plum tango-plum tango-dark-plum + tango-light-scarlet-red tango-scarlet-red tango-dark-scarlet-red + tango-aluminium-1 tango-aluminium-2 tango-aluminium-3 + tango-aluminium-4 tango-aluminium-5 tango-aluminium-6)) + +(define-record-type + (wrap-color bv) + color? + (bv unwrap-color)) + +(define-inlinable (color-r color) + (f32vector-ref (unwrap-color color) 0)) + +(define-inlinable (color-g color) + (f32vector-ref (unwrap-color color) 1)) + +(define-inlinable (color-b color) + (f32vector-ref (unwrap-color color) 2)) + +(define-inlinable (color-a color) + (f32vector-ref (unwrap-color color) 3)) + +(define-inlinable (make-color r g b a) + (wrap-color + (f32vector + (clamp 0.0 1.0 r) + (clamp 0.0 1.0 g) + (clamp 0.0 1.0 b) + (clamp 0.0 1.0 a)))) + +(define-inlinable (color r g b a) + (make-color r g b a)) + +(define (color-component color-code offset) + "Return the value of an 8-bit color channel in the range [0,1] for +the integer COLOR-CODE, given an OFFSET in bits." + (let ((mask (ash #xff offset))) + (/ (ash (logand mask color-code) + (- offset)) + 255.0))) + +(define (rgba color-code) + "Translate an RGBA format string COLOR-CODE into a color object. +For example: #xffffffff will return a color with RGBA values 1, 1, 1, +1." + (make-color (color-component color-code 24) + (color-component color-code 16) + (color-component color-code 8) + (color-component color-code 0))) + +(define (rgb color-code) + "Translate an RGB format string COLOR-CODE into a color object. +For example: #xffffff will return a color with RGBA values 1, 1, 1, +1." + (make-color (color-component color-code 16) + (color-component color-code 8) + (color-component color-code 0) + 1.0)) + +(define (transparency alpha) + "Create a new color that is white with a transparency value of +ALPHA. ALPHA is clamped to the range [0, 1]." + (make-color 1 1 1 alpha)) + +(define (string->color s) + "Convert the color code string S, in a format like \"#RRGGBBAA\", to +a color object." + (define (parse-digit i) + (match (string-ref s i) + (#\0 0) + (#\1 1) + (#\2 2) + (#\3 3) + (#\4 4) + (#\5 5) + (#\6 6) + (#\7 7) + (#\8 8) + (#\9 9) + ((or #\a #\A) 10) + ((or #\b #\B) 11) + ((or #\c #\C) 12) + ((or #\d #\D) 13) + ((or #\e #\E) 14) + ((or #\f #\F) 15))) + (define (parse-channel i) + (/ (+ (* (parse-digit i) 16) + (parse-digit (+ i 1))) + 255.0)) + ;; Support color codes with or without a "#" prefix and with or + ;; without an alpha channel. + (let* ((start (if (string-prefix? "#" s) 1 0)) + (alpha? (> (string-length s) (+ start 6))) + (red (parse-channel start)) + (green (parse-channel (+ start 2))) + (blue (parse-channel (+ start 4))) + (alpha (if alpha? + (parse-channel (+ start 6)) + 1.0))) + (make-color red green blue alpha))) + +(define-inlinable (color* a b) + (if (color? b) + (make-color (* (color-r a) (color-r b)) + (* (color-g a) (color-g b)) + (* (color-b a) (color-b b)) + (* (color-a a) (color-a b))) + ;; Scalar multiplication. + (make-color (* (color-r a) b) + (* (color-g a) b) + (* (color-b a) b) + (* (color-a a) b)))) + +(define-inlinable (color+ a b) + (make-color (+ (color-r a) (color-r b)) + (+ (color-g a) (color-g b)) + (+ (color-b a) (color-b b)) + (+ (color-a a) (color-a b)))) + +(define-inlinable (color- a b) + (make-color (- (color-r a) (color-r b)) + (- (color-g a) (color-g b)) + (- (color-b a) (color-b b)) + (- (color-a a) (color-a b)))) + +(define-inlinable (color-inverse color) + (make-color (- 1.0 (color-r color)) + (- 1.0 (color-g color)) + (- 1.0 (color-b color)) + ;; Do not alter alpha channel. + (color-a color))) + +(define-inlinable (color-lerp start end alpha) + (color+ (color* start (- 1.0 alpha)) + (color* end alpha))) + +;;; +;;; Pre-defined Colors +;;; + +;; Basic +(define white (rgb #xffffff)) +(define black (rgb #x000000)) +(define red (rgb #xff0000)) +(define green (rgb #x00ff00)) +(define blue (rgb #x0000ff)) +(define yellow (rgb #xffff00)) +(define magenta (rgb #xff00ff)) +(define cyan (rgb #x00ffff)) +(define transparent (make-color 0 0 0 0)) + +;; Tango color pallete +;; http://tango.freedesktop.org +(define tango-light-butter (rgb #xfce94f)) +(define tango-butter (rgb #xedd400)) +(define tango-dark-butter (rgb #xc4a000)) +(define tango-light-orange (rgb #xfcaf3e)) +(define tango-orange (rgb #xf57900)) +(define tango-dark-orange (rgb #xce5c00)) +(define tango-light-chocolate (rgb #xe9b96e)) +(define tango-chocolate (rgb #xc17d11)) +(define tango-dark-chocolate (rgb #x8f5902)) +(define tango-light-chameleon (rgb #x8ae234)) +(define tango-chameleon (rgb #x73d216)) +(define tango-dark-chameleon (rgb #x4e9a06)) +(define tango-light-sky-blue (rgb #x729fcf)) +(define tango-sky-blue (rgb #x3465a4)) +(define tango-dark-sky-blue (rgb #x204a87)) +(define tango-light-plum (rgb #xad7fa8)) +(define tango-plum (rgb #x75507b)) +(define tango-dark-plum (rgb #x5c3566)) +(define tango-light-scarlet-red (rgb #xef2929)) +(define tango-scarlet-red (rgb #xcc0000)) +(define tango-dark-scarlet-red (rgb #xa40000)) +(define tango-aluminium-1 (rgb #xeeeeec)) +(define tango-aluminium-2 (rgb #xd3d7cf)) +(define tango-aluminium-3 (rgb #xbabdb6)) +(define tango-aluminium-4 (rgb #x888a85)) +(define tango-aluminium-5 (rgb #x555753)) +(define tango-aluminium-6 (rgb #x2e3436)) diff --git a/chickadee/graphics/depth.scm b/chickadee/graphics/depth.scm new file mode 100644 index 0000000..8e622e4 --- /dev/null +++ b/chickadee/graphics/depth.scm @@ -0,0 +1,61 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2020 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics depth) + #:use-module (ice-9 match) + #:use-module (gl) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:use-module (srfi srfi-9) + #:export (make-depth-test + depth-test? + depth-test-write? + depth-test-function + depth-test-near + depth-test-far + default-depth-test + apply-depth-test)) + +(define-record-type + (%make-depth-test write? function near far) + depth-test? + (write? depth-test-write?) + (function depth-test-function) + (near depth-test-near) + (far depth-test-far)) + +(define* (make-depth-test #:key (write? #t) (function 'less-than) (near 0.0) (far 1.0)) + (%make-depth-test write? function near far)) + +(define default-depth-test (make-depth-test)) + +(define (apply-depth-test depth-test) + (if depth-test + (let ((glfunc (match (depth-test-function depth-test) + ('always (depth-function always)) + ('never (depth-function never)) + ('equal (depth-function equal)) + ('not-equal (depth-function notequal)) + ('less-than (depth-function less)) + ('less-than-or-equal (depth-function lequal)) + ('greater-than (depth-function greater)) + ('greater-than-or-equal (depth-function gequal))))) + (gl-enable (enable-cap depth-test)) + (gl-depth-func glfunc) + (gl-depth-mask (depth-test-write? depth-test)) + (gl-depth-range (depth-test-near depth-test) (depth-test-far depth-test))) + (gl-disable (enable-cap depth-test)))) diff --git a/chickadee/graphics/font.scm b/chickadee/graphics/font.scm new file mode 100644 index 0000000..6c115b9 --- /dev/null +++ b/chickadee/graphics/font.scm @@ -0,0 +1,513 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2017, 2020 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Bitmap font rendering. +;; +;;; Code: + +(define-module (chickadee graphics font) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (sxml xpath) + #:use-module (sxml simple) + #:use-module (chickadee config) + #:use-module (chickadee freetype) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics gpu) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics sprite) + #:use-module (chickadee graphics texture) + #:use-module (rnrs bytevectors) + #:export (load-tile-font + load-bitmap-font + load-font + font? + font-face + font-line-height + font-line-width + font-bold? + font-italic? + default-font + draw-text* + draw-text)) + +(define-record-type + (make-font-char id texture-region offset dimensions advance) + font-char? + (id font-char-id) + (texture-region font-char-texture-region) + (offset font-char-offset) + (dimensions font-char-dimensions) + (advance font-char-advance)) + +(define-record-type + (make-font face bold? italic? line-height chars kernings sprite-batches) + font? + (face font-face) + (bold? font-bold?) + (italic? font-italic?) + (line-height font-line-height) + (chars font-chars) + (kernings font-kernings) + (sprite-batches font-sprite-batches)) + +(define (display-font font port) + (format port "#" + (font-face font) + (font-line-height font) + (font-bold? font) + (font-italic? font))) + +(set-record-type-printer! display-font) + +(define (font-line-width font text) + "Return the width of TEXT when rendered with FONT." + (let loop ((width 0.0) + (i 0)) + (if (< i (string-length text)) + (let ((char (or (font-ref font (string-ref text i)) + (font-ref font #\?)))) + (loop (+ width (vec2-x (font-char-advance char))) + (+ i 1))) + width))) + +(define freetype-handle + (delay (init-freetype))) + +(define* (load-font file-name point-size #:key (char-set char-set:ascii)) + "Load all the glyphs in CHAR-SET from the font in FILE-NAME and +display it at POINT-SIZE. By default, the ASCII character is used." + (unless (file-exists? file-name) + (error "no such file" file-name)) + (let ((face (load-face (force freetype-handle) file-name)) + (chars (make-hash-table)) + (kernings (make-hash-table)) + (batches (make-hash-table)) + (texture-size (min (gpu-max-texture-size (current-gpu)) 2048))) + ;; TODO: Use actual screen DPI. + (set-char-size! face (* point-size 64) 0 96 96) + (let ((glyph (face-glyph-slot face)) + (pixels (make-bytevector (* texture-size texture-size 4))) + (x 0) + (y 0) + (next-y 0)) + (define (add-pixels char width height pitch left top advance glyph-pixels) + (when (> (+ x width) texture-size) + (set! y next-y) + (set! x 0)) + (let y-loop ((row 0)) + (when (< row height) + (let x-loop ((column 0)) + (when (< column width) + (let ((gray (u8vector-ref glyph-pixels + (+ (* row pitch) column))) + (offset (+ (* (+ y row) texture-size 4) + (* (+ x column) 4)))) + (u8vector-set! pixels offset 255) + (u8vector-set! pixels (+ offset 1) 255) + (u8vector-set! pixels (+ offset 2) 255) + (u8vector-set! pixels (+ offset 3) gray)) + (x-loop (+ column 1)))) + (y-loop (+ row 1)))) + (let ((spec (list char x y width height left top advance))) + (set! x (+ x width)) + (set! next-y (max next-y (+ y height))) + spec)) + ;; Render individual glyph bitmaps and compose them into larger + ;; images to be used as textures. + (let* ((specs + (char-set-fold + (lambda (char prev) + (load-char face char '(render)) + (let ((left (glyph-bitmap-left glyph)) + (top (glyph-bitmap-top glyph))) + (match (glyph-metrics glyph) + ((bearing-x bearing-y advance) + (match (glyph-bitmap glyph) + ((width height pitch glyph-pixels) + (cons (if glyph-pixels + (add-pixels char width height + pitch left top + advance + glyph-pixels) + (list char #f #f width height left top advance)) + prev))))))) + '() + char-set)) + ;; TODO: Use multiple textures if needed. + (texture (make-texture pixels texture-size texture-size))) + ;; Process kernings. + (char-set-for-each + (lambda (left) + (let ((left-index (get-char-index face left))) + (char-set-for-each + (lambda (right) + (let* ((k (get-kerning face + left-index + (get-char-index face right))) + (kx (s64vector-ref k 0)) + (ky (s64vector-ref k 1)) + (t (hash-ref kernings left))) + (unless (and (zero? kx) (zero? ky)) + (let ((kv (vec2 (/ kx 64.0) (/ ky 64.0)))) + (if t + (hash-set! t right kv) + (let ((t (make-hash-table))) + (hash-set! t right kv) + (hash-set! kernings left t))))))) + char-set))) + char-set) + ;; Build chars. + (for-each (match-lambda + ((char x y width height left top advance) + (hash-set! chars char + (make-font-char 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))))) + specs) + (hashq-set! batches texture (make-sprite-batch texture)))) + (let ((style (face-style-name face))) + (match (size-metrics (face-size face)) + ((_ _ _ _ _ _ height _) + (make-font (face-family-name face) + (and (string-match ".*[B,b]old.*" style) #t) + (and (string-match ".*[I,i]talic.*" style) #t) + (/ height 64.0) + chars + kernings + batches)))))) + +(define* (load-tile-font file tile-width tile-height characters #:key + (face "untitled") (margin 0) (spacing 0)) + "Load the font named FACE from FILE, a bitmap image containing the +characters in the string CHARACTERS that are TILE-WIDTH by TILE-HEIGHT +pixels in size. The characters in the image *must* appear in the +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)) + (chars + (let ((table (make-hash-table))) + (string-for-each-index + (lambda (i) + (hash-set! table (string-ref characters i) + (make-font-char (string-ref characters i) + (texture-atlas-ref atlas i) + (vec2 0.0 0.0) + (vec2 tile-width tile-height) + (vec2 tile-width 0.0)))) + characters) + table)) + ;; These fonts are by definition monospace fonts, so no + ;; kerning. + (kernings (make-hash-table)) + (batches (make-hash-table))) + (hashq-set! batches texture (make-sprite-batch texture)) + (make-font face #f #f tile-height chars kernings batches))) + +(define (load-bitmap-font file) + "Load the AngelCode formatted bitmap font within FILE. The file +extension must be either .xml or .fnt." + (cond + ((string-suffix? ".xml" file) + (parse-bmfont-sxml file (call-with-input-file file xml->sxml))) + ((string-suffix? ".fnt" file) + (parse-bmfont-sxml file (parse-fnt file))) + (else + (error "unknown bmfont file type: " file)))) + +(define (parse-fnt file) + (define (newline? char) + (eqv? char #\newline)) + (define (whitespace? char) + (and (not (newline? char)) + (char-set-contains? char-set:whitespace char))) + (define (letter? char) + (char-set-contains? char-set:letter char)) + (define (consume-whitespace port) + (match (peek-char port) + ((? eof-object?) *unspecified*) + ((? whitespace?) + (read-char port) + (consume-whitespace port)) + (_ *unspecified*))) + (define (read-tag port) + (list->symbol + (let loop () + (match (peek-char port) + ((? letter? char) + (read-char port) + (cons char (loop))) + ((? whitespace? char) + '()))))) + (define (read-key port) + (list->symbol + (let loop () + (match (read-char port) + (#\= '()) + ((? letter? char) + (cons char (loop))))))) + (define (read-quoted-string port) + (match (read-char port) + (#\" #t)) + (list->string + (let loop () + (match (read-char port) + (#\" + (if (or (whitespace? (peek-char port)) + (newline? (peek-char port))) + '() + (cons #\" (loop)))) + (char (cons char (loop))))))) + (define (read-unquoted-string port) + (list->string + (let loop () + (match (peek-char port) + ((or (? whitespace?) + (? newline?)) + '()) + (char + (read-char port) + (cons char (loop))))))) + (define (read-value port) + (match (peek-char port) + (#\" + (read-quoted-string port)) + (_ (read-unquoted-string port)))) + (define (read-key/value-pair port) + (list (read-key port) (read-value port))) + (define (read-key/value-pairs port) + (cons '@ + (let loop () + (consume-whitespace port) + (match (peek-char port) + ((? newline?) + (read-char port) + '()) + ((? letter?) + (cons (read-key/value-pair port) + (loop))))))) + (define (read-line port) + (list (read-tag port) (read-key/value-pairs port))) + `(*TOP* + (font + ,@(call-with-input-file file + (lambda (port) + (let loop ((pages '())) + (match (peek-char port) + ((? eof-object?) + `((pages (@ (count ,(number->string (length pages)))) + ,@pages))) + ((? newline?) + (read-char port) + (loop pages)) + ((? letter?) + (match (read-line port) + ((tag ('@ ('count count))) + (cons (cons* tag + `(@ (count ,count)) + (list-tabulate (string->number count) + (lambda (i) + (read-line port)))) + (loop pages))) + ((and ('page . _) page) + (loop (cons page pages))) + (exp (cons exp (loop pages)))))))))))) + +(define (parse-bmfont-sxml file tree) + (define directory (dirname file)) + (define* (attr tree name #:optional (parse identity)) + (let ((result ((sxpath `(@ ,name *text*)) tree))) + (if (null? result) + #f + (parse (car result))))) + (define (parse-pages nodes) + (let ((table (make-hash-table))) + (for-each (lambda (node) + (let* ((id (attr node 'id string->number)) + (file (attr node 'file)) + (texture (load-image + (string-append directory "/" file)))) + (hash-set! table id texture))) + nodes) + table)) + (define (string->character s) + (integer->char (string->number s))) + (define (parse-chars nodes pages image-width image-height line-height) + (define (x->s x) + (exact->inexact (/ x image-width))) + (define (y->t y) + (exact->inexact (/ y image-height))) + (let ((table (make-hash-table))) + (for-each (lambda (node) + (let* ((id (attr node 'id string->character)) + (width (attr node 'width string->number)) + (height (attr node 'height string->number)) + (x (attr node 'x string->number)) + (y (attr node 'y string->number)) + (x-offset (attr node 'xoffset string->number)) + (y-offset (- line-height height + (attr node 'yoffset string->number))) + (x-advance (attr node 'xadvance string->number)) + (page (or (attr node 'page string->number) 0)) + (region (make-texture-region (hash-ref pages page) + (make-rect x y width height))) + (char (make-font-char id + region + (vec2 x-offset y-offset) + (vec2 width height) + (vec2 x-advance 0.0)))) + (hash-set! table id char))) + nodes) + table)) + (define (parse-kernings nodes) + (let ((table (make-hash-table))) + (for-each (lambda (node) + (let* ((first (attr node 'first string->character)) + (second (attr node 'second string->character)) + (x-offset (attr node 'amount string->number)) + (inner-table (hash-ref table first))) + (if inner-table + (hash-set! inner-table second (vec2 x-offset 0.0)) + (let ((inner-table (make-hash-table))) + (hash-set! inner-table second (vec2 x-offset 0.0)) + (hash-set! table first inner-table))))) + nodes) + table)) + (let* ((info ((sxpath '(font info)) tree)) + (common ((sxpath '(font common)) tree)) + (face (attr info 'face)) + (bold? (attr info 'bold (const #t))) + (italic? (attr info 'italic (const #t))) + (line-height (attr common 'lineHeight string->number)) + (image-width (attr common 'scaleW string->number)) + (image-height (attr common 'scaleH string->number)) + (pages (parse-pages ((sxpath '(font pages page)) tree))) + (chars (parse-chars ((sxpath '(font chars char)) tree) + pages + image-width + image-height + line-height)) + (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree))) + (batches (make-hash-table))) + (hash-for-each (lambda (id texture) + (hashq-set! batches texture (make-sprite-batch texture))) + pages) + (make-font face bold? italic? line-height chars kernings batches))) + +(define (font-ref font char) + (hashv-ref (font-chars font) char)) + +(define draw-text* + (let ((cursor (vec2 0.0 0.0)) + (rect (make-rect 0.0 0.0 0.0 0.0))) + (lambda* (font text matrix #:key (blend-mode 'alpha) + (start 0) (end (string-length text))) + (let ((batches (font-sprite-batches font)) + (kernings (font-kernings font))) + (define (kerning char prev) + (let ((t (hash-ref kernings prev))) + (and t (hash-ref t char)))) + (define (render-char c prev) + (if (eqv? c #\newline) + (begin + (set-vec2-x! cursor 0.0) + (set-vec2-y! cursor (- (vec2-y cursor) (font-line-height font)))) + ;; TODO: What if "?" isn't in the font? + (let* ((char (or (font-ref font c) (font-ref font #\?))) + (k (kerning c prev)) + (texture (font-char-texture-region char)) + (batch (and texture (hashq-ref batches (texture-parent texture)))) + (dimensions (font-char-dimensions char)) + (offset (font-char-offset char))) + ;; Apply kerning, if present. + (when k + (set-vec2-x! cursor (+ (vec2-x cursor) (vec2-x k)))) + (when texture + (set-rect-x! rect (+ (vec2-x cursor) (vec2-x offset))) + (set-rect-y! rect (+ (vec2-y cursor) (vec2-y offset))) + (set-rect-width! rect (vec2-x dimensions)) + (set-rect-height! rect (vec2-y dimensions)) + (sprite-batch-add* batch rect matrix + #:texture-region texture)) + ;; Move forward to where the next character needs to be drawn. + (set-vec2-x! cursor + (+ (vec2-x cursor) + (vec2-x + (font-char-advance char))))))) + (set-vec2! cursor 0.0 0.0) + (hash-for-each (lambda (texture batch) + (sprite-batch-clear! batch)) + batches) + (let loop ((i start) + (prev #f)) + (when (< i end) + (let ((char (string-ref text i))) + (render-char char prev) + (loop (+ i 1) char)))) + (hash-for-each (lambda (texture batch) + (draw-sprite-batch batch #:blend-mode blend-mode)) + batches))))) + +(define %default-scale (vec2 1.0 1.0)) +(define %null-vec2 (vec2 0.0 0.0)) +(define %default-font + (delay (load-font (scope-datadir "fonts/Inconsolata-Regular.otf") 12))) + +(define (default-font) + (force %default-font)) + +(define draw-text + (let ((matrix (make-null-matrix4))) + (lambda* (text + position + #:key + (font (default-font)) + (origin %null-vec2) + (rotation 0) + (scale %default-scale) + (blend-mode 'alpha) + (start 0) + (end (string-length text))) + "Draw the string TEXT with the first character starting at +POSITION using FONT." + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (draw-text* font text matrix #:blend-mode blend-mode + #:start start #:end end)))) diff --git a/chickadee/graphics/framebuffer.scm b/chickadee/graphics/framebuffer.scm new file mode 100644 index 0000000..967c115 --- /dev/null +++ b/chickadee/graphics/framebuffer.scm @@ -0,0 +1,137 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2017 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Render to texture. +;; +;;; Code: + +(define-module (chickadee graphics framebuffer) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:use-module (gl) + #:use-module (gl enums) + #:use-module (chickadee math matrix) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:use-module ((chickadee graphics texture) #:select (make-texture null-texture)) + #:use-module (chickadee graphics viewport) + #:export (make-framebuffer + framebuffer? + framebuffer-texture + framebuffer-viewport + framebuffer-projection + null-framebuffer + apply-framebuffer)) + +(define (generate-framebuffer) + "Generate a new OpenGL framebuffer object." + (let ((bv (u32vector 1))) + (gl-gen-framebuffers 1 (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define (generate-renderbuffer) + "Generate a new OpenGL renderbuffer object." + (let ((bv (u32vector 1))) + (gl-gen-renderbuffers 1 (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define-record-type + (%make-framebuffer id renderbuffer-id texture viewport projection) + framebuffer? + (id framebuffer-id) + (renderbuffer-id framebuffer-renderbuffer-id) + (texture framebuffer-texture) + (viewport framebuffer-viewport) + (projection framebuffer-projection)) + +(define null-framebuffer + (%make-framebuffer 0 0 null-texture null-viewport (make-identity-matrix4))) + +(define <> (class-of null-framebuffer)) + +(define (free-framebuffer framebuffer) + (gl-delete-renderbuffers 1 + (bytevector->pointer + (u32vector + (framebuffer-renderbuffer-id framebuffer)))) + (gl-delete-framebuffers 1 + (bytevector->pointer + (u32vector + (framebuffer-id framebuffer))))) + +(define-method (gpu-finalize (framebuffer <>)) + (free-framebuffer framebuffer)) + +(define (apply-framebuffer framebuffer) + (gl-bind-framebuffer (version-3-0 framebuffer) + (framebuffer-id framebuffer))) + +(define make-framebuffer + (let ((draw-buffers (u32vector (version-3-0 color-attachment0)))) + (lambda* (width height #:key (min-filter 'linear) (mag-filter 'linear) + (wrap-s 'repeat) (wrap-t 'repeat)) + "Create a new framebuffer that renders to a texture with +dimensions WIDTH x HEIGHT." + (let* ((framebuffer-id (generate-framebuffer)) + (renderbuffer-id (generate-renderbuffer)) + (texture (make-texture #f width height + #:flip? #t + #:min-filter min-filter + #:mag-filter mag-filter + #:wrap-s wrap-s + #:wrap-t wrap-t)) + ;; It is convenient to make a default viewport and + ;; projection matrix for the framebuffer so that the + ;; rendering engine can set it whenever it changes to + ;; this framebuffer, saving users the trouble of having + ;; to this tedious task themselves. + (viewport (make-viewport 0 0 width height)) + (projection (orthographic-projection 0 width height 0 0 1)) + (framebuffer (%make-framebuffer framebuffer-id + renderbuffer-id + texture + viewport + projection))) + (set-gpu-framebuffer! (current-gpu) framebuffer) + ;; Setup depth buffer. + (gl-bind-renderbuffer (version-3-0 renderbuffer) + renderbuffer-id) + (gl-renderbuffer-storage (version-3-0 renderbuffer) + (pixel-format depth-component) + width + height) + (gl-framebuffer-renderbuffer (version-3-0 framebuffer) + (arb-framebuffer-object depth-attachment) + (version-3-0 renderbuffer) + renderbuffer-id) + ;; Setup framebuffer. + (gl-framebuffer-texture-2d (version-3-0 framebuffer) + (version-3-0 color-attachment0) + (texture-target texture-2d) + ((@@ (chickadee graphics texture) texture-id) + texture) + 0) + (gl-draw-buffers 1 (bytevector->pointer draw-buffers)) + ;; Check for errors. + (unless (= (gl-check-framebuffer-status (version-3-0 framebuffer)) + (version-3-0 framebuffer-complete)) + (error "Framebuffer cannot be created")) + framebuffer)))) diff --git a/chickadee/graphics/gl.scm b/chickadee/graphics/gl.scm new file mode 100644 index 0000000..334da09 --- /dev/null +++ b/chickadee/graphics/gl.scm @@ -0,0 +1,330 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Custom wrappers over low level OpenGL commands that aren't part of +;; guile-opengl. +;; +;;; Code: + +(define-module (chickadee graphics gl) + #:use-module (srfi srfi-4) + #:use-module ((system foreign) #:select (bytevector->pointer)) + #:use-module (gl) + #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%)) + #:use-module (gl enums) + #:use-module (gl runtime) + #:use-module (gl types)) + +(re-export (%glClearColor . gl-clear-color) + (%glScissor . gl-scissor) + (%glBlendFunc . gl-blend-func) + (%glBlendEquation . gl-blend-equation)) + +;;; +;;; 3.8.1 Texture Image Specification +;;; + +(re-export (%glTexImage3D . gl-texture-image-3d) + (%glTexImage2D . gl-texture-image-2d) + (%glTexImage1D . gl-texture-image-1d)) + +;;; +;;; 3.8.2 Alternate Texture Image Specification Commands +;;; + +(re-export (%glCopyTexImage2D . gl-copy-texture-image-2d) + (%glCopyTexImage1D . gl-copy-texture-image-1d) + (%glCopyTexSubImage3D . gl-copy-texture-sub-image-3d) + (%glCopyTexSubImage2D . gl-copy-texture-sub-image-2d) + (%glCopyTexSubImage1D . gl-copy-texture-sub-image-1d) + (%glTexSubImage3D . gl-texture-sub-image-3d) + (%glTexSubImage2D . gl-texture-sub-image-2d) + (%glTexSubImage1D . gl-texture-sub-image-1d)) + +;;; +;;; 3.8.3 Compressed Texture Images +;;; + +(re-export (%glCompressedTexImage1D . gl-compressed-texture-image-1d) + (%glCompressedTexImage2D . gl-compressed-texture-image-2d) + (%glCompressedTexImage3D . gl-compressed-texture-image-3d) + (%glCompressedTexSubImage1D . gl-compressed-texture-sub-image-1d) + (%glCompressedTexSubImage2D . gl-compressed-texture-sub-image-2d) + (%glCompressedTexSubImage3D . gl-compressed-texture-sub-image-3d)) + +;;; +;;; 3.8.4 Texture Parameters +;;; + +(re-export (%glTexParameteri . gl-texture-parameter) + (%glBindTexture . gl-bind-texture)) + +;;; +;;; Instancing extension +;;; + +(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.") + +(export (glDrawArraysInstanced . gl-draw-arrays-instanced) + (glDrawElementsInstanced . gl-draw-elements-instanced) + (glVertexAttribDivisor . gl-vertex-attrib-divisor)) + +;;; +;;; VBOs +;;; + +(re-export (%glGenBuffers . gl-gen-buffers) + (%glDeleteBuffers . gl-delete-buffers) + (%glBufferData . gl-buffer-data) + (%glBufferSubData . gl-buffer-sub-data) + (%glMapBuffer . gl-map-buffer) + (%glUnmapBuffer . gl-unmap-buffer)) + +;;; +;;; VAOs +;;; + +(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.") + +(export (glGenVertexArrays . gl-gen-vertex-arrays) + (glDeleteVertexArrays . gl-delete-vertex-arrays) + (glBindVertexArray . gl-bind-vertex-array) + (glEnableVertexAttribArray . gl-enable-vertex-attrib-array) + (glVertexAttribPointer . gl-vertex-attrib-pointer) + (glDrawElements . gl-draw-elements)) + +(define-syntax-rule (with-gl-client-state state body ...) + (begin + (gl-enable-client-state state) + body ... + (gl-disable-client-state state))) + +(export with-gl-client-state) + +;;; +;;; Framebuffers +;;; + +(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 (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.") + +(export (glGenFramebuffers . gl-gen-framebuffers) + (glDeleteFramebuffers . gl-delete-framebuffers) + (glBindFramebuffer . gl-bind-framebuffer) + (glFramebufferTexture2D . gl-framebuffer-texture-2d) + (glCheckFramebufferStatus . gl-check-framebuffer-status) + (glGenRenderbuffers . gl-gen-renderbuffers) + (glDeleteRenderbuffers . gl-delete-renderbuffers) + (glBindRenderbuffer . gl-bind-renderbuffer) + (glRenderbufferStorage . gl-renderbuffer-storage) + (glFramebufferRenderbuffer . gl-framebuffer-renderbuffer)) + +(re-export (%glDrawBuffers . gl-draw-buffers)) + + +;;; +;;; Shaders +;;; + +(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") + +(export (glUniform1ui . gl-uniform1ui) + (glUniform1uiv . gl-uniform1uiv)) + +(re-export (%glUseProgram . gl-use-program) + (%glDeleteProgram . gl-delete-program) + (%glDetachShader . gl-detach-shader) + (%glLinkProgram . gl-link-program) + (%glBindAttribLocation . gl-bind-attrib-location) + (%glAttachShader . gl-attach-shader) + (%glGetAttribLocation . gl-get-attrib-location) + (%glGetUniformLocation . gl-get-uniform-location) + (%glCreateProgram . gl-create-program) + (%glGetProgramInfoLog . gl-get-program-info-log) + (%glGetProgramiv . gl-get-programiv) + (%glDeleteProgram . gl-delete-program) + (%glDeleteShader . gl-delete-shader) + (%glGetShaderiv . gl-get-shaderiv) + (%glGetShaderInfoLog . gl-get-shader-info-log) + (%glCompileShader . gl-compile-shader) + (%glShaderSource . gl-shader-source) + (%glCreateShader . gl-create-shader) + (%glGetActiveUniform . gl-get-active-uniform) + (%glGetActiveAttrib . gl-get-active-attrib) + (%glUniform1i . gl-uniform1i) + (%glUniform1iv . gl-uniform1iv) + (%glUniform2i . gl-uniform2i) + (%glUniform3i . gl-uniform3i) + (%glUniform4i . gl-uniform4i) + (%glUniform1f . gl-uniform1f) + (%glUniform1fv . gl-uniform1fv) + (%glUniform2f . gl-uniform2f) + (%glUniform2fv . gl-uniform2fv) + (%glUniform3f . gl-uniform3f) + (%glUniform3fv . gl-uniform3fv) + (%glUniform4f . gl-uniform4f) + (%glUniform4fv . gl-uniform4fv) + (%glUniformMatrix4fv . gl-uniform-matrix4fv) + (%glUniform4f . gl-uniform4f)) + +(re-export (%glPointSize . gl-point-size)) + + +;;; +;;; Context Queries +;;; + +(re-export (%glGetString . gl-get-string) + (%glGetIntegerv . gl-get-integer-v)) + + +;;; +;;; Depth Buffer +;;; + +(re-export (%glDepthFunc . gl-depth-func) + (%glDepthMask . gl-depth-mask) + (%glDepthRange . gl-depth-range)) + + +;;; +;;; Stencil Buffer +;;; + +(re-export (%glStencilMask . gl-stencil-mask) + (%glStencilMaskSeparate . gl-stencil-mask-separate) + (%glStencilFunc . gl-stencil-func) + (%glStencilFuncSeparate . gl-stencil-func-separate) + (%glStencilOp . gl-stencil-op) + (%glStencilOpSeparate . gl-stencil-op-separate)) diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm new file mode 100644 index 0000000..b8c8ca5 --- /dev/null +++ b/chickadee/graphics/gpu.scm @@ -0,0 +1,211 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics gpu) + #:use-module (chickadee graphics gl) + #:use-module (gl enums) + #:use-module (oop goops) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:export (make-gpu-state + gpu-state-ref + gpu-state-set! + + gpu-finalize + gpu-guard + gpu-reap! + + make-gpu + current-gpu + gpu? + gpu-gl-context + gpu-gl-version + gpu-glsl-version + gpu-max-texture-size + gpu-blend-mode + gpu-depth-test + gpu-stencil-test + gpu-framebuffer + gpu-shader + gpu-texture + gpu-vertex-buffer + gpu-vertex-array + gpu-viewport + set-gpu-blend-mode! + set-gpu-depth-test! + set-gpu-stencil-test! + set-gpu-framebuffer! + set-gpu-shader! + set-gpu-texture! + set-gpu-vertex-buffer! + set-gpu-vertex-array! + set-gpu-viewport!)) + + +;;; +;;; GPU state +;;; + +(define-record-type + (make-gpu-state bind value) + gpu-state? + (bind gpu-state-bind) + (value gpu-state-ref %gpu-state-set!)) + +(define (gpu-state-set! state new-value) + (unless (eq? new-value (gpu-state-ref state)) + ((gpu-state-bind state) new-value) + (%gpu-state-set! state new-value))) + +;;; +;;; GPU finalizers +;;; + +(define-generic gpu-finalize) + +(define *gpu-guardian* (make-guardian)) + +(define (gpu-guard obj) + "Protect OBJ for the garbage collector until OBJ has been deleted +from the GPU's memory." + (*gpu-guardian* obj) + obj) + +(define (gpu-reap!) + "Delete all GPU objects that are no longer being referenced." + (let loop ((obj (*gpu-guardian*))) + (when obj + (gpu-finalize obj) + (loop (*gpu-guardian*))))) + + +;;; +;;; GPU +;;; + +(define-record-type + (%make-gpu gl-context + gl-version + glsl-version + max-texture-size + blend-mode + depth-test + stencil-test + framebuffer + shader + textures + vertex-buffer + vertex-array + viewport) + gpu? + (gl-context gpu-gl-context) + (gl-version gpu-gl-version) + (glsl-version gpu-glsl-version) + (max-texture-size gpu-max-texture-size) + (blend-mode %gpu-blend-mode) + (depth-test %gpu-depth-test) + (stencil-test %gpu-stencil-test) + (framebuffer %gpu-framebuffer) + (shader %gpu-shader) + (textures gpu-textures) + (vertex-buffer %gpu-vertex-buffer) + (vertex-array %gpu-vertex-array) + (viewport %gpu-viewport)) + +(define current-gpu (make-parameter #f)) + +(define (max-texture-size) + (let ((bv (make-s32vector 1))) + (gl-get-integer-v (get-p-name max-texture-size) + (bytevector->pointer bv)) + (s32vector-ref bv 0))) + +(define (make-gpu gl-context) + (define (extract-version attr) + (car (string-split (pointer->string (gl-get-string attr)) #\space))) + (let ((textures (make-vector 32)) + ;; Lazily resolve bindings to avoid circular dependencies. + (blend-module (resolve-interface '(chickadee graphics blend))) + (depth-module (resolve-interface '(chickadee graphics depth))) + (stencil-module (resolve-interface '(chickadee graphics stencil))) + (buffer-module (resolve-interface '(chickadee graphics buffer))) + (framebuffer-module (resolve-interface '(chickadee graphics framebuffer))) + (shader-module (resolve-interface '(chickadee graphics shader))) + (texture-module (resolve-interface '(chickadee graphics texture))) + (viewport-module (resolve-interface '(chickadee graphics viewport))) + (gl-version (extract-version (string-name version))) + (glsl-version (extract-version (version-2-0 shading-language-version)))) + ;; Create state for 32 texture units. + (let loop ((i 0)) + (when (< i 32) + (vector-set! textures i + (let ((apply-texture (module-ref texture-module 'apply-texture))) + (make-gpu-state (lambda (texture) + (apply-texture i texture)) + (module-ref texture-module 'null-texture)))) + (loop (+ i 1)))) + (%make-gpu gl-context + gl-version + glsl-version + (max-texture-size) + (make-gpu-state (module-ref blend-module 'apply-blend-mode) + 'replace) + (make-gpu-state (module-ref depth-module 'apply-depth-test) #f) + (make-gpu-state (module-ref stencil-module 'apply-stencil-test) #f) + (make-gpu-state (module-ref framebuffer-module 'apply-framebuffer) + (module-ref framebuffer-module 'null-framebuffer)) + (make-gpu-state (module-ref shader-module 'apply-shader) + (module-ref shader-module 'null-shader)) + textures + (make-gpu-state (module-ref buffer-module 'apply-buffer) + (module-ref buffer-module 'null-buffer)) + (make-gpu-state (module-ref buffer-module 'apply-vertex-array) + (module-ref buffer-module 'null-vertex-array)) + (make-gpu-state (module-ref viewport-module 'apply-viewport) + (module-ref viewport-module 'null-viewport))))) + +(define-syntax-rule (define-gpu-getter name ref) + (define (name gpu) + (gpu-state-ref (ref gpu)))) + +(define-gpu-getter gpu-blend-mode %gpu-blend-mode) +(define-gpu-getter gpu-depth-test %gpu-depth-test) +(define-gpu-getter gpu-stencil-test %gpu-stencil-test) +(define-gpu-getter gpu-framebuffer %gpu-framebuffer) +(define-gpu-getter gpu-shader %gpu-shader) +(define-gpu-getter gpu-vertex-buffer %gpu-vertex-buffer) +(define-gpu-getter gpu-vertex-array %gpu-vertex-array) +(define-gpu-getter gpu-viewport %gpu-viewport) + +(define-syntax-rule (define-gpu-setter name ref) + (define (name gpu x) + (gpu-state-set! (ref gpu) x))) + +(define-gpu-setter set-gpu-blend-mode! %gpu-blend-mode) +(define-gpu-setter set-gpu-depth-test! %gpu-depth-test) +(define-gpu-setter set-gpu-stencil-test! %gpu-stencil-test) +(define-gpu-setter set-gpu-framebuffer! %gpu-framebuffer) +(define-gpu-setter set-gpu-shader! %gpu-shader) +(define-gpu-setter set-gpu-vertex-buffer! %gpu-vertex-buffer) +(define-gpu-setter set-gpu-vertex-array! %gpu-vertex-array) +(define-gpu-setter set-gpu-viewport! %gpu-viewport) + +(define (gpu-texture gpu texture-unit) + (gpu-state-ref (vector-ref (gpu-textures gpu) texture-unit))) + +(define (set-gpu-texture! gpu texture-unit texture) + (gpu-state-set! (vector-ref (gpu-textures gpu) texture-unit) texture)) diff --git a/chickadee/graphics/model.scm b/chickadee/graphics/model.scm new file mode 100644 index 0000000..6e696f7 --- /dev/null +++ b/chickadee/graphics/model.scm @@ -0,0 +1,1073 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; 3D Model loading and rendering. +;; +;;; Code: + +(define-module (chickadee graphics model) + #:use-module (chickadee array-list) + #:use-module (chickadee json) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics buffer) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics depth) + #:use-module (chickadee graphics pbr) + #:use-module (chickadee graphics phong) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-9) + #:use-module ((srfi srfi-43) #:select (vector-every)) + #:export (scene-node? + scene-node-name + scene-node-mesh + scene-node-matrix + scene-node-children + model? + model-scenes + model-default-scene + draw-model + load-obj + load-gltf)) + + +;;; +;;; Rendering State +;;; + +(define-record-type + (%make-render-state shader renderer world-matrix view-matrix) + render-state? + (shader render-state-shader) + (renderer render-state-renderer) + (world-matrix render-state-world-matrix) + (view-matrix render-state-view-matrix)) + +(define* (make-render-state #:key shader renderer) + (%make-render-state shader renderer + (make-identity-matrix4) + (make-identity-matrix4))) + +(define (render-state-reset! state) + (matrix4-identity! (render-state-world-matrix state)) + (matrix4-identity! (render-state-view-matrix state))) + +(define (render-state-world-matrix-mult! state matrix) + (let ((world (render-state-world-matrix state))) + (matrix4-mult! world world matrix))) + +(define (render-state-view-matrix-mult! state matrix) + (let ((view (render-state-view-matrix state))) + (matrix4-mult! view view matrix))) + + +;;; +;;; Primitive +;;; + +;; A piece of a mesh. Represents a single draw call. +(define-record-type + (make-primitive name vertex-array material) + primitive? + (name primitive-name) + (vertex-array primitive-vertex-array) + (material primitive-material)) + +(define (draw-primitive/phong primitive state) + (gpu-apply/phong (render-state-shader state) + (primitive-vertex-array primitive) + (primitive-material primitive) + (render-state-world-matrix state) + (render-state-view-matrix state))) + +(define (draw-primitive/pbr primitive state) + (gpu-apply/pbr (render-state-shader state) + (primitive-vertex-array primitive) + (primitive-material primitive) + (render-state-world-matrix state) + (render-state-view-matrix state))) + + +;;; +;;; Mesh +;;; + +;; A complete 3D model composed of many primitives. +(define-record-type + (make-mesh name primitives) + mesh? + (name mesh-name) + (primitives mesh-primitives)) + +(define (draw-mesh mesh state) + (let ((render (render-state-renderer state))) + (for-each (lambda (primitive) (render primitive state)) + (mesh-primitives mesh)))) + + +;;; +;;; Scene Node +;;; + +;; A tree of meshes with their own transformation matrices. +(define-record-type + (%make-scene-node name mesh matrix children) + scene-node? + (name scene-node-name) + (mesh scene-node-mesh) + (matrix scene-node-matrix) + (children scene-node-children)) + +(define* (make-scene-node #:key + (name "anonymous") + mesh + (matrix (make-identity-matrix4)) + (children '())) + (%make-scene-node name mesh matrix children)) + +(define (draw-scene-node node state) + ;; TODO: Apply push/pop model matrix stuff. + (for-each (lambda (child) + (draw-scene-node child state)) + (scene-node-children node)) + (let ((mesh (scene-node-mesh node))) + (when mesh + (draw-mesh mesh state)))) + + +;;; +;;; Model +;;; + +;; A collection of scenes and the associated information about *how* +;; to actually render the darn thing. +(define-record-type + (%make-model name scenes default-scene render-state) + model? + (name model-name) + (scenes model-scenes) + (default-scene model-default-scene) + (render-state model-render-state)) + +(define* (make-model #:key name scenes (default-scene (car scenes)) render-state) + (%make-model name scenes default-scene render-state)) + +(define (draw-model model model-matrix view-matrix) + (with-depth-test default-depth-test + (let ((state (model-render-state model))) + (render-state-reset! state) + (render-state-view-matrix-mult! state view-matrix) + (render-state-world-matrix-mult! state model-matrix) + ;; TODO: Support drawing non-default scenes. + (draw-scene-node (model-default-scene model) state)))) + + +;;; +;;; OBJ Format +;;; + +;; Reference documentation: +;; * http://paulbourke.net/dataformats/obj +;; * http://paulbourke.net/dataformats/mtl +(define (load-obj file-name) + (define (scope-file other-file) + (string-append (dirname file-name) "/" other-file)) + (call-with-input-file file-name + (lambda (port) + (let ((vertices (make-array-list)) + (texcoords (make-array-list)) + (normals (make-array-list)) + (faces (make-array-list)) + (face-map (make-hash-table)) + (face-indices-map (make-hash-table)) + (material-map (make-hash-table))) + (define (parse-map-args args) + (define (map-option? str) + (string-prefix? "-" str)) + (let loop ((args args) + (opts '())) + (match args + (() opts) + (((? map-option? opt) arg . rest) + (loop rest + (cons (cons (string->symbol + (substring opt 1)) + arg) + opts))) + ((file-name . rest) + (loop rest (cons (cons 'file-name file-name) opts)))))) + (define (load-mtl mtl-file-name) + (define (scope-file other-file) + (string-append (dirname mtl-file-name) "/" other-file)) + (call-with-input-file mtl-file-name + (lambda (port) + (let loop ((opts '())) + (define (maybe-add-material) + (let ((name (assq-ref opts 'name))) + (when name + (hash-set! material-map + name + (make-phong-material + #:name name + #:ambient (assq-ref opts 'ambient) + #:ambient-map (assq-ref opts 'ambient-map) + #:use-ambient-map + (assq-ref opts 'use-ambient-map?) + #:diffuse (assq-ref opts 'diffuse) + #:diffuse-map (assq-ref opts 'diffuse-map) + #:use-diffuse-map + (assq-ref opts 'use-diffuse-map?) + #:specular (assq-ref opts 'specular) + #:specular-map (assq-ref opts 'specular-map) + #:use-specular-map + (assq-ref opts 'use-specular-map?) + #:shininess (assq-ref opts 'shininess) + #:bump-map (assq-ref opts 'bump-map) + #:use-bump-map + (assq-ref opts 'use-bump-map?)))))) + (match (read-line port) + ((? eof-object?) + (maybe-add-material)) + (line + (match (delete "" (string-split line char-set:whitespace)) + ((or () ("#" . _)) ; ignore comments and blank lines + (loop opts)) + (("d" d) ; ignore dissolve for now + (loop opts)) + (("illum" n) ; ignore illumation model for now + (loop opts)) + (("Ka" r g b) ; ambient factor + (let ((new-ambient (vec3 (string->number r) + (string->number g) + (string->number b)))) + (loop (cons (cons 'ambient new-ambient) opts)))) + (("Ka" r) ; ambient factor + (let ((new-ambient (vec3 (string->number r) + (string->number r) + (string->number r)))) + (loop (cons (cons 'ambient new-ambient) opts)))) + (("Kd" r g b) ; diffuse factor + (let ((new-diffuse (vec3 (string->number r) + (string->number g) + (string->number b)))) + (loop (cons (cons 'diffuse new-diffuse) opts)))) + (("Kd" r) ; diffuse factor + (let ((new-diffuse (vec3 (string->number r) + (string->number r) + (string->number r)))) + (loop (cons (cons 'diffuse new-diffuse) opts)))) + (("Ks" r g b) ; specular factor + (let ((new-specular (vec3 (string->number r) + (string->number g) + (string->number b)))) + (loop (cons (cons 'specular new-specular) opts)))) + (("Ks" r) ; specular factor + (let ((new-specular (vec3 (string->number r) + (string->number r) + (string->number r)))) + (loop (cons (cons 'specular new-specular) opts)))) + (("Ni" i) ; ignore optical density for now + (loop opts)) + (("Ns" s) ; specular exponent (shininess) + ;; Force specular exponent to be a float. + (let ((new-shininess (* (string->number s) 1.0))) + (loop (cons (cons 'shininess new-shininess) opts)))) + (("map_Ka" . args) ; ambient map + (let* ((ambient-opts (parse-map-args args)) + (file (scope-file (assq-ref ambient-opts + 'file-name))) + (texture (load-image file + #:min-filter 'linear + #:mag-filter 'linear))) + (loop (cons* (cons 'ambient-map texture) + (cons 'use-ambient-map? #t) + opts)))) + (("map_Kd" . args) ; diffuse map + (let* ((diffuse-opts (parse-map-args args)) + (file (scope-file (assq-ref diffuse-opts + 'file-name))) + (texture (load-image file + #:min-filter 'linear + #:mag-filter 'linear))) + (loop (cons* (cons 'diffuse-map texture) + (cons 'use-diffuse-map? #t) + opts)))) + (("map_Ks" . args) ; specular map + (let* ((specular-opts (parse-map-args args)) + (file (scope-file (assq-ref specular-opts + 'file-name))) + (texture (load-image file + #:min-filter 'linear + #:mag-filter 'linear))) + (loop (cons* (cons 'specular-map texture) + (cons 'use-specular-map? #t) + opts)))) + (((or "map_Bump" "map_bump" "bump") . args) ; normal map + (let* ((bump-opts (parse-map-args args)) + (file (scope-file (assq-ref bump-opts + 'file-name))) + (texture (load-image file + #:min-filter 'linear + #:mag-filter 'linear))) + (loop (cons* (cons 'bump-map texture) + (cons 'use-bump-map? #t) + opts)))) + (("newmtl" new-name) + ;; Begin new material + (maybe-add-material) + (loop `((name . ,new-name) + (ambient . ,(vec3 0.0 0.0 0.0)) + (ambient-map . ,null-texture) + (use-ambient-map? . #f) + (diffuse . ,(vec3 0.0 0.0 0.0)) + (diffuse-map . ,null-texture) + (use-diffuse-map? . #f) + (specular . ,(vec3 0.0 0.0 0.0)) + (specular-map . ,null-texture) + (use-specular-map? . #f) + (shininess . 1.0) + (bump-map . ,null-texture) + (use-bump-map? . #f)))) + (data + (format (current-error-port) + "warning: ~a:~d: unsupported MTL data: ~s~%" + mtl-file-name + (port-line port) + data) + (loop opts))))))))) + (define (parse-error message args) + (apply error (format #f "OBJ parser error @ ~a:~d: ~a" + file-name + (port-line port) + message) + args)) + (define (parse-vertex args) + (array-list-push! vertices + (match args + ((x y z) + (vec3 (string->number x) + (string->number y) + (string->number z))) + ;; TODO: handle w properly + ((x y z w) + (vec3 (string->number x) + (string->number y) + (string->number z))) + (_ + (parse-error "wrong number of vertex arguments" args))))) + (define (parse-texcoord args) + ;; TODO: Handle w properly. + (array-list-push! texcoords + (match args + ((u) + (vec2 (string->number u) 0.0)) + ((u v) + ;; OBJ texture coordinates use the + ;; top-left of the image as the origin, + ;; but OpenGL uses the bottom-left, so + ;; all V values must be inverted. + (vec2 (string->number u) + (- 1.0 (string->number v)))) + ((u v w) + (vec2 (string->number u) + (- 1.0 (string->number v)))) + (_ + (parse-error "wrong number of texcoord arguments" args))))) + (define (parse-normal args) + (array-list-push! normals + (match args + ((i j k) + (vec3 (string->number i) + (string->number j) + (string->number k))) + (_ + (parse-error "wrong number of normal arguments" args))))) + (define (parse-face-index arg) + (- (string->number arg) 1)) + (define (parse-face-element arg) + (match (string-split arg #\/) + ((v) + (list (parse-face-index v) #f #f)) + ((v t) + (list (parse-face-index v) + (parse-face-index t) + #f)) + ((v "" n) + (list (parse-face-index v) + #f + (parse-face-index n))) + ((v t n) + (list (parse-face-index v) + (parse-face-index t) + (parse-face-index n))) + (_ + (parse-error "invalid face syntax" (list arg))))) + (define (indices-for-material material) + (or (hash-ref face-indices-map material) + (let ((new-indices (make-array-list))) + (hash-set! face-indices-map material new-indices) + new-indices))) + (define (deduplicate-face-element e) + ;; Faces are often redundant, so we deduplicate in order to + ;; make the VBOs we build later as small as possible. + (or (hash-ref face-map e) + (let ((i (array-list-size faces))) + (array-list-push! faces (parse-face-element e)) + (hash-set! face-map e i) + i))) + (define (push-face material e) + (array-list-push! (indices-for-material material) + (deduplicate-face-element e))) + (define (parse-face args material) + (match args + ;; A single triangle. Ah, life is so simple... + ((a b c) + (push-face material a) + (push-face material b) + (push-face material c)) + ;; A quadrilateral. Needs to be split into 2 triangles. + ;; + ;; d-------c + ;; | /| + ;; | / | + ;; | / | + ;; |/ | + ;; a-------b + ((a b c d) + ;; triangle 1: a b c + (push-face material a) + (push-face material b) + (push-face material c) + ;; triangle 2: a c d + (push-face material a) + (push-face material c) + (push-face material d)) + ;; 3 or more triangles. Interpret as a strip of triangles + ;; moving from right to left (because counter-clockwise + ;; winding) like this: + ;; + ;; h-------f-------d-------c + ;; | /| /| /| + ;; | / | / | / | + ;; | / | / | / | + ;; |/ |/ |/ | + ;; g-------e-------a-------b + ;; + ;; ... and so on for however many face elements there are. + ;; Every other triangle is flipped over, hence the 'flip?' + ;; flag in the loop below. + ((a b . rest) + (let loop ((a a) + (b b) + (args rest) + (flip? #f)) + (match args + (() #t) + ((c . rest) + (push-face material a) + (push-face material b) + (push-face material c) + (if flip? + (loop c a rest #f) + (loop a c rest #t)))))) + (_ + (parse-error "invalid face" args)))) + ;; Build a vertex array for all the faces of a single + ;; material. + ;; + ;; XXX: We assume there is normal and texture data. Models + ;; that don't have one or both will still use up as much + ;; memory as if they did. Maybe that's just fine? Dunno. + (define (make-primitive-for-material material) + (let* ((face-indices (indices-for-material material)) + (vertex-count (array-list-size faces)) + (index-count (array-list-size face-indices)) + (stride 8) + (mesh-data (make-f32vector (* vertex-count stride))) + (mesh-indices (make-u32vector index-count)) + (null-texcoord (vec2 0.0 0.0)) + (null-normal (vec3 0.0 0.0 0.0))) + ;; The mesh vertex data is packed like so: + ;; - 3 floats for vertex + ;; - 2 floats for texture coordinate + ;; - 3 floats for normal + ;; - repeat for each face + (let loop ((i 0)) + (when (< i vertex-count) + (let ((offset (* i stride))) + (match (array-list-ref faces i) + ((vert-index tex-index norm-index) + ;; Vertex + (let ((v (array-list-ref vertices vert-index))) + (f32vector-set! mesh-data offset (vec3-x v)) + (f32vector-set! mesh-data (+ offset 1) (vec3-y v)) + (f32vector-set! mesh-data (+ offset 2) (vec3-z v))) + ;; Texture coordinate + (let ((t (if tex-index + (array-list-ref texcoords tex-index) + null-texcoord))) + (f32vector-set! mesh-data (+ offset 3) (vec2-x t)) + (f32vector-set! mesh-data (+ offset 4) (vec2-y t))) + ;; Normal + (let ((n (if norm-index + (array-list-ref normals norm-index) + null-normal))) + (f32vector-set! mesh-data (+ offset 5) (vec3-x n)) + (f32vector-set! mesh-data (+ offset 6) (vec3-y n)) + (f32vector-set! mesh-data (+ offset 7) (vec3-z n)))))) + (loop (+ i 1)))) + ;; Pack indices. + (let loop ((i 0)) + (when (< i index-count) + (u32vector-set! mesh-indices i (array-list-ref face-indices i)) + (loop (+ i 1)))) + ;; Construct vertex array. + ;; TODO: Add names to buffers and views. + (let* ((index-buffer (make-buffer mesh-indices #:target 'index)) + (index-view (make-buffer-view #:type 'scalar + #:component-type 'unsigned-int + #:buffer index-buffer)) + (data-buffer (make-buffer mesh-data #:stride (* stride 4))) + (vertex-view (make-buffer-view #:type 'vec3 + #:component-type 'float + #:buffer data-buffer)) + (texcoord-view (make-buffer-view #:type 'vec2 + #:component-type 'float + #:buffer data-buffer + #:offset 12)) + (normal-view (make-buffer-view #:type 'vec3 + #:component-type 'float + #:buffer data-buffer + #:offset 20))) + (make-primitive material + (make-vertex-array + #:indices index-view + #:attributes `((0 . ,vertex-view) + (1 . ,texcoord-view) + (2 . ,normal-view))) + (or (hash-ref material-map material) + (hash-ref material-map "default")))))) + ;; Register default material + (hash-set! material-map "default" default-phong-material) + ;; Parse file. + (let loop ((material "default")) + (match (read-line port) + ((? eof-object?) + #f) + (line + (match (delete "" (string-split line char-set:whitespace)) + ((or () ("#" . _)) ; ignore comments and blank lines + (loop material)) + (("f" . args) + (parse-face args material) + (loop material)) + (("g" . _) ; ignore group name for now + (loop material)) + (("mtllib" mtl-file-name) + (load-mtl (scope-file mtl-file-name)) + (loop material)) + (("o" . _) ;ignore object name for now + (loop material)) + (("s" . _) ; ignore smoothing group for now + (loop material)) + (("usemtl" new-material) + (loop new-material)) + (("v" . args) + (parse-vertex args) + (loop material)) + (("vn" . args) + (parse-normal args) + (loop material)) + (("vt" . args) + (parse-texcoord args) + (loop material)) + (data + (format (current-error-port) + "warning: ~a:~d: unsupported OBJ data: ~s~%" + file-name + (port-line port) + data) + (loop material)))))) + ;; Construct a mesh by composing primitives. One primitive + ;; per material. + (let* ((model-name (basename file-name)) + (mesh (make-mesh model-name + (hash-fold (lambda (material indices memo) + ;; It's possible that a material has + ;; no data associated with it, so we + ;; drop those. + (if (array-list-empty? indices) + memo + (cons (make-primitive-for-material material) + memo))) + '() + face-indices-map))) + (scene (make-scene-node #:name model-name + #:mesh mesh))) + (make-model #:name model-name + #:scenes (list scene) + #:render-state + (make-render-state #:shader (load-phong-shader) + #:renderer draw-primitive/phong))))))) + + +;;; +;;; glTF 2.0 +;;; + +(define (load-gltf file-name) + (define (object-ref obj key) + (let ((value (assoc-ref obj key))) + (unless (pair? value) + (error "expected object for key" key value)) + value)) + (define (object-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (unless (or (not value) (pair? value)) + (error "expected object for optional key" key value)) + value)) + (define (array-ref obj key) + (let ((value (assoc-ref obj key))) + (unless (vector? value) + (error "expected array for key" key value)) + value)) + (define (array-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (unless (or (not value) (vector? value)) + (error "expected array for optional key" key value)) + value)) + (define (string-ref obj key) + (let ((value (assoc-ref obj key))) + (unless (string? value) + (error "expected string for key" key value)) + value)) + (define (string-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (unless (or (not value) (string? value)) + (error "expected string for optional key" key value)) + value)) + (define (number-ref obj key) + (let ((value (assoc-ref obj key))) + (unless (number? value) + (error "expected number for key" key value)) + value)) + (define (number-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (unless (or (not value) (number? value)) + (error "expected number for key" key value)) + value)) + (define (boolean-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (unless (boolean? value) + (error "expected boolean for key" key value)) + value)) + (define (number-array-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (unless (or (not value) + (and (vector? value) (vector-every number? value))) + (error "expected numeric array for key" key value)) + value)) + (define (matrix-ref/optional obj key) + (let ((value (assoc-ref obj key))) + (cond + ((not value) #f) + ((and (vector? value) + (= (vector-length value) 16) + (vector-every number? value)) + ;; glTF matrices are in column-major order. + (make-matrix4 (vector-ref value 0) + (vector-ref value 4) + (vector-ref value 8) + (vector-ref value 12) + (vector-ref value 1) + (vector-ref value 5) + (vector-ref value 9) + (vector-ref value 13) + (vector-ref value 2) + (vector-ref value 6) + (vector-ref value 10) + (vector-ref value 14) + (vector-ref value 3) + (vector-ref value 7) + (vector-ref value 11) + (vector-ref value 15))) + (else + (error "expected 4x4 matrix for key" key value))))) + (define (assert-color v) + (if (and (= (vector-length v) 4) + (vector-every (lambda (x) (and (>= x 0.0) (<= x 1.0))) v)) + (make-color (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3)) + (error "not a color vector" v))) + (define scope-file + (let ((gltf-root (dirname + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))))) + (lambda (other-file) + (if (absolute-file-name? other-file) + other-file + (string-append gltf-root "/" other-file))))) + (define (parse-buffer obj) + ;; TODO: support base64 encoded buffer data as uri + ;; TODO: support glb-stored buffers: + ;; https://github.com/KhronosGroup/glTF/blob/master/specification/2.0/README.md#glb-stored-buffer + (let* ((uri (string-ref/optional obj "uri")) + (length (number-ref obj "byteLength")) + (name (or (string-ref/optional obj "name") "anonymous")) + (extensions (object-ref/optional obj "extensions")) + (extras (assoc-ref obj "extras")) + (data (if uri + (call-with-input-file (scope-file uri) + (lambda (port) + (get-bytevector-n port length))) + (make-bytevector length)))) + data)) + (define (parse-buffer-view obj buffers) + (let ((name (string-ref/optional obj "name")) + (data (vector-ref buffers (number-ref obj "buffer"))) + (offset (or (number-ref/optional obj "byteOffset") 0)) + (length (number-ref obj "byteLength")) + (stride (number-ref/optional obj "byteStride")) + (target (match (or (number-ref/optional obj "target") 34962) + (34962 'vertex) + (34963 'index))) + (extensions (object-ref/optional obj "extensions")) + (extras (assoc-ref obj "extras"))) + (make-buffer data + #:name name + #:offset offset + #:length length + #:stride stride + #:target target))) + (define (parse-accessor obj buffer-views) + (define (type-length type) + (match type + ('scalar 1) + ('vec2 2) + ('vec3 3) + ('vec4 4) + ('mat2 4) + ('mat3 9) + ('mat4 16))) + (let ((name (or (string-ref/optional obj "name") "anonymous")) + (view (match (number-ref/optional obj "bufferView") + (#f #f) + (n (vector-ref buffer-views n)))) + (offset (or (number-ref/optional obj "byteOffset") 0)) + (component-type (match (number-ref obj "componentType") + (5120 'byte) + (5121 'unsigned-byte) + (5122 'short) + (5123 'unsigned-short) + (5125 'unsigned-int) + (5126 'float))) + (normalized? (boolean-ref/optional obj "normalized")) + (length (number-ref obj "count")) + (type (match (string-ref obj "type") + ("SCALAR" 'scalar) + ("VEC2" 'vec2) + ("VEC3" 'vec3) + ("VEC4" 'vec4) + ("MAT2" 'mat2) + ("MAT3" 'mat3) + ("MAT4" 'mat4))) + (max (number-array-ref/optional obj "max")) + (min (number-array-ref/optional obj "min")) + (sparse (object-ref/optional obj "sparse")) + (extensions (object-ref/optional obj "extensions")) + (extras (assoc-ref obj "extras"))) + (unless (>= length 1) + (error "count must be greater than 0" length)) + (when (and (vector? max) + (not (= (vector-length max) (type-length type)))) + (error "not enough elements for max" max type)) + (when (and (vector? min) + (not (= (vector-length min) (type-length type)))) + (error "not enough elements for min" min type)) + (make-buffer-view #:name name + #:buffer view + #:offset offset + #:component-type component-type + #:normalized? normalized? + #:length length + #:type type + #:max max + #:min min + #:sparse sparse))) + (define (texture-filter n) + (match n + (9728 'nearest) + ((or #f 9729) 'linear) + ;; TODO: Support mip-mapping + ;; (9984 'nearest-mipmap-nearest) + ;; (9985 'linear-mipmap-nearest) + ;; (9986 'nearest-mipmap-linear) + ;; (9987 'linear-mipmap-linear) + (_ 'linear))) + (define (texture-wrap n) + (match n + (10496 'clamp) + ((or #f 10497) 'repeat) + (33069 'clamp-to-border) + (33071 'clamp-to-edge))) + (define (parse-texture obj images samplers) + (let ((image (vector-ref images (number-ref obj "source"))) + (sampler + (vector-ref samplers (or (number-ref/optional obj "sampler") 0)))) + (load-image (scope-file (string-ref image "uri")) + #:min-filter (texture-filter + (number-ref/optional sampler "minFilter")) + #:mag-filter (texture-filter + (number-ref/optional sampler "magFilter")) + #:wrap-s (texture-wrap (number-ref/optional sampler "wrapS")) + #:wrap-t (texture-wrap (number-ref/optional sampler "wrapT"))))) + (define (parse-material obj textures) + (let* ((name (or (string-ref/optional obj "name") "anonymous")) + (pbrmr (or (object-ref/optional obj "pbrMetallicRoughness") '())) + (base-color-factor + (let ((v (or (number-array-ref/optional pbrmr "baseColorFactor") + #(1.0 1.0 1.0 1.0)))) + (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) + (base-color-texture + (match (object-ref/optional pbrmr "baseColorTexture") + (#f null-texture) + (obj + (vector-ref textures (number-ref obj "index"))))) + (metallic-factor + (or (number-ref/optional pbrmr "metallicFactor") + 1.0)) + (roughness-factor + (or (number-ref/optional pbrmr "roughnessFactor") + 1.0)) + (metallic-roughness-texture + (match (object-ref/optional pbrmr "metallicRoughnessTexture") + (#f null-texture) + (obj + (vector-ref textures (number-ref obj "index"))))) + (normal-factor + (let ((v (or (array-ref/optional obj "normalFactor") + #(1.0 1.0 1.0)))) + (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) + (normal-texture + (match (object-ref/optional obj "normalTexture") + (#f null-texture) + (obj (vector-ref textures (number-ref obj "index"))))) + (occlusion-factor + (let ((v (or (array-ref/optional obj "occlusionFactor") + #(1.0 1.0 1.0)))) + (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) + (occlusion-texture + (match (object-ref/optional obj "occlusionTexture") + (#f null-texture) + (obj (vector-ref textures (number-ref obj "index"))))) + (emissive-factor + (let ((v (or (array-ref/optional obj "emissiveFactor") + #(1.0 1.0 1.0)))) + (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) + (emissive-texture + (match (object-ref/optional obj "emissiveTexture") + (#f null-texture) + (obj (vector-ref textures (number-ref obj "index"))))) + (alpha-mode (match (or (string-ref/optional obj "alphaMode") + "BLEND") + ("OPAQUE" 'opaque) + ("MASK" 'mask) + ("BLEND" 'blend))) + (alpha-cutoff (or (number-ref/optional obj "alphaCutoff") 0.5)) + (double-sided? (boolean-ref/optional obj "doubleSided")) + (extensions (object-ref/optional obj "extensions")) + (extras (assoc-ref obj "extras"))) + (make-pbr-material #:name name + #:base-color-factor base-color-factor + #:base-color-texture base-color-texture + #:metallic-factor metallic-factor + #:roughness-factor roughness-factor + #:metallic-roughness-texture metallic-roughness-texture + #:normal-factor normal-factor + #:normal-texture normal-texture + #:occlusion-factor occlusion-factor + #:occlusion-texture occlusion-texture + #:emissive-factor emissive-factor + #:emissive-texture emissive-texture + #:alpha-mode alpha-mode + #:alpha-cutoff alpha-cutoff + #:double-sided? double-sided?))) + (define (attribute-name->index name) + (let ((shader (load-pbr-shader))) + (match name + ("POSITION" + (attribute-location + (hash-ref (shader-attributes shader) "position"))) + ("NORMAL" 1) + ("TANGENT" 2) + ("TEXCOORD_0" + (attribute-location + (hash-ref (shader-attributes shader) "texcoord0"))) + ("TEXCOORD_1" 4) + ("COLOR_0" 5) + ("JOINTS_0" 6) + ("WEIGHTS_0" 7)))) + (define (parse-primitive obj materials accessors) + (let ((attributes (map (match-lambda + ((name . n) + (cons (attribute-name->index name) + (vector-ref accessors n)))) + (object-ref obj "attributes"))) + (indices (match (number-ref/optional obj "indices") + (#f #f) + (n (vector-ref accessors n)))) + ;; TODO: Set a default material when none is given. + (material (match (number-ref/optional obj "material") + (#f #f) + (n (vector-ref materials n)))) + (mode (match (or (number-ref/optional obj "mode") 4) + (0 'points) + (1 'lines) + (2 'line-loop) + (3 'line-strip) + (4 'triangles) + (5 'triangle-strip) + (6 'triangle-fan))) + ;; TODO: Support morph targets. + (targets #f)) + (make-primitive "primitive" + (make-vertex-array #:indices indices + #:attributes attributes + #:mode mode) + material))) + (define (parse-mesh obj materials accessors) + (let ((name (or (string-ref/optional obj "name") "anonymous")) + (primitives + (map (lambda (obj) + (parse-primitive obj materials accessors)) + (vector->list (array-ref obj "primitives")))) + (weights (number-array-ref/optional obj "weights"))) + ;; TODO: Support weights. + (make-mesh name primitives))) + (define (parse-node obj parse-child meshes) + ;; TODO: Parse all fields of nodes. + (let ((name (or (string-ref/optional obj "name") "anonymous")) + ;; TODO: Parse camera. + (camera #f) + ;; TODO: Parse skin. + (skin #f) + (matrix (or (matrix-ref/optional obj "matrix") + (make-identity-matrix4))) + (mesh (match (number-ref/optional obj "mesh") + (#f #f) + (n (vector-ref meshes n)))) + ;; TODO: Parse rotation, scale, translation + (rotation #f) + (scale #f) + (translation #f) + ;; TODO: Parse weights. + (weights #f) + (children (map parse-child + (vector->list + (or (array-ref/optional obj "children") + #()))))) + (make-scene-node #:name name + #:children children + #:matrix matrix + #:mesh mesh))) + (define (parse-nodes array meshes) + (define nodes (make-vector (vector-length array) #f)) + (define (parse-node* i) + (let ((node (vector-ref nodes i))) + (or node + (let ((node (parse-node (vector-ref array i) + parse-node* + meshes))) + (vector-set! nodes i node) + node)))) + (let loop ((i 0)) + (when (< i (vector-length array)) + (parse-node* i) + (loop (+ i 1)))) + nodes) + (define (parse-scene obj nodes) + (let ((name (or (string-ref/optional obj "name") "anonymous")) + (children + (map (lambda (i) (vector-ref nodes i)) + (vector->list + (or (number-array-ref/optional obj "nodes") + #()))))) + (make-scene-node #:name name #:children children))) + (define (vector-map proc v) + (let ((new-v (make-vector (vector-length v)))) + (let loop ((i 0)) + (when (< i (vector-length v)) + (vector-set! new-v i (proc (vector-ref v i))) + (loop (+ i 1)))) + new-v)) + (call-with-input-file file-name + (lambda (port) + (let* ((tree (read-json port)) + (asset (object-ref tree "asset")) + (version (string-ref asset "version")) + (copyright (string-ref/optional asset "copyright")) + (generator (string-ref/optional asset "generator")) + (minimum-version (string-ref/optional asset "minVersion")) + (extensions (object-ref/optional asset "extensions")) + ;; TODO: Figure out how to parse extras in a user-defined way + (extras (assoc-ref asset "extras")) + (buffers (vector-map parse-buffer + (or (assoc-ref tree "buffers") #()))) + (buffer-views (vector-map (lambda (obj) + (parse-buffer-view obj buffers)) + (or (assoc-ref tree "bufferViews") #()))) + (accessors (vector-map (lambda (obj) + (parse-accessor obj buffer-views)) + (or (assoc-ref tree "accessors") #()))) + (images (or (assoc-ref tree "images") #())) + (samplers (or (assoc-ref tree "samplers") #(()))) + (textures (vector-map (lambda (obj) + (parse-texture obj images samplers)) + (or (assoc-ref tree "textures") #()))) + (materials (vector-map (lambda (obj) + (parse-material obj textures)) + (or (assoc-ref tree "materials") #()))) + (meshes (vector-map (lambda (obj) + (parse-mesh obj materials accessors)) + (or (assoc-ref tree "meshes") #()))) + (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes)) + (scenes (map (lambda (obj) + (parse-scene obj nodes)) + (vector->list + (or (assoc-ref tree "scenes") #())))) + (default-scene (list-ref scenes + (or (number-ref/optional tree "scene") + 0)))) + (unless (string=? version "2.0") + (error "unsupported glTF version" version)) + (make-model #:name (basename file-name) + #:scenes (list default-scene) + #:render-state + (make-render-state #:shader (load-pbr-shader) + #:renderer draw-primitive/pbr)))))) diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm new file mode 100644 index 0000000..0cd275e --- /dev/null +++ b/chickadee/graphics/particles.scm @@ -0,0 +1,490 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2018 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics particles) + #: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) + #:use-module (chickadee graphics buffer) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:export (make-particle-emitter + particle-emitter? + particle-emitter-spawn-area + particle-emitter-rate + particle-emitter-life + particle-emitter-done? + make-particles + particles? + particles-capacity + particles-size + particles-texture + particles-blend-mode + particles-color + particles-spawn-area + add-particle-emitter + remove-particle-emitter + update-particles + draw-particles* + draw-particles)) + +(define-record-type + (%make-particle-emitter spawn-area rate life) + particle-emitter? + (spawn-area particle-emitter-spawn-area) + (rate particle-emitter-rate) + (life particle-emitter-life set-particle-emitter-life!)) + +(define* (make-particle-emitter spawn-area rate #:optional duration) + "Return a new particle emitter that spawns RATE particles per frame +within SPAWN-AREA (a rectangle or 2D vector) for DURATION frames. If +DURATION is not specified, the emitter will spawn particles +indefinitely." + (%make-particle-emitter spawn-area rate duration)) + +(define (update-particle-emitter emitter) + "Advance the lifecycle of EMITTER." + (let ((life (particle-emitter-life emitter))) + (when life + (set-particle-emitter-life! emitter (- life 1))))) + +(define (particle-emitter-done? emitter) + "Return #t if EMITTER has finished emitting particles." + (let ((life (particle-emitter-life emitter))) + (and life (<= life 0)))) + +(define-record-type + (%make-particles capacity size bv buffer shader vertex-array + texture animation-rows animation-columns + speed-range acceleration-range direction-range + blend-mode start-color end-color lifetime + sort emitters) + particles? + (capacity particles-capacity) + (size particles-size set-particles-size!) + (bv particles-bv) + (buffer particles-buffer) + (shader particles-shader) + (vertex-array particles-vertex-array) + (texture particles-texture set-particles-texture!) + (animation-rows particles-animation-rows) + (animation-columns particles-animation-columns) + (speed-range particles-speed-range set-particles-speed-range!) + (acceleration-range particles-acceleration-range + set-particles-acceleration-range!) + (direction-range particles-direction-range set-particles-direction-range!) + (blend-mode particles-blend-mode set-particles-blend-mode!) + (start-color particles-start-color set-particles-start-color!) + (end-color particles-end-color set-particles-end-color!) + (lifetime particles-lifetime set-particles-lifetime!) + (sort particles-sort set-particles-sort!) + (emitters particles-emitters set-particles-emitters!)) + +(define (add-particle-emitter particles emitter) + "Add EMITTER to PARTICLES." + (set-particles-emitters! particles + (cons emitter (particles-emitters particles)))) + +(define (remove-particle-emitter particles emitter) + "Remove EMITTER from PARTICLES." + (set-particles-emitters! particles + (delete emitter (particles-emitters particles)))) + +(define (make-particles-shader) + (strings->shader + " +#ifdef GLSL330 +layout (location = 0) in vec2 position; +layout (location = 1) in vec2 tex; +layout (location = 2) in vec2 offset; +layout (location = 3) in float life; +#elif defined(GLSL130) +in vec2 position; +in vec2 tex; +in vec2 offset; +in float life; +#elif defined(GLSL120) +attribute vec2 position; +attribute vec2 tex; +attribute vec2 offset; +attribute float life; +#endif +#ifdef GLSL120 +varying vec2 fragTex; +varying float t; +#else +out vec2 fragTex; +out float t; +#endif +uniform mat4 mvp; +uniform int lifetime; +uniform int animationRows; +uniform int animationColumns; + +void main(void) { + t = life / lifetime; + int numTiles = animationRows * animationColumns; + int tile = int(numTiles * (1.0 - t)); + float tx = float(tile % animationColumns) / animationColumns; + float ty = float(tile / animationColumns) / animationRows; + 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); +} +" + " +#ifdef GLSL120 +attribute vec2 fragTex; +attribute float t; +#else +in vec2 fragTex; +in float t; +#endif +#ifdef GLSL330 +out vec4 fragColor; +#endif +uniform sampler2D color_texture; +uniform vec4 startColor; +uniform vec4 endColor; + +void main (void) { +#ifdef GLSL330 + fragColor = mix(endColor, startColor, t) * texture(color_texture, fragTex); +#elif ifdef GLSL130 + gl_FragColor = mix(endColor, startColor, t) * texture2D(color_texture, fragTex); +#endif +} +")) + +(define (make-particles-vertex-array capacity width height texture buffer) + (let* ((indices (make-buffer-view #:type 'scalar + #:component-type 'unsigned-int + #:divisor 0 + #:buffer (make-buffer + (u32vector 0 3 2 0 2 1) + #:target 'index))) + (verts (make-buffer-view #:type 'vec2 + #:component-type 'float + #:divisor 0 + #:buffer (make-buffer + ;; TODO: use the texture + ;; size in pixels. + (let ((hw (/ width 2.0)) + (hh (/ height 2.0))) + (f32vector (- hw) (- hh) + hw (- hh) + hw hh + (- hw) hh)) + #:target 'vertex))) + (tex (make-buffer-view #:type 'vec2 + #:component-type 'float + #:divisor 0 + #:buffer (make-buffer + (let ((tex (texture-gl-tex-rect + texture))) + (f32vector 0 0 + 1 0 + 1 1 + 0 1)) + #:target 'vertex))) + (pos (make-buffer-view #:name "particle position buffer" + #:buffer buffer + #:type 'vec2 + #:component-type 'float + #:length capacity + #:divisor 1)) + (life (make-buffer-view #:name "particle life remaining buffer" + #:buffer buffer + #:type 'scalar + #:component-type 'int + #:offset 24 + #:length capacity + #:divisor 1))) + (make-vertex-array #:indices indices + #:attributes `((0 . ,verts) + (1 . ,tex) + (2 . ,pos) + (3 . ,life))))) + +(define* (make-particles capacity #:key + (blend-mode 'alpha) + (start-color white) + (end-color (make-color 0.0 0.0 0.0 0.0)) + (texture null-texture) + (animation-rows 1) + (animation-columns 1) + (width (if (texture-null? texture) + 8.0 + (inexact->exact + (floor + (/ (texture-width texture) + animation-columns))))) + (height (if (texture-null? texture) + 8.0 + (inexact->exact + (floor + (/ (texture-height texture) + animation-rows))))) + (speed-range (vec2 0.1 1.0)) + (acceleration-range (vec2 0.0 0.1)) + (direction-range (vec2 0.0 (* 2 pi))) + (lifetime 30) + sort) + "Return a new particle system that may contain up to CAPACITY +particles. Achieving the desired particle effect involves tweaking +the following keyword arguments as needed: + +- BLEND-MODE: Pixel blending mode. 'alpha' by default. + +- START-COLOR: The tint color of the particle at the beginning of its +life. White by default. + +- END-COLOR: The tint color of the particle at the end of of its life. +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. + +- ANIMATION-ROWS: How many animation frame rows there are in the +texture. Default is 1. + +- ANIMATION-COLUMNS: How many animation frame columns there are in the +texture. Default is 1. + +- WIDTH: The width of each particle. By default, the width of an +animation frame (in pixels) is used. + +- HEIGHT: The height of each particle. By default, the height of an +animation frame (in pixels) is used. + +- SPEED-RANGE: A 2D vector containing the min and max particle speed. +Each particle will have a speed chosen at random from this range. By +default, speed ranges from 0.1 to 1.0. + +- ACCELERATION-RANGE: A 2D vector containing the min and max particle +acceleration. Each particle will have an acceleration chosen at +random from this range. By default, acceleration ranges from 0.0 to +0.1. + +- DIRECTION-RANGE: A 2D vector containing the min and max particle +direction as an angle in radians. Each particle will have a direction +chosen at random from this range. By default, the range covers all +possible angles. + +- LIFETIME: How long each particle lives, measured in updates. 30 by +default. + +- SORT: 'youngest' if youngest particle should be drawn last or +'oldest' for the reverse. By default, no sorting is applied at all." + (let* ((stride (+ (* 4 2) ; position - 2x f32 + (* 4 2) ; velocity - 2x f32 + (* 4 2) ; acceleration - 2x f32 + 4)) ; life remaining - 1x s32 + (buffer (make-buffer #f + #:name "packed particle data" + ;; One extra element to use as + ;; swap space for sorting + ;; particles. + #:length (* stride capacity) + #:stride stride + #:usage 'stream))) + (%make-particles capacity + 0 + ;; 1 extra element as swap space for sorting. + (make-bytevector (* (+ capacity 1) stride)) + buffer + (make-particles-shader) + (make-particles-vertex-array capacity + width + height + texture + buffer) + texture + animation-rows + animation-columns + speed-range + acceleration-range + direction-range + blend-mode + start-color + end-color + lifetime + sort + '()))) + +(define (update-particles particles) + "Advance the simulation of PARTICLES." + (let* ((buffer (particles-buffer particles)) + (va (particles-vertex-array particles)) + (pos (assq-ref (vertex-array-attributes va) 2)) + (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 (buffer-stride buffer)) + (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-mapped-buffer buffer + (bytevector-copy! bv 0 (buffer-data buffer) 0 (* (particles-size particles) stride)))))) + +(define draw-particles* + (let ((mvp (make-null-matrix4))) + (lambda (particles matrix) + "Render PARTICLES with MATRIX applied." + (let ((size (particles-size particles)) + (va (particles-vertex-array particles))) + (with-blend-mode (particles-blend-mode particles) + (with-texture 0 (particles-texture particles) + (gpu-apply/instanced (particles-shader particles) + va + size + #: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)))))))) + +(define (draw-particles particles) + "Render PARTICLES." + (draw-particles* particles #f)) diff --git a/chickadee/graphics/pbr.scm b/chickadee/graphics/pbr.scm new file mode 100644 index 0000000..375f5d0 --- /dev/null +++ b/chickadee/graphics/pbr.scm @@ -0,0 +1,150 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Physically based lighting model. +;; +;;; Code: + +(define-module (chickadee graphics pbr) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (srfi srfi-9) + #:export (make-pbr-material + pbr-material? + pbr-material-name + pbr-material-base-color-factor + pbr-material-base-color-texture + pbr-material-metallic-factor + pbr-material-roughness-factor + pbr-material-metallic-roughness-texture + pbr-material-normal-factor + pbr-material-normal-texture + pbr-material-occlusion-facgor + pbr-material-occlusion-texture + pbr-material-emissive-factor + pbr-material-emissive-texture + pbr-material-alpha-mode + pbr-material-alpha-cutoff + pbr-material-double-sided? + default-pbr-material + load-pbr-shader + gpu-apply/pbr)) + +(define-shader-type + make-pbr-material + pbr-material? + (local-field name pbr-material-name) + (float-vec3 base-color-factor pbr-material-base-color-factor) + (local-field base-color-texture pbr-material-base-color-texture) + (float metallic-factor pbr-material-metallic-factor) + (float roughness-factor pbr-material-roughness-factor) + (local-field metallic-roughness-texture pbr-material-metallic-roughness-texture) + (float-vec3 normal-factor pbr-material-normal-factor) + (local-field normal-texture pbr-material-normal-texture) + (float-vec3 occlusion-factor pbr-material-occlusion-factor) + (local-field occlusion-texture pbr-material-occlusion-texture) + (float-vec3 emissive-factor pbr-material-emissive-factor) + (local-field emissive-texture pbr-material-emissive-texture) + (local-field alpha-mode pbr-material-alpha-mode) + (float alpha-cutoff pbr-material-alpha-cutoff) + (bool double-sided? pbr-material-double-sided?)) + +(define default-pbr-material + (make-pbr-material #:name "default" + #:base-color-factor #v(1.0 1.0 1.0) + #:base-color-texture null-texture + #:metallic-factor 1.0 + #:roughness-factor 1.0 + #:metallic-roughness-texture null-texture + #:normal-factor #v(1.0 1.0 1.0) + #:normal-texture null-texture + #:occlusion-factor #v(1.0 1.0 1.0) + #:occlusion-texture null-texture + #:emissive-factor #v(1.0 1.0 1.0) + #:emissive-texture null-texture + #:alpha-mode 'opaque + #:alpha-cutoff 0.5 + #:double-sided? #f)) + +;; TODO: Actually implement PBR. For now it's just the minimal amount +;; of code needed to render the base texture of a mesh. +(define pbr-shader + (delay + (strings->shader + " +#ifdef GLSL330 +layout (location = 0) in vec3 position; +layout (location = 1) in vec2 texcoord0; +#elif defined(GLSL130) +in vec3 position; +in vec2 texcoord0; +#elif defined(GLSL120) +attribute vec3 position; +attribute vec2 texcoord0; +#endif +#ifdef GLSL120 +varying vec2 fragTex; +#else +out vec2 fragTex; +#endif +uniform mat4 model; +uniform mat4 view; +uniform mat4 projection; + +void main(void) { + fragTex = texcoord0; + gl_Position = projection * view * model * vec4(position.xyz, 1.0); +} +" + " +#ifdef GLSL120 +attribute vec2 fragTex; +#else +in vec2 fragTex; +#endif +#ifdef GLSL330 +out vec4 fragColor; +#endif +uniform vec3 baseColorFactor; +uniform sampler2D baseColorTexture; + +void main (void) { +#ifdef GLSL330 + fragColor = texture(baseColorTexture, fragTex) * + vec4(baseColorFactor, 1.0); +#else + gl_FragColor = texture2D(baseColorTexture, fragTex) * + vec4(baseColorFactor, 1.0); +#endif +} +"))) + +(define (load-pbr-shader) + (force pbr-shader)) + +(define (gpu-apply/pbr shader vertex-array material model-matrix view-matrix) + (with-texture 0 (pbr-material-base-color-texture material) + (gpu-apply shader vertex-array + #:model model-matrix + #:view view-matrix + #:projection (current-projection) + #:base-color-factor (pbr-material-base-color-factor material)))) diff --git a/chickadee/graphics/phong.scm b/chickadee/graphics/phong.scm new file mode 100644 index 0000000..ab34fce --- /dev/null +++ b/chickadee/graphics/phong.scm @@ -0,0 +1,253 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Simple forward rendered Phong lighting model. +;; +;;; Code: + +(define-module (chickadee graphics phong) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (srfi srfi-9) + #:export (make-phong-material + phong-material? + phong-material-name + phong-material-ambient + phong-material-ambient-map + phong-material-use-ambient-map? + phong-material-diffuse + phong-material-diffuse-map + phong-material-use-diffuse-map? + phong-material-specular + phong-material-specular-map? + phong-material-use-specular-map? + phong-material-specular-exponent + phong-material-bump-map + phong-material-use-bump-map? + default-phong-material + load-phong-shader + gpu-apply/phong)) + + +;;; +;;; Phong Material +;;; + +(define-shader-type + make-phong-material + phong-material? + (local-field name phong-material-name) + (float-vec3 ambient phong-material-ambient) + (local-field ambient-map phong-material-ambient-map) + (bool use-ambient-map phong-material-use-ambient-map?) + (float-vec3 diffuse phong-material-diffuse) + (local-field diffuse-map phong-material-diffuse-map) + (bool use-diffuse-map phong-material-use-diffuse-map?) + (float-vec3 specular phong-material-specular) + (local-field specular-map phong-material-specular-map) + (bool use-specular-map phong-material-use-specular-map?) + (float shininess phong-material-shininess) + (local-field bump-map phong-material-bump-map) + (bool use-bump-map phong-material-use-bump-map?)) + +(define default-phong-material + (make-phong-material #:name "default" + #:ambient (vec3 0.5 0.5 0.5) + #:ambient-map null-texture + #:use-ambient-map #f + #:diffuse (vec3 0.8 0.8 0.8) + #:diffuse-map null-texture + #:use-diffuse-map #f + #:specular (vec3 0.3 0.3 0.3) + #:specular-map null-texture + #:use-specular-map #f + #:shininess 32.0 + #:bump-map null-texture + #:use-bump-map #f)) + + +;;; +;;; Lights +;;; + +(define-shader-type + make-directional-light + directional-light? + (float-vec3 direction directional-light-direction) + (float-vec3 ambient directional-light-ambient) + (float-vec3 diffuse directional-light-diffuse) + (float-vec3 specular directional-light-specular) + (float shininess directional-light-shininess)) + +(define default-directional-light + (make-directional-light #:direction (vec3 0.0 0.0 -1.0) + #:ambient (vec3 0.1 0.1 0.1) + #:diffuse (vec3 1.0 1.0 1.0) + #:specular (vec3 0.5 0.5 0.5) + #:shininess 32.0)) + + +;;; +;;; Phong Shader +;;; + +(define phong-shader + (delay + (strings->shader + " +#ifdef GLSL330 +layout (location = 0) in vec3 position; +layout (location = 1) in vec2 texcoord; +layout (location = 2) in vec3 normal; +#elif defined(GLSL130) +in vec3 position; +in vec2 texcoord; +in vec3 normal; +#elif defined(GLSL120) +attribute vec3 position; +attribute vec2 texcoord; +attribute vec3 normal; +#endif + +uniform mat4 model; +uniform mat4 view; +uniform mat4 projection; + +#ifdef GLSL120 +varying vec3 fragNorm; +varying vec2 fragTex; +#else +out vec3 fragNorm; +out vec2 fragTex; +#endif + +void main() { + gl_Position = projection * view * model * vec4(position, 1.0); + // TODO: Calculate normal matrix on CPU + fragNorm = normalize(model * vec4(normal, 1.0)).xyz; + fragTex = texcoord; +} +" + " +struct Material { + vec3 ambient; + sampler2D ambientMap; + bool useAmbientMap; + vec3 diffuse; + sampler2D diffuseMap; + bool useDiffuseMap; + vec3 specular; + sampler2D specularMap; + bool useSpecularMap; + float shininess; + sampler2D bumpMap; + bool useBumpMap; +}; + +struct DirectionalLight { + vec3 direction; + vec3 ambient; + vec3 diffuse; + vec3 specular; +}; + +#ifdef GLSL120 +attribute vec3 fragNorm; +attribute vec2 fragTex; +#else +in vec3 fragNorm; +in vec2 fragTex; +#endif + +#ifdef GLSL330 +out vec4 fragColor; +#endif + +uniform Material material; +uniform DirectionalLight directionalLight; + +void main() { + vec3 baseAmbientColor; + vec3 baseDiffuseColor; + vec3 baseSpecularColor; + if(material.useAmbientMap) { +#ifdef GLSL330 + baseAmbientColor = texture(material.ambientMap, fragTex).xyz; +#else + baseAmbientColor = texture2D(material.ambientMap, fragTex).xyz; +#endif + } else { + baseAmbientColor = vec3(1.0, 1.0, 1.0); + } + if(material.useDiffuseMap) { + // discard transparent fragments. +#ifdef GLSL330 + vec4 color = texture(material.diffuseMap, fragTex); +#else + vec4 color = texture2D(material.diffuseMap, fragTex); +#endif + if(color.a == 0.0) { discard; } + baseDiffuseColor = color.xyz; + } else { + baseDiffuseColor = vec3(1.0, 1.0, 1.0); + } + if(material.useSpecularMap) { +#ifdef GLSL330 + baseSpecularColor = texture(material.specularMap, fragTex).xyz; +#else + baseSpecularColor = texture2D(material.specularMap, fragTex).xyz; +#endif + } else { + baseSpecularColor = vec3(1.0, 1.0, 1.0); + } + vec3 ambientColor = material.ambient * baseAmbientColor * baseDiffuseColor; + vec3 lightDir = normalize(-directionalLight.direction); + float diffuseFactor = max(dot(lightDir, fragNorm), 0.0); + vec3 diffuseColor = diffuseFactor * baseDiffuseColor * material.diffuse; + vec3 reflectDir = reflect(-lightDir, fragNorm); + float specularFactor = 0; + if(material.shininess > 0) { + specularFactor = pow(max(dot(lightDir, reflectDir), 0.0), material.shininess); + } + vec3 specularColor = specularFactor * baseSpecularColor * material.specular; +#ifdef GLSL330 + fragColor = vec4(ambientColor + diffuseColor + specularColor, 1.0); +#else + gl_FragColor = vec4(ambientColor + diffuseColor + specularColor, 1.0); +#endif +} +"))) + +(define (load-phong-shader) + (force phong-shader)) + +(define (gpu-apply/phong shader vertex-array material model-matrix view-matrix) + (with-texture 0 (phong-material-ambient-map material) + (with-texture 1 (phong-material-diffuse-map material) + (with-texture 2 (phong-material-specular-map material) + (with-texture 3 (phong-material-bump-map material) + (gpu-apply shader vertex-array + #:model model-matrix + #:view view-matrix + #:projection (current-projection) + #:material material + #:directional-light default-directional-light)))))) diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm new file mode 100644 index 0000000..fc6f5ea --- /dev/null +++ b/chickadee/graphics/shader.scm @@ -0,0 +1,826 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics shader) + #:use-module (ice-9 format) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (oop goops) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (gl) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:use-module (chickadee graphics texture) + #:export (shader-data-type? + bool + int + unsigned-int + float + float-vec2 + float-vec3 + float-vec4 + mat4 + sampler-2d + local-field + define-shader-type + uniform-namespace? + uniform-namespace-ref + uniform-namespace-for-each + make-shader + shader? + null-shader + apply-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)) + + +;;; +;;; Primitive Shader Data Types +;;; + +(define-record-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 type) + (shader-primitive-type-size type) + (shader-primitive-type-null type))) + +(set-record-type-printer! 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))) + (let loop ((i 0)) + (when (< i (vector-length data)) + (serialize bv (* i size) (vector-ref data i)) + (loop (+ i 1))))) + (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 color? + #:serializer + (lambda (bv i v) + ;; As of now, there is no vec4 Scheme type, but we do want to + ;; accept colors as vec4s since there is no special color type in + ;; GLSL. + (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 (color 0.0 0.0 0.0 0.0)) + +(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) + + +;;; +;;; 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 + (make-vtable (string-append standard-vtable-fields "pwpw") + (lambda (vt port) + (format port "#" + (shader-struct-fields vt))))) + +(define local-field (gensym "local-shader-field-")) + +(define (shader-struct? struct) + (eq? (struct-vtable (struct-vtable 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)) + (let loop ((i 0)) + (when (< i (vector-length value)) + (validate (vector-ref value i)) + (loop (+ i 1))))) + ((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) ) + (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 + (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 () + ((_ field getter) + (define getter + (let ((index (match (assq-ref (shader-struct-fields ) 'field) + ((i _ _) i)))) + (lambda (obj) + (struct-ref obj index))))) + ((_ field getter setter) + (begin + (define-accessors field getter) + (define setter + (let ((index (match (assq-ref (shader-struct-fields ) 'field) + ((i _ _) i)))) + (lambda (obj value) + (shader-struct-type-check 'field value) + (struct-set! obj index value)))))))) + +(define-syntax define-shader-type + (syntax-rules () + ((_ constructor predicate (field-type field-name . field-rest) ...) + (begin + (define + (make-shader-struct ' (list (list 'field-name field-type) ...))) + (define* (constructor #:key (field-name (shader-struct-default 'field-name)) ...) + (shader-struct-type-check 'field-name field-name) ... + (make-struct/no-tail field-name ...)) + (define (predicate obj) + (and (struct? obj) (eq? (struct-vtable obj) ))) + (define-accessors field-name . field-rest) ...)))) + + +;;; +;;; Shaders +;;; + +(define-record-type + (%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 + (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!)) + +;; variable name -> {uniform, namespace, uniform array} map +(define-record-type + (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 + (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 + (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 <> (class-of null-shader)) + +(define-method (gpu-finalize (shader <>)) + (gl-delete-program (shader-id shader))) + +(define (apply-shader shader) + (gl-use-program (shader-id 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 (gpu-glsl-version (current-gpu)))) + (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-mat4)) mat4) + ((= type (version-2-0 sampler-2d)) sampler-2d) + (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? (eq? type sampler-2d)) + (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))) + (let loop ((i 0)) + (unless (= 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)))) + (loop (1+ i)))) + table)) + (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))) + (gpu-guard + (%make-shader id (extract-attributes id) namespace + scratch (bytevector->pointer scratch)))))))) + +(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) + (define (traverse thing) + (cond + ((uniform? thing) + (proc thing)) + ((uniform-namespace? thing) + (uniform-namespace-for-each + (lambda (key uniform) + (traverse uniform)) + thing)) + ((uniform-array? thing) + (let ((size (uniform-array-size thing))) + (let loop ((i 0)) + (when (< i size) + (traverse (uniform-array-namespace-ref thing i)) + (loop (+ i 1)))))))) + (traverse (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-name x) + (define (traverse 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 x)))) + (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 (eq? (uniform-type uniform) sampler-2d) + (traverse uniform (shader-struct-ref value key)))) + uniform) + (error "expected shader struct" x))) + ;; 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))) + (let loop ((i 0)) + (when (< i size) + (traverse (uniform-array-namespace-ref uniform i) + (vector-ref value i)) + (loop (+ i 1)))) + (error "vector size mismatch for uniform" + (uniform-array-name uniform))))))) + ;; Walk the uniform namespace tree until we get to a leaf node or + ;; nodes. + (traverse (shader-uniform shader uniform-name) x)) diff --git a/chickadee/graphics/shapes.scm b/chickadee/graphics/shapes.scm new file mode 100644 index 0000000..79a73b6 --- /dev/null +++ b/chickadee/graphics/shapes.scm @@ -0,0 +1,408 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2018 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary +;; +;; Polylines as described in +;; http://jcgt.org/published/0002/02/08/paper.pdf +;; +;;; Code: + +(define-module (chickadee graphics shapes) + #:use-module (ice-9 match) + #:use-module (srfi srfi-4) + #:use-module (chickadee math bezier) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics buffer) + #:export (draw-filled-rect + draw-line + draw-bezier-curve + draw-bezier-path)) + +;; TODO: Make a generic polygon renderer, include batching, etc. +(define draw-filled-rect + (let* ((vertex-buffer + (delay + (make-streaming-buffer-view 'vec2 'float 4 + #:name "rect-buffer-view"))) + (index-buffer + (delay + (make-buffer-view #:type 'scalar + #:component-type 'unsigned-int + #:buffer (make-buffer (u32vector 0 3 2 0 2 1) + #:target 'index)))) + (vertex-array + (delay + (make-vertex-array #:indices (force index-buffer) + #:attributes `((0 . ,(force vertex-buffer)))))) + (default-shader + (delay + (strings->shader + " +#ifdef GLSL330 +layout (location = 0) in vec2 position; +#elif defined(GLSL130) +in vec2 position; +#elif defined(GLSL120) +attribute vec2 position; +#endif +uniform mat4 mvp; + +void main(void) { + gl_Position = mvp * vec4(position.xy, 0.0, 1.0); +} +" + " +#ifdef GLSL330 +out vec4 fragColor; +#endif +uniform vec4 color; + +void main (void) { +#ifdef GLSL330 + fragColor = color; +#else + gl_FragColor = color; +#endif +} +"))) + (mvp (make-null-matrix4))) + (lambda* (region + color + #:key + (blend-mode 'alpha) + (shader (force default-shader)) + matrix) + (let* ((x1 (rect-x region)) + (y1 (rect-y region)) + (x2 (+ x1 (rect-width region))) + (y2 (+ y1 (rect-height region)))) + (with-mapped-buffer-view (force vertex-buffer) + (let ((bv (buffer-view-data (force vertex-buffer)))) + (f32vector-set! bv 0 x1) + (f32vector-set! bv 1 y1) + (f32vector-set! bv 2 x2) + (f32vector-set! bv 3 y1) + (f32vector-set! bv 4 x2) + (f32vector-set! bv 5 y2) + (f32vector-set! bv 6 x1) + (f32vector-set! bv 7 y2))) + (with-blend-mode blend-mode + (gpu-apply shader (force vertex-array) + #:mvp (if matrix + (begin + (matrix4-mult! mvp matrix + (current-projection)) + mvp) + (current-projection)) + #:color color)))))) + +(define draw-line + (let* ((mvp (make-null-matrix4)) + (vertex-buffer + (delay + (make-streaming-buffer-view 'vec2 'float 4 + #:name "line-buffer-view"))) + (texcoord-buffer + (delay + (make-streaming-buffer-view 'vec2 'float 4 + #:name "line-buffer-view"))) + (index-buffer + (delay + (make-buffer-view #:type 'scalar + #:component-type 'unsigned-int + #:buffer (make-buffer (u32vector 0 3 2 0 2 1) + #:target 'index)))) + (vertex-array + (delay + (make-vertex-array #:indices (force index-buffer) + #:attributes `((0 . ,(force vertex-buffer)) + (1 . ,(force texcoord-buffer)))))) + (default-shader + (delay + (strings->shader + " +#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 +uniform mat4 mvp; + +void main(void) { + fragTex = tex; + gl_Position = mvp * vec4(position.xy, 0.0, 1.0); +} +" + " +#ifdef GLSL120 +attribute vec2 fragTex; +#else +in vec2 fragTex; +#endif +#ifdef GLSL330 +out vec4 fragColor; +#endif +uniform vec4 color; +uniform float r; +uniform float w; +uniform float t; +uniform float l; +uniform int cap; +float infinity = 1.0 / 0.0; + +void main (void) { + float hw = w / 2.0; + float u = fragTex.x; + float v = fragTex.y; + float dx; + float dy; + float d; + + if (u < 0 || u > l) { + if (u < 0) { + dx = abs(u); + } else { + dx = u - l; + } + dy = abs(v); + + switch (cap) { + // none + case 0: + d = infinity; + break; + // butt + case 1: + d = max(dx + w / 2 - 2 * r, dy); + break; + // square + case 2: + d = max(dx, dy); + break; + // round + case 3: + d = sqrt(dx * dx + dy * dy); + break; + // triangle out + case 4: + d = dx + dy; + break; + // triangle in + case 5: + d = max(dy, w / 2 - r + dx - dy); + break; + } + } else { + d = abs(v); + } + + if (d <= hw) { +#ifdef GLSL330 + fragColor = color; +#else + gl_FragColor = color; +#endif + } else { +#ifdef GLSL330 + fragColor = vec4(color.rgb, color.a * (1.0 - ((d - hw) / r))); +#else + gl_FragColor = vec4(color.rgb, color.a * (1.0 - ((d - hw) / r))); +#endif + } +} +")))) + (lambda* (start end #:key + (thickness 0.5) + (feather 1.0) + (cap 'round) + (color white) + (shader (force default-shader)) + matrix) + "Draw a line segment from START to END. The line will be +THICKNESS pixels thick with an antialiased border FEATHER pixels wide. +The line will be colored COLOR. CAP specifies the type of end cap that +should be used to terminate the lines, either 'none', 'butt', +'square', 'round', 'triangle-in', or 'triangle-out'. Advanced users +may use SHADER to override the built-in line segment shader." + (let* ((x1 (vec2-x start)) + (y1 (vec2-y start)) + (x2 (vec2-x end)) + (y2 (vec2-y end)) + (dx (- x2 x1)) + (dy (- y2 y1)) + (length (sqrt (+ (expt dx 2) (expt dy 2)))) + (padding (/ (ceiling (+ thickness (* feather 2.5))) 2.0)) + (nx (/ dx length)) + (ny (/ dy length)) + (xpad (* nx padding)) + (ypad (* ny padding)) + ;; start left + (vx1 (+ (- x1 xpad) ypad)) + (vy1 (+ (- y1 ypad) (- xpad))) + (s1 (- padding)) + (t1 padding) + ;; start right + (vx2 (+ (- x1 xpad) (- ypad))) + (vy2 (+ (- y1 ypad) xpad)) + (s2 (- padding)) + (t2 (- padding)) + ;; end left + (vx3 (+ x2 xpad (- ypad))) + (vy3 (+ y2 ypad xpad)) + (s3 (+ length padding)) + (t3 (- padding)) + ;; end right + (vx4 (+ (+ x2 xpad) ypad)) + (vy4 (+ (+ y2 ypad) (- xpad))) + (s4 (+ length padding)) + (t4 padding)) + (with-mapped-buffer-view (force vertex-buffer) + (let ((bv (buffer-view-data (force vertex-buffer)))) + (f32vector-set! bv 0 vx1) + (f32vector-set! bv 1 vy1) + (f32vector-set! bv 2 vx2) + (f32vector-set! bv 3 vy2) + (f32vector-set! bv 4 vx3) + (f32vector-set! bv 5 vy3) + (f32vector-set! bv 6 vx4) + (f32vector-set! bv 7 vy4))) + (with-mapped-buffer-view (force texcoord-buffer) + (let ((bv (buffer-view-data (force texcoord-buffer)))) + (f32vector-set! bv 0 s1) + (f32vector-set! bv 1 t1) + (f32vector-set! bv 2 s2) + (f32vector-set! bv 3 t2) + (f32vector-set! bv 4 s3) + (f32vector-set! bv 5 t3) + (f32vector-set! bv 6 s4) + (f32vector-set! bv 7 t4))) + (with-blend-mode 'alpha + (gpu-apply shader (force vertex-array) + #:mvp (if matrix + (begin + (matrix4-mult! mvp matrix + (current-projection)) + mvp) + (current-projection)) + #:color color + #:w thickness + #:r feather + #:l length + #:cap (match cap + ('none 0) + ('butt 1) + ('square 2) + ('round 3) + ('triangle-out 4) + ('triangle-in 5)))))))) + +;; XXX: This is going to be hopelessly slow until I implement batching +;; for lines and shapes. +(define draw-bezier-curve + (let ((start #v(0.0 0.0)) + (end #v(0.0 0.0)) + (tmp #f) + (rect (make-rect 0.0 0.0 0.0 0.0))) + (lambda* (bezier #:key + (segments 32) + control-points? + tangents? + (control-point-size 8.0) + (color white) + (control-point-color yellow) + (tangent-color yellow) + (thickness 0.5) + (feather 1.0) + matrix) + "Draw the curve defined by BEZIER using a resolution of n SEGMENTS." + (define (draw-segment start end color) + (draw-line start end + #:thickness thickness + #:feather feather + #:cap 'none + #:color color)) + (define (draw-control-point p) + (let ((hs (/ control-point-size 2.0))) + (set-rect-x! rect (- (vec2-x p) hs)) + (set-rect-y! rect (- (vec2-y p) hs)) + (set-rect-width! rect control-point-size) + (set-rect-height! rect control-point-size) + (draw-filled-rect rect control-point-color #:matrix matrix))) + (bezier-curve-point-at! start bezier 0.0) + (let loop ((i 1)) + (when (<= i segments) + (bezier-curve-point-at! end bezier (exact->inexact (/ i segments))) + (draw-segment start end color) + ;; Make the previous end point is now the new start point + ;; for the next iteration. + (set! tmp start) + (set! start end) + (set! end tmp) + (loop (+ i 1)))) + (when tangents? + (draw-segment (bezier-curve-p0 bezier) + (bezier-curve-p1 bezier) + tangent-color) + (draw-segment (bezier-curve-p3 bezier) + (bezier-curve-p2 bezier) + tangent-color)) + (when control-points? + (draw-control-point (bezier-curve-p0 bezier)) + (draw-control-point (bezier-curve-p1 bezier)) + (draw-control-point (bezier-curve-p2 bezier)) + (draw-control-point (bezier-curve-p3 bezier)))))) + +(define* (draw-bezier-path path #:key + (segments 32) + control-points? + tangents? + (control-point-size 8.0) + (color white) + (control-point-color yellow) + (tangent-color yellow) + (thickness 0.5) + (feather 1.0) + matrix) + (for-each (lambda (bezier) + (draw-bezier-curve bezier + #:segments segments + #:control-points? control-points? + #:tangents? tangents? + #:control-point-size control-point-size + #:color color + #:control-point-color control-point-color + #:tangent-color tangent-color + #:thickness 0.5 + #:feather feather + #:matrix matrix)) + path)) diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm new file mode 100644 index 0000000..4a78292 --- /dev/null +++ b/chickadee/graphics/sprite.scm @@ -0,0 +1,611 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2019 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics sprite) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics shader) + #:use-module (chickadee graphics texture) + #:use-module (chickadee graphics buffer) + #:export (draw-sprite* + draw-sprite + + make-sprite-batch + sprite-batch? + sprite-batch-texture + set-sprite-batch-texture! + sprite-batch-clear! + sprite-batch-add* + sprite-batch-add! + draw-sprite-batch* + draw-sprite-batch + + with-batched-sprites + draw-nine-patch* + draw-nine-patch)) + +(define unbatched-sprite-shader + (delay + (strings->shader + " +#ifdef GLSL330 +layout (location = 0) in vec2 position; +layout (location = 1) in vec2 tex; +#elif ifdef GLSL130 +in vec2 position; +in vec2 tex; +#elif ifdef GLSL120 +attribute vec2 position; +attribute vec2 tex; +#endif +#ifdef GLSL120 +varying vec2 fragTex; +#else +out vec2 fragTex; +#endif +uniform mat4 mvp; + +void main(void) { + fragTex = tex; + gl_Position = mvp * vec4(position.xy, 0.0, 1.0); +} +" + " + +#ifdef GLSL120 +attribute vec2 fragTex; +#else +in vec2 fragTex; +#endif +#ifdef GLSL330 +out vec4 fragColor; +#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 +} +"))) + +(define draw-sprite* + (let* ((stride 16) ; 4 f32s, 2 for vertex, 2 for texcoord + (buffer (delay + (make-buffer #f + #:name "unbatched sprite buffer" + #:length (* stride 4) + #:stride stride + #:usage 'stream))) + (pos (delay + (make-buffer-view #:name "unbatched sprite vertices" + #:buffer (force buffer) + #:type 'vec2 + #:component-type 'float + #:length 4))) + (tex (delay + (make-buffer-view #:name "unbatched sprite texcoords" + #:buffer (force buffer) + #:type 'vec2 + #:component-type 'float + #:length 4 + #:offset 8))) + (indices + (delay + (make-buffer-view #:name "unbatched sprite indices" + #:type 'scalar + #:component-type 'unsigned-int + #:buffer (make-buffer (u32vector 0 3 2 0 2 1) + #:target 'index)))) + (vertex-array + (delay + (make-vertex-array #:indices (force indices) + #:attributes + `((0 . ,(force pos)) + (1 . ,(force tex)))))) + (mvp (make-null-matrix4))) + (lambda* (texture + rect + matrix + #:key + (tint white) + (blend-mode 'alpha) + (texcoords (texture-gl-tex-rect texture))) + (with-mapped-buffer-view (force pos) + (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))) + (bv (buffer-view-data (force pos)))) + ;; Texture origin is at the top-left, so we need to flip the Y + ;; coordinate relative to the vertices. + (f32vector-set! bv 0 x1) + (f32vector-set! bv 1 y1) + (f32vector-set! bv 2 s1) + (f32vector-set! bv 3 t2) + (f32vector-set! bv 4 x2) + (f32vector-set! bv 5 y1) + (f32vector-set! bv 6 s2) + (f32vector-set! bv 7 t2) + (f32vector-set! bv 8 x2) + (f32vector-set! bv 9 y2) + (f32vector-set! bv 10 s2) + (f32vector-set! bv 11 t1) + (f32vector-set! bv 12 x1) + (f32vector-set! bv 13 y2) + (f32vector-set! bv 14 s1) + (f32vector-set! bv 15 t1))) + (with-blend-mode blend-mode + (with-texture 0 texture + (gpu-apply (force unbatched-sprite-shader) (force vertex-array) + #:tint tint + #:mvp (if matrix + (begin + (matrix4-mult! mvp matrix + (current-projection)) + mvp) + (current-projection)))))))) + +(define %null-vec2 (vec2 0.0 0.0)) +(define %default-scale (vec2 1.0 1.0)) + +(define draw-sprite + (let ((matrix (make-null-matrix4))) + (lambda* (texture + position + #:key + (tint white) + (origin %null-vec2) + (scale %default-scale) + (rotation 0.0) + (blend-mode 'alpha) + (rect (texture-gl-rect texture))) + "Draw TEXTURE at POSITION. + +Optionally, other transformations may be applied to the sprite. +ROTATION specifies the angle to rotate the sprite, in radians. SCALE +specifies the scaling factor as a 2D vector. All transformations are +applied relative to ORIGIN, a 2D vector. + +TINT specifies the color to multiply against all the sprite's pixels. +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." + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (draw-sprite* texture rect matrix + #:tint tint + #:blend-mode blend-mode)))) + + +;;; +;;; Sprite Batches +;;; + +(define-record-type + (%make-sprite-batch texture size capacity vertex-buffer vertex-array) + sprite-batch? + (texture sprite-batch-texture set-sprite-batch-texture!) + (size sprite-batch-size set-sprite-batch-size!) + (capacity sprite-batch-capacity set-sprite-batch-capacity!) + (vertex-buffer sprite-batch-vertex-buffer set-sprite-batch-vertex-buffer!) + (vertex-array sprite-batch-vertex-array set-sprite-batch-vertex-array!)) + +(define (init-sprite-batch batch capacity) + (let* ((index-data (let ((bv (make-u32vector (* capacity 6)))) + (let loop ((i 0)) + (when (< i capacity) + (let ((index-offset (* i 6)) + (vertex-offset (* i 4))) + (u32vector-set! bv index-offset vertex-offset) + (u32vector-set! bv (+ index-offset 1) (+ vertex-offset 3)) + (u32vector-set! bv (+ index-offset 2) (+ vertex-offset 2)) + (u32vector-set! bv (+ index-offset 3) vertex-offset) + (u32vector-set! bv (+ index-offset 4) (+ vertex-offset 2)) + (u32vector-set! bv (+ index-offset 5) (+ vertex-offset 1)) + (loop (+ i 1))))) + bv)) + (index-buffer (make-buffer index-data + #:name "indices" + #:target 'index)) + (indices (make-buffer-view #:name "indices" + #:buffer index-buffer + #:type 'scalar + #:component-type 'unsigned-int)) + (stride 32) ; 8 f32s, 2 for vertex, 2 for texcoord, 4 for tint color + (buffer (make-buffer #f + #:name "sprite batch buffer" + #:length (* capacity stride 4) + #:stride stride + #:usage 'stream)) + (pos (make-buffer-view #:name "sprite batch vertices" + #:buffer buffer + #:type 'vec2 + #:component-type 'float + #:length (* capacity 4))) + (tex (make-buffer-view #:name "sprite batch texture coordinates" + #:buffer buffer + #:type 'vec2 + #:component-type 'float + #:length (* capacity 4) + #:offset 8)) + (tint (make-buffer-view #:name "sprite batch tint colors" + #:buffer buffer + #:type 'vec4 + #:component-type 'float + #:length (* capacity 4) + #:offset 16)) + (va (make-vertex-array #:indices indices + #:attributes `((0 . ,pos) + (1 . ,tex) + (2 . ,tint))))) + (set-sprite-batch-capacity! batch capacity) + (set-sprite-batch-vertex-buffer! batch buffer) + (set-sprite-batch-vertex-array! batch va))) + +(define* (make-sprite-batch texture #:key (capacity 256)) + "Make a sprite batch that can hold CAPACITY sprites." + (let ((batch (%make-sprite-batch texture 0 0 #f #f))) + (init-sprite-batch batch capacity) + batch)) + +(define (sprite-batch-full? batch) + (= (sprite-batch-capacity batch) (sprite-batch-size batch))) + +(define (double-sprite-batch-size! batch) + (let* ((old-verts (sprite-batch-vertex-buffer batch)) + (old-vertex-data (buffer-data old-verts))) + (unmap-buffer! old-verts) + (init-sprite-batch batch (* (sprite-batch-capacity batch) 2)) + (let ((new-verts (sprite-batch-vertex-buffer batch))) + (map-buffer! new-verts 'write-only) + (bytevector-copy! old-vertex-data 0 + (buffer-data new-verts) 0 + (bytevector-length old-vertex-data))))) + +(define (sprite-batch-clear! batch) + "Reset BATCH to size 0." + (set-sprite-batch-size! batch 0)) + +(define (sprite-batch-flush! batch) + "Submit the contents of BATCH to the GPU." + (unmap-buffer! (sprite-batch-vertex-buffer batch))) + +(define* (sprite-batch-add* batch rect matrix + #:key + (tint white) + texture-region) + "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." + ;; Expand the buffers when necessary. + (when (sprite-batch-full? batch) + (double-sprite-batch-size! batch)) + (map-buffer! (sprite-batch-vertex-buffer batch) 'write-only) + (let* ((size (sprite-batch-size batch)) + (vertices (buffer-data (sprite-batch-vertex-buffer batch))) + (offset (* size 32)) ; each sprite is 32 floats in size + (minx (rect-x rect)) + (miny (rect-y rect)) + (maxx (+ minx (rect-width rect))) + (maxy (+ miny (rect-height rect))) + (x1 (transform-x matrix minx miny)) + (y1 (transform-y matrix minx miny)) + (x2 (transform-x matrix maxx miny)) + (y2 (transform-y matrix maxx miny)) + (x3 (transform-x matrix maxx maxy)) + (y3 (transform-y matrix maxx maxy)) + (x4 (transform-x matrix minx maxy)) + (y4 (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)))) + ;; Add vertices. + ;; Bottom-left + (f32vector-set! vertices offset x1) + (f32vector-set! vertices (+ offset 1) y1) + ;; Bottom-right + (f32vector-set! vertices (+ offset 8) x2) + (f32vector-set! vertices (+ offset 9) y2) + ;; Top-right + (f32vector-set! vertices (+ offset 16) x3) + (f32vector-set! vertices (+ offset 17) y3) + ;; Top-left + (f32vector-set! vertices (+ offset 24) x4) + (f32vector-set! vertices (+ offset 25) y4) + ;; Add texture coordinates. + ;; Bottom-left + (f32vector-set! vertices (+ offset 2) s1) + (f32vector-set! vertices (+ offset 3) t2) + ;; Bottom-right + (f32vector-set! vertices (+ offset 10) s2) + (f32vector-set! vertices (+ offset 11) t2) + ;; Top-right + (f32vector-set! vertices (+ offset 18) s2) + (f32vector-set! vertices (+ offset 19) t1) + ;; Top-left + (f32vector-set! vertices (+ offset 26) s1) + (f32vector-set! vertices (+ offset 27) t1) + ;; Add tint. + (let ((bv ((@@ (chickadee graphics color) unwrap-color) tint)) + (byte-offset (* offset 4))) + (bytevector-copy! bv 0 vertices (+ byte-offset 16) 16) + (bytevector-copy! bv 0 vertices (+ byte-offset 48) 16) + (bytevector-copy! bv 0 vertices (+ byte-offset 80) 16) + (bytevector-copy! bv 0 vertices (+ byte-offset 112) 16)) + (set-sprite-batch-size! batch (1+ size)))) + +(define sprite-batch-add! + (let ((matrix (make-null-matrix4))) + (lambda* (batch + position + #:key + (origin %null-vec2) + (scale %default-scale) + (rotation 0.0) + (tint white) + texture-region) + "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 ((rect (texture-gl-rect + (or texture-region (sprite-batch-texture batch))))) + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (sprite-batch-add* batch rect matrix + #:tint tint + #:texture-region texture-region))))) + + +(define batched-sprite-shader + (delay + (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 vec2 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 +attribute vec2 fragTex; +attribute 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 draw-sprite-batch* + (let ((mvp (make-null-matrix4))) + (lambda* (batch matrix #:key (blend-mode 'alpha)) + "Render the contents of BATCH." + (sprite-batch-flush! batch) + (matrix4-mult! mvp matrix (current-projection)) + (with-blend-mode blend-mode + (with-texture 0 (sprite-batch-texture batch) + (gpu-apply* (force batched-sprite-shader) + (sprite-batch-vertex-array batch) + (* (sprite-batch-size batch) 6) + #:mvp mvp)))))) + +(define draw-sprite-batch + (let ((matrix (make-null-matrix4))) + (lambda* (batch + #:key + (position %null-vec2) + (origin %null-vec2) + (scale %default-scale) + (rotation 0.0) + (blend-mode 'alpha)) + "Render the contents of BATCH." + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (draw-sprite-batch* batch matrix #:blend-mode blend-mode)))) + + +;;; +;;; Nine Patches +;;; + +(define draw-nine-patch* + (let ((%rect (make-rect 0.0 0.0 0.0 0.0)) + (texcoords (make-rect 0.0 0.0 0.0 0.0))) + (lambda* (texture + rect + matrix + #:key + (margin 0.0) + (top-margin margin) + (bottom-margin margin) + (left-margin margin) + (right-margin margin) + (blend-mode 'alpha) + (tint white)) + (let* ((x (rect-x rect)) + (y (rect-y rect)) + (w (rect-width rect)) + (h (rect-height rect)) + (border-x1 x) + (border-y1 y) + (border-x2 (+ x w)) + (border-y2 (+ y h)) + (fill-x1 (+ border-x1 left-margin)) + (fill-y1 (+ border-y1 bottom-margin)) + (fill-x2 (- border-x2 right-margin)) + (fill-y2 (- border-y2 top-margin)) + (prect (texture-gl-rect texture)) + (trect (texture-gl-tex-rect texture)) + (tw (rect-width prect)) + (th (rect-height prect)) + (border-s1 (rect-x trect)) + (border-t1 (rect-y trect)) + (border-s2 (+ (rect-x trect) (rect-width trect))) + (border-t2 (+ (rect-y trect) (rect-height trect))) + (fill-s1 (+ border-s1 (/ left-margin tw))) + (fill-t1 (+ border-t1 (/ top-margin th))) + (fill-s2 (- border-s2 (/ right-margin tw))) + (fill-t2 (- border-t2 (/ bottom-margin th)))) + (define (draw-piece x1 y1 x2 y2 s1 t1 s2 t2) + (set-rect-x! %rect x1) + (set-rect-y! %rect y1) + (set-rect-width! %rect (- x2 x1)) + (set-rect-height! %rect (- y2 y1)) + (set-rect-x! texcoords s1) + (set-rect-y! texcoords t1) + (set-rect-width! texcoords (- s2 s1)) + (set-rect-height! texcoords (- t2 t1)) + (draw-sprite* texture %rect matrix + #:texcoords texcoords + #:blend-mode blend-mode + #:tint tint)) + ;; bottom-left + (draw-piece border-x1 border-y1 fill-x1 fill-y1 + border-s1 fill-t2 fill-s1 border-t2) + ;; bottom-center + (draw-piece fill-x1 border-y1 fill-x2 fill-y1 + fill-s1 fill-t2 fill-s2 border-t2) + ;; bottom-right + (draw-piece fill-x2 border-y1 border-x2 fill-y1 + fill-s2 fill-t2 border-s2 border-t2) + ;; center-left + (draw-piece border-x1 fill-y1 fill-x1 fill-y2 + border-s1 fill-t2 fill-s1 fill-t1) + ;; center + (draw-piece fill-x1 fill-y1 fill-x2 fill-y2 + fill-s1 fill-t2 fill-s2 fill-t1) + ;; center-right + (draw-piece fill-x2 fill-y1 border-x2 fill-y2 + fill-s2 fill-t2 border-s2 fill-t1) + ;; top-left + (draw-piece border-x1 fill-y2 fill-x1 border-y2 + border-s1 border-t1 fill-s1 fill-t1) + ;; top-center + (draw-piece fill-x1 fill-y2 fill-x2 border-y2 + fill-s1 border-t1 fill-s2 fill-t1) + ;; top-right + (draw-piece fill-x2 fill-y2 border-x2 border-y2 + fill-s2 border-t1 border-s2 fill-t1))))) + +(define draw-nine-patch + (let ((position (vec2 0.0 0.0)) + (%rect (make-rect 0.0 0.0 0.0 0.0)) + (matrix (make-null-matrix4))) + (lambda* (texture + rect + #:key + (margin 0.0) + (top-margin margin) (bottom-margin margin) + (left-margin margin) (right-margin margin) + (origin %null-vec2) + (rotation 0.0) + (scale %default-scale) + (blend-mode 'alpha) + (tint white)) + "Draw a \"nine patch\" sprite. A nine patch sprite renders +TEXTURE on the rectangular area RECT whose stretchable areas are +defined by the given margin measurements. The corners are never +stretched, the left and right edges may be stretched vertically, the +top and bottom edges may be stretched horizontally, and the center may +be stretched in both directions. This rendering technique is +particularly well suited for resizable windows and buttons in +graphical user interfaces. + +MARGIN specifies the margin size for all sides of the nine patch. To +make margins of differing sizes, the TOP-MARGIN, BOTTOM-MARGIN, +LEFT-MARGIN, and RIGHT-MARGIN arguments may be used." + (set-rect-x! %rect 0.0) + (set-rect-y! %rect 0.0) + (set-rect-width! %rect (rect-width rect)) + (set-rect-height! %rect (rect-height rect)) + (set-vec2-x! position (rect-x rect)) + (set-vec2-y! position (rect-y rect)) + (matrix4-2d-transform! matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (draw-nine-patch* texture %rect matrix + #:top-margin top-margin + #:bottom-margin bottom-margin + #:left-margin left-margin + #:right-margin right-margin + #:blend-mode blend-mode + #:tint tint)))) diff --git a/chickadee/graphics/stencil.scm b/chickadee/graphics/stencil.scm new file mode 100644 index 0000000..b17bf21 --- /dev/null +++ b/chickadee/graphics/stencil.scm @@ -0,0 +1,137 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2020 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics stencil) + #:use-module (ice-9 match) + #:use-module (gl) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:use-module (srfi srfi-9) + #:export (make-stencil-test + stencil-test? + stencil-test-mask-front + stencil-test-mask-back + stencil-test-function-front + stencil-test-function-back + stencil-test-function-mask-front + stencil-test-function-mask-back + stencil-test-reference-front + stencil-test-reference-back + stencil-test-on-fail-front + stencil-test-on-fail-back + stencil-test-on-depth-fail-front + stencil-test-on-depth-fail-back + stencil-test-on-pass-front + stencil-test-on-pass-back + default-stencil-test + apply-stencil-test)) + +(define-record-type + (%make-stencil-test mask-front mask-back function-front function-back + function-mask-front function-mask-back + reference-front reference-back + on-fail-front on-fail-back + on-depth-fail-front on-depth-fail-back + on-pass-front on-pass-back) + stencil-test? + (mask-front stencil-test-mask-front) + (mask-back stencil-test-mask-back) + (function-front stencil-test-function-front) + (function-back stencil-test-function-back) + (function-mask-front stencil-test-function-mask-front) + (function-mask-back stencil-test-function-mask-back) + (reference-front stencil-test-reference-front) + (reference-back stencil-test-reference-back) + (on-fail-front stencil-test-on-fail-front) + (on-fail-back stencil-test-on-fail-back) + (on-depth-fail-front stencil-test-on-depth-fail-front) + (on-depth-fail-back stencil-test-on-depth-fail-back) + (on-pass-front stencil-test-on-pass-front) + (on-pass-back stencil-test-on-pass-back)) + +(define* (make-stencil-test #:key (mask #xFF) (function 'always) + (function-mask #xFF) (reference 0) + (on-fail 'keep) (on-depth-fail 'keep) (on-pass 'keep) + (mask-front mask) (mask-back mask) + (function-front function) (function-back function) + (function-mask-front function-mask) + (function-mask-back function-mask) + (reference-front reference) + (reference-back reference) + (on-fail-front on-fail) (on-fail-back on-fail) + (on-depth-fail-front on-depth-fail) + (on-depth-fail-back on-depth-fail) + (on-pass-front on-pass) (on-pass-back on-pass)) + (%make-stencil-test mask-front mask-back function-front function-back + function-mask-front function-mask-back + reference-front reference-back + on-fail-front on-fail-back + on-depth-fail-front on-depth-fail-back + on-pass-front on-pass-back)) + +(define %default-stencil-test (make-stencil-test)) + +(define* (apply-stencil-test stencil) + (define (symbol->op sym) + (match sym + ('zero (stencil-op zero)) + ('keep (stencil-op keep)) + ('replace (stencil-op replace)) + ('increment (stencil-op incr)) + ('increment-wrap (version-1-4 incr-wrap)) + ('decrement (stencil-op decr)) + ('decrement-wrap (version-1-4 decr-wrap)) + ('invert (stencil-op invert)))) + (define (symbol->function sym) + (match sym + ('always (stencil-function always)) + ('never (stencil-function never)) + ('less-than (stencil-function less)) + ('equal (stencil-function equal)) + ('less-than-or-equal (stencil-function lequal)) + ('greater-than (stencil-function greater)) + ('greater-than-or-equal (stencil-function gequal)) + ('not-equal (stencil-function notequal)))) + (if stencil + (begin + (gl-enable (enable-cap stencil-test)) + ;; Mask + (gl-stencil-mask-separate (cull-face-mode front) + (stencil-test-mask-front stencil)) + (gl-stencil-mask-separate (cull-face-mode back) + (stencil-test-mask-back stencil)) + ;; Function + (gl-stencil-func-separate (cull-face-mode front) + (symbol->function + (stencil-test-function-front stencil)) + (stencil-test-reference-front stencil) + (stencil-test-function-mask-front stencil)) + (gl-stencil-func-separate (cull-face-mode back) + (symbol->function + (stencil-test-function-back stencil)) + (stencil-test-reference-back stencil) + (stencil-test-function-mask-back stencil)) + ;; Operation + (gl-stencil-op-separate (cull-face-mode front) + (symbol->op (stencil-test-on-fail-front stencil)) + (symbol->op (stencil-test-on-depth-fail-front stencil)) + (symbol->op (stencil-test-on-pass-front stencil))) + (gl-stencil-op-separate (cull-face-mode back) + (symbol->op (stencil-test-on-fail-back stencil)) + (symbol->op (stencil-test-on-depth-fail-back stencil)) + (symbol->op (stencil-test-on-pass-back stencil)))) + (gl-disable (enable-cap stencil-test)))) diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm new file mode 100644 index 0000000..397ecc4 --- /dev/null +++ b/chickadee/graphics/texture.scm @@ -0,0 +1,329 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +(define-module (chickadee graphics texture) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (system foreign) + #:use-module (gl) + #:use-module (gl enums) + #:use-module ((sdl2 surface) #:prefix sdl2:) + #:use-module (oop goops) + #:use-module (chickadee math rect) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics gl) + #:use-module (chickadee graphics gpu) + #:export (make-texture + make-texture-region + load-image + texture? + texture-region? + texture-null? + texture-parent + texture-min-filter + texture-mag-filter + texture-wrap-s + texture-wrap-t + texture-x + texture-y + texture-width + texture-height + texture-gl-rect + texture-gl-tex-rect + null-texture + apply-texture + + texture-atlas + list->texture-atlas + split-texture + texture-atlas? + texture-atlas-texture + texture-atlas-ref)) + + +;;; +;;; Textures +;;; + +;; The object is a simple wrapper around an OpenGL texture +;; id. +(define-record-type + (%make-texture id parent min-filter mag-filter wrap-s wrap-t + x y width height gl-rect gl-tex-rect) + texture? + (id texture-id) + (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! + (lambda (texture port) + (format port + "#" + (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 #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 <> (class-of null-texture)) + +(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 (free-texture texture) + (gl-delete-texture (texture-id texture))) + +(define-method (gpu-finalize (texture <>)) + (free-texture texture)) + +(define (apply-texture n texture) + (let ((texture-unit (+ (version-1-3 texture0) n))) + (set-gl-active-texture texture-unit) + (gl-bind-texture (texture-target texture-2d) + (texture-id texture)))) + +(define* (make-texture pixels width height #:key + flip? + (min-filter 'linear) + (mag-filter 'linear) + (wrap-s 'repeat) + (wrap-t 'repeat) + (format 'rgba)) + "Translate the bytevector PIXELS into an OpenGL texture with +dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format. +The first pixe lin PIXELS corresponds to the upper-left corner of the +image. If this is not the case and the first pixel corresponds to the +lower-left corner of the image, set FLIP? to #t. 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), clamp, clamp-to-border, +clamp-to-edge. FORMAT specifies the pixel format. Currently only +32-bit RGBA format is supported." + (define (gl-wrap mode) + (match mode + ('repeat (texture-wrap-mode 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)))) + + (let ((texture (gpu-guard + (%make-texture (gl-generate-texture) #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)))))) + (set-gpu-texture! (current-gpu) 0 texture) + (gl-texture-parameter (texture-target texture-2d) + (texture-parameter-name texture-min-filter) + (match min-filter + ('nearest 9728) + ('linear 9729))) + (gl-texture-parameter (texture-target texture-2d) + (texture-parameter-name texture-mag-filter) + (match mag-filter + ('nearest 9728) + ('linear 9729))) + (gl-texture-parameter (texture-target texture-2d) + (texture-parameter-name texture-wrap-s) + (gl-wrap wrap-s)) + (gl-texture-parameter (texture-target texture-2d) + (texture-parameter-name texture-wrap-t) + (gl-wrap wrap-t)) + (gl-texture-image-2d (texture-target texture-2d) + 0 (pixel-format rgba) width height 0 + (match format + ('rgba (pixel-format rgba))) + (color-pointer-type unsigned-byte) + (or pixels %null-pointer)) + 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)))) + (%make-texture (texture-id texture) + 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))) + +(define (flip-pixels-vertically pixels width height) + "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x +HEIGHT, 32 bit color bytevector." + (let ((buffer (make-u8vector (bytevector-length pixels))) + (row-width (* width 4))) ; assuming 32 bit color + (let loop ((y 0)) + (when (< y height) + (let* ((y* (- height y 1)) + (source-start (* y row-width)) + (target-start (* y* row-width))) + (bytevector-copy! pixels source-start buffer target-start row-width) + (loop (1+ y))))) + buffer)) + +(define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color) + "Convert SURFACE, an SDL2 surface object, into a texture that uses +the given MIN-FILTER and MAG-FILTER." + ;; Convert to 32 bit RGBA color. + (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888) + (lambda (surface) + (let* ((width (sdl2:surface-width surface)) + (height (sdl2:surface-height surface)) + (pixels (sdl2:surface-pixels surface))) + ;; Zero the alpha channel of pixels that match the transparent + ;; color key. + (when transparent-color + (let ((r (inexact->exact (* (color-r transparent-color) 255))) + (g (inexact->exact (* (color-g transparent-color) 255))) + (b (inexact->exact (* (color-b transparent-color) 255))) + (pixel-count (* width height 4))) + (let loop ((i 0)) + (when (< i pixel-count) + (when (and (= r (bytevector-u8-ref pixels i)) + (= g (bytevector-u8-ref pixels (+ i 1))) + (= b (bytevector-u8-ref pixels (+ i 2)))) + (bytevector-u8-set! pixels (+ i 3) 0)) + (loop (+ i 4)))))) + (make-texture pixels width height + #:min-filter min-filter + #:mag-filter mag-filter + #:wrap-s wrap-s + #:wrap-t wrap-t))))) + +(define* (load-image file #:key + (min-filter 'nearest) + (mag-filter 'nearest) + (wrap-s 'repeat) + (wrap-t 'repeat) + transparent-color) + "Load a texture from an image in FILE. 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." + (sdl2:call-with-surface ((@ (sdl2 image) load-image) file) + (lambda (surface) + (surface->texture surface min-filter mag-filter wrap-s wrap-t + transparent-color)))) + + +;;; +;;; Texture Atlas +;;; + +(define-record-type + (%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 atlas) + (vector-length (texture-atlas-vector atlas)))) + +(set-record-type-printer! 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-ref atlas index) + "Return the texture region associated with INDEX in +ATLAS." + (vector-ref (texture-atlas-vector atlas) index)) + +(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." + (let* ((w (texture-width texture)) + (h (texture-height texture)) + (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing))))) + (columns (inexact->exact (ceiling (/ (- w margin) (+ tile-width spacing))))) + (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)))) + (let y-loop ((y 0)) + (when (< y rows) + (let x-loop ((x 0)) + (when (< x columns) + (vector-set! v (+ x (* y columns)) (make-tile x y)) + (x-loop (1+ x)))) + (y-loop (1+ y)))) + (%make-texture-atlas texture v))) diff --git a/chickadee/graphics/tiled.scm b/chickadee/graphics/tiled.scm new file mode 100644 index 0000000..4f79a63 --- /dev/null +++ b/chickadee/graphics/tiled.scm @@ -0,0 +1,497 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2018 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Tiled map format parser and renderer. +;; +;;; Code: + +(define-module (chickadee graphics tiled) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee graphics) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics sprite) + #:use-module (chickadee graphics texture) + #:use-module (chickadee graphics viewport) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-43) + #:use-module (sxml simple) + #:use-module (sxml xpath) + #:export (tile-map? + tile-map-orientation + tile-map-width + tile-map-height + tile-map-tile-width + tile-map-tile-height + tile-map-tilesets + tile-map-layers + tile-map-properties + tile-map-rect + tile-map-layer-ref + point->tile + + animation-frame? + animation-frame-tile + animation-frame-duration + + tile? + tile-id + tile-animation + tile-properties + + tileset? + tileset-name + tileset-first-gid + tileset-size + tileset-tile-width + tileset-tile-height + tileset-atlas + tileset-tiles + tileset-properties + + map-tile? + map-tile-ref + map-tile-rect + + tile-layer? + tile-layer-name + tile-layer-width + tile-layer-height + tile-layer-tiles + tile-layer-properties + + object-layer? + object-layer-name + object-layer-objects + object-layer-properties + + polygon? + polygon-points + + map-object? + map-object-id + map-object-name + map-object-type + map-object-shape + map-object-properties + + load-tile-map + draw-tile-map + draw-tile-map*)) + +(define-record-type + (%make-tile-map orientation width height tile-width tile-height + tilesets layers properties rect) + tile-map? + (orientation tile-map-orientation) + (width tile-map-width) + (height tile-map-height) + (tile-width tile-map-tile-width) + (tile-height tile-map-tile-height) + (tilesets tile-map-tilesets) + (layers tile-map-layers) + (properties tile-map-properties) + (rect tile-map-rect)) + +(define-record-type + (%make-animation-frame tile duration) + animation-frame? + (tile animation-frame-tile) + (duration animation-frame-duration)) + +(define-record-type + (%make-tile id texture batch animation properties) + tile? + (id tile-id) + (texture tile-texture) + (batch tile-batch) + (animation tile-animation) + (properties tile-properties)) + +(define-record-type + (%make-tileset name first-gid size tile-width tile-height + atlas tiles properties batch) + tileset? + (name tileset-name) + (first-gid tileset-first-gid) + (size tileset-size) + (tile-width tileset-tile-width) + (tile-height tileset-tile-height) + (atlas tileset-atlas) + (tiles tileset-tiles) + (properties tileset-properties) + (batch tileset-batch)) + +(define-record-type + (%make-map-tile tile rect) + map-tile? + (tile map-tile-ref) + (rect map-tile-rect)) + +(define-record-type + (%make-tile-layer name width height tiles properties) + tile-layer? + (name tile-layer-name) + (width tile-layer-width) + (height tile-layer-height) + (tiles tile-layer-tiles) + (properties tile-layer-properties)) + +(define-record-type + (%make-object-layer name objects properties) + object-layer? + (name object-layer-name) + (objects object-layer-objects) + (properties object-layer-properties)) + +;; TODO: This should probably be a generic thing that we can use +;; outside of tiled maps. +(define-record-type + (make-polygon points) + polygon? + (points polygon-points)) + +(define-record-type + (%make-map-object id name type shape properties) + map-object? + (id map-object-id) + (name map-object-name) + (type map-object-type) + (shape map-object-shape) + (properties map-object-properties)) + +(define (tile-map-layer-ref tile-map name) + "Return the layer named NAME." + (define (layer-name layer) + (if (tile-layer? layer) + (tile-layer-name layer) + (object-layer-name layer))) + (let ((layers (tile-map-layers tile-map))) + (let loop ((i 0)) + (cond + ((= i (vector-length layers)) + #f) + ((string=? name (layer-name (vector-ref layers i))) + (vector-ref layers i)) + (else + (loop (+ i 1))))))) + +(define (point->tile tile-map x y) + "Translate the pixel coordinates (X, Y) into tile coordinates." + (values (floor (/ x (tile-map-tile-width tile-map))) + (floor (/ y (tile-map-tile-height tile-map))))) + +(define (load-tile-map file-name) + "Load the Tiled TMX formatted map in FILE-NAME." + (define map-directory + (if (absolute-file-name? file-name) + (dirname file-name) + (string-append (getcwd) "/" (dirname file-name)))) + (define (scope file-name) + (string-append map-directory "/" file-name)) + (define* (attr node name #:optional (parse identity)) + (let ((result ((sxpath `(@ ,name *text*)) node))) + (if (null? result) + #f + (parse (car result))))) + (define (parse-color-channel s start) + (/ (string->number (substring s start (+ start 2)) 16) 255.0)) + (define (parse-property node) + (let ((name (attr node 'name string->symbol)) + (type (or (attr node 'type string->symbol) 'string)) + (value (attr node 'value))) + (cons name + (match type + ((or 'string 'file) value) + ('bool (not (string=? value "false"))) + ((or 'int 'float) (string->number value)) + ('color + (make-color (parse-color-channel value 3) + (parse-color-channel value 5) + (parse-color-channel value 7) + (parse-color-channel value 1))) + (_ (error "unsupported property type" type)))))) + (define (parse-image node) + (let ((source (attr node 'source)) + (trans (attr node 'trans))) + (load-image (scope source) + #:transparent-color (and trans (string->color trans))))) + (define (parse-frame node) + (let ((tile-id (attr node 'tileid string->number)) + (duration (attr node 'duration string->number))) + ;; TODO: lookup actual tile in tileset + (%make-animation-frame tile-id duration))) + (define (parse-tile node rows columns atlas batch) + (let ((id (attr node 'id string->number)) + (animation (map parse-frame ((sxpath '(animation frame)) node))) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-tile id (texture-atlas-ref atlas id) batch animation properties))) + (define (parse-tiles nodes size columns atlas batch) + (let ((table (make-hash-table)) + (tiles (make-vector size)) + (rows (/ size columns))) + (for-each (lambda (node) + (let ((tile (parse-tile node rows columns atlas batch))) + (hash-set! table (tile-id tile) tile))) + nodes) + (let loop ((i 0)) + (when (< i size) + (let ((tile + (or (hash-ref table i) + (%make-tile i (texture-atlas-ref atlas i) batch #f '())))) + (vector-set! tiles i tile)) + (loop (+ i 1)))) + tiles)) + (define (first-gid node) + (attr node 'firstgid string->number)) + (define (parse-internal-tileset node first-gid) + (let* ((name (attr node 'name)) + (tile-width (attr node 'tilewidth string->number)) + (tile-height (attr node 'tileheight string->number)) + (margin (or (attr node 'margin string->number) 0)) + (spacing (or (attr node 'spacing string->number) 0)) + (columns (attr node 'columns string->number)) + (size (attr node 'tilecount string->number)) + (texture (parse-image ((sxpath '(image)) node))) + (atlas (split-texture texture tile-width tile-height + #:margin margin #:spacing spacing)) + (batch (make-sprite-batch texture)) + (tiles (parse-tiles ((sxpath '(tile)) node) size columns atlas batch)) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-tileset name first-gid size tile-width tile-height + atlas tiles properties batch))) + (define (parse-external-tileset node) + (let* ((first-gid (attr node 'firstgid string->number)) + (source (scope (attr node 'source))) + (tree (call-with-input-file source xml->sxml))) + (parse-internal-tileset (car ((sxpath '(tileset)) tree)) first-gid))) + (define (parse-tileset node) + (if (attr node 'source) + (parse-external-tileset node) + (parse-internal-tileset node (first-gid node)))) + (define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height) + ;; The top 3 bits of the tile gid are flags for various types of + ;; flipping. + ;; + ;; TODO: Respect the flipping settings. + (let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0)) + (flipped-vertically? (> (logand raw-gid #x40000000) 0)) + (flipped-diagonally? (> (logand raw-gid #x20000000) 0)) + ;; Remove the upper 3 bits to get the true tile id. + (gid (logand raw-gid #x1FFFFFFF)) + (tileset (find (lambda (t) + (and (>= gid (tileset-first-gid t)) + (< gid (+ (tileset-first-gid t) + (tileset-size t))))) + tilesets)) + (tw (tileset-tile-width tileset)) + (th (tileset-tile-height tileset))) + (%make-map-tile (vector-ref (tileset-tiles tileset) + (- gid (tileset-first-gid tileset))) + (make-rect (* x tw) (* y th) tw th)))) + (define (tile-gids->map-tiles gids width height tilesets) + (let ((tiles (make-vector (* width height)))) + (let y-loop ((y 0) + (rows (reverse gids))) ; invert y + (when (< y height) + (match rows + ((row . rest) + (let x-loop ((x 0) + (columns row)) + (when (< x width) + (match columns + ((gid . rest) + (vector-set! tiles + (+ (* width y) x) + (if (zero? gid) + #f + (tile-gid->map-tile gid tilesets + x y width height))) + (x-loop (+ x 1) rest))))) + (y-loop (+ y 1) rest))))) + tiles)) + (define (parse-csv lines width height tilesets) + (let ((gids (map (lambda (line) + (filter-map (lambda (s) + (and (not (string-null? s)) + (string->number s))) + (string-split line #\,))) + (take (drop (string-split lines #\newline) 1) height)))) + (tile-gids->map-tiles gids width height tilesets))) + (define (parse-layer-data node width height tilesets) + (let ((encoding (attr node 'encoding string->symbol)) + (data (car ((sxpath '(*text*)) node)))) + (match encoding + ('csv (parse-csv data width height tilesets)) + (_ (error "unsupported tile layer encoding" encoding))))) + (define (parse-tile-layer node tilesets) + (let* ((name (attr node 'name)) + (width (attr node 'width string->number)) + (height (attr node 'height string->number)) + (tiles (parse-layer-data ((sxpath '(data)) node) + width height tilesets)) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-tile-layer name width height tiles properties))) + (define (parse-polygon node pixel-height) + (make-polygon + (list->vector + (map (lambda (s) + (match (string-split s #\,) + ((x y) + (vec2 (string->number x) + (- pixel-height (string->number y)))))) + (string-split (attr node 'points) #\space))))) + (define (parse-object node pixel-height) + (let* ((id (attr node 'id string->number)) + (name (attr node 'name)) + (type (attr node 'type string->symbol)) + (x (attr node 'x string->number)) + (y (- pixel-height (attr node 'y string->number))) + (width (attr node 'width string->number)) + (height (attr node 'height string->number)) + (shape (if (and width height) + (make-rect x y width height) + (parse-polygon (car ((sxpath '(polygon)) node)) + pixel-height))) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-map-object id name type shape properties))) + (define (parse-object-layer node pixel-height) + (let ((name (attr node 'name)) + (objects (map (lambda (node) + (parse-object node pixel-height)) + ((sxpath '(object)) node))) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-object-layer name objects properties))) + (let* ((tree (call-with-input-file file-name xml->sxml)) + (m ((sxpath '(map)) tree)) + (version (let ((version (attr m 'version))) + (unless (any (lambda (v) (string=? version v)) '("1.0" "1.1" "1.2")) + (error "unsupported tiled map format version" version)) + version)) + (orientation (attr m 'orientation string->symbol)) + (width (attr m 'width string->number)) + (height (attr m 'height string->number)) + (tile-width (attr m 'tilewidth string->number)) + (tile-height (attr m 'tileheight string->number)) + (properties ((sxpath '(map properties property)) tree)) + (tilesets (map parse-tileset ((sxpath '(map tileset)) tree))) + (layers ((node-or (sxpath '(map layer)) + (sxpath '(map objectgroup))) + tree))) + (%make-tile-map orientation width height tile-width tile-height + tilesets + (list->vector + (map (lambda (node) + (match node + (('layer . _) + (parse-tile-layer node tilesets)) + (('objectgroup . _) + (parse-object-layer node (* height tile-height))))) + layers)) + (map parse-property properties) + (make-rect 0.0 + 0.0 + (* width tile-width) + (* height tile-height))))) + + +(define (draw-tile-layer layer matrix x1 y1 x2 y2) + (let ((width (tile-layer-width layer)) + (height (tile-layer-height layer))) + (let y-loop ((y y1)) + (when (< y y2) + (let x-loop ((x x1)) + (when (< x x2) + (let ((tile (vector-ref (tile-layer-tiles layer) + (+ (* y width) x)))) + (when tile + (let ((tref (map-tile-ref tile))) + (sprite-batch-add* (tile-batch tref) + (map-tile-rect tile) + matrix + #:texture-region (tile-texture tref))))) + (x-loop (+ x 1)))) + (y-loop (+ y 1)))))) + +(define* (draw-tile-map* tile-map matrix region #:key layers) + ;; Calculate the tiles that are visible so we don't waste time + ;; drawing unnecessary sprites. + (let* ((w (tile-map-width tile-map)) + (h (tile-map-height tile-map)) + (tw (tile-map-tile-width tile-map)) + (th (tile-map-tile-height tile-map)) + (rx (rect-x region)) + (ry (rect-y region)) + (rw (rect-width region)) + (rh (rect-height region)) + (x1 (max (inexact->exact (floor (/ rx tw))) 0)) + (y1 (max (inexact->exact (floor (/ ry th))) 0)) + (x2 (min (inexact->exact (ceiling (/ (+ rx rw) tw))) w)) + (y2 (min (inexact->exact (ceiling (/ (+ ry rh) th))) h))) + (vector-for-each (lambda (i layer) + (when (and (tile-layer? layer) + (or (not layers) + (memv i layers))) + (for-each (lambda (tileset) + (sprite-batch-clear! (tileset-batch tileset))) + (tile-map-tilesets tile-map)) + (draw-tile-layer layer matrix x1 y1 x2 y2) + (for-each (lambda (tileset) + (draw-sprite-batch (tileset-batch tileset))) + (tile-map-tilesets tile-map)))) + (tile-map-layers tile-map)))) + +(define %null-vec2 (vec2 0.0 0.0)) +(define %default-scale (vec2 1.0 1.0)) +(define %matrix (make-null-matrix4)) +(define %region (make-rect 0.0 0.0 0.0 0.0)) + +;; Make a default region that is as big as the viewport. +(define (default-region tile-map position) + (let ((vp (current-viewport))) + (set-rect-x! %region (- (vec2-x position))) + (set-rect-y! %region (- (vec2-y position))) + (set-rect-width! %region (viewport-width vp)) + (set-rect-height! %region (viewport-height vp)) + %region)) + +(define* (draw-tile-map tile-map + #:key + layers + (position %null-vec2) + (region (default-region tile-map position)) + (origin %null-vec2) + (scale %default-scale) + (rotation 0.0)) + "Draw TILE-MAP. By default, all layers are drawn. The LAYERS +argument may be used to specify a list of layers to draw, instead." + (matrix4-2d-transform! %matrix + #:origin origin + #:position position + #:rotation rotation + #:scale scale) + (draw-tile-map* tile-map %matrix region #:layers layers)) diff --git a/chickadee/graphics/viewport.scm b/chickadee/graphics/viewport.scm new file mode 100644 index 0000000..5fd2e9b --- /dev/null +++ b/chickadee/graphics/viewport.scm @@ -0,0 +1,111 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2017 David Thompson +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Viewports specify the renderable section of a window. +;; +;;; 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 gl) + #:use-module (chickadee graphics gpu) + #:export (make-viewport + viewport? + viewport-x + viewport-y + viewport-width + viewport-height + viewport-clear-color + viewport-clear-flags + null-viewport + apply-viewport + clear-viewport + %default-clear-flags + %default-clear-color)) + +(define-record-type + (%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 viewport) + (gl-clear (clear-buffer-mask (viewport-clear-flags 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))))) diff --git a/chickadee/render.scm b/chickadee/render.scm deleted file mode 100644 index 23dc6d2..0000000 --- a/chickadee/render.scm +++ /dev/null @@ -1,201 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; High-level rendering API. -;; -;;; Code: - -(define-module (chickadee render) - #:use-module (chickadee math matrix) - #:use-module (chickadee render gpu) - #:use-module (chickadee render blend) - #:use-module (chickadee render framebuffer) - #:use-module (chickadee render shader) - #:use-module (chickadee render texture) - #:use-module (chickadee render buffer) - #:use-module (chickadee render viewport) - #:use-module (srfi srfi-9) - #:export (current-viewport - current-framebuffer - current-blend-mode - current-depth-test - current-stencil-test - current-texture - current-projection - with-viewport - with-framebuffer - with-blend-mode - with-depth-test - with-stencil-test - with-texture - with-projection - clear-screen - gpu-apply - gpu-apply* - gpu-apply/instanced* - gpu-apply/instanced)) - -(define-record-type - (make-render-context viewport framebuffer blend-mode depth-test - stencil-test projection textures) - render-context? - (viewport render-context-viewport set-render-context-viewport!) - (framebuffer render-context-framebuffer set-render-context-framebuffer!) - (blend-mode render-context-blend-mode set-render-context-blend-mode!) - (depth-test render-context-depth-test set-render-context-depth-test!) - (stencil-test render-context-stencil-test set-render-context-stencil-test!) - (projection render-context-projection set-render-context-projection!) - (textures render-context-textures)) - -(define render-context - (make-render-context null-viewport - null-framebuffer - 'replace - #f - #f - (make-identity-matrix4) - (make-vector 32 null-texture))) - -(define (current-viewport) - (render-context-viewport render-context)) - -(define (current-framebuffer) - (render-context-framebuffer render-context)) - -(define (current-blend-mode) - (render-context-blend-mode render-context)) - -(define (current-depth-test) - (render-context-depth-test render-context)) - -(define (current-stencil-test) - (render-context-stencil-test render-context)) - -(define (current-texture i) - (vector-ref (render-context-textures render-context) i)) - -(define (current-projection) - (render-context-projection render-context)) - -(define-syntax-rule (with (getter setter value) body ...) - (let ((prev (getter render-context))) - (setter render-context value) - body ... - (setter render-context prev))) - -(define-syntax-rule (with-viewport viewport body ...) - (with (render-context-viewport set-render-context-viewport! viewport) - body ...)) - -(define (clear-screen) - (let ((viewport (current-viewport))) - (set-gpu-framebuffer! (current-gpu) (current-framebuffer)) - (set-gpu-viewport! (current-gpu) viewport) - (clear-viewport viewport))) - -(define-syntax-rule (with-framebuffer framebuffer body ...) - (with (render-context-framebuffer set-render-context-framebuffer! framebuffer) - ;; As a convenience, initialize the viewport and projection - ;; matrix as well so that the user doesn't have to explicitly - ;; make a viewport and/or projection matrix unless they - ;; actually want to do fancy viewport manipulations. - (with-viewport (framebuffer-viewport framebuffer) - (with-projection (framebuffer-projection framebuffer) - body ...)))) - -(define-syntax-rule (with-blend-mode blend-mode body ...) - (with (render-context-blend-mode set-render-context-blend-mode! blend-mode) - body ...)) - -(define-syntax-rule (with-depth-test depth-test body ...) - (with (render-context-depth-test set-render-context-depth-test! depth-test) - body ...)) - -(define-syntax-rule (with-stencil-test stencil-test body ...) - (with (render-context-stencil-test set-render-context-stencil-test! stencil-test) - body ...)) - -(define-syntax-rule (with-texture n texture body ...) - (let* ((textures (render-context-textures render-context)) - (prev (vector-ref textures n))) - (dynamic-wind - (lambda () (vector-set! textures n texture)) - (lambda () body ...) - (lambda () (vector-set! textures n prev))))) - -(define-syntax-rule (with-projection matrix body ...) - (with (render-context-projection set-render-context-projection! matrix) - body ...)) - -(define (keyword->string kw) - (symbol->string (keyword->symbol kw))) - -(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 (gpu-prepare shader vertex-array uniforms) - (let ((gpu (current-gpu))) - ;; It's important that the framebuffer is set before setting the - ;; viewport because applying a new viewport will clear the current - ;; framebuffer. - (set-gpu-framebuffer! gpu (current-framebuffer)) - (set-gpu-viewport! gpu (current-viewport)) - (set-gpu-blend-mode! gpu (current-blend-mode)) - (set-gpu-depth-test! gpu (current-depth-test)) - (set-gpu-stencil-test! gpu (current-stencil-test)) - (set-gpu-shader! gpu shader) - (let loop ((i 0)) - (when (< i 32) - (set-gpu-texture! gpu i (current-texture i)) - (loop (1+ i)))) - (uniform-apply shader uniforms) - ;; Sampler2D values aren't explicitly passed as uniform values via - ;; gpu-apply, so we have to bind them to the proper texture units - ;; behind the scenes. - (shader-uniform-for-each - (lambda (uniform) - (when (eq? (uniform-type uniform) sampler-2d) - (set-uniform-value! shader uniform (uniform-value uniform)))) - shader))) - -(define-syntax-rule (gpu-apply* shader vertex-array count . uniforms) - (begin - (gpu-prepare shader vertex-array uniforms) - (render-vertices vertex-array count))) - -(define-syntax-rule (gpu-apply shader vertex-array uniforms ...) - (gpu-apply* shader vertex-array #f uniforms ...)) - -(define-syntax-rule (gpu-apply/instanced* shader vertex-array count instances . - uniforms) - (begin - (gpu-prepare shader vertex-array uniforms) - (render-vertices/instanced vertex-array instances count))) - -(define-syntax-rule (gpu-apply/instanced shader vertex-array instances - uniforms ...) - (gpu-apply/instanced* shader vertex-array #f instances uniforms ...)) diff --git a/chickadee/render/blend.scm b/chickadee/render/blend.scm deleted file mode 100644 index 1c0b215..0000000 --- a/chickadee/render/blend.scm +++ /dev/null @@ -1,63 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render blend) - #:use-module (ice-9 match) - #:use-module (gl) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:export (apply-blend-mode)) - -(define (apply-blend-mode blend-mode) - (if blend-mode - (begin - (gl-enable (enable-cap blend)) - (match blend-mode - ('alpha - (gl-blend-equation (blend-equation-mode-ext func-add-ext)) - (gl-blend-func (blending-factor-src src-alpha) - (blending-factor-dest one-minus-src-alpha))) - ('multiply - (gl-blend-equation (blend-equation-mode-ext func-add-ext)) - (gl-blend-func (blending-factor-src dst-color) - (blending-factor-dest zero))) - ('subtract - (gl-blend-equation - (blend-equation-mode-ext func-reverse-subtract-ext)) - (gl-blend-func (blending-factor-src one) - (blending-factor-dest zero))) - ('add - (gl-blend-equation (blend-equation-mode-ext func-add-ext)) - (gl-blend-func (blending-factor-src one) - (blending-factor-dest one))) - ('lighten - (gl-blend-equation (blend-equation-mode-ext max-ext)) - (gl-blend-func (blending-factor-src one) - (blending-factor-dest zero))) - ('darken - (gl-blend-equation (blend-equation-mode-ext min-ext)) - (gl-blend-func (blending-factor-src one) - (blending-factor-dest zero))) - ('screen - (gl-blend-equation (blend-equation-mode-ext func-add-ext)) - (gl-blend-func (blending-factor-src one) - (blending-factor-dest one-minus-src-color))) - ('replace - (gl-blend-equation (blend-equation-mode-ext func-add-ext)) - (gl-blend-func (blending-factor-src one) - (blending-factor-dest zero))))) - (gl-disable (enable-cap blend)))) diff --git a/chickadee/render/buffer.scm b/chickadee/render/buffer.scm deleted file mode 100644 index fc66dad..0000000 --- a/chickadee/render/buffer.scm +++ /dev/null @@ -1,605 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2017, 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; GPU data buffers. -;; -;;; Code: - -(define-module (chickadee render buffer) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (oop goops) - #:use-module (rnrs bytevectors) - #: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 render gl) - #:use-module (chickadee render gpu) - #:export (make-buffer - make-streaming-buffer - buffer? - index-buffer? - buffer-mapped? - buffer-name - buffer-length - buffer-stride - buffer-target - buffer-usage - buffer-data - null-buffer - apply-buffer - map-buffer! - unmap-buffer! - with-mapped-buffer - make-buffer-view - make-streaming-buffer-view - buffer-view? - buffer-view->buffer - buffer-view->vector - buffer-view-name - buffer-view-offset - buffer-view-component-type - buffer-view-normalized? - buffer-view-count - buffer-view-type - buffer-view-max - buffer-view-min - buffer-view-sparse - buffer-view-data - buffer-view-divisor - map-buffer-view! - unmap-buffer-view! - with-mapped-buffer-view - make-vertex-array - apply-vertex-array - vertex-array? - vertex-array-indices - vertex-array-attributes - vertex-array-mode - null-vertex-array - render-vertices - render-vertices/instanced)) - -;;; -;;; Buffers -;;; - -(define-record-type - (%make-buffer id name length stride target usage data) - buffer? - (id buffer-id) - (name buffer-name) - (length buffer-length) - (stride buffer-stride) - (target buffer-target) - (usage buffer-usage) - (data buffer-data set-buffer-data!)) - -(set-record-type-printer! - (lambda (buffer port) - (format port - "#" - (buffer-id buffer) - (buffer-name buffer) - (buffer-usage buffer) - (buffer-target buffer) - (buffer-length buffer) - (buffer-stride buffer)))) - -(define null-buffer - (%make-buffer 0 "null" 0 0 'vertex 'static #f)) - -(define <> (class-of null-buffer)) - -(define (free-buffer buffer) - (gl-delete-buffers 1 (u32vector (buffer-id buffer)))) - -(define-method (gpu-finalize (buffer <>)) - (free-buffer buffer)) - -(define (apply-buffer buffer) - (gl-bind-buffer (buffer-target-gl buffer) - (buffer-id 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) - (match (buffer-usage buffer) - ('static (arb-vertex-buffer-object static-draw-arb)) - ('stream (arb-vertex-buffer-object stream-draw-arb)))) - -(define (buffer-target-gl buffer) - (if (index-buffer? buffer) - (arb-vertex-buffer-object element-array-buffer-arb) - (arb-vertex-buffer-object array-buffer-arb))) - -(define* (make-buffer data #:key - (name "anonymous") - (length (bytevector-length data)) - (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." - ;; Weird bugs will occur when creating a new vertex buffer while a - ;; vertex array is bound. - (set-gpu-vertex-array! (current-gpu) null-vertex-array) - (let ((buffer (gpu-guard - (%make-buffer (generate-buffer-gl) - name - length - stride - target - usage - #f)))) - (set-gpu-vertex-buffer! (current-gpu) buffer) - (gl-buffer-data (buffer-target-gl buffer) - length - (if data - (bytevector->pointer data offset) - %null-pointer) - (buffer-usage-gl buffer)) - (set-gpu-vertex-buffer! (current-gpu) null-buffer) - buffer)) - -(define* (make-streaming-buffer length #:key - (name "anonymous") - (target 'vertex)) - "Return a new vertex buffer of LENGTH bytes, named NAME, suitable -for streaming data to the GPU every frame." - (make-buffer #f #:usage 'stream #:length length #:name name #:target target)) - -(define (buffer-mapped? buffer) - "Return #t if buffer data has been mapped from GPU." - (if (buffer-data buffer) #t #f)) - -(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))) - (set-gpu-vertex-buffer! (current-gpu) 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 (match mode - ('read-write (version-1-5 read-write)) - ('read-only (version-1-5 read-only)) - ('write-only (version-1-5 write-only)))))) - (set-buffer-data! buffer (pointer->bytevector ptr length)))))) - -(define (unmap-buffer! buffer) - "Return the mapped vertex buffer data for BUFFER to the GPU." - (set-gpu-vertex-buffer! (current-gpu) buffer) - (gl-unmap-buffer (buffer-target-gl buffer)) - (set-buffer-data! buffer #f)) - -(define-syntax-rule (with-mapped-buffer buffer body ...) - (dynamic-wind - (lambda () - (map-buffer! buffer)) - (lambda () body ...) - (lambda () - (unmap-buffer! buffer)))) - - -;;; -;;; Buffer Views -;;; - -(define-record-type - (%make-buffer-view name buffer offset component-type - normalized? length type max min sparse divisor) - buffer-view? - (name buffer-view-name) - (buffer buffer-view->buffer) - (offset buffer-view-offset) - (component-type buffer-view-component-type) - (normalized? buffer-view-normalized?) - (length buffer-view-length) - (type buffer-view-type) - (max buffer-view-max) - (min buffer-view-min) - (sparse buffer-view-sparse) - (divisor buffer-view-divisor)) ; for instanced rendering - -(define (buffer-view-stride buffer-view) - (or (buffer-stride (buffer-view->buffer buffer-view)) - (* (type-size (buffer-view-type buffer-view)) - (component-type-size (buffer-view-component-type buffer-view))))) - -(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-buffer-view #:key - (name "anonymous") - buffer - type - component-type - normalized? - (offset 0) - (length (num-elements (buffer-length buffer) - offset - type - component-type)) - max - min - sparse - divisor) - "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 -- 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." - (%make-buffer-view name buffer offset component-type - normalized? length type max min sparse divisor)) - -(define (type-size type) - (match type - ('scalar 1) - ('vec2 2) - ('vec3 3) - ((or 'vec4 'mat2) 4) - ('mat3 9) - ('mat4 16))) - -(define (component-type-size component-type) - (match component-type - ('byte 1) - ('unsigned-byte 1) - ('short 2) - ('unsigned-short 2) - ('int 4) - ('unsigned-int 4) - ('float 4) - ('double 8))) - -(define* (make-streaming-buffer-view type component-type length #:key - (name "anonymous") - (target 'vertex) - data - divisor) - "Return a new typed buffer to hold LENGTH elements of TYPE whose -components are comprised of COMPONENT-TYPE values. The underlying -untyped buffer is configured for GPU streaming. Optonally, a NAME can -be specified for the buffer. If the buffer will be used for instanced -rendering, the DIVISOR argument must be used to specify the rate at -which attributes advance when rendering multiple instances." - (let* ((buffer-length - (* length (type-size type) (component-type-size component-type))) - (buffer (if data - (make-buffer data - #:name name - #:length buffer-length - #:usage 'stream - #:target target) - (make-streaming-buffer buffer-length - #:name name - #:target target)))) - (make-buffer-view #:name name - #:buffer buffer - #:type type - #:component-type component-type - #:length length - #:divisor divisor))) - -(define (display-buffer-view buffer-view port) - (format port "#" - (buffer-view-name buffer-view) - (buffer-view->buffer buffer-view) - (buffer-view-type buffer-view) - (buffer-view-component-type buffer-view) - (buffer-view-length buffer-view) - (buffer-view-offset buffer-view))) - -(set-record-type-printer! display-buffer-view) - -(define (buffer-view-type-size buffer-view) - (type-size (buffer-view-type buffer-view))) - -(define (buffer-view-data buffer-view) - (buffer-data (buffer-view->buffer buffer-view))) - -(define (buffer-view-type-gl buffer-view) - (match (buffer-view-component-type buffer-view) - ('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 (map-buffer-view! buffer-view) - (map-buffer! (buffer-view->buffer buffer-view))) - -(define (unmap-buffer-view! buffer-view) - (unmap-buffer! (buffer-view->buffer buffer-view))) - -(define-syntax-rule (with-mapped-buffer-view buffer-view body ...) - (with-mapped-buffer (buffer-view->buffer buffer-view) body ...)) - -(define* (apply-buffer-view buffer-view #:optional attribute-index) - (set-gpu-vertex-buffer! (current-gpu) (buffer-view->buffer buffer-view)) - ;; 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 - (buffer-view-type-size buffer-view) - (buffer-view-type-gl buffer-view) - (buffer-view-normalized? buffer-view) - (buffer-view-stride buffer-view) - (make-pointer (buffer-view-offset buffer-view))) - (let ((divisor (buffer-view-divisor buffer-view))) - (when divisor - (gl-vertex-attrib-divisor attribute-index divisor))))) - -;; TODO: Handle 4-byte alignment rule for the types that need it. -(define (buffer-view->vector buffer-view) - (define (component-parser type) - (match type - ('byte bytevector-s8-ref) - ('unsigned-byte bytevector-u8-ref) - ('short - (lambda (bv i) - (bytevector-s16-ref bv i (native-endianness)))) - ('unsigned-short - (lambda (bv i) - (bytevector-u16-ref bv i (native-endianness)))) - ('unsigned-int - (lambda (bv i) - (bytevector-u32-ref bv i (native-endianness)))) - ('float bytevector-ieee-single-native-ref))) - (define (element-parser type component-type) - (let ((parse-component (component-parser component-type)) - (component-type-size (component-type-size component-type))) - (match type - ('scalar parse-component) - ('vec2 - (lambda (bv i) - (vec2 (parse-component bv i) - (parse-component bv (+ i component-type-size))))) - ('vec3 - (lambda (bv i) - (vec3 (parse-component bv i) - (parse-component bv (+ i component-type-size)) - (parse-component bv (+ i (* component-type-size 2)))))) - ;; TODO: Use a proper vec4 type when it exists. - ('vec4 - (lambda (bv i) - (vector (parse-component bv i) - (parse-component bv (+ i component-type-size)) - (parse-component bv (+ i (* component-type-size 2))) - (parse-component bv (+ i (* component-type-size 3)))))) - ;; TODO: Use proper matrix2 type when it exists. - ('mat2 - (lambda (bv i) - (vector (vector (parse-component bv i) - (parse-component bv (+ i component-type-size))) - (vector (parse-component bv (+ i (* component-type-size 2))) - (parse-component bv (+ i (* component-type-size 3))))))) - ;; TODO: Use proper matrix3 type when it exists. - ('mat3 - (lambda (bv i) - (vector (vector (parse-component bv i) - (parse-component bv (+ i component-type-size)) - (parse-component bv (+ i (* component-type-size 2)))) - (vector (parse-component bv (+ i (* component-type-size 3))) - (parse-component bv (+ i (* component-type-size 4))) - (parse-component bv (+ i (* component-type-size 5))))))) - ('mat4 - (lambda (bv i) - (make-matrix4 (parse-component bv i) - (parse-component bv (+ i component-type-size)) - (parse-component bv (+ i (* component-type-size 2))) - (parse-component bv (+ i (* component-type-size 3))) - (parse-component bv (+ i (* component-type-size 4))) - (parse-component bv (+ i (* component-type-size 5))) - (parse-component bv (+ i (* component-type-size 6))) - (parse-component bv (+ i (* component-type-size 7))) - (parse-component bv (+ i (* component-type-size 8))) - (parse-component bv (+ i (* component-type-size 9))) - (parse-component bv (+ i (* component-type-size 10))) - (parse-component bv (+ i (* component-type-size 11))) - (parse-component bv (+ i (* component-type-size 12))) - (parse-component bv (+ i (* component-type-size 13))) - (parse-component bv (+ i (* component-type-size 14))) - (parse-component bv (+ i (* component-type-size 15))))))))) - (with-mapped-buffer-view buffer-view - (let* ((data (buffer-view-data buffer-view)) - (length (buffer-view-length buffer-view)) - (offset (buffer-view-offset buffer-view)) - (stride (buffer-view-stride buffer-view)) - (type (buffer-view-type buffer-view)) - (component-type (buffer-view-component-type buffer-view)) - (type-byte-size (* (type-size type) - (component-type-size component-type))) - (v (make-vector length)) - (parse-element (element-parser type component-type))) - (let loop ((i 0)) - (when (< i length) - (let ((byte-index (+ (* i stride) offset))) - (vector-set! v i (parse-element data byte-index))) - (loop (+ i 1)))) - v))) - - -;;; -;;; Vertex Arrays -;;; - -(define-record-type - (%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! - (lambda (array port) - (format port - "#" - (vertex-array-indices array) - (vertex-array-attributes array) - (vertex-array-mode array)))) - -(define null-vertex-array (%make-vertex-array 0 #f '() 'triangles)) - -(define <> (class-of null-vertex-array)) - -(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-method (gpu-finalize (va <>)) - (free-vertex-array va)) - -(define (apply-vertex-array va) - (gl-bind-vertex-array (vertex-array-id va))) - -(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" - (let ((array (gpu-guard - (%make-vertex-array (generate-vertex-array) - indices - attributes - mode)))) - (set-gpu-vertex-array! (current-gpu) array) - (for-each (match-lambda - ((index . buffer-view) - (apply-buffer-view buffer-view index))) - attributes) - (apply-buffer-view indices) - (set-gpu-vertex-array! (current-gpu) null-vertex-array) - array)) - -(define (vertex-array-mode-gl array) - (match (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 #:optional count) - (set-gpu-vertex-array! (current-gpu) array) - (let ((indices (vertex-array-indices array))) - (gl-draw-elements (vertex-array-mode-gl array) - (or count - (buffer-view-length indices)) - (buffer-view-type-gl indices) - %null-pointer))) - -(define* (render-vertices/instanced array instances #:optional count) - (set-gpu-vertex-array! (current-gpu) array) - (let ((indices (vertex-array-indices array))) - (gl-draw-elements-instanced (vertex-array-mode-gl array) - (or count - (buffer-view-length indices)) - (buffer-view-type-gl indices) - %null-pointer - instances))) diff --git a/chickadee/render/color.scm b/chickadee/render/color.scm deleted file mode 100644 index 52f98d7..0000000 --- a/chickadee/render/color.scm +++ /dev/null @@ -1,220 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2018 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Colors! -;; -;;; Code: - -(define-module (chickadee render color) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-1) - #:use-module (chickadee math) - #:export (color make-color - color? - color-r color-g color-b color-a - rgba rgb transparency string->color - color* color+ color- color-inverse color-lerp - - white black red green blue yellow magenta cyan transparent - tango-light-butter tango-butter tango-dark-butter - tango-light-orange tango-orange tango-dark-orange - tango-light-chocolate tango-chocolate tango-dark-chocolate - tango-light-chameleon tango-chameleon tango-dark-chameleon - tango-light-sky-blue tango-sky-blue tango-dark-sky-blue - tango-light-plum tango-plum tango-dark-plum - tango-light-scarlet-red tango-scarlet-red tango-dark-scarlet-red - tango-aluminium-1 tango-aluminium-2 tango-aluminium-3 - tango-aluminium-4 tango-aluminium-5 tango-aluminium-6)) - -(define-record-type - (wrap-color bv) - color? - (bv unwrap-color)) - -(define-inlinable (color-r color) - (f32vector-ref (unwrap-color color) 0)) - -(define-inlinable (color-g color) - (f32vector-ref (unwrap-color color) 1)) - -(define-inlinable (color-b color) - (f32vector-ref (unwrap-color color) 2)) - -(define-inlinable (color-a color) - (f32vector-ref (unwrap-color color) 3)) - -(define-inlinable (make-color r g b a) - (wrap-color - (f32vector - (clamp 0.0 1.0 r) - (clamp 0.0 1.0 g) - (clamp 0.0 1.0 b) - (clamp 0.0 1.0 a)))) - -(define-inlinable (color r g b a) - (make-color r g b a)) - -(define (color-component color-code offset) - "Return the value of an 8-bit color channel in the range [0,1] for -the integer COLOR-CODE, given an OFFSET in bits." - (let ((mask (ash #xff offset))) - (/ (ash (logand mask color-code) - (- offset)) - 255.0))) - -(define (rgba color-code) - "Translate an RGBA format string COLOR-CODE into a color object. -For example: #xffffffff will return a color with RGBA values 1, 1, 1, -1." - (make-color (color-component color-code 24) - (color-component color-code 16) - (color-component color-code 8) - (color-component color-code 0))) - -(define (rgb color-code) - "Translate an RGB format string COLOR-CODE into a color object. -For example: #xffffff will return a color with RGBA values 1, 1, 1, -1." - (make-color (color-component color-code 16) - (color-component color-code 8) - (color-component color-code 0) - 1.0)) - -(define (transparency alpha) - "Create a new color that is white with a transparency value of -ALPHA. ALPHA is clamped to the range [0, 1]." - (make-color 1 1 1 alpha)) - -(define (string->color s) - "Convert the color code string S, in a format like \"#RRGGBBAA\", to -a color object." - (define (parse-digit i) - (match (string-ref s i) - (#\0 0) - (#\1 1) - (#\2 2) - (#\3 3) - (#\4 4) - (#\5 5) - (#\6 6) - (#\7 7) - (#\8 8) - (#\9 9) - ((or #\a #\A) 10) - ((or #\b #\B) 11) - ((or #\c #\C) 12) - ((or #\d #\D) 13) - ((or #\e #\E) 14) - ((or #\f #\F) 15))) - (define (parse-channel i) - (/ (+ (* (parse-digit i) 16) - (parse-digit (+ i 1))) - 255.0)) - ;; Support color codes with or without a "#" prefix and with or - ;; without an alpha channel. - (let* ((start (if (string-prefix? "#" s) 1 0)) - (alpha? (> (string-length s) (+ start 6))) - (red (parse-channel start)) - (green (parse-channel (+ start 2))) - (blue (parse-channel (+ start 4))) - (alpha (if alpha? - (parse-channel (+ start 6)) - 1.0))) - (make-color red green blue alpha))) - -(define-inlinable (color* a b) - (if (color? b) - (make-color (* (color-r a) (color-r b)) - (* (color-g a) (color-g b)) - (* (color-b a) (color-b b)) - (* (color-a a) (color-a b))) - ;; Scalar multiplication. - (make-color (* (color-r a) b) - (* (color-g a) b) - (* (color-b a) b) - (* (color-a a) b)))) - -(define-inlinable (color+ a b) - (make-color (+ (color-r a) (color-r b)) - (+ (color-g a) (color-g b)) - (+ (color-b a) (color-b b)) - (+ (color-a a) (color-a b)))) - -(define-inlinable (color- a b) - (make-color (- (color-r a) (color-r b)) - (- (color-g a) (color-g b)) - (- (color-b a) (color-b b)) - (- (color-a a) (color-a b)))) - -(define-inlinable (color-inverse color) - (make-color (- 1.0 (color-r color)) - (- 1.0 (color-g color)) - (- 1.0 (color-b color)) - ;; Do not alter alpha channel. - (color-a color))) - -(define-inlinable (color-lerp start end alpha) - (color+ (color* start (- 1.0 alpha)) - (color* end alpha))) - -;;; -;;; Pre-defined Colors -;;; - -;; Basic -(define white (rgb #xffffff)) -(define black (rgb #x000000)) -(define red (rgb #xff0000)) -(define green (rgb #x00ff00)) -(define blue (rgb #x0000ff)) -(define yellow (rgb #xffff00)) -(define magenta (rgb #xff00ff)) -(define cyan (rgb #x00ffff)) -(define transparent (make-color 0 0 0 0)) - -;; Tango color pallete -;; http://tango.freedesktop.org -(define tango-light-butter (rgb #xfce94f)) -(define tango-butter (rgb #xedd400)) -(define tango-dark-butter (rgb #xc4a000)) -(define tango-light-orange (rgb #xfcaf3e)) -(define tango-orange (rgb #xf57900)) -(define tango-dark-orange (rgb #xce5c00)) -(define tango-light-chocolate (rgb #xe9b96e)) -(define tango-chocolate (rgb #xc17d11)) -(define tango-dark-chocolate (rgb #x8f5902)) -(define tango-light-chameleon (rgb #x8ae234)) -(define tango-chameleon (rgb #x73d216)) -(define tango-dark-chameleon (rgb #x4e9a06)) -(define tango-light-sky-blue (rgb #x729fcf)) -(define tango-sky-blue (rgb #x3465a4)) -(define tango-dark-sky-blue (rgb #x204a87)) -(define tango-light-plum (rgb #xad7fa8)) -(define tango-plum (rgb #x75507b)) -(define tango-dark-plum (rgb #x5c3566)) -(define tango-light-scarlet-red (rgb #xef2929)) -(define tango-scarlet-red (rgb #xcc0000)) -(define tango-dark-scarlet-red (rgb #xa40000)) -(define tango-aluminium-1 (rgb #xeeeeec)) -(define tango-aluminium-2 (rgb #xd3d7cf)) -(define tango-aluminium-3 (rgb #xbabdb6)) -(define tango-aluminium-4 (rgb #x888a85)) -(define tango-aluminium-5 (rgb #x555753)) -(define tango-aluminium-6 (rgb #x2e3436)) diff --git a/chickadee/render/depth.scm b/chickadee/render/depth.scm deleted file mode 100644 index 2eb4e55..0000000 --- a/chickadee/render/depth.scm +++ /dev/null @@ -1,61 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2020 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render depth) - #:use-module (ice-9 match) - #:use-module (gl) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:use-module (srfi srfi-9) - #:export (make-depth-test - depth-test? - depth-test-write? - depth-test-function - depth-test-near - depth-test-far - default-depth-test - apply-depth-test)) - -(define-record-type - (%make-depth-test write? function near far) - depth-test? - (write? depth-test-write?) - (function depth-test-function) - (near depth-test-near) - (far depth-test-far)) - -(define* (make-depth-test #:key (write? #t) (function 'less-than) (near 0.0) (far 1.0)) - (%make-depth-test write? function near far)) - -(define default-depth-test (make-depth-test)) - -(define (apply-depth-test depth-test) - (if depth-test - (let ((glfunc (match (depth-test-function depth-test) - ('always (depth-function always)) - ('never (depth-function never)) - ('equal (depth-function equal)) - ('not-equal (depth-function notequal)) - ('less-than (depth-function less)) - ('less-than-or-equal (depth-function lequal)) - ('greater-than (depth-function greater)) - ('greater-than-or-equal (depth-function gequal))))) - (gl-enable (enable-cap depth-test)) - (gl-depth-func glfunc) - (gl-depth-mask (depth-test-write? depth-test)) - (gl-depth-range (depth-test-near depth-test) (depth-test-far depth-test))) - (gl-disable (enable-cap depth-test)))) diff --git a/chickadee/render/font.scm b/chickadee/render/font.scm deleted file mode 100644 index 128be9d..0000000 --- a/chickadee/render/font.scm +++ /dev/null @@ -1,513 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2017, 2020 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Bitmap font rendering. -;; -;;; Code: - -(define-module (chickadee render font) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-4) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) - #:use-module (sxml xpath) - #:use-module (sxml simple) - #:use-module (chickadee config) - #:use-module (chickadee freetype) - #:use-module (chickadee math matrix) - #:use-module (chickadee math rect) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render gpu) - #:use-module (chickadee render shader) - #:use-module (chickadee render sprite) - #:use-module (chickadee render texture) - #:use-module (rnrs bytevectors) - #:export (load-tile-font - load-bitmap-font - load-font - font? - font-face - font-line-height - font-line-width - font-bold? - font-italic? - default-font - draw-text* - draw-text)) - -(define-record-type - (make-font-char id texture-region offset dimensions advance) - font-char? - (id font-char-id) - (texture-region font-char-texture-region) - (offset font-char-offset) - (dimensions font-char-dimensions) - (advance font-char-advance)) - -(define-record-type - (make-font face bold? italic? line-height chars kernings sprite-batches) - font? - (face font-face) - (bold? font-bold?) - (italic? font-italic?) - (line-height font-line-height) - (chars font-chars) - (kernings font-kernings) - (sprite-batches font-sprite-batches)) - -(define (display-font font port) - (format port "#" - (font-face font) - (font-line-height font) - (font-bold? font) - (font-italic? font))) - -(set-record-type-printer! display-font) - -(define (font-line-width font text) - "Return the width of TEXT when rendered with FONT." - (let loop ((width 0.0) - (i 0)) - (if (< i (string-length text)) - (let ((char (or (font-ref font (string-ref text i)) - (font-ref font #\?)))) - (loop (+ width (vec2-x (font-char-advance char))) - (+ i 1))) - width))) - -(define freetype-handle - (delay (init-freetype))) - -(define* (load-font file-name point-size #:key (char-set char-set:ascii)) - "Load all the glyphs in CHAR-SET from the font in FILE-NAME and -display it at POINT-SIZE. By default, the ASCII character is used." - (unless (file-exists? file-name) - (error "no such file" file-name)) - (let ((face (load-face (force freetype-handle) file-name)) - (chars (make-hash-table)) - (kernings (make-hash-table)) - (batches (make-hash-table)) - (texture-size (min (gpu-max-texture-size (current-gpu)) 2048))) - ;; TODO: Use actual screen DPI. - (set-char-size! face (* point-size 64) 0 96 96) - (let ((glyph (face-glyph-slot face)) - (pixels (make-bytevector (* texture-size texture-size 4))) - (x 0) - (y 0) - (next-y 0)) - (define (add-pixels char width height pitch left top advance glyph-pixels) - (when (> (+ x width) texture-size) - (set! y next-y) - (set! x 0)) - (let y-loop ((row 0)) - (when (< row height) - (let x-loop ((column 0)) - (when (< column width) - (let ((gray (u8vector-ref glyph-pixels - (+ (* row pitch) column))) - (offset (+ (* (+ y row) texture-size 4) - (* (+ x column) 4)))) - (u8vector-set! pixels offset 255) - (u8vector-set! pixels (+ offset 1) 255) - (u8vector-set! pixels (+ offset 2) 255) - (u8vector-set! pixels (+ offset 3) gray)) - (x-loop (+ column 1)))) - (y-loop (+ row 1)))) - (let ((spec (list char x y width height left top advance))) - (set! x (+ x width)) - (set! next-y (max next-y (+ y height))) - spec)) - ;; Render individual glyph bitmaps and compose them into larger - ;; images to be used as textures. - (let* ((specs - (char-set-fold - (lambda (char prev) - (load-char face char '(render)) - (let ((left (glyph-bitmap-left glyph)) - (top (glyph-bitmap-top glyph))) - (match (glyph-metrics glyph) - ((bearing-x bearing-y advance) - (match (glyph-bitmap glyph) - ((width height pitch glyph-pixels) - (cons (if glyph-pixels - (add-pixels char width height - pitch left top - advance - glyph-pixels) - (list char #f #f width height left top advance)) - prev))))))) - '() - char-set)) - ;; TODO: Use multiple textures if needed. - (texture (make-texture pixels texture-size texture-size))) - ;; Process kernings. - (char-set-for-each - (lambda (left) - (let ((left-index (get-char-index face left))) - (char-set-for-each - (lambda (right) - (let* ((k (get-kerning face - left-index - (get-char-index face right))) - (kx (s64vector-ref k 0)) - (ky (s64vector-ref k 1)) - (t (hash-ref kernings left))) - (unless (and (zero? kx) (zero? ky)) - (let ((kv (vec2 (/ kx 64.0) (/ ky 64.0)))) - (if t - (hash-set! t right kv) - (let ((t (make-hash-table))) - (hash-set! t right kv) - (hash-set! kernings left t))))))) - char-set))) - char-set) - ;; Build chars. - (for-each (match-lambda - ((char x y width height left top advance) - (hash-set! chars char - (make-font-char 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))))) - specs) - (hashq-set! batches texture (make-sprite-batch texture)))) - (let ((style (face-style-name face))) - (match (size-metrics (face-size face)) - ((_ _ _ _ _ _ height _) - (make-font (face-family-name face) - (and (string-match ".*[B,b]old.*" style) #t) - (and (string-match ".*[I,i]talic.*" style) #t) - (/ height 64.0) - chars - kernings - batches)))))) - -(define* (load-tile-font file tile-width tile-height characters #:key - (face "untitled") (margin 0) (spacing 0)) - "Load the font named FACE from FILE, a bitmap image containing the -characters in the string CHARACTERS that are TILE-WIDTH by TILE-HEIGHT -pixels in size. The characters in the image *must* appear in the -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)) - (chars - (let ((table (make-hash-table))) - (string-for-each-index - (lambda (i) - (hash-set! table (string-ref characters i) - (make-font-char (string-ref characters i) - (texture-atlas-ref atlas i) - (vec2 0.0 0.0) - (vec2 tile-width tile-height) - (vec2 tile-width 0.0)))) - characters) - table)) - ;; These fonts are by definition monospace fonts, so no - ;; kerning. - (kernings (make-hash-table)) - (batches (make-hash-table))) - (hashq-set! batches texture (make-sprite-batch texture)) - (make-font face #f #f tile-height chars kernings batches))) - -(define (load-bitmap-font file) - "Load the AngelCode formatted bitmap font within FILE. The file -extension must be either .xml or .fnt." - (cond - ((string-suffix? ".xml" file) - (parse-bmfont-sxml file (call-with-input-file file xml->sxml))) - ((string-suffix? ".fnt" file) - (parse-bmfont-sxml file (parse-fnt file))) - (else - (error "unknown bmfont file type: " file)))) - -(define (parse-fnt file) - (define (newline? char) - (eqv? char #\newline)) - (define (whitespace? char) - (and (not (newline? char)) - (char-set-contains? char-set:whitespace char))) - (define (letter? char) - (char-set-contains? char-set:letter char)) - (define (consume-whitespace port) - (match (peek-char port) - ((? eof-object?) *unspecified*) - ((? whitespace?) - (read-char port) - (consume-whitespace port)) - (_ *unspecified*))) - (define (read-tag port) - (list->symbol - (let loop () - (match (peek-char port) - ((? letter? char) - (read-char port) - (cons char (loop))) - ((? whitespace? char) - '()))))) - (define (read-key port) - (list->symbol - (let loop () - (match (read-char port) - (#\= '()) - ((? letter? char) - (cons char (loop))))))) - (define (read-quoted-string port) - (match (read-char port) - (#\" #t)) - (list->string - (let loop () - (match (read-char port) - (#\" - (if (or (whitespace? (peek-char port)) - (newline? (peek-char port))) - '() - (cons #\" (loop)))) - (char (cons char (loop))))))) - (define (read-unquoted-string port) - (list->string - (let loop () - (match (peek-char port) - ((or (? whitespace?) - (? newline?)) - '()) - (char - (read-char port) - (cons char (loop))))))) - (define (read-value port) - (match (peek-char port) - (#\" - (read-quoted-string port)) - (_ (read-unquoted-string port)))) - (define (read-key/value-pair port) - (list (read-key port) (read-value port))) - (define (read-key/value-pairs port) - (cons '@ - (let loop () - (consume-whitespace port) - (match (peek-char port) - ((? newline?) - (read-char port) - '()) - ((? letter?) - (cons (read-key/value-pair port) - (loop))))))) - (define (read-line port) - (list (read-tag port) (read-key/value-pairs port))) - `(*TOP* - (font - ,@(call-with-input-file file - (lambda (port) - (let loop ((pages '())) - (match (peek-char port) - ((? eof-object?) - `((pages (@ (count ,(number->string (length pages)))) - ,@pages))) - ((? newline?) - (read-char port) - (loop pages)) - ((? letter?) - (match (read-line port) - ((tag ('@ ('count count))) - (cons (cons* tag - `(@ (count ,count)) - (list-tabulate (string->number count) - (lambda (i) - (read-line port)))) - (loop pages))) - ((and ('page . _) page) - (loop (cons page pages))) - (exp (cons exp (loop pages)))))))))))) - -(define (parse-bmfont-sxml file tree) - (define directory (dirname file)) - (define* (attr tree name #:optional (parse identity)) - (let ((result ((sxpath `(@ ,name *text*)) tree))) - (if (null? result) - #f - (parse (car result))))) - (define (parse-pages nodes) - (let ((table (make-hash-table))) - (for-each (lambda (node) - (let* ((id (attr node 'id string->number)) - (file (attr node 'file)) - (texture (load-image - (string-append directory "/" file)))) - (hash-set! table id texture))) - nodes) - table)) - (define (string->character s) - (integer->char (string->number s))) - (define (parse-chars nodes pages image-width image-height line-height) - (define (x->s x) - (exact->inexact (/ x image-width))) - (define (y->t y) - (exact->inexact (/ y image-height))) - (let ((table (make-hash-table))) - (for-each (lambda (node) - (let* ((id (attr node 'id string->character)) - (width (attr node 'width string->number)) - (height (attr node 'height string->number)) - (x (attr node 'x string->number)) - (y (attr node 'y string->number)) - (x-offset (attr node 'xoffset string->number)) - (y-offset (- line-height height - (attr node 'yoffset string->number))) - (x-advance (attr node 'xadvance string->number)) - (page (or (attr node 'page string->number) 0)) - (region (make-texture-region (hash-ref pages page) - (make-rect x y width height))) - (char (make-font-char id - region - (vec2 x-offset y-offset) - (vec2 width height) - (vec2 x-advance 0.0)))) - (hash-set! table id char))) - nodes) - table)) - (define (parse-kernings nodes) - (let ((table (make-hash-table))) - (for-each (lambda (node) - (let* ((first (attr node 'first string->character)) - (second (attr node 'second string->character)) - (x-offset (attr node 'amount string->number)) - (inner-table (hash-ref table first))) - (if inner-table - (hash-set! inner-table second (vec2 x-offset 0.0)) - (let ((inner-table (make-hash-table))) - (hash-set! inner-table second (vec2 x-offset 0.0)) - (hash-set! table first inner-table))))) - nodes) - table)) - (let* ((info ((sxpath '(font info)) tree)) - (common ((sxpath '(font common)) tree)) - (face (attr info 'face)) - (bold? (attr info 'bold (const #t))) - (italic? (attr info 'italic (const #t))) - (line-height (attr common 'lineHeight string->number)) - (image-width (attr common 'scaleW string->number)) - (image-height (attr common 'scaleH string->number)) - (pages (parse-pages ((sxpath '(font pages page)) tree))) - (chars (parse-chars ((sxpath '(font chars char)) tree) - pages - image-width - image-height - line-height)) - (kernings (parse-kernings ((sxpath '(font kernings kerning)) tree))) - (batches (make-hash-table))) - (hash-for-each (lambda (id texture) - (hashq-set! batches texture (make-sprite-batch texture))) - pages) - (make-font face bold? italic? line-height chars kernings batches))) - -(define (font-ref font char) - (hashv-ref (font-chars font) char)) - -(define draw-text* - (let ((cursor (vec2 0.0 0.0)) - (rect (make-rect 0.0 0.0 0.0 0.0))) - (lambda* (font text matrix #:key (blend-mode 'alpha) - (start 0) (end (string-length text))) - (let ((batches (font-sprite-batches font)) - (kernings (font-kernings font))) - (define (kerning char prev) - (let ((t (hash-ref kernings prev))) - (and t (hash-ref t char)))) - (define (render-char c prev) - (if (eqv? c #\newline) - (begin - (set-vec2-x! cursor 0.0) - (set-vec2-y! cursor (- (vec2-y cursor) (font-line-height font)))) - ;; TODO: What if "?" isn't in the font? - (let* ((char (or (font-ref font c) (font-ref font #\?))) - (k (kerning c prev)) - (texture (font-char-texture-region char)) - (batch (and texture (hashq-ref batches (texture-parent texture)))) - (dimensions (font-char-dimensions char)) - (offset (font-char-offset char))) - ;; Apply kerning, if present. - (when k - (set-vec2-x! cursor (+ (vec2-x cursor) (vec2-x k)))) - (when texture - (set-rect-x! rect (+ (vec2-x cursor) (vec2-x offset))) - (set-rect-y! rect (+ (vec2-y cursor) (vec2-y offset))) - (set-rect-width! rect (vec2-x dimensions)) - (set-rect-height! rect (vec2-y dimensions)) - (sprite-batch-add* batch rect matrix - #:texture-region texture)) - ;; Move forward to where the next character needs to be drawn. - (set-vec2-x! cursor - (+ (vec2-x cursor) - (vec2-x - (font-char-advance char))))))) - (set-vec2! cursor 0.0 0.0) - (hash-for-each (lambda (texture batch) - (sprite-batch-clear! batch)) - batches) - (let loop ((i start) - (prev #f)) - (when (< i end) - (let ((char (string-ref text i))) - (render-char char prev) - (loop (+ i 1) char)))) - (hash-for-each (lambda (texture batch) - (draw-sprite-batch batch #:blend-mode blend-mode)) - batches))))) - -(define %default-scale (vec2 1.0 1.0)) -(define %null-vec2 (vec2 0.0 0.0)) -(define %default-font - (delay (load-font (scope-datadir "fonts/Inconsolata-Regular.otf") 12))) - -(define (default-font) - (force %default-font)) - -(define draw-text - (let ((matrix (make-null-matrix4))) - (lambda* (text - position - #:key - (font (default-font)) - (origin %null-vec2) - (rotation 0) - (scale %default-scale) - (blend-mode 'alpha) - (start 0) - (end (string-length text))) - "Draw the string TEXT with the first character starting at -POSITION using FONT." - (matrix4-2d-transform! matrix - #:origin origin - #:position position - #:rotation rotation - #:scale scale) - (draw-text* font text matrix #:blend-mode blend-mode - #:start start #:end end)))) diff --git a/chickadee/render/framebuffer.scm b/chickadee/render/framebuffer.scm deleted file mode 100644 index 53890ba..0000000 --- a/chickadee/render/framebuffer.scm +++ /dev/null @@ -1,137 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2017 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Render to texture. -;; -;;; Code: - -(define-module (chickadee render framebuffer) - #:use-module (oop goops) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) - #:use-module (system foreign) - #:use-module (gl) - #:use-module (gl enums) - #:use-module (chickadee math matrix) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:use-module ((chickadee render texture) #:select (make-texture null-texture)) - #:use-module (chickadee render viewport) - #:export (make-framebuffer - framebuffer? - framebuffer-texture - framebuffer-viewport - framebuffer-projection - null-framebuffer - apply-framebuffer)) - -(define (generate-framebuffer) - "Generate a new OpenGL framebuffer object." - (let ((bv (u32vector 1))) - (gl-gen-framebuffers 1 (bytevector->pointer bv)) - (u32vector-ref bv 0))) - -(define (generate-renderbuffer) - "Generate a new OpenGL renderbuffer object." - (let ((bv (u32vector 1))) - (gl-gen-renderbuffers 1 (bytevector->pointer bv)) - (u32vector-ref bv 0))) - -(define-record-type - (%make-framebuffer id renderbuffer-id texture viewport projection) - framebuffer? - (id framebuffer-id) - (renderbuffer-id framebuffer-renderbuffer-id) - (texture framebuffer-texture) - (viewport framebuffer-viewport) - (projection framebuffer-projection)) - -(define null-framebuffer - (%make-framebuffer 0 0 null-texture null-viewport (make-identity-matrix4))) - -(define <> (class-of null-framebuffer)) - -(define (free-framebuffer framebuffer) - (gl-delete-renderbuffers 1 - (bytevector->pointer - (u32vector - (framebuffer-renderbuffer-id framebuffer)))) - (gl-delete-framebuffers 1 - (bytevector->pointer - (u32vector - (framebuffer-id framebuffer))))) - -(define-method (gpu-finalize (framebuffer <>)) - (free-framebuffer framebuffer)) - -(define (apply-framebuffer framebuffer) - (gl-bind-framebuffer (version-3-0 framebuffer) - (framebuffer-id framebuffer))) - -(define make-framebuffer - (let ((draw-buffers (u32vector (version-3-0 color-attachment0)))) - (lambda* (width height #:key (min-filter 'linear) (mag-filter 'linear) - (wrap-s 'repeat) (wrap-t 'repeat)) - "Create a new framebuffer that renders to a texture with -dimensions WIDTH x HEIGHT." - (let* ((framebuffer-id (generate-framebuffer)) - (renderbuffer-id (generate-renderbuffer)) - (texture (make-texture #f width height - #:flip? #t - #:min-filter min-filter - #:mag-filter mag-filter - #:wrap-s wrap-s - #:wrap-t wrap-t)) - ;; It is convenient to make a default viewport and - ;; projection matrix for the framebuffer so that the - ;; rendering engine can set it whenever it changes to - ;; this framebuffer, saving users the trouble of having - ;; to this tedious task themselves. - (viewport (make-viewport 0 0 width height)) - (projection (orthographic-projection 0 width height 0 0 1)) - (framebuffer (%make-framebuffer framebuffer-id - renderbuffer-id - texture - viewport - projection))) - (set-gpu-framebuffer! (current-gpu) framebuffer) - ;; Setup depth buffer. - (gl-bind-renderbuffer (version-3-0 renderbuffer) - renderbuffer-id) - (gl-renderbuffer-storage (version-3-0 renderbuffer) - (pixel-format depth-component) - width - height) - (gl-framebuffer-renderbuffer (version-3-0 framebuffer) - (arb-framebuffer-object depth-attachment) - (version-3-0 renderbuffer) - renderbuffer-id) - ;; Setup framebuffer. - (gl-framebuffer-texture-2d (version-3-0 framebuffer) - (version-3-0 color-attachment0) - (texture-target texture-2d) - ((@@ (chickadee render texture) texture-id) - texture) - 0) - (gl-draw-buffers 1 (bytevector->pointer draw-buffers)) - ;; Check for errors. - (unless (= (gl-check-framebuffer-status (version-3-0 framebuffer)) - (version-3-0 framebuffer-complete)) - (error "Framebuffer cannot be created")) - framebuffer)))) diff --git a/chickadee/render/gl.scm b/chickadee/render/gl.scm deleted file mode 100644 index 06c20e7..0000000 --- a/chickadee/render/gl.scm +++ /dev/null @@ -1,330 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Custom wrappers over low level OpenGL commands that aren't part of -;; guile-opengl. -;; -;;; Code: - -(define-module (chickadee render gl) - #:use-module (srfi srfi-4) - #:use-module ((system foreign) #:select (bytevector->pointer)) - #:use-module (gl) - #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%)) - #:use-module (gl enums) - #:use-module (gl runtime) - #:use-module (gl types)) - -(re-export (%glClearColor . gl-clear-color) - (%glScissor . gl-scissor) - (%glBlendFunc . gl-blend-func) - (%glBlendEquation . gl-blend-equation)) - -;;; -;;; 3.8.1 Texture Image Specification -;;; - -(re-export (%glTexImage3D . gl-texture-image-3d) - (%glTexImage2D . gl-texture-image-2d) - (%glTexImage1D . gl-texture-image-1d)) - -;;; -;;; 3.8.2 Alternate Texture Image Specification Commands -;;; - -(re-export (%glCopyTexImage2D . gl-copy-texture-image-2d) - (%glCopyTexImage1D . gl-copy-texture-image-1d) - (%glCopyTexSubImage3D . gl-copy-texture-sub-image-3d) - (%glCopyTexSubImage2D . gl-copy-texture-sub-image-2d) - (%glCopyTexSubImage1D . gl-copy-texture-sub-image-1d) - (%glTexSubImage3D . gl-texture-sub-image-3d) - (%glTexSubImage2D . gl-texture-sub-image-2d) - (%glTexSubImage1D . gl-texture-sub-image-1d)) - -;;; -;;; 3.8.3 Compressed Texture Images -;;; - -(re-export (%glCompressedTexImage1D . gl-compressed-texture-image-1d) - (%glCompressedTexImage2D . gl-compressed-texture-image-2d) - (%glCompressedTexImage3D . gl-compressed-texture-image-3d) - (%glCompressedTexSubImage1D . gl-compressed-texture-sub-image-1d) - (%glCompressedTexSubImage2D . gl-compressed-texture-sub-image-2d) - (%glCompressedTexSubImage3D . gl-compressed-texture-sub-image-3d)) - -;;; -;;; 3.8.4 Texture Parameters -;;; - -(re-export (%glTexParameteri . gl-texture-parameter) - (%glBindTexture . gl-bind-texture)) - -;;; -;;; Instancing extension -;;; - -(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.") - -(export (glDrawArraysInstanced . gl-draw-arrays-instanced) - (glDrawElementsInstanced . gl-draw-elements-instanced) - (glVertexAttribDivisor . gl-vertex-attrib-divisor)) - -;;; -;;; VBOs -;;; - -(re-export (%glGenBuffers . gl-gen-buffers) - (%glDeleteBuffers . gl-delete-buffers) - (%glBufferData . gl-buffer-data) - (%glBufferSubData . gl-buffer-sub-data) - (%glMapBuffer . gl-map-buffer) - (%glUnmapBuffer . gl-unmap-buffer)) - -;;; -;;; VAOs -;;; - -(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.") - -(export (glGenVertexArrays . gl-gen-vertex-arrays) - (glDeleteVertexArrays . gl-delete-vertex-arrays) - (glBindVertexArray . gl-bind-vertex-array) - (glEnableVertexAttribArray . gl-enable-vertex-attrib-array) - (glVertexAttribPointer . gl-vertex-attrib-pointer) - (glDrawElements . gl-draw-elements)) - -(define-syntax-rule (with-gl-client-state state body ...) - (begin - (gl-enable-client-state state) - body ... - (gl-disable-client-state state))) - -(export with-gl-client-state) - -;;; -;;; Framebuffers -;;; - -(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 (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.") - -(export (glGenFramebuffers . gl-gen-framebuffers) - (glDeleteFramebuffers . gl-delete-framebuffers) - (glBindFramebuffer . gl-bind-framebuffer) - (glFramebufferTexture2D . gl-framebuffer-texture-2d) - (glCheckFramebufferStatus . gl-check-framebuffer-status) - (glGenRenderbuffers . gl-gen-renderbuffers) - (glDeleteRenderbuffers . gl-delete-renderbuffers) - (glBindRenderbuffer . gl-bind-renderbuffer) - (glRenderbufferStorage . gl-renderbuffer-storage) - (glFramebufferRenderbuffer . gl-framebuffer-renderbuffer)) - -(re-export (%glDrawBuffers . gl-draw-buffers)) - - -;;; -;;; Shaders -;;; - -(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") - -(export (glUniform1ui . gl-uniform1ui) - (glUniform1uiv . gl-uniform1uiv)) - -(re-export (%glUseProgram . gl-use-program) - (%glDeleteProgram . gl-delete-program) - (%glDetachShader . gl-detach-shader) - (%glLinkProgram . gl-link-program) - (%glBindAttribLocation . gl-bind-attrib-location) - (%glAttachShader . gl-attach-shader) - (%glGetAttribLocation . gl-get-attrib-location) - (%glGetUniformLocation . gl-get-uniform-location) - (%glCreateProgram . gl-create-program) - (%glGetProgramInfoLog . gl-get-program-info-log) - (%glGetProgramiv . gl-get-programiv) - (%glDeleteProgram . gl-delete-program) - (%glDeleteShader . gl-delete-shader) - (%glGetShaderiv . gl-get-shaderiv) - (%glGetShaderInfoLog . gl-get-shader-info-log) - (%glCompileShader . gl-compile-shader) - (%glShaderSource . gl-shader-source) - (%glCreateShader . gl-create-shader) - (%glGetActiveUniform . gl-get-active-uniform) - (%glGetActiveAttrib . gl-get-active-attrib) - (%glUniform1i . gl-uniform1i) - (%glUniform1iv . gl-uniform1iv) - (%glUniform2i . gl-uniform2i) - (%glUniform3i . gl-uniform3i) - (%glUniform4i . gl-uniform4i) - (%glUniform1f . gl-uniform1f) - (%glUniform1fv . gl-uniform1fv) - (%glUniform2f . gl-uniform2f) - (%glUniform2fv . gl-uniform2fv) - (%glUniform3f . gl-uniform3f) - (%glUniform3fv . gl-uniform3fv) - (%glUniform4f . gl-uniform4f) - (%glUniform4fv . gl-uniform4fv) - (%glUniformMatrix4fv . gl-uniform-matrix4fv) - (%glUniform4f . gl-uniform4f)) - -(re-export (%glPointSize . gl-point-size)) - - -;;; -;;; Context Queries -;;; - -(re-export (%glGetString . gl-get-string) - (%glGetIntegerv . gl-get-integer-v)) - - -;;; -;;; Depth Buffer -;;; - -(re-export (%glDepthFunc . gl-depth-func) - (%glDepthMask . gl-depth-mask) - (%glDepthRange . gl-depth-range)) - - -;;; -;;; Stencil Buffer -;;; - -(re-export (%glStencilMask . gl-stencil-mask) - (%glStencilMaskSeparate . gl-stencil-mask-separate) - (%glStencilFunc . gl-stencil-func) - (%glStencilFuncSeparate . gl-stencil-func-separate) - (%glStencilOp . gl-stencil-op) - (%glStencilOpSeparate . gl-stencil-op-separate)) diff --git a/chickadee/render/gpu.scm b/chickadee/render/gpu.scm deleted file mode 100644 index 8921062..0000000 --- a/chickadee/render/gpu.scm +++ /dev/null @@ -1,211 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render gpu) - #:use-module (chickadee render gl) - #:use-module (gl enums) - #:use-module (oop goops) - #:use-module (srfi srfi-9) - #:use-module (system foreign) - #:export (make-gpu-state - gpu-state-ref - gpu-state-set! - - gpu-finalize - gpu-guard - gpu-reap! - - make-gpu - current-gpu - gpu? - gpu-gl-context - gpu-gl-version - gpu-glsl-version - gpu-max-texture-size - gpu-blend-mode - gpu-depth-test - gpu-stencil-test - gpu-framebuffer - gpu-shader - gpu-texture - gpu-vertex-buffer - gpu-vertex-array - gpu-viewport - set-gpu-blend-mode! - set-gpu-depth-test! - set-gpu-stencil-test! - set-gpu-framebuffer! - set-gpu-shader! - set-gpu-texture! - set-gpu-vertex-buffer! - set-gpu-vertex-array! - set-gpu-viewport!)) - - -;;; -;;; GPU state -;;; - -(define-record-type - (make-gpu-state bind value) - gpu-state? - (bind gpu-state-bind) - (value gpu-state-ref %gpu-state-set!)) - -(define (gpu-state-set! state new-value) - (unless (eq? new-value (gpu-state-ref state)) - ((gpu-state-bind state) new-value) - (%gpu-state-set! state new-value))) - -;;; -;;; GPU finalizers -;;; - -(define-generic gpu-finalize) - -(define *gpu-guardian* (make-guardian)) - -(define (gpu-guard obj) - "Protect OBJ for the garbage collector until OBJ has been deleted -from the GPU's memory." - (*gpu-guardian* obj) - obj) - -(define (gpu-reap!) - "Delete all GPU objects that are no longer being referenced." - (let loop ((obj (*gpu-guardian*))) - (when obj - (gpu-finalize obj) - (loop (*gpu-guardian*))))) - - -;;; -;;; GPU -;;; - -(define-record-type - (%make-gpu gl-context - gl-version - glsl-version - max-texture-size - blend-mode - depth-test - stencil-test - framebuffer - shader - textures - vertex-buffer - vertex-array - viewport) - gpu? - (gl-context gpu-gl-context) - (gl-version gpu-gl-version) - (glsl-version gpu-glsl-version) - (max-texture-size gpu-max-texture-size) - (blend-mode %gpu-blend-mode) - (depth-test %gpu-depth-test) - (stencil-test %gpu-stencil-test) - (framebuffer %gpu-framebuffer) - (shader %gpu-shader) - (textures gpu-textures) - (vertex-buffer %gpu-vertex-buffer) - (vertex-array %gpu-vertex-array) - (viewport %gpu-viewport)) - -(define current-gpu (make-parameter #f)) - -(define (max-texture-size) - (let ((bv (make-s32vector 1))) - (gl-get-integer-v (get-p-name max-texture-size) - (bytevector->pointer bv)) - (s32vector-ref bv 0))) - -(define (make-gpu gl-context) - (define (extract-version attr) - (car (string-split (pointer->string (gl-get-string attr)) #\space))) - (let ((textures (make-vector 32)) - ;; Lazily resolve bindings to avoid circular dependencies. - (blend-module (resolve-interface '(chickadee render blend))) - (depth-module (resolve-interface '(chickadee render depth))) - (stencil-module (resolve-interface '(chickadee render stencil))) - (buffer-module (resolve-interface '(chickadee render buffer))) - (framebuffer-module (resolve-interface '(chickadee render framebuffer))) - (shader-module (resolve-interface '(chickadee render shader))) - (texture-module (resolve-interface '(chickadee render texture))) - (viewport-module (resolve-interface '(chickadee render viewport))) - (gl-version (extract-version (string-name version))) - (glsl-version (extract-version (version-2-0 shading-language-version)))) - ;; Create state for 32 texture units. - (let loop ((i 0)) - (when (< i 32) - (vector-set! textures i - (let ((apply-texture (module-ref texture-module 'apply-texture))) - (make-gpu-state (lambda (texture) - (apply-texture i texture)) - (module-ref texture-module 'null-texture)))) - (loop (+ i 1)))) - (%make-gpu gl-context - gl-version - glsl-version - (max-texture-size) - (make-gpu-state (module-ref blend-module 'apply-blend-mode) - 'replace) - (make-gpu-state (module-ref depth-module 'apply-depth-test) #f) - (make-gpu-state (module-ref stencil-module 'apply-stencil-test) #f) - (make-gpu-state (module-ref framebuffer-module 'apply-framebuffer) - (module-ref framebuffer-module 'null-framebuffer)) - (make-gpu-state (module-ref shader-module 'apply-shader) - (module-ref shader-module 'null-shader)) - textures - (make-gpu-state (module-ref buffer-module 'apply-buffer) - (module-ref buffer-module 'null-buffer)) - (make-gpu-state (module-ref buffer-module 'apply-vertex-array) - (module-ref buffer-module 'null-vertex-array)) - (make-gpu-state (module-ref viewport-module 'apply-viewport) - (module-ref viewport-module 'null-viewport))))) - -(define-syntax-rule (define-gpu-getter name ref) - (define (name gpu) - (gpu-state-ref (ref gpu)))) - -(define-gpu-getter gpu-blend-mode %gpu-blend-mode) -(define-gpu-getter gpu-depth-test %gpu-depth-test) -(define-gpu-getter gpu-stencil-test %gpu-stencil-test) -(define-gpu-getter gpu-framebuffer %gpu-framebuffer) -(define-gpu-getter gpu-shader %gpu-shader) -(define-gpu-getter gpu-vertex-buffer %gpu-vertex-buffer) -(define-gpu-getter gpu-vertex-array %gpu-vertex-array) -(define-gpu-getter gpu-viewport %gpu-viewport) - -(define-syntax-rule (define-gpu-setter name ref) - (define (name gpu x) - (gpu-state-set! (ref gpu) x))) - -(define-gpu-setter set-gpu-blend-mode! %gpu-blend-mode) -(define-gpu-setter set-gpu-depth-test! %gpu-depth-test) -(define-gpu-setter set-gpu-stencil-test! %gpu-stencil-test) -(define-gpu-setter set-gpu-framebuffer! %gpu-framebuffer) -(define-gpu-setter set-gpu-shader! %gpu-shader) -(define-gpu-setter set-gpu-vertex-buffer! %gpu-vertex-buffer) -(define-gpu-setter set-gpu-vertex-array! %gpu-vertex-array) -(define-gpu-setter set-gpu-viewport! %gpu-viewport) - -(define (gpu-texture gpu texture-unit) - (gpu-state-ref (vector-ref (gpu-textures gpu) texture-unit))) - -(define (set-gpu-texture! gpu texture-unit texture) - (gpu-state-set! (vector-ref (gpu-textures gpu) texture-unit) texture)) diff --git a/chickadee/render/model.scm b/chickadee/render/model.scm deleted file mode 100644 index a9133c4..0000000 --- a/chickadee/render/model.scm +++ /dev/null @@ -1,1073 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; 3D Model loading and rendering. -;; -;;; Code: - -(define-module (chickadee render model) - #:use-module (chickadee array-list) - #:use-module (chickadee json) - #:use-module (chickadee math matrix) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render buffer) - #:use-module (chickadee render color) - #:use-module (chickadee render depth) - #:use-module (chickadee render pbr) - #:use-module (chickadee render phong) - #:use-module (chickadee render shader) - #:use-module (chickadee render texture) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (srfi srfi-9) - #:use-module ((srfi srfi-43) #:select (vector-every)) - #:export (scene-node? - scene-node-name - scene-node-mesh - scene-node-matrix - scene-node-children - model? - model-scenes - model-default-scene - draw-model - load-obj - load-gltf)) - - -;;; -;;; Rendering State -;;; - -(define-record-type - (%make-render-state shader renderer world-matrix view-matrix) - render-state? - (shader render-state-shader) - (renderer render-state-renderer) - (world-matrix render-state-world-matrix) - (view-matrix render-state-view-matrix)) - -(define* (make-render-state #:key shader renderer) - (%make-render-state shader renderer - (make-identity-matrix4) - (make-identity-matrix4))) - -(define (render-state-reset! state) - (matrix4-identity! (render-state-world-matrix state)) - (matrix4-identity! (render-state-view-matrix state))) - -(define (render-state-world-matrix-mult! state matrix) - (let ((world (render-state-world-matrix state))) - (matrix4-mult! world world matrix))) - -(define (render-state-view-matrix-mult! state matrix) - (let ((view (render-state-view-matrix state))) - (matrix4-mult! view view matrix))) - - -;;; -;;; Primitive -;;; - -;; A piece of a mesh. Represents a single draw call. -(define-record-type - (make-primitive name vertex-array material) - primitive? - (name primitive-name) - (vertex-array primitive-vertex-array) - (material primitive-material)) - -(define (draw-primitive/phong primitive state) - (gpu-apply/phong (render-state-shader state) - (primitive-vertex-array primitive) - (primitive-material primitive) - (render-state-world-matrix state) - (render-state-view-matrix state))) - -(define (draw-primitive/pbr primitive state) - (gpu-apply/pbr (render-state-shader state) - (primitive-vertex-array primitive) - (primitive-material primitive) - (render-state-world-matrix state) - (render-state-view-matrix state))) - - -;;; -;;; Mesh -;;; - -;; A complete 3D model composed of many primitives. -(define-record-type - (make-mesh name primitives) - mesh? - (name mesh-name) - (primitives mesh-primitives)) - -(define (draw-mesh mesh state) - (let ((render (render-state-renderer state))) - (for-each (lambda (primitive) (render primitive state)) - (mesh-primitives mesh)))) - - -;;; -;;; Scene Node -;;; - -;; A tree of meshes with their own transformation matrices. -(define-record-type - (%make-scene-node name mesh matrix children) - scene-node? - (name scene-node-name) - (mesh scene-node-mesh) - (matrix scene-node-matrix) - (children scene-node-children)) - -(define* (make-scene-node #:key - (name "anonymous") - mesh - (matrix (make-identity-matrix4)) - (children '())) - (%make-scene-node name mesh matrix children)) - -(define (draw-scene-node node state) - ;; TODO: Apply push/pop model matrix stuff. - (for-each (lambda (child) - (draw-scene-node child state)) - (scene-node-children node)) - (let ((mesh (scene-node-mesh node))) - (when mesh - (draw-mesh mesh state)))) - - -;;; -;;; Model -;;; - -;; A collection of scenes and the associated information about *how* -;; to actually render the darn thing. -(define-record-type - (%make-model name scenes default-scene render-state) - model? - (name model-name) - (scenes model-scenes) - (default-scene model-default-scene) - (render-state model-render-state)) - -(define* (make-model #:key name scenes (default-scene (car scenes)) render-state) - (%make-model name scenes default-scene render-state)) - -(define (draw-model model model-matrix view-matrix) - (with-depth-test default-depth-test - (let ((state (model-render-state model))) - (render-state-reset! state) - (render-state-view-matrix-mult! state view-matrix) - (render-state-world-matrix-mult! state model-matrix) - ;; TODO: Support drawing non-default scenes. - (draw-scene-node (model-default-scene model) state)))) - - -;;; -;;; OBJ Format -;;; - -;; Reference documentation: -;; * http://paulbourke.net/dataformats/obj -;; * http://paulbourke.net/dataformats/mtl -(define (load-obj file-name) - (define (scope-file other-file) - (string-append (dirname file-name) "/" other-file)) - (call-with-input-file file-name - (lambda (port) - (let ((vertices (make-array-list)) - (texcoords (make-array-list)) - (normals (make-array-list)) - (faces (make-array-list)) - (face-map (make-hash-table)) - (face-indices-map (make-hash-table)) - (material-map (make-hash-table))) - (define (parse-map-args args) - (define (map-option? str) - (string-prefix? "-" str)) - (let loop ((args args) - (opts '())) - (match args - (() opts) - (((? map-option? opt) arg . rest) - (loop rest - (cons (cons (string->symbol - (substring opt 1)) - arg) - opts))) - ((file-name . rest) - (loop rest (cons (cons 'file-name file-name) opts)))))) - (define (load-mtl mtl-file-name) - (define (scope-file other-file) - (string-append (dirname mtl-file-name) "/" other-file)) - (call-with-input-file mtl-file-name - (lambda (port) - (let loop ((opts '())) - (define (maybe-add-material) - (let ((name (assq-ref opts 'name))) - (when name - (hash-set! material-map - name - (make-phong-material - #:name name - #:ambient (assq-ref opts 'ambient) - #:ambient-map (assq-ref opts 'ambient-map) - #:use-ambient-map - (assq-ref opts 'use-ambient-map?) - #:diffuse (assq-ref opts 'diffuse) - #:diffuse-map (assq-ref opts 'diffuse-map) - #:use-diffuse-map - (assq-ref opts 'use-diffuse-map?) - #:specular (assq-ref opts 'specular) - #:specular-map (assq-ref opts 'specular-map) - #:use-specular-map - (assq-ref opts 'use-specular-map?) - #:shininess (assq-ref opts 'shininess) - #:bump-map (assq-ref opts 'bump-map) - #:use-bump-map - (assq-ref opts 'use-bump-map?)))))) - (match (read-line port) - ((? eof-object?) - (maybe-add-material)) - (line - (match (delete "" (string-split line char-set:whitespace)) - ((or () ("#" . _)) ; ignore comments and blank lines - (loop opts)) - (("d" d) ; ignore dissolve for now - (loop opts)) - (("illum" n) ; ignore illumation model for now - (loop opts)) - (("Ka" r g b) ; ambient factor - (let ((new-ambient (vec3 (string->number r) - (string->number g) - (string->number b)))) - (loop (cons (cons 'ambient new-ambient) opts)))) - (("Ka" r) ; ambient factor - (let ((new-ambient (vec3 (string->number r) - (string->number r) - (string->number r)))) - (loop (cons (cons 'ambient new-ambient) opts)))) - (("Kd" r g b) ; diffuse factor - (let ((new-diffuse (vec3 (string->number r) - (string->number g) - (string->number b)))) - (loop (cons (cons 'diffuse new-diffuse) opts)))) - (("Kd" r) ; diffuse factor - (let ((new-diffuse (vec3 (string->number r) - (string->number r) - (string->number r)))) - (loop (cons (cons 'diffuse new-diffuse) opts)))) - (("Ks" r g b) ; specular factor - (let ((new-specular (vec3 (string->number r) - (string->number g) - (string->number b)))) - (loop (cons (cons 'specular new-specular) opts)))) - (("Ks" r) ; specular factor - (let ((new-specular (vec3 (string->number r) - (string->number r) - (string->number r)))) - (loop (cons (cons 'specular new-specular) opts)))) - (("Ni" i) ; ignore optical density for now - (loop opts)) - (("Ns" s) ; specular exponent (shininess) - ;; Force specular exponent to be a float. - (let ((new-shininess (* (string->number s) 1.0))) - (loop (cons (cons 'shininess new-shininess) opts)))) - (("map_Ka" . args) ; ambient map - (let* ((ambient-opts (parse-map-args args)) - (file (scope-file (assq-ref ambient-opts - 'file-name))) - (texture (load-image file - #:min-filter 'linear - #:mag-filter 'linear))) - (loop (cons* (cons 'ambient-map texture) - (cons 'use-ambient-map? #t) - opts)))) - (("map_Kd" . args) ; diffuse map - (let* ((diffuse-opts (parse-map-args args)) - (file (scope-file (assq-ref diffuse-opts - 'file-name))) - (texture (load-image file - #:min-filter 'linear - #:mag-filter 'linear))) - (loop (cons* (cons 'diffuse-map texture) - (cons 'use-diffuse-map? #t) - opts)))) - (("map_Ks" . args) ; specular map - (let* ((specular-opts (parse-map-args args)) - (file (scope-file (assq-ref specular-opts - 'file-name))) - (texture (load-image file - #:min-filter 'linear - #:mag-filter 'linear))) - (loop (cons* (cons 'specular-map texture) - (cons 'use-specular-map? #t) - opts)))) - (((or "map_Bump" "map_bump" "bump") . args) ; normal map - (let* ((bump-opts (parse-map-args args)) - (file (scope-file (assq-ref bump-opts - 'file-name))) - (texture (load-image file - #:min-filter 'linear - #:mag-filter 'linear))) - (loop (cons* (cons 'bump-map texture) - (cons 'use-bump-map? #t) - opts)))) - (("newmtl" new-name) - ;; Begin new material - (maybe-add-material) - (loop `((name . ,new-name) - (ambient . ,(vec3 0.0 0.0 0.0)) - (ambient-map . ,null-texture) - (use-ambient-map? . #f) - (diffuse . ,(vec3 0.0 0.0 0.0)) - (diffuse-map . ,null-texture) - (use-diffuse-map? . #f) - (specular . ,(vec3 0.0 0.0 0.0)) - (specular-map . ,null-texture) - (use-specular-map? . #f) - (shininess . 1.0) - (bump-map . ,null-texture) - (use-bump-map? . #f)))) - (data - (format (current-error-port) - "warning: ~a:~d: unsupported MTL data: ~s~%" - mtl-file-name - (port-line port) - data) - (loop opts))))))))) - (define (parse-error message args) - (apply error (format #f "OBJ parser error @ ~a:~d: ~a" - file-name - (port-line port) - message) - args)) - (define (parse-vertex args) - (array-list-push! vertices - (match args - ((x y z) - (vec3 (string->number x) - (string->number y) - (string->number z))) - ;; TODO: handle w properly - ((x y z w) - (vec3 (string->number x) - (string->number y) - (string->number z))) - (_ - (parse-error "wrong number of vertex arguments" args))))) - (define (parse-texcoord args) - ;; TODO: Handle w properly. - (array-list-push! texcoords - (match args - ((u) - (vec2 (string->number u) 0.0)) - ((u v) - ;; OBJ texture coordinates use the - ;; top-left of the image as the origin, - ;; but OpenGL uses the bottom-left, so - ;; all V values must be inverted. - (vec2 (string->number u) - (- 1.0 (string->number v)))) - ((u v w) - (vec2 (string->number u) - (- 1.0 (string->number v)))) - (_ - (parse-error "wrong number of texcoord arguments" args))))) - (define (parse-normal args) - (array-list-push! normals - (match args - ((i j k) - (vec3 (string->number i) - (string->number j) - (string->number k))) - (_ - (parse-error "wrong number of normal arguments" args))))) - (define (parse-face-index arg) - (- (string->number arg) 1)) - (define (parse-face-element arg) - (match (string-split arg #\/) - ((v) - (list (parse-face-index v) #f #f)) - ((v t) - (list (parse-face-index v) - (parse-face-index t) - #f)) - ((v "" n) - (list (parse-face-index v) - #f - (parse-face-index n))) - ((v t n) - (list (parse-face-index v) - (parse-face-index t) - (parse-face-index n))) - (_ - (parse-error "invalid face syntax" (list arg))))) - (define (indices-for-material material) - (or (hash-ref face-indices-map material) - (let ((new-indices (make-array-list))) - (hash-set! face-indices-map material new-indices) - new-indices))) - (define (deduplicate-face-element e) - ;; Faces are often redundant, so we deduplicate in order to - ;; make the VBOs we build later as small as possible. - (or (hash-ref face-map e) - (let ((i (array-list-size faces))) - (array-list-push! faces (parse-face-element e)) - (hash-set! face-map e i) - i))) - (define (push-face material e) - (array-list-push! (indices-for-material material) - (deduplicate-face-element e))) - (define (parse-face args material) - (match args - ;; A single triangle. Ah, life is so simple... - ((a b c) - (push-face material a) - (push-face material b) - (push-face material c)) - ;; A quadrilateral. Needs to be split into 2 triangles. - ;; - ;; d-------c - ;; | /| - ;; | / | - ;; | / | - ;; |/ | - ;; a-------b - ((a b c d) - ;; triangle 1: a b c - (push-face material a) - (push-face material b) - (push-face material c) - ;; triangle 2: a c d - (push-face material a) - (push-face material c) - (push-face material d)) - ;; 3 or more triangles. Interpret as a strip of triangles - ;; moving from right to left (because counter-clockwise - ;; winding) like this: - ;; - ;; h-------f-------d-------c - ;; | /| /| /| - ;; | / | / | / | - ;; | / | / | / | - ;; |/ |/ |/ | - ;; g-------e-------a-------b - ;; - ;; ... and so on for however many face elements there are. - ;; Every other triangle is flipped over, hence the 'flip?' - ;; flag in the loop below. - ((a b . rest) - (let loop ((a a) - (b b) - (args rest) - (flip? #f)) - (match args - (() #t) - ((c . rest) - (push-face material a) - (push-face material b) - (push-face material c) - (if flip? - (loop c a rest #f) - (loop a c rest #t)))))) - (_ - (parse-error "invalid face" args)))) - ;; Build a vertex array for all the faces of a single - ;; material. - ;; - ;; XXX: We assume there is normal and texture data. Models - ;; that don't have one or both will still use up as much - ;; memory as if they did. Maybe that's just fine? Dunno. - (define (make-primitive-for-material material) - (let* ((face-indices (indices-for-material material)) - (vertex-count (array-list-size faces)) - (index-count (array-list-size face-indices)) - (stride 8) - (mesh-data (make-f32vector (* vertex-count stride))) - (mesh-indices (make-u32vector index-count)) - (null-texcoord (vec2 0.0 0.0)) - (null-normal (vec3 0.0 0.0 0.0))) - ;; The mesh vertex data is packed like so: - ;; - 3 floats for vertex - ;; - 2 floats for texture coordinate - ;; - 3 floats for normal - ;; - repeat for each face - (let loop ((i 0)) - (when (< i vertex-count) - (let ((offset (* i stride))) - (match (array-list-ref faces i) - ((vert-index tex-index norm-index) - ;; Vertex - (let ((v (array-list-ref vertices vert-index))) - (f32vector-set! mesh-data offset (vec3-x v)) - (f32vector-set! mesh-data (+ offset 1) (vec3-y v)) - (f32vector-set! mesh-data (+ offset 2) (vec3-z v))) - ;; Texture coordinate - (let ((t (if tex-index - (array-list-ref texcoords tex-index) - null-texcoord))) - (f32vector-set! mesh-data (+ offset 3) (vec2-x t)) - (f32vector-set! mesh-data (+ offset 4) (vec2-y t))) - ;; Normal - (let ((n (if norm-index - (array-list-ref normals norm-index) - null-normal))) - (f32vector-set! mesh-data (+ offset 5) (vec3-x n)) - (f32vector-set! mesh-data (+ offset 6) (vec3-y n)) - (f32vector-set! mesh-data (+ offset 7) (vec3-z n)))))) - (loop (+ i 1)))) - ;; Pack indices. - (let loop ((i 0)) - (when (< i index-count) - (u32vector-set! mesh-indices i (array-list-ref face-indices i)) - (loop (+ i 1)))) - ;; Construct vertex array. - ;; TODO: Add names to buffers and views. - (let* ((index-buffer (make-buffer mesh-indices #:target 'index)) - (index-view (make-buffer-view #:type 'scalar - #:component-type 'unsigned-int - #:buffer index-buffer)) - (data-buffer (make-buffer mesh-data #:stride (* stride 4))) - (vertex-view (make-buffer-view #:type 'vec3 - #:component-type 'float - #:buffer data-buffer)) - (texcoord-view (make-buffer-view #:type 'vec2 - #:component-type 'float - #:buffer data-buffer - #:offset 12)) - (normal-view (make-buffer-view #:type 'vec3 - #:component-type 'float - #:buffer data-buffer - #:offset 20))) - (make-primitive material - (make-vertex-array - #:indices index-view - #:attributes `((0 . ,vertex-view) - (1 . ,texcoord-view) - (2 . ,normal-view))) - (or (hash-ref material-map material) - (hash-ref material-map "default")))))) - ;; Register default material - (hash-set! material-map "default" default-phong-material) - ;; Parse file. - (let loop ((material "default")) - (match (read-line port) - ((? eof-object?) - #f) - (line - (match (delete "" (string-split line char-set:whitespace)) - ((or () ("#" . _)) ; ignore comments and blank lines - (loop material)) - (("f" . args) - (parse-face args material) - (loop material)) - (("g" . _) ; ignore group name for now - (loop material)) - (("mtllib" mtl-file-name) - (load-mtl (scope-file mtl-file-name)) - (loop material)) - (("o" . _) ;ignore object name for now - (loop material)) - (("s" . _) ; ignore smoothing group for now - (loop material)) - (("usemtl" new-material) - (loop new-material)) - (("v" . args) - (parse-vertex args) - (loop material)) - (("vn" . args) - (parse-normal args) - (loop material)) - (("vt" . args) - (parse-texcoord args) - (loop material)) - (data - (format (current-error-port) - "warning: ~a:~d: unsupported OBJ data: ~s~%" - file-name - (port-line port) - data) - (loop material)))))) - ;; Construct a mesh by composing primitives. One primitive - ;; per material. - (let* ((model-name (basename file-name)) - (mesh (make-mesh model-name - (hash-fold (lambda (material indices memo) - ;; It's possible that a material has - ;; no data associated with it, so we - ;; drop those. - (if (array-list-empty? indices) - memo - (cons (make-primitive-for-material material) - memo))) - '() - face-indices-map))) - (scene (make-scene-node #:name model-name - #:mesh mesh))) - (make-model #:name model-name - #:scenes (list scene) - #:render-state - (make-render-state #:shader (load-phong-shader) - #:renderer draw-primitive/phong))))))) - - -;;; -;;; glTF 2.0 -;;; - -(define (load-gltf file-name) - (define (object-ref obj key) - (let ((value (assoc-ref obj key))) - (unless (pair? value) - (error "expected object for key" key value)) - value)) - (define (object-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (unless (or (not value) (pair? value)) - (error "expected object for optional key" key value)) - value)) - (define (array-ref obj key) - (let ((value (assoc-ref obj key))) - (unless (vector? value) - (error "expected array for key" key value)) - value)) - (define (array-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (unless (or (not value) (vector? value)) - (error "expected array for optional key" key value)) - value)) - (define (string-ref obj key) - (let ((value (assoc-ref obj key))) - (unless (string? value) - (error "expected string for key" key value)) - value)) - (define (string-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (unless (or (not value) (string? value)) - (error "expected string for optional key" key value)) - value)) - (define (number-ref obj key) - (let ((value (assoc-ref obj key))) - (unless (number? value) - (error "expected number for key" key value)) - value)) - (define (number-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (unless (or (not value) (number? value)) - (error "expected number for key" key value)) - value)) - (define (boolean-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (unless (boolean? value) - (error "expected boolean for key" key value)) - value)) - (define (number-array-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (unless (or (not value) - (and (vector? value) (vector-every number? value))) - (error "expected numeric array for key" key value)) - value)) - (define (matrix-ref/optional obj key) - (let ((value (assoc-ref obj key))) - (cond - ((not value) #f) - ((and (vector? value) - (= (vector-length value) 16) - (vector-every number? value)) - ;; glTF matrices are in column-major order. - (make-matrix4 (vector-ref value 0) - (vector-ref value 4) - (vector-ref value 8) - (vector-ref value 12) - (vector-ref value 1) - (vector-ref value 5) - (vector-ref value 9) - (vector-ref value 13) - (vector-ref value 2) - (vector-ref value 6) - (vector-ref value 10) - (vector-ref value 14) - (vector-ref value 3) - (vector-ref value 7) - (vector-ref value 11) - (vector-ref value 15))) - (else - (error "expected 4x4 matrix for key" key value))))) - (define (assert-color v) - (if (and (= (vector-length v) 4) - (vector-every (lambda (x) (and (>= x 0.0) (<= x 1.0))) v)) - (make-color (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3)) - (error "not a color vector" v))) - (define scope-file - (let ((gltf-root (dirname - (if (absolute-file-name? file-name) - file-name - (string-append (getcwd) "/" file-name))))) - (lambda (other-file) - (if (absolute-file-name? other-file) - other-file - (string-append gltf-root "/" other-file))))) - (define (parse-buffer obj) - ;; TODO: support base64 encoded buffer data as uri - ;; TODO: support glb-stored buffers: - ;; https://github.com/KhronosGroup/glTF/blob/master/specification/2.0/README.md#glb-stored-buffer - (let* ((uri (string-ref/optional obj "uri")) - (length (number-ref obj "byteLength")) - (name (or (string-ref/optional obj "name") "anonymous")) - (extensions (object-ref/optional obj "extensions")) - (extras (assoc-ref obj "extras")) - (data (if uri - (call-with-input-file (scope-file uri) - (lambda (port) - (get-bytevector-n port length))) - (make-bytevector length)))) - data)) - (define (parse-buffer-view obj buffers) - (let ((name (string-ref/optional obj "name")) - (data (vector-ref buffers (number-ref obj "buffer"))) - (offset (or (number-ref/optional obj "byteOffset") 0)) - (length (number-ref obj "byteLength")) - (stride (number-ref/optional obj "byteStride")) - (target (match (or (number-ref/optional obj "target") 34962) - (34962 'vertex) - (34963 'index))) - (extensions (object-ref/optional obj "extensions")) - (extras (assoc-ref obj "extras"))) - (make-buffer data - #:name name - #:offset offset - #:length length - #:stride stride - #:target target))) - (define (parse-accessor obj buffer-views) - (define (type-length type) - (match type - ('scalar 1) - ('vec2 2) - ('vec3 3) - ('vec4 4) - ('mat2 4) - ('mat3 9) - ('mat4 16))) - (let ((name (or (string-ref/optional obj "name") "anonymous")) - (view (match (number-ref/optional obj "bufferView") - (#f #f) - (n (vector-ref buffer-views n)))) - (offset (or (number-ref/optional obj "byteOffset") 0)) - (component-type (match (number-ref obj "componentType") - (5120 'byte) - (5121 'unsigned-byte) - (5122 'short) - (5123 'unsigned-short) - (5125 'unsigned-int) - (5126 'float))) - (normalized? (boolean-ref/optional obj "normalized")) - (length (number-ref obj "count")) - (type (match (string-ref obj "type") - ("SCALAR" 'scalar) - ("VEC2" 'vec2) - ("VEC3" 'vec3) - ("VEC4" 'vec4) - ("MAT2" 'mat2) - ("MAT3" 'mat3) - ("MAT4" 'mat4))) - (max (number-array-ref/optional obj "max")) - (min (number-array-ref/optional obj "min")) - (sparse (object-ref/optional obj "sparse")) - (extensions (object-ref/optional obj "extensions")) - (extras (assoc-ref obj "extras"))) - (unless (>= length 1) - (error "count must be greater than 0" length)) - (when (and (vector? max) - (not (= (vector-length max) (type-length type)))) - (error "not enough elements for max" max type)) - (when (and (vector? min) - (not (= (vector-length min) (type-length type)))) - (error "not enough elements for min" min type)) - (make-buffer-view #:name name - #:buffer view - #:offset offset - #:component-type component-type - #:normalized? normalized? - #:length length - #:type type - #:max max - #:min min - #:sparse sparse))) - (define (texture-filter n) - (match n - (9728 'nearest) - ((or #f 9729) 'linear) - ;; TODO: Support mip-mapping - ;; (9984 'nearest-mipmap-nearest) - ;; (9985 'linear-mipmap-nearest) - ;; (9986 'nearest-mipmap-linear) - ;; (9987 'linear-mipmap-linear) - (_ 'linear))) - (define (texture-wrap n) - (match n - (10496 'clamp) - ((or #f 10497) 'repeat) - (33069 'clamp-to-border) - (33071 'clamp-to-edge))) - (define (parse-texture obj images samplers) - (let ((image (vector-ref images (number-ref obj "source"))) - (sampler - (vector-ref samplers (or (number-ref/optional obj "sampler") 0)))) - (load-image (scope-file (string-ref image "uri")) - #:min-filter (texture-filter - (number-ref/optional sampler "minFilter")) - #:mag-filter (texture-filter - (number-ref/optional sampler "magFilter")) - #:wrap-s (texture-wrap (number-ref/optional sampler "wrapS")) - #:wrap-t (texture-wrap (number-ref/optional sampler "wrapT"))))) - (define (parse-material obj textures) - (let* ((name (or (string-ref/optional obj "name") "anonymous")) - (pbrmr (or (object-ref/optional obj "pbrMetallicRoughness") '())) - (base-color-factor - (let ((v (or (number-array-ref/optional pbrmr "baseColorFactor") - #(1.0 1.0 1.0 1.0)))) - (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) - (base-color-texture - (match (object-ref/optional pbrmr "baseColorTexture") - (#f null-texture) - (obj - (vector-ref textures (number-ref obj "index"))))) - (metallic-factor - (or (number-ref/optional pbrmr "metallicFactor") - 1.0)) - (roughness-factor - (or (number-ref/optional pbrmr "roughnessFactor") - 1.0)) - (metallic-roughness-texture - (match (object-ref/optional pbrmr "metallicRoughnessTexture") - (#f null-texture) - (obj - (vector-ref textures (number-ref obj "index"))))) - (normal-factor - (let ((v (or (array-ref/optional obj "normalFactor") - #(1.0 1.0 1.0)))) - (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) - (normal-texture - (match (object-ref/optional obj "normalTexture") - (#f null-texture) - (obj (vector-ref textures (number-ref obj "index"))))) - (occlusion-factor - (let ((v (or (array-ref/optional obj "occlusionFactor") - #(1.0 1.0 1.0)))) - (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) - (occlusion-texture - (match (object-ref/optional obj "occlusionTexture") - (#f null-texture) - (obj (vector-ref textures (number-ref obj "index"))))) - (emissive-factor - (let ((v (or (array-ref/optional obj "emissiveFactor") - #(1.0 1.0 1.0)))) - (vec3 (vector-ref v 0) (vector-ref v 1) (vector-ref v 2)))) - (emissive-texture - (match (object-ref/optional obj "emissiveTexture") - (#f null-texture) - (obj (vector-ref textures (number-ref obj "index"))))) - (alpha-mode (match (or (string-ref/optional obj "alphaMode") - "BLEND") - ("OPAQUE" 'opaque) - ("MASK" 'mask) - ("BLEND" 'blend))) - (alpha-cutoff (or (number-ref/optional obj "alphaCutoff") 0.5)) - (double-sided? (boolean-ref/optional obj "doubleSided")) - (extensions (object-ref/optional obj "extensions")) - (extras (assoc-ref obj "extras"))) - (make-pbr-material #:name name - #:base-color-factor base-color-factor - #:base-color-texture base-color-texture - #:metallic-factor metallic-factor - #:roughness-factor roughness-factor - #:metallic-roughness-texture metallic-roughness-texture - #:normal-factor normal-factor - #:normal-texture normal-texture - #:occlusion-factor occlusion-factor - #:occlusion-texture occlusion-texture - #:emissive-factor emissive-factor - #:emissive-texture emissive-texture - #:alpha-mode alpha-mode - #:alpha-cutoff alpha-cutoff - #:double-sided? double-sided?))) - (define (attribute-name->index name) - (let ((shader (load-pbr-shader))) - (match name - ("POSITION" - (attribute-location - (hash-ref (shader-attributes shader) "position"))) - ("NORMAL" 1) - ("TANGENT" 2) - ("TEXCOORD_0" - (attribute-location - (hash-ref (shader-attributes shader) "texcoord0"))) - ("TEXCOORD_1" 4) - ("COLOR_0" 5) - ("JOINTS_0" 6) - ("WEIGHTS_0" 7)))) - (define (parse-primitive obj materials accessors) - (let ((attributes (map (match-lambda - ((name . n) - (cons (attribute-name->index name) - (vector-ref accessors n)))) - (object-ref obj "attributes"))) - (indices (match (number-ref/optional obj "indices") - (#f #f) - (n (vector-ref accessors n)))) - ;; TODO: Set a default material when none is given. - (material (match (number-ref/optional obj "material") - (#f #f) - (n (vector-ref materials n)))) - (mode (match (or (number-ref/optional obj "mode") 4) - (0 'points) - (1 'lines) - (2 'line-loop) - (3 'line-strip) - (4 'triangles) - (5 'triangle-strip) - (6 'triangle-fan))) - ;; TODO: Support morph targets. - (targets #f)) - (make-primitive "primitive" - (make-vertex-array #:indices indices - #:attributes attributes - #:mode mode) - material))) - (define (parse-mesh obj materials accessors) - (let ((name (or (string-ref/optional obj "name") "anonymous")) - (primitives - (map (lambda (obj) - (parse-primitive obj materials accessors)) - (vector->list (array-ref obj "primitives")))) - (weights (number-array-ref/optional obj "weights"))) - ;; TODO: Support weights. - (make-mesh name primitives))) - (define (parse-node obj parse-child meshes) - ;; TODO: Parse all fields of nodes. - (let ((name (or (string-ref/optional obj "name") "anonymous")) - ;; TODO: Parse camera. - (camera #f) - ;; TODO: Parse skin. - (skin #f) - (matrix (or (matrix-ref/optional obj "matrix") - (make-identity-matrix4))) - (mesh (match (number-ref/optional obj "mesh") - (#f #f) - (n (vector-ref meshes n)))) - ;; TODO: Parse rotation, scale, translation - (rotation #f) - (scale #f) - (translation #f) - ;; TODO: Parse weights. - (weights #f) - (children (map parse-child - (vector->list - (or (array-ref/optional obj "children") - #()))))) - (make-scene-node #:name name - #:children children - #:matrix matrix - #:mesh mesh))) - (define (parse-nodes array meshes) - (define nodes (make-vector (vector-length array) #f)) - (define (parse-node* i) - (let ((node (vector-ref nodes i))) - (or node - (let ((node (parse-node (vector-ref array i) - parse-node* - meshes))) - (vector-set! nodes i node) - node)))) - (let loop ((i 0)) - (when (< i (vector-length array)) - (parse-node* i) - (loop (+ i 1)))) - nodes) - (define (parse-scene obj nodes) - (let ((name (or (string-ref/optional obj "name") "anonymous")) - (children - (map (lambda (i) (vector-ref nodes i)) - (vector->list - (or (number-array-ref/optional obj "nodes") - #()))))) - (make-scene-node #:name name #:children children))) - (define (vector-map proc v) - (let ((new-v (make-vector (vector-length v)))) - (let loop ((i 0)) - (when (< i (vector-length v)) - (vector-set! new-v i (proc (vector-ref v i))) - (loop (+ i 1)))) - new-v)) - (call-with-input-file file-name - (lambda (port) - (let* ((tree (read-json port)) - (asset (object-ref tree "asset")) - (version (string-ref asset "version")) - (copyright (string-ref/optional asset "copyright")) - (generator (string-ref/optional asset "generator")) - (minimum-version (string-ref/optional asset "minVersion")) - (extensions (object-ref/optional asset "extensions")) - ;; TODO: Figure out how to parse extras in a user-defined way - (extras (assoc-ref asset "extras")) - (buffers (vector-map parse-buffer - (or (assoc-ref tree "buffers") #()))) - (buffer-views (vector-map (lambda (obj) - (parse-buffer-view obj buffers)) - (or (assoc-ref tree "bufferViews") #()))) - (accessors (vector-map (lambda (obj) - (parse-accessor obj buffer-views)) - (or (assoc-ref tree "accessors") #()))) - (images (or (assoc-ref tree "images") #())) - (samplers (or (assoc-ref tree "samplers") #(()))) - (textures (vector-map (lambda (obj) - (parse-texture obj images samplers)) - (or (assoc-ref tree "textures") #()))) - (materials (vector-map (lambda (obj) - (parse-material obj textures)) - (or (assoc-ref tree "materials") #()))) - (meshes (vector-map (lambda (obj) - (parse-mesh obj materials accessors)) - (or (assoc-ref tree "meshes") #()))) - (nodes (parse-nodes (or (assoc-ref tree "nodes") #()) meshes)) - (scenes (map (lambda (obj) - (parse-scene obj nodes)) - (vector->list - (or (assoc-ref tree "scenes") #())))) - (default-scene (list-ref scenes - (or (number-ref/optional tree "scene") - 0)))) - (unless (string=? version "2.0") - (error "unsupported glTF version" version)) - (make-model #:name (basename file-name) - #:scenes (list default-scene) - #:render-state - (make-render-state #:shader (load-pbr-shader) - #:renderer draw-primitive/pbr)))))) diff --git a/chickadee/render/particles.scm b/chickadee/render/particles.scm deleted file mode 100644 index c81209a..0000000 --- a/chickadee/render/particles.scm +++ /dev/null @@ -1,490 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2018 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render particles) - #: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 render) - #:use-module (chickadee render buffer) - #:use-module (chickadee render color) - #:use-module (chickadee render shader) - #:use-module (chickadee render texture) - #:export (make-particle-emitter - particle-emitter? - particle-emitter-spawn-area - particle-emitter-rate - particle-emitter-life - particle-emitter-done? - make-particles - particles? - particles-capacity - particles-size - particles-texture - particles-blend-mode - particles-color - particles-spawn-area - add-particle-emitter - remove-particle-emitter - update-particles - draw-particles* - draw-particles)) - -(define-record-type - (%make-particle-emitter spawn-area rate life) - particle-emitter? - (spawn-area particle-emitter-spawn-area) - (rate particle-emitter-rate) - (life particle-emitter-life set-particle-emitter-life!)) - -(define* (make-particle-emitter spawn-area rate #:optional duration) - "Return a new particle emitter that spawns RATE particles per frame -within SPAWN-AREA (a rectangle or 2D vector) for DURATION frames. If -DURATION is not specified, the emitter will spawn particles -indefinitely." - (%make-particle-emitter spawn-area rate duration)) - -(define (update-particle-emitter emitter) - "Advance the lifecycle of EMITTER." - (let ((life (particle-emitter-life emitter))) - (when life - (set-particle-emitter-life! emitter (- life 1))))) - -(define (particle-emitter-done? emitter) - "Return #t if EMITTER has finished emitting particles." - (let ((life (particle-emitter-life emitter))) - (and life (<= life 0)))) - -(define-record-type - (%make-particles capacity size bv buffer shader vertex-array - texture animation-rows animation-columns - speed-range acceleration-range direction-range - blend-mode start-color end-color lifetime - sort emitters) - particles? - (capacity particles-capacity) - (size particles-size set-particles-size!) - (bv particles-bv) - (buffer particles-buffer) - (shader particles-shader) - (vertex-array particles-vertex-array) - (texture particles-texture set-particles-texture!) - (animation-rows particles-animation-rows) - (animation-columns particles-animation-columns) - (speed-range particles-speed-range set-particles-speed-range!) - (acceleration-range particles-acceleration-range - set-particles-acceleration-range!) - (direction-range particles-direction-range set-particles-direction-range!) - (blend-mode particles-blend-mode set-particles-blend-mode!) - (start-color particles-start-color set-particles-start-color!) - (end-color particles-end-color set-particles-end-color!) - (lifetime particles-lifetime set-particles-lifetime!) - (sort particles-sort set-particles-sort!) - (emitters particles-emitters set-particles-emitters!)) - -(define (add-particle-emitter particles emitter) - "Add EMITTER to PARTICLES." - (set-particles-emitters! particles - (cons emitter (particles-emitters particles)))) - -(define (remove-particle-emitter particles emitter) - "Remove EMITTER from PARTICLES." - (set-particles-emitters! particles - (delete emitter (particles-emitters particles)))) - -(define (make-particles-shader) - (strings->shader - " -#ifdef GLSL330 -layout (location = 0) in vec2 position; -layout (location = 1) in vec2 tex; -layout (location = 2) in vec2 offset; -layout (location = 3) in float life; -#elif defined(GLSL130) -in vec2 position; -in vec2 tex; -in vec2 offset; -in float life; -#elif defined(GLSL120) -attribute vec2 position; -attribute vec2 tex; -attribute vec2 offset; -attribute float life; -#endif -#ifdef GLSL120 -varying vec2 fragTex; -varying float t; -#else -out vec2 fragTex; -out float t; -#endif -uniform mat4 mvp; -uniform int lifetime; -uniform int animationRows; -uniform int animationColumns; - -void main(void) { - t = life / lifetime; - int numTiles = animationRows * animationColumns; - int tile = int(numTiles * (1.0 - t)); - float tx = float(tile % animationColumns) / animationColumns; - float ty = float(tile / animationColumns) / animationRows; - 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); -} -" - " -#ifdef GLSL120 -attribute vec2 fragTex; -attribute float t; -#else -in vec2 fragTex; -in float t; -#endif -#ifdef GLSL330 -out vec4 fragColor; -#endif -uniform sampler2D color_texture; -uniform vec4 startColor; -uniform vec4 endColor; - -void main (void) { -#ifdef GLSL330 - fragColor = mix(endColor, startColor, t) * texture(color_texture, fragTex); -#elif ifdef GLSL130 - gl_FragColor = mix(endColor, startColor, t) * texture2D(color_texture, fragTex); -#endif -} -")) - -(define (make-particles-vertex-array capacity width height texture buffer) - (let* ((indices (make-buffer-view #:type 'scalar - #:component-type 'unsigned-int - #:divisor 0 - #:buffer (make-buffer - (u32vector 0 3 2 0 2 1) - #:target 'index))) - (verts (make-buffer-view #:type 'vec2 - #:component-type 'float - #:divisor 0 - #:buffer (make-buffer - ;; TODO: use the texture - ;; size in pixels. - (let ((hw (/ width 2.0)) - (hh (/ height 2.0))) - (f32vector (- hw) (- hh) - hw (- hh) - hw hh - (- hw) hh)) - #:target 'vertex))) - (tex (make-buffer-view #:type 'vec2 - #:component-type 'float - #:divisor 0 - #:buffer (make-buffer - (let ((tex (texture-gl-tex-rect - texture))) - (f32vector 0 0 - 1 0 - 1 1 - 0 1)) - #:target 'vertex))) - (pos (make-buffer-view #:name "particle position buffer" - #:buffer buffer - #:type 'vec2 - #:component-type 'float - #:length capacity - #:divisor 1)) - (life (make-buffer-view #:name "particle life remaining buffer" - #:buffer buffer - #:type 'scalar - #:component-type 'int - #:offset 24 - #:length capacity - #:divisor 1))) - (make-vertex-array #:indices indices - #:attributes `((0 . ,verts) - (1 . ,tex) - (2 . ,pos) - (3 . ,life))))) - -(define* (make-particles capacity #:key - (blend-mode 'alpha) - (start-color white) - (end-color (make-color 0.0 0.0 0.0 0.0)) - (texture null-texture) - (animation-rows 1) - (animation-columns 1) - (width (if (texture-null? texture) - 8.0 - (inexact->exact - (floor - (/ (texture-width texture) - animation-columns))))) - (height (if (texture-null? texture) - 8.0 - (inexact->exact - (floor - (/ (texture-height texture) - animation-rows))))) - (speed-range (vec2 0.1 1.0)) - (acceleration-range (vec2 0.0 0.1)) - (direction-range (vec2 0.0 (* 2 pi))) - (lifetime 30) - sort) - "Return a new particle system that may contain up to CAPACITY -particles. Achieving the desired particle effect involves tweaking -the following keyword arguments as needed: - -- BLEND-MODE: Pixel blending mode. 'alpha' by default. - -- START-COLOR: The tint color of the particle at the beginning of its -life. White by default. - -- END-COLOR: The tint color of the particle at the end of of its life. -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. - -- ANIMATION-ROWS: How many animation frame rows there are in the -texture. Default is 1. - -- ANIMATION-COLUMNS: How many animation frame columns there are in the -texture. Default is 1. - -- WIDTH: The width of each particle. By default, the width of an -animation frame (in pixels) is used. - -- HEIGHT: The height of each particle. By default, the height of an -animation frame (in pixels) is used. - -- SPEED-RANGE: A 2D vector containing the min and max particle speed. -Each particle will have a speed chosen at random from this range. By -default, speed ranges from 0.1 to 1.0. - -- ACCELERATION-RANGE: A 2D vector containing the min and max particle -acceleration. Each particle will have an acceleration chosen at -random from this range. By default, acceleration ranges from 0.0 to -0.1. - -- DIRECTION-RANGE: A 2D vector containing the min and max particle -direction as an angle in radians. Each particle will have a direction -chosen at random from this range. By default, the range covers all -possible angles. - -- LIFETIME: How long each particle lives, measured in updates. 30 by -default. - -- SORT: 'youngest' if youngest particle should be drawn last or -'oldest' for the reverse. By default, no sorting is applied at all." - (let* ((stride (+ (* 4 2) ; position - 2x f32 - (* 4 2) ; velocity - 2x f32 - (* 4 2) ; acceleration - 2x f32 - 4)) ; life remaining - 1x s32 - (buffer (make-buffer #f - #:name "packed particle data" - ;; One extra element to use as - ;; swap space for sorting - ;; particles. - #:length (* stride capacity) - #:stride stride - #:usage 'stream))) - (%make-particles capacity - 0 - ;; 1 extra element as swap space for sorting. - (make-bytevector (* (+ capacity 1) stride)) - buffer - (make-particles-shader) - (make-particles-vertex-array capacity - width - height - texture - buffer) - texture - animation-rows - animation-columns - speed-range - acceleration-range - direction-range - blend-mode - start-color - end-color - lifetime - sort - '()))) - -(define (update-particles particles) - "Advance the simulation of PARTICLES." - (let* ((buffer (particles-buffer particles)) - (va (particles-vertex-array particles)) - (pos (assq-ref (vertex-array-attributes va) 2)) - (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 (buffer-stride buffer)) - (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-mapped-buffer buffer - (bytevector-copy! bv 0 (buffer-data buffer) 0 (* (particles-size particles) stride)))))) - -(define draw-particles* - (let ((mvp (make-null-matrix4))) - (lambda (particles matrix) - "Render PARTICLES with MATRIX applied." - (let ((size (particles-size particles)) - (va (particles-vertex-array particles))) - (with-blend-mode (particles-blend-mode particles) - (with-texture 0 (particles-texture particles) - (gpu-apply/instanced (particles-shader particles) - va - size - #: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)))))))) - -(define (draw-particles particles) - "Render PARTICLES." - (draw-particles* particles #f)) diff --git a/chickadee/render/pbr.scm b/chickadee/render/pbr.scm deleted file mode 100644 index 167334e..0000000 --- a/chickadee/render/pbr.scm +++ /dev/null @@ -1,150 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Physically based lighting model. -;; -;;; Code: - -(define-module (chickadee render pbr) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render color) - #:use-module (chickadee render shader) - #:use-module (chickadee render texture) - #:use-module (srfi srfi-9) - #:export (make-pbr-material - pbr-material? - pbr-material-name - pbr-material-base-color-factor - pbr-material-base-color-texture - pbr-material-metallic-factor - pbr-material-roughness-factor - pbr-material-metallic-roughness-texture - pbr-material-normal-factor - pbr-material-normal-texture - pbr-material-occlusion-facgor - pbr-material-occlusion-texture - pbr-material-emissive-factor - pbr-material-emissive-texture - pbr-material-alpha-mode - pbr-material-alpha-cutoff - pbr-material-double-sided? - default-pbr-material - load-pbr-shader - gpu-apply/pbr)) - -(define-shader-type - make-pbr-material - pbr-material? - (local-field name pbr-material-name) - (float-vec3 base-color-factor pbr-material-base-color-factor) - (local-field base-color-texture pbr-material-base-color-texture) - (float metallic-factor pbr-material-metallic-factor) - (float roughness-factor pbr-material-roughness-factor) - (local-field metallic-roughness-texture pbr-material-metallic-roughness-texture) - (float-vec3 normal-factor pbr-material-normal-factor) - (local-field normal-texture pbr-material-normal-texture) - (float-vec3 occlusion-factor pbr-material-occlusion-factor) - (local-field occlusion-texture pbr-material-occlusion-texture) - (float-vec3 emissive-factor pbr-material-emissive-factor) - (local-field emissive-texture pbr-material-emissive-texture) - (local-field alpha-mode pbr-material-alpha-mode) - (float alpha-cutoff pbr-material-alpha-cutoff) - (bool double-sided? pbr-material-double-sided?)) - -(define default-pbr-material - (make-pbr-material #:name "default" - #:base-color-factor #v(1.0 1.0 1.0) - #:base-color-texture null-texture - #:metallic-factor 1.0 - #:roughness-factor 1.0 - #:metallic-roughness-texture null-texture - #:normal-factor #v(1.0 1.0 1.0) - #:normal-texture null-texture - #:occlusion-factor #v(1.0 1.0 1.0) - #:occlusion-texture null-texture - #:emissive-factor #v(1.0 1.0 1.0) - #:emissive-texture null-texture - #:alpha-mode 'opaque - #:alpha-cutoff 0.5 - #:double-sided? #f)) - -;; TODO: Actually implement PBR. For now it's just the minimal amount -;; of code needed to render the base texture of a mesh. -(define pbr-shader - (delay - (strings->shader - " -#ifdef GLSL330 -layout (location = 0) in vec3 position; -layout (location = 1) in vec2 texcoord0; -#elif defined(GLSL130) -in vec3 position; -in vec2 texcoord0; -#elif defined(GLSL120) -attribute vec3 position; -attribute vec2 texcoord0; -#endif -#ifdef GLSL120 -varying vec2 fragTex; -#else -out vec2 fragTex; -#endif -uniform mat4 model; -uniform mat4 view; -uniform mat4 projection; - -void main(void) { - fragTex = texcoord0; - gl_Position = projection * view * model * vec4(position.xyz, 1.0); -} -" - " -#ifdef GLSL120 -attribute vec2 fragTex; -#else -in vec2 fragTex; -#endif -#ifdef GLSL330 -out vec4 fragColor; -#endif -uniform vec3 baseColorFactor; -uniform sampler2D baseColorTexture; - -void main (void) { -#ifdef GLSL330 - fragColor = texture(baseColorTexture, fragTex) * - vec4(baseColorFactor, 1.0); -#else - gl_FragColor = texture2D(baseColorTexture, fragTex) * - vec4(baseColorFactor, 1.0); -#endif -} -"))) - -(define (load-pbr-shader) - (force pbr-shader)) - -(define (gpu-apply/pbr shader vertex-array material model-matrix view-matrix) - (with-texture 0 (pbr-material-base-color-texture material) - (gpu-apply shader vertex-array - #:model model-matrix - #:view view-matrix - #:projection (current-projection) - #:base-color-factor (pbr-material-base-color-factor material)))) diff --git a/chickadee/render/phong.scm b/chickadee/render/phong.scm deleted file mode 100644 index 1c718a8..0000000 --- a/chickadee/render/phong.scm +++ /dev/null @@ -1,253 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Simple forward rendered Phong lighting model. -;; -;;; Code: - -(define-module (chickadee render phong) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render color) - #:use-module (chickadee render shader) - #:use-module (chickadee render texture) - #:use-module (srfi srfi-9) - #:export (make-phong-material - phong-material? - phong-material-name - phong-material-ambient - phong-material-ambient-map - phong-material-use-ambient-map? - phong-material-diffuse - phong-material-diffuse-map - phong-material-use-diffuse-map? - phong-material-specular - phong-material-specular-map? - phong-material-use-specular-map? - phong-material-specular-exponent - phong-material-bump-map - phong-material-use-bump-map? - default-phong-material - load-phong-shader - gpu-apply/phong)) - - -;;; -;;; Phong Material -;;; - -(define-shader-type - make-phong-material - phong-material? - (local-field name phong-material-name) - (float-vec3 ambient phong-material-ambient) - (local-field ambient-map phong-material-ambient-map) - (bool use-ambient-map phong-material-use-ambient-map?) - (float-vec3 diffuse phong-material-diffuse) - (local-field diffuse-map phong-material-diffuse-map) - (bool use-diffuse-map phong-material-use-diffuse-map?) - (float-vec3 specular phong-material-specular) - (local-field specular-map phong-material-specular-map) - (bool use-specular-map phong-material-use-specular-map?) - (float shininess phong-material-shininess) - (local-field bump-map phong-material-bump-map) - (bool use-bump-map phong-material-use-bump-map?)) - -(define default-phong-material - (make-phong-material #:name "default" - #:ambient (vec3 0.5 0.5 0.5) - #:ambient-map null-texture - #:use-ambient-map #f - #:diffuse (vec3 0.8 0.8 0.8) - #:diffuse-map null-texture - #:use-diffuse-map #f - #:specular (vec3 0.3 0.3 0.3) - #:specular-map null-texture - #:use-specular-map #f - #:shininess 32.0 - #:bump-map null-texture - #:use-bump-map #f)) - - -;;; -;;; Lights -;;; - -(define-shader-type - make-directional-light - directional-light? - (float-vec3 direction directional-light-direction) - (float-vec3 ambient directional-light-ambient) - (float-vec3 diffuse directional-light-diffuse) - (float-vec3 specular directional-light-specular) - (float shininess directional-light-shininess)) - -(define default-directional-light - (make-directional-light #:direction (vec3 0.0 0.0 -1.0) - #:ambient (vec3 0.1 0.1 0.1) - #:diffuse (vec3 1.0 1.0 1.0) - #:specular (vec3 0.5 0.5 0.5) - #:shininess 32.0)) - - -;;; -;;; Phong Shader -;;; - -(define phong-shader - (delay - (strings->shader - " -#ifdef GLSL330 -layout (location = 0) in vec3 position; -layout (location = 1) in vec2 texcoord; -layout (location = 2) in vec3 normal; -#elif defined(GLSL130) -in vec3 position; -in vec2 texcoord; -in vec3 normal; -#elif defined(GLSL120) -attribute vec3 position; -attribute vec2 texcoord; -attribute vec3 normal; -#endif - -uniform mat4 model; -uniform mat4 view; -uniform mat4 projection; - -#ifdef GLSL120 -varying vec3 fragNorm; -varying vec2 fragTex; -#else -out vec3 fragNorm; -out vec2 fragTex; -#endif - -void main() { - gl_Position = projection * view * model * vec4(position, 1.0); - // TODO: Calculate normal matrix on CPU - fragNorm = normalize(model * vec4(normal, 1.0)).xyz; - fragTex = texcoord; -} -" - " -struct Material { - vec3 ambient; - sampler2D ambientMap; - bool useAmbientMap; - vec3 diffuse; - sampler2D diffuseMap; - bool useDiffuseMap; - vec3 specular; - sampler2D specularMap; - bool useSpecularMap; - float shininess; - sampler2D bumpMap; - bool useBumpMap; -}; - -struct DirectionalLight { - vec3 direction; - vec3 ambient; - vec3 diffuse; - vec3 specular; -}; - -#ifdef GLSL120 -attribute vec3 fragNorm; -attribute vec2 fragTex; -#else -in vec3 fragNorm; -in vec2 fragTex; -#endif - -#ifdef GLSL330 -out vec4 fragColor; -#endif - -uniform Material material; -uniform DirectionalLight directionalLight; - -void main() { - vec3 baseAmbientColor; - vec3 baseDiffuseColor; - vec3 baseSpecularColor; - if(material.useAmbientMap) { -#ifdef GLSL330 - baseAmbientColor = texture(material.ambientMap, fragTex).xyz; -#else - baseAmbientColor = texture2D(material.ambientMap, fragTex).xyz; -#endif - } else { - baseAmbientColor = vec3(1.0, 1.0, 1.0); - } - if(material.useDiffuseMap) { - // discard transparent fragments. -#ifdef GLSL330 - vec4 color = texture(material.diffuseMap, fragTex); -#else - vec4 color = texture2D(material.diffuseMap, fragTex); -#endif - if(color.a == 0.0) { discard; } - baseDiffuseColor = color.xyz; - } else { - baseDiffuseColor = vec3(1.0, 1.0, 1.0); - } - if(material.useSpecularMap) { -#ifdef GLSL330 - baseSpecularColor = texture(material.specularMap, fragTex).xyz; -#else - baseSpecularColor = texture2D(material.specularMap, fragTex).xyz; -#endif - } else { - baseSpecularColor = vec3(1.0, 1.0, 1.0); - } - vec3 ambientColor = material.ambient * baseAmbientColor * baseDiffuseColor; - vec3 lightDir = normalize(-directionalLight.direction); - float diffuseFactor = max(dot(lightDir, fragNorm), 0.0); - vec3 diffuseColor = diffuseFactor * baseDiffuseColor * material.diffuse; - vec3 reflectDir = reflect(-lightDir, fragNorm); - float specularFactor = 0; - if(material.shininess > 0) { - specularFactor = pow(max(dot(lightDir, reflectDir), 0.0), material.shininess); - } - vec3 specularColor = specularFactor * baseSpecularColor * material.specular; -#ifdef GLSL330 - fragColor = vec4(ambientColor + diffuseColor + specularColor, 1.0); -#else - gl_FragColor = vec4(ambientColor + diffuseColor + specularColor, 1.0); -#endif -} -"))) - -(define (load-phong-shader) - (force phong-shader)) - -(define (gpu-apply/phong shader vertex-array material model-matrix view-matrix) - (with-texture 0 (phong-material-ambient-map material) - (with-texture 1 (phong-material-diffuse-map material) - (with-texture 2 (phong-material-specular-map material) - (with-texture 3 (phong-material-bump-map material) - (gpu-apply shader vertex-array - #:model model-matrix - #:view view-matrix - #:projection (current-projection) - #:material material - #:directional-light default-directional-light)))))) diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm deleted file mode 100644 index 6df77f1..0000000 --- a/chickadee/render/shader.scm +++ /dev/null @@ -1,826 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render shader) - #:use-module (ice-9 format) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) - #:use-module (oop goops) - #:use-module (system foreign) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-4) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (gl) - #:use-module (chickadee math matrix) - #:use-module (chickadee math vector) - #:use-module (chickadee render color) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:use-module (chickadee render texture) - #:export (shader-data-type? - bool - int - unsigned-int - float - float-vec2 - float-vec3 - float-vec4 - mat4 - sampler-2d - local-field - define-shader-type - uniform-namespace? - uniform-namespace-ref - uniform-namespace-for-each - make-shader - shader? - null-shader - apply-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)) - - -;;; -;;; Primitive Shader Data Types -;;; - -(define-record-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 type) - (shader-primitive-type-size type) - (shader-primitive-type-null type))) - -(set-record-type-printer! 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))) - (let loop ((i 0)) - (when (< i (vector-length data)) - (serialize bv (* i size) (vector-ref data i)) - (loop (+ i 1))))) - (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 color? - #:serializer - (lambda (bv i v) - ;; As of now, there is no vec4 Scheme type, but we do want to - ;; accept colors as vec4s since there is no special color type in - ;; GLSL. - (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 (color 0.0 0.0 0.0 0.0)) - -(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) - - -;;; -;;; 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 - (make-vtable (string-append standard-vtable-fields "pwpw") - (lambda (vt port) - (format port "#" - (shader-struct-fields vt))))) - -(define local-field (gensym "local-shader-field-")) - -(define (shader-struct? struct) - (eq? (struct-vtable (struct-vtable 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)) - (let loop ((i 0)) - (when (< i (vector-length value)) - (validate (vector-ref value i)) - (loop (+ i 1))))) - ((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) ) - (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 - (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 () - ((_ field getter) - (define getter - (let ((index (match (assq-ref (shader-struct-fields ) 'field) - ((i _ _) i)))) - (lambda (obj) - (struct-ref obj index))))) - ((_ field getter setter) - (begin - (define-accessors field getter) - (define setter - (let ((index (match (assq-ref (shader-struct-fields ) 'field) - ((i _ _) i)))) - (lambda (obj value) - (shader-struct-type-check 'field value) - (struct-set! obj index value)))))))) - -(define-syntax define-shader-type - (syntax-rules () - ((_ constructor predicate (field-type field-name . field-rest) ...) - (begin - (define - (make-shader-struct ' (list (list 'field-name field-type) ...))) - (define* (constructor #:key (field-name (shader-struct-default 'field-name)) ...) - (shader-struct-type-check 'field-name field-name) ... - (make-struct/no-tail field-name ...)) - (define (predicate obj) - (and (struct? obj) (eq? (struct-vtable obj) ))) - (define-accessors field-name . field-rest) ...)))) - - -;;; -;;; Shaders -;;; - -(define-record-type - (%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 - (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!)) - -;; variable name -> {uniform, namespace, uniform array} map -(define-record-type - (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 - (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 - (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 <> (class-of null-shader)) - -(define-method (gpu-finalize (shader <>)) - (gl-delete-program (shader-id shader))) - -(define (apply-shader shader) - (gl-use-program (shader-id 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 (gpu-glsl-version (current-gpu)))) - (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-mat4)) mat4) - ((= type (version-2-0 sampler-2d)) sampler-2d) - (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? (eq? type sampler-2d)) - (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))) - (let loop ((i 0)) - (unless (= 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)))) - (loop (1+ i)))) - table)) - (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))) - (gpu-guard - (%make-shader id (extract-attributes id) namespace - scratch (bytevector->pointer scratch)))))))) - -(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) - (define (traverse thing) - (cond - ((uniform? thing) - (proc thing)) - ((uniform-namespace? thing) - (uniform-namespace-for-each - (lambda (key uniform) - (traverse uniform)) - thing)) - ((uniform-array? thing) - (let ((size (uniform-array-size thing))) - (let loop ((i 0)) - (when (< i size) - (traverse (uniform-array-namespace-ref thing i)) - (loop (+ i 1)))))))) - (traverse (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-name x) - (define (traverse 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 x)))) - (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 (eq? (uniform-type uniform) sampler-2d) - (traverse uniform (shader-struct-ref value key)))) - uniform) - (error "expected shader struct" x))) - ;; 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))) - (let loop ((i 0)) - (when (< i size) - (traverse (uniform-array-namespace-ref uniform i) - (vector-ref value i)) - (loop (+ i 1)))) - (error "vector size mismatch for uniform" - (uniform-array-name uniform))))))) - ;; Walk the uniform namespace tree until we get to a leaf node or - ;; nodes. - (traverse (shader-uniform shader uniform-name) x)) diff --git a/chickadee/render/shapes.scm b/chickadee/render/shapes.scm deleted file mode 100644 index dd690ec..0000000 --- a/chickadee/render/shapes.scm +++ /dev/null @@ -1,408 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2018 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary -;; -;; Polylines as described in -;; http://jcgt.org/published/0002/02/08/paper.pdf -;; -;;; Code: - -(define-module (chickadee render shapes) - #:use-module (ice-9 match) - #:use-module (srfi srfi-4) - #:use-module (chickadee math bezier) - #:use-module (chickadee math matrix) - #:use-module (chickadee math rect) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render color) - #:use-module (chickadee render shader) - #:use-module (chickadee render buffer) - #:export (draw-filled-rect - draw-line - draw-bezier-curve - draw-bezier-path)) - -;; TODO: Make a generic polygon renderer, include batching, etc. -(define draw-filled-rect - (let* ((vertex-buffer - (delay - (make-streaming-buffer-view 'vec2 'float 4 - #:name "rect-buffer-view"))) - (index-buffer - (delay - (make-buffer-view #:type 'scalar - #:component-type 'unsigned-int - #:buffer (make-buffer (u32vector 0 3 2 0 2 1) - #:target 'index)))) - (vertex-array - (delay - (make-vertex-array #:indices (force index-buffer) - #:attributes `((0 . ,(force vertex-buffer)))))) - (default-shader - (delay - (strings->shader - " -#ifdef GLSL330 -layout (location = 0) in vec2 position; -#elif defined(GLSL130) -in vec2 position; -#elif defined(GLSL120) -attribute vec2 position; -#endif -uniform mat4 mvp; - -void main(void) { - gl_Position = mvp * vec4(position.xy, 0.0, 1.0); -} -" - " -#ifdef GLSL330 -out vec4 fragColor; -#endif -uniform vec4 color; - -void main (void) { -#ifdef GLSL330 - fragColor = color; -#else - gl_FragColor = color; -#endif -} -"))) - (mvp (make-null-matrix4))) - (lambda* (region - color - #:key - (blend-mode 'alpha) - (shader (force default-shader)) - matrix) - (let* ((x1 (rect-x region)) - (y1 (rect-y region)) - (x2 (+ x1 (rect-width region))) - (y2 (+ y1 (rect-height region)))) - (with-mapped-buffer-view (force vertex-buffer) - (let ((bv (buffer-view-data (force vertex-buffer)))) - (f32vector-set! bv 0 x1) - (f32vector-set! bv 1 y1) - (f32vector-set! bv 2 x2) - (f32vector-set! bv 3 y1) - (f32vector-set! bv 4 x2) - (f32vector-set! bv 5 y2) - (f32vector-set! bv 6 x1) - (f32vector-set! bv 7 y2))) - (with-blend-mode blend-mode - (gpu-apply shader (force vertex-array) - #:mvp (if matrix - (begin - (matrix4-mult! mvp matrix - (current-projection)) - mvp) - (current-projection)) - #:color color)))))) - -(define draw-line - (let* ((mvp (make-null-matrix4)) - (vertex-buffer - (delay - (make-streaming-buffer-view 'vec2 'float 4 - #:name "line-buffer-view"))) - (texcoord-buffer - (delay - (make-streaming-buffer-view 'vec2 'float 4 - #:name "line-buffer-view"))) - (index-buffer - (delay - (make-buffer-view #:type 'scalar - #:component-type 'unsigned-int - #:buffer (make-buffer (u32vector 0 3 2 0 2 1) - #:target 'index)))) - (vertex-array - (delay - (make-vertex-array #:indices (force index-buffer) - #:attributes `((0 . ,(force vertex-buffer)) - (1 . ,(force texcoord-buffer)))))) - (default-shader - (delay - (strings->shader - " -#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 -uniform mat4 mvp; - -void main(void) { - fragTex = tex; - gl_Position = mvp * vec4(position.xy, 0.0, 1.0); -} -" - " -#ifdef GLSL120 -attribute vec2 fragTex; -#else -in vec2 fragTex; -#endif -#ifdef GLSL330 -out vec4 fragColor; -#endif -uniform vec4 color; -uniform float r; -uniform float w; -uniform float t; -uniform float l; -uniform int cap; -float infinity = 1.0 / 0.0; - -void main (void) { - float hw = w / 2.0; - float u = fragTex.x; - float v = fragTex.y; - float dx; - float dy; - float d; - - if (u < 0 || u > l) { - if (u < 0) { - dx = abs(u); - } else { - dx = u - l; - } - dy = abs(v); - - switch (cap) { - // none - case 0: - d = infinity; - break; - // butt - case 1: - d = max(dx + w / 2 - 2 * r, dy); - break; - // square - case 2: - d = max(dx, dy); - break; - // round - case 3: - d = sqrt(dx * dx + dy * dy); - break; - // triangle out - case 4: - d = dx + dy; - break; - // triangle in - case 5: - d = max(dy, w / 2 - r + dx - dy); - break; - } - } else { - d = abs(v); - } - - if (d <= hw) { -#ifdef GLSL330 - fragColor = color; -#else - gl_FragColor = color; -#endif - } else { -#ifdef GLSL330 - fragColor = vec4(color.rgb, color.a * (1.0 - ((d - hw) / r))); -#else - gl_FragColor = vec4(color.rgb, color.a * (1.0 - ((d - hw) / r))); -#endif - } -} -")))) - (lambda* (start end #:key - (thickness 0.5) - (feather 1.0) - (cap 'round) - (color white) - (shader (force default-shader)) - matrix) - "Draw a line segment from START to END. The line will be -THICKNESS pixels thick with an antialiased border FEATHER pixels wide. -The line will be colored COLOR. CAP specifies the type of end cap that -should be used to terminate the lines, either 'none', 'butt', -'square', 'round', 'triangle-in', or 'triangle-out'. Advanced users -may use SHADER to override the built-in line segment shader." - (let* ((x1 (vec2-x start)) - (y1 (vec2-y start)) - (x2 (vec2-x end)) - (y2 (vec2-y end)) - (dx (- x2 x1)) - (dy (- y2 y1)) - (length (sqrt (+ (expt dx 2) (expt dy 2)))) - (padding (/ (ceiling (+ thickness (* feather 2.5))) 2.0)) - (nx (/ dx length)) - (ny (/ dy length)) - (xpad (* nx padding)) - (ypad (* ny padding)) - ;; start left - (vx1 (+ (- x1 xpad) ypad)) - (vy1 (+ (- y1 ypad) (- xpad))) - (s1 (- padding)) - (t1 padding) - ;; start right - (vx2 (+ (- x1 xpad) (- ypad))) - (vy2 (+ (- y1 ypad) xpad)) - (s2 (- padding)) - (t2 (- padding)) - ;; end left - (vx3 (+ x2 xpad (- ypad))) - (vy3 (+ y2 ypad xpad)) - (s3 (+ length padding)) - (t3 (- padding)) - ;; end right - (vx4 (+ (+ x2 xpad) ypad)) - (vy4 (+ (+ y2 ypad) (- xpad))) - (s4 (+ length padding)) - (t4 padding)) - (with-mapped-buffer-view (force vertex-buffer) - (let ((bv (buffer-view-data (force vertex-buffer)))) - (f32vector-set! bv 0 vx1) - (f32vector-set! bv 1 vy1) - (f32vector-set! bv 2 vx2) - (f32vector-set! bv 3 vy2) - (f32vector-set! bv 4 vx3) - (f32vector-set! bv 5 vy3) - (f32vector-set! bv 6 vx4) - (f32vector-set! bv 7 vy4))) - (with-mapped-buffer-view (force texcoord-buffer) - (let ((bv (buffer-view-data (force texcoord-buffer)))) - (f32vector-set! bv 0 s1) - (f32vector-set! bv 1 t1) - (f32vector-set! bv 2 s2) - (f32vector-set! bv 3 t2) - (f32vector-set! bv 4 s3) - (f32vector-set! bv 5 t3) - (f32vector-set! bv 6 s4) - (f32vector-set! bv 7 t4))) - (with-blend-mode 'alpha - (gpu-apply shader (force vertex-array) - #:mvp (if matrix - (begin - (matrix4-mult! mvp matrix - (current-projection)) - mvp) - (current-projection)) - #:color color - #:w thickness - #:r feather - #:l length - #:cap (match cap - ('none 0) - ('butt 1) - ('square 2) - ('round 3) - ('triangle-out 4) - ('triangle-in 5)))))))) - -;; XXX: This is going to be hopelessly slow until I implement batching -;; for lines and shapes. -(define draw-bezier-curve - (let ((start #v(0.0 0.0)) - (end #v(0.0 0.0)) - (tmp #f) - (rect (make-rect 0.0 0.0 0.0 0.0))) - (lambda* (bezier #:key - (segments 32) - control-points? - tangents? - (control-point-size 8.0) - (color white) - (control-point-color yellow) - (tangent-color yellow) - (thickness 0.5) - (feather 1.0) - matrix) - "Draw the curve defined by BEZIER using a resolution of n SEGMENTS." - (define (draw-segment start end color) - (draw-line start end - #:thickness thickness - #:feather feather - #:cap 'none - #:color color)) - (define (draw-control-point p) - (let ((hs (/ control-point-size 2.0))) - (set-rect-x! rect (- (vec2-x p) hs)) - (set-rect-y! rect (- (vec2-y p) hs)) - (set-rect-width! rect control-point-size) - (set-rect-height! rect control-point-size) - (draw-filled-rect rect control-point-color #:matrix matrix))) - (bezier-curve-point-at! start bezier 0.0) - (let loop ((i 1)) - (when (<= i segments) - (bezier-curve-point-at! end bezier (exact->inexact (/ i segments))) - (draw-segment start end color) - ;; Make the previous end point is now the new start point - ;; for the next iteration. - (set! tmp start) - (set! start end) - (set! end tmp) - (loop (+ i 1)))) - (when tangents? - (draw-segment (bezier-curve-p0 bezier) - (bezier-curve-p1 bezier) - tangent-color) - (draw-segment (bezier-curve-p3 bezier) - (bezier-curve-p2 bezier) - tangent-color)) - (when control-points? - (draw-control-point (bezier-curve-p0 bezier)) - (draw-control-point (bezier-curve-p1 bezier)) - (draw-control-point (bezier-curve-p2 bezier)) - (draw-control-point (bezier-curve-p3 bezier)))))) - -(define* (draw-bezier-path path #:key - (segments 32) - control-points? - tangents? - (control-point-size 8.0) - (color white) - (control-point-color yellow) - (tangent-color yellow) - (thickness 0.5) - (feather 1.0) - matrix) - (for-each (lambda (bezier) - (draw-bezier-curve bezier - #:segments segments - #:control-points? control-points? - #:tangents? tangents? - #:control-point-size control-point-size - #:color color - #:control-point-color control-point-color - #:tangent-color tangent-color - #:thickness 0.5 - #:feather feather - #:matrix matrix)) - path)) diff --git a/chickadee/render/sprite.scm b/chickadee/render/sprite.scm deleted file mode 100644 index a5c25bc..0000000 --- a/chickadee/render/sprite.scm +++ /dev/null @@ -1,611 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016, 2019 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render sprite) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-4) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (chickadee math matrix) - #:use-module (chickadee math rect) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render color) - #:use-module (chickadee render shader) - #:use-module (chickadee render texture) - #:use-module (chickadee render buffer) - #:export (draw-sprite* - draw-sprite - - make-sprite-batch - sprite-batch? - sprite-batch-texture - set-sprite-batch-texture! - sprite-batch-clear! - sprite-batch-add* - sprite-batch-add! - draw-sprite-batch* - draw-sprite-batch - - with-batched-sprites - draw-nine-patch* - draw-nine-patch)) - -(define unbatched-sprite-shader - (delay - (strings->shader - " -#ifdef GLSL330 -layout (location = 0) in vec2 position; -layout (location = 1) in vec2 tex; -#elif ifdef GLSL130 -in vec2 position; -in vec2 tex; -#elif ifdef GLSL120 -attribute vec2 position; -attribute vec2 tex; -#endif -#ifdef GLSL120 -varying vec2 fragTex; -#else -out vec2 fragTex; -#endif -uniform mat4 mvp; - -void main(void) { - fragTex = tex; - gl_Position = mvp * vec4(position.xy, 0.0, 1.0); -} -" - " - -#ifdef GLSL120 -attribute vec2 fragTex; -#else -in vec2 fragTex; -#endif -#ifdef GLSL330 -out vec4 fragColor; -#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 -} -"))) - -(define draw-sprite* - (let* ((stride 16) ; 4 f32s, 2 for vertex, 2 for texcoord - (buffer (delay - (make-buffer #f - #:name "unbatched sprite buffer" - #:length (* stride 4) - #:stride stride - #:usage 'stream))) - (pos (delay - (make-buffer-view #:name "unbatched sprite vertices" - #:buffer (force buffer) - #:type 'vec2 - #:component-type 'float - #:length 4))) - (tex (delay - (make-buffer-view #:name "unbatched sprite texcoords" - #:buffer (force buffer) - #:type 'vec2 - #:component-type 'float - #:length 4 - #:offset 8))) - (indices - (delay - (make-buffer-view #:name "unbatched sprite indices" - #:type 'scalar - #:component-type 'unsigned-int - #:buffer (make-buffer (u32vector 0 3 2 0 2 1) - #:target 'index)))) - (vertex-array - (delay - (make-vertex-array #:indices (force indices) - #:attributes - `((0 . ,(force pos)) - (1 . ,(force tex)))))) - (mvp (make-null-matrix4))) - (lambda* (texture - rect - matrix - #:key - (tint white) - (blend-mode 'alpha) - (texcoords (texture-gl-tex-rect texture))) - (with-mapped-buffer-view (force pos) - (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))) - (bv (buffer-view-data (force pos)))) - ;; Texture origin is at the top-left, so we need to flip the Y - ;; coordinate relative to the vertices. - (f32vector-set! bv 0 x1) - (f32vector-set! bv 1 y1) - (f32vector-set! bv 2 s1) - (f32vector-set! bv 3 t2) - (f32vector-set! bv 4 x2) - (f32vector-set! bv 5 y1) - (f32vector-set! bv 6 s2) - (f32vector-set! bv 7 t2) - (f32vector-set! bv 8 x2) - (f32vector-set! bv 9 y2) - (f32vector-set! bv 10 s2) - (f32vector-set! bv 11 t1) - (f32vector-set! bv 12 x1) - (f32vector-set! bv 13 y2) - (f32vector-set! bv 14 s1) - (f32vector-set! bv 15 t1))) - (with-blend-mode blend-mode - (with-texture 0 texture - (gpu-apply (force unbatched-sprite-shader) (force vertex-array) - #:tint tint - #:mvp (if matrix - (begin - (matrix4-mult! mvp matrix - (current-projection)) - mvp) - (current-projection)))))))) - -(define %null-vec2 (vec2 0.0 0.0)) -(define %default-scale (vec2 1.0 1.0)) - -(define draw-sprite - (let ((matrix (make-null-matrix4))) - (lambda* (texture - position - #:key - (tint white) - (origin %null-vec2) - (scale %default-scale) - (rotation 0.0) - (blend-mode 'alpha) - (rect (texture-gl-rect texture))) - "Draw TEXTURE at POSITION. - -Optionally, other transformations may be applied to the sprite. -ROTATION specifies the angle to rotate the sprite, in radians. SCALE -specifies the scaling factor as a 2D vector. All transformations are -applied relative to ORIGIN, a 2D vector. - -TINT specifies the color to multiply against all the sprite's pixels. -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." - (matrix4-2d-transform! matrix - #:origin origin - #:position position - #:rotation rotation - #:scale scale) - (draw-sprite* texture rect matrix - #:tint tint - #:blend-mode blend-mode)))) - - -;;; -;;; Sprite Batches -;;; - -(define-record-type - (%make-sprite-batch texture size capacity vertex-buffer vertex-array) - sprite-batch? - (texture sprite-batch-texture set-sprite-batch-texture!) - (size sprite-batch-size set-sprite-batch-size!) - (capacity sprite-batch-capacity set-sprite-batch-capacity!) - (vertex-buffer sprite-batch-vertex-buffer set-sprite-batch-vertex-buffer!) - (vertex-array sprite-batch-vertex-array set-sprite-batch-vertex-array!)) - -(define (init-sprite-batch batch capacity) - (let* ((index-data (let ((bv (make-u32vector (* capacity 6)))) - (let loop ((i 0)) - (when (< i capacity) - (let ((index-offset (* i 6)) - (vertex-offset (* i 4))) - (u32vector-set! bv index-offset vertex-offset) - (u32vector-set! bv (+ index-offset 1) (+ vertex-offset 3)) - (u32vector-set! bv (+ index-offset 2) (+ vertex-offset 2)) - (u32vector-set! bv (+ index-offset 3) vertex-offset) - (u32vector-set! bv (+ index-offset 4) (+ vertex-offset 2)) - (u32vector-set! bv (+ index-offset 5) (+ vertex-offset 1)) - (loop (+ i 1))))) - bv)) - (index-buffer (make-buffer index-data - #:name "indices" - #:target 'index)) - (indices (make-buffer-view #:name "indices" - #:buffer index-buffer - #:type 'scalar - #:component-type 'unsigned-int)) - (stride 32) ; 8 f32s, 2 for vertex, 2 for texcoord, 4 for tint color - (buffer (make-buffer #f - #:name "sprite batch buffer" - #:length (* capacity stride 4) - #:stride stride - #:usage 'stream)) - (pos (make-buffer-view #:name "sprite batch vertices" - #:buffer buffer - #:type 'vec2 - #:component-type 'float - #:length (* capacity 4))) - (tex (make-buffer-view #:name "sprite batch texture coordinates" - #:buffer buffer - #:type 'vec2 - #:component-type 'float - #:length (* capacity 4) - #:offset 8)) - (tint (make-buffer-view #:name "sprite batch tint colors" - #:buffer buffer - #:type 'vec4 - #:component-type 'float - #:length (* capacity 4) - #:offset 16)) - (va (make-vertex-array #:indices indices - #:attributes `((0 . ,pos) - (1 . ,tex) - (2 . ,tint))))) - (set-sprite-batch-capacity! batch capacity) - (set-sprite-batch-vertex-buffer! batch buffer) - (set-sprite-batch-vertex-array! batch va))) - -(define* (make-sprite-batch texture #:key (capacity 256)) - "Make a sprite batch that can hold CAPACITY sprites." - (let ((batch (%make-sprite-batch texture 0 0 #f #f))) - (init-sprite-batch batch capacity) - batch)) - -(define (sprite-batch-full? batch) - (= (sprite-batch-capacity batch) (sprite-batch-size batch))) - -(define (double-sprite-batch-size! batch) - (let* ((old-verts (sprite-batch-vertex-buffer batch)) - (old-vertex-data (buffer-data old-verts))) - (unmap-buffer! old-verts) - (init-sprite-batch batch (* (sprite-batch-capacity batch) 2)) - (let ((new-verts (sprite-batch-vertex-buffer batch))) - (map-buffer! new-verts 'write-only) - (bytevector-copy! old-vertex-data 0 - (buffer-data new-verts) 0 - (bytevector-length old-vertex-data))))) - -(define (sprite-batch-clear! batch) - "Reset BATCH to size 0." - (set-sprite-batch-size! batch 0)) - -(define (sprite-batch-flush! batch) - "Submit the contents of BATCH to the GPU." - (unmap-buffer! (sprite-batch-vertex-buffer batch))) - -(define* (sprite-batch-add* batch rect matrix - #:key - (tint white) - texture-region) - "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." - ;; Expand the buffers when necessary. - (when (sprite-batch-full? batch) - (double-sprite-batch-size! batch)) - (map-buffer! (sprite-batch-vertex-buffer batch) 'write-only) - (let* ((size (sprite-batch-size batch)) - (vertices (buffer-data (sprite-batch-vertex-buffer batch))) - (offset (* size 32)) ; each sprite is 32 floats in size - (minx (rect-x rect)) - (miny (rect-y rect)) - (maxx (+ minx (rect-width rect))) - (maxy (+ miny (rect-height rect))) - (x1 (transform-x matrix minx miny)) - (y1 (transform-y matrix minx miny)) - (x2 (transform-x matrix maxx miny)) - (y2 (transform-y matrix maxx miny)) - (x3 (transform-x matrix maxx maxy)) - (y3 (transform-y matrix maxx maxy)) - (x4 (transform-x matrix minx maxy)) - (y4 (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)))) - ;; Add vertices. - ;; Bottom-left - (f32vector-set! vertices offset x1) - (f32vector-set! vertices (+ offset 1) y1) - ;; Bottom-right - (f32vector-set! vertices (+ offset 8) x2) - (f32vector-set! vertices (+ offset 9) y2) - ;; Top-right - (f32vector-set! vertices (+ offset 16) x3) - (f32vector-set! vertices (+ offset 17) y3) - ;; Top-left - (f32vector-set! vertices (+ offset 24) x4) - (f32vector-set! vertices (+ offset 25) y4) - ;; Add texture coordinates. - ;; Bottom-left - (f32vector-set! vertices (+ offset 2) s1) - (f32vector-set! vertices (+ offset 3) t2) - ;; Bottom-right - (f32vector-set! vertices (+ offset 10) s2) - (f32vector-set! vertices (+ offset 11) t2) - ;; Top-right - (f32vector-set! vertices (+ offset 18) s2) - (f32vector-set! vertices (+ offset 19) t1) - ;; Top-left - (f32vector-set! vertices (+ offset 26) s1) - (f32vector-set! vertices (+ offset 27) t1) - ;; Add tint. - (let ((bv ((@@ (chickadee render color) unwrap-color) tint)) - (byte-offset (* offset 4))) - (bytevector-copy! bv 0 vertices (+ byte-offset 16) 16) - (bytevector-copy! bv 0 vertices (+ byte-offset 48) 16) - (bytevector-copy! bv 0 vertices (+ byte-offset 80) 16) - (bytevector-copy! bv 0 vertices (+ byte-offset 112) 16)) - (set-sprite-batch-size! batch (1+ size)))) - -(define sprite-batch-add! - (let ((matrix (make-null-matrix4))) - (lambda* (batch - position - #:key - (origin %null-vec2) - (scale %default-scale) - (rotation 0.0) - (tint white) - texture-region) - "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 ((rect (texture-gl-rect - (or texture-region (sprite-batch-texture batch))))) - (matrix4-2d-transform! matrix - #:origin origin - #:position position - #:rotation rotation - #:scale scale) - (sprite-batch-add* batch rect matrix - #:tint tint - #:texture-region texture-region))))) - - -(define batched-sprite-shader - (delay - (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 vec2 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 -attribute vec2 fragTex; -attribute 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 draw-sprite-batch* - (let ((mvp (make-null-matrix4))) - (lambda* (batch matrix #:key (blend-mode 'alpha)) - "Render the contents of BATCH." - (sprite-batch-flush! batch) - (matrix4-mult! mvp matrix (current-projection)) - (with-blend-mode blend-mode - (with-texture 0 (sprite-batch-texture batch) - (gpu-apply* (force batched-sprite-shader) - (sprite-batch-vertex-array batch) - (* (sprite-batch-size batch) 6) - #:mvp mvp)))))) - -(define draw-sprite-batch - (let ((matrix (make-null-matrix4))) - (lambda* (batch - #:key - (position %null-vec2) - (origin %null-vec2) - (scale %default-scale) - (rotation 0.0) - (blend-mode 'alpha)) - "Render the contents of BATCH." - (matrix4-2d-transform! matrix - #:origin origin - #:position position - #:rotation rotation - #:scale scale) - (draw-sprite-batch* batch matrix #:blend-mode blend-mode)))) - - -;;; -;;; Nine Patches -;;; - -(define draw-nine-patch* - (let ((%rect (make-rect 0.0 0.0 0.0 0.0)) - (texcoords (make-rect 0.0 0.0 0.0 0.0))) - (lambda* (texture - rect - matrix - #:key - (margin 0.0) - (top-margin margin) - (bottom-margin margin) - (left-margin margin) - (right-margin margin) - (blend-mode 'alpha) - (tint white)) - (let* ((x (rect-x rect)) - (y (rect-y rect)) - (w (rect-width rect)) - (h (rect-height rect)) - (border-x1 x) - (border-y1 y) - (border-x2 (+ x w)) - (border-y2 (+ y h)) - (fill-x1 (+ border-x1 left-margin)) - (fill-y1 (+ border-y1 bottom-margin)) - (fill-x2 (- border-x2 right-margin)) - (fill-y2 (- border-y2 top-margin)) - (prect (texture-gl-rect texture)) - (trect (texture-gl-tex-rect texture)) - (tw (rect-width prect)) - (th (rect-height prect)) - (border-s1 (rect-x trect)) - (border-t1 (rect-y trect)) - (border-s2 (+ (rect-x trect) (rect-width trect))) - (border-t2 (+ (rect-y trect) (rect-height trect))) - (fill-s1 (+ border-s1 (/ left-margin tw))) - (fill-t1 (+ border-t1 (/ top-margin th))) - (fill-s2 (- border-s2 (/ right-margin tw))) - (fill-t2 (- border-t2 (/ bottom-margin th)))) - (define (draw-piece x1 y1 x2 y2 s1 t1 s2 t2) - (set-rect-x! %rect x1) - (set-rect-y! %rect y1) - (set-rect-width! %rect (- x2 x1)) - (set-rect-height! %rect (- y2 y1)) - (set-rect-x! texcoords s1) - (set-rect-y! texcoords t1) - (set-rect-width! texcoords (- s2 s1)) - (set-rect-height! texcoords (- t2 t1)) - (draw-sprite* texture %rect matrix - #:texcoords texcoords - #:blend-mode blend-mode - #:tint tint)) - ;; bottom-left - (draw-piece border-x1 border-y1 fill-x1 fill-y1 - border-s1 fill-t2 fill-s1 border-t2) - ;; bottom-center - (draw-piece fill-x1 border-y1 fill-x2 fill-y1 - fill-s1 fill-t2 fill-s2 border-t2) - ;; bottom-right - (draw-piece fill-x2 border-y1 border-x2 fill-y1 - fill-s2 fill-t2 border-s2 border-t2) - ;; center-left - (draw-piece border-x1 fill-y1 fill-x1 fill-y2 - border-s1 fill-t2 fill-s1 fill-t1) - ;; center - (draw-piece fill-x1 fill-y1 fill-x2 fill-y2 - fill-s1 fill-t2 fill-s2 fill-t1) - ;; center-right - (draw-piece fill-x2 fill-y1 border-x2 fill-y2 - fill-s2 fill-t2 border-s2 fill-t1) - ;; top-left - (draw-piece border-x1 fill-y2 fill-x1 border-y2 - border-s1 border-t1 fill-s1 fill-t1) - ;; top-center - (draw-piece fill-x1 fill-y2 fill-x2 border-y2 - fill-s1 border-t1 fill-s2 fill-t1) - ;; top-right - (draw-piece fill-x2 fill-y2 border-x2 border-y2 - fill-s2 border-t1 border-s2 fill-t1))))) - -(define draw-nine-patch - (let ((position (vec2 0.0 0.0)) - (%rect (make-rect 0.0 0.0 0.0 0.0)) - (matrix (make-null-matrix4))) - (lambda* (texture - rect - #:key - (margin 0.0) - (top-margin margin) (bottom-margin margin) - (left-margin margin) (right-margin margin) - (origin %null-vec2) - (rotation 0.0) - (scale %default-scale) - (blend-mode 'alpha) - (tint white)) - "Draw a \"nine patch\" sprite. A nine patch sprite renders -TEXTURE on the rectangular area RECT whose stretchable areas are -defined by the given margin measurements. The corners are never -stretched, the left and right edges may be stretched vertically, the -top and bottom edges may be stretched horizontally, and the center may -be stretched in both directions. This rendering technique is -particularly well suited for resizable windows and buttons in -graphical user interfaces. - -MARGIN specifies the margin size for all sides of the nine patch. To -make margins of differing sizes, the TOP-MARGIN, BOTTOM-MARGIN, -LEFT-MARGIN, and RIGHT-MARGIN arguments may be used." - (set-rect-x! %rect 0.0) - (set-rect-y! %rect 0.0) - (set-rect-width! %rect (rect-width rect)) - (set-rect-height! %rect (rect-height rect)) - (set-vec2-x! position (rect-x rect)) - (set-vec2-y! position (rect-y rect)) - (matrix4-2d-transform! matrix - #:origin origin - #:position position - #:rotation rotation - #:scale scale) - (draw-nine-patch* texture %rect matrix - #:top-margin top-margin - #:bottom-margin bottom-margin - #:left-margin left-margin - #:right-margin right-margin - #:blend-mode blend-mode - #:tint tint)))) diff --git a/chickadee/render/stencil.scm b/chickadee/render/stencil.scm deleted file mode 100644 index 4a20300..0000000 --- a/chickadee/render/stencil.scm +++ /dev/null @@ -1,137 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2020 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render stencil) - #:use-module (ice-9 match) - #:use-module (gl) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:use-module (srfi srfi-9) - #:export (make-stencil-test - stencil-test? - stencil-test-mask-front - stencil-test-mask-back - stencil-test-function-front - stencil-test-function-back - stencil-test-function-mask-front - stencil-test-function-mask-back - stencil-test-reference-front - stencil-test-reference-back - stencil-test-on-fail-front - stencil-test-on-fail-back - stencil-test-on-depth-fail-front - stencil-test-on-depth-fail-back - stencil-test-on-pass-front - stencil-test-on-pass-back - default-stencil-test - apply-stencil-test)) - -(define-record-type - (%make-stencil-test mask-front mask-back function-front function-back - function-mask-front function-mask-back - reference-front reference-back - on-fail-front on-fail-back - on-depth-fail-front on-depth-fail-back - on-pass-front on-pass-back) - stencil-test? - (mask-front stencil-test-mask-front) - (mask-back stencil-test-mask-back) - (function-front stencil-test-function-front) - (function-back stencil-test-function-back) - (function-mask-front stencil-test-function-mask-front) - (function-mask-back stencil-test-function-mask-back) - (reference-front stencil-test-reference-front) - (reference-back stencil-test-reference-back) - (on-fail-front stencil-test-on-fail-front) - (on-fail-back stencil-test-on-fail-back) - (on-depth-fail-front stencil-test-on-depth-fail-front) - (on-depth-fail-back stencil-test-on-depth-fail-back) - (on-pass-front stencil-test-on-pass-front) - (on-pass-back stencil-test-on-pass-back)) - -(define* (make-stencil-test #:key (mask #xFF) (function 'always) - (function-mask #xFF) (reference 0) - (on-fail 'keep) (on-depth-fail 'keep) (on-pass 'keep) - (mask-front mask) (mask-back mask) - (function-front function) (function-back function) - (function-mask-front function-mask) - (function-mask-back function-mask) - (reference-front reference) - (reference-back reference) - (on-fail-front on-fail) (on-fail-back on-fail) - (on-depth-fail-front on-depth-fail) - (on-depth-fail-back on-depth-fail) - (on-pass-front on-pass) (on-pass-back on-pass)) - (%make-stencil-test mask-front mask-back function-front function-back - function-mask-front function-mask-back - reference-front reference-back - on-fail-front on-fail-back - on-depth-fail-front on-depth-fail-back - on-pass-front on-pass-back)) - -(define %default-stencil-test (make-stencil-test)) - -(define* (apply-stencil-test stencil) - (define (symbol->op sym) - (match sym - ('zero (stencil-op zero)) - ('keep (stencil-op keep)) - ('replace (stencil-op replace)) - ('increment (stencil-op incr)) - ('increment-wrap (version-1-4 incr-wrap)) - ('decrement (stencil-op decr)) - ('decrement-wrap (version-1-4 decr-wrap)) - ('invert (stencil-op invert)))) - (define (symbol->function sym) - (match sym - ('always (stencil-function always)) - ('never (stencil-function never)) - ('less-than (stencil-function less)) - ('equal (stencil-function equal)) - ('less-than-or-equal (stencil-function lequal)) - ('greater-than (stencil-function greater)) - ('greater-than-or-equal (stencil-function gequal)) - ('not-equal (stencil-function notequal)))) - (if stencil - (begin - (gl-enable (enable-cap stencil-test)) - ;; Mask - (gl-stencil-mask-separate (cull-face-mode front) - (stencil-test-mask-front stencil)) - (gl-stencil-mask-separate (cull-face-mode back) - (stencil-test-mask-back stencil)) - ;; Function - (gl-stencil-func-separate (cull-face-mode front) - (symbol->function - (stencil-test-function-front stencil)) - (stencil-test-reference-front stencil) - (stencil-test-function-mask-front stencil)) - (gl-stencil-func-separate (cull-face-mode back) - (symbol->function - (stencil-test-function-back stencil)) - (stencil-test-reference-back stencil) - (stencil-test-function-mask-back stencil)) - ;; Operation - (gl-stencil-op-separate (cull-face-mode front) - (symbol->op (stencil-test-on-fail-front stencil)) - (symbol->op (stencil-test-on-depth-fail-front stencil)) - (symbol->op (stencil-test-on-pass-front stencil))) - (gl-stencil-op-separate (cull-face-mode back) - (symbol->op (stencil-test-on-fail-back stencil)) - (symbol->op (stencil-test-on-depth-fail-back stencil)) - (symbol->op (stencil-test-on-pass-back stencil)))) - (gl-disable (enable-cap stencil-test)))) diff --git a/chickadee/render/texture.scm b/chickadee/render/texture.scm deleted file mode 100644 index 4aea488..0000000 --- a/chickadee/render/texture.scm +++ /dev/null @@ -1,329 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2016 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -(define-module (chickadee render texture) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (system foreign) - #:use-module (gl) - #:use-module (gl enums) - #:use-module ((sdl2 surface) #:prefix sdl2:) - #:use-module (oop goops) - #:use-module (chickadee math rect) - #:use-module (chickadee render color) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:export (make-texture - make-texture-region - load-image - texture? - texture-region? - texture-null? - texture-parent - texture-min-filter - texture-mag-filter - texture-wrap-s - texture-wrap-t - texture-x - texture-y - texture-width - texture-height - texture-gl-rect - texture-gl-tex-rect - null-texture - apply-texture - - texture-atlas - list->texture-atlas - split-texture - texture-atlas? - texture-atlas-texture - texture-atlas-ref)) - - -;;; -;;; Textures -;;; - -;; The object is a simple wrapper around an OpenGL texture -;; id. -(define-record-type - (%make-texture id parent min-filter mag-filter wrap-s wrap-t - x y width height gl-rect gl-tex-rect) - texture? - (id texture-id) - (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! - (lambda (texture port) - (format port - "#" - (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 #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 <> (class-of null-texture)) - -(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 (free-texture texture) - (gl-delete-texture (texture-id texture))) - -(define-method (gpu-finalize (texture <>)) - (free-texture texture)) - -(define (apply-texture n texture) - (let ((texture-unit (+ (version-1-3 texture0) n))) - (set-gl-active-texture texture-unit) - (gl-bind-texture (texture-target texture-2d) - (texture-id texture)))) - -(define* (make-texture pixels width height #:key - flip? - (min-filter 'linear) - (mag-filter 'linear) - (wrap-s 'repeat) - (wrap-t 'repeat) - (format 'rgba)) - "Translate the bytevector PIXELS into an OpenGL texture with -dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format. -The first pixe lin PIXELS corresponds to the upper-left corner of the -image. If this is not the case and the first pixel corresponds to the -lower-left corner of the image, set FLIP? to #t. 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), clamp, clamp-to-border, -clamp-to-edge. FORMAT specifies the pixel format. Currently only -32-bit RGBA format is supported." - (define (gl-wrap mode) - (match mode - ('repeat (texture-wrap-mode 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)))) - - (let ((texture (gpu-guard - (%make-texture (gl-generate-texture) #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)))))) - (set-gpu-texture! (current-gpu) 0 texture) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (match min-filter - ('nearest 9728) - ('linear 9729))) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (match mag-filter - ('nearest 9728) - ('linear 9729))) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-s) - (gl-wrap wrap-s)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-t) - (gl-wrap wrap-t)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (match format - ('rgba (pixel-format rgba))) - (color-pointer-type unsigned-byte) - (or pixels %null-pointer)) - 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)))) - (%make-texture (texture-id texture) - 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))) - -(define (flip-pixels-vertically pixels width height) - "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x -HEIGHT, 32 bit color bytevector." - (let ((buffer (make-u8vector (bytevector-length pixels))) - (row-width (* width 4))) ; assuming 32 bit color - (let loop ((y 0)) - (when (< y height) - (let* ((y* (- height y 1)) - (source-start (* y row-width)) - (target-start (* y* row-width))) - (bytevector-copy! pixels source-start buffer target-start row-width) - (loop (1+ y))))) - buffer)) - -(define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color) - "Convert SURFACE, an SDL2 surface object, into a texture that uses -the given MIN-FILTER and MAG-FILTER." - ;; Convert to 32 bit RGBA color. - (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888) - (lambda (surface) - (let* ((width (sdl2:surface-width surface)) - (height (sdl2:surface-height surface)) - (pixels (sdl2:surface-pixels surface))) - ;; Zero the alpha channel of pixels that match the transparent - ;; color key. - (when transparent-color - (let ((r (inexact->exact (* (color-r transparent-color) 255))) - (g (inexact->exact (* (color-g transparent-color) 255))) - (b (inexact->exact (* (color-b transparent-color) 255))) - (pixel-count (* width height 4))) - (let loop ((i 0)) - (when (< i pixel-count) - (when (and (= r (bytevector-u8-ref pixels i)) - (= g (bytevector-u8-ref pixels (+ i 1))) - (= b (bytevector-u8-ref pixels (+ i 2)))) - (bytevector-u8-set! pixels (+ i 3) 0)) - (loop (+ i 4)))))) - (make-texture pixels width height - #:min-filter min-filter - #:mag-filter mag-filter - #:wrap-s wrap-s - #:wrap-t wrap-t))))) - -(define* (load-image file #:key - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) - transparent-color) - "Load a texture from an image in FILE. 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." - (sdl2:call-with-surface ((@ (sdl2 image) load-image) file) - (lambda (surface) - (surface->texture surface min-filter mag-filter wrap-s wrap-t - transparent-color)))) - - -;;; -;;; Texture Atlas -;;; - -(define-record-type - (%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 atlas) - (vector-length (texture-atlas-vector atlas)))) - -(set-record-type-printer! 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-ref atlas index) - "Return the texture region associated with INDEX in -ATLAS." - (vector-ref (texture-atlas-vector atlas) index)) - -(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." - (let* ((w (texture-width texture)) - (h (texture-height texture)) - (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing))))) - (columns (inexact->exact (ceiling (/ (- w margin) (+ tile-width spacing))))) - (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)))) - (let y-loop ((y 0)) - (when (< y rows) - (let x-loop ((x 0)) - (when (< x columns) - (vector-set! v (+ x (* y columns)) (make-tile x y)) - (x-loop (1+ x)))) - (y-loop (1+ y)))) - (%make-texture-atlas texture v))) diff --git a/chickadee/render/tiled.scm b/chickadee/render/tiled.scm deleted file mode 100644 index 7ce8c53..0000000 --- a/chickadee/render/tiled.scm +++ /dev/null @@ -1,497 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2018 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Tiled map format parser and renderer. -;; -;;; Code: - -(define-module (chickadee render tiled) - #:use-module (chickadee math matrix) - #:use-module (chickadee math rect) - #:use-module (chickadee math vector) - #:use-module (chickadee render) - #:use-module (chickadee render color) - #:use-module (chickadee render sprite) - #:use-module (chickadee render texture) - #:use-module (chickadee render viewport) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-43) - #:use-module (sxml simple) - #:use-module (sxml xpath) - #:export (tile-map? - tile-map-orientation - tile-map-width - tile-map-height - tile-map-tile-width - tile-map-tile-height - tile-map-tilesets - tile-map-layers - tile-map-properties - tile-map-rect - tile-map-layer-ref - point->tile - - animation-frame? - animation-frame-tile - animation-frame-duration - - tile? - tile-id - tile-animation - tile-properties - - tileset? - tileset-name - tileset-first-gid - tileset-size - tileset-tile-width - tileset-tile-height - tileset-atlas - tileset-tiles - tileset-properties - - map-tile? - map-tile-ref - map-tile-rect - - tile-layer? - tile-layer-name - tile-layer-width - tile-layer-height - tile-layer-tiles - tile-layer-properties - - object-layer? - object-layer-name - object-layer-objects - object-layer-properties - - polygon? - polygon-points - - map-object? - map-object-id - map-object-name - map-object-type - map-object-shape - map-object-properties - - load-tile-map - draw-tile-map - draw-tile-map*)) - -(define-record-type - (%make-tile-map orientation width height tile-width tile-height - tilesets layers properties rect) - tile-map? - (orientation tile-map-orientation) - (width tile-map-width) - (height tile-map-height) - (tile-width tile-map-tile-width) - (tile-height tile-map-tile-height) - (tilesets tile-map-tilesets) - (layers tile-map-layers) - (properties tile-map-properties) - (rect tile-map-rect)) - -(define-record-type - (%make-animation-frame tile duration) - animation-frame? - (tile animation-frame-tile) - (duration animation-frame-duration)) - -(define-record-type - (%make-tile id texture batch animation properties) - tile? - (id tile-id) - (texture tile-texture) - (batch tile-batch) - (animation tile-animation) - (properties tile-properties)) - -(define-record-type - (%make-tileset name first-gid size tile-width tile-height - atlas tiles properties batch) - tileset? - (name tileset-name) - (first-gid tileset-first-gid) - (size tileset-size) - (tile-width tileset-tile-width) - (tile-height tileset-tile-height) - (atlas tileset-atlas) - (tiles tileset-tiles) - (properties tileset-properties) - (batch tileset-batch)) - -(define-record-type - (%make-map-tile tile rect) - map-tile? - (tile map-tile-ref) - (rect map-tile-rect)) - -(define-record-type - (%make-tile-layer name width height tiles properties) - tile-layer? - (name tile-layer-name) - (width tile-layer-width) - (height tile-layer-height) - (tiles tile-layer-tiles) - (properties tile-layer-properties)) - -(define-record-type - (%make-object-layer name objects properties) - object-layer? - (name object-layer-name) - (objects object-layer-objects) - (properties object-layer-properties)) - -;; TODO: This should probably be a generic thing that we can use -;; outside of tiled maps. -(define-record-type - (make-polygon points) - polygon? - (points polygon-points)) - -(define-record-type - (%make-map-object id name type shape properties) - map-object? - (id map-object-id) - (name map-object-name) - (type map-object-type) - (shape map-object-shape) - (properties map-object-properties)) - -(define (tile-map-layer-ref tile-map name) - "Return the layer named NAME." - (define (layer-name layer) - (if (tile-layer? layer) - (tile-layer-name layer) - (object-layer-name layer))) - (let ((layers (tile-map-layers tile-map))) - (let loop ((i 0)) - (cond - ((= i (vector-length layers)) - #f) - ((string=? name (layer-name (vector-ref layers i))) - (vector-ref layers i)) - (else - (loop (+ i 1))))))) - -(define (point->tile tile-map x y) - "Translate the pixel coordinates (X, Y) into tile coordinates." - (values (floor (/ x (tile-map-tile-width tile-map))) - (floor (/ y (tile-map-tile-height tile-map))))) - -(define (load-tile-map file-name) - "Load the Tiled TMX formatted map in FILE-NAME." - (define map-directory - (if (absolute-file-name? file-name) - (dirname file-name) - (string-append (getcwd) "/" (dirname file-name)))) - (define (scope file-name) - (string-append map-directory "/" file-name)) - (define* (attr node name #:optional (parse identity)) - (let ((result ((sxpath `(@ ,name *text*)) node))) - (if (null? result) - #f - (parse (car result))))) - (define (parse-color-channel s start) - (/ (string->number (substring s start (+ start 2)) 16) 255.0)) - (define (parse-property node) - (let ((name (attr node 'name string->symbol)) - (type (or (attr node 'type string->symbol) 'string)) - (value (attr node 'value))) - (cons name - (match type - ((or 'string 'file) value) - ('bool (not (string=? value "false"))) - ((or 'int 'float) (string->number value)) - ('color - (make-color (parse-color-channel value 3) - (parse-color-channel value 5) - (parse-color-channel value 7) - (parse-color-channel value 1))) - (_ (error "unsupported property type" type)))))) - (define (parse-image node) - (let ((source (attr node 'source)) - (trans (attr node 'trans))) - (load-image (scope source) - #:transparent-color (and trans (string->color trans))))) - (define (parse-frame node) - (let ((tile-id (attr node 'tileid string->number)) - (duration (attr node 'duration string->number))) - ;; TODO: lookup actual tile in tileset - (%make-animation-frame tile-id duration))) - (define (parse-tile node rows columns atlas batch) - (let ((id (attr node 'id string->number)) - (animation (map parse-frame ((sxpath '(animation frame)) node))) - (properties (map parse-property - ((sxpath '(properties property)) node)))) - (%make-tile id (texture-atlas-ref atlas id) batch animation properties))) - (define (parse-tiles nodes size columns atlas batch) - (let ((table (make-hash-table)) - (tiles (make-vector size)) - (rows (/ size columns))) - (for-each (lambda (node) - (let ((tile (parse-tile node rows columns atlas batch))) - (hash-set! table (tile-id tile) tile))) - nodes) - (let loop ((i 0)) - (when (< i size) - (let ((tile - (or (hash-ref table i) - (%make-tile i (texture-atlas-ref atlas i) batch #f '())))) - (vector-set! tiles i tile)) - (loop (+ i 1)))) - tiles)) - (define (first-gid node) - (attr node 'firstgid string->number)) - (define (parse-internal-tileset node first-gid) - (let* ((name (attr node 'name)) - (tile-width (attr node 'tilewidth string->number)) - (tile-height (attr node 'tileheight string->number)) - (margin (or (attr node 'margin string->number) 0)) - (spacing (or (attr node 'spacing string->number) 0)) - (columns (attr node 'columns string->number)) - (size (attr node 'tilecount string->number)) - (texture (parse-image ((sxpath '(image)) node))) - (atlas (split-texture texture tile-width tile-height - #:margin margin #:spacing spacing)) - (batch (make-sprite-batch texture)) - (tiles (parse-tiles ((sxpath '(tile)) node) size columns atlas batch)) - (properties (map parse-property - ((sxpath '(properties property)) node)))) - (%make-tileset name first-gid size tile-width tile-height - atlas tiles properties batch))) - (define (parse-external-tileset node) - (let* ((first-gid (attr node 'firstgid string->number)) - (source (scope (attr node 'source))) - (tree (call-with-input-file source xml->sxml))) - (parse-internal-tileset (car ((sxpath '(tileset)) tree)) first-gid))) - (define (parse-tileset node) - (if (attr node 'source) - (parse-external-tileset node) - (parse-internal-tileset node (first-gid node)))) - (define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height) - ;; The top 3 bits of the tile gid are flags for various types of - ;; flipping. - ;; - ;; TODO: Respect the flipping settings. - (let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0)) - (flipped-vertically? (> (logand raw-gid #x40000000) 0)) - (flipped-diagonally? (> (logand raw-gid #x20000000) 0)) - ;; Remove the upper 3 bits to get the true tile id. - (gid (logand raw-gid #x1FFFFFFF)) - (tileset (find (lambda (t) - (and (>= gid (tileset-first-gid t)) - (< gid (+ (tileset-first-gid t) - (tileset-size t))))) - tilesets)) - (tw (tileset-tile-width tileset)) - (th (tileset-tile-height tileset))) - (%make-map-tile (vector-ref (tileset-tiles tileset) - (- gid (tileset-first-gid tileset))) - (make-rect (* x tw) (* y th) tw th)))) - (define (tile-gids->map-tiles gids width height tilesets) - (let ((tiles (make-vector (* width height)))) - (let y-loop ((y 0) - (rows (reverse gids))) ; invert y - (when (< y height) - (match rows - ((row . rest) - (let x-loop ((x 0) - (columns row)) - (when (< x width) - (match columns - ((gid . rest) - (vector-set! tiles - (+ (* width y) x) - (if (zero? gid) - #f - (tile-gid->map-tile gid tilesets - x y width height))) - (x-loop (+ x 1) rest))))) - (y-loop (+ y 1) rest))))) - tiles)) - (define (parse-csv lines width height tilesets) - (let ((gids (map (lambda (line) - (filter-map (lambda (s) - (and (not (string-null? s)) - (string->number s))) - (string-split line #\,))) - (take (drop (string-split lines #\newline) 1) height)))) - (tile-gids->map-tiles gids width height tilesets))) - (define (parse-layer-data node width height tilesets) - (let ((encoding (attr node 'encoding string->symbol)) - (data (car ((sxpath '(*text*)) node)))) - (match encoding - ('csv (parse-csv data width height tilesets)) - (_ (error "unsupported tile layer encoding" encoding))))) - (define (parse-tile-layer node tilesets) - (let* ((name (attr node 'name)) - (width (attr node 'width string->number)) - (height (attr node 'height string->number)) - (tiles (parse-layer-data ((sxpath '(data)) node) - width height tilesets)) - (properties (map parse-property - ((sxpath '(properties property)) node)))) - (%make-tile-layer name width height tiles properties))) - (define (parse-polygon node pixel-height) - (make-polygon - (list->vector - (map (lambda (s) - (match (string-split s #\,) - ((x y) - (vec2 (string->number x) - (- pixel-height (string->number y)))))) - (string-split (attr node 'points) #\space))))) - (define (parse-object node pixel-height) - (let* ((id (attr node 'id string->number)) - (name (attr node 'name)) - (type (attr node 'type string->symbol)) - (x (attr node 'x string->number)) - (y (- pixel-height (attr node 'y string->number))) - (width (attr node 'width string->number)) - (height (attr node 'height string->number)) - (shape (if (and width height) - (make-rect x y width height) - (parse-polygon (car ((sxpath '(polygon)) node)) - pixel-height))) - (properties (map parse-property - ((sxpath '(properties property)) node)))) - (%make-map-object id name type shape properties))) - (define (parse-object-layer node pixel-height) - (let ((name (attr node 'name)) - (objects (map (lambda (node) - (parse-object node pixel-height)) - ((sxpath '(object)) node))) - (properties (map parse-property - ((sxpath '(properties property)) node)))) - (%make-object-layer name objects properties))) - (let* ((tree (call-with-input-file file-name xml->sxml)) - (m ((sxpath '(map)) tree)) - (version (let ((version (attr m 'version))) - (unless (any (lambda (v) (string=? version v)) '("1.0" "1.1" "1.2")) - (error "unsupported tiled map format version" version)) - version)) - (orientation (attr m 'orientation string->symbol)) - (width (attr m 'width string->number)) - (height (attr m 'height string->number)) - (tile-width (attr m 'tilewidth string->number)) - (tile-height (attr m 'tileheight string->number)) - (properties ((sxpath '(map properties property)) tree)) - (tilesets (map parse-tileset ((sxpath '(map tileset)) tree))) - (layers ((node-or (sxpath '(map layer)) - (sxpath '(map objectgroup))) - tree))) - (%make-tile-map orientation width height tile-width tile-height - tilesets - (list->vector - (map (lambda (node) - (match node - (('layer . _) - (parse-tile-layer node tilesets)) - (('objectgroup . _) - (parse-object-layer node (* height tile-height))))) - layers)) - (map parse-property properties) - (make-rect 0.0 - 0.0 - (* width tile-width) - (* height tile-height))))) - - -(define (draw-tile-layer layer matrix x1 y1 x2 y2) - (let ((width (tile-layer-width layer)) - (height (tile-layer-height layer))) - (let y-loop ((y y1)) - (when (< y y2) - (let x-loop ((x x1)) - (when (< x x2) - (let ((tile (vector-ref (tile-layer-tiles layer) - (+ (* y width) x)))) - (when tile - (let ((tref (map-tile-ref tile))) - (sprite-batch-add* (tile-batch tref) - (map-tile-rect tile) - matrix - #:texture-region (tile-texture tref))))) - (x-loop (+ x 1)))) - (y-loop (+ y 1)))))) - -(define* (draw-tile-map* tile-map matrix region #:key layers) - ;; Calculate the tiles that are visible so we don't waste time - ;; drawing unnecessary sprites. - (let* ((w (tile-map-width tile-map)) - (h (tile-map-height tile-map)) - (tw (tile-map-tile-width tile-map)) - (th (tile-map-tile-height tile-map)) - (rx (rect-x region)) - (ry (rect-y region)) - (rw (rect-width region)) - (rh (rect-height region)) - (x1 (max (inexact->exact (floor (/ rx tw))) 0)) - (y1 (max (inexact->exact (floor (/ ry th))) 0)) - (x2 (min (inexact->exact (ceiling (/ (+ rx rw) tw))) w)) - (y2 (min (inexact->exact (ceiling (/ (+ ry rh) th))) h))) - (vector-for-each (lambda (i layer) - (when (and (tile-layer? layer) - (or (not layers) - (memv i layers))) - (for-each (lambda (tileset) - (sprite-batch-clear! (tileset-batch tileset))) - (tile-map-tilesets tile-map)) - (draw-tile-layer layer matrix x1 y1 x2 y2) - (for-each (lambda (tileset) - (draw-sprite-batch (tileset-batch tileset))) - (tile-map-tilesets tile-map)))) - (tile-map-layers tile-map)))) - -(define %null-vec2 (vec2 0.0 0.0)) -(define %default-scale (vec2 1.0 1.0)) -(define %matrix (make-null-matrix4)) -(define %region (make-rect 0.0 0.0 0.0 0.0)) - -;; Make a default region that is as big as the viewport. -(define (default-region tile-map position) - (let ((vp (current-viewport))) - (set-rect-x! %region (- (vec2-x position))) - (set-rect-y! %region (- (vec2-y position))) - (set-rect-width! %region (viewport-width vp)) - (set-rect-height! %region (viewport-height vp)) - %region)) - -(define* (draw-tile-map tile-map - #:key - layers - (position %null-vec2) - (region (default-region tile-map position)) - (origin %null-vec2) - (scale %default-scale) - (rotation 0.0)) - "Draw TILE-MAP. By default, all layers are drawn. The LAYERS -argument may be used to specify a list of layers to draw, instead." - (matrix4-2d-transform! %matrix - #:origin origin - #:position position - #:rotation rotation - #:scale scale) - (draw-tile-map* tile-map %matrix region #:layers layers)) diff --git a/chickadee/render/viewport.scm b/chickadee/render/viewport.scm deleted file mode 100644 index 7b9a192..0000000 --- a/chickadee/render/viewport.scm +++ /dev/null @@ -1,111 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2017 David Thompson -;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. -;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Viewports specify the renderable section of a window. -;; -;;; Code: - -(define-module (chickadee render viewport) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) - #:use-module (gl) - #:use-module (chickadee utils) - #:use-module (chickadee render color) - #:use-module (chickadee render gl) - #:use-module (chickadee render gpu) - #:export (make-viewport - viewport? - viewport-x - viewport-y - viewport-width - viewport-height - viewport-clear-color - viewport-clear-flags - null-viewport - apply-viewport - clear-viewport - %default-clear-flags - %default-clear-color)) - -(define-record-type - (%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 viewport) - (gl-clear (clear-buffer-mask (viewport-clear-flags 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))))) diff --git a/doc/api.texi b/doc/api.texi index 84bcaed..a227cdc 100644 --- a/doc/api.texi +++ b/doc/api.texi @@ -1530,7 +1530,7 @@ will@dots{} Okay, okay. We all know what colors are. Chickadee provides a data type to represent color and some convenient procedures to work with -them in the @code{(chickadee render color)} module. Colors are made +them in the @code{(chickadee graphics color)} module. Colors are made up of four components, or channels: red, green, blue, and alpha (transparency.) Each of these values is expressed as a uniform floating point value in the range [0, 1]. 0 means that color channel @@ -1756,7 +1756,7 @@ Tango color palette}. @subsection Textures Textures are essentially images: a 2D grid of color values. The -@code{(chickadee render texture)} module provides an interface for +@code{(chickadee graphics texture)} module provides an interface for working with texture objects. @deffn {Procedure} load-image file [#:min-filter nearest] @ @@ -1868,7 +1868,7 @@ bitmap that is rendered to the screen. For 2D games, sprites are the most essential graphical abstraction. They are used for drawing maps, players, NPCs, items, particles, text, etc. -In Chickadee, the @code{(chickadee render sprite)} module provides the +In Chickadee, the @code{(chickadee graphics sprite)} module provides the interface for working with sprites. Bitmaps are stored in textures (@pxref{Textures}) and can be used to draw sprites via the @code{draw-sprite} procedure. @@ -2001,7 +2001,7 @@ A tile map is a scene created by composing lots of small sprites, called ``tiles'', into a larger image. One program for editing such maps is called @url{http://mapeditor.org,Tiled}. Chickadee has native support for loading and rendering Tiled maps in the @code{(chickadee -render tiled)} module. +graphics tiled)} module. @deffn {Procedure} load-tile-map file-name Load the Tiled formatted map in @var{file-name} and return a new tile @@ -2212,7 +2212,7 @@ Return the list of points that form @var{polygon}. @subsection Lines and Shapes Sprites are fun, but sometimes simple, untextured lines and polygons -are desired. That's where the @code{(chickadee render shapes)} module +are desired. That's where the @code{(chickadee graphics shapes)} module comes in! @deffn {Procedure} draw-line start end @ @@ -2280,7 +2280,7 @@ bitmap fonts. A default font named Inconsolata is used for all text rendering operations where a font is not specified, as is the case in the above example. -The following procedures can be found in the @code{(chickadee render +The following procedures can be found in the @code{(chickadee graphics font)} module: @deffn {Procedure} load-font file-name point-size [#:char-set] @@ -2349,14 +2349,14 @@ all of these effects, and more, can be accomplished by turning a few configuration knobs in a ``particle system''. A particle system takes care of managing the many miniscule moving morsels so the developer can quickly produce an effect and move on with their life. The -@code{(chickadee render particles)} module provides an API for +@code{(chickadee graphics particles)} module provides an API for manipulating particle systems. Below is an example of a very simple particle system that utilizes nearly all of the default configuration settings: @example -(use-modules (chickadee render particles)) +(use-modules (chickadee graphics particles)) (define texture (load-image "particle.png")) (define particles (make-particles 2000 #:texture texture)) @end example @@ -2504,7 +2504,7 @@ Here's some basic boilerplate to render a 3D model: (use-modules (chickadee) (chickadee math) (chickadee math matrix) - (chickadee render model)) + (chickadee graphics model)) (define model #f) (define projection-matrix @@ -2642,7 +2642,7 @@ render to two different viewports, each occupying a different half of the screen. For information about how to set the current viewport, see @code{with-viewport} in @ref{Rendering Engine}. -The @code{(chickadee render viewport)} module provides the following +The @code{(chickadee graphics viewport)} module provides the following API: @deffn {Procedure} make-viewport x y width height @ @@ -2704,7 +2704,7 @@ would be tedious to have to have to specify them each time @code{gpu-apply} is called. The following procedures and syntax can be found in the -@code{(chickadee render)} module. +@code{(chickadee graphics)} module. @deffn {Syntax} gpu-apply shader vertex-array @ [#:uniform-key uniform-value @dots{}] @@ -2795,7 +2795,7 @@ Alright, let's brush aside all of those pretty high level abstractions and discuss what is going on under the hood. The GPU exists as a discrete piece of hardware separate from the CPU. In order to make it draw things, we must ship lots of data out of our memory space and -into the GPU. The @code{(chickadee render buffer}) module provides an +into the GPU. The @code{(chickadee graphics buffer}) module provides an API for manipulating GPU buffers. In OpenGL terminology, a chunk of data allocated on the GPU is a @@ -2804,7 +2804,7 @@ that could be transformed into a GPU buffer that packs together vertex position and texture coordinates: @example -(use-modules (chickadee render buffer) (srfi srfi-4)) +(use-modules (chickadee graphics buffer) (srfi srfi-4)) (define data (f32vector -8.0 -8.0 ; 2D vertex 0.0 0.0 ; 2D texture coordinate @@ -3139,7 +3139,7 @@ Return the primitive rendering mode for @var{vertex-array}. Shaders are programs that the GPU can evaluate that allow the programmer to completely customized the final output of a GPU draw -call. The @code{(chickadee render shader)} module provides an API for +call. The @code{(chickadee graphics shader)} module provides an API for building custom shaders. Shaders are written in the OpenGL Shading Language, or GLSL for short. diff --git a/examples/audio.scm b/examples/audio.scm index b3e1de4..c9885a2 100644 --- a/examples/audio.scm +++ b/examples/audio.scm @@ -1,7 +1,7 @@ (use-modules (chickadee) (chickadee audio) (chickadee math vector) - (chickadee render font) + (chickadee graphics font) (ice-9 match)) (define effect #f) diff --git a/examples/game-controller.scm b/examples/game-controller.scm index 77a0ac0..44070ac 100644 --- a/examples/game-controller.scm +++ b/examples/game-controller.scm @@ -1,9 +1,9 @@ (use-modules (chickadee) (chickadee math vector) - (chickadee render color) - (chickadee render font) - (chickadee render sprite) - (chickadee render texture) + (chickadee graphics color) + (chickadee graphics font) + (chickadee graphics sprite) + (chickadee graphics texture) (ice-9 match)) (define batch #f) diff --git a/examples/grid.scm b/examples/grid.scm index e9fe2cc..58ada10 100644 --- a/examples/grid.scm +++ b/examples/grid.scm @@ -2,11 +2,11 @@ (chickadee math grid) (chickadee math vector) (chickadee math rect) - (chickadee render) - (chickadee render color) - (chickadee render font) - (chickadee render shapes) - (chickadee render sprite)) + (chickadee graphics) + (chickadee graphics color) + (chickadee graphics font) + (chickadee graphics shapes) + (chickadee graphics sprite)) (define grid (make-grid)) (define item-color (make-color 0.7 0.0 0.0 0.5)) diff --git a/examples/lines.scm b/examples/lines.scm index b7a551a..6750083 100644 --- a/examples/lines.scm +++ b/examples/lines.scm @@ -2,8 +2,8 @@ (srfi srfi-1) (chickadee) (chickadee math vector) - (chickadee render color) - (chickadee render shapes)) + (chickadee graphics color) + (chickadee graphics shapes)) (define lines (list-tabulate 48 diff --git a/examples/model.scm b/examples/model.scm index 5980e85..d345988 100644 --- a/examples/model.scm +++ b/examples/model.scm @@ -2,9 +2,9 @@ (chickadee math) (chickadee math matrix) (chickadee math vector) - (chickadee render) - (chickadee render model) - (chickadee render font) + (chickadee graphics) + (chickadee graphics model) + (chickadee graphics font) (ice-9 format)) (define projection (perspective-projection (/ pi 3) (/ 4.0 3.0) 0.1 500.0)) diff --git a/examples/nine-patch.scm b/examples/nine-patch.scm index ff5b9a8..d8988c8 100644 --- a/examples/nine-patch.scm +++ b/examples/nine-patch.scm @@ -1,9 +1,9 @@ (use-modules (chickadee) (chickadee math rect) (chickadee math vector) - (chickadee render font) - (chickadee render sprite) - (chickadee render texture)) + (chickadee graphics font) + (chickadee graphics sprite) + (chickadee graphics texture)) (define image #f) diff --git a/examples/particles.scm b/examples/particles.scm index c51f62f..5b42025 100644 --- a/examples/particles.scm +++ b/examples/particles.scm @@ -1,12 +1,12 @@ (use-modules (chickadee) (chickadee math rect) (chickadee math vector) - (chickadee render) - (chickadee render color) - (chickadee render font) - (chickadee render particles) - (chickadee render sprite) - (chickadee render texture) + (chickadee graphics) + (chickadee graphics color) + (chickadee graphics font) + (chickadee graphics particles) + (chickadee graphics sprite) + (chickadee graphics texture) (chickadee scripting) (ice-9 format) ((sdl2) #:select (sdl-ticks))) diff --git a/examples/sprite-batch.scm b/examples/sprite-batch.scm index 4bddf8f..d4cccb5 100644 --- a/examples/sprite-batch.scm +++ b/examples/sprite-batch.scm @@ -2,10 +2,10 @@ (chickadee math matrix) (chickadee math rect) (chickadee math vector) - (chickadee render) - (chickadee render font) - (chickadee render sprite) - (chickadee render texture) + (chickadee graphics) + (chickadee graphics font) + (chickadee graphics sprite) + (chickadee graphics texture) (chickadee scripting) (ice-9 format) (ice-9 match) diff --git a/examples/sprite.scm b/examples/sprite.scm index 0e8b4b3..a132c92 100644 --- a/examples/sprite.scm +++ b/examples/sprite.scm @@ -1,7 +1,7 @@ (use-modules (chickadee) (chickadee math vector) - (chickadee render sprite) - (chickadee render texture)) + (chickadee graphics sprite) + (chickadee graphics texture)) (define sprite #f) diff --git a/examples/text.scm b/examples/text.scm index df0a2ed..dd9c83a 100644 --- a/examples/text.scm +++ b/examples/text.scm @@ -1,6 +1,6 @@ (use-modules (chickadee) (chickadee math vector) - (chickadee render font)) + (chickadee graphics font)) (define (draw alpha) (draw-text "The quick brown fox jumps over the lazy dog.\nFive hexing wizard bots jump quickly." diff --git a/examples/tiled.scm b/examples/tiled.scm index e6099df..e1bf22a 100644 --- a/examples/tiled.scm +++ b/examples/tiled.scm @@ -1,8 +1,8 @@ (use-modules (chickadee) (chickadee math vector) (chickadee math rect) - (chickadee render font) - (chickadee render tiled) + (chickadee graphics font) + (chickadee graphics tiled) (ice-9 format) (ice-9 match) (srfi srfi-11)) -- cgit v1.2.3