summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2014-10-01 20:52:09 -0400
committerDavid Thompson <dthompson2@worcester.edu>2014-10-01 20:52:09 -0400
commit0735ffb5a06e71a27b215ab342522557bb51b7d1 (patch)
tree6d5f269030dfbf990ba1027ad3138538123edef7
parent5e5920afad058cbb7a179b2be92271f1603da9e1 (diff)
Rewrite vector math module.
* .gitignore: Ignore '*.log' files. * sly/vector.scm: Delete file. * sly/math/vector.scm: New file. * tests/math/vector.scm: New file. * Makefile.am: Add new file and remove the old one. * sly/font.scm: Remove import. * sly/game.scm: Change import. * sly/joystick.scm (make-directional-signal-raw, make-directional): Use 'vector2'. * sly/keyboard.scm (key-directions): Use 'vector2'. * sly/mesh.scm (vertices-bytevector): Use new vector procedures. * sly/mouse.scm (mouse-position): Use 'vector2'. * sly/quaternion.scm (axis-angle->quaternion, quaternion->vector, vector->quaternion): Use new vector procedures. * sly/rect.scm (rect-position, rect-top-right, rect-bottom-left, rect-bottom-right, rect-center, rect-size): Use 'vector2'. * sly/scene.scm (make-scene-node): Use 'vector2'. * sly/shader.scm: Change import. * sly/shape.scm (make-cube): Use new vector procedures. * sly/sprite.scm (make-sprite): Use new vector procedures. * sly/texture.scm (anchor-texture): Use 'vector2'. * sly/transform.scm (transform-vector2): Use 'vector2'. (translate, scale): Use new vector procedures. * sly/transition.scm (guess-interpolator): Use new vector procedures. * sly/window.scm (make-window, window-size, open-window): Use 'vector2'.
-rw-r--r--.gitignore1
-rw-r--r--Makefile.am2
-rw-r--r--sly/font.scm1
-rw-r--r--sly/game.scm2
-rw-r--r--sly/joystick.scm8
-rw-r--r--sly/keyboard.scm10
-rw-r--r--sly/math/vector.scm159
-rw-r--r--sly/mesh.scm47
-rw-r--r--sly/mouse.scm7
-rw-r--r--sly/quaternion.scm12
-rw-r--r--sly/rect.scm26
-rw-r--r--sly/scene.scm3
-rw-r--r--sly/shader.scm2
-rw-r--r--sly/shape.scm97
-rw-r--r--sly/sprite.scm18
-rw-r--r--sly/texture.scm20
-rw-r--r--sly/transform.scm83
-rw-r--r--sly/transition.scm6
-rw-r--r--sly/vector.scm157
-rw-r--r--sly/window.scm11
-rw-r--r--tests/math/vector.scm128
21 files changed, 471 insertions, 329 deletions
diff --git a/.gitignore b/.gitignore
index e0df7c2..f5c9fba 100644
--- a/.gitignore
+++ b/.gitignore
@@ -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))