a6179108fedc71ffc236418800413a8bbafdafeb
[chickadee.git] / chickadee / math / vector.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Chickadee is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published
6 ;;; by the Free Software Foundation, either version 3 of the License,
7 ;;; or (at your option) any later version.
8 ;;;
9 ;;; Chickadee is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 (define-module (chickadee math vector)
19 #:use-module (ice-9 format)
20 #:use-module (rnrs bytevectors)
21 #:use-module (srfi srfi-9)
22 #:use-module (srfi srfi-9 gnu)
23 #:use-module (system foreign)
24 #:use-module (chickadee math)
25 #:export (vec2
26 vec2/polar
27 vec2?
28 vec2->pointer
29 vec2-copy
30 vec2-copy!
31 vec2-x
32 vec2-y
33 vec2-magnitude
34 vec2-dot-product
35 vec2-normalize
36 set-vec2-x!
37 set-vec2-y!
38 vec2-normalize!
39 vec2-mult!
40 vec2-add!
41 vec2-sub!
42 vec2*
43 vec2+
44 vec2-
45 vec3
46 vec3?
47 vec3->pointer
48 vec3-copy
49 vec3-copy!
50 vec3-x
51 vec3-y
52 vec3-z
53 vec3-magnitude
54 vec3-dot-product
55 vec3-normalize
56 set-vec3-x!
57 set-vec3-y!
58 vec3-normalize!
59 vec3-mult!
60 vec3-add!
61 vec3-sub!))
62
63 (define-record-type <vec2>
64 (wrap-vec2 bv pointer)
65 vec2?
66 (bv unwrap-vec2)
67 (pointer vec2-pointer set-vec2-pointer!))
68
69 (define-record-type <vec3>
70 (wrap-vec3 bv pointer)
71 vec3?
72 (bv unwrap-vec3)
73 (pointer vec3-pointer set-vec3-pointer!))
74
75 (define (vec2->pointer v)
76 "Return a foreign pointer to V."
77 ;; Create foreign pointer lazily.
78 (or (vec2-pointer v)
79 (let ((pointer (bytevector->pointer (unwrap-vec2 v))))
80 (set-vec2-pointer! v pointer)
81 pointer)))
82
83 (define (vec3->pointer v)
84 "Return a foreign pointer to V."
85 ;; Create foreign pointer lazily.
86 (or (vec3-pointer v)
87 (let ((pointer (bytevector->pointer (unwrap-vec3 v))))
88 (set-vec3-pointer! v pointer)
89 pointer)))
90
91 (define (make-null-vec2)
92 (wrap-vec2 (make-f32vector 2) #f))
93
94 (define (make-null-vec3)
95 (wrap-vec3 (make-f32vector 3) #f))
96
97 (define-syntax-rule (with-new-vec2 name body ...)
98 (let ((name (make-null-vec2))) body ... name))
99
100 (define-syntax-rule (with-new-vec3 name body ...)
101 (let ((name (make-null-vec3))) body ... name))
102
103 (define-inlinable (vec2-ref v i)
104 (f32vector-ref (unwrap-vec2 v) i))
105
106 (define-inlinable (vec3-ref v i)
107 (f32vector-ref (unwrap-vec3 v) i))
108
109 (define-inlinable (vec2-set! v i x)
110 (f32vector-set! (unwrap-vec2 v) i x))
111
112 (define-inlinable (vec3-set! v i x)
113 (f32vector-set! (unwrap-vec3 v) i x))
114
115 (define-inlinable (vec2 x y)
116 "Return a new vec2 with coordinates (X, Y)."
117 (with-new-vec2 v
118 (vec2-set! v 0 x)
119 (vec2-set! v 1 y)))
120
121 (define-inlinable (vec3 x y z)
122 (with-new-vec3 v
123 (vec3-set! v 0 x)
124 (vec3-set! v 1 y)
125 (vec3-set! v 2 z)))
126
127 (define-inlinable (vec2/polar r theta)
128 "Return a new vec2 containing the Cartesian representation of the
129 polar coordinate (R, THETA)."
130 (vec2 (* r (cos theta)) (* r (sin theta))))
131
132 (define-inlinable (vec2-x v)
133 "Return the x coordinate of the vec2 V."
134 (vec2-ref v 0))
135
136 (define-inlinable (vec3-x v)
137 "Return the x coordinate of the vec3 V."
138 (vec3-ref v 0))
139
140 (define-inlinable (vec2-y v)
141 "Return the y coordinate of the vec2 V."
142 (vec2-ref v 1))
143
144 (define-inlinable (vec3-y v)
145 "Return the y coordinate of the vec3 V."
146 (vec3-ref v 1))
147
148 (define-inlinable (vec3-z v)
149 "Return the z coordinate of the vec3 V."
150 (vec3-ref v 2))
151
152 (define-inlinable (set-vec2-x! v x)
153 "Set the x coordinate of the vec2 V to X."
154 (vec2-set! v 0 x))
155
156 (define-inlinable (set-vec3-x! v x)
157 "Set the x coordinate of the vec3 V to X."
158 (vec3-set! v 0 x))
159
160 (define-inlinable (set-vec2-y! v y)
161 "Set the y coordinate of the vec2 V to Y."
162 (vec2-set! v 1 y))
163
164 (define-inlinable (set-vec3-y! v y)
165 "Set the y coordinate of the vec3 V to Y."
166 (vec3-set! v 1 y))
167
168 (define-inlinable (set-vec3-z! v z)
169 "Set the z coordinate of the vec3 V to Z."
170 (vec3-set! v 2 z))
171
172 (define (display-vec2 v port)
173 (format port "#<vec2 x: ~f y: ~f>" (vec2-x v) (vec2-y v)))
174
175 (set-record-type-printer! <vec2> display-vec2)
176
177 (define (display-vec3 v port)
178 (format port "#<vec3 x: ~f y: ~f z: ~f>" (vec3-x v) (vec3-y v) (vec3-z v)))
179
180 (set-record-type-printer! <vec3> display-vec3)
181
182 (define (vec2-copy! source-vec2 target-vec2)
183 "Copy SOURCE-VEC2 to TARGET-VEC2."
184 (set-vec2-x! target-vec2 (vec2-x source-vec2))
185 (set-vec2-y! target-vec2 (vec2-y source-vec2)))
186
187 (define (vec3-copy! source-vec3 target-vec3)
188 "Copy SOURCE-VEC3 to TARGET-VEC3."
189 (set-vec3-x! target-vec3 (vec3-x source-vec3))
190 (set-vec3-y! target-vec3 (vec3-y source-vec3)))
191
192 (define (vec2-copy vec2)
193 "Return a new vec2 that is a copy of VEC2."
194 (with-new-vec2 new
195 (vec2-copy! vec2 new)))
196
197 (define (vec3-copy vec3)
198 "Return a new vec3 that is a copy of VEC3."
199 (with-new-vec3 new
200 (vec3-copy! vec3 new)))
201
202 (define-inlinable (vec2-magnitude v)
203 "Return the magnitude of the vec2 V."
204 (sqrt (+ (square (vec2-x v)) (square (vec2-y v)))))
205
206 (define-inlinable (vec3-magnitude v)
207 "Return the magnitude of the vec3 V."
208 (sqrt (+ (square (vec3-x v))
209 (square (vec3-y v))
210 (square (vec3-z v)))))
211
212 (define-inlinable (vec2-dot-product v1 v2)
213 "Return the dot product of the vec2s V1 and V2."
214 (+ (* (vec2-x v1) (vec2-x v2))
215 (* (vec2-y v1) (vec2-y v2))))
216
217 (define-inlinable (vec3-dot-product v1 v2)
218 "Return the dot product of the vec3s V1 and V2."
219 (+ (* (vec3-x v1) (vec3-x v2))
220 (* (vec3-y v1) (vec3-y v2))
221 (* (vec3-z v1) (vec3-z v2))))
222
223 (define-inlinable (vec2-normalize! v)
224 "Normalize the vec2 V in-place."
225 (unless (and (zero? (vec2-x v)) (zero? (vec2-y v)))
226 (let ((m (vec2-magnitude v)))
227 (set-vec2-x! v (/ (vec2-x v) m))
228 (set-vec2-y! v (/ (vec2-y v) m)))))
229
230 (define-inlinable (vec3-normalize! v)
231 "Normalize the vec3 V in-place."
232 (unless (and (zero? (vec3-x v))
233 (zero? (vec3-y v))
234 (zero? (vec3-z v)))
235 (let ((m (vec3-magnitude v)))
236 (set-vec3-x! v (/ (vec3-x v) m))
237 (set-vec3-y! v (/ (vec3-y v) m))
238 (set-vec3-z! v (/ (vec3-z v) m)))))
239
240 (define (vec2-normalize v)
241 "Return the normalized form of the vec2 V."
242 (with-new-vec2 new
243 (vec2-copy! v new)
244 (vec2-normalize! new)))
245
246 (define (vec3-normalize v)
247 "Return the normalized form of the vec3 V."
248 (with-new-vec3 new
249 (vec3-copy! v new)
250 (vec3-normalize! new)))
251
252 (define-inlinable (vec2-mult! v x)
253 "Multiply the vec2 V by X, a real number or vec2."
254 (if (real? x)
255 (begin
256 (set-vec2-x! v (* (vec2-x v) x))
257 (set-vec2-y! v (* (vec2-y v) x)))
258 (begin
259 (set-vec2-x! v (* (vec2-x v) (vec2-x x)))
260 (set-vec2-y! v (* (vec2-y v) (vec2-y x))))))
261
262 (define-inlinable (vec3-mult! v x)
263 "Multiply the vec3 V by X, a real number or vec3."
264 (if (real? x)
265 (begin
266 (set-vec3-x! v (* (vec3-x v) x))
267 (set-vec3-y! v (* (vec3-y v) x))
268 (set-vec3-z! v (* (vec3-z v) x)))
269 (begin
270 (set-vec3-x! v (* (vec3-x v) (vec3-x x)))
271 (set-vec3-y! v (* (vec3-y v) (vec3-y x)))
272 (set-vec3-z! v (* (vec3-z v) (vec3-z x))))))
273
274 (define-inlinable (vec2-add! v x)
275 "Add X, a real number or vec2, to the vec2 V."
276 (if (real? x)
277 (begin
278 (set-vec2-x! v (+ (vec2-x v) x))
279 (set-vec2-y! v (+ (vec2-y v) x)))
280 (begin
281 (set-vec2-x! v (+ (vec2-x v) (vec2-x x)))
282 (set-vec2-y! v (+ (vec2-y v) (vec2-y x))))))
283
284 (define-inlinable (vec3-add! v x)
285 "Add X, a real number or vec3, to the vec3 V."
286 (if (real? x)
287 (begin
288 (set-vec3-x! v (+ (vec3-x v) x))
289 (set-vec3-y! v (+ (vec3-y v) x))
290 (set-vec3-z! v (+ (vec3-z v) x)))
291 (begin
292 (set-vec3-x! v (+ (vec3-x v) (vec3-x x)))
293 (set-vec3-y! v (+ (vec3-y v) (vec3-y x)))
294 (set-vec3-z! v (+ (vec3-z v) (vec3-z x))))))
295
296 (define-inlinable (vec2-sub! v x)
297 "Subtract X, a real number or vec2, from the vec2 V."
298 (if (real? x)
299 (begin
300 (set-vec2-x! v (- (vec2-x v) x))
301 (set-vec2-y! v (- (vec2-y v) x)))
302 (begin
303 (set-vec2-x! v (- (vec2-x v) (vec2-x x)))
304 (set-vec2-y! v (- (vec2-y v) (vec2-y x))))))
305
306 (define-inlinable (vec3-sub! v x)
307 "Subtract X, a real number or vec3, from the vec3 V."
308 (if (real? x)
309 (begin
310 (set-vec3-x! v (- (vec3-x v) x))
311 (set-vec3-y! v (- (vec3-y v) x))
312 (set-vec3-z! v (- (vec3-z v) x)))
313 (begin
314 (set-vec3-x! v (- (vec3-x v) (vec3-x x)))
315 (set-vec3-y! v (- (vec3-y v) (vec3-y x)))
316 (set-vec3-z! v (- (vec3-z v) (vec3-z x))))))
317
318 (define-inlinable (vec2* v x)
319 "Multiply V by X."
320 (let ((new (vec2-copy v)))
321 (vec2-mult! new x)
322 new))
323
324 (define-inlinable (vec2+ v x)
325 "Add X to V."
326 (let ((new (vec2-copy v)))
327 (vec2-add! new x)
328 new))
329
330 (define-inlinable (vec2- v x)
331 "Subtract X from V."
332 (let ((new (vec2-copy v)))
333 (vec2-sub! new x)
334 new))
335
336 ;; Reader macro for vectors.
337 (define (read-vec chr port)
338 (define (consume-whitespace port)
339 (when (char-whitespace? (peek-char port))
340 (read-char port)
341 (consume-whitespace port)))
342 (if (eq? (peek-char port) #\()
343 (read-char port)
344 (error "expected opening #\\("))
345 (consume-whitespace port)
346 (let ((x (read port))
347 (y (read port)))
348 (if (eq? (peek-char port) #\))
349 (begin
350 (read-char port)
351 `(vec2 ,x ,y))
352 (let ((z (read port)))
353 (consume-whitespace port)
354 (if (eq? (peek-char port) #\))
355 (begin
356 (read-char port)
357 `(vec3 ,x ,y ,z))
358 (error "expected terminating #\\)"))))))
359
360 (read-hash-extend #\v read-vec)