sequences.lisp

   1 (in-package :alexandria)
   2
   3 ;; Make these inlinable by declaiming them INLINE here and some of them
   4 ;; NOTINLINE at the end of the file. Exclude functions that have a compiler
   5 ;; macro, because inlining seems to cancel compiler macros (at least on SBCL).
   6 (declaim (inline copy-sequence sequence-of-length-p))
   7
   8 (defun rotate-tail-to-head (sequence n)
   9   (declare (type (integer 1) n))
  10   (if (listp sequence)
  11       (let ((m (mod n (proper-list-length sequence))))
  12         (if (null (cdr sequence))
  13             sequence
  14             (let* ((tail (last sequence (+ m 1)))
  15                    (last (cdr tail)))
  16               (setf (cdr tail) nil)
  17               (nconc last sequence))))
  18       (let* ((len (length sequence))
  19              (m (mod n len))
  20              (tail (subseq sequence (- len m))))
  21         (replace sequence sequence :start1 m :start2 0)
  22         (replace sequence tail)
  23         sequence)))
  24
  25 (defun rotate-head-to-tail (sequence n)
  26   (declare (type (integer 1) n))
  27   (if (listp sequence)
  28       (let ((m (mod (1- n) (proper-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 rotate (sequence &optional (n 1))
  43   "Returns a sequence of the same type as SEQUENCE, with the elements of
  44 SEQUENCE rotated by N: N elements are moved from the end of the sequence to
  45 the front if N is positive, and -N elements moved from the front to the end if
  46 N is negative. SEQUENCE must be a proper sequence. N must be an integer,
  47 defaulting to 1. If absolute value of N is greater then the length of the
  48 sequence, the results are identical to calling ROTATE with (* (SIGNUM N) (MOD
  49 N (LENGTH SEQUENCE))). The original sequence may be destructively altered, and
  50 result sequence may share structure with it."
  51   (if (plusp n)
  52       (rotate-tail-to-head sequence n)
  53       (if (minusp n)
  54           (rotate-head-to-tail sequence (- n))
  55           sequence)))
  56
  57 (defun shuffle (sequence &key (start 0) end)
  58   "Returns a random permutation of SEQUENCE bounded by START and END.
  59 Permuted sequence may share storage with the original one. Signals an
  60 error if SEQUENCE is not a proper sequence."
  61   (declare (fixnum start) (type (or fixnum null) end))
  62   (typecase sequence
  63     (list
  64      (let* ((end (or end (proper-list-length sequence)))
  65             (n (- end start)))
  66        (do ((tail (nthcdr start sequence) (cdr tail)))
  67            ((zerop n))
  68          (rotatef (car tail) (car (nthcdr (random n) tail)))
  69          (decf n))))
  70     (vector
  71      (let ((end (or end (length sequence))))
  72        (loop for i from (- end 1) downto start
  73              do (rotatef (aref sequence i) (aref sequence (random (+ i 1)))))))
  74     (sequence
  75      (let ((end (or end (length sequence))))
  76        (loop for i from (- end 1) downto start
  77              do (rotatef (elt sequence i) (elt sequence (random (+ i 1))))))))
  78   sequence)
  79
  80 (defun random-elt (sequence &key (start 0) end)
  81   "Returns a random element from SEQUENCE bounded by START and END. Signals an
  82 error if the SEQUENCE is not a proper sequence."
  83   (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
  84   (let ((i (+ start (random (- (or end  (if (listp sequence)
  85                                             (proper-list-length sequence)
  86                                             (length sequence)))
  87                                start)))))
  88     (elt sequence i)))
  89
  90 (declaim (inline remove/swapped-arguments))
  91 (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
  92   (apply #'remove item sequence keyword-arguments))
  93
  94 (define-modify-macro removef (item &rest remove-keywords)
  95   remove/swapped-arguments
  96   "Modify-macro for REMOVE. Sets place designated by the first argument to
  97 the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")
  98
  99 (declaim (inline delete/swapped-arguments))
 100 (defun delete/swapped-arguments (sequence item &rest keyword-arguments)
 101   (apply #'delete item sequence keyword-arguments))
 102
 103 (define-modify-macro deletef (item &rest remove-keywords)
 104   delete/swapped-arguments
 105   "Modify-macro for DELETE. Sets place designated by the first argument to
 106 the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")
 107
 108 (deftype proper-sequence ()
 109   "Type designator for proper sequences, that is proper lists and sequences
 110 that are not lists."
 111   `(or proper-list
 112        (and (not list) sequence)))
 113
 114 (defun emptyp (sequence)
 115   "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
 116 is not a sequence"
 117   (etypecase sequence
 118     (list (null sequence))
 119     (sequence (zerop (length sequence)))))
 120
 121 (defun length= (&rest sequences)
 122   "Takes any number of sequences or integers in any order. Returns true iff
 123 the length of all the sequences and the integers are equal. Hint: there's a
 124 compiler macro that expands into more efficient code if the first argument
 125 is a literal integer."
 126   (declare (dynamic-extent sequences)
 127            (inline sequence-of-length-p)
 128            (optimize speed))
 129   (unless (cdr sequences)
 130     (error "You must call LENGTH= with at least two arguments"))
 131   ;; There's room for optimization here: multiple list arguments could be
 132   ;; traversed in parallel.
 133   (let* ((first (pop sequences))
 134          (current (if (integerp first)
 135                       first
 136                       (length first))))
 137     (declare (type array-index current))
 138     (dolist (el sequences)
 139       (if (integerp el)
 140           (unless (= el current)
 141             (return-from length= nil))
 142           (unless (sequence-of-length-p el current)
 143             (return-from length= nil)))))
 144   t)
 145
 146 (define-compiler-macro length= (&whole form length &rest sequences)
 147   (cond
 148     ((zerop (length sequences))
 149      form)
 150     (t
 151      (let ((optimizedp (integerp length)))
 152        (with-unique-names (tmp current)
 153          (declare (ignorable current))
 154          `(locally
 155               (declare (inline sequence-of-length-p))
 156             (let ((,tmp)
 157                   ,@(unless optimizedp
 158                      `((,current ,length))))
 159               ,@(unless optimizedp
 160                   `((unless (integerp ,current)
 161                       (setf ,current (length ,current)))))
 162               (and
 163                ,@(loop
 164                     :for sequence :in sequences
 165                     :collect `(progn
 166                                 (setf ,tmp ,sequence)
 167                                 (if (integerp ,tmp)
 168                                     (= ,tmp ,(if optimizedp
 169                                                  length
 170                                                  current))
 171                                     (sequence-of-length-p ,tmp ,(if optimizedp
 172                                                                     length
 173                                                                     current)))))))))))))
 174
 175 (defun sequence-of-length-p (sequence length)
 176   "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
 177 SEQUENCE is not a sequence. Returns FALSE for circular lists."
 178   (declare (type array-index length)
 179            (inline length)
 180            (optimize speed))
 181   (etypecase sequence
 182     (null
 183      (zerop length))
 184     (cons
 185      (let ((n (1- length)))
 186        (unless (minusp n)
 187          (let ((tail (nthcdr n sequence)))
 188            (and tail
 189                 (null (cdr tail)))))))
 190     (vector
 191      (= length (length sequence)))
 192     (sequence
 193      (= length (length sequence)))))
 194
 195 (defun copy-sequence (type sequence)
 196   "Returns a fresh sequence of TYPE, which has the same elements as
 197 SEQUENCE."
 198   (if (typep sequence type)
 199       (copy-seq sequence)
 200       (coerce sequence type)))
 201
 202 (defun first-elt (sequence)
 203   "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 204 not a sequence, or is an empty sequence."
 205   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 206   ;; type-error.
 207   (cond  ((consp sequence)
 208           (car sequence))
 209          ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
 210           (elt sequence 0))
 211          (t
 212           (error 'type-error
 213                  :datum sequence
 214                  :expected-type '(and sequence (not (satisfies emptyp)))))))
 215
 216 (defun (setf first-elt) (object sequence)
 217   "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 218 not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 219   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 220   ;; type-error.
 221   (cond ((consp sequence)
 222          (setf (car sequence) object))
 223         ((and (typep sequence '(and sequence (not list)))
 224               (plusp (length sequence)))
 225          (setf (elt sequence 0) object))
 226         (t
 227          (error 'type-error
 228                 :datum sequence
 229                 :expected-type '(and sequence (not (satisfies emptyp)))))))
 230
 231 (defun last-elt (sequence)
 232   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 233 not a proper sequence, or is an empty sequence."
 234   ;; Can't just directly use ELT, as it is not guaranteed to signal the
 235   ;; type-error.
 236   (let ((len 0))
 237     (cond ((consp sequence)
 238            (lastcar sequence))
 239           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 240            (elt sequence (1- len)))
 241           (t
 242            (error 'type-error
 243                   :datum sequence
 244                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 245
 246 (defun (setf last-elt) (object sequence)
 247   "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
 248 sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 249   (let ((len 0))
 250     (cond ((consp sequence)
 251            (setf (lastcar sequence) object))
 252           ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 253            (setf (elt sequence (1- len)) object))
 254           (t
 255            (error 'type-error
 256                   :datum sequence
 257                   :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 258
 259 (defun starts-with-subseq (prefix sequence &rest args &key (return-suffix nil) &allow-other-keys)
 260   "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
 261
 262 If RETURN-SUFFIX is T the functions returns, as a second value, a
 263 displaced array pointing to the sequence after PREFIX."
 264   (remove-from-plistf args :return-suffix)
 265   (let ((sequence-length (length sequence))
 266         (prefix-length (length prefix)))
 267     (if (<= prefix-length sequence-length)
 268         (let ((mismatch (apply #'mismatch sequence prefix args)))
 269           (if mismatch
 270               (if (< mismatch prefix-length)
 271                   (values nil nil)
 272                   (values t (when return-suffix
 273                               (make-array (- sequence-length mismatch)
 274                                           :element-type (array-element-type sequence)
 275                                           :displaced-to sequence
 276                                           :displaced-index-offset prefix-length
 277                                           :adjustable nil))))
 278               (values t (when return-suffix
 279                           (make-array 0 :element-type (array-element-type sequence)
 280                                       :adjustable nil)))))
 281         (values nil nil))))
 282
 283 (defun ends-with-subseq (suffix sequence &key (test #'eql))
 284   "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
 285 the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
 286   (let ((sequence-length (length sequence))
 287         (suffix-length (length suffix)))
 288     (when (< sequence-length suffix-length)
 289       ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
 290       (return-from ends-with-subseq nil))
 291     (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
 292           for suffix-index from 0 below suffix-length
 293           when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
 294           do (return-from ends-with-subseq nil)
 295           finally (return t))))
 296
 297 (defun starts-with (object sequence &key (test #'eql) (key #'identity))
 298   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 299 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 300   (funcall test
 301            (funcall key
 302                     (typecase sequence
 303                       (cons (car sequence))
 304                       (sequence
 305                        (if (plusp (length sequence))
 306                            (elt sequence 0)
 307                            (return-from starts-with nil)))
 308                       (t
 309                        (return-from starts-with nil))))
 310            object))
 311
 312 (defun ends-with (object sequence &key (test #'eql) (key #'identity))
 313   "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 314 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 315 an error if SEQUENCE is an improper list."
 316   (funcall test
 317            (funcall key
 318                     (typecase sequence
 319                       (cons
 320                        ;; signals for improper lists
 321                        (lastcar sequence))
 322                       (sequence
 323                        ;; Can't use last-elt, as that signals an error
 324                        ;; for empty sequences
 325                        (let ((len (length sequence)))
 326                          (if (plusp len)
 327                              (elt sequence (1- len))
 328                              (return-from ends-with nil))))
 329                       (t
 330                        (return-from ends-with nil))))
 331            object))
 332
 333 (defun map-combinations (function sequence &key (start 0) end length (copy t))
 334   "Calls FUNCTION with each combination of LENGTH constructable from the
 335 elements of the subsequence of SEQUENCE delimited by START and END. START
 336 defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
 337 delimited subsequence. (So unless LENGTH is specified there is only a single
 338 combination, which has the same elements as the delimited subsequence.) If
 339 COPY is true (the default) each combination is freshly allocated. If COPY is
 340 false all combinations are EQ to each other, in which case consequences are
 341 specified if a combination is modified by FUNCTION."
 342   (let* ((end (or end (length sequence)))
 343          (size (- end start))
 344          (length (or length size))
 345          (combination (subseq sequence 0 length))
 346          (function (ensure-function function)))
 347     (if (= length size)
 348         (funcall function combination)
 349         (flet ((call ()
 350                  (funcall function (if copy
 351                                        (copy-seq combination)
 352                                        combination))))
 353           (etypecase sequence
 354             ;; When dealing with lists we prefer walking back and
 355             ;; forth instead of using indexes.
 356             (list
 357              (labels ((combine-list (c-tail o-tail)
 358                         (if (not c-tail)
 359                             (call)
 360                             (do ((tail o-tail (cdr tail)))
 361                                 ((not tail))
 362                               (setf (car c-tail) (car tail))
 363                               (combine-list (cdr c-tail) (cdr tail))))))
 364                (combine-list combination (nthcdr start sequence))))
 365             (vector
 366              (labels ((combine (count start)
 367                         (if (zerop count)
 368                             (call)
 369                             (loop for i from start below end
 370                                   do (let ((j (- count 1)))
 371                                        (setf (aref combination j) (aref sequence i))
 372                                        (combine j (+ i 1)))))))
 373                (combine length start)))
 374             (sequence
 375              (labels ((combine (count start)
 376                         (if (zerop count)
 377                             (call)
 378                             (loop for i from start below end
 379                                   do (let ((j (- count 1)))
 380                                        (setf (elt combination j) (elt sequence i))
 381                                        (combine j (+ i 1)))))))
 382                (combine length start)))))))
 383   sequence)
 384
 385 (defun map-permutations (function sequence &key (start 0) end length (copy t))
 386   "Calls function with each permutation of LENGTH constructable
 387 from the subsequence of SEQUENCE delimited by START and END. START
 388 defaults to 0, END to length of the sequence, and LENGTH to the
 389 length of the delimited subsequence."
 390   (let* ((end (or end (length sequence)))
 391          (size (- end start))
 392          (length (or length size)))
 393     (labels ((permute (seq n)
 394                (let ((n-1 (- n 1)))
 395                  (if (zerop n-1)
 396                      (funcall function (if copy
 397                                            (copy-seq seq)
 398                                            seq))
 399                      (loop for i from 0 upto n-1
 400                            do (permute seq n-1)
 401                            (if (evenp n-1)
 402                                (rotatef (elt seq 0) (elt seq n-1))
 403                                (rotatef (elt seq i) (elt seq n-1)))))))
 404              (permute-sequence (seq)
 405                (permute seq length)))
 406       (if (= length size)
 407           ;; Things are simple if we need to just permute the
 408           ;; full START-END range.
 409           (permute-sequence (subseq sequence start end))
 410           ;; Otherwise we need to generate all the combinations
 411           ;; of LENGTH in the START-END range, and then permute
 412           ;; a copy of the result: can't permute the combination
 413           ;; directly, as they share structure with each other.
 414           (let ((permutation (subseq sequence 0 length)))
 415             (flet ((permute-combination (combination)
 416                      (permute-sequence (replace permutation combination))))
 417               (declare (dynamic-extent #'permute-combination))
 418               (map-combinations #'permute-combination sequence
 419                                 :start start
 420                                 :end end
 421                                 :length length
 422                                 :copy nil)))))))
 423
 424 (defun map-derangements (function sequence &key (start 0) end (copy t))
 425   "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
 426 by the bounding index designators START and END. Derangement is a permutation
 427 of the sequence where no element remains in place. SEQUENCE is not modified,
 428 but individual derangements are EQ to each other. Consequences are unspecified
 429 if calling FUNCTION modifies either the derangement or SEQUENCE."
 430   (let* ((end (or end (length sequence)))
 431          (size (- end start))
 432          ;; We don't really care about the elements here.
 433          (derangement (subseq sequence 0 size))
 434          ;; Bitvector that has 1 for elements that have been deranged.
 435          (mask (make-array size :element-type 'bit :initial-element 0)))
 436     (declare (dynamic-extent mask))
 437     ;; ad hoc algorith
 438     (labels ((derange (place n)
 439                ;; Perform one recursive step in deranging the
 440                ;; sequence: PLACE is index of the original sequence
 441                ;; to derange to another index, and N is the number of
 442                ;; indexes not yet deranged.
 443                (if (zerop n)
 444                    (funcall function (if copy
 445                                          (copy-seq derangement)
 446                                          derangement))
 447                    ;; Itarate over the indexes I of the subsequence to
 448                    ;; derange: if I != PLACE and I has not yet been
 449                    ;; deranged by an earlier call put the element from
 450                    ;; PLACE to I, mark I as deranged, and recurse,
 451                    ;; finally removing the mark.
 452                    (loop for i from 0 below size
 453                          do
 454                          (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
 455                            (setf (elt derangement i) (elt sequence place)
 456                                  (bit mask i) 1)
 457                            (derange (1+ place) (1- n))
 458                            (setf (bit mask i) 0))))))
 459       (derange start size)
 460       sequence)))
 461
 462 (declaim (notinline sequence-of-length-p))