src/overload/concatenate.lisp

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