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)))
 141               (plusp (length sequence)))
 142          (setf (elt sequence 0) object))
 143         (t
 144          (error 'type-error
 145                 :datum sequence
 146                 :expected-type '(and sequence (not (satisfies emptyp)))))))
 147
 148 (defun last-elt (sequence)
 149   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 150 not a proper sequence, or is an empty sequence."
 151   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 152   ;; type-error.
 153   (let ((len 0))
 154     (cond ((consp sequence)
 155            (lastcar sequence))
 156           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 157            (elt sequence (1- len)))
 158           (t
 159            (error 'type-error
 160                   :datum sequence
 161                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 162
 163 (defun (setf last-elt) (object sequence)
 164   "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
 165 sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 166   (let ((len 0))
 167     (cond ((consp sequence)
 168            (setf (lastcar sequence) object))
 169           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 170            (setf (elt sequence (1- len)) object))
 171           (t
 172            (error 'type-error
 173                   :datum sequence
 174                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 175
 176 (defun starts-with-subseq (sequence prefix &rest args &key (return-suffix nil) &allow-other-keys)
 177   "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
 178
 179 If RETURN-SUFFIX is T the functions returns, as a second value, a
 180 displaced array pointing to the sequence after PREFIX."
 181   (remove-from-plistf args :return-suffix)
 182   (let ((sequence-length (length sequence))
 183         (prefix-length (length prefix)))
 184     (if (<= prefix-length sequence-length)
 185         (let ((mismatch (apply #'mismatch sequence prefix args)))
 186           (if mismatch
 187               (if (< mismatch prefix-length)
 188                   (values nil nil)
 189                   (values t (when return-suffix
 190                               (make-array (- sequence-length mismatch)
 191                                           :element-type (array-element-type sequence)
 192                                           :displaced-to sequence
 193                                           :displaced-index-offset prefix-length
 194                                           :adjustable nil))))
 195               (values t (when return-suffix
 196                           (make-array 0 :element-type (array-element-type sequence)
 197                                       :adjustable nil)))))
 198         (values nil nil))))
 199
 200 (defun ends-with-subseq (sequence suffix &key (test #'eql))
 201   "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
 202 the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
 203   (let ((sequence-length (length sequence))
 204         (suffix-length (length suffix)))
 205     (when (< sequence-length suffix-length)
 206       ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
 207       (return-from ends-with-subseq nil))
 208     (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
 209           for suffix-index from 0 below suffix-length
 210           when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
 211           do (return-from ends-with-subseq nil)
 212           finally (return t))))
 213
 214 (defun starts-with (object sequence &key (test #'eql) (key #'identity))
 215   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 216 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 217   (funcall test
 218            (funcall key
 219                     (typecase sequence
 220                       (cons (car sequence))
 221                       (sequence
 222                        (if (plusp (length sequence))
 223                            (elt sequence 0)
 224                            (return-from starts-with nil)))
 225                       (t
 226                        (return-from starts-with nil))))
 227            object))
 228
 229 (defun ends-with (object sequence &key (test #'eql) (key #'identity))
 230   "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 231 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 232 an error if SEQUENCE is an improper list."
 233   (funcall test
 234            (funcall key
 235                     (typecase sequence
 236                       (cons
 237                        ;; signals for improper lists
 238                        (lastcar sequence))
 239                       (sequence
 240                        ;; Can't use last-elt, as that signals an error for empty sequences
 241                        (let ((len (length sequence)))
 242                          (if (plusp len)
 243                              (elt sequence (1- len))
 244                              (return-from ends-with nil))))
 245                       (t
 246                        (return-from ends-with nil))))
 247            object))
 248
 249 (defun map-combinations (function sequence &key (start 0) end length (copy t))
 250   "Calls FUNCTION with each combination of LENGTH constructable from the
 251 elements of the subsequence of SEQUENCE delimited by START and END. START
 252 defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
 253 delimited subsequence. (So unless LENGTH is specified there is only a single
 254 combination, which has the same elements as the delimited subsequence.) If
 255 COPY is true (the default) each combination is freshly allocated. If COPY is
 256 false all combinations are EQ to each other, in which case consequences are
 257 specified if a combination is modified by FUNCTION."
 258   (let* ((end (or end (length sequence)))
 259          (size (- end start))
 260          (length (or length size))
 261          (combination (subseq sequence 0 length))
 262          (function (ensure-function function)))
 263     (if (= length size)
 264         (funcall function combination)
 265         (flet ((call ()
 266                  (funcall function (if copy
 267                                        (copy-seq combination)
 268                                        combination))))
 269           (etypecase sequence
 270             ;; When dealing with lists we prefer walking back and
 271             ;; forth instead of using indexes.
 272             (list
 273              (labels ((combine-list (c-tail o-tail)
 274                         (if (not c-tail)
 275                             (call)
 276                             (do ((tail o-tail (cdr tail)))
 277                                 ((not tail))
 278                               (setf (car c-tail) (car tail))
 279                               (combine-list (cdr c-tail) (cdr tail))))))
 280                (combine-list combination (nthcdr start sequence))))
 281             (vector
 282              (labels ((combine (count start)
 283                         (if (zerop count)
 284                             (call)
 285                             (loop for i from start below end
 286                                   do (let ((j (- count 1)))
 287                                        (setf (aref combination j) (aref sequence i))
 288                                        (combine j (+ i 1)))))))
 289                (combine length start)))
 290             (sequence
 291              (labels ((combine (count start)
 292                         (if (zerop count)
 293                             (call)
 294                             (loop for i from start below end
 295                                   do (let ((j (- count 1)))
 296                                        (setf (elt combination j) (elt sequence i))
 297                                        (combine j (+ i 1)))))))
 298                (combine length start)))))))
 299   sequence)
 300
 301 (defun map-permutations (function sequence &key (start 0) end length (copy t))
 302   "Calls function with each permutation of LENGTH constructable
 303 from the subsequence of SEQUENCE delimited by START and END. START
 304 defaults to 0, END to length of the sequence, and LENGTH to the
 305 length of the delimited subsequence."
 306   (let* ((end (or end (length sequence)))
 307          (size (- end start))
 308          (length (or length size)))
 309     (labels ((permute (seq n)
 310                (let ((n-1 (- n 1)))
 311                  (if (zerop n-1)
 312                      (funcall function (if copy
 313                                            (copy-seq seq)
 314                                            seq))
 315                      (if (evenp n-1)
 316                          (loop for i from 0 upto n-1
 317                                do (permute seq n-1)
 318                                   (if (evenp n-1)
 319                                       (rotatef (elt seq 0) (elt seq n-1))
 320                                       (rotatef (elt seq i) (elt seq n-1))))))))
 321              (permute-sequence (seq)
 322                (permute seq length)))
 323       (if (= length size)
 324           ;; Things are simple if we need to just permute the
 325           ;; full START-END range.
 326           (permute-sequence (subseq sequence start end))
 327           ;; Otherwise we need to generate all the combinations
 328           ;; of LENGTH in the START-END range, and then permute
 329           ;; a copy of the result: can't permute the combination
 330           ;; directly, as they share structure with each other.
 331           (let ((permutation (subseq sequence 0 length)))
 332             (flet ((permute-combination (combination)
 333                      (permute-sequence (replace permutation combination))))
 334               (declare (dynamic-extent #'permute-combination))
 335               (map-combinations #'permute-combination sequence
 336                                 :start start
 337                                 :end end
 338                                 :length length
 339                                 :copy nil)))))))
 340
 341 (defun map-derangements (function sequence &key (start 0) end (copy t))
 342   "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
 343 by the bounding index designators START and END. Derangement is a permutation
 344 of the sequence where no element remains in place. SEQUENCE is not modified,
 345 but individual derangements are EQ to each other. Consequences are unspecified
 346 if calling FUNCTION modifies either the derangement or SEQUENCE."
 347   (let* ((end (or end (length sequence)))
 348          (size (- end start))
 349          ;; We don't really care about the elements here.
 350          (derangement (subseq sequence 0 size))
 351          ;; Bitvector that has 1 for elements that have been deranged.
 352          (mask (make-array size :element-type 'bit :initial-element 0)))
 353     (declare (dynamic-extent mask))
 354     ;; ad hoc algorith
 355     (labels ((derange (place n)
 356                ;; Perform one recursive step in deranging the
 357                ;; sequence: PLACE is index of the original sequence
 358                ;; to derange to another index, and N is the number of
 359                ;; indexes not yet deranged.
 360                (if (zerop n)
 361                    (funcall function (if copy
 362                                          (copy-seq derangement)
 363                                          derangement))
 364                    ;; Itarate over the indexes I of the subsequence to
 365                    ;; derange: if I != PLACE and I has not yet been
 366                    ;; deranged by an earlier call put the element from
 367                    ;; PLACE to I, mark I as deranged, and recurse,
 368                    ;; finally removing the mark.
 369                    (loop for i from 0 below size
 370                          do
 371                          (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
 372                            (setf (elt derangement i) (elt sequence place)
 373                                  (bit mask i) 1)
 374                            (derange (1+ place) (1- n))
 375                            (setf (bit mask i) 0))))))
 376       (derange start size)
 377       sequence)))