src/vectors.lisp @ 8a0c2154cda5

(in-package #:coding-math.vectors)


;;;; Utils
(declaim (inline square))


(defun symbolize (&rest args)
  (intern (format nil "~{~A~}" args)))

(defun square (x)
  (* x x))

(defmacro defuns (names &rest rest)
  `(progn
     ,@(loop :for name :in names :collect `(defun ,name ,@rest))))


;;;; Structs
(defmacro defvec (name slots arglist type default)
  `(defstruct (,name (:constructor ,name ,arglist))
     ,@(loop :for slot :in slots :collect `(,slot ,default :type ,type))))

(defmacro defvec2 (name type default)
  `(defvec ,name (x y) (&optional (x ,default) (y x)) ,type ,default))

(defmacro defvec3 (name type default)
  `(defvec ,name (x y z) (&optional (x ,default) (y x) (z y)) ,type ,default))

(defmacro defvec4 (name type default)
  `(defvec ,name (x y z w) (&optional (x ,default) (y x) (z y) (w z)) ,type ,default))


(defvec2 vec2 real 0)
(defvec2 vec2f single-float 0f0)
(defvec2 vec2d double-float 0d0)
(defvec2 vec2i fixnum 0)

(defvec3 vec3 real 0)
(defvec3 vec3f single-float 0f0)
(defvec3 vec3d double-float 0d0)
(defvec3 vec3i fixnum 0)

(defvec4 vec4 real 0)
(defvec4 vec4f single-float 0f0)
(defvec4 vec4d double-float 0d0)
(defvec4 vec4i fixnum 0)


;;;; Operations
(defmacro with-fns (vec-type element-type &body body)
  `(macrolet
    ((vec (&rest args) `(,',vec-type ,@args))
     (vec-x (v) `(,(symbolize ',vec-type '-x) ,v))
     (vec-y (v) `(,(symbolize ',vec-type '-y) ,v))
     (vec-z (v) `(,(symbolize ',vec-type '-z) ,v))
     (vec-w (v) `(,(symbolize ',vec-type '-w) ,v))
     ,(if (eq element-type 'fixnum)
        `(wrap (x) `(logand most-positive-fixnum ,x))
        `(wrap (x) x))
     ,(if (eq element-type 'fixnum)
       `(// (x y) `(floor ,x ,y))
       `(// (x y) `(/ ,x ,y))))
    ,@body))

(defmacro defvec2ops (vec-type element-type)
  (let ((add (symbolize vec-type '-add))
        (sub (symbolize vec-type '-sub))
        (mul (symbolize vec-type '-mul))
        (div (symbolize vec-type '-div))
        (eql (symbolize vec-type '-eql))
        (magnitude (symbolize vec-type '-magnitude))
        (length (symbolize vec-type '-length))
        (angle (symbolize vec-type '-angle))
        (direction (symbolize vec-type '-direction)))
    `(progn
      (declaim (ftype (function (,vec-type ,vec-type)
                                (values boolean &optional))
                      ,eql))

      (declaim (ftype (function (,vec-type ,vec-type)
                                (values ,vec-type &optional))
                      ,add ,sub))

      (declaim (ftype (function (,vec-type ,element-type)
                                (values ,vec-type &optional))
                      ,mul ,div))

      (declaim (ftype (function (,vec-type)
                                ,(if (eq 'fixnum element-type)
                                   `(values real &optional)
                                   `(values ,element-type &optional)))
                      ,magnitude ,length ,angle ,direction))

      (with-fns
        ,vec-type ,element-type

        (defun ,eql (v1 v2)
          (and (= (vec-x v1) (vec-x v2))
               (= (vec-y v1) (vec-y v2))))

        (defun ,add (v1 v2)
          (vec
            (wrap (+ (vec-x v1) (vec-x v2)))
            (wrap (+ (vec-y v1) (vec-y v2)))))

        (defun ,sub (v1 v2)
          (vec
            (wrap (- (vec-x v1) (vec-x v2)))
            (wrap (- (vec-y v1) (vec-y v2)))))

        (defun ,mul (v scalar)
          (vec
            (wrap (* (vec-x v) scalar))
            (wrap (* (vec-y v) scalar))))

        (defun ,div (v scalar)
          (vec
            (wrap (// (vec-x v) scalar))
            (wrap (// (vec-y v) scalar))))

        (defuns (,magnitude ,length) (v)
          (sqrt (+ (square (vec-x v))
                   (square (vec-y v)))))

        (defuns (,angle ,direction) (v)
          (atan (vec-y v) (vec-x v)))))))


(defvec2ops vec2 real)
(defvec2ops vec2f single-float)
(defvec2ops vec2d double-float)
(defvec2ops vec2i fixnum)

(declaim (optimize (speed 3)))
; vec2i-add