src/overload/crop.lisp

   1
   2 (defmethod over-crop ((n integer) (u tuple))
   3   (declare (ignore n)) u)
   4 (defmethod over-crop ((u tuple) (n integer))
   5   (declare (ignore n)) u)
   6
   7 (defmethod over-crop ((u list) n)
   8   (declare (ignore n)) u)
   9 (defmethod over-crop (n (u list))
  10   (declare (ignore n)) u)
  11
  12 (defmethod over-vcrop ((n integer) (u tuple))
  13   (if (= 1 n)
  14     (car (tuple-elems u))
  15     (loop :with dim = (min n (tuple-dim u))
  16           :for elem :in (tuple-elems u)
  17           :repeat dim
  18           :collect elem :into elems
  19           :finally
  20           (return (make-tuple :dim dim :elems elems)))))
  21
  22 (defmethod over-vcrop (n (u list))
  23   (over-vcrop n (tuple-list u)))
  24
  25
  26 (defmethod over-vcrop ((u tuple) (n integer))
  27   (if (= 1 n)
  28     (car (last (tuple-elems u)))
  29     (let ((dim (min n (tuple-dim u))))
  30       (make-tuple :dim dim
  31                   :elems (nthcdr (- (tuple-dim u) dim)
  32                                  (tuple-elems u))))))
  33
  34 (defmethod over-vcrop ((u list) n)
  35   (over-vcrop (tuple-list u) n))
  36
  37
  38 (defmethod over-crop ((n integer) (a mtrix))
  39   (if (= n 1)
  40     (make-tuple
  41       :dim (mtrix-dimcodom a)
  42       :elems (mapcar #'car (mtrix-elems a)))
  43     (loop
  44       :with width = (min n (mtrix-dimdom a))
  45       :for row :in (mtrix-elems a)
  46       :collect (loop :for elem :in row
  47                      :repeat width
  48                      :collect elem)
  49       :into rows
  50       :finally
  51       (return (make-mtrix
  52                 :dimdom width
  53                 :dimcodom (mtrix-dimcodom a)
  54                 :elems rows)))))
  55
  56 (defmethod over-crop ((a mtrix) (n integer))
  57   (if (= n 1)
  58     (make-tuple
  59       :dim (mtrix-dimcodom a)
  60       :elems (mapcar (lambda (row) (car (last row)))
  61                      (mtrix-elems a)))
  62     (loop
  63       :with width = (min n (mtrix-dimdom a))
  64       :with prune-count = (- (mtrix-dimdom a) width)
  65       :for row :in (mtrix-elems a)
  66       :collect (nthcdr prune-count row) :into rows
  67       :finally
  68       (return (make-mtrix
  69                 :dimdom width
  70                 :dimcodom (mtrix-dimcodom a)
  71                 :elems rows)))))
  72
  73 (defmethod over-vcrop ((n integer) (a mtrix))
  74   (let ((height (min n (mtrix-dimcodom a))))
  75     (make-mtrix
  76       :dimdom (mtrix-dimdom a)
  77       :dimcodom height
  78       :elems (loop :for row :in (mtrix-elems a)
  79                    :repeat height
  80                    :collect row))))
  81
  82 (defmethod over-vcrop ((a mtrix) (n integer))
  83   (let ((height (min n (mtrix-dimcodom a))))
  84     (make-mtrix
  85       :dimdom (mtrix-dimdom a)
  86       :dimcodom height
  87       :elems (nthcdr (- (mtrix-dimcodom a) height)
  88                      (mtrix-elems a)))))
  89
  90 (defmethod over-crop :around ((a integer) b)
  91   (if (plusp a) (call-next-method a b)
  92     (throw 'over-ex "Can only crop a positive number of columns.")))
  93 (defmethod over-crop :around (a (b integer))
  94   (if (plusp b) (call-next-method a b)
  95     (throw 'over-ex "Can only crop a positive number of columns.")))
  96
  97 (defmethod over-vcrop :around ((a integer) b)
  98   (if (plusp a) (call-next-method a b)
  99     (throw 'over-ex "Can only vcrop a positive number of rows.")))
 100 (defmethod over-vcrop :around (a (b integer))
 101   (if (plusp b) (call-next-method a b)
 102     (throw 'over-ex "Can only vcrop a positive number of rows.")))
 103
 104 (defmethod over-crop (a b)
 105   (throw 'over-ex
 106          (format nil "crop usage: (crop [n] [thing]) ~
 107                  or (crop [thing] [n])~%where [n] is ~
 108                  the number of columns you want.")))
 109
 110 (defmethod over-vcrop (a b)
 111   (throw 'over-ex
 112          (format nil "vcrop usage: (vcrop [n] [thing]) ~
 113                  or (vcrop [thing] [n])~%where [n] is ~
 114                  the number of rows you want.")))
 115