(defun subst-with (tree &key values (subst-fn (constantly nil)))
  "Walks the tree (conses), substituting leaves/subtrees as
indicated by values [an alist] or 
subst-fn (Either nil element -> [subst-p subst-with]),
in that order"
  (let ((entry (assoc tree values :test #'equal)))
    (if entry                           ; `=>' anyone?
        (cdr entry)
        (multiple-value-bind (subst-p new-value)
            (funcall subst-fn tree)
          (if subst-p
              new-value
              (if (consp tree)
                  (cons (subst-with (car tree) :values values :subst-fn subst-fn)
                        (subst-with (cdr tree) :values values :subst-fn subst-fn))
                  tree))))))

(defun arg-names (arg-list)
  "Extracts the argument names from a lambda list."
  (mapcan (lambda (arg)
            (unless (member arg lambda-list-keywords :test #'eq)
              (list (cond ((symbolp arg)  arg)
                          ((symbolp (car arg)) (car arg))
                          ((symbolp (second (car arg))) (second (car arg)))
                          (t   (error "Malformed argument ~A~%" arg))))))
          arg-list))

(defun symbol-concat (package externalp &rest symbols)
  "Concatenates the symbols into a single symbol
in package `package', and exports it if `externalp'"
  (let* ((symbol-name (apply #'concatenate 'string
                             (mapcar (lambda (symbol)
                                       (if (stringp symbol)
                                           symbol
                                           (symbol-name symbol)))
                                     symbols)))
         (symbol      (intern symbol-name package)))
    (when externalp
      (export (list symbol) package))
    symbol))

(defun make-symbol-concat (externalp environment)
  "Given an environment (alist of var -> value),
first returns a function that will substitute
 (:~ ...) with a single symbol."
  (lambda (expr)
    (when (and (listp expr)
               (eq (first expr) ':~))
      (let* ((args (rest expr))
             (package (if (eq (first args)
                              :package)
                          (prog1 (second args)
                            (setf args (cddr args)))
                          (symbol-package (first args))))
             (symbol (intern
                      (apply #'concatenate 'string
                             (mapcar (lambda (arg)
                                       (cond ((stringp arg)   arg)
                                             ((and (listp arg)
                                                   (eq (first arg)
                                                       'quote))
                                              (symbol-name (second arg)))
                                             (t    (let ((entry (assoc arg environment)))
                                                     (symbol-name (if entry
                                                                      (cdr entry)
                                                                      arg))))))
                                     args))
                      package)))
        (when externalp
          (export (list symbol) package))
        (values t symbol)))))

(defmacro deftemplate (name (&rest arguments)
                       (&key (external t)
                             (compile-toplevel t)
                             (load-toplevel t)
                             (execute t))
                       &body templated)
  "Defines a templating macro. The arguments are replaced with
their value in the template body"
  (let ((args (arg-names arguments)))
    `(defmacro ,name ,arguments
       (let ((environment (list ,@ (mapcar (lambda (arg)
                                             `(cons ',arg ,arg))
                                           args))))
         (list* 'eval-when
                '(,@ (when compile-toplevel
                       '(:compile-toplevel))
                  ,@ (when load-toplevel
                       '(:load-toplevel))
                  ,@ (when execute
                       '(:execute)))
                (subst-with ',templated
                            :values environment
                            :subst-fn (make-symbol-concat ',external environment)))))))

(deftemplate ~vector (type-name &optional (type-spec type-name)
                                &aux (base-name (symbol-concat '#:m t
                                                               'vec '- type-name))
                                     (imm-name  (symbol-concat '#:m t
                                                               'imm '- base-name))
                                     (map-name  (symbol-concat '#:m t
                                                               'map '- base-name)))
    ()
  (defclass base-name (m:vector)
    ((element-type :accessor m:element-type :initform 'type-spec)))
  (defclass imm-name (base-name)
    ((content      :accessor content-of :initarg :content)))

  (defun imm-name (value)
    (make-instance 'imm-name :length  (length value)
                             :content (make-array (length value)
                                                  :element-type 'type-spec
                                                  :initial-contents (coerce value 'list))))

  (defmethod m:ref ((value imm-name) &rest indices)
    (aref (content-of value) (first indices)))

  (defmethod m:!ref ((value imm-name))
    '(:before ()
      :after  ()
      :extract content-of
      :ref    aref))
  
  (defclass map-name (base-name)
    ((input        :accessor input-of   :initarg :input)
     (fn           :accessor fn-of      :initarg :fn)
     (cfn          :accessor cfn-of     :initarg :cfn)
     (extract      :accessor extract-of :initarg :extract)
     (cxt          :accessor cxt-of     :initarg :cxt)))

  (defun map-name (fn input)
    (destructuring-bind (&key before after extract ref)
        (m:!ref input)
      (let* ((_index   (gensym "INDEX"))
             (_input   (gensym "INPUT"))
             (fn `(lambda (,_input ,_index)
                    (prog2
                        (progn ,@before)
                        (,fn (,ref ,_input ,_index))
                      ,@after)))
             (extract `(lambda (,_input)
                         ,(if extract
                              `(,extract (input-of ,_input))
                              `(input-of ,_input)))))
        (make-instance 'map-name
                       :input input
                       :fn fn
                       :cfn (compile nil fn)
                       :extract extract
                       :cxt (compile nil extract)))))

  (defmethod m:map (fn (input base-name))
    (map-name fn input))

  (defmethod m:ref ((value map-name) &rest indices)
    (funcall (cfn-of value)
             (funcall (cxt-of value)
                      value)
             (first indices)))

  (defmethod m:!ref ((value map-name))
    `(:extract ,(extract-of value) :ref ,(fn-of value)))
  )

(~vector double double-float)