Maths module with a generic vector submodule.

Simple vector and scalar operations are supported like + - * / but
without any optimization whatsoever to keep it generic and simple for now.

A swizzle function to get a new vector out of a subset of the original
vector's attributes is also added.

A lengthsq and length function is also provided.

src/maths/maths.lisp

@@ -0,0 +1,10 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(in-package :cl-user)
+(defpackage stoe.maths
+  (:nicknames :maths)
+  (:use :cl))
+(in-package :stoe.maths)

src/maths/vector.lisp

@@ -0,0 +1,107 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(in-package :cl-user)
+(defpackage stoe.maths.vector
+  (:nicknames :vector :v)
+  (:use :cl)
+  (:shadow :+ :- :* :/ :length)
+  (:export :vec :vec-int :x :y :z :w
+           :swizzle :with-attributes
+           :+ :- :* :/
+           :lengthsq :length
+           :normalize :safe-normalize))
+(in-package :stoe.maths.vector)
+
+(defun make-vector (type components)
+  (let ((dim (cl:length components)))
+    `(make-array ,dim :element-type ',type :initial-contents (list ,@(loop for i in components
+                                                                        collect (if (numberp i)
+                                                                                    (coerce i type)
+                                                                                    `(coerce ,i ',type)))))))
+
+(defmacro vec (&rest components)
+  (make-vector 'single-float components))
+
+(defmacro vec-int (&rest components)
+  (make-vector 'fixnum components))
+
+(defun x (vec) (if (> (array-dimension vec 0) 0) (aref vec 0) (coerce 0 (array-element-type vec))))
+(defun y (vec) (if (> (array-dimension vec 0) 1) (aref vec 1) (coerce 0 (array-element-type vec))))
+(defun z (vec) (if (> (array-dimension vec 0) 2) (aref vec 2) (coerce 0 (array-element-type vec))))
+(defun w (vec) (if (> (array-dimension vec 0) 3) (aref vec 3) (coerce 0 (array-element-type vec))))
+
+(defmacro swizzle (vec attributes)
+  (let* ((name (symbol-name attributes))
+         (len (cl:length name)))
+    `(make-array ,len :element-type (array-element-type ,vec)
+                 :initial-contents (list ,@(loop for x being the element of name
+                                              collect `(,(intern (concatenate 'string `(,x)) 'stoe.maths.vector)
+                                                         ,vec))))))
+
+(defmacro with-attributes (attr-list vec &body body)
+  "Binds a list of variables with x y z w or some swizzled vector for use in `body'."
+  `(let ,(mapcar (lambda (attr)
+                   (let* ((var (if (listp attr) (car attr) attr))
+                          (sym (symbol-name (if (listp attr) (cadr attr) attr)))
+                          (sym-len (cl:length sym)))
+                     (if (> sym-len 1)
+                         (list var `(swizzle ,vec ,(intern sym 'vector)))
+                         (list var `(,(intern sym 'vector) ,vec)))))
+                 attr-list)
+     ,@body))
+
+(defun op-scalar (fun vec scalar)
+  (map (type-of vec) #'(lambda (attr) (funcall fun attr scalar)) vec))
+
+(defun op-vec (fun vec-a vec-b)
+  (map (type-of vec-a) fun vec-a vec-b))
+
+(defun + (&rest vec-list)
+  (reduce #'(lambda (a b)
+              (cond
+                ((not (typep a 'simple-array)) (op-scalar #'cl:+ b a))
+                ((not (typep b 'simple-array)) (op-scalar #'cl:+ a b))
+                (t (op-vec #'cl:+ a b))))
+          vec-list))
+
+(defun - (&rest vec-list)
+  (reduce #'(lambda (a b)
+              (cond
+                ((not (typep a 'simple-array)) (op-scalar #'cl:- b a))
+                ((not (typep b 'simple-array)) (op-scalar #'cl:- a b))
+                (t (op-vec #'cl:- a b))))
+          vec-list))
+
+(defun * (&rest vec-list)
+  (reduce #'(lambda (a b)
+              (cond
+                ((not (typep a 'simple-array)) (op-scalar #'cl:* b a))
+                ((not (typep b 'simple-array)) (op-scalar #'cl:* a b))
+                (t (op-vec #'cl:* a b))))
+          vec-list))
+
+(defun / (&rest vec-list)
+  (reduce #'(lambda (a b)
+              (cond
+                ((not (typep a 'simple-array)) (op-scalar #'cl:/ b a))
+                ((not (typep b 'simple-array)) (op-scalar #'cl:/ a b))
+                (t (op-vec #'cl:/ a b))))
+          vec-list))
+
+(defun lengthsq (vec)
+  (reduce #'cl:+ (map 'list #'(lambda (x) (cl:* x x)) vec)))
+
+(defun length (vec)
+  (sqrt (lengthsq vec)))
+
+(defun normalize (vec)
+  (/ vec (length vec)))
+
+(defun safe-normalize (vec &optional default)
+  (let ((lensq (lengthsq vec)))
+    (if (zerop lensq)
+        (or default vec)
+        (/ vec (sqrt lensq)))))

stoe.asd

@@ -21,7 +21,11 @@
   :depends-on (:swank)
   :components ((:module "src"
                 :components
-                ((:file "utils")
+                ((:module "maths"
+                          :components
+                          ((:file "maths")
+                           (:file "vector")))
+                 (:file "utils")
                  (:file "thread"
                         :depends-on ("utils"))
                  (:file "containers")