15 |
(setq test (complement test-not))) |
(setq test (complement test-not))) |
16 |
((not test) (setq test #'eql))) |
((not test) (setq test #'eql))) |
17 |
|
|
18 |
(when (symbolp test) (setq test (symbol-function test))) |
;;; (when (symbolp test) (setq test (symbol-function test))) |
19 |
|
(etypecase test |
20 |
|
(symbol (setq test (symbol-function test))) |
21 |
|
(function nil)) |
22 |
|
|
23 |
(let* ((keys1 (if key (mapcar key set1) set1)) |
(etypecase key |
24 |
(keys2 (if key (mapcar key set2) set2)) |
(null nil) |
25 |
|
(symbol (setq key (symbol-function key))) |
26 |
|
(function nil)) |
27 |
|
|
28 |
|
(let* ((keys1 (if key (mapcar (the function key) set1) set1)) |
29 |
|
(keys2 (if key (mapcar (the function key) set2) set2)) |
30 |
(mask1 (make-array (length set1) :element-type 'bit |
(mask1 (make-array (length set1) :element-type 'bit |
31 |
:initial-element 0)) |
:initial-element 0)) |
32 |
(mask2 (make-array (length set2) :element-type 'bit |
(mask2 (make-array (length set2) :element-type 'bit |
36 |
do |
do |
37 |
(loop for i2 from 0 |
(loop for i2 from 0 |
38 |
for k2 in keys2 |
for k2 in keys2 |
39 |
when (funcall test k1 k2) |
when (funcall (the function test) k1 k2) |
40 |
do (setf (sbit mask1 i1) 1 |
do (setf (sbit mask1 i1) 1 |
41 |
(sbit mask2 i2) 1))) |
(sbit mask2 i2) 1))) |
42 |
(nconc |
(nconc |
72 |
(list test-args test-not-args key-args)))))) |
(list test-args test-not-args key-args)))))) |
73 |
|
|
74 |
(defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) |
(defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) |
75 |
(loop for i below reps |
(let ((actual-fn (etypecase fn |
76 |
for args = (make-random-set-exclusive-or-input n) |
(symbol (symbol-function fn)) |
77 |
for set1 = (car args) |
(function fn)))) |
78 |
for set2 = (cadr args) |
(declare (type function actual-fn)) |
79 |
for result1 = (apply #'remove-duplicates |
(loop for i below reps |
80 |
(sort (copy-list (apply #'my-set-exclusive-or args)) |
for args = (make-random-set-exclusive-or-input n) |
81 |
#'<) |
for set1 = (car args) |
82 |
(cddr args)) |
for set2 = (cadr args) |
83 |
for result2 = (apply #'remove-duplicates |
for result1 = (apply #'remove-duplicates |
84 |
(sort (copy-list (apply fn |
(sort (copy-list (apply #'my-set-exclusive-or args)) |
85 |
(copy-list set1) |
#'<) |
86 |
(copy-list set2) |
(cddr args)) |
87 |
(cddr args))) |
for result2 = (apply #'remove-duplicates |
88 |
#'<) |
(sort (copy-list (apply actual-fn |
89 |
(cddr args)) |
(copy-list set1) |
90 |
unless (equal result1 result2) |
(copy-list set2) |
91 |
return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") |
(cddr args))) |
92 |
"actual: " result2 "should be: " result1))) |
#'<) |
93 |
|
(cddr args)) |
94 |
|
unless (equal result1 result2) |
95 |
|
return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") |
96 |
|
"actual: " result2 "should be: " result1)))) |
97 |
|
|
98 |
(defun rev-assoc-list (x) |
(defun rev-assoc-list (x) |
99 |
(cond |
(cond |