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 an
  55 error if SEQUENCE is not a proper sequence."
  56   (declare (fixnum start) (type (or fixnum null) end))
  57   (typecase sequence
  58     (list
  59      (let* ((end (or end (list-length sequence)))
  60             (n (- end start)))
  61        (do ((tail (nthcdr start sequence) (cdr tail)))
  62            ((zerop n))
  63          (rotatef (car tail) (car (nthcdr (random n) tail)))
  64          (decf n))))
  65     (vector
  66      (let ((end (or end (length sequence))))
  67        (loop for i from (- end 1) downto start
  68              do (rotatef (aref sequence i) (aref sequence (random (+ i 1)))))))
  69     (sequence
  70      (let ((end (or end (length sequence))))
  71        (loop for i from (- end 1) downto start
  72              do (rotatef (elt sequence i) (elt sequence (random (+ i 1))))))))
  73   sequence)
  74
  75 (defun random-elt (sequence &key (start 0) end)
  76   "Returns a random element from SEQUENCE bounded by START and END. Signals an
  77 error if the SEQUENCE is not a proper sequence."
  78   (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
  79   (let ((i (+ start (random (- (or end  (if (listp sequence)
  80                                             (list-length sequence)
  81                                             (length sequence)))
  82                                start)))))
  83     (elt sequence i)))
  84
  85 (declaim (inline remove/swapped-arguments))
  86 (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
  87   (apply #'remove item sequence keyword-arguments))
  88
  89 (define-modify-macro removef (item &rest remove-keywords)
  90   remove/swapped-arguments
  91   "Modify-macro for REMOVE. Sets place designated by the first argument to
  92 the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")
  93
  94 (declaim (inline delete/swapped-arguments))
  95 (defun delete/swapped-arguments (sequence item &rest keyword-arguments)
  96   (apply #'delete item sequence keyword-arguments))
  97
  98 (define-modify-macro deletef (item &rest remove-keywords)
  99   delete/swapped-arguments
 100   "Modify-macro for DELETE. Sets place designated by the first argument to
 101 the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")
 102
 103 (deftype proper-sequence ()
 104   "Type designator for proper sequences, that is proper lists and sequences
 105 that are not lists."
 106   `(or proper-list
 107        (and (not list) sequence)))
 108
 109 (defun emptyp (sequence)
 110   "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
 111 is not a sequence"
 112   (etypecase sequence
 113     (list (null sequence))
 114     (sequence (zerop (length sequence)))))
 115
 116 (defun sequence-of-length-p (sequence length)
 117   "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
 118 SEQUENCE is not a sequence. Returns FALSE for circular lists."
 119   (etypecase sequence
 120     (null
 121      (zerop length))
 122     (cons
 123      (let ((n (1- length)))
 124        (unless (minusp n)
 125          (let ((tail (nthcdr n sequence)))
 126            (and tail (null (cdr tail)))))))
 127     (sequence
 128      (= length (length sequence)))))
 129
 130 (declaim (inline copy-sequence))
 131 (defun copy-sequence (type sequence)
 132   "Returns a fresh sequence of TYPE, which has the same elements as
 133 SEQUENCE."
 134   (if (typep sequence type)
 135       (copy-seq sequence)
 136       (coerce sequence type)))
 137
 138 (defun first-elt (sequence)
 139   "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 140 not a sequence, or is an empty sequence."
 141   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 142   ;; type-error.
 143   (cond  ((consp sequence)
 144           (car sequence))
 145          ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
 146           (elt sequence 0))
 147          (t
 148           (error 'type-error
 149                  :datum sequence
 150                  :expected-type '(and sequence (not (satisfies emptyp)))))))
 151
 152 (defun (setf first-elt) (object sequence)
 153   "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 154 not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 155   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 156   ;; type-error.
 157   (cond ((consp sequence)
 158          (setf (car sequence) object))
 159         ((and (typep sequence '(and sequence (not list)))
 160               (plusp (length sequence)))
 161          (setf (elt sequence 0) object))
 162         (t
 163          (error 'type-error
 164                 :datum sequence
 165                 :expected-type '(and sequence (not (satisfies emptyp)))))))
 166
 167 (defun last-elt (sequence)
 168   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 169 not a proper sequence, or is an empty sequence."
 170   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 171   ;; type-error.
 172   (let ((len 0))
 173     (cond ((consp sequence)
 174            (lastcar sequence))
 175           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 176            (elt sequence (1- len)))
 177           (t
 178            (error 'type-error
 179                   :datum sequence
 180                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 181
 182 (defun (setf last-elt) (object sequence)
 183   "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
 184 sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 185   (let ((len 0))
 186     (cond ((consp sequence)
 187            (setf (lastcar sequence) object))
 188           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 189            (setf (elt sequence (1- len)) object))
 190           (t
 191            (error 'type-error
 192                   :datum sequence
 193                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 194
 195 (defun starts-with-subseq (prefix sequence &rest args &key (return-suffix nil) &allow-other-keys)
 196   "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
 197
 198 If RETURN-SUFFIX is T the functions returns, as a second value, a
 199 displaced array pointing to the sequence after PREFIX."
 200   (remove-from-plistf args :return-suffix)
 201   (let ((sequence-length (length sequence))
 202         (prefix-length (length prefix)))
 203     (if (<= prefix-length sequence-length)
 204         (let ((mismatch (apply #'mismatch sequence prefix args)))
 205           (if mismatch
 206               (if (< mismatch prefix-length)
 207                   (values nil nil)
 208                   (values t (when return-suffix
 209                               (make-array (- sequence-length mismatch)
 210                                           :element-type (array-element-type sequence)
 211                                           :displaced-to sequence
 212                                           :displaced-index-offset prefix-length
 213                                           :adjustable nil))))
 214               (values t (when return-suffix
 215                           (make-array 0 :element-type (array-element-type sequence)
 216                                       :adjustable nil)))))
 217         (values nil nil))))
 218
 219 (defun ends-with-subseq (suffix sequence &key (test #'eql))
 220   "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
 221 the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
 222   (let ((sequence-length (length sequence))
 223         (suffix-length (length suffix)))
 224     (when (< sequence-length suffix-length)
 225       ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
 226       (return-from ends-with-subseq nil))
 227     (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
 228           for suffix-index from 0 below suffix-length
 229           when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
 230           do (return-from ends-with-subseq nil)
 231           finally (return t))))
 232
 233 (defun starts-with (object sequence &key (test #'eql) (key #'identity))
 234   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 235 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 236   (funcall test
 237            (funcall key
 238                     (typecase sequence
 239                       (cons (car sequence))
 240                       (sequence
 241                        (if (plusp (length sequence))
 242                            (elt sequence 0)
 243                            (return-from starts-with nil)))
 244                       (t
 245                        (return-from starts-with nil))))
 246            object))
 247
 248 (defun ends-with (object sequence &key (test #'eql) (key #'identity))
 249   "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 250 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 251 an error if SEQUENCE is an improper list."
 252   (funcall test
 253            (funcall key
 254                     (typecase sequence
 255                       (cons
 256                        ;; signals for improper lists
 257                        (lastcar sequence))
 258                       (sequence
 259                        ;; Can't use last-elt, as that signals an error
 260                        ;; for empty sequences
 261                        (let ((len (length sequence)))
 262                          (if (plusp len)
 263                              (elt sequence (1- len))
 264                              (return-from ends-with nil))))
 265                       (t
 266                        (return-from ends-with nil))))
 267            object))
 268
 269 (defun map-combinations (function sequence &key (start 0) end length (copy t))
 270   "Calls FUNCTION with each combination of LENGTH constructable from the
 271 elements of the subsequence of SEQUENCE delimited by START and END. START
 272 defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
 273 delimited subsequence. (So unless LENGTH is specified there is only a single
 274 combination, which has the same elements as the delimited subsequence.) If
 275 COPY is true (the default) each combination is freshly allocated. If COPY is
 276 false all combinations are EQ to each other, in which case consequences are
 277 specified if a combination is modified by FUNCTION."
 278   (let* ((end (or end (length sequence)))
 279          (size (- end start))
 280          (length (or length size))
 281          (combination (subseq sequence 0 length))
 282          (function (ensure-function function)))
 283     (if (= length size)
 284         (funcall function combination)
 285         (flet ((call ()
 286                  (funcall function (if copy
 287                                        (copy-seq combination)
 288                                        combination))))
 289           (etypecase sequence
 290             ;; When dealing with lists we prefer walking back and
 291             ;; forth instead of using indexes.
 292             (list
 293              (labels ((combine-list (c-tail o-tail)
 294                         (if (not c-tail)
 295                             (call)
 296                             (do ((tail o-tail (cdr tail)))
 297                                 ((not tail))
 298                               (setf (car c-tail) (car tail))
 299                               (combine-list (cdr c-tail) (cdr tail))))))
 300                (combine-list combination (nthcdr start sequence))))
 301             (vector
 302              (labels ((combine (count start)
 303                         (if (zerop count)
 304                             (call)
 305                             (loop for i from start below end
 306                                   do (let ((j (- count 1)))
 307                                        (setf (aref combination j) (aref sequence i))
 308                                        (combine j (+ i 1)))))))
 309                (combine length start)))
 310             (sequence
 311              (labels ((combine (count start)
 312                         (if (zerop count)
 313                             (call)
 314                             (loop for i from start below end
 315                                   do (let ((j (- count 1)))
 316                                        (setf (elt combination j) (elt sequence i))
 317                                        (combine j (+ i 1)))))))
 318                (combine length start)))))))
 319   sequence)
 320
 321 (defun map-permutations (function sequence &key (start 0) end length (copy t))
 322   "Calls function with each permutation of LENGTH constructable
 323 from the subsequence of SEQUENCE delimited by START and END. START
 324 defaults to 0, END to length of the sequence, and LENGTH to the
 325 length of the delimited subsequence."
 326   (let* ((end (or end (length sequence)))
 327          (size (- end start))
 328          (length (or length size)))
 329     (labels ((permute (seq n)
 330                (let ((n-1 (- n 1)))
 331                  (if (zerop n-1)
 332                      (funcall function (if copy
 333                                            (copy-seq seq)
 334                                            seq))
 335                      (if (evenp n-1)
 336                          (loop for i from 0 upto n-1
 337                                do (permute seq n-1)
 338                                   (if (evenp n-1)
 339                                       (rotatef (elt seq 0) (elt seq n-1))
 340                                       (rotatef (elt seq i) (elt seq n-1))))))))
 341              (permute-sequence (seq)
 342                (permute seq length)))
 343       (if (= length size)
 344           ;; Things are simple if we need to just permute the
 345           ;; full START-END range.
 346           (permute-sequence (subseq sequence start end))
 347           ;; Otherwise we need to generate all the combinations
 348           ;; of LENGTH in the START-END range, and then permute
 349           ;; a copy of the result: can't permute the combination
 350           ;; directly, as they share structure with each other.
 351           (let ((permutation (subseq sequence 0 length)))
 352             (flet ((permute-combination (combination)
 353                      (permute-sequence (replace permutation combination))))
 354               (declare (dynamic-extent #'permute-combination))
 355               (map-combinations #'permute-combination sequence
 356                                 :start start
 357                                 :end end
 358                                 :length length
 359                                 :copy nil)))))))
 360
 361 (defun map-derangements (function sequence &key (start 0) end (copy t))
 362   "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
 363 by the bounding index designators START and END. Derangement is a permutation
 364 of the sequence where no element remains in place. SEQUENCE is not modified,
 365 but individual derangements are EQ to each other. Consequences are unspecified
 366 if calling FUNCTION modifies either the derangement or SEQUENCE."
 367   (let* ((end (or end (length sequence)))
 368          (size (- end start))
 369          ;; We don't really care about the elements here.
 370          (derangement (subseq sequence 0 size))
 371          ;; Bitvector that has 1 for elements that have been deranged.
 372          (mask (make-array size :element-type 'bit :initial-element 0)))
 373     (declare (dynamic-extent mask))
 374     ;; ad hoc algorith
 375     (labels ((derange (place n)
 376                ;; Perform one recursive step in deranging the
 377                ;; sequence: PLACE is index of the original sequence
 378                ;; to derange to another index, and N is the number of
 379                ;; indexes not yet deranged.
 380                (if (zerop n)
 381                    (funcall function (if copy
 382                                          (copy-seq derangement)
 383                                          derangement))
 384                    ;; Itarate over the indexes I of the subsequence to
 385                    ;; derange: if I != PLACE and I has not yet been
 386                    ;; deranged by an earlier call put the element from
 387                    ;; PLACE to I, mark I as deranged, and recurse,
 388                    ;; finally removing the mark.
 389                    (loop for i from 0 below size
 390                          do
 391                          (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
 392                            (setf (elt derangement i) (elt sequence place)
 393                                  (bit mask i) 1)
 394                            (derange (1+ place) (1- n))
 395                            (setf (bit mask i) 0))))))
 396       (derange start size)
 397       sequence)))