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

3
4
5
6
7
;; 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
;; macro, because inlining seems to cancel compiler macros (at least on SBCL).
(declaim (inline copy-sequence sequence-of-length-p))

8
9
(defun rotate-tail-to-head (sequence n)
  (declare (type (integer 1) n))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
  (if (listp sequence)
      (let ((m (mod n (list-length sequence))))
        (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)))

25
26
(defun rotate-head-to-tail (sequence n)
  (declare (type (integer 1) n))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
  (if (listp sequence)
      (let ((m (mod (1- n) (list-length sequence))))
        (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)))

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
(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,
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))). The original sequence may be destructively altered, and
result sequence may share structure with it."
  (if (plusp n)
      (rotate-tail-to-head sequence n)
      (if (minusp n)
          (rotate-head-to-tail sequence (- n))
          sequence)))

57
58
(defun shuffle (sequence &key (start 0) end)
  "Returns a random permutation of SEQUENCE bounded by START and END.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
59
60
Permuted sequence may share storage with the original one. Signals an
error if SEQUENCE is not a proper sequence."
61
  (declare (fixnum start) (type (or fixnum null) end))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
  (typecase sequence
    (list
     (let* ((end (or end (list-length sequence)))
            (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))))
       (loop for i from (- end 1) downto start
             do (rotatef (aref sequence i) (aref sequence (random (+ i 1)))))))
    (sequence
     (let ((end (or end (length sequence))))
       (loop for i from (- end 1) downto start
             do (rotatef (elt sequence i) (elt sequence (random (+ i 1))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
78
79
80
81
82
  sequence)

(defun random-elt (sequence &key (start 0) end)
  "Returns a random element from SEQUENCE bounded by START and END. Signals an
error if the SEQUENCE is not a proper sequence."
83
  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
84
85
86
87
88
89
  (let ((i (+ start (random (- (or end  (if (listp sequence)
                                            (list-length sequence)
                                            (length sequence)))
                               start)))))
    (elt sequence i)))

90
91
92
93
(declaim (inline remove/swapped-arguments))
(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
  (apply #'remove item sequence keyword-arguments))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
94
(define-modify-macro removef (item &rest remove-keywords)
95
  remove/swapped-arguments
Nikodemus Siivola's avatar
Nikodemus Siivola committed
96
97
98
  "Modify-macro for REMOVE. Sets place designated by the first argument to
the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")

99
100
101
102
(declaim (inline delete/swapped-arguments))
(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
  (apply #'delete item sequence keyword-arguments))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
103
(define-modify-macro deletef (item &rest remove-keywords)
104
  delete/swapped-arguments
Nikodemus Siivola's avatar
Nikodemus Siivola committed
105
106
107
108
  "Modify-macro for DELETE. Sets place designated by the first argument to
the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")

(deftype proper-sequence ()
Nikodemus Siivola's avatar
Nikodemus Siivola committed
109
110
111
112
  "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
113
114
115
116
117
118
119
120

(defun emptyp (sequence)
  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
is not a sequence"
  (etypecase sequence
    (list (null sequence))
    (sequence (zerop (length sequence)))))

Attila Lendvai's avatar
Attila Lendvai committed
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
(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
175
176
(defun sequence-of-length-p (sequence length)
  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
Nikodemus Siivola's avatar
Nikodemus Siivola committed
177
SEQUENCE is not a sequence. Returns FALSE for circular lists."
178
179
180
  (declare (type array-index length)
           (inline length)
           (optimize speed))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
181
182
183
184
185
186
187
  (etypecase sequence
    (null
     (zerop length))
    (cons
     (let ((n (1- length)))
       (unless (minusp n)
         (let ((tail (nthcdr n sequence)))
188
189
190
191
           (and tail
                (null (cdr tail)))))))
    (vector
     (= length (length sequence)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
192
193
194
195
196
197
198
199
200
201
202
203
204
    (sequence
     (= length (length sequence)))))

(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."
205
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
206
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
207
  (cond  ((consp sequence)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
208
          (car sequence))
209
210
         ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
          (elt sequence 0))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
211
         (t
212
213
          (error 'type-error
                 :datum sequence
Nikodemus Siivola's avatar
Nikodemus Siivola committed
214
215
                 :expected-type '(and sequence (not (satisfies emptyp)))))))

216
217
218
(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."
219
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
220
221
222
  ;; type-error.
  (cond ((consp sequence)
         (setf (car sequence) object))
223
224
        ((and (typep sequence '(and sequence (not list)))
              (plusp (length sequence)))
225
226
         (setf (elt sequence 0) object))
        (t
227
228
         (error 'type-error
                :datum sequence
229
                :expected-type '(and sequence (not (satisfies emptyp)))))))
230

Nikodemus Siivola's avatar
Nikodemus Siivola committed
231
232
233
(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."
234
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
235
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
236
237
238
  (let ((len 0))
    (cond ((consp sequence)
           (lastcar sequence))
239
240
241
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
           (elt sequence (1- len)))
          (t
242
243
           (error 'type-error
                  :datum sequence
244
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
245

246
247
248
249
250
251
252
253
254
(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
255
256
           (error 'type-error
                  :datum sequence
257
258
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))

259
(defun starts-with-subseq (prefix sequence &rest args &key (return-suffix nil) &allow-other-keys)
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.

If RETURN-SUFFIX is T the functions returns, as a second value, a
displaced array pointing to the sequence after PREFIX."
  (remove-from-plistf args :return-suffix)
  (let ((sequence-length (length sequence))
        (prefix-length (length prefix)))
    (if (<= prefix-length sequence-length)
        (let ((mismatch (apply #'mismatch sequence prefix args)))
          (if mismatch
              (if (< mismatch prefix-length)
                  (values nil nil)
                  (values t (when return-suffix
                              (make-array (- sequence-length mismatch)
                                          :element-type (array-element-type sequence)
                                          :displaced-to sequence
                                          :displaced-index-offset prefix-length
                                          :adjustable nil))))
              (values t (when return-suffix
                          (make-array 0 :element-type (array-element-type sequence)
                                      :adjustable nil)))))
        (values nil nil))))

283
(defun ends-with-subseq (suffix sequence &key (test #'eql))
284
285
286
287
288
289
290
291
292
293
294
295
296
  "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))))

297
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
298
299
  "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."
300
  (funcall test
301
           (funcall key
302
303
304
305
306
307
308
309
310
                    (typecase sequence
                      (cons (car sequence))
                      (sequence
                       (if (plusp (length sequence))
                           (elt sequence 0)
                           (return-from starts-with nil)))
                      (t
                       (return-from starts-with nil))))
           object))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
311

312
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
313
314
315
  "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."
316
317
318
  (funcall test
           (funcall key
                    (typecase sequence
319
                      (cons
320
                       ;; signals for improper lists
321
                       (lastcar sequence))
322
                      (sequence
323
324
                       ;; Can't use last-elt, as that signals an error
                       ;; for empty sequences
325
326
327
328
329
330
331
                       (let ((len (length sequence)))
                         (if (plusp len)
                             (elt sequence (1- len))
                             (return-from ends-with nil))))
                      (t
                       (return-from ends-with nil))))
           object))
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398

(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
specified if a combination is modified by FUNCTION."
  (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
399
400
401
402
403
                     (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)))))))
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
             (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))
434
         ;; Bitvector that has 1 for elements that have been deranged.
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
         (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)))
461
462

(declaim (notinline sequence-of-length-p))