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