summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el5
-rw-r--r--.gitignore2
-rw-r--r--Makefile.am18
-rw-r--r--chickadee.scm2
-rw-r--r--chickadee/graphics/buffer.scm401
-rw-r--r--chickadee/graphics/color.scm7
-rw-r--r--chickadee/graphics/engine.scm2
-rw-r--r--chickadee/graphics/gl.scm10
-rw-r--r--chickadee/graphics/mesh.scm639
-rw-r--r--chickadee/graphics/model.scm372
-rw-r--r--chickadee/graphics/path.scm169
-rw-r--r--chickadee/graphics/pbr.scm164
-rw-r--r--chickadee/graphics/phong.scm94
-rw-r--r--chickadee/graphics/shader.scm34
-rw-r--r--chickadee/graphics/skybox.scm101
-rw-r--r--chickadee/graphics/texture.scm314
-rw-r--r--chickadee/math.scm8
-rw-r--r--chickadee/math/matrix.scm53
-rw-r--r--chickadee/math/vector.scm8
-rw-r--r--configure.ac1
-rw-r--r--data/shaders/path-fill-frag.glsl41
-rw-r--r--data/shaders/path-fill-vert.glsl30
-rw-r--r--data/shaders/path-frag.glsl93
-rw-r--r--data/shaders/path-stroke-frag.glsl77
-rw-r--r--data/shaders/path-stroke-vert.glsl (renamed from data/shaders/path-vert.glsl)17
-rw-r--r--data/shaders/pbr-frag.glsl94
-rw-r--r--data/shaders/pbr-vert.glsl10
-rw-r--r--data/shaders/phong-frag.glsl92
-rw-r--r--data/shaders/phong-vert.glsl2
-rw-r--r--doc/api.texi107
-rw-r--r--examples/path.scm5
-rw-r--r--test-env.in5
-rw-r--r--tests/math/vector.scm88
-rw-r--r--tests/utils.scm26
34 files changed, 2085 insertions, 1006 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 9eb5b8e..8b26cb4 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -1,7 +1,10 @@
((nil . ((compile-command . "make -j$(nproc)")))
(scheme-mode
.
- ((eval . (put 'sdl2:call-with-surface 'scheme-indent-function 1))
+ ((eval . (put 'with-tests 'scheme-indent-function 1))
+ (eval . (put 'test-group 'scheme-indent-function 1))
+ (eval . (put 'sdl2:call-with-surface 'scheme-indent-function 1))
+ (eval . (put 'call-with-loaded-image 'scheme-indent-function 3))
(eval . (put 'with-blend-mode 'scheme-indent-function 1))
(eval . (put 'with-polygon-mode 'scheme-indent-function 1))
(eval . (put 'with-cull-face-mode 'scheme-indent-function 1))
diff --git a/.gitignore b/.gitignore
index eddda1d..fde1483 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,6 +2,8 @@
*.tar.gz
*.tar.gz.asc
*~
+*.log
+*.trs
/configure
/config.status
diff --git a/Makefile.am b/Makefile.am
index 4b5d802..806157f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -80,7 +80,9 @@ SOURCES = \
chickadee/graphics/font.scm \
chickadee/graphics/tile-map.scm \
chickadee/graphics/particles.scm \
+ chickadee/graphics/skybox.scm \
chickadee/graphics/light.scm \
+ chickadee/graphics/mesh.scm \
chickadee/graphics/phong.scm \
chickadee/graphics/pbr.scm \
chickadee/graphics/model.scm \
@@ -91,6 +93,13 @@ SOURCES = \
chickadee/scripting.scm \
chickadee.scm
+TESTS = \
+ tests/math/vector.scm
+
+TEST_EXTENSIONS = .scm
+SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE)
+AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
+
EXTRA_DIST += \
COPYING \
run-example \
@@ -119,7 +128,8 @@ EXTRA_DIST += \
examples/images/serene-village.png \
examples/maps/example.tmx \
examples/maps/serene-village.tsx \
- examples/models/suzanne.obj
+ examples/models/suzanne.obj \
+ tests/utils.scm
dist_pkgdata_DATA = \
data/AUTHORS \
@@ -131,8 +141,10 @@ dist_fonts_DATA = \
shadersdir = $(pkgdatadir)/shaders
dist_shaders_DATA = \
- data/shaders/path-vert.glsl \
- data/shaders/path-frag.glsl \
+ data/shaders/path-fill-frag.glsl \
+ data/shaders/path-fill-vert.glsl \
+ data/shaders/path-stroke-frag.glsl \
+ data/shaders/path-stroke-vert.glsl \
data/shaders/pbr-vert.glsl \
data/shaders/pbr-frag.glsl \
data/shaders/phong-vert.glsl \
diff --git a/chickadee.scm b/chickadee.scm
index 8adc313..bffb83c 100644
--- a/chickadee.scm
+++ b/chickadee.scm
@@ -401,6 +401,8 @@ border is disabled, otherwise it is enabled.")
(current-error-port))))
;; Turn off multisampling by default.
(gl-disable (version-1-3 multisample))
+ ;; Enable seamless cube maps.
+ (gl-enable (version-3-2 texture-cube-map-seamless))
(load)
(sdl2:load-game-controller-mappings!
(scope-datadir "gamecontrollerdb.txt"))
diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm
index 89ee376..5ee12da 100644
--- a/chickadee/graphics/buffer.scm
+++ b/chickadee/graphics/buffer.scm
@@ -53,32 +53,17 @@
unmap-buffer!
resize-buffer!
- make-dynamic-buffer
- dynamic-buffer?
- dynamic-buffer->buffer
- dynamic-buffer-data
- dynamic-buffer-capacity
- dynamic-buffer-count
- dynamic-buffer-next!
- dynamic-buffer-clear!
- dynamic-buffer-map!
- dynamic-buffer-unmap!
- dynamic-buffer-import!
-
- make-buffer-view
- buffer-view?
- buffer-view->buffer
- buffer-view-name
- buffer-view-offset
- buffer-view-component-type
- buffer-view-normalized?
- buffer-view-length
- buffer-view-type
- buffer-view-max
- buffer-view-min
- buffer-view-sparse
- buffer-view-data
- buffer-view-divisor
+ make-vertex-attribute
+ vertex-attribute?
+ vertex-attribute->buffer
+ vertex-attribute-name
+ vertex-attribute-offset
+ vertex-attribute-component-type
+ vertex-attribute-normalized?
+ vertex-attribute-length
+ vertex-attribute-type
+ vertex-attribute-data
+ vertex-attribute-divisor
make-vertex-array
vertex-array?
@@ -91,6 +76,18 @@
render-vertices
render-vertices/instanced
+ make-dynamic-buffer
+ dynamic-buffer?
+ dynamic-buffer->buffer
+ dynamic-buffer-data
+ dynamic-buffer-capacity
+ dynamic-buffer-count
+ dynamic-buffer-next!
+ dynamic-buffer-clear!
+ dynamic-buffer-map!
+ dynamic-buffer-unmap!
+ dynamic-buffer-import!
+
define-geometry-type
geometry-type?
geometry-type-attributes
@@ -278,85 +275,7 @@ resized."
;;;
-;;; Dynamic Buffers
-;;;
-
-;; A layer on top of vertex buffers to handle buffer streaming with
-;; dynamic buffer expansion.
-(define-record-type <dynamic-buffer>
- (%make-dynamic-buffer buffer capacity count)
- dynamic-buffer?
- (buffer dynamic-buffer->buffer)
- (data dynamic-buffer-data set-dynamic-buffer-data!)
- (capacity dynamic-buffer-capacity set-dynamic-buffer-capacity!)
- (count dynamic-buffer-count set-dynamic-buffer-count!))
-
-(define* (make-dynamic-buffer #:key name capacity stride usage (target 'vertex))
- (let* ((buffer (make-buffer #f
- #:name name
- #:length (* capacity stride)
- #:stride stride
- #:usage usage
- #:target target)))
- (%make-dynamic-buffer buffer capacity 0)))
-
-(define-inlinable (dynamic-buffer-bounds-check dbuffer i)
- (unless (< i (dynamic-buffer-count dbuffer))
- (error "index out of bounds" i)))
-
-(define (expand-dynamic-buffer dbuffer)
- (let ((new-capacity (inexact->exact
- (round (* (dynamic-buffer-capacity dbuffer) 1.5))))
- (buffer (dynamic-buffer->buffer dbuffer)))
- (resize-buffer! buffer (* new-capacity (buffer-stride buffer)))
- (set-dynamic-buffer-capacity! dbuffer new-capacity)
- (set-dynamic-buffer-data! dbuffer (buffer-data buffer))))
-
-(define-inlinable (dynamic-buffer-next! dbuffer n)
- (let ((count (dynamic-buffer-count dbuffer)))
- (let resize ()
- (let ((capacity (dynamic-buffer-capacity dbuffer)))
- (when (> (+ count n) capacity)
- (expand-dynamic-buffer dbuffer)
- (resize))))
- (set-dynamic-buffer-count! dbuffer (+ count n))
- count))
-
-(define (dynamic-buffer-clear! dbuffer)
- (set-dynamic-buffer-count! dbuffer 0))
-
-(define (dynamic-buffer-map! dbuffer)
- (let ((buffer (dynamic-buffer->buffer dbuffer)))
- (dynamic-buffer-clear! dbuffer)
- (map-buffer! buffer 'write-only)
- ;; Stashing the bytevector here turns out to be a *huge* performance
- ;; booster. Probably because it's avoiding another layer of record
- ;; type checks and stuff? I dunno.
- (set-dynamic-buffer-data! dbuffer (buffer-data buffer))))
-
-(define (dynamic-buffer-unmap! dbuffer)
- (unmap-buffer! (dynamic-buffer->buffer dbuffer))
- (set-dynamic-buffer-data! dbuffer #f))
-
-(define (dynamic-buffer-import! dbuffer bv start end)
- (let ((stride (buffer-stride (dynamic-buffer->buffer dbuffer)))
- (copy-count (- end start)))
- (let resize ()
- (let ((capacity (dynamic-buffer-capacity dbuffer)))
- (when (< capacity copy-count)
- (begin
- (expand-dynamic-buffer dbuffer)
- (resize)))))
- (bytevector-copy! bv
- (* start stride)
- (dynamic-buffer-data dbuffer)
- 0
- (* copy-count stride))
- (set-dynamic-buffer-count! dbuffer copy-count)))
-
-
-;;;
-;;; Buffer Views
+;;; Vertex Attributes
;;;
(define (type-size type)
@@ -379,27 +298,24 @@ resized."
('float 4)
('double 8)))
-(define-record-type <buffer-view>
- (%make-buffer-view name buffer offset offset-pointer component-type
- normalized? length type max min sparse divisor)
- buffer-view?
- (name buffer-view-name)
- (buffer buffer-view->buffer)
- (offset buffer-view-offset)
- (offset-pointer buffer-view-offset-pointer)
- (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-record-type <vertex-attribute>
+ (%make-vertex-attribute name buffer offset offset-pointer component-type
+ normalized? length type divisor)
+ vertex-attribute?
+ (name vertex-attribute-name)
+ (buffer vertex-attribute->buffer)
+ (offset vertex-attribute-offset)
+ (offset-pointer vertex-attribute-offset-pointer)
+ (component-type vertex-attribute-component-type)
+ (normalized? vertex-attribute-normalized?)
+ (length vertex-attribute-length)
+ (type vertex-attribute-type)
+ (divisor vertex-attribute-divisor)) ; for instanced rendering
+
+(define (vertex-attribute-stride vertex-attribute)
+ (or (buffer-stride (vertex-attribute->buffer vertex-attribute))
+ (* (type-size (vertex-attribute-type vertex-attribute))
+ (component-type-size (vertex-attribute-component-type vertex-attribute)))))
(define (num-elements byte-length byte-offset type component-type)
(inexact->exact
@@ -408,21 +324,18 @@ resized."
(* (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 0))
+(define* (make-vertex-attribute #:key
+ (name "anonymous")
+ buffer
+ type
+ component-type
+ normalized?
+ (offset 0)
+ (length (num-elements (buffer-length buffer)
+ offset
+ type
+ component-type))
+ (divisor 0))
"Return a new typed buffer view for BUFFER starting at byte index
OFFSET of LENGTH elements, where each element is of TYPE and composed
of COMPONENT-TYPE values.
@@ -455,29 +368,29 @@ and is used for the data being instanced. A divisor of 1 means that
each element is used for 1 instance. A divisor of 2 means that each
element is used for 2 instances, and so on."
(let ((offset-ptr (make-pointer offset)))
- (%make-buffer-view name buffer offset offset-ptr component-type
- normalized? length type max min sparse divisor)))
+ (%make-vertex-attribute name buffer offset offset-ptr component-type
+ normalized? length type divisor)))
-(define (display-buffer-view buffer-view port)
- (format port "#<buffer-view name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d divisor: ~d>"
- (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)
- (buffer-view-divisor buffer-view)))
+(define (display-vertex-attribute vertex-attribute port)
+ (format port "#<vertex-attribute name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d divisor: ~d>"
+ (vertex-attribute-name vertex-attribute)
+ (vertex-attribute->buffer vertex-attribute)
+ (vertex-attribute-type vertex-attribute)
+ (vertex-attribute-component-type vertex-attribute)
+ (vertex-attribute-length vertex-attribute)
+ (vertex-attribute-offset vertex-attribute)
+ (vertex-attribute-divisor vertex-attribute)))
-(set-record-type-printer! <buffer-view> display-buffer-view)
+(set-record-type-printer! <vertex-attribute> display-vertex-attribute)
-(define (buffer-view-type-size buffer-view)
- (type-size (buffer-view-type buffer-view)))
+(define (vertex-attribute-type-size vertex-attribute)
+ (type-size (vertex-attribute-type vertex-attribute)))
-(define (buffer-view-data buffer-view)
- (buffer-data (buffer-view->buffer buffer-view)))
+(define (vertex-attribute-data vertex-attribute)
+ (buffer-data (vertex-attribute->buffer vertex-attribute)))
-(define (buffer-view-type-gl buffer-view)
- (match (buffer-view-component-type buffer-view)
+(define (vertex-attribute-type-gl vertex-attribute)
+ (match (vertex-attribute-component-type vertex-attribute)
('byte (data-type byte))
('unsigned-byte (data-type unsigned-byte))
('short (data-type short))
@@ -487,19 +400,19 @@ element is used for 2 instances, and so on."
('float (data-type float))
('double (data-type double))))
-(define* (apply-buffer-view buffer-view #:optional attribute-index)
- (with-graphics-state! ((g:buffer (buffer-view->buffer buffer-view)))
+(define* (apply-vertex-attribute vertex-attribute #:optional attribute-index)
+ (with-graphics-state! ((g:buffer (vertex-attribute->buffer vertex-attribute)))
;; If there is no attribute-index, we assume this is being bound for
;; use as an index buffer.
(when attribute-index
(gl-enable-vertex-attrib-array attribute-index)
(gl-vertex-attrib-pointer attribute-index
- (buffer-view-type-size buffer-view)
- (buffer-view-type-gl buffer-view)
- (buffer-view-normalized? buffer-view)
- (buffer-view-stride buffer-view)
- (buffer-view-offset-pointer buffer-view))
- (let ((divisor (buffer-view-divisor buffer-view)))
+ (vertex-attribute-type-size vertex-attribute)
+ (vertex-attribute-type-gl vertex-attribute)
+ (vertex-attribute-normalized? vertex-attribute)
+ (vertex-attribute-stride vertex-attribute)
+ (vertex-attribute-offset-pointer vertex-attribute))
+ (let ((divisor (vertex-attribute-divisor vertex-attribute)))
(when divisor
(gl-vertex-attrib-divisor attribute-index divisor))))))
@@ -574,10 +487,10 @@ argument may be overridden. The following values are supported:
(graphics-engine-guard! array)
(with-graphics-state! ((g:vertex-array array))
(for-each (match-lambda
- ((index . buffer-view)
- (apply-buffer-view buffer-view index)))
+ ((index . vertex-attribute)
+ (apply-vertex-attribute vertex-attribute index)))
attributes)
- (when indices (apply-buffer-view indices)))
+ (when indices (apply-vertex-attribute indices)))
;; Restore the old array. Is this needed?
;; (graphics-engine-commit!)
array))
@@ -597,16 +510,16 @@ argument may be overridden. The following values are supported:
(let ((indices (vertex-array-indices array)))
(if indices
(begin
- (apply-buffer-view indices)
+ (apply-vertex-attribute indices)
(gl-draw-elements (vertex-array-mode-gl array)
(or count
- (buffer-view-length indices))
- (buffer-view-type-gl indices)
- (buffer-view-offset-pointer indices)))
+ (vertex-attribute-length indices))
+ (vertex-attribute-type-gl indices)
+ (vertex-attribute-offset-pointer indices)))
(gl-draw-arrays (vertex-array-mode-gl array)
offset
(or count
- (buffer-view-length
+ (vertex-attribute-length
(assv-ref (vertex-array-attributes array)
0))))))))
@@ -615,18 +528,96 @@ argument may be overridden. The following values are supported:
(let ((indices (vertex-array-indices array)))
(if indices
(begin
- (apply-buffer-view indices)
+ (apply-vertex-attribute indices)
(gl-draw-elements-instanced (vertex-array-mode-gl array)
(or count
- (buffer-view-length indices))
- (buffer-view-type-gl indices)
- (buffer-view-offset-pointer indices)
+ (vertex-attribute-length indices))
+ (vertex-attribute-type-gl indices)
+ (vertex-attribute-offset-pointer indices)
instances))
(gl-draw-arrays-instanced (vertex-array-mode-gl array)
offset count instances)))))
;;;
+;;; Dynamic Buffers
+;;;
+
+;; A layer on top of vertex buffers to handle buffer streaming with
+;; dynamic buffer expansion.
+(define-record-type <dynamic-buffer>
+ (%make-dynamic-buffer buffer capacity count)
+ dynamic-buffer?
+ (buffer dynamic-buffer->buffer)
+ (data dynamic-buffer-data set-dynamic-buffer-data!)
+ (capacity dynamic-buffer-capacity set-dynamic-buffer-capacity!)
+ (count dynamic-buffer-count set-dynamic-buffer-count!))
+
+(define* (make-dynamic-buffer #:key name capacity stride usage (target 'vertex))
+ (let* ((buffer (make-buffer #f
+ #:name name
+ #:length (* capacity stride)
+ #:stride stride
+ #:usage usage
+ #:target target)))
+ (%make-dynamic-buffer buffer capacity 0)))
+
+(define-inlinable (dynamic-buffer-bounds-check dbuffer i)
+ (unless (< i (dynamic-buffer-count dbuffer))
+ (error "index out of bounds" i)))
+
+(define (expand-dynamic-buffer dbuffer)
+ (let ((new-capacity (inexact->exact
+ (round (* (dynamic-buffer-capacity dbuffer) 1.5))))
+ (buffer (dynamic-buffer->buffer dbuffer)))
+ (resize-buffer! buffer (* new-capacity (buffer-stride buffer)))
+ (set-dynamic-buffer-capacity! dbuffer new-capacity)
+ (set-dynamic-buffer-data! dbuffer (buffer-data buffer))))
+
+(define-inlinable (dynamic-buffer-next! dbuffer n)
+ (let ((count (dynamic-buffer-count dbuffer)))
+ (let resize ()
+ (let ((capacity (dynamic-buffer-capacity dbuffer)))
+ (when (> (+ count n) capacity)
+ (expand-dynamic-buffer dbuffer)
+ (resize))))
+ (set-dynamic-buffer-count! dbuffer (+ count n))
+ count))
+
+(define (dynamic-buffer-clear! dbuffer)
+ (set-dynamic-buffer-count! dbuffer 0))
+
+(define (dynamic-buffer-map! dbuffer)
+ (let ((buffer (dynamic-buffer->buffer dbuffer)))
+ (dynamic-buffer-clear! dbuffer)
+ (map-buffer! buffer 'write-only)
+ ;; Stashing the bytevector here turns out to be a *huge* performance
+ ;; booster. Probably because it's avoiding another layer of record
+ ;; type checks and stuff? I dunno.
+ (set-dynamic-buffer-data! dbuffer (buffer-data buffer))))
+
+(define (dynamic-buffer-unmap! dbuffer)
+ (unmap-buffer! (dynamic-buffer->buffer dbuffer))
+ (set-dynamic-buffer-data! dbuffer #f))
+
+(define (dynamic-buffer-import! dbuffer bv start end)
+ (let ((stride (buffer-stride (dynamic-buffer->buffer dbuffer)))
+ (copy-count (- end start)))
+ (let resize ()
+ (let ((capacity (dynamic-buffer-capacity dbuffer)))
+ (when (< capacity copy-count)
+ (begin
+ (expand-dynamic-buffer dbuffer)
+ (resize)))))
+ (bytevector-copy! bv
+ (* start stride)
+ (dynamic-buffer-data dbuffer)
+ 0
+ (* copy-count stride))
+ (set-dynamic-buffer-count! dbuffer copy-count)))
+
+
+;;;
;;; Geometry Builder
;;;
@@ -663,8 +654,8 @@ argument may be overridden. The following values are supported:
(if (memq kw keep)
(cons* kw arg (loop rest))
(loop rest))))))
- (define (make-buffer-view* name type attr-type dbuffer offset args)
- (apply make-buffer-view
+ (define (make-vertex-attribute* name type attr-type dbuffer offset args)
+ (apply make-vertex-attribute
#:name (format #f "~s view" name)
#:buffer (dynamic-buffer->buffer dbuffer)
#:type (if (scalar-type? attr-type)
@@ -706,12 +697,12 @@ argument may be overridden. The following values are supported:
(loop rest location))
(((name attr-type offset) . rest)
(cons (cons location
- (make-buffer-view* name
- type
- attr-type
- (assq-ref buffers type)
- offset
- (filter-kwargs args '(#:divisor))))
+ (make-vertex-attribute* name
+ type
+ attr-type
+ (assq-ref buffers type)
+ offset
+ (filter-kwargs args '(#:divisor))))
(inner rest (+ location 1))))))))))
(let* ((index-buffer (and index?
(make-dynamic-buffer #:name "index"
@@ -720,11 +711,11 @@ argument may be overridden. The following values are supported:
#:stride 4
#:target 'index)))
(index-view (and index?
- (make-buffer-view #:name "index view"
- #:buffer (dynamic-buffer->buffer
- index-buffer)
- #:type 'scalar
- #:component-type 'unsigned-int)))
+ (make-vertex-attribute #:name "index view"
+ #:buffer (dynamic-buffer->buffer
+ index-buffer)
+ #:type 'scalar
+ #:component-type 'unsigned-int)))
(types (canonicalize-types))
(vertex-buffers (build-vertex-buffers types))
(vertex-views (build-views types vertex-buffers))
@@ -886,7 +877,7 @@ argument may be overridden. The following values are supported:
(case 'field
((field-name)
(field-getter (dynamic-buffer-data dbuffer
- (+ (* i type-stride) field-offset))))
+ (+ (* i type-stride) field-offset))))
...
(else (error "unknown field" 'field)))))
(define-syntax-rule (setter geometry field i x)
@@ -895,19 +886,19 @@ argument may be overridden. The following values are supported:
(case 'field
((field-name)
(field-setter (dynamic-buffer-data dbuffer)
- (+ (* i type-stride) field-offset)
- x))
+ (+ (* i type-stride) field-offset)
+ x))
...
(else (error "unknown field" 'field)))))
(define-syntax appender
(syntax-rules ::: ()
- ((_ geometry (field-name ...) :::)
- (let* ((dbuffer (geometry-vertex-buffer geometry type-name))
- (n (length '((field-name ...) :::)))
- (i (dynamic-buffer-next! dbuffer n))
- (bv (dynamic-buffer-data dbuffer)))
- (let ((offset (* i type-stride)))
- (field-setter bv (+ offset field-offset) field-name)
- ...
- (set! i (+ i 1)))
- :::)))))))))))
+ ((_ geometry (field-name ...) :::)
+ (let* ((dbuffer (geometry-vertex-buffer geometry type-name))
+ (n (length '((field-name ...) :::)))
+ (i (dynamic-buffer-next! dbuffer n))
+ (bv (dynamic-buffer-data dbuffer)))
+ (let ((offset (* i type-stride)))
+ (field-setter bv (+ offset field-offset) field-name)
+ ...
+ (set! i (+ i 1)))
+ :::)))))))))))
diff --git a/chickadee/graphics/color.scm b/chickadee/graphics/color.scm
index a43c7f0..fc7a1d6 100644
--- a/chickadee/graphics/color.scm
+++ b/chickadee/graphics/color.scm
@@ -142,12 +142,7 @@
(f32vector-ref (unwrap-color color) 3))
(define* (make-color r g b #:optional (a 1.0))
- (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))))
+ (wrap-color (f32vector r g b a)))
(define* (make-color8 r g b #:optional (a 255))
(make-color (/ r 255.0) (/ g 255.0) (/ b 255.0) (/ a 255.0)))
diff --git a/chickadee/graphics/engine.scm b/chickadee/graphics/engine.scm
index 75cd85f..a1d3352 100644
--- a/chickadee/graphics/engine.scm
+++ b/chickadee/graphics/engine.scm
@@ -281,7 +281,7 @@
(error "not a graphics state specification" spec)))
(define* (graphics-variable-ref var #:optional
- (engine (current-graphics-engine)))
+ (engine (current-graphics-engine)))
(hashq-ref (graphics-engine-variables engine) var))
(define* (graphics-variable-set! var value #:optional
diff --git a/chickadee/graphics/gl.scm b/chickadee/graphics/gl.scm
index 2ba0ec2..51ba82f 100644
--- a/chickadee/graphics/gl.scm
+++ b/chickadee/graphics/gl.scm
@@ -26,6 +26,7 @@
#:use-module (srfi srfi-4)
#:use-module ((system foreign) #:select (bytevector->pointer))
#:use-module (gl)
+ #:use-module (gl runtime)
#:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%))
#:use-module (gl enums)
#:use-module (gl runtime)
@@ -44,6 +45,14 @@
(%glTexImage2D . gl-texture-image-2d)
(%glTexImage1D . gl-texture-image-1d))
+;; For some reason, guile-opengl does not bind glGenerateMipmap, so we
+;; have to do it ourselves.
+(define-gl-procedure (glGenerateMipmap (target GLenum) -> void)
+ "Generate mipmaps for the texture attached to target of the active
+texture unit.")
+
+(export (glGenerateMipmap . gl-generate-mipmap))
+
;;;
;;; 3.8.2 Alternate Texture Image Specification Commands
;;;
@@ -295,6 +304,7 @@ object.")
(%glUniform3fv . gl-uniform3fv)
(%glUniform4f . gl-uniform4f)
(%glUniform4fv . gl-uniform4fv)
+ (%glUniformMatrix3fv . gl-uniform-matrix3fv)
(%glUniformMatrix4fv . gl-uniform-matrix4fv)
(%glUniform4f . gl-uniform4f))
diff --git a/chickadee/graphics/mesh.scm b/chickadee/graphics/mesh.scm
new file mode 100644
index 0000000..14cd82a
--- /dev/null
+++ b/chickadee/graphics/mesh.scm
@@ -0,0 +1,639 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; 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
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; 3D mesh rendering and generation.
+;;
+;;; Code:
+
+(define-module (chickadee graphics mesh)
+ #:use-module (chickadee math)
+ #:use-module (chickadee math matrix)
+ #:use-module (chickadee math vector)
+ #:use-module (chickadee graphics blend)
+ #:use-module (chickadee graphics buffer)
+ #:use-module (chickadee graphics color)
+ #:use-module (chickadee graphics depth)
+ #:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics multisample)
+ #:use-module (chickadee graphics light)
+ #:use-module (chickadee graphics polygon)
+ #:use-module (chickadee graphics shader)
+ #:use-module (chickadee graphics skybox)
+ #:use-module (chickadee graphics stencil)
+ #:use-module (chickadee graphics texture)
+ #:use-module (chickadee utils)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:export (make-material
+ material?
+ material-name
+ material-shader
+ material-blend-mode
+ material-polygon-mode
+ material-cull-face-mode
+ material-depth-test
+ material-stencil-test
+ material-multisample?
+ material-texture-0
+ material-texture-1
+ material-texture-2
+ material-texture-3
+ material-texture-4
+ material-properties
+
+ make-primitive
+ primitive?
+ primitive-name
+ primitive-vertex-array
+ primitive-material
+
+ make-mesh
+ mesh?
+ mesh-name
+ mesh-primitives
+ draw-mesh
+
+ build-mesh
+ make-plane
+ make-tesselated-plane
+ make-cube
+ make-sphere))
+
+
+;;;
+;;; Materials
+;;;
+
+(define-record-type <material>
+ (%make-material name shader blend-mode polygon-mode cull-face-mode
+ depth-test stencil-test multisample?
+ texture-0 texture-1 texture-2 texture-3 texture-4
+ properties)
+ material?
+ (name material-name)
+ (shader material-shader)
+ (blend-mode material-blend-mode)
+ (polygon-mode material-polygon-mode)
+ (cull-face-mode material-cull-face-mode)
+ (depth-test material-depth-test)
+ (stencil-test material-stencil-test)
+ (multisample? material-multisample?)
+ (texture-0 material-texture-0)
+ (texture-1 material-texture-1)
+ (texture-2 material-texture-2)
+ (texture-3 material-texture-3)
+ (texture-4 material-texture-4)
+ (properties material-properties))
+
+(define* (make-material #:key
+ (name "anonymous")
+ (shader null-shader)
+ (blend-mode blend:replace)
+ (polygon-mode fill-polygon-mode)
+ (cull-face-mode back-cull-face-mode)
+ (depth-test (make-depth-test))
+ (stencil-test default-stencil-test)
+ multisample?
+ (texture-0 null-texture)
+ (texture-1 null-texture)
+ (texture-2 null-texture)
+ (texture-3 null-texture)
+ (texture-4 null-texture)
+ properties)
+ (%make-material name shader blend-mode polygon-mode cull-face-mode
+ depth-test stencil-test multisample? texture-0
+ texture-1 texture-2 texture-3 texture-4 properties))
+
+(define %camera-position (vec3 0.0 0.0 0.0))
+
+(define (material-apply material vertex-array model-matrix view-matrix
+ camera-position skybox light-vector)
+ (with-graphics-state ((g:blend-mode (material-blend-mode material))
+ (g:cull-face-mode (material-cull-face-mode material))
+ (g:depth-test (material-depth-test material))
+ (g:multisample? (material-multisample? material))
+ (g:polygon-mode (material-polygon-mode material))
+ (g:stencil-test (material-stencil-test material))
+ (g:texture-0 (if skybox
+ (skybox-cube-map skybox)
+ null-texture))
+ (g:texture-1 (material-texture-0 material))
+ (g:texture-2 (material-texture-1 material))
+ (g:texture-3 (material-texture-2 material))
+ (g:texture-4 (material-texture-3 material))
+ (g:texture-5 (material-texture-4 material)))
+ (shader-apply (material-shader material) vertex-array
+ #:model model-matrix
+ #:view view-matrix
+ #:projection (current-projection)
+ #:camera-position camera-position
+ #:lights light-vector
+ #:material (material-properties material))))
+
+
+;;;
+;;; Primitives
+;;;
+
+;; A primitive represents a single draw call: Some material applied to
+;; some vertex data.
+(define-record-type <primitive>
+ (make-primitive name vertex-array material)
+ primitive?
+ (name primitive-name)
+ (vertex-array primitive-vertex-array)
+ (material primitive-material))
+
+(define (draw-primitive primitive model-matrix view-matrix camera-position
+ skybox light-vector)
+ (material-apply (primitive-material primitive)
+ (primitive-vertex-array primitive)
+ model-matrix
+ view-matrix
+ camera-position
+ skybox
+ light-vector))
+
+
+;;;
+;;; Meshes
+;;;
+
+;; A mesh is just a glorified list of primitives.
+(define-record-type <mesh>
+ (%make-mesh name primitives light-vector)
+ mesh?
+ (name mesh-name)
+ (primitives mesh-primitives)
+ (light-vector mesh-light-vector))
+
+(define (make-mesh name primitives)
+ (%make-mesh name primitives (make-vector %max-lights %disabled-light)))
+
+(define %identity-matrix (make-identity-matrix4))
+(define %origin (vec3 0.0 0.0 0.0))
+
+(define* (draw-mesh mesh #:key (model-matrix %identity-matrix)
+ (view-matrix %identity-matrix)
+ (camera-position %origin)
+ skybox
+ (lights '()))
+ ;; Populate light vector to pass on to shader.
+ (let ((light-vector (mesh-light-vector mesh)))
+ (let loop ((i 0)
+ (lights lights))
+ (when (< i %max-lights)
+ (match lights
+ (()
+ (vector-set! light-vector i %disabled-light)
+ (loop (+ i 1) '()))
+ ((light . rest)
+ (vector-set! light-vector i light)
+ (loop (+ i 1) rest)))))
+ (for-each (lambda (primitive)
+ (draw-primitive primitive model-matrix view-matrix camera-position
+ skybox light-vector))
+ (mesh-primitives mesh))))
+
+
+;;;
+;;; Programattically generated meshes
+;;;
+
+(define-record-type <vertex>
+ (vertex position uv normal)
+ vertex?
+ (position vertex-position)
+ (uv vertex-uv)
+ (normal vertex-normal))
+
+(define (build-mesh name vertices material)
+ (let* ((index (make-hash-table))
+ ;; Build index and count unique verts.
+ (count
+ (fold (lambda (vertex count)
+ (if (hashq-ref index vertex)
+ count
+ (begin
+ (hashq-set! index vertex count)
+ (+ count 1))))
+ 0
+ vertices))
+ ;; 8 floats per vertex.
+ (stride (* 8 4))
+ (verts (make-bytevector (* count stride)))
+ (indices (make-u32vector (length vertices))))
+ ;; Pack verts.
+ (hash-for-each (lambda (vertex i)
+ (let ((p (vertex-position vertex))
+ (uv (vertex-uv vertex))
+ (n (vertex-normal vertex))
+ (offset (* i stride)))
+ (bytevector-ieee-single-native-set! verts offset
+ (vec3-x p))
+ (bytevector-ieee-single-native-set! verts (+ offset 4)
+ (vec3-y p))
+ (bytevector-ieee-single-native-set! verts (+ offset 8)
+ (vec3-z p))
+ (bytevector-ieee-single-native-set! verts (+ offset 12)
+ (vec2-x uv))
+ (bytevector-ieee-single-native-set! verts (+ offset 16)
+ (vec2-y uv))
+ (bytevector-ieee-single-native-set! verts (+ offset 20)
+ (vec3-x n))
+ (bytevector-ieee-single-native-set! verts (+ offset 24)
+ (vec3-y n))
+ (bytevector-ieee-single-native-set! verts (+ offset 28)
+ (vec3-z n))))
+ index)
+ ;; Pack indices.
+ (let loop ((i 0)
+ (vertices vertices))
+ (match vertices
+ (() #t)
+ ((vertex . rest)
+ (u32vector-set! indices i (hashq-ref index vertex))
+ (loop (+ i 1) rest))))
+ (let* ((vertex-buffer (make-buffer verts #:stride stride))
+ (index-buffer (make-buffer indices #:target 'index))
+ (positions (make-vertex-attribute #:buffer vertex-buffer
+ #:type 'vec3
+ #:component-type 'float))
+ (uvs (make-vertex-attribute #:buffer vertex-buffer
+ #:offset 12
+ #:type 'vec2
+ #:component-type 'float))
+ (normals (make-vertex-attribute #:buffer vertex-buffer
+ #:offset 20
+ #:type 'vec3
+ #:component-type 'float))
+ (vertex-array
+ (make-vertex-array #:indices
+ (make-vertex-attribute #:buffer index-buffer
+ #:type 'scalar
+ #:component-type 'unsigned-int)
+ #:attributes `((0 . ,positions)
+ (1 . ,uvs)
+ (2 . ,normals)))))
+ (make-mesh name (list (make-primitive name vertex-array material))))))
+
+(define (make-plane length width material)
+ (let* ((hl (/ length 2.0))
+ (hw (/ width 2.0))
+ (bottom-left (vertex (vec3 (- hw) 0.0 (- hl))
+ (vec2 0.0 0.0)
+ (vec3 0.0 1.0 0.0)))
+ (bottom-right (vertex (vec3 hw 0.0 (- hl))
+ (vec2 1.0 0.0)
+ (vec3 0.0 1.0 0.0)))
+ (top-right (vertex (vec3 hw 0.0 hl)
+ (vec2 1.0 1.0)
+ (vec3 0.0 1.0 0.0)))
+ (top-left (vertex (vec3 (- hw) 0.0 hl)
+ (vec2 0.0 1.0)
+ (vec3 0.0 1.0 0.0))))
+ (build-mesh "plane"
+ (list bottom-left
+ top-left
+ top-right
+ bottom-left
+ top-right
+ bottom-right)
+ material)))
+
+(define (make-tesselated-plane length width resolution material)
+ (let ((hl (/ length 2.0))
+ (hw (/ width 2.0))
+ (stepl (/ length resolution))
+ (stepw (/ width resolution))
+ (uvstep (/ 1.0 resolution))
+ (cache (make-vector (* resolution resolution) #f)))
+ (define (get-vertex x z)
+ (or (vector-ref cache (+ (* resolution z) x))
+ (let ((v (vertex (vec3 (- (* x stepw) hw) 0.0 (- (* z stepl) hl))
+ (vec2 (* x uvstep) (* z uvstep))
+ (vec3 0.0 1.0 0.0))))
+ (vector-set! cache (+ (* resolution z) x) v)
+ v)))
+ (build-mesh "tesselated plane"
+ (let loop ((x 0)
+ (z 0))
+ (cond
+ ((= z (- resolution 1))
+ '())
+ ((= x (- resolution 1))
+ (loop 0 (+ z 1)))
+ (else
+ (cons* (get-vertex x z)
+ (get-vertex x (+ z 1))
+ (get-vertex (+ x 1) (+ z 1))
+ (get-vertex x z)
+ (get-vertex (+ x 1) (+ z 1))
+ (get-vertex (+ x 1) z)
+ (loop (+ x 1) z)))))
+ material)))
+
+(define (make-cube size material)
+ (let* ((hs (/ size 2.0))
+ (bottom0 (vertex (vec3 (- hs) (- hs) (- hs))
+ (vec2 0.0 0.0)
+ (vec3 0.0 -1.0 0.0)))
+ (bottom1 (vertex (vec3 hs (- hs) (- hs))
+ (vec2 1.0 0.0)
+ (vec3 0.0 -1.0 0.0)))
+ (bottom2 (vertex (vec3 hs (- hs) hs)
+ (vec2 1.0 1.0)
+ (vec3 0.0 -1.0 0.0)))
+ (bottom3 (vertex (vec3 (- hs) (- hs) hs)
+ (vec2 0.0 1.0)
+ (vec3 0.0 -1.0 0.0)))
+ (top0 (vertex (vec3 (- hs) hs (- hs))
+ (vec2 0.0 0.0)
+ (vec3 0.0 1.0 0.0)))
+ (top1 (vertex (vec3 hs hs (- hs))
+ (vec2 1.0 0.0)
+ (vec3 0.0 1.0 0.0)))
+ (top2 (vertex (vec3 hs hs hs)
+ (vec2 1.0 1.0)
+ (vec3 0.0 1.0 0.0)))
+ (top3 (vertex (vec3 (- hs) hs hs)
+ (vec2 0.0 1.0)
+ (vec3 0.0 1.0 0.0)))
+ (left0 (vertex (vec3 (- hs) (- hs) (- hs))
+ (vec2 0.0 0.0)
+ (vec3 -1.0 0.0 0.0)))
+ (left1 (vertex (vec3 (- hs) hs (- hs))
+ (vec2 1.0 0.0)
+ (vec3 -1.0 0.0 0.0)))
+ (left2 (vertex (vec3 (- hs) hs hs)
+ (vec2 1.0 1.0)
+ (vec3 -1.0 0.0 0.0)))
+ (left3 (vertex (vec3 (- hs) (- hs) hs)
+ (vec2 0.0 1.0)
+ (vec3 -1.0 0.0 0.0)))
+ (right0 (vertex (vec3 hs (- hs) (- hs))
+ (vec2 0.0 0.0)
+ (vec3 1.0 0.0 0.0)))
+ (right1 (vertex (vec3 hs hs (- hs))
+ (vec2 1.0 0.0)
+ (vec3 1.0 0.0 0.0)))
+ (right2 (vertex (vec3 hs hs hs)
+ (vec2 1.0 1.0)
+ (vec3 1.0 0.0 0.0)))
+ (right3 (vertex (vec3 hs (- hs) hs)
+ (vec2 0.0 1.0)
+ (vec3 1.0 0.0 0.0)))
+ (front0 (vertex (vec3 (- hs) (- hs) hs)
+ (vec2 0.0 0.0)
+ (vec3 0.0 0.0 1.0)))
+ (front1 (vertex (vec3 hs (- hs) hs)
+ (vec2 1.0 0.0)
+ (vec3 0.0 0.0 1.0)))
+ (front2 (vertex (vec3 hs hs hs)
+ (vec2 1.0 1.0)
+ (vec3 0.0 0.0 1.0)))
+ (front3 (vertex (vec3 (- hs) hs hs)
+ (vec2 0.0 1.0)
+ (vec3 0.0 0.0 1.0)))
+ (back0 (vertex (vec3 (- hs) (- hs) (- hs))
+ (vec2 0.0 0.0)
+ (vec3 0.0 0.0 -1.0)))
+ (back1 (vertex (vec3 hs (- hs) (- hs))
+ (vec2 1.0 0.0)
+ (vec3 0.0 0.0 -1.0)))
+ (back2 (vertex (vec3 hs hs (- hs))
+ (vec2 1.0 1.0)
+ (vec3 0.0 0.0 -1.0)))
+ (back3 (vertex (vec3 (- hs) hs (- hs))
+ (vec2 0.0 1.0)
+ (vec3 0.0 0.0 -1.0))))
+ (build-mesh "cube"
+ (list bottom0 bottom3 bottom2 bottom0 bottom2 bottom1
+ top0 top3 top2 top0 top2 top1
+ left0 left3 left2 left0 left2 left1
+ right0 right3 right2 right0 right2 right1
+ front0 front3 front2 front0 front2 front1
+ back0 back3 back2 back0 back2 back1)
+ material)))
+
+(define* (make-sphere radius material #:key (quality 2))
+ (define phi 1.618033988749895) ; the golden ratio
+ ;; Compute the vector halfway between A and B.
+ (define (halfway a b)
+ (vec3+ a (vec3* (vec3- b a) 0.5)))
+ ;; "Normalization" in this context refers to transforming each
+ ;; vertex such that it is a constant distance (as determined by the
+ ;; radius argument) away from the origin.
+ ;;
+ ;; The result is memoized so that vertex data is shared as much as
+ ;; possible in the final mesh. For example, a sphere of quality 3
+ ;; requires 3840 vertices, but only 642 of them are unique.
+ ;; Memoization reduces the mesh vertex buffer size by ~82%.
+ (define normalize
+ (memoize
+ (lambda (p)
+ (let ((n (vec3-normalize p)))
+ (vertex (vec3* n radius)
+ (vec2 (+ (/ (atan (vec3-x n) (vec3-z n)) tau) 0.5)
+ (+ (/ (asin (vec3-y n)) pi) 0.5))
+ n)))))
+ ;; When mapping UV's to the sphere's vertices, there is some
+ ;; distortion that occurs at the 6 triangles that form a pole. The
+ ;; polar vertex has a U coordinate of 0.5, but the U coordinates of
+ ;; the other vertices that form the triangles are the percentage of
+ ;; how far they have traversed a unit circle. Something like this:
+ ;;
+ ;; 0.588 0.412
+ ;; *-----*
+ ;; / \ C / \
+ ;; / D \ / B \
+ ;; 0.75 *----*-0.5-* 0.25
+ ;; \ E / \ A /
+ ;; \ / F \ /
+ ;; *-----*
+ ;; 0.911 0.089
+ ;;
+ ;; There are 2 problems:
+ ;;
+ ;; 1) With the exception of triangle C, 0.5 is not the halfway point
+ ;; between the other 2 U values, which results in a very obvious
+ ;; visual artifact where the texture looks very compressed in the
+ ;; triangle.
+ ;;
+ ;; 2) Triangle F, in addition to suffering from issue 1, also has
+ ;; the issue that it spans the seam where there's a hard jump from
+ ;; U=1 to U=0, causing another compressed visual artifact.
+ ;;
+ ;; The solution is to duplicate the polar vertex for all triangles
+ ;; and supply unique UV coordinates for each one such that the U
+ ;; value lies halfway between the other 2 U values. Additionally,
+ ;; triangle F needs the vertex with the lowest U value (0.089 in the
+ ;; example) adjusted to extend past 1 (1.089 would be the fixed
+ ;; value in the example.)
+ ;;
+ ;; This UV map adjustment is not without it's own issues, but the
+ ;; result looks far more acceptable.
+ (define (find-minu v)
+ (let ((u (vec2-x (vertex-uv v))))
+ ;; We don't want the center point to ever be considered the min.
+ (if (= u 0.5) 1.0 u)))
+ (define (find-maxu v)
+ (let ((u (vec2-x (vertex-uv v))))
+ ;; We don't want the center point to ever be considered the max.
+ (if (= u 0.5) 0.0 u)))
+ (define (fix-pole a b c)
+ (let* ((minu (min (find-minu a) (find-minu b) (find-minu c)))
+ (maxu (max (find-maxu a) (find-maxu b) (find-maxu c)))
+ (seam? (and (< minu 0.25) (> maxu 0.75))))
+ (define (fix v)
+ (let ((uv (vertex-uv v)))
+ (cond
+ ((and seam? (= (vec2-x uv) 0.5))
+ (vertex (vertex-position v)
+ (vec2 (+ maxu minu)
+ (vec2-y uv))
+ (vertex-normal v)))
+ ((= (vec2-x uv) 0.5)
+ (vertex (vertex-position v)
+ (vec2 (+ minu (/ (- maxu minu) 2.0)) (vec2-y uv))
+ (vertex-normal v)))
+ ((and seam? (= minu (vec2-x uv)))
+ (vertex (vertex-position v)
+ (vec2 (+ maxu (* minu 2.0)) (vec2-y uv))
+ (vertex-normal v)))
+ (else v))))
+ (list (fix a) (fix b) (fix c))))
+ ;; Triangles at the poles have a vertex with a V value of either 0
+ ;; or 1.
+ (define (on-pole? a b c)
+ (let ((av (vec2-y (vertex-uv a)))
+ (bv (vec2-y (vertex-uv b)))
+ (cv (vec2-y (vertex-uv c))))
+ (or (= av 0.0) (= av 1.0) (= bv 0.0) (= bv 1.0) (= cv 0.0) (= cv 1.0))))
+ ;; When mapping UVs to the sphere's vertices, there's a smooth
+ ;; wrapping of U values from 0 to 1 around the sphere, but when it
+ ;; reaches the beginning again there is a hard jump from 1 back to
+ ;; 0. This creates a glaringly obvious, distorted seam when a
+ ;; texture is applied. To fix it, we must identify triangles that
+ ;; are in the back hemisphere (-Z values) with at least one vertex
+ ;; whose U coordinate is 1. These are the faces that span the seam.
+ ;; The UVs of each vertex are then adjusted as necessary to reduce
+ ;; the range of U values to the desired amount.
+ (define (on-seam? a b c)
+ (and (or (negative? (vec3-z (vertex-position a)))
+ (negative? (vec3-z (vertex-position b)))
+ (negative? (vec3-z (vertex-position c))))
+ (or (= (vec2-x (vertex-uv a)) 1.0)
+ (= (vec2-x (vertex-uv b)) 1.0)
+ (= (vec2-x (vertex-uv c)) 1.0))))
+ (define fix-seam-maybe
+ (memoize
+ (lambda (v)
+ (let* ((uv (vertex-uv v))
+ (du (- 1.0 (vec2-x uv))))
+ (if (< du 0.5)
+ (vertex (vertex-position v)
+ (vec2 (- du) (vec2-y uv))
+ (vertex-normal v))
+ v)))))
+ (define (fix-uvs a b c)
+ (cond
+ ((on-seam? a b c)
+ (list (fix-seam-maybe a)
+ (fix-seam-maybe b)
+ (fix-seam-maybe c)))
+ ((on-pole? a b c)
+ (fix-pole a b c))
+ (else
+ (list a b c))))
+ ;; Recursively subdivide a triangle into 4 sub-triangles n times.
+ (define (subdivide tri n)
+ (match tri
+ ((a b c)
+ (if (= n 0)
+ (fix-uvs (normalize a) (normalize b) (normalize c))
+ ;; Subdivide one triangle into 4, like so:
+ ;;
+ ;; B
+ ;; *
+ ;; / \
+ ;; / \
+ ;; E *_____* F
+ ;; / \ / \
+ ;; / \ / \
+ ;; *_____*_____*
+ ;; A G C
+ (let ((e (halfway a b))
+ (f (halfway b c))
+ (g (halfway c a)))
+ (append (subdivide (list a g e) (- n 1))
+ (subdivide (list e f b) (- n 1))
+ (subdivide (list g c f) (- n 1))
+ (subdivide (list e g f) (- n 1))))))))
+ ;; Icosahedrons (picture a 20-sided die) have 12 vertices. The
+ ;; position of these vertices can be defined using 3 mutually
+ ;; centered, mutually orthogonal golden rectangles. See
+ ;; https://math.wikia.org/wiki/Icosahedron#Cartesian_coordinates for
+ ;; a visualization of this.
+ ;;
+ ;; Rectangle on the YZ plane
+ (let ((yz0 (vec3 0.0 -1.0 (- phi)))
+ (yz1 (vec3 0.0 1.0 (- phi)))
+ (yz2 (vec3 0.0 1.0 phi))
+ (yz3 (vec3 0.0 -1.0 phi))
+ ;; Rectangle on the XY plane
+ (xy0 (vec3 -1.0 (- phi) 0.0))
+ (xy1 (vec3 1.0 (- phi) 0.0))
+ (xy2 (vec3 1.0 phi 0.0))
+ (xy3 (vec3 -1.0 phi 0.0))
+ ;; Rectangle on the XZ plane
+ (xz0 (vec3 (- phi) 0.0 -1.0))
+ (xz1 (vec3 phi 0.0 -1.0))
+ (xz2 (vec3 phi 0.0 1.0))
+ (xz3 (vec3 (- phi) 0.0 1.0)))
+ (build-mesh "sphere"
+ (append-map (lambda (tri)
+ (subdivide tri quality))
+ ;; 20 triangles form the base icosahedron,
+ ;; which will be subdivided to form a
+ ;; higher resolution mesh that closely
+ ;; approximates a sphere.
+ (list (list xy3 xy2 yz1)
+ (list yz2 xy3 xy2)
+ (list yz2 xy3 xz3)
+ (list xy3 xz3 xz0)
+ (list xz0 xy3 yz1) ; 5
+ (list xy2 yz1 xz1)
+ (list yz0 yz1 xz1)
+ (list yz0 yz1 xz0)
+ (list yz0 xz0 xy0)
+ (list xy0 xz0 xz3) ; 10
+ (list xz3 xy0 yz3)
+ (list yz3 yz2 xz3)
+ (list yz3 yz2 xz2)
+ (list yz2 xz2 xy2)
+ (list xz2 xz1 xy2) ; 15
+ (list xz2 xz1 xy1)
+ (list xz1 xy1 yz0)
+ (list xy0 xy1 yz0)
+ (list xy0 xy1 yz3)
+ (list xy1 yz3 xz2)))
+ material)))
diff --git a/chickadee/graphics/model.scm b/chickadee/graphics/model.scm
index 8636652..5e0857e 100644
--- a/chickadee/graphics/model.scm
+++ b/chickadee/graphics/model.scm
@@ -29,13 +29,16 @@
#:use-module (chickadee math quaternion)
#:use-module (chickadee math vector)
#:use-module (chickadee graphics buffer)
+ #:use-module (chickadee graphics blend)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics depth)
#:use-module (chickadee graphics engine)
#:use-module (chickadee graphics light)
+ #:use-module (chickadee graphics mesh)
#:use-module (chickadee graphics multisample)
#:use-module (chickadee graphics pbr)
#:use-module (chickadee graphics phong)
+ #:use-module (chickadee graphics polygon)
#:use-module (chickadee graphics shader)
#:use-module (chickadee graphics texture)
#:use-module (chickadee utils)
@@ -67,37 +70,18 @@
;;;
(define-record-type <render-state>
- (%make-render-state renderer view-matrix model-matrix world-model-matrix
- camera-position lights ambient-light-color)
+ (%make-render-state model-matrix world-model-matrix)
render-state?
- (renderer render-state-renderer)
- (view-matrix render-state-view-matrix)
(model-matrix render-state-model-matrix)
- (world-model-matrix render-state-world-model-matrix)
- (camera-position render-state-camera-position)
- (lights render-state-lights)
- (ambient-light-color render-state-ambient-light-color
- set-render-state-ambient-light-color!))
+ (world-model-matrix render-state-world-model-matrix))
-(define %default-ambient-light-color (make-color 0.03 0.03 0.03 1.0))
-
-(define (make-render-state renderer)
- (%make-render-state renderer
- (make-identity-matrix4)
- (make-identity-matrix4)
- (make-identity-matrix4)
- (vec3 0.0 0.0 0.0)
- (make-vector %max-lights %disabled-light)
- %default-ambient-light-color))
+(define (make-render-state)
+ (%make-render-state (make-identity-matrix4)
+ (make-identity-matrix4)))
(define (render-state-reset! state)
- (matrix4-identity! (render-state-view-matrix state))
(matrix4-identity! (render-state-model-matrix state)))
-(define (render-state-view-matrix-mult! state matrix)
- (let ((view (render-state-view-matrix state)))
- (matrix4-mult! view view matrix)))
-
(define (render-state-model-matrix-mult! state matrix)
(let ((model (render-state-model-matrix state)))
(matrix4-mult! model model matrix)))
@@ -107,70 +91,6 @@
matrix
(render-state-model-matrix state)))
-(define (set-render-state-camera-position! state position)
- (vec3-copy! position (render-state-camera-position state)))
-
-(define (set-render-state-lights! state lights)
- (let ((lv (render-state-lights state)))
- (let loop ((i 0)
- (lights lights))
- (when (< i %max-lights)
- (match lights
- (()
- (vector-set! lv i %disabled-light)
- (loop (+ i 1) '()))
- ((light . rest)
- (vector-set! lv i light)
- (loop (+ i 1) rest)))))))
-
-
-;;;
-;;; Primitive
-;;;
-
-;; A piece of a mesh. Represents a single draw call.
-(define-record-type <primitive>
- (make-primitive name vertex-array material)
- primitive?
- (name primitive-name)
- (vertex-array primitive-vertex-array)
- (material primitive-material))
-
-(define (draw-primitive/phong primitive state)
- (shader-apply/phong (primitive-vertex-array primitive)
- (primitive-material primitive)
- (render-state-world-model-matrix state)
- (render-state-view-matrix state)
- (render-state-camera-position state)
- (render-state-lights state)
- (render-state-ambient-light-color state)))
-
-(define (draw-primitive/pbr primitive state)
- (shader-apply/pbr (primitive-vertex-array primitive)
- (primitive-material primitive)
- (render-state-world-model-matrix state)
- (render-state-view-matrix state)
- (render-state-camera-position state)
- (render-state-lights state)
- (render-state-ambient-light-color state)))
-
-
-;;;
-;;; Mesh
-;;;
-
-;; A complete 3D model composed of many primitives.
-(define-record-type <mesh>
- (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))))
-
;;;
;;; Model Node
@@ -194,15 +114,21 @@
(children '()))
(%make-model-node name mesh matrix world-matrix children))
-(define (draw-model-node node state)
+(define (draw-model-node node state view-matrix camera-position skybox lights)
(for-each (lambda (child)
- (draw-model-node child state))
+ (draw-model-node child state view-matrix camera-position
+ skybox lights))
(model-node-children node))
(let ((mesh (model-node-mesh node)))
(when mesh
(render-state-world-model-matrix-mult! state
(model-node-world-matrix node))
- (draw-mesh mesh state))))
+ (draw-mesh mesh
+ #:model-matrix (render-state-world-model-matrix state)
+ #:view-matrix view-matrix
+ #:camera-position camera-position
+ #:skybox skybox
+ #:lights lights))))
;;;
@@ -225,19 +151,16 @@
(define %depth-test (make-depth-test))
(define* (draw-model model model-matrix view-matrix camera-position #:key
- (lights '())
- (ambient-light-color %default-ambient-light-color))
+ skybox
+ (lights '()))
(with-graphics-state ((g:depth-test %depth-test)
(g:multisample? #t))
(let ((state (model-render-state model)))
(render-state-reset! state)
- (render-state-view-matrix-mult! state view-matrix)
(render-state-model-matrix-mult! state model-matrix)
- (set-render-state-camera-position! state camera-position)
- (set-render-state-lights! state lights)
- (set-render-state-ambient-light-color! state ambient-light-color)
;; TODO: Support drawing non-default scenes.
- (draw-model-node (model-default-scene model) state))))
+ (draw-model-node (model-default-scene model) state view-matrix
+ camera-position skybox lights))))
;;;
@@ -283,26 +206,24 @@
(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?))))))
+ (let* ((ambient (or (assq-ref opts 'ambient-map) (white-texture)))
+ (diffuse (or (assq-ref opts 'diffuse-map) (white-texture)))
+ (specular (or (assq-ref opts 'specular-map) (white-texture)))
+ (normals (or (assq-ref opts 'normal-map) (flat-texture)))
+ (properties (make-phong-properties
+ #:ambient (assq-ref opts 'ambient)
+ #:diffuse (assq-ref opts 'diffuse)
+ #:specular (assq-ref opts 'specular)
+ #:shininess (assq-ref opts 'shininess)))
+ (material
+ (make-material #:name name
+ #:shader (phong-shader)
+ #:texture-0 ambient
+ #:texture-1 diffuse
+ #:texture-2 specular
+ #:texture-3 normals
+ #:properties properties)))
+ (hash-set! material-map name material)))))
(match (read-line port)
((? eof-object?)
(maybe-add-material))
@@ -358,9 +279,8 @@
#:min-filter 'linear
#:mag-filter 'linear
#:flip? #f)))
- (loop (cons* (cons 'ambient-map texture)
- (cons 'use-ambient-map? #t)
- opts))))
+ (loop (cons (cons 'ambient-map texture)
+ opts))))
(("map_Kd" . args) ; diffuse map
(let* ((diffuse-opts (parse-map-args args))
(file (scope-file (assq-ref diffuse-opts
@@ -369,9 +289,8 @@
#:min-filter 'linear
#:mag-filter 'linear
#:flip? #f)))
- (loop (cons* (cons 'diffuse-map texture)
- (cons 'use-diffuse-map? #t)
- opts))))
+ (loop (cons (cons 'diffuse-map texture)
+ opts))))
(("map_Ks" . args) ; specular map
(let* ((specular-opts (parse-map-args args))
(file (scope-file (assq-ref specular-opts
@@ -380,36 +299,30 @@
#:min-filter 'linear
#:mag-filter 'linear
#:flip? #f)))
- (loop (cons* (cons 'specular-map texture)
- (cons 'use-specular-map? #t)
- opts))))
+ (loop (cons (cons 'specular-map texture)
+ opts))))
(((or "map_Bump" "map_bump" "bump") . args) ; normal map
- (let* ((bump-opts (parse-map-args args))
- (file (scope-file (assq-ref bump-opts
+ (let* ((normal-opts (parse-map-args args))
+ (file (scope-file (assq-ref normal-opts
'file-name)))
(texture (load-image file
#:min-filter 'linear
#:mag-filter 'linear
#:flip? #f)))
- (loop (cons* (cons 'bump-map texture)
- (cons 'use-bump-map? #t)
- opts))))
+ (loop (cons (cons 'normal-map texture)
+ opts))))
(("newmtl" new-name)
;; Begin new material
(maybe-add-material)
(loop `((name . ,new-name)
(ambient . ,(vec3 1.0 1.0 1.0))
(ambient-map . ,null-texture)
- (use-ambient-map? . #f)
(diffuse . ,(vec3 1.0 1.0 1.0))
(diffuse-map . ,null-texture)
- (use-diffuse-map? . #f)
(specular . ,(vec3 1.0 1.0 1.0))
(specular-map . ,null-texture)
- (use-specular-map? . #f)
(shininess . 1.0)
- (bump-map . ,null-texture)
- (use-bump-map? . #f))))
+ (normal-map . ,null-texture))))
(data
(format (current-error-port)
"warning: ~a:~d: unsupported MTL data: ~s~%"
@@ -419,9 +332,9 @@
(loop opts)))))))))
(define (parse-error message args)
(apply error (format #f "OBJ parser error @ ~a:~d: ~a"
- file-name
- (port-line port)
- message)
+ file-name
+ (port-line port)
+ message)
args))
(define (parse-vertex args)
(array-list-push! vertices
@@ -602,21 +515,21 @@
;; 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))
+ (index-view (make-vertex-attribute #: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)))
+ (vertex-view (make-vertex-attribute #:type 'vec3
+ #:component-type 'float
+ #:buffer data-buffer))
+ (texcoord-view (make-vertex-attribute #:type 'vec2
+ #:component-type 'float
+ #:buffer data-buffer
+ #:offset 12))
+ (normal-view (make-vertex-attribute #:type 'vec3
+ #:component-type 'float
+ #:buffer data-buffer
+ #:offset 20)))
(make-primitive material
(make-vertex-array
#:indices index-view
@@ -626,7 +539,14 @@
(or (hash-ref material-map material)
(hash-ref material-map "default"))))))
;; Register default material
- (hash-set! material-map "default" default-phong-material)
+ (hash-set! material-map "default"
+ (make-material #:name "default"
+ #:shader (phong-shader)
+ #:texture-0 (white-texture)
+ #:texture-1 (white-texture)
+ #:texture-2 (white-texture)
+ #:texture-3 (flat-texture)
+ #:properties default-phong-properties))
;; Parse file.
(let loop ((material "default"))
(match (read-line port)
@@ -684,8 +604,7 @@
#:mesh mesh)))
(make-model #:name model-name
#:scenes (list scene)
- #:render-state
- (make-render-state draw-primitive/phong)))))))
+ #:render-state (make-render-state)))))))
;;;
@@ -806,7 +725,7 @@
(else
(make-bytevector length)))))
data))
- (define (parse-buffer-view obj i buffers index-ids)
+ (define (parse-vertex-attribute obj i buffers index-ids)
(let ((name (string-ref/optional obj "name"))
(data (vector-ref buffers (number-ref obj "buffer")))
(offset (or (number-ref/optional obj "byteOffset") 0))
@@ -826,7 +745,7 @@
#:length length
#:stride stride
#:target target)))
- (define (parse-accessor obj buffer-views)
+ (define (parse-accessor obj vertex-attributes)
(define (type-length type)
(match type
('scalar 1)
@@ -839,7 +758,7 @@
(let ((name (or (string-ref/optional obj "name") "anonymous"))
(view (match (number-ref/optional obj "bufferView")
(#f #f)
- (n (vector-ref buffer-views n))))
+ (n (vector-ref vertex-attributes n))))
(offset (or (number-ref/optional obj "byteOffset") 0))
(component-type (match (number-ref obj "componentType")
(5120 'byte)
@@ -875,25 +794,21 @@
(display "glTF: sparse accessors currently unsupported"
(current-error-port))
(newline (current-error-port)))
- (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)))
+ (make-vertex-attribute #:name name
+ #:buffer view
+ #:offset offset
+ #:component-type component-type
+ #:normalized? normalized?
+ #:length length
+ #:type type)))
(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)
+ (9984 'nearest-mipmap-nearest)
+ (9985 'linear-mipmap-nearest)
+ (9986 'nearest-mipmap-linear)
+ (9987 'linear-mipmap-linear)
(_ 'linear)))
(define (texture-wrap n)
(match n
@@ -928,10 +843,6 @@
(roughness-factor
(or (number-ref/optional pbrmr "roughnessFactor")
1.0))
- (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))))
(emissive-factor
(let ((v (or (array-ref/optional obj "emissiveFactor")
#(1.0 1.0 1.0))))
@@ -948,50 +859,48 @@
(double-sided? (boolean-ref/optional obj "doubleSided"))
(extensions (object-ref/optional obj "extensions"))
(extras (assoc-ref obj "extras")))
- (define (parse-texture obj key)
+ (define (parse-texture obj key default)
(match (object-ref/optional obj key)
- (#f (values null-texture 0))
+ (#f (values (default) 0))
(texture
(values (vector-ref textures (number-ref texture "index"))
(or (number-ref/optional texture "texCoord") 0)))))
- (define (non-null-texture? texture)
- (not (eq? texture null-texture)))
(let-values (((base-color-texture base-color-texcoord)
- (parse-texture pbrmr "baseColorTexture"))
+ (parse-texture pbrmr "baseColorTexture" white-texture))
((metal-rough-texture metal-rough-texcoord)
- (parse-texture pbrmr "metallicRoughnessTexture"))
+ (parse-texture pbrmr "metallicRoughnessTexture" white-texture))
((normal-texture normal-texcoord)
- (parse-texture obj "normalTexture"))
+ (parse-texture obj "normalTexture" flat-texture))
((occlusion-texture occlusion-texcoord)
- (parse-texture obj "occlusionTexture"))
+ (parse-texture obj "occlusionTexture" white-texture))
((emissive-texture emissive-texcoord)
- (parse-texture obj "emissiveTexture")))
- (make-pbr-material #:name name
- #:base-color-factor base-color-factor
- #:base-color-texture base-color-texture
- #:base-color-texture-enabled (non-null-texture? base-color-texture)
- #:base-color-texcoord base-color-texcoord
- #:metallic-factor metallic-factor
- #:roughness-factor roughness-factor
- #:metallic-roughness-texture metal-rough-texture
- #:metallic-roughness-texture-enabled (non-null-texture? metal-rough-texture)
- #:metallic-roughness-texcoord metal-rough-texcoord
- #:normal-factor normal-factor
- #:normal-texture normal-texture
- #:normal-texture-enabled (non-null-texture? normal-texture)
- #:normal-texcoord normal-texcoord
- #:occlusion-texture occlusion-texture
- #:occlusion-texture-enabled (non-null-texture? occlusion-texture)
- #:occlusion-texcoord occlusion-texcoord
- #:emissive-factor emissive-factor
- #:emissive-texture emissive-texture
- #:emissive-texture-enabled (non-null-texture? emissive-texture)
- #:emissive-texcoord emissive-texcoord
- #:alpha-mode alpha-mode
- #:alpha-cutoff alpha-cutoff
- #:double-sided? double-sided?))))
+ (parse-texture obj "emissiveTexture" black-texture)))
+ (make-material
+ #:name name
+ #:shader (pbr-shader)
+ #:blend-mode (if (= alpha-mode 2) blend:alpha blend:replace)
+ #:cull-face-mode (if double-sided?
+ no-cull-face-mode
+ back-cull-face-mode)
+ #:texture-0 base-color-texture
+ #:texture-1 metal-rough-texture
+ #:texture-2 normal-texture
+ #:texture-3 occlusion-texture
+ #:texture-4 emissive-texture
+ #:properties (make-pbr-properties
+ #:base-color-factor base-color-factor
+ #:base-color-texcoord base-color-texcoord
+ #:metallic-factor metallic-factor
+ #:roughness-factor roughness-factor
+ #:metallic-roughness-texcoord metal-rough-texcoord
+ #:normal-texcoord normal-texcoord
+ #:occlusion-texcoord occlusion-texcoord
+ #:emissive-factor emissive-factor
+ #:emissive-texcoord emissive-texcoord
+ #:alpha-mode alpha-mode
+ #:alpha-cutoff alpha-cutoff)))))
(define (attribute-name->index name)
- (let ((shader (graphics-variable-ref pbr-shader)))
+ (let ((shader (pbr-shader)))
(match name
("POSITION"
(attribute-location
@@ -999,7 +908,6 @@
("NORMAL"
(attribute-location
(hash-ref (shader-attributes shader) "normal")))
- ("TANGENT" 10)
("TEXCOORD_0"
(attribute-location
(hash-ref (shader-attributes shader) "texcoord0")))
@@ -1009,19 +917,28 @@
("COLOR_0"
(attribute-location
(hash-ref (shader-attributes shader) "color0")))
- ("JOINTS_0" 12)
- ("WEIGHTS_0" 13))))
+ ;; TODO
+ ("TANGENT" #f)
+ ("JOINTS_0" #f)
+ ("WEIGHTS_0" #f)
+ (_ #f))))
+ ;; TODO: When normals are not specified, generate flat normals.
+ ;;
+ ;; TODO: When positions are not specified, skip the entire
+ ;; primitive.
(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")))
+ (let ((attributes (filter-map (match-lambda
+ ((name . n)
+ (let ((attr (attribute-name->index name)))
+ (and attr
+ (cons attr
+ (vector-ref accessors n))))))
+ (object-ref obj "attributes")))
(indices (match (number-ref/optional obj "indices")
(#f #f)
(n (vector-ref accessors n))))
(material (match (number-ref/optional obj "material")
- (#f default-pbr-material)
+ (#f default-pbr-properties)
(n (vector-ref materials n))))
(mode (match (or (number-ref/optional obj "mode") 4)
(0 'points)
@@ -1139,11 +1056,11 @@
(parse-buffer obj))
(or (assoc-ref tree "buffers") #())))
(indices (index-ids tree))
- (buffer-views (vector-map (lambda (obj i)
- (parse-buffer-view obj i buffers indices))
- (or (assoc-ref tree "bufferViews") #())))
+ (vertex-attributes (vector-map (lambda (obj i)
+ (parse-vertex-attribute obj i buffers indices))
+ (or (assoc-ref tree "bufferViews") #())))
(accessors (vector-map (lambda (obj i)
- (parse-accessor obj buffer-views))
+ (parse-accessor obj vertex-attributes))
(or (assoc-ref tree "accessors") #())))
(images (or (assoc-ref tree "images") #()))
(samplers (or (assoc-ref tree "samplers") #(())))
@@ -1168,5 +1085,4 @@
(error "unsupported glTF version" version))
(make-model #:name (basename file-name)
#:scenes (list default-scene)
- #:render-state
- (make-render-state draw-primitive/pbr))))))
+ #:render-state (make-render-state))))))
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 0d218fb..4978fbb 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -62,6 +62,15 @@
regular-polygon
ellipse
circle
+ gradient?
+ gradient-type
+ gradient-matrix
+ gradient-start-color
+ gradient-end-color
+ gradient-range
+ gradient-radial-ratio
+ linear-gradient
+ radial-gradient
stroke
fill
fill-and-stroke
@@ -118,8 +127,8 @@
;; Curves" by Joe Cridge:
;; https://web.archive.org/web/20170829122313/https://www.joecridge.me/content/pdf/bezier-arcs.pdf
(define (adjust-angle angle)
- ;; Clamp within [0, 2pi] range.
- (let* ((clamped (mod angle 2pi))
+ ;; Clamp within [0, tau] range.
+ (let* ((clamped (mod angle tau))
(adjusted (atan (* (/ rx ry) (tan clamped)))))
;; Adjust angles to counter linear scaling.
(cond
@@ -129,11 +138,11 @@
(<= clamped (* pi 1.5)))
(+ adjusted pi))
(else
- (+ adjusted 2pi)))))
+ (+ adjusted tau)))))
(let* ((angle-start (adjust-angle angle-start))
(angle-end* (adjust-angle angle-end))
(angle-end (if (> angle-start angle-end*)
- (+ angle-end* 2pi)
+ (+ angle-end* tau)
angle-end*))
;; Don't bother making a curve for an angle smaller than
;; this.
@@ -416,7 +425,7 @@
(close-path))))
(define (regular-polygon center num-sides radius)
- (let ((theta-step (/ 2pi num-sides)))
+ (let ((theta-step (/ tau num-sides)))
(apply path
(let loop ((i 0))
(cond
@@ -469,6 +478,67 @@
;;;
+;;; Gradients
+;;;
+
+(define-record-type <gradient>
+ (make-gradient type matrix start-color end-color range radial-ratio)
+ gradient?
+ (type gradient-type)
+ (matrix gradient-matrix)
+ (start-color gradient-start-color)
+ (end-color gradient-end-color)
+ (range gradient-range)
+ ;; This x:y ratio is used to squash/stretch radial gradients to give
+ ;; an elliptical appearance.
+ (radial-ratio gradient-radial-ratio))
+
+(define (angle->vec2 theta)
+ (vec2 (cos theta) (sin theta)))
+
+(define (make-range offset length)
+ (vec2 offset (+ offset length)))
+
+(define (make-gradient-matrix origin rotation)
+ (matrix3* (matrix3-translate (vec2* origin -1.0))
+ (matrix3-rotate rotation)))
+
+(define (transform-gradient gradient matrix)
+ (make-gradient (gradient-type gradient)
+ ;; The matrix needs to be inverted in order to
+ ;; convert world space coordinates back into local
+ ;; coordinates within the fragment shader. We need
+ ;; the local coordinates for the gradient math to
+ ;; produce the correct result.
+ (matrix3* (matrix3-inverse matrix) (gradient-matrix gradient))
+ (gradient-start-color gradient)
+ (gradient-end-color gradient)
+ (gradient-range gradient)
+ (gradient-radial-ratio gradient)))
+
+(define* (linear-gradient #:key (origin %origin) (start-color white)
+ (end-color black) (rotation 0.0) (offset 0.0)
+ (length 100.0))
+ (make-gradient 'linear
+ (make-gradient-matrix origin rotation)
+ start-color
+ end-color
+ (make-range offset length)
+ 0.0))
+
+(define* (radial-gradient #:key (origin %origin) (start-color white)
+ (end-color black) (radius 50.0)
+ (radius-x radius) (radius-y radius)
+ (rotation 0.0) (offset 0.0))
+ (make-gradient 'radial
+ (make-gradient-matrix origin rotation)
+ start-color
+ end-color
+ (make-range offset (- radius-x offset))
+ (/ radius-x radius-y)))
+
+
+;;;
;;; Path Tesselation
;;;
@@ -480,7 +550,7 @@
;; Step 2: Use compiled points to fill vertex buffers with triangles
;; for filling or stroking.
(define-record-type <compiled-path>
- (%make-compiled-path point-capacity point-count path-capacity path-count bounding-box)
+ (%make-compiled-path point-capacity point-count path-capacity path-count)
compiled-path?
(point-count compiled-path-point-count set-compiled-path-point-count!)
(point-capacity compiled-path-point-capacity set-compiled-path-point-capacity!)
@@ -489,7 +559,7 @@
(points compiled-path-points set-compiled-path-points!)
(offsets compiled-path-offsets set-compiled-path-offsets!)
(counts compiled-path-counts set-compiled-path-counts!)
- (bounding-box compiled-path-bounding-box))
+ (bounding-box compiled-path-bounding-box set-compiled-path-bounding-box!))
(define (resize-compiled-path-offsets-and-counts! compiled-path capacity)
(let ((new-offsets (make-u32vector capacity))
@@ -512,14 +582,15 @@
(set-compiled-path-point-capacity! compiled-path capacity)))
(define (make-compiled-path)
- (let ((compiled-path (%make-compiled-path 0 0 0 0 (make-rect 0.0 0.0 0.0 0.0))))
+ (let ((compiled-path (%make-compiled-path 0 0 0 0)))
(resize-compiled-path-offsets-and-counts! compiled-path 64)
(resize-compiled-path-points! compiled-path 256)
compiled-path))
(define (clear-compiled-path compiled-path)
(set-compiled-path-count! compiled-path 0)
- (set-compiled-path-point-count! compiled-path 0))
+ (set-compiled-path-point-count! compiled-path 0)
+ (set-compiled-path-bounding-box! compiled-path (make-rect 0.0 0.0 0.0 0.0)))
(define %origin (vec2 0.0 0.0))
@@ -578,7 +649,6 @@
;; the transformation matrix.
(rect-union! (compiled-path-bounding-box compiled-path)
(transform-bounding-box (path-bounding-box path) matrix))
- (path-bounding-box path) (compiled-path-bounding-box compiled-path)
;; Evaluate all commands. This simple virtual machine uses a
;; brush-on-paper metaphor and has a few variables that can be
;; manipulated:
@@ -1087,9 +1157,13 @@
;;; Rendering
;;;
-(define-graphics-variable path-shader
- (load-shader (scope-datadir "shaders/path-vert.glsl")
- (scope-datadir "shaders/path-frag.glsl")))
+(define-graphics-variable stroke-shader
+ (load-shader (scope-datadir "shaders/path-stroke-vert.glsl")
+ (scope-datadir "shaders/path-stroke-frag.glsl")))
+
+(define-graphics-variable fill-shader
+ (load-shader (scope-datadir "shaders/path-fill-vert.glsl")
+ (scope-datadir "shaders/path-fill-frag.glsl")))
(define-graphics-variable mvp-matrix (make-null-matrix4))
@@ -1102,9 +1176,8 @@
(define *debug?* #f)
-;; TODO: gradients
(define* (draw-filled-path filled-path matrix)
- (let ((shader (graphics-variable-ref path-shader))
+ (let ((shader (graphics-variable-ref fill-shader))
(mvp (graphics-variable-ref mvp-matrix))
(counts (filled-path-counts filled-path))
(offsets (filled-path-offsets filled-path))
@@ -1120,8 +1193,7 @@
(geometry-vertex-array stencil-geometry)
(u32vector-ref offsets i)
(u32vector-ref counts i)
- #:mvp (current-projection)
- #:mode 0))))
+ #:mvp (current-projection)))))
;; Anti-alias the edges of the fill.
(with-graphics-state ((g:multisample? #t))
;; Render fan to stencil buffer. Each time a triangle is
@@ -1142,23 +1214,37 @@
(geometry-vertex-array stencil-geometry)
(u32vector-ref offsets i)
(u32vector-ref counts i)
- #:mvp mvp
- #:mode 0)))
+ #:mvp mvp)))
;; Render a quad with the stencil applied. The quad is the size
;; of the path's bounding box. The stencil test will make it so
;; we only draw fragments that are part of the filled path.
(with-graphics-state ((g:stencil-test stencil-cover-and-clear)
(g:blend-mode (filled-path-blend-mode filled-path)))
- (shader-apply shader
- (geometry-vertex-array quad-geometry)
- #:mvp mvp
- #:mode 0
- #:color (filled-path-color filled-path))))))
+ (let ((color (filled-path-color filled-path)))
+ (if (gradient? color)
+ ;; Linear/radial gradient fill.
+ (shader-apply shader
+ (geometry-vertex-array quad-geometry)
+ #:mvp mvp
+ #:color (gradient-start-color color)
+ #:end-color (gradient-end-color color)
+ #:gradient-matrix (gradient-matrix color)
+ #:gradient-range (gradient-range color)
+ #:radial-gradient-ratio (gradient-radial-ratio color)
+ #:mode (case (gradient-type color)
+ ((linear) 1)
+ ((radial) 2)))
+ ;; Solid fill.
+ (shader-apply shader
+ (geometry-vertex-array quad-geometry)
+ #:mvp mvp
+ #:color (filled-path-color filled-path)
+ #:mode 0)))))))
;; TODO: dashed stroke
;; TODO: miter styles and miter limit
(define* (draw-stroked-path stroked-path matrix)
- (let ((shader (graphics-variable-ref path-shader))
+ (let ((shader (graphics-variable-ref stroke-shader))
(mvp (graphics-variable-ref mvp-matrix)))
(matrix4-mult! mvp matrix (current-projection))
(with-graphics-state ((g:blend-mode (stroked-path-blend-mode stroked-path)))
@@ -1169,16 +1255,17 @@
(geometry-index-count geometry)
#:mvp mvp
#:color (stroked-path-color stroked-path)
- #:mode 1
#:feather (stroked-path-feather stroked-path)
- #:stroke-cap (match (stroked-path-cap stroked-path)
- (#f 0) ; no cap
- ('butt 1)
- ('square 2)
- ('round 3)
- ('triangle-out 4)
- ('triangle-in 5)
- (x (error "unsupported line cap style" x)))
+ #:stroke-cap (case (stroked-path-cap stroked-path)
+ ((#f) 0) ; no cap
+ ((butt) 1)
+ ((square) 2)
+ ((round) 3)
+ ((triangle-out) 4)
+ ((triangle-in) 5)
+ (else
+ (error "unsupported line cap style"
+ (stroked-path-cap stroked-path))))
#:stroke-width (stroked-path-width stroked-path))))))
@@ -1220,7 +1307,9 @@
(array-list-pop! filled-paths))))
(fill-path filled-path compiled-path
#:blend-mode blend-mode
- #:color fill-color)
+ #:color (if (gradient? fill-color)
+ (transform-gradient fill-color matrix)
+ fill-color))
(array-list-push! result filled-path)
(loop rest matrix blend-mode fill-color stroke-color stroke-width
stroke-feather stroke-cap)))
@@ -1248,8 +1337,14 @@
stroke-feather stroke-cap)))
;; Apply transformation matrix.
(('transform transform)
- (loop rest (matrix3* matrix transform) blend-mode fill-color
- stroke-color stroke-width stroke-feather stroke-cap))
+ (loop rest
+ (matrix3* transform matrix)
+ blend-mode
+ fill-color
+ stroke-color
+ stroke-width
+ stroke-feather
+ stroke-cap))
;; Set style properties.
((or ('set-style 'blend-mode blend-mode)
('set-style 'fill-color fill-color)
diff --git a/chickadee/graphics/pbr.scm b/chickadee/graphics/pbr.scm
index 0977579..e1641ec 100644
--- a/chickadee/graphics/pbr.scm
+++ b/chickadee/graphics/pbr.scm
@@ -32,119 +32,59 @@
#: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-base-color-texture-enabled?
- pbr-material-base-color-texcoord
- pbr-material-metallic-factor
- pbr-material-roughness-factor
- pbr-material-metallic-roughness-texture
- pbr-material-metallic-roughness-texture-enabled?
- pbr-material-metallic-roughness-texcoord
- pbr-material-normal-factor
- pbr-material-normal-texture
- pbr-material-normal-texture-enabled?
- pbr-material-normal-texcoord
- pbr-material-occlusion-texture
- pbr-material-occlusion-texture-enabled?
- pbr-material-occlusion-texcoord
- pbr-material-emissive-factor
- pbr-material-emissive-texture
- pbr-material-emissive-texture-enabled?
- pbr-material-emissive-texcoord
- pbr-material-alpha-mode
- pbr-material-alpha-cutoff
- pbr-material-double-sided?
- default-pbr-material
- pbr-shader
- shader-apply/pbr))
+ #:export (make-pbr-properties
+ pbr-properties?
+ pbr-properties-base-color-factor
+ pbr-properties-base-color-texcoord
+ pbr-properties-metallic-factor
+ pbr-properties-roughness-factor
+ pbr-properties-metallic-roughness-texcoord
+ pbr-properties-normal-texcoord
+ pbr-properties-occlusion-texcoord
+ pbr-properties-emissive-factor
+ pbr-properties-emissive-texcoord
+ pbr-properties-alpha-mode
+ pbr-properties-alpha-cutoff
+ default-pbr-properties
+ pbr-shader))
-(define-shader-type <pbr-material>
- 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)
- (bool base-color-texture-enabled pbr-material-base-color-texture-enabled?)
- (int base-color-texcoord pbr-material-base-color-texcoord)
- (float metallic-factor pbr-material-metallic-factor)
- (float roughness-factor pbr-material-roughness-factor)
- (local-field metallic-roughness-texture pbr-material-metallic-roughness-texture)
- (bool metallic-roughness-texture-enabled pbr-material-metallic-roughness-texture-enabled?)
- (int metallic-roughness-texcoord pbr-material-metallic-roughness-texcoord)
- (float-vec3 normal-factor pbr-material-normal-factor)
- (local-field normal-texture pbr-material-normal-texture)
- (bool normal-texture-enabled pbr-material-normal-texture-enabled)
- (int normal-texcoord pbr-material-normal-texcoord)
- (local-field occlusion-texture pbr-material-occlusion-texture)
- (bool occlusion-texture-enabled pbr-material-occlusion-texture-enabled)
- (int occlusion-texcoord pbr-material-occlusion-texcoord)
- (float-vec3 emissive-factor pbr-material-emissive-factor)
- (local-field emissive-texture pbr-material-emissive-texture)
- (bool emissive-texture-enabled pbr-material-emissive-texture-enabled)
- (int emissive-texcoord pbr-material-emissive-texcoord)
- (int alpha-mode pbr-material-alpha-mode)
- (float alpha-cutoff pbr-material-alpha-cutoff)
- (local-field double-sided? pbr-material-double-sided?))
+(define-shader-type <pbr-properties>
+ make-pbr-properties
+ pbr-properties?
+ (float-vec3 base-color-factor pbr-properties-base-color-factor)
+ (int base-color-texcoord pbr-properties-base-color-texcoord)
+ (float metallic-factor pbr-properties-metallic-factor)
+ (float roughness-factor pbr-properties-roughness-factor)
+ (int metallic-roughness-texcoord pbr-properties-metallic-roughness-texcoord)
+ (int normal-texcoord pbr-properties-normal-texcoord)
+ (int occlusion-texcoord pbr-properties-occlusion-texcoord)
+ (float-vec3 emissive-factor pbr-properties-emissive-factor)
+ (int emissive-texcoord pbr-properties-emissive-texcoord)
+ (int alpha-mode pbr-properties-alpha-mode)
+ (float alpha-cutoff pbr-properties-alpha-cutoff))
-(define default-pbr-material
- (make-pbr-material #:name "default"
- #:base-color-factor #v(1.0 1.0 1.0)
- #:base-color-texture null-texture
- #:base-color-texture-enabled #f
- #:base-color-texcoord 0
- #:metallic-factor 1.0
- #:roughness-factor 1.0
- #:metallic-roughness-texture null-texture
- #:metallic-roughness-texture-enabled #f
- #:metallic-roughness-texcoord 0
- #:normal-factor #v(1.0 1.0 1.0)
- #:normal-texture null-texture
- #:normal-texture-enabled #f
- #:normal-texcoord 0
- #:occlusion-texture null-texture
- #:occlusion-texture-enabled #f
- #:occlusion-texcoord 0
- #:emissive-factor #v(1.0 1.0 1.0)
- #:emissive-texture null-texture
- #:emissive-texture-enabled #f
- #:emissive-texcoord 0
- #:alpha-mode 0
- #:alpha-cutoff 0.5
- #:double-sided? #f))
+(define default-pbr-properties
+ (make-pbr-properties #:base-color-factor #v(1.0 1.0 1.0)
+ #:base-color-texcoord 0
+ #:metallic-factor 1.0
+ #:roughness-factor 1.0
+ #:metallic-roughness-texcoord 0
+ #:normal-texcoord 0
+ #:occlusion-texcoord 0
+ #:emissive-factor #v(1.0 1.0 1.0)
+ #:emissive-texcoord 0
+ #:alpha-mode 0
+ #:alpha-cutoff 0.5))
-(define-graphics-variable pbr-shader
- (load-shader (scope-datadir "shaders/pbr-vert.glsl")
- (scope-datadir "shaders/pbr-frag.glsl")))
+(define %pbr-shader
+ (delay (load-shader (scope-datadir "shaders/pbr-vert.glsl")
+ (scope-datadir "shaders/pbr-frag.glsl"))))
-(define (shader-apply/pbr vertex-array material model-matrix view-matrix
- camera-position lights ambient-light-color)
- (let* ((shader (graphics-variable-ref pbr-shader))
- (vattrs (vertex-array-attributes vertex-array))
- (sattrs (shader-attributes shader)))
- (with-graphics-state ((g:blend-mode (if (= (pbr-material-alpha-mode material) 2)
- blend:alpha
- blend:replace))
- (g:cull-face-mode (if (pbr-material-double-sided? material)
- no-cull-face-mode
- back-cull-face-mode))
- (g:texture-0 (pbr-material-base-color-texture material))
- (g:texture-1 (pbr-material-metallic-roughness-texture material))
- (g:texture-2 (pbr-material-normal-texture material))
- (g:texture-3 (pbr-material-occlusion-texture material))
- (g:texture-4 (pbr-material-emissive-texture material)))
- (shader-apply shader vertex-array
- #:model model-matrix
- #:view view-matrix
- #:projection (current-projection)
- #:vertex-colored (buffer-view?
- (assv-ref vattrs
- (attribute-location
- (hash-ref sattrs "color0"))))
- #:camera-position camera-position
- #:material material
- #:ambient-light-color ambient-light-color
- #:lights lights))))
+(define (pbr-shader)
+ (force %pbr-shader))
+
+;; TODO: Handle vertex colors
+;; (buffer-view?
+;; (assv-ref vattrs
+;; (attribute-location
+;; (hash-ref sattrs "color0"))))
diff --git a/chickadee/graphics/phong.scm b/chickadee/graphics/phong.scm
index f52f10b..e3deba2 100644
--- a/chickadee/graphics/phong.scm
+++ b/chickadee/graphics/phong.scm
@@ -30,83 +30,43 @@
#: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
- shader-apply/phong))
+ #:export (make-phong-properties
+ phong-properties?
+ phong-properties-name
+ phong-properties-ambient
+ phong-properties-diffuse
+ phong-properties-specular
+ phong-properties-shininess
+ default-phong-properties
+ phong-shader))
;;;
-;;; Phong Material
+;;; Phong Properties
;;;
-(define-shader-type <phong-material>
- 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-shader-type <phong-properties>
+ make-phong-properties
+ phong-properties?
+ (float-vec3 ambient phong-properties-ambient)
+ (float-vec3 diffuse phong-properties-diffuse)
+ (float-vec3 specular phong-properties-specular)
+ (float shininess phong-properties-shininess))
-(define 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))
+(define default-phong-properties
+ (make-phong-properties #:ambient (vec3 1.0 1.0 1.0)
+ #:diffuse (vec3 1.0 1.0 1.0)
+ #:specular (vec3 1.0 1.0 1.0)
+ #:shininess 32.0))
;;;
;;; Phong Shader
;;;
-(define-graphics-variable phong-shader
- (load-shader (scope-datadir "shaders/phong-vert.glsl")
- (scope-datadir "shaders/phong-frag.glsl")))
+(define %phong-shader
+ (delay (load-shader (scope-datadir "shaders/phong-vert.glsl")
+ (scope-datadir "shaders/phong-frag.glsl"))))
-(define (shader-apply/phong vertex-array material model-matrix view-matrix
- camera-position lights ambient-light-color)
- (let ((shader (graphics-variable-ref phong-shader)))
- (with-graphics-state ((g:texture-0 (phong-material-ambient-map material))
- (g:texture-1 (phong-material-diffuse-map material))
- (g:texture-2 (phong-material-specular-map material))
- (g:texture-3 (phong-material-bump-map material)))
- (shader-apply shader vertex-array
- #:model model-matrix
- #:view view-matrix
- #:projection (current-projection)
- #:material material
- ;; #:camera-position camera-position
- #:ambient-light-color ambient-light-color
- #:lights lights))))
+(define (phong-shader)
+ (force %phong-shader))
diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm
index 80acd02..7def1f2 100644
--- a/chickadee/graphics/shader.scm
+++ b/chickadee/graphics/shader.scm
@@ -45,8 +45,10 @@
float-vec2
float-vec3
float-vec4
+ mat3
mat4
sampler-2d
+ sampler-cube
local-field
define-shader-type
uniform-namespace?
@@ -213,6 +215,18 @@
#:setter gl-uniform4fv
#:null (make-null-rect))
+(define-shader-primitive-type mat3
+ #:name 'mat3
+ #:size (* 3 3 4) ; 3 rows x 3 columns x 4 byte floats
+ #:validator matrix3?
+ #:serializer
+ (let ((matrix3-bv (@@ (chickadee math matrix) matrix3-bv)))
+ (lambda (bv i m)
+ (bytevector-copy! (matrix3-bv m) 0 bv i (* 3 3 4))))
+ #:setter (lambda (location count ptr)
+ (gl-uniform-matrix3fv location count #f ptr))
+ #:null (make-identity-matrix3))
+
(define-shader-primitive-type mat4
#:name 'mat4
#:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes
@@ -236,6 +250,16 @@
#:setter gl-uniform1iv
#:null 0)
+(define-shader-primitive-type sampler-cube
+ #:name 'sampler-cube
+ #:size 4
+ #:validator integer?
+ #:serializer
+ (lambda (bv i texture-unit)
+ (bytevector-s32-native-set! bv i texture-unit))
+ #:setter gl-uniform1iv
+ #:null 0)
+
;;;
;;; Compound Shader Data Types
@@ -577,8 +601,10 @@ them into a GPU shader program."
((= type (version-2-0 float-vec2)) float-vec2)
((= type (version-2-0 float-vec3)) float-vec3)
((= type (version-2-0 float-vec4)) float-vec4)
+ ((= type (version-2-0 float-mat3)) mat3)
((= type (version-2-0 float-mat4)) mat4)
((= type (version-2-0 sampler-2d)) sampler-2d)
+ ((= type (version-2-0 sampler-cube)) sampler-cube)
(else
(error "unsupported OpenGL type" type))))
(define (camel->snake str)
@@ -660,7 +686,7 @@ them into a GPU shader program."
(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))
+ (sampler? (or (eq? type sampler-2d) (eq? type sampler-cube)))
(default (cond
(sampler?
texture-unit)
@@ -815,7 +841,8 @@ shader program."
;; 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)
+ (unless (or (eq? (uniform-type uniform) sampler-2d)
+ (eq? (uniform-type uniform) sampler-cube))
(traverse uniform (shader-struct-ref value key))))
uniform)
(error "expected shader struct" x)))
@@ -854,7 +881,8 @@ shader program."
;; behind the scenes.
(shader-uniform-for-each
(lambda (uniform)
- (when (eq? (uniform-type uniform) sampler-2d)
+ (when (or (eq? (uniform-type uniform) sampler-2d)
+ (eq? (uniform-type uniform) sampler-cube))
(set-uniform-value! shader* uniform (uniform-value uniform))))
shader*)
exp))
diff --git a/chickadee/graphics/skybox.scm b/chickadee/graphics/skybox.scm
new file mode 100644
index 0000000..d7fe5d7
--- /dev/null
+++ b/chickadee/graphics/skybox.scm
@@ -0,0 +1,101 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; 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
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; 3D Skybox
+;;
+;;; Code:
+
+(define-module (chickadee graphics skybox)
+ #:use-module (chickadee config)
+ #:use-module (chickadee graphics buffer)
+ #:use-module (chickadee graphics blend)
+ #:use-module (chickadee graphics color)
+ #:use-module (chickadee graphics depth)
+ #:use-module (chickadee graphics engine)
+ #:use-module (chickadee graphics polygon)
+ #:use-module (chickadee graphics shader)
+ #:use-module (chickadee graphics texture)
+ #:use-module (srfi srfi-9)
+ #:export (make-skybox
+ skybox?
+ skybox-cube-map
+ skybox-mesh
+ draw-skybox))
+
+(define-record-type <skybox>
+ (%make-skybox cube-map vertex-array)
+ skybox?
+ (cube-map skybox-cube-map)
+ (vertex-array skybox-vertex-array))
+
+(define (make-skybox cube-map)
+ (let* ((index (u32vector 0 3 2 0 2 1
+ 4 7 6 4 6 5
+ 8 11 10 8 10 9
+ 12 15 14 12 14 13
+ 16 19 18 16 18 17
+ 20 23 22 20 22 21))
+ (verts (f32vector -1.0 -1.0 -1.0 ; bottom
+ 1.0 -1.0 -1.0
+ 1.0 -1.0 1.0
+ -1.0 -1.0 1.0
+ -1.0 1.0 -1.0 ; top
+ 1.0 1.0 -1.0
+ 1.0 1.0 1.0
+ -1.0 1.0 1.0
+ -1.0 -1.0 -1.0 ; left
+ -1.0 1.0 -1.0
+ -1.0 1.0 1.0
+ -1.0 -1.0 1.0
+ 1.0 -1.0 -1.0 ; right
+ 1.0 1.0 -1.0
+ 1.0 1.0 1.0
+ 1.0 -1.0 1.0
+ -1.0 -1.0 1.0 ; front
+ 1.0 -1.0 1.0
+ 1.0 1.0 1.0
+ -1.0 1.0 1.0
+ -1.0 -1.0 -1.0 ; back
+ 1.0 -1.0 -1.0
+ 1.0 1.0 -1.0
+ -1.0 1.0 -1.0))
+ (index-buffer (make-buffer index #:target 'index))
+ (vertex-buffer (make-buffer verts))
+ (indices (make-vertex-attribute #:buffer index-buffer
+ #:type 'scalar
+ #:component-type 'unsigned-int))
+ (positions (make-vertex-attribute #:buffer vertex-buffer
+ #:type 'vec3
+ #:component-type 'float))
+ (va (make-vertex-array #:indices indices
+ #:attributes `((0 . ,positions)))))
+ (%make-skybox cube-map va)))
+
+(define %skybox-shader
+ (delay (load-shader (scope-datadir "shaders/skybox-vert.glsl")
+ (scope-datadir "shaders/skybox-frag.glsl"))))
+
+(define (skybox-shader)
+ (force %skybox-shader))
+
+(define (draw-skybox skybox view)
+ (with-graphics-state ((g:texture-0 (skybox-cube-map skybox)))
+ (shader-apply (skybox-shader) (skybox-vertex-array skybox)
+ #:view view
+ #:projection (current-projection))))
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm
index e7342db..e9a13ae 100644
--- a/chickadee/graphics/texture.scm
+++ b/chickadee/graphics/texture.scm
@@ -33,10 +33,14 @@
#:use-module (chickadee utils)
#:export (make-texture
make-texture-region
+ make-cube-map
load-image
+ load-cube-map
texture?
texture-region?
+ cube-map?
texture-null?
+ texture-type
texture-parent
texture-min-filter
texture-mag-filter
@@ -49,16 +53,22 @@
texture-gl-rect
texture-gl-tex-rect
null-texture
+ black-texture
+ white-texture
+ gray-texture
+ flat-texture
g:texture-0
g:texture-1
g:texture-2
g:texture-3
g:texture-4
+ g:texture-5
current-texture-0
current-texture-1
current-texture-2
current-texture-3
current-texture-4
+ current-texture-5
texture-atlas
list->texture-atlas
@@ -78,10 +88,11 @@
;; The <texture> object is a simple wrapper around an OpenGL texture
;; id.
(define-record-type <texture>
- (%make-texture id parent min-filter mag-filter wrap-s wrap-t
+ (%make-texture id type parent min-filter mag-filter wrap-s wrap-t
x y width height gl-rect gl-tex-rect)
texture?
(id texture-id)
+ (type texture-type)
(parent texture-parent)
(min-filter texture-min-filter)
(mag-filter texture-mag-filter)
@@ -110,7 +121,7 @@
(texture-wrap-t texture))))
(define null-texture
- (%make-texture 0 #f 'linear 'linear 'repeat 'repeat 0 0 0 0
+ (%make-texture 0 '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0
(make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))
(define (texture-null? texture)
@@ -120,14 +131,24 @@
(define (texture-region? texture)
(texture? (texture-parent texture)))
+(define (cube-map? texture)
+ (and (texture? texture) (eq? (texture-type texture) 'cube-map)))
+
(define (free-texture texture)
(gl-delete-texture (texture-id texture)))
+(define (gl-texture-target type)
+ (case type
+ ((2d)
+ (texture-target texture-2d))
+ ((cube-map)
+ (version-1-3 texture-cube-map))))
+
(define (make-bind-texture n)
(lambda (texture)
(let ((texture-unit (+ (version-1-3 texture0) n)))
(set-gl-active-texture texture-unit)
- (gl-bind-texture (texture-target texture-2d)
+ (gl-bind-texture (gl-texture-target (texture-type texture))
(texture-id texture)))))
(define-graphics-finalizer texture-finalizer
@@ -159,6 +180,50 @@
#:default null-texture
#:bind (make-bind-texture 4))
+(define-graphics-state g:texture-5
+ current-texture-5
+ #:default null-texture
+ #:bind (make-bind-texture 5))
+
+(define (gl-wrap-mode mode)
+ (case mode
+ ((repeat)
+ (texture-wrap-mode repeat))
+ ('mirrored-repeat (version-1-4 mirrored-repeat))
+ ((clamp)
+ (texture-wrap-mode clamp))
+ ((clamp-to-border)
+ (texture-wrap-mode clamp-to-border-sgis))
+ ((clamp-to-edge)
+ (texture-wrap-mode clamp-to-edge-sgis))))
+
+(define (gl-min-filter min-filter)
+ (case min-filter
+ ((nearest)
+ (gl:texture-min-filter nearest))
+ ((linear)
+ (gl:texture-min-filter linear))
+ ((nearest-mipmap-nearest)
+ (gl:texture-min-filter nearest-mipmap-nearest))
+ ((linear-mipmap-nearest)
+ (gl:texture-min-filter linear-mipmap-nearest))
+ ((nearest-mipmap-linear)
+ (gl:texture-min-filter nearest-mipmap-linear))
+ ((linear-mipmap-linear)
+ (gl:texture-min-filter linear-mipmap-linear))))
+
+(define (gl-mag-filter mag-filter)
+ (case mag-filter
+ ((nearest)
+ (gl:texture-mag-filter nearest))
+ ((linear)
+ (gl:texture-mag-filter linear))))
+
+(define (gl-pixel-format format)
+ (case format
+ ((rgba)
+ (pixel-format rgba))))
+
(define* (make-texture pixels width height #:key
flip?
(min-filter 'nearest)
@@ -177,16 +242,8 @@ handled for texture coordinates outside the [0, 1] range. Allowed
symbols are: repeat (the default), mirrored-repeat, clamp,
clamp-to-border, clamp-to-edge. FORMAT specifies the pixel format.
Currently only 32-bit RGBA format is supported."
- (define (gl-wrap mode)
- (match mode
- ('repeat (texture-wrap-mode repeat))
- ('mirrored-repeat (version-1-4 mirrored-repeat))
- ('clamp (texture-wrap-mode clamp))
- ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
- ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))
-
(assert-current-graphics-engine)
- (let ((texture (%make-texture (gl-generate-texture) #f
+ (let ((texture (%make-texture (gl-generate-texture) '2d #f
min-filter mag-filter wrap-s wrap-t
0 0 width height
(make-rect 0.0 0.0 width height)
@@ -200,28 +257,100 @@ Currently only 32-bit RGBA format is supported."
(set-gl-active-texture (version-1-3 texture0))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-min-filter)
- (match min-filter
- ('nearest (gl:texture-min-filter nearest))
- ('linear (gl:texture-min-filter linear))))
+ (gl-min-filter min-filter))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-mag-filter)
- (match mag-filter
- ('nearest (gl:texture-mag-filter nearest))
- ('linear (gl:texture-mag-filter linear))))
+ (gl-mag-filter mag-filter))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-wrap-s)
- (gl-wrap wrap-s))
+ (gl-wrap-mode wrap-s))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-wrap-t)
- (gl-wrap wrap-t))
+ (gl-wrap-mode wrap-t))
(gl-texture-image-2d (texture-target texture-2d)
0 (pixel-format rgba) width height 0
- (match format
- ('rgba (pixel-format rgba)))
+ (gl-pixel-format format)
(color-pointer-type unsigned-byte)
- (or pixels %null-pointer)))
+ (or pixels %null-pointer))
+ ;; Generate mipmaps, if needed.
+ (when (memq min-filter
+ '(nearest-mipmap-nearest
+ linear-mipmap-nearest
+ nearest-mipmap-linear
+ linear-mipmap-linear))
+ (gl-generate-mipmap (texture-target texture-2d))))
texture))
+(define* (make-cube-map faces #:key
+ (min-filter 'linear)
+ (mag-filter 'linear)
+ (format 'rgba))
+ (define (set-face name pixels width height)
+ (gl-texture-image-2d (case name
+ ((right)
+ (version-1-3 texture-cube-map-positive-x))
+ ((left)
+ (version-1-3 texture-cube-map-negative-x))
+ ((top)
+ (version-1-3 texture-cube-map-positive-y))
+ ((bottom)
+ (version-1-3 texture-cube-map-negative-y))
+ ((front)
+ (version-1-3 texture-cube-map-positive-z))
+ ((back)
+ (version-1-3 texture-cube-map-negative-z)))
+ 0 (pixel-format rgba) width height 0
+ (gl-pixel-format format)
+ (color-pointer-type unsigned-byte)
+ pixels))
+ (match faces
+ (((right right-width right-height)
+ (left left-width left-height)
+ (top top-width top-height)
+ (bottom bottom-width bottom-height)
+ (front front-width front-height)
+ (back back-width back-height))
+ (assert-current-graphics-engine)
+ (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f
+ min-filter mag-filter
+ 'clamp-to-edge 'clamp-to-edge
+ 0 0 0 0 #f #f)))
+ (graphics-engine-guard! texture)
+ (with-graphics-state! ((g:texture-0 texture))
+ ;; Ensure that we are using texture unit 0 because
+ ;; with-graphics-state! doesn't guarantee it.
+ (set-gl-active-texture (version-1-3 texture0))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-min-filter)
+ (gl-min-filter min-filter))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-mag-filter)
+ (gl-mag-filter mag-filter))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-wrap-s)
+ (gl-wrap-mode 'clamp-to-edge))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-wrap-t)
+ (gl-wrap-mode 'clamp-to-edge))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-wrap-r-ext)
+ (gl-wrap-mode 'clamp-to-edge))
+ (set-face 'right right right-width right-height)
+ (set-face 'left left left-width left-height)
+ (set-face 'top top top-width top-height)
+ (set-face 'bottom bottom bottom-width bottom-height)
+ (set-face 'front front front-width front-height)
+ (set-face 'back back back-width back-height)
+ ;; Generate mipmaps, if needed.
+ (when (memq min-filter
+ '(nearest-mipmap-nearest
+ linear-mipmap-nearest
+ nearest-mipmap-linear
+ linear-mipmap-linear))
+ (gl-generate-mipmap (gl-texture-target 'cube-map))))
+ texture))
+ (_ (error "cube map requires six faces"))))
+
(define (make-texture-region texture rect)
"Create a new texture region covering a section of TEXTURE defined
by the bounding box RECT."
@@ -233,15 +362,20 @@ by the bounding box 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)))
+ (case (texture-type texture)
+ ((2d)
+ (%make-texture (texture-id texture)
+ '2d
+ texture
+ (texture-min-filter texture)
+ (texture-mag-filter texture)
+ (texture-wrap-s texture)
+ (texture-wrap-t texture)
+ x y w h
+ vert-rect
+ tex-rect))
+ (else
+ (error "regions can only be made from 2d textures")))))
(define (flip-pixels-vertically pixels width height)
"Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
@@ -255,36 +389,34 @@ HEIGHT, 32 bit color bytevector."
(bytevector-copy! pixels source-start buffer target-start row-width)))
buffer))
-(define (surface->texture surface min-filter mag-filter wrap-s wrap-t
- transparent-color flip?)
- "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)
+(define (call-with-loaded-image file-name transparent-color flip? proc)
+ (sdl2:call-with-surface (sdl2:load-image file-name)
(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)))
- (for-range ((i pixel-count 0 4))
- (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)))))
- (make-texture (if flip?
- (flip-pixels-vertically pixels width height)
- pixels)
- width height
- #:min-filter min-filter
- #:mag-filter mag-filter
- #:wrap-s wrap-s
- #:wrap-t wrap-t)))))
+ (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)))
+ (for-range ((i pixel-count 0 4))
+ (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)))))
+ (proc (if flip?
+ (flip-pixels-vertically pixels width height)
+ ;; Need to copy the pixels for some reason.
+ ;; Noticed when implementing cube maps when all
+ ;; 6 texture pieces were all showing up as the
+ ;; last image loaded.
+ (bytevector-copy pixels))
+ width height)))))))
(define* (load-image file #:key
(min-filter 'nearest)
@@ -297,10 +429,62 @@ the given 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:load-image file)
- (lambda (surface)
- (surface->texture surface min-filter mag-filter wrap-s wrap-t
- transparent-color flip?))))
+ (call-with-loaded-image file transparent-color flip?
+ (lambda (pixels width height)
+ (make-texture pixels width height
+ #:min-filter min-filter
+ #:mag-filter mag-filter
+ #:wrap-s wrap-s
+ #:wrap-t wrap-t))))
+
+(define* (load-cube-map #:key right left top bottom front back
+ (min-filter 'linear-mipmap-linear)
+ (mag-filter 'linear))
+ (let ((right (call-with-loaded-image right #f #f list))
+ (left (call-with-loaded-image left #f #f list))
+ (top (call-with-loaded-image top #f #f list))
+ (bottom (call-with-loaded-image bottom #f #f list))
+ (front (call-with-loaded-image front #f #f list))
+ (back (call-with-loaded-image back #f #f list)))
+ (make-cube-map (list right left top bottom front back)
+ #:min-filter min-filter
+ #:mag-filter mag-filter)))
+
+(define (black-texture)
+ null-texture)
+
+(define %white-texture
+ (delay
+ (make-texture (u32vector #xffffffff #xffffffff #xffffffff #xffffffff)
+ 2 2)))
+
+(define (white-texture)
+ (force %white-texture))
+
+(define %gray-texture
+ (delay
+ (make-texture (u32vector #xff808080 #xff808080 #xff808080 #xff808080)
+ 2 2)))
+
+(define (gray-texture)
+ (force %gray-texture))
+
+;; A "flat" normal map, in tangent space. It's like the identity
+;; property for normals. The colors are used to store 3D tangent space
+;; vectors, with positive Z being "up". Each coordinate is in the
+;; [-1,1] range and then remapped to an 8-bit color channel in the
+;; 0-255 range. Thus, 0 maps to 127 or #x80, -1 maps to 0, and 1 maps
+;; to 255. The color values are in ABGR ordering. A flat tangent
+;; normal is (0, 0, 1), which is encoded as the color #xffff8080.
+;; Such a value means that a mesh's vertex normals remain completely
+;; unchanged by this normal map.
+(define %flat-texture
+ (delay
+ (make-texture (u32vector #xffff8080 #xffff8080 #xffff8080 #xffff8080)
+ 2 2)))
+
+(define (flat-texture)
+ (force %flat-texture))
;;;
diff --git a/chickadee/math.scm b/chickadee/math.scm
index c61b862..70c2474 100644
--- a/chickadee/math.scm
+++ b/chickadee/math.scm
@@ -18,7 +18,7 @@
(define-module (chickadee math)
#:export (pi
pi/2
- 2pi
+ tau
cotan
clamp
min
@@ -28,9 +28,9 @@
radians->degrees)
#:replace (min max))
-(define pi 3.14159265358979323846)
-(define pi/2 (/ pi 2.0))
-(define 2pi (* pi 2.0))
+(define pi 3.1415926535897932)
+(define pi/2 1.5707963267948966)
+(define tau 6.283185307179586) ;; AKA 2pi
(define-inlinable (cotan z)
"Return the cotangent of Z."
diff --git a/chickadee/math/matrix.scm b/chickadee/math/matrix.scm
index b79c94d..355562a 100644
--- a/chickadee/math/matrix.scm
+++ b/chickadee/math/matrix.scm
@@ -42,6 +42,8 @@
matrix3-rotate
matrix3-transform!
matrix3-transform
+ matrix3-inverse!
+ matrix3-inverse
make-matrix4
make-null-matrix4
make-identity-matrix4
@@ -289,6 +291,51 @@ column-major format."
(matrix3-transform! matrix new-v)
new-v))
+;; I honestly found this wikihow page very helpful in explaining the
+;; process of inverting a 3x3 matrix:
+;;
+;; https://www.wikihow.com/Find-the-Inverse-of-a-3x3-Matrix
+(define (matrix3-inverse! matrix target)
+ (let* ((bv (matrix3-bv matrix))
+ (a (matrix3-ref bv 0 0))
+ (b (matrix3-ref bv 0 1))
+ (c (matrix3-ref bv 0 2))
+ (d (matrix3-ref bv 1 0))
+ (e (matrix3-ref bv 1 1))
+ (f (matrix3-ref bv 1 2))
+ (g (matrix3-ref bv 2 0))
+ (h (matrix3-ref bv 2 1))
+ (i (matrix3-ref bv 2 2))
+ ;; Calculate the determinants of the minor matrices of the
+ ;; inverse of the original matrix.
+ (a* (- (* e i) (* f h)))
+ (b* (- (* b i) (* c h)))
+ (c* (- (* b f) (* c e)))
+ (d* (- (* d i) (* f g)))
+ (e* (- (* a i) (* c g)))
+ (f* (- (* a f) (* c d)))
+ (g* (- (* d h) (* e g)))
+ (h* (- (* a h) (* b g)))
+ (i* (- (* a e) (* b d)))
+ ;; Determinant and its inverse.
+ (det (+ (- (* a a*) (* b d*)) (* c g*)))
+ (invdet (/ 1.0 det)))
+ ;; If the matrix cannot be inverted (determinant of 0), then just
+ ;; bail out by resetting target to the identity matrix.
+ (if (= det 0.0)
+ (matrix3-identity! target)
+ ;; Multiply by the inverse of the determinant to get the final
+ ;; inverse matrix. Every other value is inverted.
+ (init-matrix3 target
+ (* a* invdet) (* (- b*) invdet) (* c* invdet)
+ (* (- d*) invdet) (* e* invdet) (* (- f*) invdet)
+ (* g* invdet) (* (- h*) invdet) (* i* invdet)))))
+
+(define (matrix3-inverse matrix)
+ (let ((new (make-null-matrix3)))
+ (matrix3-inverse! matrix new)
+ new))
+
;;;
;;; 4x4 Matrix
@@ -565,9 +612,9 @@ clipping plane NEAR and FAR."
(vec3-x xaxis) (vec3-x yaxis) (- (vec3-x zaxis)) 0.0
(vec3-y xaxis) (vec3-y yaxis) (- (vec3-y zaxis)) 0.0
(vec3-z xaxis) (vec3-z yaxis) (- (vec3-z zaxis)) 0.0
- (- (vec3-dot-product xaxis eye))
- (- (vec3-dot-product yaxis eye))
- (vec3-dot-product zaxis eye)
+ (- (vec3-dot xaxis eye))
+ (- (vec3-dot yaxis eye))
+ (vec3-dot zaxis eye)
1.0)))
(define (look-at eye at up)
diff --git a/chickadee/math/vector.scm b/chickadee/math/vector.scm
index 7e847e3..680fb0f 100644
--- a/chickadee/math/vector.scm
+++ b/chickadee/math/vector.scm
@@ -33,7 +33,7 @@
vec2-x
vec2-y
vec2-magnitude
- vec2-dot-product
+ vec2-dot
vec2-cross
vec2-normalize
set-vec2-x!
@@ -55,7 +55,7 @@
vec3-y
vec3-z
vec3-magnitude
- vec3-dot-product
+ vec3-dot
vec3-cross
vec3-cross!
vec3-normalize
@@ -235,12 +235,12 @@ polar coordinate (R, THETA) with an arbitrary ORIGIN point."
(* (vec3-y v) (vec3-y v))
(* (vec3-z v) (vec3-z v)))))
-(define-inlinable (vec2-dot-product v1 v2)
+(define-inlinable (vec2-dot v1 v2)
"Return the dot product of the vec2s V1 and V2."
(+ (* (vec2-x v1) (vec2-x v2))
(* (vec2-y v1) (vec2-y v2))))
-(define-inlinable (vec3-dot-product v1 v2)
+(define-inlinable (vec3-dot v1 v2)
"Return the dot product of the vec3s V1 and V2."
(+ (* (vec3-x v1) (vec3-x v2))
(* (vec3-y v1) (vec3-y v2))
diff --git a/configure.ac b/configure.ac
index a0dda9d..aa53707 100644
--- a/configure.ac
+++ b/configure.ac
@@ -9,6 +9,7 @@ AM_SILENT_RULES([yes])
AC_PATH_PROG([GUILE], [guile])
AC_CONFIG_FILES([Makefile])
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
+AC_CONFIG_FILES([test-env], [chmod +x test-env])
AC_CONFIG_FILES([chickadee/config.scm])
# Prepare a version of $datadir that does not contain references to
diff --git a/data/shaders/path-fill-frag.glsl b/data/shaders/path-fill-frag.glsl
new file mode 100644
index 0000000..ba9c5a6
--- /dev/null
+++ b/data/shaders/path-fill-frag.glsl
@@ -0,0 +1,41 @@
+// -*- mode: c -*-
+
+#ifdef GLSL330
+out vec4 fragColor;
+#else
+#define fragColor gl_FragColor
+#endif
+
+#ifdef GLSL120
+attribute vec2 fragPosition;
+#else
+in vec2 fragPosition;
+#endif
+
+uniform int mode;
+uniform vec4 color;
+uniform vec4 endColor;
+uniform vec2 gradientRange;
+uniform float radialGradientRatio;
+
+vec4 gradientMix(float x) {
+ float start = gradientRange.x;
+ float end = gradientRange.y;
+ float t = clamp((x - start) / (end - start), 0.0, 1.0);
+ return mix(color, endColor, t);
+}
+
+void main(void) {
+ if (color.a <= 0.0) {
+ discard;
+ }
+
+ if(mode == 0) { // solid color
+ fragColor = color;
+ } else if(mode == 1) { // linear gradient
+ fragColor = gradientMix(fragPosition.x);
+ } else if(mode == 2) { // radial gradient
+ vec2 p = fragPosition * vec2(1.0, radialGradientRatio);
+ fragColor = gradientMix(length(p));
+ }
+}
diff --git a/data/shaders/path-fill-vert.glsl b/data/shaders/path-fill-vert.glsl
new file mode 100644
index 0000000..d66bb14
--- /dev/null
+++ b/data/shaders/path-fill-vert.glsl
@@ -0,0 +1,30 @@
+// -*- mode: c -*-
+
+#ifdef GLSL330
+layout (location = 0) in vec2 position;
+#elif defined(GLSL130)
+in vec2 position;
+#elif defined(GLSL120)
+attribute vec2 position;
+#endif
+
+#ifdef GLSL120
+varying vec2 fragPosition;
+#else
+out vec2 fragPosition;
+#endif
+
+uniform mat4 mvp;
+uniform vec4 color;
+uniform mat3 gradientMatrix;
+
+void main(void) {
+ // Short-circuit because the fragments will just be discarded
+ // anyway.
+ if (color.a <= 0.0) {
+ gl_Position = vec4(0.0, 0.0, 0.0, 1.0);
+ } else {
+ fragPosition = (gradientMatrix * vec3(position, 1.0)).xy;
+ gl_Position = mvp * vec4(position, 0.0, 1.0);
+ }
+}
diff --git a/data/shaders/path-frag.glsl b/data/shaders/path-frag.glsl
deleted file mode 100644
index 0288ae1..0000000
--- a/data/shaders/path-frag.glsl
+++ /dev/null
@@ -1,93 +0,0 @@
-// -*- mode: c -*-
-
-#ifdef GLSL330
-out vec4 fragColor;
-#endif
-
-#ifdef GLSL120
-varying vec2 fragTex;
-varying float fragStrokeLength;
-#else
-in vec2 fragTex;
-in float fragStrokeLength;
-#endif
-
-uniform int mode;
-uniform vec4 color;
-uniform float feather;
-uniform int strokeClosed;
-uniform float strokeWidth;
-uniform int strokeCap;
-uniform int strokeMiterStyle;
-uniform float strokeMiterLimit;
-
-float infinity = 1.0 / 0.0;
-
-void main(void) {
- if (color.a <= 0.0) {
- discard;
- }
-
- // fill mode
- if(mode == 0) {
-#ifdef GLSL330
- fragColor = color;
-#else
- gl_FragColor = color;
-#endif
- } else if(mode == 1) { // stroke mode
- float hw = strokeWidth / 2.0;
- float u = fragTex.x;
- float v = fragTex.y;
- float dx;
- float dy;
- float d;
-
- // Stroke caps.
- if (u < 0 || u > fragStrokeLength) {
- if (u < 0) {
- dx = abs(u);
- } else {
- dx = u - fragStrokeLength;
- }
- dy = abs(v);
-
- if (strokeCap == 0) { // none
- d = infinity;
- } else if (strokeCap == 1) { // butt
- d = max(dx + hw - 2 * feather, dy);
- } else if (strokeCap == 2) { // square
- d = max(dx, dy);
- } else if (strokeCap == 3) { // round
- d = sqrt(dx * dx + dy * dy);
- } else if (strokeCap == 4) { // triangle out
- d = dx + dy;
- } else if (strokeCap == 5) { // triangle in
- d = max(dy, hw - feather + dx - dy);
- }
- // Stroke inner/join
- } else {
- d = abs(v);
- }
-
- if(d <= hw) {
-#ifdef GLSL330
- fragColor = color;
-#else
- gl_FragColor = color;
-#endif
- } else {
- vec4 c = vec4(color.rgb, color.a * (1.0 - ((d - hw) / feather)));
-
- if (c.a <= 0.0) {
- discard;
- }
-
-#ifdef GLSL330
- fragColor = c;
-#else
- gl_FragColor = c;
-#endif
- }
- }
-}
diff --git a/data/shaders/path-stroke-frag.glsl b/data/shaders/path-stroke-frag.glsl
new file mode 100644
index 0000000..9682c8f
--- /dev/null
+++ b/data/shaders/path-stroke-frag.glsl
@@ -0,0 +1,77 @@
+// -*- mode: c -*-
+
+#ifdef GLSL330
+out vec4 fragColor;
+#else
+#define fragColor gl_FragColor
+#endif
+
+#ifdef GLSL120
+varying vec2 fragTex;
+varying float fragStrokeLength;
+#else
+in vec2 fragTex;
+in float fragStrokeLength;
+#endif
+
+uniform vec4 color;
+uniform float feather;
+uniform int strokeClosed;
+uniform float strokeWidth;
+uniform int strokeCap;
+uniform int strokeMiterStyle;
+uniform float strokeMiterLimit;
+
+float infinity = 1.0 / 0.0;
+
+void main(void) {
+ if (color.a <= 0.0) {
+ discard;
+ }
+
+ float hw = strokeWidth / 2.0;
+ float u = fragTex.x;
+ float v = fragTex.y;
+ float dx;
+ float dy;
+ float d;
+
+ // Stroke caps.
+ if (u < 0 || u > fragStrokeLength) {
+ if (u < 0) {
+ dx = abs(u);
+ } else {
+ dx = u - fragStrokeLength;
+ }
+ dy = abs(v);
+
+ if (strokeCap == 0) { // none
+ d = infinity;
+ } else if (strokeCap == 1) { // butt
+ d = max(dx + hw - 2 * feather, dy);
+ } else if (strokeCap == 2) { // square
+ d = max(dx, dy);
+ } else if (strokeCap == 3) { // round
+ d = sqrt(dx * dx + dy * dy);
+ } else if (strokeCap == 4) { // triangle out
+ d = dx + dy;
+ } else if (strokeCap == 5) { // triangle in
+ d = max(dy, hw - feather + dx - dy);
+ }
+ // Stroke inner/join
+ } else {
+ d = abs(v);
+ }
+
+ if(d <= hw) {
+ fragColor = color;
+ } else {
+ vec4 c = vec4(color.rgb, color.a * (1.0 - ((d - hw) / feather)));
+
+ if (c.a <= 0.0) {
+ discard;
+ }
+
+ fragColor = c;
+ }
+}
diff --git a/data/shaders/path-vert.glsl b/data/shaders/path-stroke-vert.glsl
index 38fa5d2..5915010 100644
--- a/data/shaders/path-vert.glsl
+++ b/data/shaders/path-stroke-vert.glsl
@@ -28,17 +28,12 @@ uniform int mode;
uniform int strokeClosed;
void main(void) {
- // Short-circuit because the fragments will just be discarded anyway.
- if (color.a <= 0.0) {
- gl_Position = vec4(0.0, 0.0, 0.0, 1.0);
- return;
- }
-
- // Stroke specific setup.
- if (mode == 1) {
- fragStrokeLength = strokeLength;
- }
-
+ // Short-circuit because the fragments will just be discarded anyway.
+ if (color.a <= 0.0) {
+ gl_Position = vec4(0.0, 0.0, 0.0, 1.0);
+ } else {
+ fragStrokeLength = strokeLength;
fragTex = tex;
gl_Position = mvp * vec4(position.xy, 0.0, 1.0);
+ }
}
diff --git a/data/shaders/pbr-frag.glsl b/data/shaders/pbr-frag.glsl
index 5998474..fff725a 100644
--- a/data/shaders/pbr-frag.glsl
+++ b/data/shaders/pbr-frag.glsl
@@ -2,19 +2,13 @@
struct Material {
vec3 baseColorFactor;
- bool baseColorTextureEnabled;
int baseColorTexcoord;
float metallicFactor;
float roughnessFactor;
- bool metallicRoughnessTextureEnabled;
int metallicRoughnessTexcoord;
- vec3 normalFactor;
- bool normalTextureEnabled;
int normalTexcoord;
- bool occlusionTextureEnabled;
int occlusionTexcoord;
vec3 emissiveFactor;
- bool emissiveTextureEnabled;
int emissiveTexcoord;
int alphaMode;
float alphaCutoff;
@@ -53,9 +47,9 @@ out vec4 fragColor;
uniform Material material;
uniform Light lights[MAX_LIGHTS];
-uniform vec4 ambientLightColor;
uniform bool vertexColored;
uniform vec3 cameraPosition;
+uniform samplerCube skybox;
uniform sampler2D baseColorTexture;
uniform sampler2D metallicRoughnessTexture;
uniform sampler2D normalTexture;
@@ -142,34 +136,25 @@ vec3 toneMap(vec3 color) {
float materialMetallic() {
float m = material.metallicFactor;
-
- if(material.metallicRoughnessTextureEnabled) {
- m *= texture(metallicRoughnessTexture,
- texcoord(material.metallicRoughnessTexcoord)).b;
- }
-
+ m *= texture(metallicRoughnessTexture,
+ texcoord(material.metallicRoughnessTexcoord)).b;
return m;
}
float materialRoughness() {
float r = material.roughnessFactor;
- if(material.metallicRoughnessTextureEnabled) {
- r *= texture(metallicRoughnessTexture,
- texcoord(material.metallicRoughnessTexcoord)).g;
- }
+ r *= texture(metallicRoughnessTexture,
+ texcoord(material.metallicRoughnessTexcoord)).g;
return r;
}
vec4 materialAlbedo() {
- vec4 color = vec4(0.0, 0.0, 1.0, 1.0);
-
- if(material.baseColorTextureEnabled) {
- vec4 texColor = texture(baseColorTexture,
- texcoord(material.baseColorTexcoord));
- color = sRGBtoLinear(texColor);
- }
+ vec4 color = vec4(1.0, 1.0, 1.0, 1.0);
+ vec4 texColor = texture(baseColorTexture,
+ texcoord(material.baseColorTexcoord));
+ color = sRGBtoLinear(texColor);
color *= vec4(material.baseColorFactor, 1.0);
@@ -183,44 +168,33 @@ vec4 materialAlbedo() {
vec3 materialEmissive() {
vec3 color = vec3(0.0);
- if(material.emissiveTextureEnabled) {
- vec4 texColor = texture(emissiveTexture,
- texcoord(material.emissiveTexcoord));
- color = sRGBtoLinear(texColor).rgb;
- }
+ vec4 texColor = texture(emissiveTexture,
+ texcoord(material.emissiveTexcoord));
+ color = sRGBtoLinear(texColor).rgb;
return color * material.emissiveFactor;
}
vec3 materialOcclusion() {
- if(material.occlusionTextureEnabled) {
- return vec3(texture(occlusionTexture,
- texcoord(material.occlusionTexcoord)).r);
- } else {
- return vec3(1.0);
- }
+ return vec3(texture(occlusionTexture,
+ texcoord(material.occlusionTexcoord)).r);
}
vec3 materialNormal() {
- if(material.normalTextureEnabled) {
- // See: http://www.thetenthplanet.de/archives/1180
- vec2 t = texcoord(material.normalTexcoord);
- vec3 tangentNormal = texture(normalTexture, t).xyz * 2.0 - 1.0;
-
- vec3 q1 = dFdx(fragWorldPos);
- vec3 q2 = dFdy(fragWorldPos);
- vec2 st1 = dFdx(fragTexcoord0);
- vec2 st2 = dFdy(fragTexcoord0);
-
- vec3 N = normalize(fragNormal);
- vec3 T = normalize(q1 * st2.t - q2 * st1.t);
- vec3 B = -normalize(cross(N, T));
- mat3 TBN = mat3(T, B, N);
-
- return normalize(TBN * tangentNormal);
- } else {
- return fragNormal;
- }
+ // See: https://github.com/SaschaWillems/Vulkan-glTF-PBR/blob/master/data/shaders/pbr_khr.frag
+ // See: http://www.thetenthplanet.de/archives/1180
+ vec2 uv = texcoord(material.normalTexcoord);
+ vec3 tangentNormal = texture(normalTexture, uv).xyz * 2.0 - 1.0;
+ vec3 q1 = dFdx(fragWorldPos);
+ vec3 q2 = dFdy(fragWorldPos);
+ vec2 st1 = dFdx(uv);
+ vec2 st2 = dFdy(uv);
+ vec3 N = normalize(fragNormal);
+ vec3 T = normalize(q1 * st2.t - q2 * st1.t);
+ vec3 B = -normalize(cross(N, T));
+ mat3 TBN = mat3(T, B, N);
+
+ return normalize(TBN * tangentNormal);
}
vec3 lightDirection(Light light) {
@@ -270,6 +244,7 @@ void main(void) {
float metallic = materialMetallic();
float roughness = materialRoughness();
vec3 normal = materialNormal();
+ vec3 reflection = reflect(-viewDirection, normal);
// The "raw" albedo has an alpha channel which we need to preserve
// so that we can apply the desired alpha blending method at the
// end, but it is completely ignored for lighting calculations.
@@ -382,11 +357,14 @@ void main(void) {
// The emissive texture says which fragments emit light. We simply
// add this light value to the color accumulator.
color += materialEmissive();
- // Apply simple ambient lighting. The affect of the ambient light
- // is dampened by the ambient occlusion factor.
+ // Apply image based ambient lighting. The affect of the ambient
+ // light is dampened by the ambient occlusion factor.
//
- // TODO: Use image based lighting.
- color += ambientLightColor.rgb * albedo * ambientOcclusion;
+ // TODO: Use fancy PBR equations instead of these basic ones.
+ float fresnel = pow(1.0 - clamp(dot(viewDirection, normal), 0.0, 1.0), 5);
+ vec3 ambientDiffuse = textureCube(skybox, normal).rgb;
+ vec3 ambientSpecular = textureLod(skybox, reflection, roughness * 7.0).rgb;
+ color += (ambientDiffuse * albedo + ambientSpecular * fresnel) * ambientOcclusion;
// Apply Reinhard tone mapping to convert our high dynamic range
// color value to low dynamic range. All of the lighting
// calculations stacked on top of each other is likely to create
diff --git a/data/shaders/pbr-vert.glsl b/data/shaders/pbr-vert.glsl
index adbcdc5..76989a4 100644
--- a/data/shaders/pbr-vert.glsl
+++ b/data/shaders/pbr-vert.glsl
@@ -2,26 +2,26 @@
#ifdef GLSL330
layout (location = 0) in vec3 position;
-layout (location = 1) in vec3 normal;
-layout (location = 2) in vec3 tangent;
-layout (location = 3) in vec2 texcoord0;
+layout (location = 1) in vec2 texcoord0;
+layout (location = 2) in vec3 normal;
+layout (location = 3) in vec3 tangent;
layout (location = 4) in vec2 texcoord1;
layout (location = 5) in vec4 color0;
layout (location = 6) in vec4 joint;
layout (location = 7) in vec4 weight;
#elif defined(GLSL130)
in vec3 position;
+in vec2 texcoord0;
in vec3 normal;
in vec3 tangent;
-in vec2 texcoord0;
in vec2 texcoord1;
in vec4 color0;
in vec4 joint;
#elif defined(GLSL120)
attribute vec3 position;
+attribute vec2 texcoord0;
attribute vec3 normal;
attribute vec3 tangent;
-attribute vec2 texcoord0;
attribute vec2 texcoord1;
attribute vec4 color0;
attribute vec4 weight;
diff --git a/data/shaders/phong-frag.glsl b/data/shaders/phong-frag.glsl
index 84e9feb..9c86c83 100644
--- a/data/shaders/phong-frag.glsl
+++ b/data/shaders/phong-frag.glsl
@@ -2,17 +2,9 @@
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 Light {
@@ -40,10 +32,14 @@ in vec2 fragTex;
out vec4 fragColor;
#endif
+uniform samplerCube skybox;
+uniform sampler2D ambientMap;
+uniform sampler2D diffuseMap;
+uniform sampler2D specularMap;
+uniform sampler2D normalMap;
uniform Material material;
uniform Light lights[MAX_LIGHTS];
uniform vec3 cameraPosition;
-uniform vec4 ambientLightColor;
const float GAMMA = 2.2;
@@ -54,10 +50,6 @@ vec2 texture(sampler2D tex, vec2 coord) {
}
#endif
-float posDot(vec3 v1, vec3 v2) {
- return max(dot(v1, v2), 0.0);
-}
-
vec3 gammaCorrect(vec3 color) {
return pow(color, vec3(1.0 / GAMMA));
}
@@ -104,47 +96,46 @@ vec3 lightRadiance(Light light, vec3 direction) {
}
vec3 materialAmbient() {
- if(material.useAmbientMap) {
- return texture(material.ambientMap, fragTex).rgb * material.ambient;
- } else {
- return material.ambient;
- }
+ return texture(ambientMap, fragTex).rgb * material.ambient;
}
vec3 materialDiffuse() {
- if(material.useDiffuseMap) {
- vec4 color = texture(material.diffuseMap, fragTex);
- // discard transparent fragments.
- if(color.a == 0.0) {
- discard;
- }
- return color.rgb * material.diffuse;
- } else {
- return material.diffuse;
+ vec4 color = texture(diffuseMap, fragTex);
+ // discard transparent fragments.
+ if(color.a == 0.0) {
+ discard;
}
+ return color.rgb * material.diffuse;
}
vec3 materialSpecular() {
- if(material.useSpecularMap) {
- return texture(material.specularMap, fragTex).rgb * material.specular;
- } else {
- return material.specular;
- }
+ return texture(specularMap, fragTex).rgb * material.specular;
}
vec3 materialNormal() {
- if(material.useBumpMap) {
- return normalize(texture(material.bumpMap, fragTex).xyz * 2.0 - 1.0);
- } else {
- return fragNorm;
- }
+ // Compute tangent space using fragment data rather than relying
+ // on tangent attributes. See:
+ // http://www.thetenthplanet.de/archives/1180
+ vec3 tangentNormal = normalize(texture(normalMap, fragTex).xyz * 2.0 - 1.0);
+ vec3 q1 = dFdx(fragWorldPos);
+ vec3 q2 = dFdy(fragWorldPos);
+ vec2 st1 = dFdx(fragTex);
+ vec2 st2 = dFdy(fragTex);
+ vec3 N = normalize(fragNorm);
+ vec3 T = normalize(q1 * st2.t - q2 * st1.t);
+ vec3 B = -normalize(cross(N, T));
+ mat3 TBN = mat3(T, B, N);
+
+ return normalize(TBN * tangentNormal);
}
void main() {
+ vec3 viewDir = normalize(cameraPosition - fragWorldPos);
vec3 ambientOcclusion = materialAmbient();
- vec3 baseDiffuseColor = materialDiffuse();
- vec3 baseSpecularColor = materialSpecular();
+ vec3 diffuseColor = materialDiffuse();
+ vec3 specularColor = materialSpecular();
vec3 normal = materialNormal();
+ vec3 reflection = reflect(-viewDir, normal);
vec3 color = vec3(0.0);
// Apply direct lighting.
@@ -156,20 +147,21 @@ void main() {
}
vec3 lightDir = lightDirection(light);
+ vec3 halfVector = normalize(lightDir + viewDir);
vec3 radiance = lightRadiance(light, lightDir);
- float diffuseFactor = posDot(lightDir, normal);
- vec3 reflectDir = reflect(-lightDir, normal);
- vec3 diffuseColor = baseDiffuseColor * diffuseFactor;
- float specularFactor = 0;
- if(material.shininess > 0) {
- specularFactor = pow(posDot(lightDir, reflectDir), material.shininess);
- }
- vec3 specularColor = baseSpecularColor * specularFactor;
- color += (diffuseColor + specularColor) * radiance;
+ float lambert = clamp(dot(normal, lightDir), 0.0, 1.0);
+ vec3 diffuseLight = radiance * lambert;
+ float specularFactor = clamp(dot(halfVector, normal), 0.0, 1.0) * float(lambert > 0.0);
+ vec3 specularLight = radiance * pow(specularFactor, material.shininess);
+ color += diffuseLight * diffuseColor + specularLight * specularColor;
}
- // Apply ambient lighting.
- vec3 ambientColor = baseDiffuseColor * ambientOcclusion * ambientLightColor.rgb;
+ // Apply image based ambient lighting.
+ float fresnel = pow(1.0 - clamp(dot(viewDir, normal), 0.0, 1.0), 5);
+ float roughness = 1.0 - (material.shininess / 1000.0);
+ vec3 ambientDiffuse = textureCube(skybox, normal).rgb * diffuseColor;
+ vec3 ambientSpecular = textureLod(skybox, reflection, roughness * 7.0).rgb * fresnel;
+ vec3 ambientColor = (ambientDiffuse + ambientSpecular) * ambientOcclusion;
color += ambientColor;
// Apply gamma correction and HDR tone mapping to get the final
diff --git a/data/shaders/phong-vert.glsl b/data/shaders/phong-vert.glsl
index 9b72eb3..f7fd363 100644
--- a/data/shaders/phong-vert.glsl
+++ b/data/shaders/phong-vert.glsl
@@ -30,7 +30,7 @@ uniform mat4 projection;
void main() {
fragWorldPos = vec3(model * vec4(position, 1.0));
- fragNorm = normalize(model * vec4(normal, 1.0)).xyz;
+ fragNorm = mat3(model) * normal;
fragTex = texcoord;
gl_Position = projection * view * vec4(fragWorldPos, 1.0);
}
diff --git a/doc/api.texi b/doc/api.texi
index 96ac394..56df86f 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -581,7 +581,7 @@ approximation that is ``good enough.''
Half of @var{pi}.
@end defvar
-@defvar 2pi
+@defvar tau
Twice @var{pi}.
@end defvar
@@ -675,7 +675,7 @@ Return a fresh copy of the 2D vector @var{v}.
Return the magnitude of the 2D vector @var{v}.
@end deffn
-@deffn {Procedure} vec2-dot-product v1 v2
+@deffn {Procedure} vec2-dot v1 v2
Return the dot product of the 2D vectors @var{v1} and @var{v2}.
@end deffn
@@ -760,7 +760,7 @@ Return a fresh copy of the 3D vector @var{v}.
Return the magnitude of the 3D vector @var{v}.
@end deffn
-@deffn {Procedure} vec3-dot-product v1 v2
+@deffn {Procedure} vec3-dot v1 v2
Return the dot product of the 3D vectors @var{v1} and @var{v2}.
@end deffn
@@ -1093,6 +1093,10 @@ Return a new 2D vector that is @var{v} as transformed by the 3x3
matrix @var{matrix}.
@end deffn
+@deffn {Procedure} matrix3-inverse matrix
+Return the inverse of @var{matrix}.
+@end deffn
+
The following procedures perform in-place, destructive updates to 3x3
matrix objects:
@@ -1125,6 +1129,11 @@ Modify the 2D vector @var{v} in-place to contain @var{v} as
transformed by the 3x3 matrix @var{matrix}.
@end deffn
+@deffn {Procedure} matrix3-inverse! matrix target
+Compute the inverse of @var{matrix} and store the results in
+@var{target}.
+@end deffn
+
@subsubsection 4x4 Matrices
@deffn {Procedure} make-matrix4 aa ab ac ad @
@@ -3168,21 +3177,21 @@ float is 4 bytes in length, so the buffer's stride is 16.
Within a VBO, one or more ``attributes'', as OpenGL calls them, may be
present. Attributes are subregions within the buffer that have a
particular data type. In this case, there are two attributes packed
-into the buffer. To provided a typed view into a buffer, the
-@code{make-buffer-view} procedure is needed:
+into the buffer. To define vertex attributes, the
+@code{make-vertex-attribute} procedure is needed:
@example
(define vertices
- (make-buffer-view #:buffer buffer
- #:type 'vec2
- #:component-type 'float
- #:length 4))
+ (make-vertex-attribute #:buffer buffer
+ #:type 'vec2
+ #:component-type 'float
+ #:length 4))
(define texcoords
- (make-buffer-view #:buffer buffer
- #:type 'vec2
- #:component-type 'float
- #:length 4
- #:offset 8))
+ (make-vertex-attribute #:buffer buffer
+ #:type 'vec2
+ #:component-type 'float
+ #:length 4
+ #:offset 8))
@end example
To render a square, the GPU needs to draw two triangles, which means
@@ -3197,21 +3206,20 @@ created.
(make-buffer (u32vector 0 3 2 0 2 1)
#:target 'index)
(define indices
- (make-buffer-view #:type 'scalar
- #:component-type 'unsigned-int
- #:buffer index-buffer))
+ (make-vertex-attribute #:type 'scalar
+ #:component-type 'unsigned-int
+ #:buffer index-buffer))
@end example
Note the use of the @code{#:target} keyword argument. It is required
because the GPU treats index data in a special way and must be told
which data is index data.
-Now that the buffer views representing each attribute have been
-created, all that's left is to bind them all together in a ``vertex
-array object'', or VAO. Vertex arrays associate each buffer view
-with an attribute index on the GPU. The indices that are chosen must
-correspond with the indices that the shader (@pxref{Shaders}) expects
-for each attribute.
+Now that the vertex attributes have been created, all that's left is
+to bind them all together in a vertex array. Vertex arrays associate
+each vertex attribute with an attribute index on the GPU. The indices
+that are chosen must correspond with the indices that the shader
+(@pxref{Shaders}) expects for each attribute.
@example
(define vertex-array
@@ -3325,11 +3333,11 @@ This form is useful for streaming buffers that need to update their
contents dynamically, such as a sprite batch.
@end deffn
-@deffn {Procedure} make-buffer-view #:buffer #:type @
+@deffn {Procedure} make-vertex-attribute #:buffer #:type @
#:component-type #:length [#:offset @code{0}] [#:divisor @code{1}] @
[#:name @code{"anonymous"}]
-Return a new buffer view for @var{buffer} starting at byte index
+Return a new vertex attribute for @var{buffer} starting at byte index
@var{offset} of @var{length} elements, where each element is of
@var{type} and composed of @var{component-type} values.
@@ -3382,53 +3390,54 @@ used for 1 instance. A divisor of 2 means that each element is used
for 2 instances, and so on.
@end deffn
-@deffn {Procedure} buffer-view? obj
-Return @code{#t} if @var{obj} is a buffer view.
+@deffn {Procedure} vertex-attribute? obj
+Return @code{#t} if @var{obj} is a vertex attribute.
@end deffn
-@deffn {Procedure} buffer-view->buffer buffer-view
-Return the buffer that @var{buffer-view} is using.
+@deffn {Procedure} vertex-attribute->buffer vertex-attribute
+Return the buffer that @var{vertex-attribute} is using.
@end deffn
-@deffn {Procedure} buffer-view-name buffer-view
-Return the name of @var{buffer-view}.
+@deffn {Procedure} vertex-attribute-name vertex-attribute
+Return the name of @var{vertex-attribute}.
@end deffn
-@deffn {Procedure} buffer-view-offset buffer-view
-Return the byte offset of @var{buffer-view}.
+@deffn {Procedure} vertex-attribute-offset vertex-attribute
+Return the byte offset of @var{vertex-attribute}.
@end deffn
-@deffn {Procedure} buffer-view-type buffer-view
-Return the data type of @var{buffer-view}.
+@deffn {Procedure} vertex-attribute-type vertex-attribute
+Return the data type of @var{vertex-attribute}.
@end deffn
-@deffn {Procedure} buffer-view-component-type buffer-view
-Return the component data type of @var{buffer-view}
+@deffn {Procedure} vertex-attribute-component-type vertex-attribute
+Return the component data type of @var{vertex-attribute}
@end deffn
-@deffn {Procedure} buffer-view-divisor buffer-view
-Return the instance divisor for @var{buffer-view}.
+@deffn {Procedure} vertex-attribute-divisor vertex-attribute
+Return the instance divisor for @var{vertex-attribute}.
@end deffn
-@deffn {Syntax} with-mapped-buffer-view buffer-view body @dots{}
+@deffn {Syntax} with-mapped-vertex-attribute vertex-attribute body @dots{}
-Evaluate @var{body} in the context of @var{buffer-view} having its
-data synced from GPU memory to RAM. See @code{with-mapped-buffer} for
-more information.
+Evaluate @var{body} in the context of @var{vertex-attribute} having
+its data synced from GPU memory to RAM. See @code{with-mapped-buffer}
+for more information.
@end deffn
@deffn {Procedure} make-vertex-array #:indices #:attributes @
[#:mode @code{triangles}]
-Return a new vertex array using the index data within the buffer view
-@var{indices} and the vertex attribute data within @var{attributes}.
+Return a new vertex array using the index data within the vertex
+attributes @var{indices} and the vertex attribute data within
+@var{attributes}.
-@var{attributes} is an alist mapping shader attribute indices to typed
-buffers containing vertex data:
+@var{attributes} is an alist mapping shader attribute indices to
+vertex attributes:
@example
-`((1 . ,buffer-view-a)
- (2 . ,buffer-view-b)
+`((1 . ,vertex-attribute-a)
+ (2 . ,vertex-attribute-b)
@dots{})
@end example
diff --git a/examples/path.scm b/examples/path.scm
index 7bad91b..aabfb4d 100644
--- a/examples/path.scm
+++ b/examples/path.scm
@@ -74,7 +74,12 @@
(define (update dt)
(update-agenda 1))
+(define (key-press key modifiers repeat?)
+ (case key
+ ((q) (abort-game))))
+
(run-game #:window-title "Vector paths"
#:load load
#:draw draw
+ #:key-press key-press
#:update update)
diff --git a/test-env.in b/test-env.in
new file mode 100644
index 0000000..1ab197a
--- /dev/null
+++ b/test-env.in
@@ -0,0 +1,5 @@
+#!/bin/sh
+
+"@abs_top_builddir@/pre-inst-env" "$@"
+
+exit $?
diff --git a/tests/math/vector.scm b/tests/math/vector.scm
new file mode 100644
index 0000000..e87c241
--- /dev/null
+++ b/tests/math/vector.scm
@@ -0,0 +1,88 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <davet@gnu.org>
+;;;
+;;; 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
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (tests math vector)
+ #:use-module (tests utils)
+ #:use-module (srfi srfi-64)
+ #:use-module (chickadee math)
+ #:use-module (chickadee math vector))
+
+(with-tests "vector"
+ (test-group "2D vectors"
+ (test-assert "vec2="
+ (vec2= (vec2 1.0 2.0) (vec2 1.0 2.0)))
+ (test-group "vec2/polar"
+ (test-equal (vec2/polar (vec2 1.0 1.0) 2.0 0.0) (vec2 3.0 1.0))
+ (test-equal (vec2/polar (vec2 1.0 1.0) 2.0 (/ pi 2)) (vec2 1.0 3.0))
+ (test-equal (vec2/polar (vec2 1.0 1.0) 2.0 pi) (vec2 -1.0 1.0))
+ (test-equal (vec2/polar (vec2 1.0 1.0) 2.0 (* pi 1.5)) (vec2 1.0 -1.0))
+ (test-equal (vec2/polar (vec2 1.0 1.0) 2.0 tau) (vec2 3.0 1.0)))
+ (test-group "vec2-magnitude"
+ (test-equal "normal case"
+ (vec2-magnitude (vec2 -3.0 4.0)) 5.0)
+ (test-equal "division by zero edge case"
+ (vec2-magnitude (vec2 0.0 0.0)) 0.0))
+ (test-equal "vec2-dot"
+ (vec2-dot (vec2 1.0 2.0) (vec2 3.0 4.0)) 11.0)
+ (test-equal "vec2-cross"
+ (vec2-cross (vec2 1.0 2.0) (vec2 3.0 4.0)) -5.0)
+ (test-approximate "vec2-normalize"
+ (vec2-magnitude (vec2-normalize (vec2 3.7 4.9))) 1.0 0.001)
+ (test-group "vec2*"
+ (test-equal "vec2 * vec2"
+ (vec2* (vec2 2.0 3.0) (vec2 4.0 5.0)) (vec2 8.0 15.0))
+ (test-equal "vec2 * scalar"
+ (vec2* (vec2 2.0 3.0) 4.0) (vec2 8.0 12.0)))
+ (test-group "vec2+"
+ (test-equal "vec2 + vec2"
+ (vec2+ (vec2 1.0 2.0) (vec2 3.0 4.0)) (vec2 4.0 6.0))
+ (test-equal "vec2 + scalar"
+ (vec2+ (vec2 1.0 2.0) 3.0) (vec2 4.0 5.0)))
+ (test-group "vec2-"
+ (test-equal "vec2 - vec2"
+ (vec2- (vec2 1.0 2.0) (vec2 3.0 4.0)) (vec2 -2.0 -2.0))
+ (test-equal "vec2 - scalar"
+ (vec2- (vec2 1.0 2.0) 3.0) (vec2 -2.0 -1.0))))
+ (test-group "3D vectors"
+ (test-assert "vec3="
+ (vec3= (vec3 1.0 2.0 3.0) (vec3 1.0 2.0 3.0)))
+ (test-group "vec3-magnitude"
+ (test-equal "normal case"
+ (vec3-magnitude (vec3 -2.0 3.0 -6.0)) 7.0)
+ (test-equal "division by zero edge case"
+ (vec3-magnitude (vec3 0.0 0.0 0.0)) 0.0))
+ (test-equal "vec3-dot"
+ (vec3-dot (vec3 1.0 2.0 3.0) (vec3 4.0 5.0 6.0)) 32.0)
+ (test-equal "vec3-cross"
+ (vec3-cross (vec3 2.0 3.0 4.0) (vec3 5.0 6.0 7.0)) (vec3 -3.0 6.0 -3.0))
+ (test-approximate "vec3-normalize"
+ (vec3-magnitude (vec3-normalize (vec3 3.7 4.9 9.2))) 1.0 0.001)
+ (test-group "vec3*"
+ (test-equal "vec3 * vec3"
+ (vec3* (vec3 2.0 3.0 4.0) (vec3 5.0 6.0 7.0)) (vec3 10.0 18.0 28.0))
+ (test-equal "vec3 * scalar"
+ (vec3* (vec3 2.0 3.0 4.0) 5.0) (vec3 10.0 15.0 20.0)))
+ (test-group "vec3+"
+ (test-equal "vec3 + vec3"
+ (vec3+ (vec3 1.0 2.0 3.0) (vec3 4.0 5.0 6.0)) (vec3 5.0 7.0 9.0))
+ (test-equal "vec3 + scalar"
+ (vec3+ (vec3 1.0 2.0 3.0) 4.0) (vec3 5.0 6.0 7.0)))
+ (test-group "vec3-"
+ (test-equal "vec3 - vec3"
+ (vec3- (vec3 1.0 2.0 3.0) (vec3 4.0 5.0 6.0)) (vec3 -3.0 -3.0 -3.0))
+ (test-equal "vec3 - scalar"
+ (vec3- (vec3 1.0 2.0 3.0) 4.0) (vec3 -3.0 -2.0 -1.0)))))
diff --git a/tests/utils.scm b/tests/utils.scm
new file mode 100644
index 0000000..3eb89aa
--- /dev/null
+++ b/tests/utils.scm
@@ -0,0 +1,26 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <davet@gnu.org>
+;;;
+;;; 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
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (tests utils)
+ #:use-module (srfi srfi-64)
+ #:export (with-tests))
+
+(define-syntax-rule (with-tests name body ...)
+ (begin
+ (test-begin name)
+ body ...
+ (exit (zero? (test-runner-fail-count (test-end))))))