sequences.lisp 24 KB
Newer Older
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1 2
(in-package :alexandria)

3 4
;; Make these inlinable by declaiming them INLINE here and some of them
;; 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 7
(declaim (inline copy-sequence sequence-of-length-p))

8 9 10 11
(defun sequence-of-length-p (sequence length)
  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
SEQUENCE is not a sequence. Returns FALSE for circular lists."
  (declare (type array-index length)
12
           #-lispworks (inline length)
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
           (optimize speed))
  (etypecase sequence
    (null
     (zerop length))
    (cons
     (let ((n (1- length)))
       (unless (minusp n)
         (let ((tail (nthcdr n sequence)))
           (and tail
                (null (cdr tail)))))))
    (vector
     (= length (length sequence)))
    (sequence
     (= length (length sequence)))))

28 29
(defun rotate-tail-to-head (sequence n)
  (declare (type (integer 1) n))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
30
  (if (listp sequence)
31
      (let ((m (mod n (proper-list-length sequence))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
32 33 34 35 36 37 38 39 40 41 42 43 44
        (if (null (cdr sequence))
            sequence
            (let* ((tail (last sequence (+ m 1)))
                   (last (cdr tail)))
              (setf (cdr tail) nil)
              (nconc last sequence))))
      (let* ((len (length sequence))
             (m (mod n len))
             (tail (subseq sequence (- len m))))
        (replace sequence sequence :start1 m :start2 0)
        (replace sequence tail)
        sequence)))

45 46
(defun rotate-head-to-tail (sequence n)
  (declare (type (integer 1) n))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
47
  (if (listp sequence)
48
      (let ((m (mod (1- n) (proper-list-length sequence))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
49 50 51 52 53 54 55 56 57 58 59 60 61
        (if (null (cdr sequence))
            sequence
            (let* ((headtail (nthcdr m sequence))
                   (tail (cdr headtail)))
              (setf (cdr headtail) nil)
              (nconc tail sequence))))
      (let* ((len (length sequence))
             (m (mod n len))
             (head (subseq sequence 0 m)))
        (replace sequence sequence :start1 0 :start2 m)
        (replace sequence head :start1 (- len m))
        sequence)))

62 63 64 65 66
(defun rotate (sequence &optional (n 1))
  "Returns a sequence of the same type as SEQUENCE, with the elements of
SEQUENCE rotated by N: N elements are moved from the end of the sequence to
the front if N is positive, and -N elements moved from the front to the end if
N is negative. SEQUENCE must be a proper sequence. N must be an integer,
Nikodemus Siivola's avatar
Nikodemus Siivola committed
67 68 69 70 71 72 73 74 75
defaulting to 1.

If absolute value of N is greater then the length of the sequence, the results
are identical to calling ROTATE with

  (* (signum n) (mod n (length sequence))).

Note: the original sequence may be destructively altered, and result sequence may
share structure with it."
76 77 78 79 80 81
  (if (plusp n)
      (rotate-tail-to-head sequence n)
      (if (minusp n)
          (rotate-head-to-tail sequence (- n))
          sequence)))

82 83
(defun shuffle (sequence &key (start 0) end)
  "Returns a random permutation of SEQUENCE bounded by START and END.
Philipp Marek's avatar
Philipp Marek committed
84 85 86
Original sequence may be destructively modified, and (if it contains
CONS or lists themselv) share storage with the original one.
Signals an error if SEQUENCE is not a proper sequence."
87 88 89
  (declare (type fixnum start)
           (type (or fixnum null) end))
  (etypecase sequence
Nikodemus Siivola's avatar
Nikodemus Siivola committed
90
    (list
91
     (let* ((end (or end (proper-list-length sequence)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
92 93 94 95 96 97 98
            (n (- end start)))
       (do ((tail (nthcdr start sequence) (cdr tail)))
           ((zerop n))
         (rotatef (car tail) (car (nthcdr (random n) tail)))
         (decf n))))
    (vector
     (let ((end (or end (length sequence))))
99 100 101
       (loop for i from start below end
             do (rotatef (aref sequence i)
                         (aref sequence (+ i (random (- end i))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
102 103 104
    (sequence
     (let ((end (or end (length sequence))))
       (loop for i from (- end 1) downto start
105 106
             do (rotatef (elt sequence i)
                         (elt sequence (+ i (random (- end i)))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
107 108 109 110
  sequence)

(defun random-elt (sequence &key (start 0) end)
  "Returns a random element from SEQUENCE bounded by START and END. Signals an
111 112
error if the SEQUENCE is not a proper non-empty sequence, or if END and START
are not proper bounding index designators for SEQUENCE."
113
  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
  (let* ((size (if (listp sequence)
                   (proper-list-length sequence)
                   (length sequence)))
         (end2 (or end size)))
    (cond ((zerop size)
           (error 'type-error
                  :datum sequence
                  :expected-type `(and sequence (not (satisfies emptyp)))))
          ((not (and (<= 0 start) (< start end2) (<= end2 size)))
           (error 'simple-type-error
                  :datum (cons start end)
                  :expected-type `(cons (integer 0 (,end2))
                                        (or null (integer (,start) ,size)))
                  :format-control "~@<~S and ~S are not valid bounding index designators for ~
                                   a sequence of length ~S.~:@>"
                  :format-arguments (list start end size)))
          (t
           (let ((index (+ start (random (- end2 start)))))
             (elt sequence index))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
133

134 135 136 137
(declaim (inline remove/swapped-arguments))
(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
  (apply #'remove item sequence keyword-arguments))

138
(define-modify-macro removef (item &rest keyword-arguments)
139
  remove/swapped-arguments
Nikodemus Siivola's avatar
Nikodemus Siivola committed
140
  "Modify-macro for REMOVE. Sets place designated by the first argument to
141
the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
Nikodemus Siivola's avatar
Nikodemus Siivola committed
142

143 144 145 146
(declaim (inline delete/swapped-arguments))
(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
  (apply #'delete item sequence keyword-arguments))

147
(define-modify-macro deletef (item &rest keyword-arguments)
148
  delete/swapped-arguments
Nikodemus Siivola's avatar
Nikodemus Siivola committed
149
  "Modify-macro for DELETE. Sets place designated by the first argument to
150
the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
Nikodemus Siivola's avatar
Nikodemus Siivola committed
151 152

(deftype proper-sequence ()
Nikodemus Siivola's avatar
Nikodemus Siivola committed
153 154 155 156
  "Type designator for proper sequences, that is proper lists and sequences
that are not lists."
  `(or proper-list
       (and (not list) sequence)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
157

158 159 160 161 162 163
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (and (find-package '#:sequence)
             (find-symbol (string '#:emptyp) '#:sequence))
    (pushnew 'sequence-emptyp *features*)))

#-alexandria::sequence-emptyp
Nikodemus Siivola's avatar
Nikodemus Siivola committed
164 165
(defun emptyp (sequence)
  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
166
is not a sequence."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
167 168 169 170
  (etypecase sequence
    (list (null sequence))
    (sequence (zerop (length sequence)))))

171 172 173 174 175 176 177 178
#+alexandria::sequence-emptyp
(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
#+alexandria::sequence-emptyp
(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
#+alexandria::sequence-emptyp
(define-compiler-macro emptyp (sequence)
  `(sequence:emptyp ,sequence))

Attila Lendvai's avatar
Attila Lendvai committed
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
(defun length= (&rest sequences)
  "Takes any number of sequences or integers in any order. Returns true iff
the length of all the sequences and the integers are equal. Hint: there's a
compiler macro that expands into more efficient code if the first argument
is a literal integer."
  (declare (dynamic-extent sequences)
           (inline sequence-of-length-p)
           (optimize speed))
  (unless (cdr sequences)
    (error "You must call LENGTH= with at least two arguments"))
  ;; There's room for optimization here: multiple list arguments could be
  ;; traversed in parallel.
  (let* ((first (pop sequences))
         (current (if (integerp first)
                      first
                      (length first))))
    (declare (type array-index current))
    (dolist (el sequences)
      (if (integerp el)
          (unless (= el current)
            (return-from length= nil))
          (unless (sequence-of-length-p el current)
            (return-from length= nil)))))
  t)

(define-compiler-macro length= (&whole form length &rest sequences)
  (cond
    ((zerop (length sequences))
     form)
    (t
     (let ((optimizedp (integerp length)))
       (with-unique-names (tmp current)
         (declare (ignorable current))
         `(locally
              (declare (inline sequence-of-length-p))
            (let ((,tmp)
                  ,@(unless optimizedp
                     `((,current ,length))))
              ,@(unless optimizedp
                  `((unless (integerp ,current)
                      (setf ,current (length ,current)))))
              (and
               ,@(loop
                    :for sequence :in sequences
                    :collect `(progn
                                (setf ,tmp ,sequence)
                                (if (integerp ,tmp)
                                    (= ,tmp ,(if optimizedp
                                                 length
                                                 current))
                                    (sequence-of-length-p ,tmp ,(if optimizedp
                                                                    length
                                                                    current)))))))))))))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
233 234 235 236 237 238 239 240 241 242
(defun copy-sequence (type sequence)
  "Returns a fresh sequence of TYPE, which has the same elements as
SEQUENCE."
  (if (typep sequence type)
      (copy-seq sequence)
      (coerce sequence type)))

(defun first-elt (sequence)
  "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, or is an empty sequence."
243
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
244
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
245
  (cond  ((consp sequence)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
246
          (car sequence))
247
         ((and (typep sequence 'sequence) (not (emptyp sequence)))
248
          (elt sequence 0))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
249
         (t
250 251
          (error 'type-error
                 :datum sequence
Nikodemus Siivola's avatar
Nikodemus Siivola committed
252 253
                 :expected-type '(and sequence (not (satisfies emptyp)))))))

254 255 256
(defun (setf first-elt) (object sequence)
  "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
257
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
258 259 260
  ;; type-error.
  (cond ((consp sequence)
         (setf (car sequence) object))
261
        ((and (typep sequence 'sequence) (not (emptyp sequence)))
262 263
         (setf (elt sequence 0) object))
        (t
264 265
         (error 'type-error
                :datum sequence
266
                :expected-type '(and sequence (not (satisfies emptyp)))))))
267

Nikodemus Siivola's avatar
Nikodemus Siivola committed
268 269 270
(defun last-elt (sequence)
  "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
not a proper sequence, or is an empty sequence."
271
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
272
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
273 274 275
  (let ((len 0))
    (cond ((consp sequence)
           (lastcar sequence))
276 277 278
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
           (elt sequence (1- len)))
          (t
279 280
           (error 'type-error
                  :datum sequence
281
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
282

283 284 285 286 287 288 289 290 291
(defun (setf last-elt) (object sequence)
  "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
  (let ((len 0))
    (cond ((consp sequence)
           (setf (lastcar sequence) object))
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
           (setf (elt sequence (1- len)) object))
          (t
292 293
           (error 'type-error
                  :datum sequence
294 295
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))

296 297 298 299
(defun starts-with-subseq (prefix sequence &rest args
                           &key
                           (return-suffix nil return-suffix-supplied-p)
                           &allow-other-keys)
300 301
  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.

302
If RETURN-SUFFIX is T the function returns, as a second value, a
303
sub-sequence or displaced array pointing to the sequence after PREFIX."
304
  (declare (dynamic-extent args))
305 306
  (let ((sequence-length (length sequence))
        (prefix-length (length prefix)))
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
    (when (< sequence-length prefix-length)
      (return-from starts-with-subseq (values nil nil)))
    (flet ((make-suffix (start)
             (when return-suffix
               (cond
                 ((not (arrayp sequence))
                  (if start
                      (subseq sequence start)
                      (subseq sequence 0 0)))
                 ((not start)
                  (make-array 0
                              :element-type (array-element-type sequence)
                              :adjustable nil))
                 (t
                  (make-array (- sequence-length start)
                              :element-type (array-element-type sequence)
                              :displaced-to sequence
                              :displaced-index-offset start
                              :adjustable nil))))))
      (let ((mismatch (apply #'mismatch prefix sequence
                             (if return-suffix-supplied-p
                                 (remove-from-plist args :return-suffix)
                                 args))))
        (cond
          ((not mismatch)
           (values t (make-suffix nil)))
          ((= mismatch prefix-length)
           (values t (make-suffix mismatch)))
          (t
           (values nil nil)))))))
337

338
(defun ends-with-subseq (suffix sequence &key (test #'eql))
339 340 341 342 343 344 345 346 347 348 349 350 351
  "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
  (let ((sequence-length (length sequence))
        (suffix-length (length suffix)))
    (when (< sequence-length suffix-length)
      ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
      (return-from ends-with-subseq nil))
    (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
          for suffix-index from 0 below suffix-length
          when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
          do (return-from ends-with-subseq nil)
          finally (return t))))

352
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
353 354
  "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
355 356 357 358 359 360 361 362 363
  (let ((first-elt (typecase sequence
                     (cons (car sequence))
                     (sequence
                      (if (emptyp sequence)
                          (return-from starts-with nil)
                          (elt sequence 0)))
                     (t
                      (return-from starts-with nil)))))
    (funcall test (funcall key first-elt) object)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
364

365
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
366 367 368
  "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
an error if SEQUENCE is an improper list."
369 370 371 372 373 374 375 376 377 378 379 380 381
  (let ((last-elt (typecase sequence
                    (cons
                     (lastcar sequence)) ; signals for improper lists
                    (sequence
                     ;; Can't use last-elt, as that signals an error
                     ;; for empty sequences
                     (let ((len (length sequence)))
                       (if (plusp len)
                           (elt sequence (1- len))
                           (return-from ends-with nil))))
                    (t
                     (return-from ends-with nil)))))
    (funcall test (funcall key last-elt) object)))
382 383 384 385 386 387 388 389 390

(defun map-combinations (function sequence &key (start 0) end length (copy t))
  "Calls FUNCTION with each combination of LENGTH constructable from the
elements of the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
delimited subsequence. (So unless LENGTH is specified there is only a single
combination, which has the same elements as the delimited subsequence.) If
COPY is true (the default) each combination is freshly allocated. If COPY is
false all combinations are EQ to each other, in which case consequences are
391
unspecified if a combination is modified by FUNCTION."
392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
  (let* ((end (or end (length sequence)))
         (size (- end start))
         (length (or length size))
         (combination (subseq sequence 0 length))
         (function (ensure-function function)))
    (if (= length size)
        (funcall function combination)
        (flet ((call ()
                 (funcall function (if copy
                                       (copy-seq combination)
                                       combination))))
          (etypecase sequence
            ;; When dealing with lists we prefer walking back and
            ;; forth instead of using indexes.
            (list
             (labels ((combine-list (c-tail o-tail)
                        (if (not c-tail)
                            (call)
                            (do ((tail o-tail (cdr tail)))
                                ((not tail))
                              (setf (car c-tail) (car tail))
                              (combine-list (cdr c-tail) (cdr tail))))))
               (combine-list combination (nthcdr start sequence))))
            (vector
             (labels ((combine (count start)
                        (if (zerop count)
                            (call)
                            (loop for i from start below end
                                  do (let ((j (- count 1)))
                                       (setf (aref combination j) (aref sequence i))
                                       (combine j (+ i 1)))))))
               (combine length start)))
            (sequence
             (labels ((combine (count start)
                        (if (zerop count)
                            (call)
                            (loop for i from start below end
                                  do (let ((j (- count 1)))
                                       (setf (elt combination j) (elt sequence i))
                                       (combine j (+ i 1)))))))
               (combine length start)))))))
  sequence)

(defun map-permutations (function sequence &key (start 0) end length (copy t))
  "Calls function with each permutation of LENGTH constructable
from the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of the sequence, and LENGTH to the
length of the delimited subsequence."
  (let* ((end (or end (length sequence)))
         (size (- end start))
         (length (or length size)))
    (labels ((permute (seq n)
               (let ((n-1 (- n 1)))
                 (if (zerop n-1)
                     (funcall function (if copy
                                           (copy-seq seq)
                                           seq))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
449 450 451 452 453
                     (loop for i from 0 upto n-1
                           do (permute seq n-1)
                           (if (evenp n-1)
                               (rotatef (elt seq 0) (elt seq n-1))
                               (rotatef (elt seq i) (elt seq n-1)))))))
454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483
             (permute-sequence (seq)
               (permute seq length)))
      (if (= length size)
          ;; Things are simple if we need to just permute the
          ;; full START-END range.
          (permute-sequence (subseq sequence start end))
          ;; Otherwise we need to generate all the combinations
          ;; of LENGTH in the START-END range, and then permute
          ;; a copy of the result: can't permute the combination
          ;; directly, as they share structure with each other.
          (let ((permutation (subseq sequence 0 length)))
            (flet ((permute-combination (combination)
                     (permute-sequence (replace permutation combination))))
              (declare (dynamic-extent #'permute-combination))
              (map-combinations #'permute-combination sequence
                                :start start
                                :end end
                                :length length
                                :copy nil)))))))

(defun map-derangements (function sequence &key (start 0) end (copy t))
  "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
by the bounding index designators START and END. Derangement is a permutation
of the sequence where no element remains in place. SEQUENCE is not modified,
but individual derangements are EQ to each other. Consequences are unspecified
if calling FUNCTION modifies either the derangement or SEQUENCE."
  (let* ((end (or end (length sequence)))
         (size (- end start))
         ;; We don't really care about the elements here.
         (derangement (subseq sequence 0 size))
484
         ;; Bitvector that has 1 for elements that have been deranged.
485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
         (mask (make-array size :element-type 'bit :initial-element 0)))
    (declare (dynamic-extent mask))
    ;; ad hoc algorith
    (labels ((derange (place n)
               ;; Perform one recursive step in deranging the
               ;; sequence: PLACE is index of the original sequence
               ;; to derange to another index, and N is the number of
               ;; indexes not yet deranged.
               (if (zerop n)
                   (funcall function (if copy
                                         (copy-seq derangement)
                                         derangement))
                   ;; Itarate over the indexes I of the subsequence to
                   ;; derange: if I != PLACE and I has not yet been
                   ;; deranged by an earlier call put the element from
                   ;; PLACE to I, mark I as deranged, and recurse,
                   ;; finally removing the mark.
                   (loop for i from 0 below size
                         do
                         (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
                           (setf (elt derangement i) (elt sequence place)
                                 (bit mask i) 1)
                           (derange (1+ place) (1- n))
                           (setf (bit mask i) 0))))))
      (derange start size)
      sequence)))
511 512

(declaim (notinline sequence-of-length-p))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
513 514 515 516 517 518 519 520 521 522 523 524 525 526 527

(defun extremum (sequence predicate &key key (start 0) end)
  "Returns the element of SEQUENCE that would appear first if the subsequence
bounded by START and END was sorted using PREDICATE and KEY.

EXTREMUM determines the relationship between two elements of SEQUENCE by using
the PREDICATE function. PREDICATE should return true if and only if the first
argument is strictly less than the second one (in some appropriate sense). Two
arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
and (FUNCALL PREDICATE Y X) are both false.

The arguments to the PREDICATE function are computed from elements of SEQUENCE
using the KEY function, if supplied. If KEY is not supplied or is NIL, the
sequence element itself is used.

Nikodemus Siivola's avatar
Nikodemus Siivola committed
528
If SEQUENCE is empty, NIL is returned."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549
  (let* ((pred-fun (ensure-function predicate))
         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
                    (ensure-function key)))
         (real-end (or end (length sequence))))
    (cond ((> real-end start)
           (if key-fun
               (flet ((reduce-keys (a b)
                        (if (funcall pred-fun
                                     (funcall key-fun a)
                                     (funcall key-fun b))
                            a
                            b)))
                 (declare (dynamic-extent #'reduce-keys))
                 (reduce #'reduce-keys sequence :start start :end real-end))
               (flet ((reduce-elts (a b)
                        (if (funcall pred-fun a b)
                            a
                            b)))
                 (declare (dynamic-extent #'reduce-elts))
                 (reduce #'reduce-elts sequence :start start :end real-end))))
          ((= real-end start)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
550
           nil)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
551 552 553 554 555
          (t
           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
                  (length sequence)
                  :start start
                  :end end)))))