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 suffle (sequence &key (start 0) end)
  53   "Returns a radom 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   (cond  ((consp sequence)
 123           (car sequence))
 124          ((and (vectorp sequence) (plusp (length sequence)))
 125           (aref sequence 0))
 126          (t
 127           (error 'type-error
 128                  :datum sequence
 129                  :expected-type '(and sequence (not (satisfies emptyp)))))))
 130
 131 (defun last-elt (sequence)
 132   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 133 not a proper sequence, or is an empty sequence."
 134   (declare (inline lastcar))
 135   (let ((len 0))
 136     (cond ((consp sequence)
 137            (lastcar sequence))
 138           ((and (vectorp sequence) (plusp (setf len (length sequence))))
 139            (aref sequence (1- len)))
 140          (t
 141           (error 'type-error
 142                  :datum sequence
 143                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 144
 145 (defun starts-with (object sequence)
 146   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 147 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 148   (eql (typecase sequence
 149          (cons (car sequence))
 150          (sequence
 151           (if (plusp (length sequence))
 152               (elt sequence 0)
 153               (return-from starts-with nil)))
 154          (t
 155           (return-from starts-with nil)))
 156        object))
 157
 158 (defun ends-with (object sequence)
 159   "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 160 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 161 an error if SEQUENCE is an improper list."
 162   (eql (typecase sequence
 163          (cons
 164           ;; signals for improper lists
 165           (lastcar sequence))
 166          (sequence
 167           ;; Can't use last-elt, as that signals an error for empty sequences
 168           (let ((len (length sequence)))
 169             (if (plusp len)
 170                 (elt sequence (1- len))
 171                 (return-from ends-with nil))))
 172          (t
 173           (return-from ends-with nil)))
 174        object))