src/overload/concatenate.lisp

   1
   2 (defun over-cat (&rest args)
   3   (if args
   4     (if (cdr args)
   5       (reduce #'cat2 args :from-end t)
   6       (car args))
   7     (throw 'over-ex "Can't cat nothing.")))
   8
   9 (defun over-vcat (&rest args)
  10   (if args
  11     (if (cdr args)
  12       (reduce #'vcat2 args :from-end t)
  13       (car args))
  14     (throw 'over-ex "Can't vcat nothing.")))
  15
  16 (defmethod cat2 ((u list) v)
  17   (cat2 (tuple-list u) v))
  18
  19 (defmethod cat2 (u (v list))
  20   (cat2 u (tuple-list v)))
  21
  22 (defmethod vcat2 ((u list) v)
  23   (vcat2 (tuple-list u) v))
  24
  25 (defmethod vcat2 (u (v list))
  26   (vcat2 u (tuple-list v)))
  27
  28 (defmacro cat2-fill
  29   (((arow s-arows)
  30     (brow s-brows)
  31     rows)
  32    s-cat
  33    (width
  34      (s-awidth s-azeros)
  35      (s-bwidth s-bzeros))
  36    s-return)
  37   (let ((row (gensym))
  38         (tail (gensym))
  39         (arem (gensym)) (brem (gensym))
  40         (finished (gensym)))
  41     `(tails-do*
  42        (((,row ,rows ,tail))
  43         (,arem ,s-arows (cdr ,arem))
  44         (,brem ,s-brows (cdr ,brem))
  45         (,finished nil (not (and ,arem ,brem))))
  46        (,finished
  47          (rplacd
  48            ,tail
  49            (if ,arem
  50              (let* (,@(when s-bwidth `((,width ,s-bwidth)))
  51                      (,brow ,s-bzeros))
  52                (mapcar #'(lambda (,arow) ,s-cat) ,arem))
  53              (when ,brem
  54                (let* (,@(when s-awidth `((,width ,s-awidth)))
  55                        (,arow ,s-azeros))
  56                  (mapcar #'(lambda (,brow) ,s-cat) ,brem)))))
  57          ,s-return)
  58        (let ((,arow (car ,arem))
  59              (,brow (car ,brem)))
  60          (setq ,row ,s-cat)))))
  61
  62
  63 (defmethod cat2 ((a number) (b number))
  64   (make-mtrix :dimdom 2 :dimcodom 1
  65               :elems (list (list a b))))
  66
  67 (defmethod vcat2 ((a number) (b number))
  68   (make-tuple :dim 2 :elems (list a b)))
  69
  70 (defmethod cat2 ((k number) (u tuple))
  71   (make-mtrix :dimdom 2 :dimcodom (tuple-dim u)
  72               :elems (mapcar #'(lambda (x) (list k x))
  73                              (tuple-elems u))))
  74
  75 (defmethod cat2 ((u tuple) (k number))
  76   (make-mtrix :dimdom 2 :dimcodom (tuple-dim u)
  77               :elems (mapcar #'(lambda (x) (list x k))
  78                              (tuple-elems u))))
  79
  80 (defmethod vcat2 ((k number) (u tuple))
  81   (make-tuple :dim (1+ (tuple-dim u))
  82               :elems (cons k (tuple-elems u))))
  83
  84 (defmethod vcat2 ((u tuple) (k number))
  85   (make-tuple :dim (1+ (tuple-dim u))
  86               :elems `(,@(tuple-elems u) ,k)))
  87
  88 ;V Align two tuples into a column matrix.V
  89 (defmethod cat2 ((u tuple) (v tuple))
  90   (cat2-fill
  91     ((uelem (tuple-elems u))
  92      (velem (tuple-elems v))
  93      rows)
  94     (list uelem velem)
  95     (nil (nil 0) (nil 0))
  96     (make-mtrix :dimdom 2
  97                 :dimcodom (max (tuple-dim u)
  98                                (tuple-dim v))
  99                 :elems rows)))
 100
 101 ;V Merge two tuples together into one long vector.V
 102 (defmethod vcat2 ((u tuple) (v tuple))
 103   (make-tuple :dim (+ (tuple-dim u) (tuple-dim v))
 104               :elems (append (tuple-elems u)
 105                              (tuple-elems v))))
 106
 107 ;V Add a column vector /u/ to  V
 108 ;V the left side of matrix /a/.V
 109 (defmethod cat2 ((u tuple) (a mtrix))
 110   (cat2-fill
 111     ((uelem (tuple-elems u))
 112      (arow (mtrix-elems a))
 113      rows)
 114     (cons uelem arow)
 115     (width
 116       (nil 0)
 117       ((mtrix-dimdom a)
 118        (make-list width :initial-element 0)))
 119     (make-mtrix :dimdom (1+ (mtrix-dimdom a))
 120                 :dimcodom (max (tuple-dim u)
 121                                (mtrix-dimcodom a))
 122                 :elems rows)))
 123
 124 (defmethod cat2 ((a mtrix) (u tuple))
 125   (cat2-fill
 126     ((arow (mtrix-elems a))
 127      (uelem (tuple-elems u))
 128      rows)
 129     `(,@arow ,uelem)
 130     (width
 131       ((mtrix-dimdom a)
 132        (make-list width :initial-element 0))
 133       (nil 0))
 134     (make-mtrix :dimdom (1+ (mtrix-dimdom a))
 135                 :dimcodom (mtrix-dimcodom a)
 136                 :elems rows)))
 137
 138 (defmethod cat2 ((a mtrix) (b mtrix))
 139   (cat2-fill
 140     ((arow (mtrix-elems a))
 141      (brow (mtrix-elems b))
 142      rows)
 143     (append arow brow)
 144     (width
 145       ((mtrix-dimdom a)
 146        (make-list width :initial-element 0))
 147       ((mtrix-dimdom b)
 148        (make-list width :initial-element 0)))
 149     (make-mtrix :dimdom (+ (mtrix-dimdom a)
 150                            (mtrix-dimdom b))
 151                 :dimcodom (max (mtrix-dimcodom a)
 152                                (mtrix-dimcodom b))
 153                 :elems rows)))
 154
 155 (defmethod vcat2 ((u tuple) (a mtrix))
 156   (let ((uwid (tuple-dim u))
 157         (awid (mtrix-dimdom a))
 158         (rows (cons (tuple-elems u)
 159                     (mtrix-elems a))))
 160     (if (< uwid awid)
 161       (rplaca rows
 162               (append
 163                 (car rows)
 164                 (make-list (- awid uwid)
 165                            :initial-element 0)))
 166       (unless (= uwid awid)
 167         (shiftf awid uwid (- uwid awid))
 168         (rplacd
 169           rows
 170           (mapcar
 171             #'(lambda (row)
 172                 (append
 173                   row
 174                   (make-list uwid :initial-element 0)))
 175             (cdr rows)))))
 176     (make-mtrix :dimdom awid
 177                 :dimcodom (1+ (mtrix-dimcodom a))
 178                 :elems rows)))
 179
 180 (defmethod vcat2 ((a mtrix) (u tuple))
 181   (let ((awid (mtrix-dimdom a))
 182         (uwid (tuple-dim u)))
 183     (make-mtrix
 184       :dimcodom (1+ (mtrix-dimcodom a))
 185       :elems
 186       (if (< uwid awid)
 187         `(,@(mtrix-elems a)
 188            ,(append (tuple-elems u)
 189                     (make-list (- awid uwid)
 190                                :initial-element 0)))
 191         (if (= uwid awid)
 192           `(,@(mtrix-elems a) ,(tuple-elems u))
 193           (progn
 194             (shiftf awid uwid (- uwid awid))
 195             (tails-do*
 196               (((row rows tail))
 197                (arem (mtrix-elems a) (cdr arem)))
 198               ((not arem)
 199                (rplacd tail (cons (tuple-elems u) nil))
 200                rows)
 201               (setq row
 202                     (append
 203                       (car arem)
 204                       (make-list
 205                         uwid :initial-element 0)))))))
 206       :dimdom awid)))
 207
 208 ;V Join a column of /k/'s onto the left of /a/.V
 209 (defmethod cat2 ((k number) (a mtrix))
 210   (make-mtrix
 211     :dimdom (1+ (mtrix-dimdom a))
 212     :dimcodom (mtrix-dimcodom a)
 213     :elems (mapcar #'(lambda (row) (cons k row))
 214                    (mtrix-elems a))))
 215
 216 ;V Join a column of /k/'s onto the right of /a/.V
 217 (defmethod cat2 ((a mtrix) (k number))
 218   (make-mtrix
 219     :dimdom (1+ (mtrix-dimdom a))
 220     :dimcodom (mtrix-dimcodom a)
 221     :elems (mapcar #'(lambda (row) `(,@row ,k))
 222                    (mtrix-elems a))))
 223
 224 ;V Join a row of /k/'s onto the top of /a/.V
 225 (defmethod vcat2 ((k number) (a mtrix))
 226   (make-mtrix
 227     :dimdom (mtrix-dimdom a)
 228     :dimcodom (1+ (mtrix-dimcodom a))
 229     :elems (cons (make-list (mtrix-dimdom a)
 230                             :initial-element k)
 231                  (mtrix-elems a))))
 232
 233 ;V Join a row of /k/'s onto the bottom of /a/.V
 234 (defmethod vcat2 ((a mtrix) (k number))
 235   (make-mtrix
 236     :dimdom (mtrix-dimdom a)
 237     :dimcodom (1+ (mtrix-dimcodom a))
 238     :elems `(,@(mtrix-elems a)
 239               ,(make-list (mtrix-dimdom a)
 240                           :initial-element k))))
 241
 242 (defmethod vcat2 ((a mtrix) (b mtrix))
 243   (let* ((awid (mtrix-dimdom a))
 244          (bwid (mtrix-dimdom b))
 245          (finwid (max awid bwid))
 246          (zeros (make-list (abs (- awid bwid))
 247                            :initial-element 0)))
 248     (make-mtrix
 249       :dimdom finwid
 250       :dimcodom (+ (mtrix-dimcodom a)
 251                    (mtrix-dimcodom b))
 252       :elems (append
 253                (if (= awid finwid) (mtrix-elems a)
 254                  (mapcar #'(lambda (row)
 255                              (append row zeros))
 256                          (mtrix-elems a)))
 257                (if (= bwid finwid) (mtrix-elems b)
 258                  (mapcar #'(lambda (row)
 259                              (append row zeros))
 260                          (mtrix-elems b)))))))
 261
 262