1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
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
175
176
177
178
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
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
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
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
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
449
450
451
452
453
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
484
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
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
|
;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
;; ALL RIGHTS RESERVED.
;;
;; $Id: sequence.lisp,v 1.42 2004/02/20 07:23:42 yuji Exp $
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; * Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; * Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in
;; the documentation and/or other materials provided with the
;; distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defun length (sequence)
"Return the number of elements in SEQUENCE."
(cond ;; can't use etypecase for setf
((typep sequence 'list)
(let ((length (list-length sequence)))
(or length (error-circular-list sequence))))
((typep sequence 'vector)
(if (array-has-fill-pointer-p sequence)
(fill-pointer sequence)
(array-dimension sequence 0)))
(t
(error 'type-error :datum sequence :expected-type 'sequence))))
(defun check-sequence-access (sequence index)
(check-type sequence proper-sequence)
(check-type index (integer 0))
(unless (< index (length sequence))
(error-index-too-large sequence index)))
(defun check-subsequence (sequence start end)
(check-type sequence proper-sequence)
(check-type start (integer 0))
(check-type end (integer 0)))
(defun elt (sequence index)
"Return the element of SEQUENCE specified by INDEX."
(check-sequence-access sequence index)
(if (consp sequence)
(nth index sequence)
(aref sequence index)))
(defsetf elt (sequence index) (value)
"Set the element of SEQUENCE specified by INDEX."
(let ((seq (gensym))
(idx (gensym)))
`(let ((,seq ,sequence)
(,idx ,index))
(check-sequence-access ,seq ,idx)
(if (consp ,seq)
(progn (rplaca (nthcdr ,idx ,seq) ,value) ,value)
(setf (aref ,seq ,idx) ,value)))))
(defun reverse (sequence)
"Return a new sequence containing the same elements but in reverse order."
(check-type sequence proper-sequence)
(cond
((null sequence) nil)
((consp sequence) (do ((x sequence (cdr x))
(result nil (cons (car x) result)))
((null x) result)))
(t (let* ((length (length sequence))
(result (make-array length
:element-type (array-element-type sequence))))
(do ((i 0 (1+ i))
(j (1- length) (1- j)))
((>= i length) result)
(setf (aref result i) (aref sequence j)))))))
(defun nreverse (sequence)
"Modyfy SEQUENCE so that the elements are in reverse order."
(check-type sequence proper-sequence)
(cond
((null sequence) nil)
((consp sequence) (do ((1st (cdr sequence) (cdr 1st))
(2nd sequence 1st)
(3rd '() 2nd))
((null 2nd) 3rd)
(rplacd 2nd 3rd)))
(t (let ((length (length sequence)))
(do ((i 0 (1+ i))
(j (1- length) (1- j)))
((>= i j) sequence)
(rotatef (aref sequence i) (aref sequence j)))))))
(defun count-if (predicate sequence &key from-end (start 0) end key)
"Count the number of elements in SEQUENCE which satisfy PREDICATE."
(let ((count 0))
(do-subsequence (element sequence start end from-end count)
(when (funcall predicate (apply-key key element))
(incf count)))))
(defun count-if-not (predicate sequence &key from-end (start 0) end key)
"Count the number of elements in SEQUENCE which do not satisfy PREDICATE."
(count-if (complement predicate)
sequence :from-end from-end :start start :end end :key key))
(defun count (item sequence
&key from-end (start 0) end key (test #'eql) test-not)
"Count the number of ITEM in SEQUENCE bounded by START and END."
(when test-not (setq test (complement test-not)))
(count-if #'(lambda (arg) (funcall test item arg))
sequence :from-end from-end :start start :end end :key key))
(defun find-if (predicate sequence &key from-end (start 0) end key)
"Return the first element in SEQUENCE satisfying PREDICATE."
(do-subsequence (element sequence start end from-end nil)
(when (funcall predicate (apply-key key element))
(return element))))
(defun find-if-not (predicate sequence &key from-end (start 0) end key)
"Return the first element in SEQUENCE not satisfying PREDICATE."
(find-if (complement predicate) sequence
:from-end from-end :start start :end end :key key))
(defun find (item sequence
&key from-end (test #'eql) test-not (start 0) end key)
"Return the first element in SEQUENCE satisfying TEST or TEST-NOT."
(when test-not (setq test (complement test-not)))
(find-if #'(lambda (arg) (funcall test item arg))
sequence :from-end from-end :start start :end end :key key))
(defun position-if (predicate sequence &key from-end (start 0) end key)
"Return the position of an element in SEQUENCE satisfying PREDICATE."
(unless end (setq end (length sequence)))
(let ((i (if from-end (1- end) start))
(step (if from-end -1 1)))
(do-subsequence (element sequence start end from-end nil)
(when (funcall predicate (apply-key key element))
(return i))
(incf i step))))
(defun position-if-not (predicate sequence &key from-end (start 0) end key)
"Return the position of an element in SEQUENCE not satisfying PREDICATE."
(position-if (complement predicate) sequence
:from-end from-end :start start :end end :key key))
(defun position (item sequence
&key from-end (test #'eql) test-not (start 0) end key)
"Return the position of an element in SEQUENCE equal to ITEM by TEST."
(when test-not (setq test (complement test-not)))
(position-if #'(lambda (arg) (funcall test item arg))
sequence :from-end from-end :start start :end end :key key))
(defun make-iterator (sequence start end length from-end)
(check-subsequence sequence start end)
(if (listp sequence)
(let* ((head (if from-end
(nthcdr (- length end) (reverse sequence))
(nthcdr start sequence)))
(x head))
(values #'(lambda () (prog1 (car x) (setq x (cdr x))))
#'(lambda () (setq x head))))
(let* ((from (if from-end (1- end) start))
(i from)
(step (if from-end -1 1)))
(values #'(lambda () (prog1 (aref sequence i) (setq i (+ i step))))
#'(lambda () (setq i from))))))
(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not key
(start1 0) (start2 0) end1 end2)
"Return the first position in SEQUENCE2 that matches SEQUENCE1."
(when test-not (setq test (complement test-not)))
(let* ((length1 (length sequence1))
(end1 (or end1 length1))
(end2 (or end2 (length sequence2)))
(width1 (- end1 start1))
(last-match nil))
(multiple-value-bind (get1 reset1)
(make-iterator sequence1 start1 end1 length1 nil)
(etypecase sequence2
(null (when (zerop length1) 0))
(cons (do ((x (nthcdr start2 sequence2) (cdr x))
(i start2 (1+ i)))
((> i (- end2 width1)) (when from-end last-match))
(funcall reset1)
(do ((xx x (cdr xx))
(j 0 (1+ j)))
((>= j width1) (if from-end
(setq last-match i)
(return-from search i)))
(unless (funcall test (apply-key key (funcall get1))
(apply-key key (car xx)))
(return)))))
(vector (do ((i start2 (1+ i)))
((> i (- end2 width1)) (when from-end last-match))
(funcall reset1)
(do ((ii i (1+ ii))
(j 0 (1+ j)))
((>= j width1) (if from-end
(setq last-match i)
(return-from search i)))
(unless (funcall test (apply-key key (funcall get1))
(apply-key key (aref sequence2 ii)))
(return)))))))))
(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not key
(start1 0) (start2 0) end1 end2)
"Return the first position where SEQUENCE1 and SEQUENCE2 differ."
(when test-not (setq test (complement test-not)))
(let* ((length1 (length sequence1))
(length2 (length sequence2))
(end1 (or end1 length1))
(end2 (or end2 length2))
(width1 (- end1 start1))
(width2 (- end2 start2))
(width (min width1 width2))
(s1 (if from-end (- end1 width) start1))
(e1 (if from-end end1 (+ start1 width))))
(multiple-value-bind (get2 reset2)
(make-iterator sequence2 start2 end2 length2 from-end)
(declare (ignore reset2))
(let ((i1 (if from-end (1- end1) start1))
(step (if from-end -1 1)))
(do-subsequence (element1 sequence1 s1 e1 from-end
(cond ((= width1 width2) nil)
((< width1 width2) (if from-end 0 end1))
(t (if from-end
(- end1 width2)
(+ start1 width2)))))
(unless (funcall test (apply-key key element1)
(apply-key key (funcall get2)))
(return (if from-end (1+ i1) i1)))
(incf i1 step))))))
(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
"Modify SEQUENCE1 destructively by replacing elements with those of SUBSEQUENCE2."
(let* ((length2 (length sequence2))
(end1 (or end1 (length sequence1)))
(end2 (or end2 length2))
(width1 (- end1 start1))
(width2 (- end2 start2))
(width (min width1 width2))
(from-end nil))
(when (< start2 start1 (+ start2 width))
(setq sequence2 (copy-seq sequence2)))
(multiple-value-bind (get2 reset2)
(make-iterator sequence2 start2 end2 length2 from-end)
(declare (ignore reset2))
(do-subsequence (element1 sequence1 start1 (+ start1 width) from-end)
(setf element1 (funcall get2)))
sequence1)))
(defun subseq (sequence start &optional end)
"Return a copy of the subsequence of SEQUENCE bounded by START and END."
(unless end (setq end (length sequence)))
(check-subsequence sequence start end)
(etypecase sequence
(list (do* ((x (nthcdr start sequence) (cdr x))
(i start (1+ i))
(result (list nil))
(splice result))
((>= i end) (cdr result))
(setq splice (cdr (rplacd splice (list (car x)))))))
(vector (let* ((width (- end start))
(result (make-array width
:element-type
(array-element-type sequence))))
(do ((i 0 (1+ i))
(j start (1+ j)))
((>= i width) result)
(setf (aref result i) (aref sequence j)))))))
(defsetf subseq (sequence start &optional (end nil)) (new-subsequence)
"Replace destructively the subsequence of SEQUENCE with NEW-SUBSEQUENCE."
`(progn
(check-type ,new-subsequence sequence)
(replace ,sequence ,new-subsequence :start1 ,start :end1 ,end)
,new-subsequence))
(defun copy-seq (sequence)
"Create a copy of SEQUENCE."
(subseq sequence 0))
(defun nsubstitute-if (newitem predicate sequence &key from-end
(start 0) end count key)
"Modify SEQUENCE substituting NEWITEM for elements satisfying PREDICATE."
(when (or (null count) (plusp count))
(do-subsequence (element sequence start end from-end)
(when (funcall predicate (apply-key key element))
(setf element newitem)
(when (and count (zerop (setq count (1- count))))
(return)))))
sequence)
(defun nsubstitute (newitem olditem sequence &key from-end (test #'eql) test-not
(start 0) end count key)
"Modify SEQUENCE substituting NEWITEM for elements euqal to OLDITEM."
(when test-not (setq test (complement test-not)))
(nsubstitute-if newitem #'(lambda (item) (funcall test olditem item))
sequence :from-end from-end :start start :end end
:count count :key key))
(defun nsubstitute-if-not (newitem predicate sequence &key from-end
(start 0) end count key)
"Modify SEQUENCE substituting NEWITEM for elements not satisfying PREDICATE."
(nsubstitute-if newitem (complement predicate) sequence :from-end from-end
:start start :end end :count count :key key))
(defun substitute (newitem olditem sequence &key from-end (test #'eql) test-not
(start 0) end count key)
"Return a copy of SEQUENCE with elements euqal to OLDITEM replaced with NEWITEM."
(nsubstitute newitem olditem (copy-seq sequence) :from-end from-end :test test
:test-not test-not :start start :end end :count count :key key))
(defun substitute-if (newitem predicate sequence &key from-end (start 0) end
count key)
"Return a copy of SEQUENCE with elements satisfying PREDICATE replaced with NEWITEM."
(nsubstitute-if newitem predicate (copy-seq sequence) :from-end from-end
:start start :end end :count count :key key))
(defun substitute-if-not (newitem predicate sequence &key from-end (start 0) end
count key)
"Return a copy of SEQUENCE with elements not satisfying PREDICATE replaced with NEWITEM."
(nsubstitute-if-not newitem predicate (copy-seq sequence) :from-end from-end
:start start :end end :count count :key key))
(defun fill (sequence item &key (start 0) end)
"Replace the elements of SEQUENCE bounded by START and END with ITEM."
(nsubstitute-if item (constantly t) sequence :start start :end end))
(defun concatenate (result-type &rest sequences)
"Return a sequence of RESULT-TYPE that have all the elements of SEQUENCES."
(cond
((subtypep result-type 'list)
(let* ((list (list nil))
(splice list))
(dolist (seq sequences (cdr list))
(do-subsequence (element seq 0)
(setq splice (cdr (rplacd splice (cons element nil))))))))
((subtypep result-type 'vector)
(let ((vector (make-sequence result-type
(apply #'+ (mapcar #'length sequences))))
(i 0))
(dolist (seq sequences vector)
(do-subsequence (element seq 0)
(setf (aref vector i) element)
(incf i)))))
(t
(error 'type-error
:datum result-type
:expected-type '(or null sequence)))))
(defun merge-lists (list1 list2 predicate key)
(let* ((list (list nil))
(splice list))
(do ((x1 list1)
(x2 list2))
((or (endp x1) (endp x2)) (rplacd splice (or x1 x2)) (cdr list))
(if (funcall predicate (apply-key key (car x2))
(apply-key key (car x1)))
(setq splice (cdr (rplacd splice x2))
x2 (cdr x2))
(setq splice (cdr (rplacd splice x1))
x1 (cdr x1))))))
(defun merge (result-type sequence1 sequence2 predicate &key key)
"Merge SEQUENCE1 with SEQUENCE2 destructively according to an order determined by the PREDICATE."
(let ((merged-list (merge-lists (coerce sequence1 'list)
(coerce sequence2 'list) predicate key)))
(cond ((subtypep result-type 'list) merged-list)
((subtypep result-type 'vector) (coerce merged-list result-type))
(t (error 'type-error
:datum result-type
:expected-type '(or null sequence))))))
(defun quicksort-vector (vector predicate key)
(labels ((quicksort (left right)
(if (<= right left)
vector
(let ((v (partition left right)))
(quicksort left (1- v))
(quicksort (1+ v) right))))
(partition (left right)
(let ((pivot (apply-key key (aref vector right)))
(l left)
(r (1- right)))
(loop (loop (unless (funcall predicate
(apply-key key (aref vector l))
pivot)
(return))
(incf l))
(loop (when (or (>= l r)
(funcall predicate
(apply-key key (aref vector r))
pivot))
(return))
(decf r))
(when (>= l r)
(return))
(rotatef (aref vector l) (aref vector r)))
(rotatef (aref vector l) (aref vector right))
l)))
(quicksort 0 (1- (length vector)))))
(defun sort (sequence predicate &key key)
"Sort SEQUENCE destructively according to the order determined by PREDICATE."
(if (vectorp sequence)
(quicksort-vector sequence predicate key)
(let ((vector (quicksort-vector (make-array (length sequence)
:initial-contents sequence)
predicate key)))
(do ((x sequence (cdr x))
(i 0 (1+ i)))
((endp x) sequence)
(rplaca x (aref vector i))))))
(defun mergesort-list (list predicate key)
(labels ((mergesort (list length)
(if (<= length 1)
list
(let* ((length1 (floor (/ length 2)))
(length2 (- length length1))
(list1 list)
(last1 (nthcdr (1- length1) list))
(list2 (cdr last1)))
(rplacd last1 nil)
(merge 'list
(mergesort list1 length1) (mergesort list2 length2)
predicate :key key)))))
(mergesort list (length list))))
(defun stable-sort (sequence predicate &key key)
"Sort SEQUENCE destructively guaranteeing the stability of equal elements' order."
(if (listp sequence)
(mergesort-list sequence predicate key)
(let ((list (mergesort-list (coerce sequence 'list) predicate key)))
(do ((x list (cdr x))
(i 0 (1+ i)))
((endp x) sequence)
(setf (aref sequence i) (car x))))))
(defun list-delete-if (test list start end count key)
(let* ((head (cons nil list))
(splice head))
(do ((i 0 (1+ i))
(x list (cdr x)))
((endp x) (rplacd splice nil) (cdr head))
(when (and count (<= count 0))
(rplacd splice x)
(return (cdr head)))
(if (and (<= start i) (or (null end) (< i end))
(funcall test (apply-key key (car x))))
(when count (decf count))
(setq splice (cdr (rplacd splice x)))))))
(defun vector-delete-if (test vector start end count key)
(let* ((length (length vector))
(end (or end length))
(count (or count length))
(i 0))
(do* ((j 0 (1+ j))
element)
((>= j length))
(setq element (aref vector j))
(if (and (<= start j) (< j end)
(plusp count)
(funcall test (apply-key key element)))
(when count (decf count))
(progn
(setf (aref vector i) element)
(incf i))))
(cond
((array-has-fill-pointer-p vector)
(setf (fill-pointer vector) i)
vector)
((adjustable-array-p vector) (adjust-array vector i))
(t (subseq vector 0 i)))))
(defun delete-if (predicate sequence &key from-end (start 0) end count key)
"Modify SEQUENCE by deleting elements satisfying PREDICATE."
(if from-end
(let ((length (length sequence)))
(nreverse (delete-if predicate (nreverse sequence)
:start (- length (or end length))
:end (- length start)
:count count :key key)))
(etypecase sequence
(null nil)
(cons (list-delete-if predicate sequence start end count key))
(vector (vector-delete-if predicate sequence start end count key)))))
(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) end
count key)
"Modify SEQUENCE by deleting elements equal to ITEM."
(when test-not (setq test (complement test-not)))
(delete-if #'(lambda (arg) (funcall test item arg)) sequence
:from-end from-end :start start :end end :count count :key key))
(defun delete-if-not (predicate sequence &key from-end (start 0) end count key)
"Modify SEQUENCE by deleting elements not satisfying PREDICATE."
(delete-if (complement predicate) sequence :from-end from-end
:start start :end end :count count :key key))
(defun remove-if (predicate sequence &key from-end (start 0) end count key)
"Return a copy of SEQUENCE with elements satisfying PREDICATE removed."
(delete-if predicate (copy-seq sequence) :from-end from-end :start start :end end
:count count :key key))
(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
end count key)
"Return a copy of SEQUENCE with elements equal to ITEM removed."
(when test-not (setq test (complement test-not)))
(remove-if #'(lambda (arg) (funcall test item arg)) sequence
:from-end from-end :start start :end end :count count :key key))
(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
"Return a copy of SEQUENCE with elements not satisfying PREDICATE removed."
(remove-if (complement predicate) sequence :from-end from-end
:start start :end end :count count :key key))
(defun list-delete-duplicates (test list start end key)
(check-type list proper-list)
(let* ((head (cons nil list))
(splice head)
(tail (when end (nthcdr end list))))
(flet ((list-member (list)
(do ((x (cdr list) (cdr x))
(item (car list)))
((eq x tail) nil)
(when (funcall test (apply-key key item) (apply-key key (car x)))
(return t)))))
(do ((i 0 (1+ i))
(x list (cdr x)))
((endp x) (rplacd splice nil) (cdr head))
(unless (and (<= start i) (or (null end) (< i end)) (list-member x))
(setq splice (cdr (rplacd splice x))))))))
(defun vector-delete-duplicates (test vector start end key)
(let* ((length (length vector))
(end (or end length))
(i 0))
(flet ((vector-member (item j)
(do ((k (1+ j) (1+ k)))
((>= k end) nil)
(when (funcall test (apply-key key item)
(apply-key key (aref vector k)))
(return t)))))
(do* ((j 0 (1+ j))
element)
((>= j length))
(setq element (aref vector j))
(unless (and (<= start j) (< j end) (vector-member element j))
(setf (aref vector i) element)
(incf i)))
(cond
((array-has-fill-pointer-p vector)
(setf (fill-pointer vector) i)
vector)
((adjustable-array-p vector) (adjust-array vector i))
(t (subseq vector 0 i))))))
(defun delete-duplicates (sequence &key from-end (test #'eql) test-not
(start 0) end key)
"Modify SEQUENCE deleting redundant elements."
(when test-not (setq test (complement test-not)))
(if from-end
(let ((length (length sequence)))
(nreverse (delete-duplicates (nreverse sequence) :test test :key key
:start (- length (or end length))
:end (- length start))))
(etypecase sequence
(null nil)
(cons (list-delete-duplicates test sequence start end key))
(vector (vector-delete-duplicates test sequence start end key)))))
(defun remove-duplicates (sequence &key from-end (test #'eql) test-not
(start 0) end key)
"Return a copy of SEQUENCE with redundant elements removed."
(delete-duplicates (copy-seq sequence) :from-end from-end :key key
:test test :test-not test-not :start start :end end))
(defun reduce (function sequence &key key from-end (start 0) end
(initial-value nil initial-value-supplied))
"Use a binary operation FUNCTION to combine the elements of SEQUENCE."
(unless end (setq end (length sequence)))
(check-subsequence sequence start end)
(if (= start end)
(if initial-value-supplied initial-value (funcall function))
(let ((fun (if from-end #'(lambda (a b) (funcall function b a)) function))
(value (if initial-value-supplied
initial-value
(apply-key key (if from-end
(elt sequence (decf end))
(prog1 (elt sequence start)
(incf start)))))))
(do-subsequence (element sequence start end from-end value)
(setq value (funcall fun value (apply-key key element)))))))
(defmacro do-sequences ((var sequences &optional (result nil)) &body body)
(let ((seq-list (gensym))
(i (gensym))
(min (gensym)))
`(let* ((,seq-list (copy-seq ,sequences))
(,var (make-list (list-length ,seq-list) :initial-element nil))
(,min (if ,seq-list (reduce #'min ,seq-list :key #'length) 0)))
(dotimes (,i ,min ,result)
(do* ((src ,seq-list (cdr src))
(seq (car src) (car src))
(dest ,var (cdr dest)))
((null src))
(rplaca dest (if (consp seq)
(progn
(rplaca src (cdr seq))
(car seq))
(aref seq ,i))))
,@body))))
(defun map-into (result-sequence function &rest sequences)
"Modify RESULT-SEQUENCE, applying FUNCTION to the elements of SEQUENCES."
(etypecase result-sequence
(null nil)
(cons (let ((x result-sequence))
(do-sequences (args sequences result-sequence)
(when (endp x) (return result-sequence))
(rplaca x (apply function args))
(setq x (cdr x)))))
(vector (let ((i 0)
(length (array-dimension result-sequence 0)))
(do-sequences (args sequences)
(when (= i length) (return))
(setf (aref result-sequence i) (apply function args))
(setq i (1+ i)))
(when (array-has-fill-pointer-p result-sequence)
(setf (fill-pointer result-sequence) i))
result-sequence))))
(defun map (result-type function sequence &rest more-sequences)
"Apply FUNCTION to the successive elements of SEQUENCE and MORE-SEQUENCES."
(if (null result-type)
(do-sequences (args (cons sequence more-sequences) nil)
(apply function args))
(let* ((sequences (cons sequence more-sequences))
(seq (make-sequence result-type
(reduce #'min sequences :key #'length))))
(apply #'map-into seq function sequences))))
(defun every (predicate sequence &rest more-sequences)
"Return true if and only if every invocation of PREDICATE on SEQUENCE returns true."
(do-sequences (args (cons sequence more-sequences) t)
(unless (apply predicate args)
(return nil))))
(defun some (predicate sequence &rest more-sequences)
"Return true if and only if some invocation of PREDICATE on SEQUENCE returns true."
(do-sequences (args (cons sequence more-sequences) nil)
(when (apply predicate args)
(return t))))
(defun notevery (predicate sequence &rest more-sequences)
"Return true if and only if some invocation of PREDICATE on SEQUENCE returns false."
(not (apply #'every predicate sequence more-sequences)))
(defun notany (predicate sequence &rest more-sequences)
"Return true if and only if every invocation of PREDICATE on SEQUENCE returns false."
(not (apply #'some predicate sequence more-sequences)))
|