;;; Utilities
(defun compose-name (separator &rest parts)
  (intern
   (with-output-to-string (out)
     (flet ((s (a)
              (let ((s (typecase a
                         (string a)
                         (symbol (symbol-name a))
                         (T (princ-to-string a)))))
                (write-string s out))))
       (s (first parts))
       (loop for part in (rest parts)
             do (when separator (write-char separator out))
                (s part))))))

(defun enumerate-combinations (&rest combinations)
  (if (cdr combinations)
      (loop for comb in (first combinations)
            nconc (loop for rest in (apply #'enumerate-combinations (rest combinations))
                        collect (list* comb rest)))
      (loop for comb in (first combinations)
            collect (list comb))))

;;; Template type mechanism
(defclass template-type () ())
(defgeneric template-type (base-type template-args))
(defgeneric constructor (template-type))
(defgeneric name (template-type))
(defgeneric place (template-type qualifier))

(defmethod template-type ((base symbol) template-args)
  (template-type (make-instance base) template-args))

(defun emit-template-type (parent name fields)
  (let ((class (compose-name #\- name 'type)))
    `(progn
       (defclass ,class (,parent) ())
       (defmethod constructor ((_ ,class)) ',(compose-name NIL '% name))
       (defmethod name ((_ ,class)) ',name)
       (defmethod place ((_ ,class) qualifier)
         (ecase qualifier
           ,@(loop for (name type alias) in fields
                   collect `(,alias ',name))))
       
       (defstruct (,name (:constructor ,(compose-name NIL '% name)
                             ,(loop for (name type alias) in fields collect name))
                         (:copier ,(compose-name #\- name 'copy))
                         (:predicate ,(compose-name #\- name 'p))
                         (:conc-name NIL))
         ,@(loop for (name type alias) in fields
                 collect `(,name NIL :type ,type))))))

(defmacro define-template-type (name template-args name-constructor &body body)
  (let ((fields (gensym "FIELDS"))
        (targs (gensym "TEMPLATE-ARGS"))
        (class (compose-name #\- name 'type)))
    `(progn
       (defclass ,class (template-type) ())
       (defmethod template-type ((_ (eql ',name)) ,targs)
         (template-type (make-instance ',class) ,targs))
       (defmethod template-type ((_ ,class) ,targs)
         (destructuring-bind ,template-args ,targs
           (make-instance (compose-name #\- ,name-constructor 'type))))
       (defmacro ,(compose-name #\- 'define name) ,template-args
         (let ((,fields ()))
           (labels ((field (name &key (type T) alias)
                      (push (list name type alias) ,fields)))
             ,@body
             (emit-template-type ',class ,name-constructor (nreverse ,fields))))))))

;;; Template mechanism
(defmacro define-template (name &rest args)
  (destructuring-bind (base . template-args) (loop until (listp (car args))
                                                   collect (pop args))
    (destructuring-bind (args . body) args
      `(defmacro ,(compose-name #\- 'define name) ,template-args
         (let* ((type (template-type ',base (list ,@template-args)))
                (constructor (constructor type))
                (name (name type)))
           (flet ((place (qualifier)
                    (place type qualifier)))
             `(defun ,(compose-name #\/ ',name ,@template-args) ,',args
                ,@(list ,@body))))))))

;;; Dispatch mechanism
;; FIXME: + possible impl-specific type inference expanders
;; FIXME: handle args of different type combinations
(defmacro define-dispatch (name args &rest template-combinations)
  (destructuring-bind (base-type . combinations) template-combinations
    `(defun ,name ,args
       (etypecase ,(first args)
         ,@(loop for template in (apply #'enumerate-combinations combinations)
                 for type = (template-type base-type template)
                 for op = (apply #'compose-name #\/ name template)
                 collect `(,(name type) (,op ,@args)))))))


;;;; Usage
(defun type-prefix (type)
  (ecase type
    (single-float '||)
    (double-float 'd)
    (ub32 'u)
    (sb32 'i)))

(deftype ub32 ()
  '(unsigned-byte 32))

(deftype sb32 ()
  '(signed-byte 32))

(define-template-type vec (<s> <t>)
    (compose-name NIL (type-prefix <t>) 'vec <s>)
  (loop for i from 0 below <s>
        for f in '(x y z w)
        do (field (compose-name NIL (type-prefix <t>) 'v f <s>)
                  :type <t>
                  :alias (list i f))))

(define-vec 2 single-float)
(define-vec 3 single-float)
(define-vec 4 single-float)
(define-vec 2 double-float)
(define-vec 3 double-float)
(define-vec 4 double-float)
(define-vec 2 ub32)
(define-vec 3 ub32)
(define-vec 4 ub32)
(define-vec 2 sb32)
(define-vec 3 sb32)
(define-vec 4 sb32)

(define-template 2vec+ vec <s> <t> (a b)
  `(declare (type ,name a b))
  `(,constructor
    ,@(loop for i from 0 below <s>
            collect `(+ (,(place i) a)
                        (,(place i) b)))))

(define-2vec+ 2 single-float)

(define-template 2nvec+ vec <s> <t> (a b)
  `(declare (type ,name a b))
  `(setf ,@(loop for i from 0 below <s>
                 collect `(,(place i) a)
                 collect `(+ (,(place i) a)
                             (,(place i) b))))
  'a)

(define-2nvec+ 3 ub32)

(define-template vsqrlen vec <s> <t> (a)
  `(declare (type ,name a))
  `(+ ,@(loop for i from 0 below <s>
              collect `(expt (,(place i) a) 2))))

(define-vsqrlen 2 single-float)
(define-vsqrlen 3 single-float)
(define-vsqrlen 4 single-float)
(define-vsqrlen 2 double-float)
(define-vsqrlen 3 double-float)
(define-vsqrlen 4 double-float)
(define-vsqrlen 2 sb32)
(define-vsqrlen 3 sb32)
(define-vsqrlen 4 sb32)
(define-vsqrlen 2 ub32)
(define-vsqrlen 3 ub32)
(define-vsqrlen 4 ub32)

(define-dispatch vsqrlen (a)
  vec (2 3 4) (single-float double-float ub32 sb32))