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