Commit | Line | Data |
---|---|---|
0c65f52c | 1 | ; Copyright (c) 2011 Free Software Foundation, Inc. |
8175a07e AR |
2 | ; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard. |
3 | ; | |
4 | ; Permission is hereby granted, free of charge, to any person obtaining | |
5 | ; a copy of this software and associated documentation files (the | |
6 | ; ``Software''), to deal in the Software without restriction, including | |
7 | ; without limitation the rights to use, copy, modify, merge, publish, | |
8 | ; distribute, sublicense, and/or sell copies of the Software, and to | |
9 | ; permit persons to whom the Software is furnished to do so, subject to | |
10 | ; the following conditions: | |
11 | ; | |
12 | ; The above copyright notice and this permission notice shall be | |
13 | ; included in all copies or substantial portions of the Software. | |
14 | ; | |
15 | ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, | |
16 | ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
17 | ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
18 | ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE | |
19 | ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION | |
20 | ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION | |
21 | ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. | |
22 | ; | |
23 | ; ----------------------------------------------------------------------- | |
24 | ; | |
25 | ; Compare procedures SRFI (reference implementation) | |
26 | ; Sebastian.Egner@philips.com, Jensaxel@soegaard.net | |
27 | ; history of this file: | |
28 | ; SE, 14-Oct-2004: first version | |
29 | ; SE, 18-Oct-2004: 1st redesign: axioms for 'compare function' | |
30 | ; SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite | |
31 | ; SE, 2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's | |
32 | ; SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare | |
33 | ; SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added | |
34 | ; SE, 12-Jan-2005: pair-compare-cdr | |
35 | ; SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=? | |
36 | ; SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc. | |
37 | ; JS, 24-Feb-2005: selection-compare added | |
38 | ; SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc. | |
39 | ; JS, 28-Feb-2005: kth-largest modified - is "stable" now | |
40 | ; SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged | |
41 | ; SE, 07-Apr-2005: compare-based type checks made explicit | |
42 | ; SE, 18-Apr-2005: added (rel? compare) and eq?-test | |
43 | ; SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y | |
44 | ||
45 | ; ============================================================================= | |
46 | ||
47 | ; Reference Implementation | |
48 | ; ======================== | |
49 | ; | |
50 | ; in R5RS (including hygienic macros) | |
51 | ; + SRFI-16 (case-lambda) | |
52 | ; + SRFI-23 (error) | |
53 | ; + SRFI-27 (random-integer) | |
54 | ||
55 | ; Implementation remarks: | |
56 | ; * In general, the emphasis of this implementation is on correctness | |
57 | ; and portability, not on efficiency. | |
58 | ; * Variable arity procedures are expressed in terms of case-lambda | |
59 | ; in the hope that this will produce efficient code for the case | |
60 | ; where the arity is statically known at the call site. | |
61 | ; * In procedures that are required to type-check their arguments, | |
62 | ; we use (compare x x) for executing extra checks. This relies on | |
63 | ; the assumption that eq? is used to catch this case quickly. | |
64 | ; * Care has been taken to reference comparison procedures of R5RS | |
65 | ; only at the time the operations here are being defined. This | |
66 | ; makes it possible to redefine these operations, if need be. | |
67 | ; * For the sake of efficiency, some inlining has been done by hand. | |
68 | ; This is mainly expressed by macros producing defines. | |
69 | ; * Identifiers of the form compare:<something> are private. | |
70 | ; | |
71 | ; Hints for low-level implementation: | |
72 | ; * The basis of this SRFI are the atomic compare procedures, | |
73 | ; i.e. boolean-compare, char-compare, etc. and the conditionals | |
74 | ; if3, if=?, if<? etc., and default-compare. These should make | |
75 | ; optimal use of the available type information. | |
76 | ; * For the sake of speed, the reference implementation does not | |
77 | ; use a LET to save the comparison value c for the ERROR call. | |
78 | ; This can be fixed in a low-level implementation at no cost. | |
79 | ; * Type-checks based on (compare x x) are made explicit by the | |
80 | ; expression (compare:check result compare x ...). | |
81 | ; * Eq? should can used to speed up built-in compare procedures, | |
82 | ; but it can only be used after type-checking at least one of | |
83 | ; the arguments. | |
84 | ||
85 | (define (compare:checked result compare . args) | |
86 | (for-each (lambda (x) (compare x x)) args) | |
87 | result) | |
88 | ||
89 | ||
90 | ; 3-sided conditional | |
91 | ||
0c65f52c AW |
92 | (define-syntax-rule (if3 c less equal greater) |
93 | (case c | |
94 | ((-1) less) | |
95 | (( 0) equal) | |
96 | (( 1) greater) | |
97 | (else (error "comparison value not in {-1,0,1}")))) | |
8175a07e AR |
98 | |
99 | ||
100 | ; 2-sided conditionals for comparisons | |
101 | ||
102 | (define-syntax compare:if-rel? | |
103 | (syntax-rules () | |
104 | ((compare:if-rel? c-cases a-cases c consequence) | |
105 | (compare:if-rel? c-cases a-cases c consequence (if #f #f))) | |
106 | ((compare:if-rel? c-cases a-cases c consequence alternate) | |
107 | (case c | |
108 | (c-cases consequence) | |
109 | (a-cases alternate) | |
110 | (else (error "comparison value not in {-1,0,1}")))))) | |
111 | ||
0c65f52c AW |
112 | (define-syntax-rule (if=? arg ...) |
113 | (compare:if-rel? (0) (-1 1) arg ...)) | |
8175a07e | 114 | |
0c65f52c AW |
115 | (define-syntax-rule (if<? arg ...) |
116 | (compare:if-rel? (-1) (0 1) arg ...)) | |
8175a07e | 117 | |
0c65f52c AW |
118 | (define-syntax-rule (if>? arg ...) |
119 | (compare:if-rel? (1) (-1 0) arg ...)) | |
8175a07e | 120 | |
0c65f52c AW |
121 | (define-syntax-rule (if<=? arg ...) |
122 | (compare:if-rel? (-1 0) (1) arg ...)) | |
8175a07e | 123 | |
0c65f52c AW |
124 | (define-syntax-rule (if>=? arg ...) |
125 | (compare:if-rel? (0 1) (-1) arg ...)) | |
8175a07e | 126 | |
df08fc35 | 127 | (define-syntax-rule (if-not=? arg ...) |
0c65f52c | 128 | (compare:if-rel? (-1 1) (0) arg ...)) |
8175a07e AR |
129 | |
130 | ||
131 | ; predicates from compare procedures | |
132 | ||
df08fc35 | 133 | (define-syntax-rule (compare:define-rel? rel? if-rel?) |
0c65f52c AW |
134 | (define rel? |
135 | (case-lambda | |
136 | (() (lambda (x y) (if-rel? (default-compare x y) #t #f))) | |
137 | ((compare) (lambda (x y) (if-rel? (compare x y) #t #f))) | |
138 | ((x y) (if-rel? (default-compare x y) #t #f)) | |
139 | ((compare x y) | |
140 | (if (procedure? compare) | |
141 | (if-rel? (compare x y) #t #f) | |
142 | (error "not a procedure (Did you mean rel/rel??): " compare)))))) | |
8175a07e AR |
143 | |
144 | (compare:define-rel? =? if=?) | |
145 | (compare:define-rel? <? if<?) | |
146 | (compare:define-rel? >? if>?) | |
147 | (compare:define-rel? <=? if<=?) | |
148 | (compare:define-rel? >=? if>=?) | |
149 | (compare:define-rel? not=? if-not=?) | |
150 | ||
151 | ||
152 | ; chains of length 3 | |
153 | ||
df08fc35 | 154 | (define-syntax-rule (compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?) |
0c65f52c AW |
155 | (define rel1/rel2? |
156 | (case-lambda | |
157 | (() | |
158 | (lambda (x y z) | |
159 | (if-rel1? (default-compare x y) | |
160 | (if-rel2? (default-compare y z) #t #f) | |
161 | (compare:checked #f default-compare z)))) | |
162 | ((compare) | |
163 | (lambda (x y z) | |
164 | (if-rel1? (compare x y) | |
165 | (if-rel2? (compare y z) #t #f) | |
166 | (compare:checked #f compare z)))) | |
167 | ((x y z) | |
168 | (if-rel1? (default-compare x y) | |
169 | (if-rel2? (default-compare y z) #t #f) | |
170 | (compare:checked #f default-compare z))) | |
171 | ((compare x y z) | |
172 | (if-rel1? (compare x y) | |
173 | (if-rel2? (compare y z) #t #f) | |
174 | (compare:checked #f compare z)))))) | |
8175a07e AR |
175 | |
176 | (compare:define-rel1/rel2? </<? if<? if<?) | |
177 | (compare:define-rel1/rel2? </<=? if<? if<=?) | |
178 | (compare:define-rel1/rel2? <=/<? if<=? if<?) | |
179 | (compare:define-rel1/rel2? <=/<=? if<=? if<=?) | |
180 | (compare:define-rel1/rel2? >/>? if>? if>?) | |
181 | (compare:define-rel1/rel2? >/>=? if>? if>=?) | |
182 | (compare:define-rel1/rel2? >=/>? if>=? if>?) | |
183 | (compare:define-rel1/rel2? >=/>=? if>=? if>=?) | |
184 | ||
185 | ||
186 | ; chains of arbitrary length | |
187 | ||
df08fc35 | 188 | (define-syntax-rule (compare:define-chain-rel? chain-rel? if-rel?) |
0c65f52c AW |
189 | (define chain-rel? |
190 | (case-lambda | |
191 | ((compare) | |
192 | #t) | |
193 | ((compare x1) | |
194 | (compare:checked #t compare x1)) | |
195 | ((compare x1 x2) | |
196 | (if-rel? (compare x1 x2) #t #f)) | |
197 | ((compare x1 x2 x3) | |
198 | (if-rel? (compare x1 x2) | |
199 | (if-rel? (compare x2 x3) #t #f) | |
200 | (compare:checked #f compare x3))) | |
201 | ((compare x1 x2 . x3+) | |
202 | (if-rel? (compare x1 x2) | |
203 | (let chain? ((head x2) (tail x3+)) | |
204 | (if (null? tail) | |
205 | #t | |
206 | (if-rel? (compare head (car tail)) | |
207 | (chain? (car tail) (cdr tail)) | |
208 | (apply compare:checked #f | |
209 | compare (cdr tail))))) | |
210 | (apply compare:checked #f compare x3+)))))) | |
8175a07e AR |
211 | |
212 | (compare:define-chain-rel? chain=? if=?) | |
213 | (compare:define-chain-rel? chain<? if<?) | |
214 | (compare:define-chain-rel? chain>? if>?) | |
215 | (compare:define-chain-rel? chain<=? if<=?) | |
216 | (compare:define-chain-rel? chain>=? if>=?) | |
217 | ||
218 | ||
219 | ; pairwise inequality | |
220 | ||
221 | (define pairwise-not=? | |
222 | (let ((= =) (<= <=)) | |
223 | (case-lambda | |
224 | ((compare) | |
225 | #t) | |
226 | ((compare x1) | |
227 | (compare:checked #t compare x1)) | |
228 | ((compare x1 x2) | |
229 | (if-not=? (compare x1 x2) #t #f)) | |
230 | ((compare x1 x2 x3) | |
231 | (if-not=? (compare x1 x2) | |
232 | (if-not=? (compare x2 x3) | |
233 | (if-not=? (compare x1 x3) #t #f) | |
234 | #f) | |
235 | (compare:checked #f compare x3))) | |
236 | ((compare . x1+) | |
237 | (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t)) | |
238 | (if (< n 2) | |
239 | (if (and unchecked? (= n 1)) | |
240 | (compare:checked #t compare (car x)) | |
241 | #t) | |
242 | (let* ((i-pivot (random-integer n)) | |
243 | (x-pivot (list-ref x i-pivot))) | |
244 | (let split ((i 0) (x x) (x< '()) (x> '())) | |
245 | (if (null? x) | |
246 | (and (unequal? x< (length x<) #f) | |
247 | (unequal? x> (length x>) #f)) | |
248 | (if (= i i-pivot) | |
249 | (split (+ i 1) (cdr x) x< x>) | |
250 | (if3 (compare (car x) x-pivot) | |
251 | (split (+ i 1) (cdr x) (cons (car x) x<) x>) | |
252 | (if unchecked? | |
253 | (apply compare:checked #f compare (cdr x)) | |
254 | #f) | |
255 | (split (+ i 1) (cdr x) x< (cons (car x) x>))))))))))))) | |
256 | ||
257 | ||
258 | ; min/max | |
259 | ||
260 | (define min-compare | |
261 | (case-lambda | |
262 | ((compare x1) | |
263 | (compare:checked x1 compare x1)) | |
264 | ((compare x1 x2) | |
265 | (if<=? (compare x1 x2) x1 x2)) | |
266 | ((compare x1 x2 x3) | |
267 | (if<=? (compare x1 x2) | |
268 | (if<=? (compare x1 x3) x1 x3) | |
269 | (if<=? (compare x2 x3) x2 x3))) | |
270 | ((compare x1 x2 x3 x4) | |
271 | (if<=? (compare x1 x2) | |
272 | (if<=? (compare x1 x3) | |
273 | (if<=? (compare x1 x4) x1 x4) | |
274 | (if<=? (compare x3 x4) x3 x4)) | |
275 | (if<=? (compare x2 x3) | |
276 | (if<=? (compare x2 x4) x2 x4) | |
277 | (if<=? (compare x3 x4) x3 x4)))) | |
278 | ((compare x1 x2 . x3+) | |
279 | (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+)) | |
280 | (if (null? xs) | |
281 | xmin | |
282 | (min (if<=? (compare xmin (car xs)) xmin (car xs)) | |
283 | (cdr xs))))))) | |
284 | ||
285 | (define max-compare | |
286 | (case-lambda | |
287 | ((compare x1) | |
288 | (compare:checked x1 compare x1)) | |
289 | ((compare x1 x2) | |
290 | (if>=? (compare x1 x2) x1 x2)) | |
291 | ((compare x1 x2 x3) | |
292 | (if>=? (compare x1 x2) | |
293 | (if>=? (compare x1 x3) x1 x3) | |
294 | (if>=? (compare x2 x3) x2 x3))) | |
295 | ((compare x1 x2 x3 x4) | |
296 | (if>=? (compare x1 x2) | |
297 | (if>=? (compare x1 x3) | |
298 | (if>=? (compare x1 x4) x1 x4) | |
299 | (if>=? (compare x3 x4) x3 x4)) | |
300 | (if>=? (compare x2 x3) | |
301 | (if>=? (compare x2 x4) x2 x4) | |
302 | (if>=? (compare x3 x4) x3 x4)))) | |
303 | ((compare x1 x2 . x3+) | |
304 | (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+)) | |
305 | (if (null? xs) | |
306 | xmax | |
307 | (max (if>=? (compare xmax (car xs)) xmax (car xs)) | |
308 | (cdr xs))))))) | |
309 | ||
310 | ||
311 | ; kth-largest | |
312 | ||
313 | (define kth-largest | |
314 | (let ((= =) (< <)) | |
315 | (case-lambda | |
316 | ((compare k x0) | |
317 | (case (modulo k 1) | |
318 | ((0) (compare:checked x0 compare x0)) | |
319 | (else (error "bad index" k)))) | |
320 | ((compare k x0 x1) | |
321 | (case (modulo k 2) | |
322 | ((0) (if<=? (compare x0 x1) x0 x1)) | |
323 | ((1) (if<=? (compare x0 x1) x1 x0)) | |
324 | (else (error "bad index" k)))) | |
325 | ((compare k x0 x1 x2) | |
326 | (case (modulo k 3) | |
327 | ((0) (if<=? (compare x0 x1) | |
328 | (if<=? (compare x0 x2) x0 x2) | |
329 | (if<=? (compare x1 x2) x1 x2))) | |
330 | ((1) (if3 (compare x0 x1) | |
331 | (if<=? (compare x1 x2) | |
332 | x1 | |
333 | (if<=? (compare x0 x2) x2 x0)) | |
334 | (if<=? (compare x0 x2) x1 x0) | |
335 | (if<=? (compare x0 x2) | |
336 | x0 | |
337 | (if<=? (compare x1 x2) x2 x1)))) | |
338 | ((2) (if<=? (compare x0 x1) | |
339 | (if<=? (compare x1 x2) x2 x1) | |
340 | (if<=? (compare x0 x2) x2 x0))) | |
341 | (else (error "bad index" k)))) | |
342 | ((compare k x0 . x1+) ; |x1+| >= 1 | |
343 | (if (not (and (integer? k) (exact? k))) | |
344 | (error "bad index" k)) | |
345 | (let ((n (+ 1 (length x1+)))) | |
346 | (let kth ((k (modulo k n)) | |
347 | (n n) ; = |x| | |
348 | (rev #t) ; are x<, x=, x> reversed? | |
349 | (x (cons x0 x1+))) | |
350 | (let ((pivot (list-ref x (random-integer n)))) | |
351 | (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0)) | |
352 | (if (null? x) | |
353 | (cond | |
354 | ((< k n<) | |
355 | (kth k n< (not rev) x<)) | |
356 | ((< k (+ n< n=)) | |
357 | (if rev | |
358 | (list-ref x= (- (- n= 1) (- k n<))) | |
359 | (list-ref x= (- k n<)))) | |
360 | (else | |
361 | (kth (- k (+ n< n=)) n> (not rev) x>))) | |
362 | (if3 (compare (car x) pivot) | |
363 | (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>) | |
364 | (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>) | |
365 | (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1)))))))))))) | |
366 | ||
367 | ||
368 | ; compare functions from predicates | |
369 | ||
370 | (define compare-by< | |
371 | (case-lambda | |
372 | ((lt) (lambda (x y) (if (lt x y) -1 (if (lt y x) 1 0)))) | |
373 | ((lt x y) (if (lt x y) -1 (if (lt y x) 1 0))))) | |
374 | ||
375 | (define compare-by> | |
376 | (case-lambda | |
377 | ((gt) (lambda (x y) (if (gt x y) 1 (if (gt y x) -1 0)))) | |
378 | ((gt x y) (if (gt x y) 1 (if (gt y x) -1 0))))) | |
379 | ||
380 | (define compare-by<= | |
381 | (case-lambda | |
382 | ((le) (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1))) | |
383 | ((le x y) (if (le x y) (if (le y x) 0 -1) 1)))) | |
384 | ||
385 | (define compare-by>= | |
386 | (case-lambda | |
387 | ((ge) (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1))) | |
388 | ((ge x y) (if (ge x y) (if (ge y x) 0 1) -1)))) | |
389 | ||
390 | (define compare-by=/< | |
391 | (case-lambda | |
392 | ((eq lt) (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1)))) | |
393 | ((eq lt x y) (if (eq x y) 0 (if (lt x y) -1 1))))) | |
394 | ||
395 | (define compare-by=/> | |
396 | (case-lambda | |
397 | ((eq gt) (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1)))) | |
398 | ((eq gt x y) (if (eq x y) 0 (if (gt x y) 1 -1))))) | |
399 | ||
400 | ; refine and extend construction | |
401 | ||
402 | (define-syntax refine-compare | |
403 | (syntax-rules () | |
404 | ((refine-compare) | |
405 | 0) | |
406 | ((refine-compare c1) | |
407 | c1) | |
408 | ((refine-compare c1 c2 cs ...) | |
409 | (if3 c1 -1 (refine-compare c2 cs ...) 1)))) | |
410 | ||
411 | (define-syntax select-compare | |
412 | (syntax-rules (else) | |
413 | ((select-compare x y clause ...) | |
414 | (let ((x-val x) (y-val y)) | |
415 | (select-compare (x-val y-val clause ...)))) | |
416 | ; used internally: (select-compare (x y clause ...)) | |
417 | ((select-compare (x y)) | |
418 | 0) | |
419 | ((select-compare (x y (else c ...))) | |
420 | (refine-compare c ...)) | |
421 | ((select-compare (x y (t? c ...) clause ...)) | |
422 | (let ((t?-val t?)) | |
423 | (let ((tx (t?-val x)) (ty (t?-val y))) | |
424 | (if tx | |
425 | (if ty (refine-compare c ...) -1) | |
426 | (if ty 1 (select-compare (x y clause ...))))))))) | |
427 | ||
428 | (define-syntax cond-compare | |
429 | (syntax-rules (else) | |
430 | ((cond-compare) | |
431 | 0) | |
432 | ((cond-compare (else cs ...)) | |
433 | (refine-compare cs ...)) | |
434 | ((cond-compare ((tx ty) cs ...) clause ...) | |
435 | (let ((tx-val tx) (ty-val ty)) | |
436 | (if tx-val | |
437 | (if ty-val (refine-compare cs ...) -1) | |
438 | (if ty-val 1 (cond-compare clause ...))))))) | |
439 | ||
440 | ||
441 | ; R5RS atomic types | |
442 | ||
443 | (define-syntax compare:type-check | |
444 | (syntax-rules () | |
445 | ((compare:type-check type? type-name x) | |
446 | (if (not (type? x)) | |
447 | (error (string-append "not " type-name ":") x))) | |
448 | ((compare:type-check type? type-name x y) | |
449 | (begin (compare:type-check type? type-name x) | |
450 | (compare:type-check type? type-name y))))) | |
451 | ||
df08fc35 | 452 | (define-syntax-rule (compare:define-by=/< compare = < type? type-name) |
0c65f52c AW |
453 | (define compare |
454 | (let ((= =) (< <)) | |
455 | (lambda (x y) | |
456 | (if (type? x) | |
457 | (if (eq? x y) | |
458 | 0 | |
459 | (if (type? y) | |
460 | (if (= x y) 0 (if (< x y) -1 1)) | |
461 | (error (string-append "not " type-name ":") y))) | |
462 | (error (string-append "not " type-name ":") x)))))) | |
8175a07e AR |
463 | |
464 | (define (boolean-compare x y) | |
465 | (compare:type-check boolean? "boolean" x y) | |
466 | (if x (if y 0 1) (if y -1 0))) | |
467 | ||
468 | (compare:define-by=/< char-compare char=? char<? char? "char") | |
469 | ||
470 | (compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char") | |
471 | ||
472 | (compare:define-by=/< string-compare string=? string<? string? "string") | |
473 | ||
474 | (compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string") | |
475 | ||
476 | (define (symbol-compare x y) | |
477 | (compare:type-check symbol? "symbol" x y) | |
478 | (string-compare (symbol->string x) (symbol->string y))) | |
479 | ||
480 | (compare:define-by=/< integer-compare = < integer? "integer") | |
481 | ||
482 | (compare:define-by=/< rational-compare = < rational? "rational") | |
483 | ||
484 | (compare:define-by=/< real-compare = < real? "real") | |
485 | ||
486 | (define (complex-compare x y) | |
487 | (compare:type-check complex? "complex" x y) | |
488 | (if (and (real? x) (real? y)) | |
489 | (real-compare x y) | |
490 | (refine-compare (real-compare (real-part x) (real-part y)) | |
491 | (real-compare (imag-part x) (imag-part y))))) | |
492 | ||
493 | (define (number-compare x y) | |
494 | (compare:type-check number? "number" x y) | |
495 | (complex-compare x y)) | |
496 | ||
497 | ||
498 | ; R5RS compound data structures: dotted pair, list, vector | |
499 | ||
500 | (define (pair-compare-car compare) | |
501 | (lambda (x y) | |
502 | (compare (car x) (car y)))) | |
503 | ||
504 | (define (pair-compare-cdr compare) | |
505 | (lambda (x y) | |
506 | (compare (cdr x) (cdr y)))) | |
507 | ||
508 | (define pair-compare | |
509 | (case-lambda | |
510 | ||
511 | ; dotted pair | |
512 | ((pair-compare-car pair-compare-cdr x y) | |
513 | (refine-compare (pair-compare-car (car x) (car y)) | |
514 | (pair-compare-cdr (cdr x) (cdr y)))) | |
515 | ||
516 | ; possibly improper lists | |
517 | ((compare x y) | |
518 | (cond-compare | |
519 | (((null? x) (null? y)) 0) | |
520 | (((pair? x) (pair? y)) (compare (car x) (car y)) | |
521 | (pair-compare compare (cdr x) (cdr y))) | |
522 | (else (compare x y)))) | |
523 | ||
524 | ; for convenience | |
525 | ((x y) | |
526 | (pair-compare default-compare x y)))) | |
527 | ||
528 | (define list-compare | |
529 | (case-lambda | |
530 | ((compare x y empty? head tail) | |
531 | (cond-compare | |
532 | (((empty? x) (empty? y)) 0) | |
533 | (else (compare (head x) (head y)) | |
534 | (list-compare compare (tail x) (tail y) empty? head tail)))) | |
535 | ||
536 | ; for convenience | |
537 | (( x y empty? head tail) | |
538 | (list-compare default-compare x y empty? head tail)) | |
539 | ((compare x y ) | |
540 | (list-compare compare x y null? car cdr)) | |
541 | (( x y ) | |
542 | (list-compare default-compare x y null? car cdr)))) | |
543 | ||
544 | (define list-compare-as-vector | |
545 | (case-lambda | |
546 | ((compare x y empty? head tail) | |
547 | (refine-compare | |
548 | (let compare-length ((x x) (y y)) | |
549 | (cond-compare | |
550 | (((empty? x) (empty? y)) 0) | |
551 | (else (compare-length (tail x) (tail y))))) | |
552 | (list-compare compare x y empty? head tail))) | |
553 | ||
554 | ; for convenience | |
555 | (( x y empty? head tail) | |
556 | (list-compare-as-vector default-compare x y empty? head tail)) | |
557 | ((compare x y ) | |
558 | (list-compare-as-vector compare x y null? car cdr)) | |
559 | (( x y ) | |
560 | (list-compare-as-vector default-compare x y null? car cdr)))) | |
561 | ||
562 | (define vector-compare | |
563 | (let ((= =)) | |
564 | (case-lambda | |
565 | ((compare x y size ref) | |
566 | (let ((n (size x)) (m (size y))) | |
567 | (refine-compare | |
568 | (integer-compare n m) | |
569 | (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1] | |
570 | (if (= i n) | |
571 | 0 | |
572 | (refine-compare (compare (ref x i) (ref y i)) | |
573 | (compare-rest (+ i 1)))))))) | |
574 | ||
575 | ; for convenience | |
576 | (( x y size ref) | |
577 | (vector-compare default-compare x y size ref)) | |
578 | ((compare x y ) | |
579 | (vector-compare compare x y vector-length vector-ref)) | |
580 | (( x y ) | |
581 | (vector-compare default-compare x y vector-length vector-ref))))) | |
582 | ||
583 | (define vector-compare-as-list | |
584 | (let ((= =)) | |
585 | (case-lambda | |
586 | ((compare x y size ref) | |
587 | (let ((nx (size x)) (ny (size y))) | |
588 | (let ((n (min nx ny))) | |
589 | (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1] | |
590 | (if (= i n) | |
591 | (integer-compare nx ny) | |
592 | (refine-compare (compare (ref x i) (ref y i)) | |
593 | (compare-rest (+ i 1)))))))) | |
594 | ||
595 | ; for convenience | |
596 | (( x y size ref) | |
597 | (vector-compare-as-list default-compare x y size ref)) | |
598 | ((compare x y ) | |
599 | (vector-compare-as-list compare x y vector-length vector-ref)) | |
600 | (( x y ) | |
601 | (vector-compare-as-list default-compare x y vector-length vector-ref))))) | |
602 | ||
603 | ||
604 | ; default compare | |
605 | ||
606 | (define (default-compare x y) | |
607 | (select-compare | |
608 | x y | |
609 | (null? 0) | |
610 | (pair? (default-compare (car x) (car y)) | |
611 | (default-compare (cdr x) (cdr y))) | |
612 | (boolean? (boolean-compare x y)) | |
613 | (char? (char-compare x y)) | |
614 | (string? (string-compare x y)) | |
615 | (symbol? (symbol-compare x y)) | |
616 | (number? (number-compare x y)) | |
617 | (vector? (vector-compare default-compare x y)) | |
618 | (else (error "unrecognized type in default-compare" x y)))) | |
619 | ||
620 | ; Note that we pass default-compare to compare-{pair,vector} explictly. | |
621 | ; This makes sure recursion proceeds with this default-compare, which | |
622 | ; need not be the one in the lexical scope of compare-{pair,vector}. | |
623 | ||
624 | ||
625 | ; debug compare | |
626 | ||
627 | (define (debug-compare c) | |
628 | ||
629 | (define (checked-value c x y) | |
630 | (let ((c-xy (c x y))) | |
631 | (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1)) | |
632 | c-xy | |
633 | (error "compare value not in {-1,0,1}" c-xy (list c x y))))) | |
634 | ||
635 | (define (random-boolean) | |
636 | (zero? (random-integer 2))) | |
637 | ||
638 | (define q ; (u v w) such that u <= v, v <= w, and not u <= w | |
639 | '#( | |
640 | ;x < y x = y x > y [x < z] | |
641 | 0 0 0 ; y < z | |
642 | 0 (z y x) (z y x) ; y = z | |
643 | 0 (z y x) (z y x) ; y > z | |
644 | ||
645 | ;x < y x = y x > y [x = z] | |
646 | (y z x) (z x y) 0 ; y < z | |
647 | (y z x) 0 (x z y) ; y = z | |
648 | 0 (y x z) (x z y) ; y > z | |
649 | ||
650 | ;x < y x = y x > y [x > z] | |
651 | (x y z) (x y z) 0 ; y < z | |
652 | (x y z) (x y z) 0 ; y = z | |
653 | 0 0 0 ; y > z | |
654 | )) | |
655 | ||
656 | (let ((z? #f) (z #f)) ; stored element from previous call | |
657 | (lambda (x y) | |
658 | (let ((c-xx (checked-value c x x)) | |
659 | (c-yy (checked-value c y y)) | |
660 | (c-xy (checked-value c x y)) | |
661 | (c-yx (checked-value c y x))) | |
662 | (if (not (zero? c-xx)) | |
663 | (error "compare error: not reflexive" c x)) | |
664 | (if (not (zero? c-yy)) | |
665 | (error "compare error: not reflexive" c y)) | |
666 | (if (not (zero? (+ c-xy c-yx))) | |
667 | (error "compare error: not anti-symmetric" c x y)) | |
668 | (if z? | |
669 | (let ((c-xz (checked-value c x z)) | |
670 | (c-zx (checked-value c z x)) | |
671 | (c-yz (checked-value c y z)) | |
672 | (c-zy (checked-value c z y))) | |
673 | (if (not (zero? (+ c-xz c-zx))) | |
674 | (error "compare error: not anti-symmetric" c x z)) | |
675 | (if (not (zero? (+ c-yz c-zy))) | |
676 | (error "compare error: not anti-symmetric" c y z)) | |
677 | (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13)))) | |
678 | (if (list? ijk) | |
679 | (apply error | |
680 | "compare error: not transitive" | |
681 | c | |
682 | (map (lambda (i) (case i ((x) x) ((y) y) ((z) z))) | |
683 | ijk))))) | |
684 | (set! z? #t)) | |
685 | (set! z (if (random-boolean) x y)) ; randomized testing | |
686 | c-xy)))) |