diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | sly/font.scm | 1 | ||||
| -rw-r--r-- | sly/game.scm | 2 | ||||
| -rw-r--r-- | sly/joystick.scm | 8 | ||||
| -rw-r--r-- | sly/keyboard.scm | 10 | ||||
| -rw-r--r-- | sly/math/vector.scm | 159 | ||||
| -rw-r--r-- | sly/mesh.scm | 47 | ||||
| -rw-r--r-- | sly/mouse.scm | 7 | ||||
| -rw-r--r-- | sly/quaternion.scm | 12 | ||||
| -rw-r--r-- | sly/rect.scm | 26 | ||||
| -rw-r--r-- | sly/scene.scm | 3 | ||||
| -rw-r--r-- | sly/shader.scm | 2 | ||||
| -rw-r--r-- | sly/shape.scm | 97 | ||||
| -rw-r--r-- | sly/sprite.scm | 18 | ||||
| -rw-r--r-- | sly/texture.scm | 20 | ||||
| -rw-r--r-- | sly/transform.scm | 83 | ||||
| -rw-r--r-- | sly/transition.scm | 6 | ||||
| -rw-r--r-- | sly/vector.scm | 157 | ||||
| -rw-r--r-- | sly/window.scm | 11 | ||||
| -rw-r--r-- | tests/math/vector.scm | 128 |
21 files changed, 471 insertions, 329 deletions
@@ -1,6 +1,7 @@ *~ .#* *.go +*.log autom4te.cache/ build-aux/ Makefile diff --git a/Makefile.am b/Makefile.am index 14adfa5..84653e4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -36,6 +36,7 @@ SOURCES = \ sly/keyboard.scm \ sly/live-reload.scm \ sly/math.scm \ + sly/math/vector.scm \ sly/mesh.scm \ sly/mouse.scm \ sly/quaternion.scm \ @@ -50,7 +51,6 @@ SOURCES = \ sly/tileset.scm \ sly/transform.scm \ sly/transition.scm \ - sly/vector.scm \ sly/window.scm \ sly/joystick.scm \ $(WRAPPER_SOURCES) diff --git a/sly/font.scm b/sly/font.scm index 51ae329..3a3a5f8 100644 --- a/sly/font.scm +++ b/sly/font.scm @@ -35,7 +35,6 @@ #:use-module (sly shader) #:use-module (sly sprite) #:use-module (sly texture) - #:use-module (sly vector) #:export (enable-fonts load-font load-default-font diff --git a/sly/game.scm b/sly/game.scm index 729c586..efc092b 100644 --- a/sly/game.scm +++ b/sly/game.scm @@ -34,7 +34,7 @@ #:use-module (sly math) #:use-module (sly scene) #:use-module (sly signal) - #:use-module (sly vector) + #:use-module (sly math vector) #:use-module (sly window) #:export (draw-hook after-game-loop-error-hook diff --git a/sly/joystick.scm b/sly/joystick.scm index c6b8189..b94a883 100644 --- a/sly/joystick.scm +++ b/sly/joystick.scm @@ -25,7 +25,7 @@ #:use-module ((sdl sdl) #:prefix SDL:) #:use-module (sly event) #:use-module (sly signal) - #:use-module (sly vector) + #:use-module (sly math vector) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:re-export ((SDL:joystick-name . joystick-name) @@ -126,7 +126,7 @@ values range from [-32768,32767]." (define (make-directional-signal-raw idx x-axis y-axis) "Create a signal for a Dpad or Analog stick with X and Y axes; values range from [-32768,32767]." - (signal-map vector + (signal-map vector2 (axis-value-raw idx x-axis) (axis-value-raw idx y-axis))) @@ -148,8 +148,8 @@ values are scaled to [-1,1]." "Create a signal for a Dpad or Analog stick with X and Y axes; values are scaled to [-1,1]." (signal-map (lambda (v) - (vector (axis-scale (vx v)) - (axis-scale (vy v)))) + (vector2 (axis-scale (vx v)) + (axis-scale (vy v)))) (make-directional-signal-raw idx x-axis y-axis))) (define-signal button-last-down diff --git a/sly/keyboard.scm b/sly/keyboard.scm index 65ad940..b6db9c2 100644 --- a/sly/keyboard.scm +++ b/sly/keyboard.scm @@ -25,7 +25,7 @@ #:use-module ((sdl sdl) #:prefix SDL:) #:use-module (sly event) #:use-module (sly signal) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (key-press-hook key-release-hook key-last-down @@ -75,10 +75,10 @@ KEY is pressed or #f otherwise." (define (key-directions up down left right) (signal-map (lambda (up? down? left? right?) - (vector (+ (if left? -1 0) - (if right? 1 0)) - (+ (if up? -1 0) - (if down? 1 0)))) + (vector2 (+ (if left? -1 0) + (if right? 1 0)) + (+ (if up? -1 0) + (if down? 1 0)))) (key-down? up) (key-down? down) (key-down? left) diff --git a/sly/math/vector.scm b/sly/math/vector.scm new file mode 100644 index 0000000..d2554fe --- /dev/null +++ b/sly/math/vector.scm @@ -0,0 +1,159 @@ +;;; Sly +;;; Copyright (C) 2014 David Thompson <davet@gnu.org> +;;; +;;; This program 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. +;;; +;;; This program 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: +;; +;; Vector math. +;; +;;; Code: + +(define-module (sly math vector) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (sly math) + #:export (vector2 + vector3 + vector4 + vector2? vector3? vector4? + vx vy vz vw + v+ v- v* vdot vcross + magnitude normalize)) + +(define-record-type <vector2> + (vector2 x y) + vector2? + (x vector2-x) + (y vector2-y)) + +(define-record-type <vector3> + (vector3 x y z) + vector3? + (x vector3-x) + (y vector3-y) + (z vector3-z)) + +(define-record-type <vector4> + (vector4 x y z w) + vector4? + (x vector4-x) + (y vector4-y) + (z vector4-z) + (w vector4-w)) + +(define vx + (match-lambda + (($ <vector2> x _) + x) + (($ <vector3> x _ _) + x) + (($ <vector4> x _ _ _) + x))) + +(define vy + (match-lambda + (($ <vector2> _ y) + y) + (($ <vector3> _ y _) + y) + (($ <vector4> _ y _ _) + y))) + +(define vz + (match-lambda + (($ <vector3> _ _ z) + z) + (($ <vector4> _ _ z _) + z))) + +(define vw vector4-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))))) + +(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*)))) + +(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)))))) + +(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)))))) + +(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))))))) diff --git a/sly/mesh.scm b/sly/mesh.scm index 1d7d89c..65154a7 100644 --- a/sly/mesh.scm +++ b/sly/mesh.scm @@ -34,7 +34,7 @@ #:use-module (sly color) #:use-module (sly shader) #:use-module (sly texture) - #:use-module (sly vector) + #:use-module (sly math vector) #:use-module (sly signal) #:export (make-mesh mesh? @@ -78,27 +78,30 @@ (attribute-size elem))))) (setter (if index? u32vector-set! f32vector-set!))) (vector-for-each - (cond - ((number? elem) - (lambda (i k) - (setter bv i k))) - ((or (vector2? elem) - (vector3? elem) - (vector4? elem)) - (let ((dimensions (vector-length elem))) - (lambda (i v) - (let ((offset (* i dimensions))) - (vector-for-each - (lambda (j n) - (setter bv (+ offset j) n)) - v))))) - ((color? elem) - (lambda (i 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)))))) + (match-lambda* + ((i (? number? k)) + (setter bv i k)) + ((i (? vector2? v)) + (let ((offset (* i 2))) + (setter bv offset (vx v)) + (setter bv (1+ offset) (vy v)))) + ((i (? vector3? v)) + (let ((offset (* i 3))) + (setter bv offset (vx v)) + (setter bv (1+ offset) (vy v)) + (setter bv (+ offset 2) (vz v)))) + ((i (? vector4? v)) + (let ((offset (* i 4))) + (setter bv offset (vx v)) + (setter bv (1+ offset) (vy v)) + (setter bv (+ offset 2) (vz v)) + (setter bv (+ offset 3) (vw v)))) + ((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))))) vertices) bv)) diff --git a/sly/mouse.scm b/sly/mouse.scm index 6ac56d2..1b4885a 100644 --- a/sly/mouse.scm +++ b/sly/mouse.scm @@ -25,7 +25,7 @@ #:use-module ((sdl sdl) #:prefix SDL:) #:use-module (sly event) #:use-module (sly signal) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (mouse-move-hook mouse-press-hook mouse-click-hook @@ -47,9 +47,8 @@ (define-signal mouse-position (hook->signal mouse-move-hook - #(0 0) - (lambda (x y) - (vector x y)))) + (vector2 0 0) + vector2)) (define-signal mouse-x (signal-map vx mouse-position)) (define-signal mouse-y (signal-map vy mouse-position)) diff --git a/sly/quaternion.scm b/sly/quaternion.scm index 68dd660..9bf9427 100644 --- a/sly/quaternion.scm +++ b/sly/quaternion.scm @@ -27,7 +27,7 @@ #:use-module (srfi srfi-9) #:use-module (sly math) #:use-module (sly transform) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (make-quaternion quaternion? quaternion-w quaternion-x quaternion-y quaternion-z @@ -97,20 +97,20 @@ AXIS must be a 3D vector." (let* ((cos (cos (/ theta 2))) (sin (sin (/ theta 2)))) (match axis - (#(x y z) - (make-quaternion cos (* x sin) (* y sin) (* z sin)))))) + ((? vector3? v) + (make-quaternion cos (* (vx v) sin) (* (vy v) sin) (* (vz v) sin)))))) (define (quaternion->vector q) "Convert the quaternion Q into a 4D vector." (match q (($ <quaternion> w x y z) - (vector w x y z)))) + (vector4 w x y z)))) (define (vector->quaternion v) "Convert the 4D vector V into a quaternion." (match v - (#(w x y z) - (make-quaternion w x y z)))) + ((? vector4? v) + (make-quaternion (vx v) (vy v) (vz v) (vw v))))) (define (quaternion->transform q) "Convert the quaternion Q into a 4x4 transformation matrix." diff --git a/sly/rect.scm b/sly/rect.scm index 9b61299..fbe4654 100644 --- a/sly/rect.scm +++ b/sly/rect.scm @@ -24,7 +24,7 @@ (define-module (sly rect) #:use-module (srfi srfi-9) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (<rect> make-rect null-rect @@ -93,22 +93,22 @@ (define (rect-position rect) "Return the top-left corner of RECT as a vector." - (vector (rect-x rect) - (rect-y rect))) + (vector2 (rect-x rect) + (rect-y rect))) (define rect-top-left rect-position) (define (rect-top-right rect) - (vector (rect-right rect) - (rect-top rect))) + (vector2 (rect-right rect) + (rect-top rect))) (define (rect-bottom-left rect) - (vector (rect-left rect) - (rect-bottom rect))) + (vector2 (rect-left rect) + (rect-bottom rect))) (define (rect-bottom-right rect) - (vector (rect-right rect) - (rect-bottom rect))) + (vector2 (rect-right rect) + (rect-bottom rect))) (define (rect-center-x rect) (+ (rect-x rect) (rect-half-width rect))) @@ -117,8 +117,8 @@ (+ (rect-y rect) (rect-half-height rect))) (define (rect-center rect) - (vector (rect-center-x rect) - (rect-center-y rect))) + (vector2 (rect-center-x rect) + (rect-center-y rect))) (define (rect-half-width rect) (/ (rect-width rect) 2)) @@ -128,8 +128,8 @@ (define (rect-size rect) "Return the size of RECT as a vector." - (vector (rect-width rect) - (rect-height rect))) + (vector2 (rect-width rect) + (rect-height rect))) (define (%rect-move rect x y) "Move RECT by the offset X, Y." diff --git a/sly/scene.scm b/sly/scene.scm index bb748ca..a8b90b4 100644 --- a/sly/scene.scm +++ b/sly/scene.scm @@ -30,6 +30,7 @@ #:use-module (sly signal) #:use-module (sly transform) #:use-module (sly transition) + #:use-module (sly math vector) #:export (scene-node make-scene-node scene-node? @@ -51,7 +52,7 @@ (children scene-node-children)) (define* (make-scene-node #:optional #:key - (position #(0 0)) + (position (vector2 0 0)) (scale 1) (rotation identity-quaternion) (uniforms '()) diff --git a/sly/shader.scm b/sly/shader.scm index f12e0bb..2973010 100644 --- a/sly/shader.scm +++ b/sly/shader.scm @@ -27,7 +27,7 @@ #:use-module (gl low-level) #:use-module (sly helpers) #:use-module (sly transform) - #:use-module (sly vector) + #:use-module (sly math vector) #:use-module (sly color) #:use-module (sly config) #:use-module (sly wrappers gl) diff --git a/sly/shape.scm b/sly/shape.scm index 8ffe185..8283875 100644 --- a/sly/shape.scm +++ b/sly/shape.scm @@ -26,6 +26,7 @@ #:use-module (sly mesh) #:use-module (sly shader) #:use-module (sly texture) + #:use-module (sly math vector) #:export (make-cube)) (define* (make-cube size #:optional #:key (texture #f) @@ -49,35 +50,35 @@ 20 22 23 20 21 22) #:data `(("position" ,(vector ;; Front - (vector (- half-size) (- half-size) (- half-size)) - (vector half-size (- half-size) (- half-size)) - (vector half-size half-size (- half-size)) - (vector (- half-size) half-size (- half-size)) + (vector3 (- half-size) (- half-size) (- half-size)) + (vector3 half-size (- half-size) (- half-size)) + (vector3 half-size half-size (- half-size)) + (vector3 (- half-size) half-size (- half-size)) ;; Back - (vector (- half-size) (- half-size) half-size) - (vector half-size (- half-size) half-size) - (vector half-size half-size half-size) - (vector (- half-size) half-size half-size) + (vector3 (- half-size) (- half-size) half-size) + (vector3 half-size (- half-size) half-size) + (vector3 half-size half-size half-size) + (vector3 (- half-size) half-size half-size) ;; Top - (vector (- half-size) half-size (- half-size)) - (vector half-size half-size (- half-size)) - (vector half-size half-size half-size) - (vector (- half-size) half-size half-size) + (vector3 (- half-size) half-size (- half-size)) + (vector3 half-size half-size (- half-size)) + (vector3 half-size half-size half-size) + (vector3 (- half-size) half-size half-size) ;; Bottom - (vector (- half-size) (- half-size) (- half-size)) - (vector half-size (- half-size) (- half-size)) - (vector half-size (- half-size) half-size) - (vector (- half-size) (- half-size) half-size) + (vector3 (- half-size) (- half-size) (- half-size)) + (vector3 half-size (- half-size) (- half-size)) + (vector3 half-size (- half-size) half-size) + (vector3 (- half-size) (- half-size) half-size) ;; Left - (vector (- half-size) (- half-size) (- half-size)) - (vector (- half-size) half-size (- half-size)) - (vector (- half-size) half-size half-size) - (vector (- half-size) (- half-size) half-size) + (vector3 (- half-size) (- half-size) (- half-size)) + (vector3 (- half-size) half-size (- half-size)) + (vector3 (- half-size) half-size half-size) + (vector3 (- half-size) (- half-size) half-size) ;; Right - (vector half-size (- half-size) (- half-size)) - (vector half-size half-size (- half-size)) - (vector half-size half-size half-size) - (vector half-size (- half-size) half-size))) + (vector3 half-size (- half-size) (- half-size)) + (vector3 half-size half-size (- half-size)) + (vector3 half-size half-size half-size) + (vector3 half-size (- half-size) half-size))) ,@(if texture (let ((s1 (texture-s1 texture)) (t1 (texture-t1 texture)) @@ -86,33 +87,33 @@ `(("tex" ,(vector ;; Front - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2) ;; Back - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2) ;; Top - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2) ;; Bottom - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2) ;; Left - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2) ;; Right - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2))))) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2))))) '()))))) diff --git a/sly/sprite.scm b/sly/sprite.scm index e717133..5b4ee81 100644 --- a/sly/sprite.scm +++ b/sly/sprite.scm @@ -37,7 +37,7 @@ #:use-module (sly shader) #:use-module (sly signal) #:use-module (sly texture) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (make-sprite load-sprite make-animated-sprite)) @@ -67,15 +67,15 @@ custom SHADER can be specified." #:texture texture #:indices #(0 3 2 0 2 1) #:data `(("position" ,(vector - (vector x1 y1 0) - (vector x2 y1 0) - (vector x2 y2 0) - (vector x1 y2 0))) + (vector3 x1 y1 0) + (vector3 x2 y1 0) + (vector3 x2 y2 0) + (vector3 x1 y2 0))) ("tex" ,(vector - (vector s1 t1) - (vector s2 t1) - (vector s2 t2) - (vector s1 t2))))))) + (vector2 s1 t1) + (vector2 s2 t1) + (vector2 s2 t2) + (vector2 s1 t2))))))) (define* (load-sprite file-name #:optional #:key (shader (load-default-shader)) (anchor 'center) (color white)) diff --git a/sly/texture.scm b/sly/texture.scm index 3a74c2c..3d62f1f 100644 --- a/sly/texture.scm +++ b/sly/texture.scm @@ -30,7 +30,7 @@ #:use-module (gl contrib packed-struct) #:use-module (sly color) #:use-module (sly helpers) - #:use-module (sly vector) + #:use-module (sly math vector) #:use-module (sly wrappers gl) #:use-module (sly wrappers freeimage) #:export (make-texture @@ -175,23 +175,23 @@ vector to be returned." (let ((w (texture-width texture)) (h (texture-height texture))) (match anchor - (#(x y) + ((? vector2? anchor) anchor) ('center - (vector (/ w 2) - (/ h 2))) + (vector2 (/ w 2) + (/ h 2))) ('top-left - #(0 0)) + (vector2 0 0)) ('top-right - (vector w 0)) + (vector2 w 0)) ('bottom-left - (vector 0 h)) + (vector2 0 h)) ('bottom-right - (vector w h)) + (vector2 w h)) ('top-center - (vector (/ w 2) 0)) + (vector2 (/ w 2) 0)) ('bottom-center - (vector (/ w 2) h)) + (vector2 (/ w 2) h)) (_ (error "Invalid anchor type: " anchor))))) ;;; diff --git a/sly/transform.scm b/sly/transform.scm index 905edda..3b82c2e 100644 --- a/sly/transform.scm +++ b/sly/transform.scm @@ -27,7 +27,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-42) #:use-module (sly math) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (make-transform null-transform identity-transform transform? transform-matrix transpose transform-vector2 @@ -92,12 +92,12 @@ column-major format." (let ((m (transform-matrix transform)) (x (vx v)) (y (vy v))) - (vector (+ (* x (array-ref m 0 0)) - (* y (array-ref m 0 1)) - (array-ref m 0 3)) - (+ (* x (array-ref m 1 0)) - (* y (array-ref m 1 1)) - (array-ref m 1 3))))) + (vector2 (+ (* x (array-ref m 0 0)) + (* y (array-ref m 0 1)) + (array-ref m 0 3)) + (+ (* x (array-ref m 1 0)) + (* y (array-ref m 1 1)) + (array-ref m 1 3))))) (define (transform+ . transforms) "Return the sum of all given transformation matrices. Return @@ -130,41 +130,48 @@ identity-transform if called without any arguments." (%make-transform m3))) (reduce mul identity-transform transforms)) -(define (translate v) - "Return a new transform that translates by the 2D or 3D vector V." - (match v - (#(x y) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y 0 1)) - (#(x y z) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y z 1)) - (_ (error "Invalid translation vector: " v)))) - -(define (scale v) - "Return a new transform that scales by the 2D vector, 3D vector, or -scalar V." - (match v +(define translate + (match-lambda + ((? vector2? v) + (let ((x (vx v)) + (y (vy v))) + (make-transform 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y 0 1))) + ((? vector3? v) + (let ((x (vx v)) + (y (vy v)) + (z (vz 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 + (match-lambda ((? number? v) (make-transform v 0 0 0 0 v 0 0 0 0 v 0 0 0 0 1)) - (#(x y) - (make-transform x 0 0 0 - 0 y 0 0 - 0 0 1 0 - 0 0 0 1)) - (#(x y z) - (make-transform x 0 0 0 - 0 y 0 0 - 0 0 z 0 - 0 0 0 1)) - (_ (error "Invalid scaling vector: " v)))) + ((? vector2? v) + (let ((x (vx v)) + (y (vy v))) + (make-transform x 0 0 0 + 0 y 0 0 + 0 0 1 0 + 0 0 0 1))) + ((? vector3? v) + (let ((x (vx v)) + (y (vy v)) + (z (vz 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) "Return a new transform that rotates the X axis by ANGLE radians." @@ -210,7 +217,7 @@ depth clipping plane NEAR and FAR." 0 0 (/ (+ far near) (- near far)) -1 0 0 (/ (* 2 far near) (- near far)) 0))) -(define* (look-at eye center #:optional (up #(0 1 0))) +(define* (look-at eye center #:optional (up (vector3 0 1 0))) (let* ((forward (normalize (v- center eye))) (side (normalize (vcross forward up))) (up (normalize (vcross side forward)))) diff --git a/sly/transition.scm b/sly/transition.scm index 68ec18e..c923980 100644 --- a/sly/transition.scm +++ b/sly/transition.scm @@ -28,7 +28,7 @@ #:use-module (sly math) #:use-module (sly quaternion) #:use-module (sly signal) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (ease-linear ease-in-sine ease-out-sine ease-in-out-sine ease-in-quad ease-out-quad ease-in-out-quad @@ -122,7 +122,9 @@ range [0, 1]." (cond ((both? number?) number-interpolate) - ((both? vector?) + ((or (both? vector2?) + (both? vector3?) + (both? vector4?)) vector-interpolate) ((both? color?) color-interpolate) diff --git a/sly/vector.scm b/sly/vector.scm deleted file mode 100644 index a41176e..0000000 --- a/sly/vector.scm +++ /dev/null @@ -1,157 +0,0 @@ -;;; Sly -;;; Copyright (C) 2014 David Thompson <davet@gnu.org> -;;; -;;; This program 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. -;;; -;;; This program 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: -;; -;; Vector math. -;; -;;; Code: - -(define-module (sly vector) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-43) - #:export (vector2? vector3? vector4? - vector-length= v= - vx vy vz vw - polar-vector - v+ v- v* vdot vcross - magnitude normalize)) - -(define (vector-dimensionality? v d) - (and (vector? v) (= (vector-length v) d))) - -(define (vector2? v) - "Return #t if V is a 2D vector, #f otherwise." - (vector-dimensionality? v 2)) - -(define (vector3? v) - "Return #t if V is a 3D vector, #f otherwise." - (vector-dimensionality? v 3)) - -(define (vector4? v) - "Return #t if V is a 4D vector, #f otherwise." - (vector-dimensionality? v 4)) - -(define (vector-length= v1 v2) - "Return #t if V1 and V2 are of the same dimensionality, #f -otherwise." - (= (vector-length v1) - (vector-length v2))) - -(define (v= . vectors) - "Return #t if all arguments are equivalent vectors, #f otherwise." - (apply vector= = vectors)) - -(define (vx v) - "Return the first component of the vector V." - (vector-ref v 0)) - -(define (vy v) - "Return the second component of the vector V." - (vector-ref v 1)) - -(define (vz v) - "Return the third component of the vector V." - (vector-ref v 2)) - -(define (vw v) - "Return the fourth component of the vector V." - (vector-ref v 3)) - -(define (polar-vector r theta) - "Create a 2D cartesian vector from the polar coordinates (R, -THETA)." - (vector (* r (cos theta)) - (* r (sin theta)))) - -(define (dimension-error v1 v2) - (error "Vector dimensionality mismatch: " v1 v2)) - -(define* (vreduce op vectors #:optional (reduce reduce)) - (reduce (lambda args - (match args - (((? number? k) (? number? l)) - (op k l)) - (((? number? k) (? vector? v)) - (vector-map (lambda (i n) (op k n)) v)) - (((? vector? v) (? number? k)) - (vector-map (lambda (i n) (op n k)) v)) - (((? vector? v1) (? vector? v2)) - (if (vector-length= v1 v2) - (vector-map (lambda (i a b) - (op a b)) - v1 v2) - (dimension-error v1 v2))))) - 0 vectors)) - -(define (v+ . vectors) - "Return the sum of all vectors. All vectors must be of the same -dimensionality. Scalar values can be used to add to all components of -the resulting vector." - (vreduce + vectors)) - -(define v- - (case-lambda - "Return the difference of all vectors. All vectors must be of the -same dimensionality. Scalar values can be used to subtract from all -components of the resulting vector." - ((v) (v- 0 v)) - ((v . rest) - (vreduce - (cons v rest) reduce-right)))) - -(define (v* . vectors) - "Return the product of all VECTORS. All vectors must be of the same -dimensionality. Scalar values can be used to multiply all components -of the resulting vector." - (vreduce * vectors)) - -(define (vdot v1 v2) - "Return the dot product of the vectors V1 and V2. V1 and V2 must be -of the same dimensionality." - (if (vector-length= v1 v2) - (vector-fold (lambda (i memo a b) - (+ memo (* a b))) - 0 v1 v2) - (dimension-error v1 v2))) - -(define (vcross v1 v2) - "Return the cross product of the vectors V1 and V2. V1 and V2 must -both be 3D vectors." - (match (list v1 v2) - ((#(x1 y1 z1) #(x2 y2 z2)) - (vector (- (* y1 z2) (* z1 y2)) - (- (* z1 x2) (* x1 z2)) - (- (* x1 y2) (* y1 x2)))) - (_ (error "Expected 3D vectors: " v1 v2)))) - -(define (magnitude v) - "Return the magnitude of the vector V." - (sqrt - (vector-fold (lambda (i memo n) - (+ memo (expt n 2))) - 0 v))) - -(define (normalize v) - "Normalize the vector V." - (let ((m (magnitude v))) - (if (zero? m) - v - (vector-map (lambda (i n) - (/ n m)) - v)))) diff --git a/sly/window.scm b/sly/window.scm index 0e400f5..10aee4d 100644 --- a/sly/window.scm +++ b/sly/window.scm @@ -28,7 +28,7 @@ #:use-module (sly event) #:use-module (sly signal) #:use-module (sly transform) - #:use-module (sly vector) + #:use-module (sly math vector) #:export (make-window window? window-title @@ -53,7 +53,7 @@ (define* (make-window #:optional #:key (title "Sly Window") - (resolution #(640 480)) + (resolution (vector2 640 480)) (fullscreen? #f)) (%make-window title resolution fullscreen?)) @@ -70,9 +70,8 @@ (define-signal window-size (hook->signal window-resize-hook - #(0 0) - (lambda (width height) - (vector width height)))) + (vector2 0 0) + vector2)) (define-signal window-width (signal-map vx window-size)) (define-signal window-height (signal-map vy window-size)) @@ -95,7 +94,7 @@ (let ((flags (if (window-fullscreen? window) '(opengl fullscreen) 'opengl)) (width (vx (window-resolution window))) (height (vy (window-resolution window)))) - (signal-set! window-size (vector width height)) + (signal-set! window-size (vector2 width height)) ;; Initialize everything (SDL:enable-unicode #t) (SDL:init 'everything) diff --git a/tests/math/vector.scm b/tests/math/vector.scm new file mode 100644 index 0000000..7b5b156 --- /dev/null +++ b/tests/math/vector.scm @@ -0,0 +1,128 @@ +;;; Sly +;;; Copyright (C) 2014 David Thompson <davet@gnu.org> +;;; +;;; This program 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. +;;; +;;; This program 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 (test-vector) + #:use-module (srfi srfi-64) + #:use-module (sly math vector)) + +(test-begin "vector") + +(test-group "vx" + (test-equal 1 (vx (vector2 1 2))) + (test-equal 1 (vx (vector3 1 2 3))) + (test-equal 1 (vx (vector4 1 2 3 4)))) + +(test-group "vy" + (test-equal 2 (vy (vector2 1 2))) + (test-equal 2 (vy (vector3 1 2 3))) + (test-equal 2 (vy (vector4 1 2 3 4)))) + +(test-group "vz" + (test-equal 3 (vz (vector3 1 2 3))) + (test-equal 3 (vz (vector4 1 2 3 4)))) + +(test-group "vw" + (test-equal 4 (vw (vector4 1 2 3 4)))) + +(test-group "v+" + (test-equal 0 (v+)) + (test-equal (vector2 1 1) (v+ (vector2 1 1))) + (test-equal (vector2 9 12) + (v+ (vector2 1 2) (vector2 3 4) (vector2 5 6))) + (test-equal (vector2 8 10) + (v+ (vector2 1 2) 3 (vector2 4 5))) + (test-equal (vector3 12 15 18) + (v+ (vector3 1 2 3) (vector3 4 5 6) (vector3 7 8 9))) + (test-equal (vector3 10 12 14) + (v+ (vector3 1 2 3) 4 (vector3 5 6 7))) + (test-equal (vector4 15 18 21 24) + (v+ (vector4 1 2 3 4) (vector4 5 6 7 8) (vector4 9 10 11 12))) + (test-equal (vector4 12 14 16 18) + (v+ (vector4 1 2 3 4) 5 (vector4 6 7 8 9)))) + +(test-group "v+" + (test-equal 0 (v+)) + (test-equal (vector2 1 1) (v+ (vector2 1 1))) + (test-equal (vector2 9 12) + (v+ (vector2 1 2) (vector2 3 4) (vector2 5 6))) + (test-equal (vector2 8 10) + (v+ (vector2 1 2) 3 (vector2 4 5))) + (test-equal (vector3 12 15 18) + (v+ (vector3 1 2 3) (vector3 4 5 6) (vector3 7 8 9))) + (test-equal (vector3 10 12 14) + (v+ (vector3 1 2 3) 4 (vector3 5 6 7))) + (test-equal (vector4 15 18 21 24) + (v+ (vector4 1 2 3 4) (vector4 5 6 7 8) (vector4 9 10 11 12))) + (test-equal (vector4 12 14 16 18) + (v+ (vector4 1 2 3 4) 5 (vector4 6 7 8 9)))) + +(test-group "v-" + (test-equal (vector2 -1 -1) (v- (vector2 1 1))) + (test-equal (vector2 0 1) + (v- (vector2 6 5) (vector2 4 3) (vector2 2 1))) + (test-equal (vector2 0 0) + (v- (vector2 5 4) 3 (vector2 2 1))) + (test-equal (vector3 0 1 2) + (v- (vector3 9 8 7) (vector3 6 5 4) (vector3 3 2 1))) + (test-equal (vector3 0 0 0) + (v- (vector3 7 6 5) 4 (vector3 3 2 1))) + (test-equal (vector4 0 1 2 3) + (v- (vector4 12 11 10 9) (vector4 8 7 6 5) (vector4 4 3 2 1))) + (test-equal (vector4 0 0 0 0) + (v- (vector4 9 8 7 6) 5 (vector4 4 3 2 1)))) + +(test-group "v*" + (test-equal 1 (v*)) + (test-equal (vector2 1 1) (v* (vector2 1 1))) + (test-equal (vector2 15 48) + (v* (vector2 1 2) (vector2 3 4) (vector2 5 6))) + (test-equal (vector2 12 30) + (v* (vector2 1 2) 3 (vector2 4 5))) + (test-equal (vector3 28 80 162) + (v* (vector3 1 2 3) (vector3 4 5 6) (vector3 7 8 9))) + (test-equal (vector3 20 48 84) + (v* (vector3 1 2 3) 4 (vector3 5 6 7))) + (test-equal (vector4 45 120 231 384) + (v* (vector4 1 2 3 4) (vector4 5 6 7 8) (vector4 9 10 11 12))) + (test-equal (vector4 30 70 120 180) + (v* (vector4 1 2 3 4) 5 (vector4 6 7 8 9)))) + +(test-group "vdot" + (test-equal 11 (vdot (vector2 1 2) (vector2 3 4))) + (test-equal 32 (vdot (vector3 1 2 3) (vector3 4 5 6))) + (test-equal 70 (vdot (vector4 1 2 3 4) (vector4 5 6 7 8)))) + +(test-group "vcross" + (test-equal (vector3 -3 6 -3) + (vcross (vector3 2 3 4) (vector3 5 6 7)))) + +(test-group "magnitude" + (test-equal 5 (magnitude (vector2 3 4))) + (test-equal 3 (magnitude (vector3 1 2 2))) + (test-equal 4 (magnitude (vector4 2 2 2 2)))) + +(test-group "normalize" + (test-equal (vector2 0 0) (normalize (vector2 0 0))) + (test-equal (vector3 0 0 0) (normalize (vector3 0 0 0))) + (test-equal (vector4 0 0 0 0) (normalize (vector4 0 0 0 0))) + (test-equal (vector2 3/5 4/5) (normalize (vector2 3 4))) + (test-equal (vector3 1/3 2/3 2/3) (normalize (vector3 1 2 2))) + (test-equal (vector4 1/2 1/2 1/2 1/2) (normalize (vector4 2 2 2 2)))) + +(test-end "vector") + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |