union.lsp 10.8 KB
Newer Older
1
2
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
3
4
;;;; Created:  Sun Apr 20 07:41:24 2003
;;;; Contains: Tests of UNION
5
6

(in-package :cl-test)
7

8
9
(compile-and-load "cons-aux.lsp")

10
11
(deftest union.1
  (union nil nil)
12
13
  nil)

14
15
(deftest union.2
  (union-with-check (list 'a) nil)
16
17
  (a))

18
19
(deftest union.3
  (union-with-check (list 'a) (list 'a))
20
21
22
  (a))

(deftest union-4
23
  (union-with-check (list 1) (list 1))
24
25
  (1))

26
27
28
(deftest union.5
  (let ((x (list 'a 'b)))
    (union-with-check (list x) (list x)))
29
30
  ((a b)))

31
32
(deftest union.6
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
33
        (y (copy-list '(z c y a v b))))
34
35
    (let ((result (union-with-check x y)))
      (check-union x y result)))
36
37
  t)

38
39
(deftest union.6-a
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
40
        (y (copy-list '(z c y a v b))))
41
42
    (let ((result (union-with-check x y :test #'eq)))
      (check-union x y result)))
43
44
  t)

45
46
(deftest union.7
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
47
        (y (copy-list '(z c y a v b))))
48
49
    (let ((result (union-with-check x y :test #'eql)))
      (check-union x y result)))
50
51
  t)

52
53
(deftest union.8
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
54
        (y (copy-list '(z c y a v b))))
55
56
    (let ((result (union-with-check x y :test #'equal)))
      (check-union x y result)))
57
58
  t)

59
60
(deftest union.9
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
61
        (y (copy-list '(z c y a v b))))
62
63
    (let ((result (union-with-check x y :test-not (complement #'eql))))
      (check-union x y result)))
64
65
  t)

66
67
(deftest union.10
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
68
        (y (copy-list '(z c y a v b))))
69
70
    (let ((result (union-with-check x y :test-not (complement #'equal))))
      (check-union x y result)))
71
72
  t)

73
74
(deftest union.11
  (let ((x (copy-list '(a b c d e f)))
sds's avatar
sds committed
75
        (y (copy-list '(z c y a v b))))
76
77
    (let ((result (union-with-check x y :test-not (complement #'eq))))
      (check-union x y result)))
78
79
  t)

80
81
(deftest union.12
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
82
        (y (copy-list '(10 19 5 3 17 1001 2))))
83
84
    (let ((result (union-with-check x y)))
      (check-union x y result)))
85
86
  t)

87
88
(deftest union.13
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
89
        (y (copy-list '(10 19 5 3 17 1001 2))))
90
91
    (let ((result (union-with-check x y :test #'equal)))
      (check-union x y result)))
92
93
  t)

94
95
(deftest union.14
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
96
        (y (copy-list '(10 19 5 3 17 1001 2))))
97
98
    (let ((result (union-with-check x y :test #'eql)))
      (check-union x y result)))
99
100
  t)

101
102
(deftest union.15
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
103
        (y (copy-list '(10 19 5 3 17 1001 2))))
104
105
    (let ((result (union-with-check x y :test-not (complement #'equal))))
      (check-union x y result)))
106
107
  t)

108
109
(deftest union.16
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
110
        (y (copy-list '(10 19 5 3 17 1001 2))))
111
112
    (let ((result (union-with-check x y :test-not (complement  #'eql))))
      (check-union x y result)))
113
114
  t)

115
116
(deftest union.17
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
117
        (y (copy-list '(10 19 5 3 17 1001 2))))
118
119
    (let ((result (union-with-check-and-key x y #'1+)))
      (check-union x y result)))
120
121
  t)

122
123
(deftest union.18
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
124
        (y (copy-list '(10 19 5 3 17 1001 2))))
125
126
    (let ((result (union-with-check-and-key x y #'1+ :test #'equal)))
      (check-union x y result)))
127
128
  t)

129
130
(deftest union.19
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
131
        (y (copy-list '(10 19 5 3 17 1001 2))))
132
133
    (let ((result (union-with-check-and-key x y #'1+ :test #'eql)))
      (check-union x y result)))
134
135
  t)

136
137
(deftest union.20
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
138
        (y (copy-list '(10 19 5 3 17 1001 2))))
139
    (let ((result (union-with-check-and-key x y #'1+
sds's avatar
sds committed
140
                                            :test-not (complement #'equal))))
141
      (check-union x y result)))
142
143
  t)

144
145
(deftest union.21
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
146
        (y (copy-list '(10 19 5 3 17 1001 2))))
147
    (let ((result (union-with-check-and-key x y #'1+
sds's avatar
sds committed
148
                                            :test-not (complement #'equal))))
149
      (check-union x y result)))
150
151
  t)

152
(deftest union.22
153
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
154
        (y (copy-list '(10 19 5 3 17 1001 2))))
155
156
    (let ((result (union-with-check-and-key x y nil)))
      (check-union x y result)))
157
158
  t)

159
(deftest union.23
160
  (let ((x (copy-list '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
161
        (y (copy-list '(10 19 5 3 17 1001 2))))
162
163
164
165
166
167
    (let ((result (union-with-check-and-key x y '1+)))
      (check-union x y result)))
  t)

;; Do large numbers of random units

168
(deftest union.24
169
170
171
  (do-random-unions 100 100 200)
  nil)

172
(deftest union.25
173
  (let ((x (shuffle '(1 4 6 10 45 101)))
sds's avatar
sds committed
174
        (y (copy-list '(102 5 2 11 44 6))))
175
    (let ((result (union-with-check x y
sds's avatar
sds committed
176
177
                                    :test #'(lambda (a b)
                                                    (<= (abs (- a b)) 1)))))
178
      (and
179
       (not (eqt result 'failed))
180
       (sort
sds's avatar
sds committed
181
182
183
184
        (sublis
         '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101))
         (copy-list result))
        #'<))))
185
186
  (1 4 6 10 44 101))

187
;;; Check that union uses eql, not equal or eq
188

189
(deftest union.26
190
  (let ((x 1000)
sds's avatar
sds committed
191
        (y 1000))
192
193
194
    (loop
     while (not (typep x 'bignum))
     do (progn
sds's avatar
sds committed
195
196
          (setf x (* x x))
          (setf y (* y y))))
197
198
199
200
    (notnot-mv
     (or
      (eqt x y)  ;; if bignums are eq, the test is worthless
      (eql (length
sds's avatar
sds committed
201
202
203
            (union-with-check
             (list x) (list x)))
           1))))
204
205
  t)

206
(deftest union.27
207
  (union-with-check (list (copy-seq "aa"))
sds's avatar
sds committed
208
                    (list (copy-seq "aa")))
209
210
211
212
  ("aa" "aa"))

;; Check that union does not reverse the arguments to :test, :test-not

213
214
215
216
217
218
219
(deftest union.28
  (block fail
    (sort
     (union-with-check
      (list 1 2 3)
      (list 4 5 6)
      :test #'(lambda (x y)
sds's avatar
sds committed
220
221
                (when (< y x) (return-from fail 'fail))
                (eql x y)))
222
     #'<))
223
224
  (1 2 3 4 5 6))

225
226
227
228
229
230
231
232
(deftest union.29
  (block fail
    (sort
     (union-with-check-and-key
      (list 1 2 3)
      (list 4 5 6)
      #'identity
      :test #'(lambda (x y)
sds's avatar
sds committed
233
234
                (when (< y x) (return-from fail 'fail))
                (eql x y)))
235
     #'<))
236
237
  (1 2 3 4 5 6))

238
239
240
241
242
243
244
245
(deftest union.30
  (block fail
    (sort
     (union-with-check
      (list 1 2 3)
      (list 4 5 6)
      :test-not
      #'(lambda (x y)
sds's avatar
sds committed
246
247
          (when (< y x) (return-from fail 'fail))
          (not (eql x y))))
248
     #'<))
249
250
  (1 2 3 4 5 6))

251
252
253
254
255
256
257
258
(deftest union.31
  (block fail
    (sort
     (union-with-check-and-key
      (list 1 2 3)
      (list 4 5 6)
      #'identity
      :test-not #'(lambda (x y)
sds's avatar
sds committed
259
260
                    (when (< y x) (return-from fail 'fail))
                    (not (eql x y))))
261
     #'<))
262
  (1 2 3 4 5 6))
263

264
265
266
267
268
269
270
(defharmless union.test-and-test-not.1
  (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql))

(defharmless union.test-and-test-not.2
  (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql))


271
272
;;; Order of evaluation tests

273
(deftest union.order.1
274
275
276
277
  (let ((i 0) x y)
    (values
     (sort
      (union (progn (setf x (incf i)) (copy-list '(1 3 5)))
sds's avatar
sds committed
278
             (progn (setf y (incf i)) (copy-list '(2 5 8))))
279
280
281
282
283
      #'<)
     i x y))
  (1 2 3 5 8)
  2 1 2)

284
(deftest union.order.2
285
286
287
288
  (let ((i 0) x y z w)
    (values
     (sort
      (union (progn (setf x (incf i)) (copy-list '(1 3 5)))
sds's avatar
sds committed
289
290
291
             (progn (setf y (incf i)) (copy-list '(2 5 8)))
             :test (progn (setf z (incf i)) #'eql)
             :key (progn (setf w (incf i)) #'identity))
292
293
294
295
296
297
      #'<)
     i x y z w))
  (1 2 3 5 8)
  4 1 2 3 4)


298
(deftest union.order.3
299
300
301
302
  (let ((i 0) x y z w)
    (values
     (sort
      (union (progn (setf x (incf i)) (copy-list '(1 3 5)))
sds's avatar
sds committed
303
304
305
             (progn (setf y (incf i)) (copy-list '(2 5 8)))
             :key (progn (setf z (incf i)) #'identity)
             :test (progn (setf w (incf i)) #'eql))
306
307
308
309
310
      #'<)
     i x y z w))
  (1 2 3 5 8)
  4 1 2 3 4)

311
312
313
;;; Keyword tests

(deftest union.allow-other-keys.1
314
  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t
sds's avatar
sds committed
315
316
               :allow-other-keys "yes")
        #'<)
317
318
  (1 2 5 7 9 10 11 20))

319
(deftest union.allow-other-keys.2
320
  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
sds's avatar
sds committed
321
322
               :allow-other-keys t :also-bad t)
        #'<)
323
324
  (1 2 5 7 9 10 11 20))

325
(deftest union.allow-other-keys.3
326
  (sort (union (list 1 2 3) (list 1 2 3)
sds's avatar
sds committed
327
328
329
               :allow-other-keys t :also-bad t
               :test #'(lambda (x y) (= x (+ y 100))))
        #'<)
330
331
  (1 1 2 2 3 3))

332
333
(deftest union.allow-other-keys.4
  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
sds's avatar
sds committed
334
335
               :allow-other-keys t)
        #'<)
336
337
338
339
  (1 2 5 7 9 10 11 20))

(deftest union.allow-other-keys.5
  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
sds's avatar
sds committed
340
341
               :allow-other-keys nil)
        #'<)
342
343
344
345
  (1 2 5 7 9 10 11 20))

(deftest union.allow-other-keys.6
  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
sds's avatar
sds committed
346
347
348
               :allow-other-keys t
               :allow-other-keys nil)
        #'<)
349
350
351
352
  (1 2 5 7 9 10 11 20))

(deftest union.allow-other-keys.7
  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
sds's avatar
sds committed
353
354
355
356
               :allow-other-keys t
               :allow-other-keys nil
               '#:x 1)
        #'<)
357
358
359
360
  (1 2 5 7 9 10 11 20))

(deftest union.keywords.9
  (sort (union (list 1 2 3) (list 1 2 3)
sds's avatar
sds committed
361
362
363
               :test #'(lambda (x y) (= x (+ y 100)))
               :test #'eql)
        #'<)
364
365
  (1 1 2 2 3 3))

pfdietz's avatar
pfdietz committed
366
367
(def-fold-test union.fold.1 (union '(a b c d e) '(d x y a w c)))

368
;;; Error tests
369

370
(deftest union.error.1
371
372
  (signals-error (union) program-error)
  t)
373
374

(deftest union.error.2
375
376
  (signals-error (union nil) program-error)
  t)
377
378

(deftest union.error.3
379
380
  (signals-error (union nil nil :bad t) program-error)
  t)
381
382

(deftest union.error.4
383
384
  (signals-error (union nil nil :key) program-error)
  t)
385
386

(deftest union.error.5
387
388
  (signals-error (union nil nil 1 2) program-error)
  t)
389
390

(deftest union.error.6
391
392
  (signals-error (union nil nil :bad t :allow-other-keys nil) program-error)
  t)
393
394

(deftest union.error.7
395
396
  (signals-error (union (list 1 2) (list 3 4) :test #'identity) program-error)
  t)
397
398

(deftest union.error.8
399
400
  (signals-error (union (list 1 2) (list 3 4) :test-not #'identity) program-error)
  t)
401
402

(deftest union.error.9
403
404
  (signals-error (union (list 1 2) (list 3 4) :key #'cons) program-error)
  t)
405
406

(deftest union.error.10
407
408
  (signals-error (union (list 1 2) (list 3 4) :key #'car) type-error)
  t)
409

410
(deftest union.error.11
411
412
  (signals-error (union (list 1 2 3) (list* 4 5 6)) type-error)
  t)
413
414

(deftest union.error.12
415
416
  (signals-error (union (list* 1 2 3) (list 4 5 6)) type-error)
  t)
417

418
419
420
421
422
;;; The next two tests used to check for union with NIL, but arguably
;;; that goes beyond the 'be prepared to signal an error' requirement,
;;; since a union algorithm doesn't have to traverse one argument
;;; if the other is the empty list.

423
(deftest union.error.13
424
  (check-type-error #'(lambda (x) (union x '(1 2))) #'listp)
425
426
427
  nil)

(deftest union.error.14
428
  (check-type-error #'(lambda (x) (union '(1 2) x)) #'listp)
429
  nil)