1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Sun Sep 15 07:42:36 2002 |
---|
4 | ;;;; Contains: Auxiliary functions for testing REMOVE and related functions |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (defun make-random-element (type) |
---|
9 | (cond |
---|
10 | ((subtypep* 'fixnum type) |
---|
11 | (random most-positive-fixnum)) |
---|
12 | ((and (listp type) |
---|
13 | (eql (car type) 'integer) |
---|
14 | (integerp (cadr type)) |
---|
15 | (integerp (caddr type)) |
---|
16 | (null (cdddr type))) |
---|
17 | (+ (cadr type) (random (- (1+ (caddr type)) (cadr type))))) |
---|
18 | ((subtypep* '(integer 0 255) type) |
---|
19 | (random 255)) |
---|
20 | ((subtypep* '(integer 0 7) type) |
---|
21 | (random 8)) |
---|
22 | ((subtypep* 'bit type) |
---|
23 | (random 2)) |
---|
24 | ((subtypep* 'symbol type) |
---|
25 | (elt '(a b c d e f g h) (random 8))) |
---|
26 | ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) |
---|
27 | (elt "abcdefgh" (random 8))) |
---|
28 | (t (error "Can't get random element of type ~A~%." type)))) |
---|
29 | |
---|
30 | (defun make-random-remove-input (len type element-type) |
---|
31 | |
---|
32 | "Randomly generate a test case for REMOVE. Given a length |
---|
33 | a sequence type, and an element type, produce a random |
---|
34 | sequence of length LEN of sequence type TYPE, and either |
---|
35 | generate a random member of the sequence or a random |
---|
36 | element of the element type to delete from the sequence." |
---|
37 | |
---|
38 | (let* ((seq (if (subtypep* type 'list) |
---|
39 | (loop for i from 1 to len collect |
---|
40 | (make-random-element element-type)) |
---|
41 | (let ((seq (if (and (subtypep type 'vector) |
---|
42 | (coin 3)) |
---|
43 | (make-array |
---|
44 | (list (+ len (random (1+ len)))) |
---|
45 | :initial-element (make-random-element element-type) |
---|
46 | :fill-pointer len |
---|
47 | :element-type element-type) |
---|
48 | (make-sequence type len)))) |
---|
49 | (dotimes (i len) |
---|
50 | (setf (elt seq i) (make-random-element element-type))) |
---|
51 | seq))) |
---|
52 | (e (if (and (> len 0) (coin)) |
---|
53 | (elt seq (random len)) |
---|
54 | (make-random-element element-type))) |
---|
55 | ) |
---|
56 | (values len seq e))) |
---|
57 | |
---|
58 | (defun my-remove (element |
---|
59 | sequence |
---|
60 | &key |
---|
61 | (start 0) |
---|
62 | (end nil) |
---|
63 | (test #'eql test-p) |
---|
64 | (test-not nil test-not-p) |
---|
65 | (key nil) |
---|
66 | (from-end nil) |
---|
67 | (count nil)) |
---|
68 | (assert (not (and test-p test-not-p))) |
---|
69 | (my-remove-if |
---|
70 | (cond (test-p |
---|
71 | (setf test (coerce test 'function)) |
---|
72 | #'(lambda (x) (funcall (the function test) element x))) |
---|
73 | (test-not-p |
---|
74 | (setf test-not (coerce test-not 'function)) |
---|
75 | #'(lambda (x) (not (funcall (the function test-not) element x)))) |
---|
76 | (t #'(lambda (x) (eql element x)))) |
---|
77 | sequence :start start :end end :key key :from-end from-end :count count)) |
---|
78 | |
---|
79 | (defun my-remove-if (predicate |
---|
80 | original-sequence |
---|
81 | &key (from-end nil) |
---|
82 | (start 0) |
---|
83 | (end nil) |
---|
84 | (count nil) |
---|
85 | (key #'identity)) |
---|
86 | (let ((len (length original-sequence)) |
---|
87 | (sequence (copy-seq original-sequence))) |
---|
88 | (unless end (setq end len)) |
---|
89 | (unless key (setq key #'identity)) |
---|
90 | (unless count (setq count len)) |
---|
91 | |
---|
92 | ;; Check that everything's kosher |
---|
93 | (assert (<= 0 start end len)) |
---|
94 | (assert (typep sequence 'sequence)) |
---|
95 | (assert (integerp count)) |
---|
96 | (assert (or (symbolp predicate) (functionp predicate))) |
---|
97 | (assert (or (symbolp key) (functionp key))) |
---|
98 | |
---|
99 | (setf predicate (coerce predicate 'function)) |
---|
100 | (setf key (coerce key 'function)) |
---|
101 | |
---|
102 | ;; If FROM-END, reverse the sequence and flip |
---|
103 | ;; start, end |
---|
104 | (when from-end |
---|
105 | (psetq sequence (nreverse sequence) |
---|
106 | start (- len end) |
---|
107 | end (- len start))) |
---|
108 | |
---|
109 | ;; Accumulate a list of elements for the result |
---|
110 | (let ((pos 0) |
---|
111 | (result nil)) ;; accumulate in reverse order |
---|
112 | (map nil |
---|
113 | #'(lambda (e) |
---|
114 | (if (and (> count 0) |
---|
115 | (>= pos start) |
---|
116 | (< pos end) |
---|
117 | (funcall (the function predicate) |
---|
118 | (funcall (the function key) e))) |
---|
119 | (decf count) |
---|
120 | (push e result)) |
---|
121 | (incf pos)) |
---|
122 | sequence) |
---|
123 | (unless from-end |
---|
124 | (setq result (nreverse result))) |
---|
125 | ;; Convert to the correct type |
---|
126 | (if (listp sequence) |
---|
127 | result |
---|
128 | (let ((element-type (array-element-type original-sequence))) |
---|
129 | (make-array (length result) :element-type element-type |
---|
130 | :initial-contents result)))))) |
---|
131 | |
---|
132 | (defun my-remove-if-not (pred &rest args) |
---|
133 | (when (symbolp pred) |
---|
134 | (setq pred (coerce pred 'function))) |
---|
135 | (assert (typep pred 'function)) |
---|
136 | (apply #'my-remove-if (complement pred) args)) |
---|
137 | |
---|
138 | (defun make-random-rd-params (maxlen) |
---|
139 | "Generate random paramaters for remove/delete/etc. functions." |
---|
140 | (let* ((element-type |
---|
141 | (rcase |
---|
142 | (2 t) |
---|
143 | (1 'bit) |
---|
144 | (1 '(integer 0 2)) |
---|
145 | (1 'symbol))) |
---|
146 | (type-select (random 7)) |
---|
147 | (type |
---|
148 | (case type-select |
---|
149 | (0 'list) |
---|
150 | (1 'vector) |
---|
151 | (2 (setq element-type 'character) 'string) |
---|
152 | (3 (setq element-type 'bit) 'bit-vector) |
---|
153 | (4 'simple-vector) |
---|
154 | (5 (setq element-type '(integer 0 255)) |
---|
155 | '(vector (integer 0 255))) |
---|
156 | (6 (setq element-type 'fixnum) '(vector fixnum)) |
---|
157 | (t (error "Can't happen?!~%")))) |
---|
158 | (len (random maxlen)) |
---|
159 | (start (and (coin) (> len 0) |
---|
160 | (random len))) |
---|
161 | (end (and (coin) |
---|
162 | (if start (+ start (random (- len start))) |
---|
163 | (random (1+ len))))) |
---|
164 | (from-end (coin)) |
---|
165 | (count (case (random 5) |
---|
166 | ((0 1) nil) |
---|
167 | ((2 3) (random (1+ len))) |
---|
168 | (t (if (coin) -1 -10000000000000)))) |
---|
169 | (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) |
---|
170 | (declare (ignore x z)) |
---|
171 | y)) |
---|
172 | (key (and (coin) |
---|
173 | (case type-select |
---|
174 | (2 (random-case |
---|
175 | #'char-upcase 'char-upcase |
---|
176 | #'char-downcase 'char-downcase)) |
---|
177 | (3 #'(lambda (x) (- 1 x))) |
---|
178 | ((5 6) (random-case #'1+ '1+ #'1- '1-)) |
---|
179 | (t (random-case 'identity #'identity))))) |
---|
180 | (test (and (eql (random 3) 0) |
---|
181 | (random-case 'eq 'eql 'equal |
---|
182 | #'eq #'eql #'equal))) |
---|
183 | (test-not (and (not test) |
---|
184 | (coin) |
---|
185 | (random-case 'eq 'eql 'equal |
---|
186 | #'eq #'eql #'equal))) |
---|
187 | ) |
---|
188 | ;; Return parameters |
---|
189 | (values |
---|
190 | element-type type len start end from-end count seq key test test-not))) |
---|
191 | |
---|
192 | (defun random-test-remove-args (maxlen) |
---|
193 | (multiple-value-bind (element-type type len start end from-end count seq key test test-not) |
---|
194 | (make-random-rd-params maxlen) |
---|
195 | (declare (ignore type)) |
---|
196 | (let ((element (if (and (coin) (> len 0)) |
---|
197 | (random-from-seq seq) |
---|
198 | (make-random-element element-type))) |
---|
199 | (arg-list |
---|
200 | (reduce #'nconc |
---|
201 | (random-permute |
---|
202 | (list |
---|
203 | (when start (list :start start)) |
---|
204 | (cond (end (list :end end)) |
---|
205 | ((coin) (list :end nil))) |
---|
206 | (cond (from-end (list :from-end from-end)) |
---|
207 | ((coin) (list :from-end nil))) |
---|
208 | (cond (count (list :count count)) |
---|
209 | ((coin) (list :count nil))) |
---|
210 | (cond (key (list :key key)) |
---|
211 | ;; ((coin) (list :key nil)) |
---|
212 | ) |
---|
213 | (when test (list :test test)) |
---|
214 | (when test-not (list :test test-not))))))) |
---|
215 | (values element seq arg-list)))) |
---|
216 | |
---|
217 | (defparameter *remove-fail-args* nil) |
---|
218 | |
---|
219 | (defun random-test-remove (maxlen &key (tested-fn #'remove) |
---|
220 | (check-fn #'my-remove) |
---|
221 | (pure t)) |
---|
222 | (setf tested-fn (coerce tested-fn 'function)) |
---|
223 | (setf check-fn (coerce check-fn 'function)) |
---|
224 | (multiple-value-bind (element seq arg-list) |
---|
225 | (random-test-remove-args maxlen) |
---|
226 | (let* ((seq1 (copy-seq seq)) |
---|
227 | (seq2 (copy-seq seq)) |
---|
228 | (seq1r (apply (the function tested-fn) element seq1 arg-list)) |
---|
229 | (seq2r (apply (the function check-fn) element seq2 arg-list))) |
---|
230 | (setq *remove-fail-args* (list* element seq arg-list)) |
---|
231 | (cond |
---|
232 | ((and pure (not (equalp seq seq1))) :fail1) |
---|
233 | ((and pure (not (equalp seq seq2))) :fail2) |
---|
234 | ((not (equalp seq1r seq2r)) :fail3) |
---|
235 | (t t))))) |
---|
236 | |
---|
237 | (defun random-test-remove-if (maxlen &optional (negate nil)) |
---|
238 | (multiple-value-bind (element seq arg-list) |
---|
239 | (random-test-remove-args maxlen) |
---|
240 | (let ((fn (getf arg-list :key)) |
---|
241 | (test (getf arg-list :test))) |
---|
242 | (remf arg-list :key) |
---|
243 | (remf arg-list :test) |
---|
244 | (remf arg-list :test-not) |
---|
245 | (unless test (setq test #'eql)) |
---|
246 | (setf test (coerce test 'function)) |
---|
247 | (if fn |
---|
248 | (case (random 3) |
---|
249 | (0 (setf arg-list (list* :key 'identity arg-list))) |
---|
250 | (1 (setf arg-list (list* :key #'identity arg-list))) |
---|
251 | (t nil)) |
---|
252 | (setf fn (if (coin) 'identity |
---|
253 | #'(lambda (x) (funcall (the function test) |
---|
254 | element x))))) |
---|
255 | (let* ((seq1 (copy-seq seq)) |
---|
256 | (seq2 (copy-seq seq)) |
---|
257 | (seq1r (apply (if negate #'remove-if-not #'remove-if) |
---|
258 | fn seq1 arg-list)) |
---|
259 | (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) |
---|
260 | fn seq2 arg-list))) |
---|
261 | (setq *remove-fail-args* (cons seq1 arg-list)) |
---|
262 | (cond |
---|
263 | ((not (equalp seq seq1)) :fail1) |
---|
264 | ((not (equalp seq seq2)) :fail2) |
---|
265 | ((not (equalp seq1r seq2r)) :fail3) |
---|
266 | (t t)))))) |
---|
267 | |
---|
268 | (defun random-test-delete (maxlen) |
---|
269 | (random-test-remove maxlen :tested-fn #'delete :pure nil)) |
---|
270 | |
---|
271 | (defun random-test-delete-if (maxlen &optional (negate nil)) |
---|
272 | (multiple-value-bind (element seq arg-list) |
---|
273 | (random-test-remove-args maxlen) |
---|
274 | (let ((fn (getf arg-list :key)) |
---|
275 | (test (getf arg-list :test))) |
---|
276 | (remf arg-list :key) |
---|
277 | (remf arg-list :test) |
---|
278 | (remf arg-list :test-not) |
---|
279 | (unless test (setq test #'eql)) |
---|
280 | (setf test (coerce test 'function)) |
---|
281 | (if fn |
---|
282 | (case (random 3) |
---|
283 | (0 (setf arg-list (list* :key 'identity arg-list))) |
---|
284 | (1 (setf arg-list (list* :key #'identity arg-list))) |
---|
285 | (t nil)) |
---|
286 | (setf fn (if (coin) 'identity |
---|
287 | #'(lambda (x) (funcall (the function test) element x))))) |
---|
288 | (setq *remove-fail-args* (list* seq arg-list)) |
---|
289 | (let* ((seq1 (copy-seq seq)) |
---|
290 | (seq2 (copy-seq seq)) |
---|
291 | (seq1r (apply (if negate #'delete-if-not #'delete-if) |
---|
292 | fn seq1 arg-list)) |
---|
293 | (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) |
---|
294 | fn seq2 arg-list))) |
---|
295 | (cond |
---|
296 | ((not (equalp seq1r seq2r)) :fail3) |
---|
297 | (t t)))))) |
---|