1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Robert Ransom
4
5(define-test-suite r6rs-comparison-tests)
6
7(define-test-case boolean=?/2 r6rs-comparison-tests
8  (check
9   (boolean=? #f #f) => #t)
10  (check
11   (boolean=? #f #t) => #f)
12  (check
13   (boolean=? #t #f) => #f)
14  (check
15   (boolean=? #t #t) => #t)
16  (check-exception
17   (boolean=? 'foo 'foo))
18  (check-exception
19   (boolean=? 'foo #f))
20  (check-exception
21   (boolean=? #f 'foo)))
22
23(define-test-case boolean=?/3 r6rs-comparison-tests
24  (check
25   (boolean=? #f #f #f) => #t)
26  (check
27   (boolean=? #f #f #t) => #f)
28  (check
29   (boolean=? #f #t #f) => #f)
30  (check
31   (boolean=? #f #t #t) => #f)
32  (check
33   (boolean=? #t #f #f) => #f)
34  (check
35   (boolean=? #t #f #t) => #f)
36  (check
37   (boolean=? #t #t #f) => #f)
38  (check
39   (boolean=? #t #t #t) => #t)
40  (check-exception
41   (boolean=? #f 'foo 'foo))
42  (check-exception
43   (boolean=? #f 'foo #f))
44  (check-exception
45   (boolean=? #f #f 'foo))
46  (check-exception
47   (boolean=? #f #t 'foo))
48  (check-exception
49   (boolean=? 'foo #f #f)))
50
51(define-test-case symbol=?/2 r6rs-comparison-tests
52  (check
53   (symbol=? 'foo 'foo) => #t)
54  (check
55   (symbol=? 'foo 'bar) => #f)
56  (check-exception
57   (symbol=? #f 'foo))
58  (check-exception
59   (symbol=? 'foo #f))
60  (check-exception
61   (symbol=? #f #f)))
62
63(define-test-case symbol=?/3 r6rs-comparison-tests
64  (check
65   (symbol=? 'foo 'foo 'foo) => #t)
66  (check
67   (symbol=? 'foo 'foo 'bar) => #f)
68  (check
69   (symbol=? 'foo 'bar 'foo) => #f)
70  (check
71   (symbol=? 'foo 'bar 'bar) => #f)
72  (check-exception
73   (symbol=? 'foo 'foo #f))
74  (check-exception
75   (symbol=? 'foo 'bar #f))
76  (check-exception
77   (symbol=? #f 'foo 'foo))
78  (check-exception
79   (symbol=? 'foo #f 'foo)))
80
81(define-test-case string=?/2 r6rs-comparison-tests
82  (check
83   (string=? "foo" "Foo") => #f)
84  (check
85   (string=? "foo" "foo") => #t)
86  (check
87   (string=? "foo" "bar") => #f)
88  (check-exception
89   (string=? "foo" 'bar))
90  (check-exception
91   (string=? 'foo "bar"))
92  (check-exception
93   (string=? 'foo 'bar)))
94
95(define-test-case string=?/3 r6rs-comparison-tests
96  (check
97   (string=? "foo" "foo" "foo") => #t)
98  (check
99   (string=? "foo" "foo" "Foo") => #f)
100  (check
101   (string=? "foo" "Foo" "foo") => #f)
102  (check
103   (string=? "foo" "Foo" "Foo") => #f)
104  (check
105   (string=? "Foo" "foo" "foo") => #f)
106  (check
107   (string=? "Foo" "foo" "Foo") => #f)
108  (check
109   (string=? "Foo" "Foo" "foo") => #f)
110  (check
111   (string=? "Foo" "Foo" "Foo") => #t)
112  (check-exception
113   (string=? "foo" "foo" 'foo))
114  (check-exception
115   (string=? "foo" "bar" 'foo)))
116
117(define-test-case string<?/2 r6rs-comparison-tests
118  (check
119   (string<? "abb" "abc") => #t)
120  (check
121   (string<? "abb" "abb") => #f)
122  (check-exception
123   (string<? "abb" 'abc)))
124
125(define-test-case string<?/3 r6rs-comparison-tests
126  (check
127   (string<? "abb" "abc" "abc") => #f)
128  (check
129   (string<? "abb" "abc" "abd") => #t)
130  (check
131   (string<? "abb" "abb" "abd") => #f)
132  (check-exception
133   (string<? "abb" "abc" 3))
134  (check-exception
135   (string<? "abb" "abb" 3)))
136
137; For the remaining (non-case-insensitive) string comparisons, just check
138;     that the correct 2-ary comparison is performed.
139
140; An operator (roughly) from Haskell.
141; TODO - move into a utility package
142(define (liftM2-list-uncurried f xs ys)
143  (srfi-1:append-map (lambda (x) (map (lambda (y) (f x y)) ys)) xs))
144
145(define-test-case liftM2-list-uncurried r6rs-comparison-tests
146  (check
147   (liftM2-list-uncurried list '(1 2 3) '(4 5 6))
148   => '((1 4) (1 5) (1 6) (2 4) (2 5) (2 6) (3 4) (3 5) (3 6))))
149
150(define test-list-1 '("foo" "bar" "baz"))
151
152(define-test-case other-non-ci-comparisons r6rs-comparison-tests
153  (check
154   (liftM2-list-uncurried string<=? test-list-1 test-list-1)
155   => (liftM2-list-uncurried prim:string<=? test-list-1 test-list-1))
156  (check
157   (liftM2-list-uncurried string>? test-list-1 test-list-1)
158   => (liftM2-list-uncurried prim:string>? test-list-1 test-list-1))
159  (check
160   (liftM2-list-uncurried string>=? test-list-1 test-list-1)
161   => (liftM2-list-uncurried prim:string>=? test-list-1 test-list-1)))
162
163; TODO? - move into a utility package?
164(define (int-permutations n)
165  (cond
166   ((not (and (integer? n)
167              (exact? n)
168              (not (negative? n))))
169    (assertion-violation 'int-permutations
170                         "expected non-negative exact integer"
171                         n))
172   ((zero? n)
173    '())
174   ((prim:= n 1)
175    '((0)))
176   (else
177    (let ((ps-n-1 (int-permutations (- n 1))))
178      (let loop ((i (- n 1))
179                 (acc '()))
180        (if (negative? i)
181            acc
182            (loop (- i 1)
183                  (append (map (lambda (p)
184                                 (let ((f (lambda (j)
185                                            (if (prim:>= j i)
186                                                (+ j 1)
187                                                j))))
188                                   (cons i (map f p))))
189                               ps-n-1)
190                          acc))))))))
191
192(define-test-case int-permutations r6rs-comparison-tests
193  (check
194   (int-permutations 0) => '())
195  (check
196   (int-permutations 1) => '((0)))
197  (check
198   (int-permutations 2) => '((0 1) (1 0)))
199  (check
200   (int-permutations 3) => '((0 1 2)
201                             (0 2 1)
202                             (1 0 2)
203                             (1 2 0)
204                             (2 0 1)
205                             (2 1 0)))
206  (check
207   (length (int-permutations 4)) => 24)
208  (check
209   (length (int-permutations 5)) => 120)
210  (check
211   (length (int-permutations 6)) => 720))
212; (int-permutations 8) overflows the default maximum heap size
213
214; TODO? - move into a utility package?
215(define (vector->list-of-permutations v)
216  (let* ((n (vector-length v))
217         (ps (int-permutations n)))
218    (map (lambda (p)
219           (map (lambda (i) (vector-ref v i)) p))
220         ps)))
221
222(define-test-case vector->list-of-permutations r6rs-comparison-tests
223  (check
224   (vector->list-of-permutations '#(foo bar baz)) => '((foo bar baz)
225                                                       (foo baz bar)
226                                                       (bar foo baz)
227                                                       (bar baz foo)
228                                                       (baz foo bar)
229                                                       (baz bar foo))))
230
231(define sharp-s-str (string (integer->char #xDF)))
232
233(define-test-case string-ci=?/4 r6rs-comparison-tests
234  (check
235   (map (lambda (p) (apply string-ci=? p))
236        (vector->list-of-permutations (vector "strasse"
237                                              (string-append "Stra" sharp-s-str "e")
238                                              "STRASSE"
239                                              (string-append "stra" sharp-s-str "e"))))
240   => (srfi-1:make-list 24 #t))
241  (check
242   (map (lambda (p) (apply string-ci=? p))
243        (vector->list-of-permutations '#("Hello"
244                                         "hello"
245                                         "HELLO"
246                                         "world")))
247   => (srfi-1:make-list 24 #f))
248  (check-exception
249   (string-ci=? "foo" "foo" 'baz))
250  (check-exception
251   (string-ci=? "foo" "bar" 'baz)))
252
253(define-test-case string-ci<?/2 r6rs-comparison-tests
254  (check
255   (string-ci<? "bar" "foo") => #t)
256  (check
257   (string-ci<? "bar" "FOO") => #t)
258  (check
259   (string-ci<? "BAR" "bar") => #f)
260  (check
261   (string-ci<? "FOO" "bar") => #f)
262  (check-exception
263   (string-ci<? "foo" 'bar)))
264
265(define-test-case string-ci<=?/2 r6rs-comparison-tests
266  (check
267   (string-ci<=? "bar" "foo") => #t)
268  (check
269   (string-ci<=? "bar" "FOO") => #t)
270  (check
271   (string-ci<=? "BAR" "bar") => #t)
272  (check
273   (string-ci<=? "FOO" "bar") => #f)
274  (check-exception
275   (string-ci<=? "foo" 'bar)))
276
277(define-test-case string-ci>?/2 r6rs-comparison-tests
278  (check
279   (string-ci>? "foo" "bar") => #t)
280  (check
281   (string-ci>? "FOO" "bar") => #t)
282  (check
283   (string-ci>? "bar" "BAR") => #f)
284  (check
285   (string-ci>? "bar" "FOO") => #f)
286  (check-exception
287   (string-ci>? "foo" 'bar)))
288
289(define-test-case string-ci>=?/2 r6rs-comparison-tests
290  (check
291   (string-ci>=? "foo" "bar") => #t)
292  (check
293   (string-ci>=? "FOO" "bar") => #t)
294  (check
295   (string-ci>=? "bar" "BAR") => #t)
296  (check
297   (string-ci>=? "bar" "FOO") => #f)
298  (check-exception
299   (string-ci>=? "foo" 'bar)))
300