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

3
4
(defun rotate-tail-to-head (sequence n)
  (declare (type (integer 1) n))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
  (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)))

20
21
(defun rotate-head-to-tail (sequence n)
  (declare (type (integer 1) n))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
  (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)))

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
(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)))

52
53
(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
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
Permuted sequence may share storage with the original one. Signals
an error if SEQUENCE is not a proper sequence."
  (declare (fixnum start) ((or fixnum null) end))
  (let ((end (or end (if (listp sequence) (list-length sequence) (length sequence)))))
    (loop for i from start below end
       do (rotatef (elt sequence i) (elt sequence (random end)))))
  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."
  (declare (sequence sequence) (fixnum start) ((or fixnum null) end))
  (let ((i (+ start (random (- (or end  (if (listp sequence)
                                            (list-length sequence)
                                            (length sequence)))
                               start)))))
    (elt sequence i)))

(define-modify-macro removef (item &rest remove-keywords)
  (lambda (seq item &rest keyword-arguments)
    (apply #'remove item seq keyword-arguments))
  "Modify-macro for REMOVE. Sets place designated by the first argument to
the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")

(define-modify-macro deletef (item &rest remove-keywords)
  (lambda (seq item &rest keyword-arguments)
    (apply #'delete item seq keyword-arguments))
  "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
85
86
87
88
  "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
89
90
91
92
93
94
95
96
97
98

(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)))))

(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
99
SEQUENCE is not a sequence. Returns FALSE for circular lists."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
  (etypecase sequence
    (null
     (zerop length))
    (cons
     (let ((n (1- length)))
       (unless (minusp n)
         (let ((tail (nthcdr n sequence)))
           (and tail (null (cdr tail)))))))
    (sequence
     (= length (length sequence)))))

(declaim (inline copy-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."
122
123
  ;; Can't just directly use ELT, as it is not guaranteed to signal the 
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
124
  (cond  ((consp sequence)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
125
          (car sequence))
126
127
         ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
          (elt sequence 0))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
128
129
130
131
132
         (t
          (error 'type-error 
                 :datum sequence 
                 :expected-type '(and sequence (not (satisfies emptyp)))))))

133
134
135
136
137
138
139
140
141
142
143
144
145
146
(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."
  ;; Can't just directly use ELT, as it is not guaranteed to signal the 
  ;; type-error.
  (cond ((consp sequence)
         (setf (car sequence) object))
        ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
         (setf (elt sequence 0) object))
        (t
         (error 'type-error 
                :datum sequence 
                :expected-type '(and proper-sequence (not (satisfies emptyp)))))))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
147
148
149
(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."
150
151
  ;; Can't just directly use ELT, as it is not guaranteed to signal the 
  ;; type-error.
Nikodemus Siivola's avatar
Nikodemus Siivola committed
152
153
154
  (let ((len 0))
    (cond ((consp sequence)
           (lastcar sequence))
155
156
157
158
159
160
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
           (elt sequence (1- len)))
          (t
           (error 'type-error 
                  :datum sequence 
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
(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
           (error 'type-error 
                  :datum sequence 
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))

(defun starts-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
176
177
  "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."
178
179
180
181
182
183
184
185
186
187
188
  (funcall test
           (funcall key 
                    (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
189

190
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
191
192
193
  "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."
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
  (funcall test
           (funcall key
                    (typecase sequence
                      (cons 
                       ;; signals for improper lists
                       (lastcar sequence)) 
                      (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))))
           object))