[lineal.git] / src / overload / concatenate.lisp

(in-package :lineal.overload)

(defun over-cat (&rest args)
  (if args
    (if (cdr args)
      (reduce #'cat2 args :from-end t)
      (car args))
    (throw 'over-ex "Can't cat nothing.")))

(defun over-vcat (&rest args)
  (if args
    (if (cdr args)
      (reduce #'vcat2 args :from-end t)
      (car args))
    (throw 'over-ex "Can't vcat nothing.")))

(defmethod cat2 ((u list) v)
  (cat2 (tuple-list u) v))

(defmethod cat2 (u (v list))
  (cat2 u (tuple-list v)))

(defmethod vcat2 ((u list) v)
  (vcat2 (tuple-list u) v))

(defmethod vcat2 (u (v list))
  (vcat2 u (tuple-list v)))

;V The do* macro with tails.V
(defmacro tails-do*
  (((&body tails-args) . do-args)
   (s-pred . s-cleanup) . s-proc)
  (let ((begin-loop-tag (gensym))
        (end-loop-tag (gensym))
        pre-inits post-inits
        do-setqs tail-setqs
        s-conditail-setqs
        s-declarations
        var-init-p)
    (loop
      :for (v a ta condit) :in tails-args
      ;V See if /v/ has an initial value.V
      :for init-v = (when (consp v)
                      (setq var-init-p t)
                      (prog1 (cadr v)
                        (setq v (car v))))
      ;V Find if the tail should be V
      ;V initialized as something.  V
      :for tadef =
      (if ta
        (if (consp ta)
          (cadr (shiftf ta (car ta)))
          (if a nil ta))
        ;V No tail mentioned by user, set /ta/ V
        ;V as a symbol name and return nil.    V
        (shiftf ta (gensym)))
      ;> /ta/ is now strictly the variable name referring to the
      ;> accum-list's tail. There is always a tail at this point. 
      ;V Find what the accum-list is initialized with     V
      ;V and what its part of the /post-inits/ looks like.V
      :for (adef a-init-part) =
      (if (listp a)
        (list (when a (cadr (shiftf a (car a))))
              ;^ If /a/ is a cons, set it to its symbol  ^
              ;^ name and return its initialization form.^
              (if tadef `(list ,v) 
                `(if ,a (cdr (rplacd (last ,a) (cons ,v nil)))
                   (setq ,a (list ,v)))))
        ;V The accum-list does not have an init value,  V
        ;V but will be initialized in the beginning let.V
        `(nil (setq ,a (cons ,v nil))))
      ;> /a/ is now strictly the variable name referring to the
      ;> accum-list or nil if the list exists before this macro.
      :for default-val-setq =
      (when condit
        (if (consp condit)
          (when (cdr condit)
            (cons v (cdr condit)))
          (list v nil)))
      ;V Collect variables and initializations V
      ;V to be used in the outer let form.     V
      :collect (if init-v (list v init-v) v) :into vlist
      :when a
      :collect (if adef (list a adef) a) :into vlist
      :collect (if tadef (list ta tadef) ta) :into vlist
      ;V The stuff for /post-inits/.V
      :nconc
      `(,ta ,(if tadef `(cdr (rplacd ,ta ,a-init-part))
               a-init-part))
      :into ilist
      :if condit
      :nconc default-val-setq :into ilist
      :and :collect
      `(if ,(if (consp condit) (car condit) v)
         (setq ,ta (cdr (rplacd ,ta (cons ,v nil)))
               ,@default-val-setq))
      :into condlist
      :else :nconc
      `(,ta (cdr (rplacd ,ta (cons ,v nil))))
      :into qlist
      :finally (setq pre-inits vlist
                     post-inits ilist
                     s-conditail-setqs condlist
                     tail-setqs qlist))
    ;V Handle regular do arguments.V
    (loop :for (v i a) :in do-args
          :collect (if i (list v i) v) :into vlist
          :when a :collect v :into alist
          :and :collect a :into alist
          :finally (nconc pre-inits vlist)
          (setq do-setqs alist))
    (loop :while (and (consp (car s-proc))
                      (eq 'declare (caar s-proc)))
          :collect (pop s-proc) :into decl
          :finally (setq s-declarations decl))
    `(let* (,@pre-inits);< All variable initializations.
       ,@s-declarations
       (unless ,s-pred
         ;V Run loop contents here only if the first V
         ;V value to accumulate is not specified.    V
         ,@(unless var-init-p s-proc)
         ;V Give all tails a value if they don't have one, V
         (setq ,@post-inits);< update some nil lists too.
         (tagbody
           ,begin-loop-tag
           (setq ,@do-setqs);< Normal do-loop updates.
           (if ,s-pred (go ,end-loop-tag))
           ,@s-proc;< Run inner loop.
           ,@s-conditail-setqs;< Conditional tail updates.
           (setq ,@tail-setqs);< Update all tails.
           (go ,begin-loop-tag)
           ,end-loop-tag))
       ;V Loop is over, run user's cleanup forms.V
       ,@s-cleanup)))

(defmacro cat2-fill
  (((arow s-arows)
    (brow s-brows)
    rows)
   s-cat
   (width
     (s-awidth s-azeros)
     (s-bwidth s-bzeros))
   s-return)
  (let ((row (gensym))
        (tail (gensym))
        (arem (gensym)) (brem (gensym))
        (finished (gensym)))
    `(tails-do*
       (((,row ,rows ,tail))
        (,arem ,s-arows (cdr ,arem))
        (,brem ,s-brows (cdr ,brem))
        (,finished nil (not (and ,arem ,brem))))
       (,finished
         (rplacd
           ,tail
           (if ,arem
             (let* (,@(when s-bwidth `((,width ,s-bwidth)))
                     (,brow ,s-bzeros))
               (mapcar #'(lambda (,arow) ,s-cat) ,arem))
             (when ,brem
               (let* (,@(when s-awidth `((,width ,s-awidth)))
                       (,arow ,s-azeros))
                 (mapcar #'(lambda (,brow) ,s-cat) ,brem)))))
         ,s-return)
       (let ((,arow (car ,arem))
             (,brow (car ,brem)))
         (setq ,row ,s-cat)))))


(defmethod cat2 ((a number) (b number))
  (make-mtrix :dimdom 2 :dimcodom 1
              :elems (list (list a b))))

(defmethod vcat2 ((a number) (b number))
  (make-tuple :dim 2 :elems (list a b)))

(defmethod cat2 ((k number) (u tuple))
  (make-mtrix :dimdom 2 :dimcodom (tuple-dim u)
              :elems (mapcar #'(lambda (x) (list k x))
                             (tuple-elems u))))

(defmethod cat2 ((u tuple) (k number))
  (make-mtrix :dimdom 2 :dimcodom (tuple-dim u)
              :elems (mapcar #'(lambda (x) (list x k))
                             (tuple-elems u))))

(defmethod vcat2 ((k number) (u tuple))
  (make-tuple :dim (1+ (tuple-dim u))
              :elems (cons k (tuple-elems u))))

(defmethod vcat2 ((u tuple) (k number))
  (make-tuple :dim (1+ (tuple-dim u))
              :elems `(,@(tuple-elems u) ,k)))

;V Align two tuples into a column matrix.V
(defmethod cat2 ((u tuple) (v tuple))
  (cat2-fill
    ((uelem (tuple-elems u))
     (velem (tuple-elems v))
     rows)
    (list uelem velem)
    (nil (nil 0) (nil 0))
    (make-mtrix :dimdom 2
                :dimcodom (max (tuple-dim u)
                               (tuple-dim v))
                :elems rows)))

;V Merge two tuples together into one long vector.V
(defmethod vcat2 ((u tuple) (v tuple))
  (make-tuple :dim (+ (tuple-dim u) (tuple-dim v))
              :elems (append (tuple-elems u)
                             (tuple-elems v))))

;V Add a column vector /u/ to  V
;V the left side of matrix /a/.V
(defmethod cat2 ((u tuple) (a mtrix))
  (cat2-fill
    ((uelem (tuple-elems u))
     (arow (mtrix-elems a))
     rows)
    (cons uelem arow)
    (width
      (nil 0)
      ((mtrix-dimdom a)
       (make-list width :initial-element 0)))
    (make-mtrix :dimdom (1+ (mtrix-dimdom a))
                :dimcodom (max (tuple-dim u)
                               (mtrix-dimcodom a))
                :elems rows)))

(defmethod cat2 ((a mtrix) (u tuple))
  (cat2-fill
    ((arow (mtrix-elems a))
     (uelem (tuple-elems u))
     rows)
    `(,@arow ,uelem)
    (width
      ((mtrix-dimdom a)
       (make-list width :initial-element 0))
      (nil 0))
    (make-mtrix :dimdom (1+ (mtrix-dimdom a))
                :dimcodom (mtrix-dimcodom a)
                :elems rows)))

(defmethod cat2 ((a mtrix) (b mtrix))
  (cat2-fill
    ((arow (mtrix-elems a))
     (brow (mtrix-elems b))
     rows)
    (append arow brow)
    (width
      ((mtrix-dimdom a)
       (make-list width :initial-element 0))
      ((mtrix-dimdom b)
       (make-list width :initial-element 0)))
    (make-mtrix :dimdom (+ (mtrix-dimdom a)
                           (mtrix-dimdom b))
                :dimcodom (max (mtrix-dimcodom a)
                               (mtrix-dimcodom b))
                :elems rows)))

(defmethod vcat2 ((u tuple) (a mtrix))
  (let ((uwid (tuple-dim u))
        (awid (mtrix-dimdom a))
        (rows (cons (tuple-elems u)
                    (mtrix-elems a))))
    (if (< uwid awid)
      (rplaca rows
              (append
                (car rows)
                (make-list (- awid uwid)
                           :initial-element 0)))
      (unless (= uwid awid)
        (shiftf awid uwid (- uwid awid))
        (rplacd
          rows
          (mapcar
            #'(lambda (row)
                (append
                  row
                  (make-list uwid :initial-element 0)))
            (cdr rows)))))
    (make-mtrix :dimdom awid
                :dimcodom (1+ (mtrix-dimcodom a))
                :elems rows)))

(defmethod vcat2 ((a mtrix) (u tuple))
  (let ((awid (mtrix-dimdom a))
        (uwid (tuple-dim u)))
    (make-mtrix
      :dimcodom (1+ (mtrix-dimcodom a))
      :elems
      (if (< uwid awid)
        `(,@(mtrix-elems a)
           ,(append (tuple-elems u)
                    (make-list (- awid uwid)
                               :initial-element 0)))
        (if (= uwid awid)
          `(,@(mtrix-elems a) ,(tuple-elems u))
          (progn
            (shiftf awid uwid (- uwid awid))
            (tails-do*
              (((row rows tail))
               (arem (mtrix-elems a) (cdr arem)))
              ((not arem)
               (rplacd tail (cons (tuple-elems u) nil))
               rows)
              (setq row
                    (append
                      (car arem)
                      (make-list
                        uwid :initial-element 0)))))))
      :dimdom awid)))

;V Join a column of /k/'s onto the left of /a/.V
(defmethod cat2 ((k number) (a mtrix))
  (make-mtrix
    :dimdom (1+ (mtrix-dimdom a))
    :dimcodom (mtrix-dimcodom a)
    :elems (mapcar #'(lambda (row) (cons k row))
                   (mtrix-elems a))))

;V Join a column of /k/'s onto the right of /a/.V
(defmethod cat2 ((a mtrix) (k number))
  (make-mtrix
    :dimdom (1+ (mtrix-dimdom a))
    :dimcodom (mtrix-dimcodom a)
    :elems (mapcar #'(lambda (row) `(,@row ,k))
                   (mtrix-elems a))))

;V Join a row of /k/'s onto the top of /a/.V
(defmethod vcat2 ((k number) (a mtrix))
  (make-mtrix
    :dimdom (mtrix-dimdom a)
    :dimcodom (1+ (mtrix-dimcodom a))
    :elems (cons (make-list (mtrix-dimdom a)
                            :initial-element k)
                 (mtrix-elems a))))

;V Join a row of /k/'s onto the bottom of /a/.V
(defmethod vcat2 ((a mtrix) (k number))
  (make-mtrix
    :dimdom (mtrix-dimdom a)
    :dimcodom (1+ (mtrix-dimcodom a))
    :elems `(,@(mtrix-elems a)
              ,(make-list (mtrix-dimdom a)
                          :initial-element k))))

(defmethod vcat2 ((a mtrix) (b mtrix))
  (let* ((awid (mtrix-dimdom a))
         (bwid (mtrix-dimdom b))
         (finwid (max awid bwid))
         (zeros (make-list (abs (- awid bwid))
                           :initial-element 0)))
    (make-mtrix
      :dimdom finwid
      :dimcodom (+ (mtrix-dimcodom a)
                   (mtrix-dimcodom b))
      :elems (append
               (if (= awid finwid) (mtrix-elems a)
                 (mapcar #'(lambda (row)
                             (append row zeros))
                         (mtrix-elems a)))
               (if (= bwid finwid) (mtrix-elems b)
                 (mapcar #'(lambda (row)
                             (append row zeros))
                         (mtrix-elems b)))))))