diff options
| -rw-r--r-- | examples/mines/mines.scm | 5 | ||||
| -rw-r--r-- | sly/game.scm | 4 | ||||
| -rw-r--r-- | sly/input/mouse.scm | 6 | ||||
| -rw-r--r-- | sly/math/quaternion.scm | 14 | ||||
| -rw-r--r-- | sly/math/rect.scm | 6 | ||||
| -rw-r--r-- | sly/math/transform.scm | 75 | ||||
| -rw-r--r-- | sly/math/vector.scm | 349 | ||||
| -rw-r--r-- | sly/render/mesh.scm | 49 | ||||
| -rw-r--r-- | sly/window.scm | 3 |
9 files changed, 339 insertions, 172 deletions
diff --git a/examples/mines/mines.scm b/examples/mines/mines.scm index 0b93473..954f17f 100644 --- a/examples/mines/mines.scm +++ b/examples/mines/mines.scm @@ -163,8 +163,9 @@ (define (board-update board position tile) (match position - (($ <vector2> x y) - (list-replace board y (list-replace (list-ref board y) x tile))))) + ((? vector2? v) + (list-replace board (vy v) + (list-replace (list-ref board y) (vx v) tile))))) (define (neighbors board pos) (let* ((size (length board)) diff --git a/sly/game.scm b/sly/game.scm index 66f0893..f4fb948 100644 --- a/sly/game.scm +++ b/sly/game.scm @@ -106,7 +106,9 @@ instead of becoming completely unresponsive and possibly crashing." (define (draw dt alpha) "Render a frame." (let ((size (signal-ref window-size))) - (gl-viewport 0 0 (vx size) (vy size))) + (gl-viewport 0 0 + (inexact->exact (vx size)) + (inexact->exact (vy size)))) (gl-clear (clear-buffer-mask color-buffer depth-buffer)) (run-hook draw-hook dt alpha) (with-graphics gfx diff --git a/sly/input/mouse.scm b/sly/input/mouse.scm index c6d2b96..815fee6 100644 --- a/sly/input/mouse.scm +++ b/sly/input/mouse.scm @@ -53,8 +53,10 @@ ;; Sly uses the bottom-left as the origin, so invert ;; the y-axis for convenience. (match-lambda - (($ <vector2> x y) - (vector2 x (- (signal-ref window-height) y)))))) + ((? vector2? v) + (vector2 (vector2-x v) + (- (signal-ref window-height) + (vector2-y v))))))) (define-signal mouse-x (signal-map vx mouse-position)) (define-signal mouse-y (signal-map vy mouse-position)) diff --git a/sly/math/quaternion.scm b/sly/math/quaternion.scm index f07eef1..1fc1fa3 100644 --- a/sly/math/quaternion.scm +++ b/sly/math/quaternion.scm @@ -45,10 +45,13 @@ (define make-quaternion (match-lambda* - ((($ <vector3> x y z) (? number? theta)) + (((? vector3? v) (? number? theta)) ;; Convert an axis angle to a quaternion (let* ((theta/2 (/ theta 2)) - (sin (sin theta/2))) + (sin (sin theta/2)) + (x (vector3-x v)) + (y (vector3-y v)) + (z (vector3-z v))) (%make-quaternion (cos theta/2) (* x sin) (* y sin) (* z sin)))) ((w x y z) (%make-quaternion w x y z)))) @@ -108,5 +111,8 @@ Q2 and blending factor DELTA." (define vector->quaternion (match-lambda - (($ <vector4> x y z w) - (make-quaternion x y z w)))) + ((? vector4? v) + (make-quaternion (vector4-x v) + (vector4-y v) + (vector4-z v) + (vector4-w v))))) diff --git a/sly/math/rect.scm b/sly/math/rect.scm index 07358f6..362cf69 100644 --- a/sly/math/rect.scm +++ b/sly/math/rect.scm @@ -187,9 +187,9 @@ RECT2. If the rects do not overlap, a rect of size 0 is returned." (define rect-clamp (match-lambda* - ((($ <rect> rx ry width height) ($ <vector2> x y)) - (vector2 (clamp rx (+ rx width) x) - (clamp ry (+ ry height) y))))) + ((($ <rect> rx ry width height) (? vector2? v)) + (vector2 (clamp rx (+ rx width) (vector2-x v)) + (clamp ry (+ ry height) (vector2-y v)))))) (define (rect-within? rect1 rect2) "Return #t if RECT2 is completely within RECT1." diff --git a/sly/math/transform.scm b/sly/math/transform.scm index 38fd464..234f6b1 100644 --- a/sly/math/transform.scm +++ b/sly/math/transform.scm @@ -275,29 +275,39 @@ called without any arguments." (define (translate! t . args) (match args - (($ <vector2> x y) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y 0 1)) - (($ <vector3> x y z) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y z 1)))) + ((? transform? v) + (let ((x (vector2-x v)) + (y (vector2-y v))) + (make-transform 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y 0 1))) + ((? vector3? v) + (let ((x (vector3-x v)) + (y (vector3-y v)) + (z (vector3-z v))) + (make-transform 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y z 1))))) (define translate (match-lambda - (($ <vector2> x y) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y 0 1)) - (($ <vector3> x y z) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y z 1)) + ((? vector2? v) + (let ((x (vector2-x v)) + (y (vector2-y v))) + (make-transform 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y 0 1))) + ((? vector3? v) + (let ((x (vector3-x v)) + (y (vector3-y v)) + (z (vector3-z v))) + (make-transform 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y z 1))) (v (error "Invalid translation vector: " v)))) (define scale @@ -307,16 +317,21 @@ called without any arguments." 0 v 0 0 0 0 v 0 0 0 0 1)) - (($ <vector2> x y) - (make-transform x 0 0 0 - 0 y 0 0 - 0 0 1 0 - 0 0 0 1)) - (($ <vector3> x y z) - (make-transform x 0 0 0 - 0 y 0 0 - 0 0 z 0 - 0 0 0 1)) + ((? vector2? v) + (let ((x (vector2-x v)) + (y (vector2-y v))) + (make-transform x 0 0 0 + 0 y 0 0 + 0 0 1 0 + 0 0 0 1))) + ((? vector3? v) + (let ((x (vector3-x v)) + (y (vector3-y v)) + (z (vector3-z v))) + (make-transform x 0 0 0 + 0 y 0 0 + 0 0 z 0 + 0 0 0 1))) (v (error "Invalid scaling vector: " v)))) (define (rotate-x angle) diff --git a/sly/math/vector.scm b/sly/math/vector.scm index 33c62d8..778526e 100644 --- a/sly/math/vector.scm +++ b/sly/math/vector.scm @@ -23,60 +23,63 @@ (define-module (sly math vector) #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (sly math) - #:export (<vector2> - <vector3> - <vector4> - vector2 vector3 vector4 + #:use-module (sly records) + #:export (vector2 vector3 vector4 vector2? vector3? vector4? vx vy vz vw + vector2-x vector2-y + vector3-x vector3-y vector3-z + vector4-x vector4-y vector4-z vector4-w vmap v+ v- v* vdot vcross magnitude normalize vlerp)) -(define-record-type <vector2> - (vector2 x y) +(define-packed-f64-record-type <vector2> + vector2 + bytevector->vector2 vector2->bytevector vector2? - (x vector2-x) - (y vector2-y)) + (x 0 vector2-x set-vector2-x!) + (y 1 vector2-y set-vector2-y!)) -(define-record-type <vector3> - (vector3 x y z) +(define-packed-f64-record-type <vector3> + vector3 + bytevector->vector3 vector3->bytevector vector3? - (x vector3-x) - (y vector3-y) - (z vector3-z)) + (x 0 vector3-x set-vector3-x!) + (y 1 vector3-y set-vector3-y!) + (z 2 vector3-z set-vector3-z!)) -(define-record-type <vector4> - (vector4 x y z w) +(define-packed-f64-record-type <vector4> + vector4 + bytevector->vector4 vector4->bytevector vector4? - (x vector4-x) - (y vector4-y) - (z vector4-z) - (w vector4-w)) - -(define vx - (match-lambda - ((or ($ <vector2> x _) - ($ <vector3> x _ _) - ($ <vector4> x _ _ _)) - x))) - -(define vy - (match-lambda - ((or ($ <vector2> _ y) - ($ <vector3> _ y _) - ($ <vector4> _ y _ _)) - y))) - -(define vz - (match-lambda - ((or ($ <vector3> _ _ z) - ($ <vector4> _ _ z _)) - z))) - -(define vw vector4-w) + (x 0 vector4-x set-vector4-x!) + (y 1 vector4-y set-vector4-y!) + (z 2 vector4-z set-vector4-z!) + (w 3 vector4-w set-vector4-w!)) + +(define-inlinable (vx v) + (cond + ((vector2? v) (vector2-x v)) + ((vector3? v) (vector3-x v)) + ((vector4? v) (vector4-x v)))) + +(define-inlinable (vy v) + (cond + ((vector2? v) (vector2-y v)) + ((vector3? v) (vector3-y v)) + ((vector4? v) (vector4-y v)))) + +(define-inlinable (vz v) + (cond + ((vector3? v) (vector3-z v)) + ((vector4? v) (vector4-z v)))) + +(define-inlinable (vw v) + (vector4-w v)) (define (vmap proc v) "Return a new vector that is the result of applying PROC to each @@ -89,80 +92,218 @@ element of the 2D/3D/4D vector V." (($ <vector4> x y z w) (vector4 (proc x) (proc y) (proc z) (proc w))))) -(define-syntax-rule (vector-lambda proc) - (match-lambda* - ((($ <vector2> x1 y1) ($ <vector2> x2 y2)) - (vector2 (proc x1 x2) (proc y1 y2))) - ((($ <vector2> x y) (? number? k)) - (vector2 (proc x k) (proc y k))) - (((? number? k) ($ <vector2> x y)) - (vector2 (proc k x) (proc k y))) - ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2)) - (vector3 (proc x1 x2) (proc y1 y2) (proc z1 z2))) - ((($ <vector3> x y z) (? number? k)) - (vector3 (proc x k) (proc y k) (proc z k))) - (((? number? k) ($ <vector3> x y z)) - (vector3 (proc k x) (proc k y) (proc k z))) - ((($ <vector4> x1 y1 z1 w1) ($ <vector4> x2 y2 z2 w2)) - (vector4 (proc x1 x2) (proc y1 y2) (proc z1 z2) (proc w1 w2))) - ((($ <vector4> x y z w) (? number? k)) - (vector4 (proc x k) (proc y k) (proc z k) (proc w k))) - (((? number? k) ($ <vector4> x y z w)) - (vector4 (proc k x) (proc k y) (proc k z) (proc k w))))) +;; Hoo boy, the things we do for efficiency. ;) +(define-syntax-rule (vector-arithmetic vectors op identity) + (match vectors + ;; Common cases: Adding just 2 vectors of the same type. + ;; Matching against them here means avoiding the more expensive, + ;; more general loops later on. + (((and (? vector2?) (= vector2->bytevector bv1)) + (and (? vector2?) (= vector2->bytevector bv2))) + (bytevector->vector2 + (f64vector (op (f64vector-ref bv1 0) + (f64vector-ref bv2 0)) + (op (f64vector-ref bv1 1) + (f64vector-ref bv2 1))))) + (((and (? vector3?) (= vector3->bytevector bv1)) + (and (? vector3?) (= vector3->bytevector bv2))) + (bytevector->vector3 + (f64vector (op (f64vector-ref bv1 0) + (f64vector-ref bv2 0)) + (op (f64vector-ref bv1 1) + (f64vector-ref bv2 1)) + (op (f64vector-ref bv1 2) + (f64vector-ref bv2 2))))) + (((and (? vector4?) (= vector4->bytevector bv1)) + (and (? vector4?) (= vector4->bytevector bv2))) + (bytevector->vector4 + (f64vector (op (f64vector-ref bv1 0) + (f64vector-ref bv2 0)) + (op (f64vector-ref bv1 1) + (f64vector-ref bv2 1)) + (op (f64vector-ref bv1 2) + (f64vector-ref bv2 2)) + (op (f64vector-ref bv1 3) + (f64vector-ref bv2 3))))) + ;; Special cases for a list with a a single element, to handle use + ;; with subtraction. + (((and (? vector2?) (= vector2->bytevector head))) + (vector2 (op (f64vector-ref head 0)) + (op (f64vector-ref head 1)))) + (((and (? vector3?) (= vector3->bytevector head))) + (vector3 (op (f64vector-ref head 0)) + (op (f64vector-ref head 1)) + (op (f64vector-ref head 2)))) + (((and (? vector4?) (= vector4->bytevector head))) + (vector4 (op (f64vector-ref head 0)) + (op (f64vector-ref head 1)) + (op (f64vector-ref head 2)) + (op (f64vector-ref head 3)))) + (((? number? x)) + (op x)) + ;; General case: + (vectors* + (let outer ((scalar-sum #f) + (vectors* vectors*)) + (match vectors* + ;; First, add up all of the scalars that appear at the head of + ;; the list, before we've been able to determine which vector + ;; type to specialize on. + (() (or scalar-sum identity)) + (((? number? x) . tail) + (outer (if scalar-sum (op scalar-sum x) x) tail)) + ;; Specialize based on vector type once we actually encounter a + ;; vector. + ;; + ;; 2D vectors, possibly mixed with scalars: + (((and (? vector2?) (= vector2->bytevector head)) . tail) + (let ((bv (if scalar-sum + (f64vector (op scalar-sum + (f64vector-ref head 0)) + (op scalar-sum + (f64vector-ref head 1))) + (bytevector-copy head)))) + (let inner ((vectors* tail)) + (match vectors* + (() (bytevector->vector2 bv)) + (((? number? x) . tail) + (f64vector-set! bv 0 (op (f64vector-ref bv 0) x)) + (f64vector-set! bv 1 (op (f64vector-ref bv 1) x)) + (inner tail)) + (((and (? vector2?) (= vector2->bytevector head)) . tail) + (f64vector-set! bv 0 (op (f64vector-ref bv 0) + (f64vector-ref head 0))) + (f64vector-set! bv 1 (op (f64vector-ref bv 1) + (f64vector-ref head 1))) + (inner tail)))))) + ;; 3D vectors, possibly mixed with scalars: + (((and (? vector3?) (= vector3->bytevector head)) . tail) + (let ((bv (if scalar-sum + (f64vector (op scalar-sum + (f64vector-ref head 0)) + (op scalar-sum + (f64vector-ref head 1)) + (op scalar-sum + (f64vector-ref head 2))) + (bytevector-copy head)))) + (let inner ((vectors* tail)) + (match vectors* + (() (bytevector->vector3 bv)) + (((? number? x) . tail) + (f64vector-set! bv 0 (op (f64vector-ref bv 0) x)) + (f64vector-set! bv 1 (op (f64vector-ref bv 1) x)) + (f64vector-set! bv 2 (op (f64vector-ref bv 2) x)) + (inner tail)) + (((and (? vector3?) (= vector3->bytevector head)) . tail) + (f64vector-set! bv 0 (op (f64vector-ref bv 0) + (f64vector-ref head 0))) + (f64vector-set! bv 1 (op (f64vector-ref bv 1) + (f64vector-ref head 1))) + (f64vector-set! bv 2 (op (f64vector-ref bv 2) + (f64vector-ref head 2))) + (inner tail)))))) + ;; 4D vectors, possibly mixed with scalars: + (((and (? vector4?) (= vector4->bytevector head)) . tail) + (let ((bv (if scalar-sum + (f64vector (op scalar-sum + (f64vector-ref head 0)) + (op scalar-sum + (f64vector-ref head 1)) + (op scalar-sum + (f64vector-ref head 2)) + (op scalar-sum + (f64vector-ref head 3))) + (bytevector-copy head)))) + (let inner ((vectors* tail)) + (match vectors* + (() (bytevector->vector4 bv)) + (((? number? x) . tail) + (f64vector-set! bv 0 (op (f64vector-ref bv 0) x)) + (f64vector-set! bv 1 (op (f64vector-ref bv 1) x)) + (f64vector-set! bv 2 (op (f64vector-ref bv 2) x)) + (f64vector-set! bv 3 (op (f64vector-ref bv 3) x)) + (inner tail)) + (((and (? vector4?) (= vector4->bytevector head)) . tail) + (f64vector-set! bv 0 (op (f64vector-ref bv 0) + (f64vector-ref head 0))) + (f64vector-set! bv 1 (op (f64vector-ref bv 1) + (f64vector-ref head 1))) + (f64vector-set! bv 2 (op (f64vector-ref bv 2) + (f64vector-ref head 2))) + (f64vector-set! bv 3 (op (f64vector-ref bv 3) + (f64vector-ref head 3))) + (inner tail))))))))))) (define (v+ . vectors) - (reduce (vector-lambda +) 0 vectors)) - -(define v- - (match-lambda* - ((v) (v- 0 v)) - ((v v* ...) - (fold-right (let ((- (vector-lambda -))) - (lambda (prev v) - (- v prev))) - v v*)))) + "Compute the sum of VECTORS." + (vector-arithmetic vectors + 0)) (define (v* . vectors) - (reduce (vector-lambda *) 1 vectors)) - -(define vdot - (match-lambda* - ((($ <vector2> x1 y1) ($ <vector2> x2 y2)) - (+ (* x1 x2) (* y1 y2))) - ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2)) - (+ (* x1 x2) (* y1 y2) (* z1 z2))) - ((($ <vector4> x1 y1 z1 w1) ($ <vector4> x2 y2 z2 w2)) - (+ (* x1 x2) (* y1 y2) (* z1 z2) (* w1 w2))))) - -(define vcross - (match-lambda* - ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2)) - (vector3 (- (* y1 z2) (* z1 y2)) - (- (* z1 x2) (* x1 z2)) - (- (* x1 y2) (* y1 x2)))))) + "Compute the product of VECTORS." + (vector-arithmetic vectors * 1)) + +(define (v- vectors . rest) + "Compute the difference of VECTORS." + (vector-arithmetic (cons vectors rest) - 0)) + +(define (vdot v1 v2) + "Compute the dot product of the vectors V1 and V2." + (cond + ((and (vector2? v1) (vector2? v2)) + (+ (* (vector2-x v1) (vector2-x v2)) + (* (vector2-y v1) (vector2-y v2)))) + ((and (vector3? v1) (vector3? v2)) + (+ (* (vector3-x v1) (vector3-x v2)) + (* (vector3-y v1) (vector3-y v2)) + (* (vector3-z v1) (vector3-z v2)))) + ((and (vector4? v1) (vector4? v2)) + (+ (* (vector4-x v1) (vector4-x v2)) + (* (vector4-y v1) (vector4-y v2)) + (* (vector4-z v1) (vector4-z v2)) + (* (vector4-w v1) (vector4-w v2)))))) + +(define (vcross v1 v2) + "Compute the cross product of the 3D vectors V1 and V2." + (vector3 (- (* (vector3-y v1) (vector3-z v2)) + (* (vector3-z v1) (vector3-y v2))) + (- (* (vector3-z v1) (vector3-x v2)) + (* (vector3-x v1) (vector3-z v2))) + (- (* (vector3-x v1) (vector3-y v2)) + (* (vector3-y v1) (vector3-x v2))))) (define (magnitude v) "Return the magnitude of the vector V." (sqrt - (match v - (($ <vector2> x y) - (+ (square x) (square y))) - (($ <vector3> x y z) - (+ (square x) (square y) (square z))) - (($ <vector4> x y z w) - (+ (square x) (square y) (square z) (square w)))))) + (cond + ((vector2? v) + (+ (square (vector2-x v)) + (square (vector2-y v)))) + ((vector3? v) + (+ (square (vector3-x v)) + (square (vector3-y v)) + (square (vector3-z v)))) + ((vector4? v) + (+ (square (vector4-x v)) + (square (vector4-y v)) + (square (vector4-z v)) + (square (vector4-w v))))))) (define (normalize v) "Return the normalized form of the vector V." (let ((m (magnitude v))) - (if (zero? m) - v - (match v - (($ <vector2> x y) - (vector2 (/ x m) (/ y m))) - (($ <vector3> x y z) - (vector3 (/ x m) (/ y m) (/ z m))) - (($ <vector4> x y z w) - (vector4 (/ x m) (/ y m) (/ z m) (/ w m))))))) + (cond + ((zero? m) v) + ((vector2? v) + (vector2 (/ (vector2-x v) m) + (/ (vector2-y v) m))) + ((vector3? v) + (vector3 (/ (vector3-x v) m) + (/ (vector3-y v) m) + (/ (vector3-z v) m))) + ((vector4? v) + (vector4 (/ (vector4-x v) m) + (/ (vector4-y v) m) + (/ (vector4-z v) m) + (/ (vector4-w v) m)))))) (define vlerp (make-lerp v+ v*)) diff --git a/sly/render/mesh.scm b/sly/render/mesh.scm index 7f38b29..273019d 100644 --- a/sly/render/mesh.scm +++ b/sly/render/mesh.scm @@ -133,33 +133,32 @@ (bv (if index? (make-u32vector (vector-length vertices)) (make-f32vector (* (vector-length vertices) - (attribute-size elem))))) - (setter (if index? u32vector-set! f32vector-set!))) + (attribute-size elem)))))) (vector-for-each (match-lambda* - ((i (? number? k)) - (setter bv i k)) - ((i ($ <vector2> x y)) - (let ((offset (* i 2))) - (setter bv offset x) - (setter bv (1+ offset) y))) - ((i ($ <vector3> x y z)) - (let ((offset (* i 3))) - (setter bv offset x) - (setter bv (1+ offset) y) - (setter bv (+ offset 2) z))) - ((i ($ <vector4> x y z w)) - (let ((offset (* i 4))) - (setter bv offset x) - (setter bv (1+ offset) y) - (setter bv (+ offset 2) z) - (setter bv (+ offset 3) w))) - ((i (color? c)) - (let ((offset (* i 4))) - (setter bv offset (color-r c)) - (setter bv (1+ offset) (color-g c)) - (setter bv (+ offset 2) (color-b c)) - (setter bv (+ offset 3) (color-a c))))) + ((i (? number? k)) + (u32vector-set! bv i k)) + ((i (? vector2? v)) + (let ((offset (* i 2))) + (f32vector-set! bv offset (vector2-x v)) + (f32vector-set! bv (1+ offset) (vector2-y v)))) + ((i (? vector3? v)) + (let ((offset (* i 3))) + (f32vector-set! bv offset (vector3-x v)) + (f32vector-set! bv (1+ offset) (vector3-y v)) + (f32vector-set! bv (+ offset 2) (vector3-z v)))) + ((i (? vector4? v)) + (let ((offset (* i 4))) + (f32vector-set! bv offset (vector4-x v)) + (f32vector-set! bv (1+ offset) (vector4-y v)) + (f32vector-set! bv (+ offset 2) (vector4-z v)) + (f32vector-set! bv (+ offset 3) (vector4-w v)))) + ((i (color? c)) + (let ((offset (* i 4))) + (f32vector-set! bv offset (color-r c)) + (f32vector-set! bv (1+ offset) (color-g c)) + (f32vector-set! bv (+ offset 2) (color-b c)) + (f32vector-set! bv (+ offset 3) (color-a c))))) vertices) bv)) diff --git a/sly/window.scm b/sly/window.scm index 25b90fc..695cfd6 100644 --- a/sly/window.scm +++ b/sly/window.scm @@ -105,7 +105,8 @@ (init-window) (let ((res (window-resolution window))) (sdl2:set-window-title! %sdl-window (window-title window)) - (sdl2:set-window-size! %sdl-window (list (vx res) (vy res))) + (sdl2:set-window-size! %sdl-window + (map inexact->exact (list (vx res) (vy res)))) (sdl2:set-window-fullscreen! %sdl-window (window-fullscreen? window)) (sdl2:show-window! %sdl-window) (signal-set! window-size res))) |