sequences.lisp 24.5 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.
84
Original sequence may be destructively modified.
Philipp Marek's avatar
Philipp Marek committed
85
Signals an error if SEQUENCE is not a proper sequence."
86
87
88
  (declare (type fixnum start)
           (type (or fixnum null) end))
  (etypecase sequence
Nikodemus Siivola's avatar
Nikodemus Siivola committed
89
    (list
90
     (let* ((end (or end (proper-list-length sequence)))
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
            (n (- end start))
            (sublist (nthcdr start sequence))
            (small-enough-threshold 100))
       ;; It's fine to use a pure list shuffle if the number of items
       ;; to shuffle is small enough, but otherwise it's more
       ;; time-efficient to create an intermediate vector to work on.
       ;; I picked the threshold based on rudimentary benchmarks on my
       ;; machine, where both branches take about the same time.
       (if (< n small-enough-threshold)
           (do ((tail sublist (cdr tail)))
               ((zerop n))
             (rotatef (car tail) (car (nthcdr (random n) tail)))
             (decf n))
           (let ((intermediate-vector (replace (make-array n) sublist)))
             (replace sublist (shuffle intermediate-vector))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
106
107
    (vector
     (let ((end (or end (length sequence))))
108
109
110
       (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
111
112
113
    (sequence
     (let ((end (or end (length sequence))))
       (loop for i from (- end 1) downto start
114
115
             do (rotatef (elt sequence i)
                         (elt sequence (+ i (random (- end i)))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
116
117
118
119
  sequence)

(defun random-elt (sequence &key (start 0) end)
  "Returns a random element from SEQUENCE bounded by START and END. Signals an
120
121
error if the SEQUENCE is not a proper non-empty sequence, or if END and START
are not proper bounding index designators for SEQUENCE."
122
  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
  (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
142

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

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

152
153
154
155
(declaim (inline delete/swapped-arguments))
(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
  (apply #'delete item sequence keyword-arguments))

156
(define-modify-macro deletef (item &rest keyword-arguments)
157
  delete/swapped-arguments
Nikodemus Siivola's avatar
Nikodemus Siivola committed
158
  "Modify-macro for DELETE. Sets place designated by the first argument to
159
the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
Nikodemus Siivola's avatar
Nikodemus Siivola committed
160
161

(deftype proper-sequence ()
Nikodemus Siivola's avatar
Nikodemus Siivola committed
162
163
164
165
  "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
166

167
168
169
170
171
172
(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
173
174
(defun emptyp (sequence)
  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
175
is not a sequence."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
176
177
178
179
  (etypecase sequence
    (list (null sequence))
    (sequence (zerop (length sequence)))))

180
181
182
183
184
185
186
187
#+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
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
233
234
235
236
237
238
239
240
241
(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
242
243
244
245
246
247
248
249
250
251
(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."
252
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
253
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
254
  (cond  ((consp sequence)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
255
          (car sequence))
256
         ((and (typep sequence 'sequence) (not (emptyp sequence)))
257
          (elt sequence 0))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
258
         (t
259
260
          (error 'type-error
                 :datum sequence
Nikodemus Siivola's avatar
Nikodemus Siivola committed
261
262
                 :expected-type '(and sequence (not (satisfies emptyp)))))))

263
264
265
(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."
266
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
267
268
269
  ;; type-error.
  (cond ((consp sequence)
         (setf (car sequence) object))
270
        ((and (typep sequence 'sequence) (not (emptyp sequence)))
271
272
         (setf (elt sequence 0) object))
        (t
273
274
         (error 'type-error
                :datum sequence
275
                :expected-type '(and sequence (not (satisfies emptyp)))))))
276

Nikodemus Siivola's avatar
Nikodemus Siivola committed
277
278
279
(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."
280
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
281
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
282
283
284
  (let ((len 0))
    (cond ((consp sequence)
           (lastcar sequence))
285
286
287
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
           (elt sequence (1- len)))
          (t
288
289
           (error 'type-error
                  :datum sequence
290
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
291

292
293
294
295
296
297
298
299
300
(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
301
302
           (error 'type-error
                  :datum sequence
303
304
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))

305
306
307
308
(defun starts-with-subseq (prefix sequence &rest args
                           &key
                           (return-suffix nil return-suffix-supplied-p)
                           &allow-other-keys)
309
310
  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.

311
If RETURN-SUFFIX is T the function returns, as a second value, a
312
sub-sequence or displaced array pointing to the sequence after PREFIX."
313
  (declare (dynamic-extent args))
314
315
  (let ((sequence-length (length sequence))
        (prefix-length (length prefix)))
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
    (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)))))))
346

347
(defun ends-with-subseq (suffix sequence &key (test #'eql))
348
349
350
351
352
353
354
355
356
357
358
359
360
  "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))))

361
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
362
363
  "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."
364
365
366
367
368
369
370
371
372
  (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
373

374
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
375
376
377
  "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."
378
379
380
381
382
383
384
385
386
387
388
389
390
  (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)))
391
392
393
394
395
396
397
398
399

(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
400
unspecified if a combination is modified by FUNCTION."
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
449
450
451
452
453
454
455
456
457
  (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
458
459
460
461
462
                     (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)))))))
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
             (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))
493
         ;; Bitvector that has 1 for elements that have been deranged.
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
         (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)))
520
521

(declaim (notinline sequence-of-length-p))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536

(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
537
If SEQUENCE is empty, NIL is returned."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
  (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
559
           nil)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
560
561
562
563
564
          (t
           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
                  (length sequence)
                  :start start
                  :end end)))))