sequences.lisp

   1 (in-package :alexandria)
   2
   3 (defun rotate-left (sequence &optional (n 1))
   4   "Rotates the SEQUENCE to left by N, by moving N elements from the end of the
   5 sequence to the front. Resulting sequence may share structure with the
   6 original one. N defaults to 1. Sequence must be a proper sequence. N can be
   7 creater then the length of sequence."
   8   (if (listp sequence)
   9       (let ((m (mod n (list-length sequence))))
  10         (if (null (cdr sequence))
  11             sequence
  12             (let* ((tail (last sequence (+ m 1)))
  13                    (last (cdr tail)))
  14               (setf (cdr tail) nil)
  15               (nconc last sequence))))
  16       (let* ((len (length sequence))
  17              (m (mod n len))
  18              (tail (subseq sequence (- len m))))
  19         (replace sequence sequence :start1 m :start2 0)
  20         (replace sequence tail)
  21         sequence)))
  22
  23 (defun rotate-right (sequence &optional (n 1))
  24     "Rotates the SEQUENCE to right by N, by moving N element from the front of
  25 the sequence to the end. Resulting sequence may share structure with the
  26 original one. N defaults to 1."
  27   (if (listp sequence)
  28       (let ((m (mod (1- n) (list-length sequence))))
  29         (if (null (cdr sequence))
  30             sequence
  31             (let* ((headtail (nthcdr m sequence))
  32                    (tail (cdr headtail)))
  33               (setf (cdr headtail) nil)
  34               (nconc tail sequence))))
  35       (let* ((len (length sequence))
  36              (m (mod n len))
  37              (head (subseq sequence 0 m)))
  38         (replace sequence sequence :start1 0 :start2 m)
  39         (replace sequence head :start1 (- len m))
  40         sequence)))
  41
  42 (defun suffle (sequence &key (start 0) end)
  43   "Returns a radom permutation of SEQUENCE bounded by START and END.
  44 Permuted sequence may share storage with the original one. Signals
  45 an error if SEQUENCE is not a proper sequence."
  46   (declare (fixnum start) ((or fixnum null) end))
  47   (let ((end (or end (if (listp sequence) (list-length sequence) (length sequence)))))
  48     (loop for i from start below end
  49        do (rotatef (elt sequence i) (elt sequence (random end)))))
  50   sequence)
  51
  52 (defun random-elt (sequence &key (start 0) end)
  53   "Returns a random element from SEQUENCE bounded by START and END. Signals an
  54 error if the SEQUENCE is not a proper sequence."
  55   (declare (sequence sequence) (fixnum start) ((or fixnum null) end))
  56   (let ((i (+ start (random (- (or end  (if (listp sequence)
  57                                             (list-length sequence)
  58                                             (length sequence)))
  59                                start)))))
  60     (elt sequence i)))
  61
  62 (define-modify-macro removef (item &rest remove-keywords)
  63   (lambda (seq item &rest keyword-arguments)
  64     (apply #'remove item seq keyword-arguments))
  65   "Modify-macro for REMOVE. Sets place designated by the first argument to
  66 the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")
  67
  68 (define-modify-macro deletef (item &rest remove-keywords)
  69   (lambda (seq item &rest keyword-arguments)
  70     (apply #'delete item seq keyword-arguments))
  71   "Modify-macro for DELETE. Sets place designated by the first argument to
  72 the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")
  73
  74 (deftype proper-sequence ()
  75   "Type designator for proper sequences, that is proper lists and sequences
  76 that are not lists."
  77   `(or proper-list
  78        (and (not list) sequence)))
  79
  80 (defun emptyp (sequence)
  81   "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
  82 is not a sequence"
  83   (etypecase sequence
  84     (list (null sequence))
  85     (sequence (zerop (length sequence)))))
  86
  87 (defun sequence-of-length-p (sequence length)
  88   "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
  89 SEQUENCE is not a sequence. Returns FALSE for circular lists."
  90   (etypecase sequence
  91     (null
  92      (zerop length))
  93     (cons
  94      (let ((n (1- length)))
  95        (unless (minusp n)
  96          (let ((tail (nthcdr n sequence)))
  97            (and tail (null (cdr tail)))))))
  98     (sequence
  99      (= length (length sequence)))))
 100
 101 (declaim (inline copy-sequence))
 102 (defun copy-sequence (type sequence)
 103   "Returns a fresh sequence of TYPE, which has the same elements as
 104 SEQUENCE."
 105   (if (typep sequence type)
 106       (copy-seq sequence)
 107       (coerce sequence type)))
 108
 109 (defun first-elt (sequence)
 110   "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 111 not a sequence, or is an empty sequence."
 112   (cond  ((consp sequence)
 113           (car sequence))
 114          ((and (vectorp sequence) (plusp (length sequence)))
 115           (aref sequence 0))
 116          (t
 117           (error 'type-error
 118                  :datum sequence
 119                  :expected-type '(and sequence (not (satisfies emptyp)))))))
 120
 121 (defun last-elt (sequence)
 122   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 123 not a proper sequence, or is an empty sequence."
 124   (declare (inline lastcar))
 125   (let ((len 0))
 126     (cond ((consp sequence)
 127            (lastcar sequence))
 128           ((and (vectorp sequence) (plusp (setf len (length sequence))))
 129            (aref sequence (1- len)))
 130          (t
 131           (error 'type-error
 132                  :datum sequence
 133                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 134
 135 (defun starts-with (object sequence)
 136   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 137 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 138   (eql (typecase sequence
 139          (cons (car sequence))
 140          (sequence
 141           (if (plusp (length sequence))
 142               (elt sequence 0)
 143               (return-from starts-with nil)))
 144          (t
 145           (return-from starts-with nil)))
 146        object))
 147
 148 (defun ends-with (object sequence)
 149   "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 150 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 151 an error if SEQUENCE is an improper list."
 152   (eql (typecase sequence
 153          (cons
 154           ;; signals for improper lists
 155           (lastcar sequence))
 156          (sequence
 157           ;; Can't use last-elt, as that signals an error for empty sequences
 158           (let ((len (length sequence)))
 159             (if (plusp len)
 160                 (elt sequence (1- len))
 161                 (return-from ends-with nil))))
 162          (t
 163           (return-from ends-with nil)))
 164        object))