sequences.lisp

   1 (in-package :alexandria)
   2
   3 (defun rotate-tail-to-head (sequence n)
   4   (declare (type (integer 1) n))
   5   (if (listp sequence)
   6       (let ((m (mod n (list-length sequence))))
   7         (if (null (cdr sequence))
   8             sequence
   9             (let* ((tail (last sequence (+ m 1)))
  10                    (last (cdr tail)))
  11               (setf (cdr tail) nil)
  12               (nconc last sequence))))
  13       (let* ((len (length sequence))
  14              (m (mod n len))
  15              (tail (subseq sequence (- len m))))
  16         (replace sequence sequence :start1 m :start2 0)
  17         (replace sequence tail)
  18         sequence)))
  19
  20 (defun rotate-head-to-tail (sequence n)
  21   (declare (type (integer 1) n))
  22   (if (listp sequence)
  23       (let ((m (mod (1- n) (list-length sequence))))
  24         (if (null (cdr sequence))
  25             sequence
  26             (let* ((headtail (nthcdr m sequence))
  27                    (tail (cdr headtail)))
  28               (setf (cdr headtail) nil)
  29               (nconc tail sequence))))
  30       (let* ((len (length sequence))
  31              (m (mod n len))
  32              (head (subseq sequence 0 m)))
  33         (replace sequence sequence :start1 0 :start2 m)
  34         (replace sequence head :start1 (- len m))
  35         sequence)))
  36
  37 (defun rotate (sequence &optional (n 1))
  38   "Returns a sequence of the same type as SEQUENCE, with the elements of
  39 SEQUENCE rotated by N: N elements are moved from the end of the sequence to
  40 the front if N is positive, and -N elements moved from the front to the end if
  41 N is negative. SEQUENCE must be a proper sequence. N must be an integer,
  42 defaulting to 1. If absolute value of N is greater then the length of the
  43 sequence, the results are identical to calling ROTATE with (* (SIGNUM N) (MOD
  44 N (LENGTH SEQUENCE))). The original sequence may be destructively altered, and
  45 result sequence may share structure with it."
  46   (if (plusp n)
  47       (rotate-tail-to-head sequence n)
  48       (if (minusp n)
  49           (rotate-head-to-tail sequence (- n))
  50           sequence)))
  51
  52 (defun shuffle (sequence &key (start 0) end)
  53   "Returns a random permutation of SEQUENCE bounded by START and END.
  54 Permuted sequence may share storage with the original one. Signals
  55 an error if SEQUENCE is not a proper sequence."
  56   (declare (fixnum start) ((or fixnum null) end))
  57   (let ((end (or end (if (listp sequence) (list-length sequence) (length sequence)))))
  58     (loop for i from start below end
  59        do (rotatef (elt sequence i) (elt sequence (random end)))))
  60   sequence)
  61
  62 (defun random-elt (sequence &key (start 0) end)
  63   "Returns a random element from SEQUENCE bounded by START and END. Signals an
  64 error if the SEQUENCE is not a proper sequence."
  65   (declare (sequence sequence) (fixnum start) ((or fixnum null) end))
  66   (let ((i (+ start (random (- (or end  (if (listp sequence)
  67                                             (list-length sequence)
  68                                             (length sequence)))
  69                                start)))))
  70     (elt sequence i)))
  71
  72 (define-modify-macro removef (item &rest remove-keywords)
  73   (lambda (seq item &rest keyword-arguments)
  74     (apply #'remove item seq keyword-arguments))
  75   "Modify-macro for REMOVE. Sets place designated by the first argument to
  76 the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")
  77
  78 (define-modify-macro deletef (item &rest remove-keywords)
  79   (lambda (seq item &rest keyword-arguments)
  80     (apply #'delete item seq keyword-arguments))
  81   "Modify-macro for DELETE. Sets place designated by the first argument to
  82 the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")
  83
  84 (deftype proper-sequence ()
  85   "Type designator for proper sequences, that is proper lists and sequences
  86 that are not lists."
  87   `(or proper-list
  88        (and (not list) sequence)))
  89
  90 (defun emptyp (sequence)
  91   "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
  92 is not a sequence"
  93   (etypecase sequence
  94     (list (null sequence))
  95     (sequence (zerop (length sequence)))))
  96
  97 (defun sequence-of-length-p (sequence length)
  98   "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
  99 SEQUENCE is not a sequence. Returns FALSE for circular lists."
 100   (etypecase sequence
 101     (null
 102      (zerop length))
 103     (cons
 104      (let ((n (1- length)))
 105        (unless (minusp n)
 106          (let ((tail (nthcdr n sequence)))
 107            (and tail (null (cdr tail)))))))
 108     (sequence
 109      (= length (length sequence)))))
 110
 111 (declaim (inline copy-sequence))
 112 (defun copy-sequence (type sequence)
 113   "Returns a fresh sequence of TYPE, which has the same elements as
 114 SEQUENCE."
 115   (if (typep sequence type)
 116       (copy-seq sequence)
 117       (coerce sequence type)))
 118
 119 (defun first-elt (sequence)
 120   "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 121 not a sequence, or is an empty sequence."
 122   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 123   ;; type-error.
 124   (cond  ((consp sequence)
 125           (car sequence))
 126          ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
 127           (elt sequence 0))
 128          (t
 129           (error 'type-error
 130                  :datum sequence
 131                  :expected-type '(and sequence (not (satisfies emptyp)))))))
 132
 133 (defun (setf first-elt) (object sequence)
 134   "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 135 not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 136   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 137   ;; type-error.
 138   (cond ((consp sequence)
 139          (setf (car sequence) object))
 140         ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
 141          (setf (elt sequence 0) object))
 142         (t
 143          (error 'type-error
 144                 :datum sequence
 145                 :expected-type '(and proper-sequence (not (satisfies emptyp)))))))
 146
 147 (defun last-elt (sequence)
 148   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 149 not a proper sequence, or is an empty sequence."
 150   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 151   ;; type-error.
 152   (let ((len 0))
 153     (cond ((consp sequence)
 154            (lastcar sequence))
 155           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 156            (elt sequence (1- len)))
 157           (t
 158            (error 'type-error
 159                   :datum sequence
 160                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 161
 162 (defun (setf last-elt) (object sequence)
 163   "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
 164 sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 165   (let ((len 0))
 166     (cond ((consp sequence)
 167            (setf (lastcar sequence) object))
 168           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 169            (setf (elt sequence (1- len)) object))
 170           (t
 171            (error 'type-error
 172                   :datum sequence
 173                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 174
 175 (defun starts-with (object sequence &key (test #'eql) (key #'identity))
 176   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 177 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 178   (funcall test
 179            (funcall key
 180                     (typecase sequence
 181                       (cons (car sequence))
 182                       (sequence
 183                        (if (plusp (length sequence))
 184                            (elt sequence 0)
 185                            (return-from starts-with nil)))
 186                       (t
 187                        (return-from starts-with nil))))
 188            object))
 189
 190 (defun ends-with (object sequence &key (test #'eql) (key #'identity))
 191   "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 192 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 193 an error if SEQUENCE is an improper list."
 194   (funcall test
 195            (funcall key
 196                     (typecase sequence
 197                       (cons
 198                        ;; signals for improper lists
 199                        (lastcar sequence))
 200                       (sequence
 201                        ;; Can't use last-elt, as that signals an error for empty sequences
 202                        (let ((len (length sequence)))
 203                          (if (plusp len)
 204                              (elt sequence (1- len))
 205                              (return-from ends-with nil))))
 206                       (t
 207                        (return-from ends-with nil))))
 208            object))