src/overload/concatenate.lisp

   1
   2 (in-package :lineal.overload)
   3
   4 (defun over-cat (&rest args)
   5   (if args
   6     (if (cdr args)
   7       (reduce #'cat2 args :from-end t)
   8       (car args))
   9     (throw 'over-ex "Can't cat nothing.")))
  10
  11 (defun over-vcat (&rest args)
  12   (if args
  13     (if (cdr args)
  14       (reduce #'vcat2 args :from-end t)
  15       (car args))
  16     (throw 'over-ex "Can't vcat nothing.")))
  17
  18 ;V The do* macro with tails.V
  19 (defmacro tails-do*
  20   (((&body tails-args) . do-args)
  21    (s-pred . s-cleanup) . s-proc)
  22   (let ((begin-loop-tag (gensym))
  23         (end-loop-tag (gensym))
  24         pre-inits post-inits
  25         do-setqs tail-setqs
  26         s-conditail-setqs
  27         s-declarations
  28         var-init-p)
  29     (loop
  30       :for (v a ta condit) :in tails-args
  31       ;V See if /v/ has an initial value.V
  32       :for init-v = (when (consp v)
  33                       (setq var-init-p t)
  34                       (prog1 (cadr v)
  35                         (setq v (car v))))
  36       ;V Find if the tail should be V
  37       ;V initialized as something.  V
  38       :for tadef =
  39       (if ta
  40         (if (consp ta)
  41           (cadr (shiftf ta (car ta)))
  42           (if a nil ta))
  43         ;V No tail mentioned by user, set /ta/ V
  44         ;V as a symbol name and return nil.    V
  45         (shiftf ta (gensym)))
  46       ;> /ta/ is now strictly the variable name referring to the
  47       ;> accum-list's tail. There is always a tail at this point.
  48       ;V Find what the accum-list is initialized with     V
  49       ;V and what its part of the /post-inits/ looks like.V
  50       :for (adef a-init-part) =
  51       (if (listp a)
  52         (list (when a (cadr (shiftf a (car a))))
  53               ;^ If /a/ is a cons, set it to its symbol  ^
  54               ;^ name and return its initialization form.^
  55               (if tadef `(list ,v)
  56                 `(if ,a (cdr (rplacd (last ,a) (cons ,v nil)))
  57                    (setq ,a (list ,v)))))
  58         ;V The accum-list does not have an init value,  V
  59         ;V but will be initialized in the beginning let.V
  60         `(nil (setq ,a (cons ,v nil))))
  61       ;> /a/ is now strictly the variable name referring to the
  62       ;> accum-list or nil if the list exists before this macro.
  63       :for default-val-setq =
  64       (when condit
  65         (if (consp condit)
  66           (when (cdr condit)
  67             (cons v (cdr condit)))
  68           (list v nil)))
  69       ;V Collect variables and initializations V
  70       ;V to be used in the outer let form.     V
  71       :collect (if init-v (list v init-v) v) :into vlist
  72       :when a
  73       :collect (if adef (list a adef) a) :into vlist
  74       :collect (if tadef (list ta tadef) ta) :into vlist
  75       ;V The stuff for /post-inits/.V
  76       :nconc
  77       `(,ta ,(if tadef `(cdr (rplacd ,ta ,a-init-part))
  78                a-init-part))
  79       :into ilist
  80       :if condit
  81       :nconc default-val-setq :into ilist
  82       :and :collect
  83       `(if ,(if (consp condit) (car condit) v)
  84          (setq ,ta (cdr (rplacd ,ta (cons ,v nil)))
  85                ,@default-val-setq))
  86       :into condlist
  87       :else :nconc
  88       `(,ta (cdr (rplacd ,ta (cons ,v nil))))
  89       :into qlist
  90       :finally (setq pre-inits vlist
  91                      post-inits ilist
  92                      s-conditail-setqs condlist
  93                      tail-setqs qlist))
  94     ;V Handle regular do arguments.V
  95     (loop :for (v i a) :in do-args
  96           :collect (if i (list v i) v) :into vlist
  97           :when a :collect v :into alist
  98           :and :collect a :into alist
  99           :finally (nconc pre-inits vlist)
 100           (setq do-setqs alist))
 101     (loop :while (and (consp (car s-proc))
 102                       (eq 'declare (caar s-proc)))
 103           :collect (pop s-proc) :into decl
 104           :finally (setq s-declarations decl))
 105     `(let* (,@pre-inits);< All variable initializations.
 106        ,@s-declarations
 107        (unless ,s-pred
 108          ;V Run loop contents here only if the first V
 109          ;V value to accumulate is not specified.    V
 110          ,@(unless var-init-p s-proc)
 111          ;V Give all tails a value if they don't have one, V
 112          (setq ,@post-inits);< update some nil lists too.
 113          (tagbody
 114            ,begin-loop-tag
 115            (setq ,@do-setqs);< Normal do-loop updates.
 116            (if ,s-pred (go ,end-loop-tag))
 117            ,@s-proc;< Run inner loop.
 118            ,@s-conditail-setqs;< Conditional tail updates.
 119            (setq ,@tail-setqs);< Update all tails.
 120            (go ,begin-loop-tag)
 121            ,end-loop-tag))
 122        ;V Loop is over, run user's cleanup forms.V
 123        ,@s-cleanup)))
 124
 125 (defmacro cat2-fill
 126   (((arow s-arows)
 127     (brow s-brows)
 128     rows)
 129    s-cat
 130    (width
 131      (s-awidth s-azeros)
 132      (s-bwidth s-bzeros))
 133    s-return)
 134   (let ((row (gensym))
 135         (tail (gensym))
 136         (arem (gensym)) (brem (gensym))
 137         (finished (gensym)))
 138     `(tails-do*
 139        (((,row ,rows ,tail))
 140         (,arem ,s-arows (cdr ,arem))
 141         (,brem ,s-brows (cdr ,brem))
 142         (,finished nil (not (and ,arem ,brem))))
 143        (,finished
 144          (rplacd
 145            ,tail
 146            (if ,arem
 147              (let* (,@(when s-bwidth `((,width ,s-bwidth)))
 148                      (,brow ,s-bzeros))
 149                (mapcar #'(lambda (,arow) ,s-cat) ,arem))
 150              (when ,brem
 151                (let* (,@(when s-awidth `((,width ,s-awidth)))
 152                        (,arow ,s-azeros))
 153                  (mapcar #'(lambda (,brow) ,s-cat) ,brem)))))
 154          ,s-return)
 155        (let ((,arow (car ,arem))
 156              (,brow (car ,brem)))
 157          (setq ,row ,s-cat)))))
 158
 159
 160 (defmethod cat2 ((a number) (b number))
 161   (make-mtrix :dimdom 2 :dimcodom 1
 162               :elems (list (list a b))))
 163
 164 (defmethod vcat2 ((a number) (b number))
 165   (make-tuple :dim 2 :elems (list a b)))
 166
 167 (defmethod cat2 ((k number) (u tuple))
 168   (make-mtrix :dimdom 2 :dimcodom (tuple-dim u)
 169               :elems (mapcar #'(lambda (x) (list k x))
 170                              (tuple-elems u))))
 171
 172 (defmethod cat2 ((u tuple) (k number))
 173   (make-mtrix :dimdom 2 :dimcodom (tuple-dim u)
 174               :elems (mapcar #'(lambda (x) (list x k))
 175                              (tuple-elems u))))
 176
 177 (defmethod vcat2 ((k number) (u tuple))
 178   (make-tuple :dim (1+ (tuple-dim u))
 179               :elems (cons k (tuple-elems u))))
 180
 181 (defmethod vcat2 ((u tuple) (k number))
 182   (make-tuple :dim (1+ (tuple-dim u))
 183               :elems `(,@(tuple-elems u) ,k)))
 184
 185 ;V Align two tuples into a column matrix.V
 186 (defmethod cat2 ((u tuple) (v tuple))
 187   (cat2-fill
 188     ((uelem (tuple-elems u))
 189      (velem (tuple-elems v))
 190      rows)
 191     (list uelem velem)
 192     (nil (nil 0) (nil 0))
 193     (make-mtrix :dimdom 2
 194                 :dimcodom (max (tuple-dim u)
 195                                (tuple-dim v))
 196                 :elems rows)))
 197
 198 ;V Merge two tuples together into one long vector.V
 199 (defmethod vcat2 ((u tuple) (v tuple))
 200   (make-tuple :dim (+ (tuple-dim u) (tuple-dim v))
 201               :elems (append (tuple-elems u)
 202                              (tuple-elems v))))
 203
 204 ;V Add a column vector /u/ to  V
 205 ;V the left side of matrix /a/.V
 206 (defmethod cat2 ((u tuple) (a mtrix))
 207   (cat2-fill
 208     ((uelem (tuple-elems u))
 209      (arow (mtrix-elems a))
 210      rows)
 211     (cons uelem arow)
 212     (width
 213       (nil 0)
 214       ((mtrix-dimdom a)
 215        (make-list width :initial-element 0)))
 216     (make-mtrix :dimdom (1+ (mtrix-dimdom a))
 217                 :dimcodom (max (tuple-dim u)
 218                                (mtrix-dimcodom a))
 219                 :elems rows)))
 220
 221 (defmethod cat2 ((a mtrix) (u tuple))
 222   (cat2-fill
 223     ((arow (mtrix-elems a))
 224      (uelem (tuple-elems u))
 225      rows)
 226     `(,@arow ,uelem)
 227     (width
 228       ((mtrix-dimdom a)
 229        (make-list width :initial-element 0))
 230       (nil 0))
 231     (make-mtrix :dimdom (1+ (mtrix-dimdom a))
 232                 :dimcodom (mtrix-dimcodom a)
 233                 :elems rows)))
 234
 235 (defmethod cat2 ((a mtrix) (b mtrix))
 236   (cat2-fill
 237     ((arow (mtrix-elems a))
 238      (brow (mtrix-elems b))
 239      rows)
 240     (append arow brow)
 241     (width
 242       ((mtrix-dimdom a)
 243        (make-list width :initial-element 0))
 244       ((mtrix-dimdom b)
 245        (make-list width :initial-element 0)))
 246     (make-mtrix :dimdom (+ (mtrix-dimdom a)
 247                            (mtrix-dimdom b))
 248                 :dimcodom (max (mtrix-dimcodom a)
 249                                (mtrix-dimcodom b))
 250                 :elems rows)))
 251
 252 (defmethod vcat2 ((u tuple) (a mtrix))
 253   (let ((uwid (tuple-dim u))
 254         (awid (mtrix-dimdom a))
 255         (rows (cons (tuple-elems u)
 256                     (mtrix-elems a))))
 257     (if (< uwid awid)
 258       (rplaca rows
 259               (append
 260                 (car rows)
 261                 (make-list (- awid uwid)
 262                            :initial-element 0)))
 263       (unless (= uwid awid)
 264         (shiftf awid uwid (- uwid awid))
 265         (rplacd
 266           rows
 267           (mapcar
 268             #'(lambda (row)
 269                 (append
 270                   row
 271                   (make-list uwid :initial-element 0)))
 272             (cdr rows)))))
 273     (make-mtrix :dimdom awid
 274                 :dimcodom (1+ (mtrix-dimcodom a))
 275                 :elems rows)))
 276
 277 (defmethod vcat2 ((a mtrix) (u tuple))
 278   (let ((awid (mtrix-dimdom a))
 279         (uwid (tuple-dim u)))
 280     (make-mtrix
 281       :dimcodom (1+ (mtrix-dimcodom a))
 282       :elems
 283       (if (< uwid awid)
 284         `(,@(mtrix-elems a)
 285            ,(append (tuple-elems u)
 286                     (make-list (- awid uwid)
 287                                :initial-element 0)))
 288         (if (= uwid awid)
 289           `(,@(mtrix-elems a) ,(tuple-elems u))
 290           (progn
 291             (shiftf awid uwid (- uwid awid))
 292             (tails-do*
 293               (((row rows tail))
 294                (arem (mtrix-elems a) (cdr arem)))
 295               ((not arem)
 296                (rplacd tail (cons (tuple-elems u) nil))
 297                rows)
 298               (setq row
 299                     (append
 300                       (car arem)
 301                       (make-list
 302                         uwid :initial-element 0)))))))
 303       :dimdom awid)))
 304
 305 ;V Join a column of /k/'s onto the left of /a/.V
 306 (defmethod cat2 ((k number) (a mtrix))
 307   (make-mtrix
 308     :dimdom (1+ (mtrix-dimdom a))
 309     :dimcodom (mtrix-dimcodom a)
 310     :elems (mapcar #'(lambda (row) (cons k row))
 311                    (mtrix-elems a))))
 312
 313 ;V Join a column of /k/'s onto the right of /a/.V
 314 (defmethod cat2 ((a mtrix) (k number))
 315   (make-mtrix
 316     :dimdom (1+ (mtrix-dimdom a))
 317     :dimcodom (mtrix-dimcodom a)
 318     :elems (mapcar #'(lambda (row) `(,@row ,k))
 319                    (mtrix-elems a))))
 320
 321 ;V Join a row of /k/'s onto the top of /a/.V
 322 (defmethod vcat2 ((k number) (a mtrix))
 323   (make-mtrix
 324     :dimdom (mtrix-dimdom a)
 325     :dimcodom (1+ (mtrix-dimcodom a))
 326     :elems (cons (make-list (mtrix-dimdom a)
 327                             :initial-element k)
 328                  (mtrix-elems a))))
 329
 330 ;V Join a row of /k/'s onto the bottom of /a/.V
 331 (defmethod vcat2 ((a mtrix) (k number))
 332   (make-mtrix
 333     :dimdom (mtrix-dimdom a)
 334     :dimcodom (1+ (mtrix-dimcodom a))
 335     :elems `(,@(mtrix-elems a)
 336               ,(make-list (mtrix-dimdom a)
 337                           :initial-element k))))
 338
 339 (defmethod vcat2 ((a mtrix) (b mtrix))
 340   (let* ((awid (mtrix-dimdom a))
 341          (bwid (mtrix-dimdom b))
 342          (finwid (max awid bwid))
 343          (zeros (make-list (abs (- awid bwid))
 344                            :initial-element 0)))
 345     (make-mtrix
 346       :dimdom finwid
 347       :dimcodom (+ (mtrix-dimcodom a)
 348                    (mtrix-dimcodom b))
 349       :elems (append
 350                (if (= awid finwid) (mtrix-elems a)
 351                  (mapcar #'(lambda (row)
 352                              (append row zeros))
 353                          (mtrix-elems a)))
 354                (if (= bwid finwid) (mtrix-elems b)
 355                  (mapcar #'(lambda (row)
 356                              (append row zeros))
 357                          (mtrix-elems b)))))))
 358
 359