1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Thu Mar 6 17:45:42 2003 |
---|
4 | ;;;; Contains: Auxiliary functions for cons-related tests |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | ;;; |
---|
9 | ;;; A scaffold is a structure that is used to remember the object |
---|
10 | ;;; identities of the cons cells in a (noncircular) data structure. |
---|
11 | ;;; This lets us check if the data structure has been changed by |
---|
12 | ;;; an operation. |
---|
13 | ;;; |
---|
14 | |
---|
15 | (defstruct scaffold |
---|
16 | node |
---|
17 | car |
---|
18 | cdr) |
---|
19 | |
---|
20 | (defun make-scaffold-copy (x) |
---|
21 | "Make a tree that will be used to check if a tree has been changed." |
---|
22 | (if |
---|
23 | (consp x) |
---|
24 | (make-scaffold :node x |
---|
25 | :car (make-scaffold-copy (car x)) |
---|
26 | :cdr (make-scaffold-copy (cdr x))) |
---|
27 | (make-scaffold :node x |
---|
28 | :car nil |
---|
29 | :cdr nil))) |
---|
30 | |
---|
31 | (defun check-scaffold-copy (x xcopy) |
---|
32 | "Return t if xcopy were produced from x by make-scaffold-copy, |
---|
33 | and none of the cons cells in the tree rooted at x have been |
---|
34 | changed." |
---|
35 | |
---|
36 | (and (eq x (scaffold-node xcopy)) |
---|
37 | (or |
---|
38 | (not (consp x)) |
---|
39 | (and |
---|
40 | (check-scaffold-copy (car x) (scaffold-car xcopy)) |
---|
41 | (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) |
---|
42 | |
---|
43 | (defun create-c*r-test (n) |
---|
44 | (cond |
---|
45 | ((<= n 0) 'none) |
---|
46 | (t |
---|
47 | (cons (create-c*r-test (1- n)) |
---|
48 | (create-c*r-test (1- n)))))) |
---|
49 | |
---|
50 | (defun nth-1-body (x) |
---|
51 | (loop |
---|
52 | for e in x |
---|
53 | and i from 0 |
---|
54 | count (not (eqt e (nth i x))))) |
---|
55 | |
---|
56 | (defun check-cons-copy (x y) |
---|
57 | "Check that the tree x is a copy of the tree y, |
---|
58 | returning t if it is, nil if not." |
---|
59 | (cond |
---|
60 | ((consp x) |
---|
61 | (and (consp y) |
---|
62 | (not (eqt x y)) |
---|
63 | (check-cons-copy (car x) (car y)) |
---|
64 | (check-cons-copy (cdr x) (cdr y)))) |
---|
65 | ((eqt x y) t) |
---|
66 | (t nil))) |
---|
67 | |
---|
68 | (defun check-sublis (a al &key (key 'no-key) test test-not) |
---|
69 | "Apply sublis al a with various keys. Check that |
---|
70 | the arguments are not themselves changed. Return nil |
---|
71 | if the arguments do get changed." |
---|
72 | (setf a (copy-tree a)) |
---|
73 | (setf al (copy-tree al)) |
---|
74 | (let ((acopy (make-scaffold-copy a)) |
---|
75 | (alcopy (make-scaffold-copy al))) |
---|
76 | (let ((as |
---|
77 | (apply #'sublis al a |
---|
78 | `(,@(when test `(:test ,test)) |
---|
79 | ,@(when test-not `(:test-not ,test-not)) |
---|
80 | ,@(unless (eqt key 'no-key) `(:key ,key)))))) |
---|
81 | (and |
---|
82 | (check-scaffold-copy a acopy) |
---|
83 | (check-scaffold-copy al alcopy) |
---|
84 | as)))) |
---|
85 | |
---|
86 | (defun check-nsublis (a al &key (key 'no-key) test test-not) |
---|
87 | "Apply nsublis al a, copying these arguments first." |
---|
88 | (setf a (copy-tree a)) |
---|
89 | (setf al (copy-tree al)) |
---|
90 | (let ((as |
---|
91 | (apply #'sublis (copy-tree al) (copy-tree a) |
---|
92 | `(,@(when test `(:test ,test)) |
---|
93 | ,@(when test-not `(:test-not ,test-not)) |
---|
94 | ,@(unless (eqt key 'no-key) `(:key ,key)))))) |
---|
95 | as)) |
---|
96 | |
---|
97 | (defun check-subst (new old tree &key (key 'no-key) test test-not) |
---|
98 | "Call subst new old tree, with keyword arguments if present. |
---|
99 | Check that the arguments are not changed." |
---|
100 | (setf new (copy-tree new)) |
---|
101 | (setf old (copy-tree old)) |
---|
102 | (setf tree (copy-tree tree)) |
---|
103 | (let ((newcopy (make-scaffold-copy new)) |
---|
104 | (oldcopy (make-scaffold-copy old)) |
---|
105 | (treecopy (make-scaffold-copy tree))) |
---|
106 | (let ((result |
---|
107 | (apply #'subst new old tree |
---|
108 | `(,@(unless (eqt key 'no-key) `(:key ,key)) |
---|
109 | ,@(when test `(:test ,test)) |
---|
110 | ,@(when test-not `(:test-not ,test-not)))))) |
---|
111 | (and (check-scaffold-copy new newcopy) |
---|
112 | (check-scaffold-copy old oldcopy) |
---|
113 | (check-scaffold-copy tree treecopy) |
---|
114 | result)))) |
---|
115 | |
---|
116 | |
---|
117 | (defun check-subst-if (new pred tree &key (key 'no-key)) |
---|
118 | "Call subst-if new pred tree, with various keyword arguments |
---|
119 | if present. Check that the arguments are not changed." |
---|
120 | (setf new (copy-tree new)) |
---|
121 | (setf tree (copy-tree tree)) |
---|
122 | (let ((newcopy (make-scaffold-copy new)) |
---|
123 | (predcopy (make-scaffold-copy pred)) |
---|
124 | (treecopy (make-scaffold-copy tree))) |
---|
125 | (let ((result |
---|
126 | (apply #'subst-if new pred tree |
---|
127 | (unless (eqt key 'no-key) `(:key ,key))))) |
---|
128 | (and (check-scaffold-copy new newcopy) |
---|
129 | (check-scaffold-copy pred predcopy) |
---|
130 | (check-scaffold-copy tree treecopy) |
---|
131 | result)))) |
---|
132 | |
---|
133 | (defun check-subst-if-not (new pred tree &key (key 'no-key)) |
---|
134 | "Call subst-if-not new pred tree, with various keyword arguments |
---|
135 | if present. Check that the arguments are not changed." |
---|
136 | (setf new (copy-tree new)) |
---|
137 | (setf tree (copy-tree tree)) |
---|
138 | (let ((newcopy (make-scaffold-copy new)) |
---|
139 | (predcopy (make-scaffold-copy pred)) |
---|
140 | (treecopy (make-scaffold-copy tree))) |
---|
141 | (let ((result |
---|
142 | (apply #'subst-if-not new pred tree |
---|
143 | (unless (eqt key 'no-key) `(:key ,key))))) |
---|
144 | (and (check-scaffold-copy new newcopy) |
---|
145 | (check-scaffold-copy pred predcopy) |
---|
146 | (check-scaffold-copy tree treecopy) |
---|
147 | result)))) |
---|
148 | |
---|
149 | (defun check-nsubst (new old tree &key (key 'no-key) test test-not) |
---|
150 | "Call nsubst new old tree, with keyword arguments if present." |
---|
151 | (setf new (copy-tree new)) |
---|
152 | (setf old (copy-tree old)) |
---|
153 | (setf tree (copy-tree tree)) |
---|
154 | (apply #'nsubst new old tree |
---|
155 | `(,@(unless (eqt key 'no-key) `(:key ,key)) |
---|
156 | ,@(when test `(:test ,test)) |
---|
157 | ,@(when test-not `(:test-not ,test-not))))) |
---|
158 | |
---|
159 | (defun check-nsubst-if (new pred tree &key (key 'no-key)) |
---|
160 | "Call nsubst-if new pred tree, with keyword arguments if present." |
---|
161 | (setf new (copy-tree new)) |
---|
162 | (setf tree (copy-tree tree)) |
---|
163 | (apply #'nsubst-if new pred tree |
---|
164 | (unless (eqt key 'no-key) `(:key ,key)))) |
---|
165 | |
---|
166 | (defun check-nsubst-if-not (new pred tree &key (key 'no-key)) |
---|
167 | "Call nsubst-if-not new pred tree, with keyword arguments if present." |
---|
168 | (setf new (copy-tree new)) |
---|
169 | (setf tree (copy-tree tree)) |
---|
170 | (apply #'nsubst-if-not new pred tree |
---|
171 | (unless (eqt key 'no-key) `(:key ,key)))) |
---|
172 | |
---|
173 | (defun check-copy-list-copy (x y) |
---|
174 | "Check that y is a copy of the list x." |
---|
175 | (if |
---|
176 | (consp x) |
---|
177 | (and (consp y) |
---|
178 | (not (eqt x y)) |
---|
179 | (eqt (car x) (car y)) |
---|
180 | (check-copy-list-copy (cdr x) (cdr y))) |
---|
181 | (and (eqt x y) t))) |
---|
182 | |
---|
183 | (defun check-copy-list (x) |
---|
184 | "Apply copy-list, checking that it properly copies, |
---|
185 | and checking that it does not change its argument." |
---|
186 | (let ((xcopy (make-scaffold-copy x))) |
---|
187 | (let ((y (copy-list x))) |
---|
188 | (and |
---|
189 | (check-scaffold-copy x xcopy) |
---|
190 | (check-copy-list-copy x y) |
---|
191 | y)))) |
---|
192 | |
---|
193 | (defun append-6-body () |
---|
194 | (let* ((cal (min 2048 call-arguments-limit)) |
---|
195 | (step (max 1 (floor (/ cal) 64)))) |
---|
196 | (loop |
---|
197 | for n from 0 |
---|
198 | below cal |
---|
199 | by step |
---|
200 | count |
---|
201 | (not |
---|
202 | (equal |
---|
203 | (apply #'append (loop for i from 1 to n |
---|
204 | collect '(a))) |
---|
205 | (make-list n :initial-element 'a)))))) |
---|
206 | |
---|
207 | (defun is-intersection (x y z) |
---|
208 | "Check that z is the intersection of x and y." |
---|
209 | (and |
---|
210 | (listp x) |
---|
211 | (listp y) |
---|
212 | (listp z) |
---|
213 | (loop for e in x |
---|
214 | always (or (not (member e y)) |
---|
215 | (member e z))) |
---|
216 | (loop for e in y |
---|
217 | always (or (not (member e x)) |
---|
218 | (member e z))) |
---|
219 | (loop for e in z |
---|
220 | always (and (member e x) (member e y))) |
---|
221 | t)) |
---|
222 | |
---|
223 | (defun shuffle (x) |
---|
224 | (cond |
---|
225 | ((null x) nil) |
---|
226 | ((null (cdr x)) x) |
---|
227 | (t |
---|
228 | (multiple-value-bind |
---|
229 | (y z) |
---|
230 | (split-list x) |
---|
231 | (append (shuffle y) (shuffle z)))))) |
---|
232 | |
---|
233 | (defun split-list (x) |
---|
234 | (cond |
---|
235 | ((null x) (values nil nil)) |
---|
236 | ((null (cdr x)) (values x nil)) |
---|
237 | (t |
---|
238 | (multiple-value-bind |
---|
239 | (y z) |
---|
240 | (split-list (cddr x)) |
---|
241 | (values (cons (car x) y) (cons (cadr x) z)))))) |
---|
242 | |
---|
243 | (defun intersection-12-body (size niters &optional (maxelem (* 2 size))) |
---|
244 | (let ((state (make-random-state))) |
---|
245 | (loop |
---|
246 | for i from 1 to niters do |
---|
247 | (let ((x (shuffle (loop for j from 1 to size |
---|
248 | collect (random maxelem state)))) |
---|
249 | (y (shuffle (loop for j from 1 to size |
---|
250 | collect (random maxelem state))))) |
---|
251 | (let ((z (intersection x y))) |
---|
252 | (let ((is-good (is-intersection x y z))) |
---|
253 | (unless is-good (return (values x y z))))))) |
---|
254 | nil)) |
---|
255 | |
---|
256 | (defun nintersection-with-check (x y &key test) |
---|
257 | (let ((ycopy (make-scaffold-copy y))) |
---|
258 | (let ((result (if test |
---|
259 | (nintersection x y :test test) |
---|
260 | (nintersection x y)))) |
---|
261 | (if (check-scaffold-copy y ycopy) |
---|
262 | result |
---|
263 | 'failed)))) |
---|
264 | |
---|
265 | (defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) |
---|
266 | (let ((state (make-random-state t))) |
---|
267 | (loop |
---|
268 | for i from 1 to niters do |
---|
269 | (let ((x (shuffle (loop for j from 1 to size |
---|
270 | collect (random maxelem state)))) |
---|
271 | (y (shuffle (loop for j from 1 to size |
---|
272 | collect (random maxelem state))))) |
---|
273 | (let ((z (nintersection-with-check (copy-list x) y))) |
---|
274 | (when (eqt z 'failed) (return (values x y z))) |
---|
275 | (let ((is-good (is-intersection x y z))) |
---|
276 | (unless is-good (return (values x y z))))))) |
---|
277 | nil)) |
---|
278 | |
---|
279 | |
---|
280 | (defun union-with-check (x y &key test test-not) |
---|
281 | (let ((xcopy (make-scaffold-copy x)) |
---|
282 | (ycopy (make-scaffold-copy y))) |
---|
283 | (let ((result (cond |
---|
284 | (test (union x y :test test)) |
---|
285 | (test-not (union x y :test-not test-not)) |
---|
286 | (t (union x y))))) |
---|
287 | (if (and (check-scaffold-copy x xcopy) |
---|
288 | (check-scaffold-copy y ycopy)) |
---|
289 | result |
---|
290 | 'failed)))) |
---|
291 | |
---|
292 | (defun union-with-check-and-key (x y key &key test test-not) |
---|
293 | (let ((xcopy (make-scaffold-copy x)) |
---|
294 | (ycopy (make-scaffold-copy y))) |
---|
295 | (let ((result (cond |
---|
296 | (test (union x y :key key :test test)) |
---|
297 | (test-not (union x y :key key :test-not test-not)) |
---|
298 | (t (union x y :key key))))) |
---|
299 | (if (and (check-scaffold-copy x xcopy) |
---|
300 | (check-scaffold-copy y ycopy)) |
---|
301 | result |
---|
302 | 'failed)))) |
---|
303 | |
---|
304 | (defun check-union (x y z) |
---|
305 | (and (listp x) |
---|
306 | (listp y) |
---|
307 | (listp z) |
---|
308 | (loop for e in z always (or (member e x) (member e y))) |
---|
309 | (loop for e in x always (member e z)) |
---|
310 | (loop for e in y always (member e z)) |
---|
311 | t)) |
---|
312 | |
---|
313 | (defun do-random-unions (size niters &optional (maxelem (* 2 size))) |
---|
314 | (let ((state (make-random-state))) |
---|
315 | (loop |
---|
316 | for i from 1 to niters do |
---|
317 | (let ((x (shuffle (loop for j from 1 to size collect |
---|
318 | (random maxelem state)))) |
---|
319 | (y (shuffle (loop for j from 1 to size collect |
---|
320 | (random maxelem state))))) |
---|
321 | (let ((z (union x y))) |
---|
322 | (let ((is-good (check-union x y z))) |
---|
323 | (unless is-good (return (values x y z))))))) |
---|
324 | nil)) |
---|
325 | |
---|
326 | (defun nunion-with-copy (x y &key test test-not) |
---|
327 | (setf x (copy-list x)) |
---|
328 | (setf y (copy-list y)) |
---|
329 | (cond |
---|
330 | (test (nunion x y :test test)) |
---|
331 | (test-not (nunion x y :test-not test-not)) |
---|
332 | (t (nunion x y)))) |
---|
333 | |
---|
334 | (defun nunion-with-copy-and-key (x y key &key test test-not) |
---|
335 | (setf x (copy-list x)) |
---|
336 | (setf y (copy-list y)) |
---|
337 | (cond |
---|
338 | (test (nunion x y :key key :test test)) |
---|
339 | (test-not (nunion x y :key key :test-not test-not)) |
---|
340 | (t (nunion x y :key key)))) |
---|
341 | |
---|
342 | (defun do-random-nunions (size niters &optional (maxelem (* 2 size))) |
---|
343 | (let ((state (make-random-state))) |
---|
344 | (loop |
---|
345 | for i from 1 to niters do |
---|
346 | (let ((x (shuffle (loop for j from 1 to size collect |
---|
347 | (random maxelem state)))) |
---|
348 | (y (shuffle (loop for j from 1 to size collect |
---|
349 | (random maxelem state))))) |
---|
350 | (let ((z (nunion-with-copy x y))) |
---|
351 | (let ((is-good (check-union x y z))) |
---|
352 | (unless is-good (return (values x y z))))))) |
---|
353 | nil)) |
---|
354 | |
---|
355 | (defun set-difference-with-check (x y &key (key 'no-key) |
---|
356 | test test-not) |
---|
357 | (setf x (copy-list x)) |
---|
358 | (setf y (copy-list y)) |
---|
359 | (let ((xcopy (make-scaffold-copy x)) |
---|
360 | (ycopy (make-scaffold-copy y))) |
---|
361 | (let ((result (apply #'set-difference |
---|
362 | x y |
---|
363 | `(,@(unless (eqt key 'no-key) `(:key ,key)) |
---|
364 | ,@(when test `(:test ,test)) |
---|
365 | ,@(when test-not `(:test-not ,test-not)))))) |
---|
366 | (cond |
---|
367 | ((and (check-scaffold-copy x xcopy) |
---|
368 | (check-scaffold-copy y ycopy)) |
---|
369 | result) |
---|
370 | (t |
---|
371 | 'failed))))) |
---|
372 | |
---|
373 | (defun check-set-difference (x y z &key (key #'identity) |
---|
374 | (test #'eql)) |
---|
375 | (and |
---|
376 | ;; (not (eqt 'failed z)) |
---|
377 | (listp x) |
---|
378 | (listp y) |
---|
379 | (listp z) |
---|
380 | (loop for e in z always (member e x :key key :test test)) |
---|
381 | (loop for e in x always (or (member e y :key key :test test) |
---|
382 | (member e z :key key :test test))) |
---|
383 | (loop for e in y never (member e z :key key :test test)) |
---|
384 | t)) |
---|
385 | |
---|
386 | (defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) |
---|
387 | (let ((state (make-random-state))) |
---|
388 | (loop |
---|
389 | for i from 1 to niters do |
---|
390 | (let ((x (shuffle (loop for j from 1 to size collect |
---|
391 | (random maxelem state)))) |
---|
392 | (y (shuffle (loop for j from 1 to size collect |
---|
393 | (random maxelem state))))) |
---|
394 | (let ((z (set-difference-with-check x y))) |
---|
395 | (let ((is-good (check-set-difference x y z))) |
---|
396 | (unless is-good (return (values x y z))))))) |
---|
397 | nil)) |
---|
398 | (defun nset-difference-with-check (x y &key (key 'no-key) |
---|
399 | test test-not) |
---|
400 | (setf x (copy-list x)) |
---|
401 | (setf y (copy-list y)) |
---|
402 | (apply #'nset-difference |
---|
403 | x y |
---|
404 | `(,@(unless (eqt key 'no-key) `(:key ,key)) |
---|
405 | ,@(when test `(:test ,test)) |
---|
406 | ,@(when test-not `(:test-not ,test-not))))) |
---|
407 | |
---|
408 | (defun check-nset-difference (x y z &key (key #'identity) |
---|
409 | (test #'eql)) |
---|
410 | (and |
---|
411 | (listp x) |
---|
412 | (listp y) |
---|
413 | (listp z) |
---|
414 | (loop for e in z always (member e x :key key :test test)) |
---|
415 | (loop for e in x always (or (member e y :key key :test test) |
---|
416 | (member e z :key key :test test))) |
---|
417 | (loop for e in y never (member e z :key key :test test)) |
---|
418 | t)) |
---|
419 | |
---|
420 | (defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) |
---|
421 | (let ((state (make-random-state))) |
---|
422 | (loop |
---|
423 | for i from 1 to niters do |
---|
424 | (let ((x (shuffle (loop for j from 1 to size collect |
---|
425 | (random maxelem state)))) |
---|
426 | (y (shuffle (loop for j from 1 to size collect |
---|
427 | (random maxelem state))))) |
---|
428 | (let ((z (nset-difference-with-check x y))) |
---|
429 | (let ((is-good (check-nset-difference x y z))) |
---|
430 | (unless is-good (return (values x y z))))))) |
---|
431 | nil)) |
---|
432 | |
---|
433 | (defun set-exclusive-or-with-check (x y &key (key 'no-key) |
---|
434 | test test-not) |
---|
435 | (setf x (copy-list x)) |
---|
436 | (setf y (copy-list y)) |
---|
437 | (let ((xcopy (make-scaffold-copy x)) |
---|
438 | (ycopy (make-scaffold-copy y))) |
---|
439 | (let ((result (apply #'set-exclusive-or |
---|
440 | x y |
---|
441 | `(,@(unless (eqt key 'no-key) `(:key ,key)) |
---|
442 | ,@(when test `(:test ,test)) |
---|
443 | ,@(when test-not `(:test-not ,test-not)))))) |
---|
444 | (cond |
---|
445 | ((and (check-scaffold-copy x xcopy) |
---|
446 | (check-scaffold-copy y ycopy)) |
---|
447 | result) |
---|
448 | (t |
---|
449 | 'failed))))) |
---|
450 | |
---|
451 | (defun check-set-exclusive-or (x y z &key (key #'identity) |
---|
452 | (test #'eql)) |
---|
453 | (and |
---|
454 | ;; (not (eqt 'failed z)) |
---|
455 | (listp x) |
---|
456 | (listp y) |
---|
457 | (listp z) |
---|
458 | (loop for e in z always (or (member e x :key key :test test) |
---|
459 | (member e y :key key :test test))) |
---|
460 | (loop for e in x always (if (member e y :key key :test test) |
---|
461 | (not (member e z :key key :test test)) |
---|
462 | (member e z :key key :test test))) |
---|
463 | (loop for e in y always (if (member e x :key key :test test) |
---|
464 | (not (member e z :key key :test test)) |
---|
465 | (member e z :key key :test test))) |
---|
466 | t)) |
---|
467 | |
---|
468 | #| |
---|
469 | (defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) |
---|
470 | (let ((state (make-random-state))) |
---|
471 | (loop |
---|
472 | for i from 1 to niters do |
---|
473 | (let ((x (shuffle (loop for j from 1 to size collect |
---|
474 | (random maxelem state)))) |
---|
475 | (y (shuffle (loop for j from 1 to size collect |
---|
476 | (random maxelem state))))) |
---|
477 | (let ((z (set-exclusive-or-with-check x y))) |
---|
478 | (let ((is-good (check-set-exclusive-or x y z))) |
---|
479 | (unless is-good (return (values x y z))))))) |
---|
480 | nil)) |
---|
481 | |# |
---|
482 | |
---|
483 | (defun nset-exclusive-or-with-check (x y &key (key 'no-key) |
---|
484 | test test-not) |
---|
485 | (setf x (copy-list x)) |
---|
486 | (setf y (copy-list y)) |
---|
487 | (apply #'nset-exclusive-or |
---|
488 | x y |
---|
489 | `(,@(unless (eqt key 'no-key) `(:key ,key)) |
---|
490 | ,@(when test `(:test ,test)) |
---|
491 | ,@(when test-not `(:test-not ,test-not))))) |
---|
492 | |
---|
493 | #| |
---|
494 | (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) |
---|
495 | (let ((state (make-random-state))) |
---|
496 | (loop |
---|
497 | for i from 1 to niters do |
---|
498 | (let ((x (shuffle (loop for j from 1 to size collect |
---|
499 | (random maxelem state)))) |
---|
500 | (y (shuffle (loop for j from 1 to size collect |
---|
501 | (random maxelem state))))) |
---|
502 | (let ((z (nset-exclusive-or-with-check x y))) |
---|
503 | (let ((is-good (check-set-exclusive-or x y z))) |
---|
504 | (unless is-good (return (values x y z))))))) |
---|
505 | nil)) |
---|
506 | |# |
---|
507 | |
---|
508 | (defun subsetp-with-check (x y &key (key 'no-key) test test-not) |
---|
509 | (let ((xcopy (make-scaffold-copy x)) |
---|
510 | (ycopy (make-scaffold-copy y))) |
---|
511 | (let ((result |
---|
512 | (apply #'subsetp x y |
---|
513 | `(,@(unless (eqt key 'no-key) |
---|
514 | `(:key ,key)) |
---|
515 | ,@(when test `(:test ,test)) |
---|
516 | ,@(when test-not `(:test-not ,test-not)))))) |
---|
517 | (cond |
---|
518 | ((and (check-scaffold-copy x xcopy) |
---|
519 | (check-scaffold-copy y ycopy)) |
---|
520 | (not (not result))) |
---|
521 | (t 'failed))))) |
---|
522 | |
---|
523 | (defun my-set-exclusive-or (set1 set2 &key key test test-not) |
---|
524 | |
---|
525 | (assert (not (and test test-not))) |
---|
526 | |
---|
527 | (cond |
---|
528 | (test-not (when (symbolp test-not) |
---|
529 | (setq test-not (symbol-function test-not))) |
---|
530 | (setq test (complement test-not))) |
---|
531 | ((not test) (setq test #'eql))) |
---|
532 | |
---|
533 | ;;; (when (symbolp test) (setq test (symbol-function test))) |
---|
534 | (etypecase test |
---|
535 | (symbol (setq test (symbol-function test))) |
---|
536 | (function nil)) |
---|
537 | |
---|
538 | (etypecase key |
---|
539 | (null nil) |
---|
540 | (symbol (setq key (symbol-function key))) |
---|
541 | (function nil)) |
---|
542 | |
---|
543 | (let* ((keys1 (if key (mapcar (the function key) set1) set1)) |
---|
544 | (keys2 (if key (mapcar (the function key) set2) set2)) |
---|
545 | (mask1 (make-array (length set1) :element-type 'bit |
---|
546 | :initial-element 0)) |
---|
547 | (mask2 (make-array (length set2) :element-type 'bit |
---|
548 | :initial-element 0))) |
---|
549 | (loop for i1 from 0 |
---|
550 | for k1 in keys1 |
---|
551 | do |
---|
552 | (loop for i2 from 0 |
---|
553 | for k2 in keys2 |
---|
554 | when (funcall (the function test) k1 k2) |
---|
555 | do (setf (sbit mask1 i1) 1 |
---|
556 | (sbit mask2 i2) 1))) |
---|
557 | (nconc |
---|
558 | (loop for e in set1 |
---|
559 | for i across mask1 |
---|
560 | when (= i 0) |
---|
561 | collect e) |
---|
562 | (loop for e in set2 |
---|
563 | for i across mask2 |
---|
564 | when (= i 0) |
---|
565 | collect e)))) |
---|
566 | |
---|
567 | (defun make-random-set-exclusive-or-input (n) |
---|
568 | (let* ((set1 (loop for i from 1 to n collect (random n))) |
---|
569 | (set2 (loop for i from 1 to n collect (random n))) |
---|
570 | (test-args |
---|
571 | (random-case nil nil nil |
---|
572 | (list :test 'eql) |
---|
573 | (list :test #'eql) |
---|
574 | (list :test (complement #'eql)))) |
---|
575 | (test-not-args |
---|
576 | (and (not test-args) |
---|
577 | (random-case nil nil (list :test-not 'eql) |
---|
578 | (list :test-not #'eql) |
---|
579 | (list :test-not (complement #'eql))))) |
---|
580 | (key-args |
---|
581 | (random-case nil nil nil nil |
---|
582 | (list :key nil) |
---|
583 | (list :key 'identity) |
---|
584 | (list :key 'not)))) |
---|
585 | (list* set1 set2 |
---|
586 | (reduce #'append (random-permute |
---|
587 | (list test-args test-not-args key-args)))))) |
---|
588 | |
---|
589 | (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) |
---|
590 | (let ((actual-fn (etypecase fn |
---|
591 | (symbol (symbol-function fn)) |
---|
592 | (function fn)))) |
---|
593 | (declare (type function actual-fn)) |
---|
594 | (loop for i below reps |
---|
595 | for args = (make-random-set-exclusive-or-input n) |
---|
596 | for set1 = (car args) |
---|
597 | for set2 = (cadr args) |
---|
598 | for result1 = (apply #'remove-duplicates |
---|
599 | (sort (copy-list (apply #'my-set-exclusive-or args)) |
---|
600 | #'<) |
---|
601 | (cddr args)) |
---|
602 | for result2 = (apply #'remove-duplicates |
---|
603 | (sort (copy-list (apply actual-fn |
---|
604 | (copy-list set1) |
---|
605 | (copy-list set2) |
---|
606 | (cddr args))) |
---|
607 | #'<) |
---|
608 | (cddr args)) |
---|
609 | unless (equal result1 result2) |
---|
610 | return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") |
---|
611 | "actual: " result2 "should be: " result1)))) |
---|
612 | |
---|
613 | (defun rev-assoc-list (x) |
---|
614 | (cond |
---|
615 | ((null x) nil) |
---|
616 | ((null (car x)) |
---|
617 | (cons nil (rev-assoc-list (cdr x)))) |
---|
618 | (t |
---|
619 | (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) |
---|
620 | |
---|
621 | (defvar *mapc.6-var* nil) |
---|
622 | (defun mapc.6-fun (x) |
---|
623 | (push x *mapc.6-var*) |
---|
624 | x) |
---|