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) (type (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) (type (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 (prefix sequence &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 (suffix sequence &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
 241                        ;; for empty sequences
 242                        (let ((len (length sequence)))
 243                          (if (plusp len)
 244                              (elt sequence (1- len))
 245                              (return-from ends-with nil))))
 246                       (t
 247                        (return-from ends-with nil))))
 248            object))
 249
 250 (defun map-combinations (function sequence &key (start 0) end length (copy t))
 251   "Calls FUNCTION with each combination of LENGTH constructable from the
 252 elements of the subsequence of SEQUENCE delimited by START and END. START
 253 defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
 254 delimited subsequence. (So unless LENGTH is specified there is only a single
 255 combination, which has the same elements as the delimited subsequence.) If
 256 COPY is true (the default) each combination is freshly allocated. If COPY is
 257 false all combinations are EQ to each other, in which case consequences are
 258 specified if a combination is modified by FUNCTION."
 259   (let* ((end (or end (length sequence)))
 260          (size (- end start))
 261          (length (or length size))
 262          (combination (subseq sequence 0 length))
 263          (function (ensure-function function)))
 264     (if (= length size)
 265         (funcall function combination)
 266         (flet ((call ()
 267                  (funcall function (if copy
 268                                        (copy-seq combination)
 269                                        combination))))
 270           (etypecase sequence
 271             ;; When dealing with lists we prefer walking back and
 272             ;; forth instead of using indexes.
 273             (list
 274              (labels ((combine-list (c-tail o-tail)
 275                         (if (not c-tail)
 276                             (call)
 277                             (do ((tail o-tail (cdr tail)))
 278                                 ((not tail))
 279                               (setf (car c-tail) (car tail))
 280                               (combine-list (cdr c-tail) (cdr tail))))))
 281                (combine-list combination (nthcdr start sequence))))
 282             (vector
 283              (labels ((combine (count start)
 284                         (if (zerop count)
 285                             (call)
 286                             (loop for i from start below end
 287                                   do (let ((j (- count 1)))
 288                                        (setf (aref combination j) (aref sequence i))
 289                                        (combine j (+ i 1)))))))
 290                (combine length start)))
 291             (sequence
 292              (labels ((combine (count start)
 293                         (if (zerop count)
 294                             (call)
 295                             (loop for i from start below end
 296                                   do (let ((j (- count 1)))
 297                                        (setf (elt combination j) (elt sequence i))
 298                                        (combine j (+ i 1)))))))
 299                (combine length start)))))))
 300   sequence)
 301
 302 (defun map-permutations (function sequence &key (start 0) end length (copy t))
 303   "Calls function with each permutation of LENGTH constructable
 304 from the subsequence of SEQUENCE delimited by START and END. START
 305 defaults to 0, END to length of the sequence, and LENGTH to the
 306 length of the delimited subsequence."
 307   (let* ((end (or end (length sequence)))
 308          (size (- end start))
 309          (length (or length size)))
 310     (labels ((permute (seq n)
 311                (let ((n-1 (- n 1)))
 312                  (if (zerop n-1)
 313                      (funcall function (if copy
 314                                            (copy-seq seq)
 315                                            seq))
 316                      (if (evenp n-1)
 317                          (loop for i from 0 upto n-1
 318                                do (permute seq n-1)
 319                                   (if (evenp n-1)
 320                                       (rotatef (elt seq 0) (elt seq n-1))
 321                                       (rotatef (elt seq i) (elt seq n-1))))))))
 322              (permute-sequence (seq)
 323                (permute seq length)))
 324       (if (= length size)
 325           ;; Things are simple if we need to just permute the
 326           ;; full START-END range.
 327           (permute-sequence (subseq sequence start end))
 328           ;; Otherwise we need to generate all the combinations
 329           ;; of LENGTH in the START-END range, and then permute
 330           ;; a copy of the result: can't permute the combination
 331           ;; directly, as they share structure with each other.
 332           (let ((permutation (subseq sequence 0 length)))
 333             (flet ((permute-combination (combination)
 334                      (permute-sequence (replace permutation combination))))
 335               (declare (dynamic-extent #'permute-combination))
 336               (map-combinations #'permute-combination sequence
 337                                 :start start
 338                                 :end end
 339                                 :length length
 340                                 :copy nil)))))))
 341
 342 (defun map-derangements (function sequence &key (start 0) end (copy t))
 343   "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
 344 by the bounding index designators START and END. Derangement is a permutation
 345 of the sequence where no element remains in place. SEQUENCE is not modified,
 346 but individual derangements are EQ to each other. Consequences are unspecified
 347 if calling FUNCTION modifies either the derangement or SEQUENCE."
 348   (let* ((end (or end (length sequence)))
 349          (size (- end start))
 350          ;; We don't really care about the elements here.
 351          (derangement (subseq sequence 0 size))
 352          ;; Bitvector that has 1 for elements that have been deranged.
 353          (mask (make-array size :element-type 'bit :initial-element 0)))
 354     (declare (dynamic-extent mask))
 355     ;; ad hoc algorith
 356     (labels ((derange (place n)
 357                ;; Perform one recursive step in deranging the
 358                ;; sequence: PLACE is index of the original sequence
 359                ;; to derange to another index, and N is the number of
 360                ;; indexes not yet deranged.
 361                (if (zerop n)
 362                    (funcall function (if copy
 363                                          (copy-seq derangement)
 364                                          derangement))
 365                    ;; Itarate over the indexes I of the subsequence to
 366                    ;; derange: if I != PLACE and I has not yet been
 367                    ;; deranged by an earlier call put the element from
 368                    ;; PLACE to I, mark I as deranged, and recurse,
 369                    ;; finally removing the mark.
 370                    (loop for i from 0 below size
 371                          do
 372                          (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
 373                            (setf (elt derangement i) (elt sequence place)
 374                                  (bit mask i) 1)
 375                            (derange (1+ place) (1- n))
 376                            (setf (bit mask i) 0))))))
 377       (derange start size)
 378       sequence)))