0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 29 ;; Copyright (c)
0010: 20 32 30 30 39 20 44 65 72 69 63 6b 20 45 64 64 2009 Derick Edd
0020: 69 6e 67 74 6f 6e 2e 20 20 41 6c 6c 20 72 69 67 ington. All rig
0030: 68 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b hts reserved..;;
0040: 20 4c 69 63 65 6e 73 65 64 20 75 6e 64 65 72 20 Licensed under
0050: 61 6e 20 4d 49 54 2d 73 74 79 6c 65 20 6c 69 63 an MIT-style lic
0060: 65 6e 73 65 2e 20 20 4d 79 20 6c 69 63 65 6e 73 ense. My licens
0070: 65 20 69 73 20 69 6e 20 74 68 65 20 66 69 6c 65 e is in the file
0080: 0a 3b 3b 20 6e 61 6d 65 64 20 4c 49 43 45 4e 53 .;; named LICENS
0090: 45 20 66 72 6f 6d 20 74 68 65 20 6f 72 69 67 69 E from the origi
00a0: 6e 61 6c 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 74 nal collection t
00b0: 68 69 73 20 66 69 6c 65 20 69 73 20 64 69 73 74 his file is dist
00c0: 72 69 62 75 74 65 64 0a 3b 3b 20 77 69 74 68 2e ributed.;; with.
00d0: 20 20 49 66 20 74 68 69 73 20 66 69 6c 65 20 69 If this file i
00e0: 73 20 72 65 64 69 73 74 72 69 62 75 74 65 64 20 s redistributed
00f0: 77 69 74 68 20 73 6f 6d 65 20 6f 74 68 65 72 20 with some other
0100: 63 6f 6c 6c 65 63 74 69 6f 6e 2c 20 6d 79 0a 3b collection, my.;
0110: 3b 20 6c 69 63 65 6e 73 65 20 6d 75 73 74 20 61 ; license must a
0120: 6c 73 6f 20 62 65 20 69 6e 63 6c 75 64 65 64 2e lso be included.
0130: 0a 0a 23 21 72 36 72 73 0a 28 6c 69 62 72 61 72 ..#!r6rs.(librar
0140: 79 20 28 73 72 66 69 20 73 36 37 20 63 6f 6d 70 y (srfi s67 comp
0150: 61 72 65 2d 70 72 6f 63 65 64 75 72 65 73 29 0a are-procedures).
0160: 20 20 28 65 78 70 6f 72 74 20 20 3c 2f 3c 3d 3f (export </<=?
0170: 20 3c 2f 3c 3f 20 3c 3d 2f 3c 3d 3f 20 3c 3d 2f </<? <=/<=? <=/
0180: 3c 3f 20 3c 3d 3f 20 3c 3f 20 3d 3f 0a 20 20 20 <? <=? <? =?.
0190: 20 20 20 20 20 20 20 20 3e 2f 3e 3d 3f 20 3e 2f >/>=? >/
01a0: 3e 3f 20 3e 3d 2f 3e 3d 3f 20 3e 3d 2f 3e 3f 20 >? >=/>=? >=/>?
01b0: 3e 3d 3f 20 3e 3f 0a 20 20 20 20 20 20 20 20 20 >=? >?.
01c0: 20 20 62 6f 6f 6c 65 61 6e 2d 63 6f 6d 70 61 72 boolean-compar
01d0: 65 20 63 68 61 69 6e 3c 3d 3f 20 63 68 61 69 6e e chain<=? chain
01e0: 3c 3f 20 63 68 61 69 6e 3d 3f 20 63 68 61 69 6e <? chain=? chain
01f0: 3e 3d 3f 20 63 68 61 69 6e 3e 3f 0a 20 20 20 20 >=? chain>?.
0200: 20 20 20 20 20 20 20 63 68 61 72 2d 63 6f 6d 70 char-comp
0210: 61 72 65 20 63 68 61 72 2d 63 6f 6d 70 61 72 65 are char-compare
0220: 2d 63 69 0a 20 20 20 20 20 20 20 20 20 20 20 63 -ci. c
0230: 6f 6d 70 61 72 65 2d 62 79 3c 20 63 6f 6d 70 61 ompare-by< compa
0240: 72 65 2d 62 79 3c 3d 20 63 6f 6d 70 61 72 65 2d re-by<= compare-
0250: 62 79 3d 2f 3c 20 63 6f 6d 70 61 72 65 2d 62 79 by=/< compare-by
0260: 3d 2f 3e 20 63 6f 6d 70 61 72 65 2d 62 79 3e 20 =/> compare-by>
0270: 0a 20 20 20 20 20 20 20 20 20 20 20 63 6f 6d 70 . comp
0280: 61 72 65 2d 62 79 3e 3d 20 63 6f 6d 70 6c 65 78 are-by>= complex
0290: 2d 63 6f 6d 70 61 72 65 20 63 6f 6e 64 2d 63 6f -compare cond-co
02a0: 6d 70 61 72 65 0a 20 20 20 20 20 20 20 20 20 20 mpare.
02b0: 20 64 65 62 75 67 2d 63 6f 6d 70 61 72 65 20 64 debug-compare d
02c0: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 0a 20 efault-compare.
02d0: 20 20 20 20 20 20 20 20 20 20 69 66 2d 6e 6f 74 if-not
02e0: 3d 3f 20 69 66 33 20 69 66 3c 3d 3f 20 69 66 3c =? if3 if<=? if<
02f0: 3f 20 69 66 3d 3f 20 69 66 3e 3d 3f 20 69 66 3e ? if=? if>=? if>
0300: 3f 20 69 6e 74 65 67 65 72 2d 63 6f 6d 70 61 72 ? integer-compar
0310: 65 0a 20 20 20 20 20 20 20 20 20 20 20 6b 74 68 e. kth
0320: 2d 6c 61 72 67 65 73 74 20 6c 69 73 74 2d 63 6f -largest list-co
0330: 6d 70 61 72 65 20 6c 69 73 74 2d 63 6f 6d 70 61 mpare list-compa
0340: 72 65 2d 61 73 2d 76 65 63 74 6f 72 0a 20 20 20 re-as-vector.
0350: 20 20 20 20 20 20 20 20 6d 61 78 2d 63 6f 6d 70 max-comp
0360: 61 72 65 20 6d 69 6e 2d 63 6f 6d 70 61 72 65 20 are min-compare
0370: 6e 6f 74 3d 3f 20 6e 75 6d 62 65 72 2d 63 6f 6d not=? number-com
0380: 70 61 72 65 0a 20 20 20 20 20 20 20 20 20 20 20 pare.
0390: 70 61 69 72 2d 63 6f 6d 70 61 72 65 20 70 61 69 pair-compare pai
03a0: 72 2d 63 6f 6d 70 61 72 65 2d 63 61 72 20 70 61 r-compare-car pa
03b0: 69 72 2d 63 6f 6d 70 61 72 65 2d 63 64 72 0a 20 ir-compare-cdr.
03c0: 20 20 20 20 20 20 20 20 20 20 70 61 69 72 77 69 pairwi
03d0: 73 65 2d 6e 6f 74 3d 3f 20 72 61 74 69 6f 6e 61 se-not=? rationa
03e0: 6c 2d 63 6f 6d 70 61 72 65 20 72 65 61 6c 2d 63 l-compare real-c
03f0: 6f 6d 70 61 72 65 0a 20 20 20 20 20 20 20 20 20 ompare.
0400: 20 20 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 refine-compare
0410: 20 73 65 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 select-compare
0420: 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 73 string-compare s
0430: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d 63 69 tring-compare-ci
0440: 20 0a 20 20 20 20 20 20 20 20 20 20 20 73 79 6d . sym
0450: 62 6f 6c 2d 63 6f 6d 70 61 72 65 20 76 65 63 74 bol-compare vect
0460: 6f 72 2d 63 6f 6d 70 61 72 65 20 76 65 63 74 6f or-compare vecto
0470: 72 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 6c 69 73 r-compare-as-lis
0480: 74 29 0a 20 20 0a 20 20 28 69 6d 70 6f 72 74 20 t). . (import
0490: 28 65 78 63 65 70 74 20 28 72 6e 72 73 29 20 65 (except (rnrs) e
04a0: 72 72 6f 72 29 0a 20 20 20 20 20 20 20 20 20 20 rror).
04b0: 28 72 6e 72 73 20 72 35 72 73 29 20 20 20 20 3b (rnrs r5rs) ;
04c0: 20 66 6f 72 20 6d 6f 64 75 6c 6f 0a 20 20 20 20 for modulo.
04d0: 20 20 20 20 20 20 28 73 72 66 69 20 73 32 37 20 (srfi s27
04e0: 72 61 6e 64 6f 6d 2d 62 69 74 73 29 20 20 3b 20 random-bits) ;
04f0: 66 6f 72 20 72 61 6e 64 6f 6d 2d 69 6e 74 65 67 for random-integ
0500: 65 72 0a 20 20 20 20 20 20 20 20 20 20 28 73 72 er. (sr
0510: 66 69 20 73 32 33 20 65 72 72 6f 72 29 0a 20 20 fi s23 error).
0520: 20 20 20 20 20 20 20 20 3b 3b 20 28 73 72 66 69 ;; (srfi
0530: 20 73 32 33 20 65 72 72 6f 72 20 74 72 69 63 6b s23 error trick
0540: 73 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 72 s). (sr
0550: 66 69 20 70 72 69 76 61 74 65 20 69 6e 63 6c 75 fi private inclu
0560: 64 65 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 de)).. (define
0570: 28 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 (default-compare
0580: 20 78 20 79 29 0a 20 20 20 20 28 73 65 6c 65 63 x y). (selec
0590: 74 2d 63 6f 6d 70 61 72 65 20 0a 20 20 20 20 20 t-compare .
05a0: 78 20 79 0a 20 20 20 20 20 28 6e 75 6c 6c 3f 20 x y. (null?
05b0: 20 20 20 30 29 0a 20 20 20 20 20 28 70 61 69 72 0). (pair
05c0: 3f 20 20 20 20 28 64 65 66 61 75 6c 74 2d 63 6f ? (default-co
05d0: 6d 70 61 72 65 20 28 63 61 72 20 78 29 20 28 63 mpare (car x) (c
05e0: 61 72 20 79 29 29 0a 20 20 20 20 20 20 20 20 20 ar y)).
05f0: 20 20 20 20 20 20 28 64 65 66 61 75 6c 74 2d 63 (default-c
0600: 6f 6d 70 61 72 65 20 28 63 64 72 20 78 29 20 28 ompare (cdr x) (
0610: 63 64 72 20 79 29 29 29 0a 20 20 20 20 20 28 62 cdr y))). (b
0620: 6f 6f 6c 65 61 6e 3f 20 28 62 6f 6f 6c 65 61 6e oolean? (boolean
0630: 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 29 0a 20 -compare x y)).
0640: 20 20 20 20 28 63 68 61 72 3f 20 20 20 20 28 63 (char? (c
0650: 68 61 72 2d 63 6f 6d 70 61 72 65 20 20 20 20 78 har-compare x
0660: 20 79 29 29 0a 20 20 20 20 20 28 73 74 72 69 6e y)). (strin
0670: 67 3f 20 20 28 73 74 72 69 6e 67 2d 63 6f 6d 70 g? (string-comp
0680: 61 72 65 20 20 78 20 79 29 29 0a 20 20 20 20 20 are x y)).
0690: 28 73 79 6d 62 6f 6c 3f 20 20 28 73 79 6d 62 6f (symbol? (symbo
06a0: 6c 2d 63 6f 6d 70 61 72 65 20 20 78 20 79 29 29 l-compare x y))
06b0: 0a 20 20 20 20 20 28 6e 75 6d 62 65 72 3f 20 20 . (number?
06c0: 28 6e 75 6d 62 65 72 2d 63 6f 6d 70 61 72 65 20 (number-compare
06d0: 20 78 20 79 29 29 0a 20 20 20 20 20 28 76 65 63 x y)). (vec
06e0: 74 6f 72 3f 20 20 28 76 65 63 74 6f 72 2d 63 6f tor? (vector-co
06f0: 6d 70 61 72 65 20 64 65 66 61 75 6c 74 2d 63 6f mpare default-co
0700: 6d 70 61 72 65 20 78 20 79 29 29 0a 20 20 20 20 mpare x y)).
0710: 20 28 65 6c 73 65 20 28 65 72 72 6f 72 20 22 75 (else (error "u
0720: 6e 72 65 63 6f 67 6e 69 7a 65 64 20 74 79 70 65 nrecognized type
0730: 20 69 6e 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 in default-comp
0740: 61 72 65 22 20 78 20 79 29 29 29 29 20 20 0a 20 are" x y)))) .
0750: 20 0a 20 20 3b 3b 20 28 53 52 46 49 2d 32 33 2d . ;; (SRFI-23-
0760: 65 72 72 6f 72 2d 3e 52 36 52 53 20 22 28 6c 69 error->R6RS "(li
0770: 62 72 61 72 79 20 28 73 72 66 69 20 73 36 37 20 brary (srfi s67
0780: 63 6f 6d 70 61 72 65 2d 70 72 6f 63 65 64 75 72 compare-procedur
0790: 65 73 29 29 22 0a 20 20 3b 3b 20 20 28 69 6e 63 es))". ;; (inc
07a0: 6c 75 64 65 2f 72 65 73 6f 6c 76 65 20 28 22 73 lude/resolve ("s
07b0: 72 66 69 22 20 22 73 36 37 22 29 20 22 63 6f 6d rfi" "s67") "com
07c0: 70 61 72 65 2e 73 73 22 29 29 0a 0a 3b 20 28 64 pare.ss"))..; (d
07d0: 65 66 69 6e 65 20 63 75 72 72 65 6e 74 2d 63 6f efine current-co
07e0: 6d 70 61 72 65 20 28 6d 61 6b 65 2d 70 61 72 61 mpare (make-para
07f0: 6d 65 74 65 72 20 64 65 66 61 75 6c 74 2d 63 6f meter default-co
0800: 6d 70 61 72 65 29 29 0a 3b 20 28 70 72 6f 76 69 mpare)).; (provi
0810: 64 65 20 63 75 72 72 65 6e 74 2d 63 6f 6d 70 61 de current-compa
0820: 72 65 29 0a 0a 3b 20 43 6f 70 79 72 69 67 68 74 re)..; Copyright
0830: 20 28 63 29 20 32 30 30 35 20 53 65 62 61 73 74 (c) 2005 Sebast
0840: 69 61 6e 20 45 67 6e 65 72 20 61 6e 64 20 4a 65 ian Egner and Je
0850: 6e 73 20 41 78 65 6c 20 53 7b 5c 6f 7d 67 61 61 ns Axel S{\o}gaa
0860: 72 64 2e 0a 3b 20 0a 3b 20 50 65 72 6d 69 73 73 rd..; .; Permiss
0870: 69 6f 6e 20 69 73 20 68 65 72 65 62 79 20 67 72 ion is hereby gr
0880: 61 6e 74 65 64 2c 20 66 72 65 65 20 6f 66 20 63 anted, free of c
0890: 68 61 72 67 65 2c 20 74 6f 20 61 6e 79 20 70 65 harge, to any pe
08a0: 72 73 6f 6e 20 6f 62 74 61 69 6e 69 6e 67 0a 3b rson obtaining.;
08b0: 20 61 20 63 6f 70 79 20 6f 66 20 74 68 69 73 20 a copy of this
08c0: 73 6f 66 74 77 61 72 65 20 61 6e 64 20 61 73 73 software and ass
08d0: 6f 63 69 61 74 65 64 20 64 6f 63 75 6d 65 6e 74 ociated document
08e0: 61 74 69 6f 6e 20 66 69 6c 65 73 20 28 74 68 65 ation files (the
08f0: 0a 3b 20 60 60 53 6f 66 74 77 61 72 65 27 27 29 .; ``Software'')
0900: 2c 20 74 6f 20 64 65 61 6c 20 69 6e 20 74 68 65 , to deal in the
0910: 20 53 6f 66 74 77 61 72 65 20 77 69 74 68 6f 75 Software withou
0920: 74 20 72 65 73 74 72 69 63 74 69 6f 6e 2c 20 69 t restriction, i
0930: 6e 63 6c 75 64 69 6e 67 0a 3b 20 77 69 74 68 6f ncluding.; witho
0940: 75 74 20 6c 69 6d 69 74 61 74 69 6f 6e 20 74 68 ut limitation th
0950: 65 20 72 69 67 68 74 73 20 74 6f 20 75 73 65 2c e rights to use,
0960: 20 63 6f 70 79 2c 20 6d 6f 64 69 66 79 2c 20 6d copy, modify, m
0970: 65 72 67 65 2c 20 70 75 62 6c 69 73 68 2c 0a 3b erge, publish,.;
0980: 20 64 69 73 74 72 69 62 75 74 65 2c 20 73 75 62 distribute, sub
0990: 6c 69 63 65 6e 73 65 2c 20 61 6e 64 2f 6f 72 20 license, and/or
09a0: 73 65 6c 6c 20 63 6f 70 69 65 73 20 6f 66 20 74 sell copies of t
09b0: 68 65 20 53 6f 66 74 77 61 72 65 2c 20 61 6e 64 he Software, and
09c0: 20 74 6f 0a 3b 20 70 65 72 6d 69 74 20 70 65 72 to.; permit per
09d0: 73 6f 6e 73 20 74 6f 20 77 68 6f 6d 20 74 68 65 sons to whom the
09e0: 20 53 6f 66 74 77 61 72 65 20 69 73 20 66 75 72 Software is fur
09f0: 6e 69 73 68 65 64 20 74 6f 20 64 6f 20 73 6f 2c nished to do so,
0a00: 20 73 75 62 6a 65 63 74 20 74 6f 0a 3b 20 74 68 subject to.; th
0a10: 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 63 6f 6e 64 e following cond
0a20: 69 74 69 6f 6e 73 3a 0a 3b 20 0a 3b 20 54 68 65 itions:.; .; The
0a30: 20 61 62 6f 76 65 20 63 6f 70 79 72 69 67 68 74 above copyright
0a40: 20 6e 6f 74 69 63 65 20 61 6e 64 20 74 68 69 73 notice and this
0a50: 20 70 65 72 6d 69 73 73 69 6f 6e 20 6e 6f 74 69 permission noti
0a60: 63 65 20 73 68 61 6c 6c 20 62 65 0a 3b 20 69 6e ce shall be.; in
0a70: 63 6c 75 64 65 64 20 69 6e 20 61 6c 6c 20 63 6f cluded in all co
0a80: 70 69 65 73 20 6f 72 20 73 75 62 73 74 61 6e 74 pies or substant
0a90: 69 61 6c 20 70 6f 72 74 69 6f 6e 73 20 6f 66 20 ial portions of
0aa0: 74 68 65 20 53 6f 66 74 77 61 72 65 2e 0a 3b 20 the Software..;
0ab0: 0a 3b 20 54 48 45 20 53 4f 46 54 57 41 52 45 20 .; THE SOFTWARE
0ac0: 49 53 20 50 52 4f 56 49 44 45 44 20 60 60 41 53 IS PROVIDED ``AS
0ad0: 20 49 53 27 27 2c 20 57 49 54 48 4f 55 54 20 57 IS'', WITHOUT W
0ae0: 41 52 52 41 4e 54 59 20 4f 46 20 41 4e 59 20 4b ARRANTY OF ANY K
0af0: 49 4e 44 2c 0a 3b 20 45 58 50 52 45 53 53 20 4f IND,.; EXPRESS O
0b00: 52 20 49 4d 50 4c 49 45 44 2c 20 49 4e 43 4c 55 R IMPLIED, INCLU
0b10: 44 49 4e 47 20 42 55 54 20 4e 4f 54 20 4c 49 4d DING BUT NOT LIM
0b20: 49 54 45 44 20 54 4f 20 54 48 45 20 57 41 52 52 ITED TO THE WARR
0b30: 41 4e 54 49 45 53 20 4f 46 0a 3b 20 4d 45 52 43 ANTIES OF.; MERC
0b40: 48 41 4e 54 41 42 49 4c 49 54 59 2c 20 46 49 54 HANTABILITY, FIT
0b50: 4e 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 NESS FOR A PARTI
0b60: 43 55 4c 41 52 20 50 55 52 50 4f 53 45 20 41 4e CULAR PURPOSE AN
0b70: 44 0a 3b 20 4e 4f 4e 49 4e 46 52 49 4e 47 45 4d D.; NONINFRINGEM
0b80: 45 4e 54 2e 20 49 4e 20 4e 4f 20 45 56 45 4e 54 ENT. IN NO EVENT
0b90: 20 53 48 41 4c 4c 20 54 48 45 20 41 55 54 48 4f SHALL THE AUTHO
0ba0: 52 53 20 4f 52 20 43 4f 50 59 52 49 47 48 54 20 RS OR COPYRIGHT
0bb0: 48 4f 4c 44 45 52 53 20 42 45 0a 3b 20 4c 49 41 HOLDERS BE.; LIA
0bc0: 42 4c 45 20 46 4f 52 20 41 4e 59 20 43 4c 41 49 BLE FOR ANY CLAI
0bd0: 4d 2c 20 44 41 4d 41 47 45 53 20 4f 52 20 4f 54 M, DAMAGES OR OT
0be0: 48 45 52 20 4c 49 41 42 49 4c 49 54 59 2c 20 57 HER LIABILITY, W
0bf0: 48 45 54 48 45 52 20 49 4e 20 41 4e 20 41 43 54 HETHER IN AN ACT
0c00: 49 4f 4e 0a 3b 20 4f 46 20 43 4f 4e 54 52 41 43 ION.; OF CONTRAC
0c10: 54 2c 20 54 4f 52 54 20 4f 52 20 4f 54 48 45 52 T, TORT OR OTHER
0c20: 57 49 53 45 2c 20 41 52 49 53 49 4e 47 20 46 52 WISE, ARISING FR
0c30: 4f 4d 2c 20 4f 55 54 20 4f 46 20 4f 52 20 49 4e OM, OUT OF OR IN
0c40: 20 43 4f 4e 4e 45 43 54 49 4f 4e 0a 3b 20 57 49 CONNECTION.; WI
0c50: 54 48 20 54 48 45 20 53 4f 46 54 57 41 52 45 20 TH THE SOFTWARE
0c60: 4f 52 20 54 48 45 20 55 53 45 20 4f 52 20 4f 54 OR THE USE OR OT
0c70: 48 45 52 20 44 45 41 4c 49 4e 47 53 20 49 4e 20 HER DEALINGS IN
0c80: 54 48 45 20 53 4f 46 54 57 41 52 45 2e 0a 3b 20 THE SOFTWARE..;
0c90: 0a 3b 20 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d .; -------------
0ca0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0cb0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0cc0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0cd0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 0a 3b 20 0a 3b 20 ----------.; .;
0ce0: 43 6f 6d 70 61 72 65 20 70 72 6f 63 65 64 75 72 Compare procedur
0cf0: 65 73 20 53 52 46 49 20 28 72 65 66 65 72 65 6e es SRFI (referen
0d00: 63 65 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f ce implementatio
0d10: 6e 29 0a 3b 20 53 65 62 61 73 74 69 61 6e 2e 45 n).; Sebastian.E
0d20: 67 6e 65 72 40 70 68 69 6c 69 70 73 2e 63 6f 6d gner@philips.com
0d30: 2c 20 4a 65 6e 73 61 78 65 6c 40 73 6f 65 67 61 , Jensaxel@soega
0d40: 61 72 64 2e 6e 65 74 0a 3b 20 68 69 73 74 6f 72 ard.net.; histor
0d50: 79 20 6f 66 20 74 68 69 73 20 66 69 6c 65 3a 0a y of this file:.
0d60: 3b 20 20 20 53 45 2c 20 31 34 2d 4f 63 74 2d 32 ; SE, 14-Oct-2
0d70: 30 30 34 3a 20 66 69 72 73 74 20 76 65 72 73 69 004: first versi
0d80: 6f 6e 0a 3b 20 20 20 53 45 2c 20 31 38 2d 4f 63 on.; SE, 18-Oc
0d90: 74 2d 32 30 30 34 3a 20 31 73 74 20 72 65 64 65 t-2004: 1st rede
0da0: 73 69 67 6e 3a 20 61 78 69 6f 6d 73 20 66 6f 72 sign: axioms for
0db0: 20 27 63 6f 6d 70 61 72 65 20 66 75 6e 63 74 69 'compare functi
0dc0: 6f 6e 27 0a 3b 20 20 20 53 45 2c 20 32 39 2d 4f on'.; SE, 29-O
0dd0: 63 74 2d 32 30 30 34 3a 20 32 6e 64 20 72 65 64 ct-2004: 2nd red
0de0: 65 73 69 67 6e 3a 20 68 69 67 68 65 72 20 6f 72 esign: higher or
0df0: 64 65 72 20 72 65 76 65 72 73 65 2f 6d 61 70 2f der reverse/map/
0e00: 72 65 66 69 6e 65 2f 75 6e 69 74 65 0a 3b 20 20 refine/unite.;
0e10: 20 53 45 2c 20 20 32 2d 4e 6f 76 2d 32 30 30 34 SE, 2-Nov-2004
0e20: 3a 20 33 72 64 20 72 65 64 65 73 69 67 6e 3a 20 : 3rd redesign:
0e30: 6d 61 63 72 6f 73 20 63 6f 6e 64 2f 72 65 66 69 macros cond/refi
0e40: 6e 65 2d 63 6f 6d 70 61 72 65 20 72 65 70 6c 61 ne-compare repla
0e50: 63 65 20 68 2e 6f 2e 66 27 73 0a 3b 20 20 20 53 ce h.o.f's.; S
0e60: 45 2c 20 31 30 2d 4e 6f 76 2d 32 30 30 34 3a 20 E, 10-Nov-2004:
0e70: 28 69 6d 2c 72 65 29 20 72 65 70 6c 61 63 65 64 (im,re) replaced
0e80: 20 62 79 20 28 72 65 2c 69 6d 29 20 69 6e 20 63 by (re,im) in c
0e90: 6f 6d 70 6c 65 78 2d 63 6f 6d 70 61 72 65 0a 3b omplex-compare.;
0ea0: 20 20 20 53 45 2c 20 31 31 2d 4e 6f 76 2d 32 30 SE, 11-Nov-20
0eb0: 30 34 3a 20 63 61 73 65 2d 63 6f 6d 70 61 72 65 04: case-compare
0ec0: 20 62 79 20 63 61 73 65 20 28 6e 6f 74 20 62 79 by case (not by
0ed0: 20 63 6f 6e 64 29 3b 20 73 65 6c 65 63 74 2d 63 cond); select-c
0ee0: 6f 6d 70 61 72 65 20 61 64 64 65 64 0a 3b 20 20 ompare added.;
0ef0: 20 53 45 2c 20 31 32 2d 4a 61 6e 2d 32 30 30 35 SE, 12-Jan-2005
0f00: 3a 20 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 : pair-compare-c
0f10: 64 72 0a 3b 20 20 20 53 45 2c 20 31 35 2d 46 65 dr.; SE, 15-Fe
0f20: 62 2d 32 30 30 35 3a 20 73 74 72 69 63 74 65 72 b-2005: stricter
0f30: 20 74 79 70 69 6e 67 20 66 6f 72 20 63 6f 6d 70 typing for comp
0f40: 61 72 65 2d 3c 74 79 70 65 3e 3b 20 70 61 69 72 are-<type>; pair
0f50: 77 69 73 65 2d 6e 6f 74 3d 3f 0a 3b 20 20 20 53 wise-not=?.; S
0f60: 45 2c 20 31 36 2d 46 65 62 2d 32 30 30 35 3a 20 E, 16-Feb-2005:
0f70: 63 61 73 65 2d 63 6f 6d 70 61 72 65 20 2d 3e 20 case-compare ->
0f80: 69 66 2d 63 6f 6d 70 61 72 65 20 2d 3e 20 69 66 if-compare -> if
0f90: 33 3b 20 3c 3f 20 3c 2f 3c 3f 20 63 68 61 69 6e 3; <? </<? chain
0fa0: 3c 3f 20 65 74 63 2e 0a 3b 20 20 20 4a 53 2c 20 <? etc..; JS,
0fb0: 32 34 2d 46 65 62 2d 32 30 30 35 3a 20 73 65 6c 24-Feb-2005: sel
0fc0: 65 63 74 69 6f 6e 2d 63 6f 6d 70 61 72 65 20 61 ection-compare a
0fd0: 64 64 65 64 0a 3b 20 20 20 53 45 2c 20 32 35 2d dded.; SE, 25-
0fe0: 46 65 62 2d 32 30 30 35 3a 20 73 65 6c 65 63 74 Feb-2005: select
0ff0: 69 6f 6e 2d 63 6f 6d 70 61 72 65 20 2d 3e 20 6b ion-compare -> k
1000: 74 68 2d 6c 61 72 67 65 73 74 20 6d 6f 64 69 66 th-largest modif
1010: 69 65 64 3b 20 69 66 3c 3f 20 65 74 63 2e 0a 3b ied; if<? etc..;
1020: 20 20 20 4a 53 2c 20 32 38 2d 46 65 62 2d 32 30 JS, 28-Feb-20
1030: 30 35 3a 20 6b 74 68 2d 6c 61 72 67 65 73 74 20 05: kth-largest
1040: 6d 6f 64 69 66 69 65 64 20 2d 20 69 73 20 22 73 modified - is "s
1050: 74 61 62 6c 65 22 20 6e 6f 77 0a 3b 20 20 20 53 table" now.; S
1060: 45 2c 20 32 38 2d 46 65 62 2d 32 30 30 35 3a 20 E, 28-Feb-2005:
1070: 73 69 6d 70 6c 69 66 69 65 64 20 70 61 69 72 77 simplified pairw
1080: 69 73 65 2d 6e 6f 74 3d 3f 2f 6b 74 68 2d 6c 61 ise-not=?/kth-la
1090: 72 67 65 73 74 3b 20 6d 69 6e 2f 6d 61 78 20 64 rgest; min/max d
10a0: 65 62 75 67 67 65 64 0a 3b 20 20 20 53 45 2c 20 ebugged.; SE,
10b0: 30 37 2d 41 70 72 2d 32 30 30 35 3a 20 63 6f 6d 07-Apr-2005: com
10c0: 70 61 72 65 2d 62 61 73 65 64 20 74 79 70 65 20 pare-based type
10d0: 63 68 65 63 6b 73 20 6d 61 64 65 20 65 78 70 6c checks made expl
10e0: 69 63 69 74 0a 3b 20 20 20 53 45 2c 20 31 38 2d icit.; SE, 18-
10f0: 41 70 72 2d 32 30 30 35 3a 20 61 64 64 65 64 20 Apr-2005: added
1100: 28 72 65 6c 3f 20 63 6f 6d 70 61 72 65 29 20 61 (rel? compare) a
1110: 6e 64 20 65 71 3f 2d 74 65 73 74 0a 3b 20 20 20 nd eq?-test.;
1120: 53 45 2c 20 31 36 2d 4d 61 79 2d 32 30 30 35 3a SE, 16-May-2005:
1130: 20 6e 61 6d 69 6e 67 20 63 6f 6e 76 65 6e 74 69 naming conventi
1140: 6f 6e 20 63 68 61 6e 67 65 64 3b 20 63 6f 6d 70 on changed; comp
1150: 61 72 65 2d 62 79 3c 20 65 74 63 2e 20 6f 70 74 are-by< etc. opt
1160: 69 6f 6e 61 6c 20 78 20 79 0a 0a 3b 20 3d 3d 3d ional x y..; ===
1170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 20 52 65 ==========..; Re
11c0: 66 65 72 65 6e 63 65 20 49 6d 70 6c 65 6d 65 6e ference Implemen
11d0: 74 61 74 69 6f 6e 0a 3b 20 3d 3d 3d 3d 3d 3d 3d tation.; =======
11e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f0: 3d 0a 3b 0a 3b 20 69 6e 20 52 35 52 53 20 28 69 =.;.; in R5RS (i
1200: 6e 63 6c 75 64 69 6e 67 20 68 79 67 69 65 6e 69 ncluding hygieni
1210: 63 20 6d 61 63 72 6f 73 29 0a 3b 20 20 2b 20 53 c macros).; + S
1220: 52 46 49 2d 31 36 20 28 63 61 73 65 2d 6c 61 6d RFI-16 (case-lam
1230: 62 64 61 29 20 0a 3b 20 20 2b 20 53 52 46 49 2d bda) .; + SRFI-
1240: 32 33 20 28 65 72 72 6f 72 29 20 0a 3b 20 20 2b 23 (error) .; +
1250: 20 53 52 46 49 2d 32 37 20 28 72 61 6e 64 6f 6d SRFI-27 (random
1260: 2d 69 6e 74 65 67 65 72 29 0a 0a 3b 20 49 6d 70 -integer)..; Imp
1270: 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 72 65 6d 61 lementation rema
1280: 72 6b 73 3a 0a 3b 20 20 20 2a 20 49 6e 20 67 65 rks:.; * In ge
1290: 6e 65 72 61 6c 2c 20 74 68 65 20 65 6d 70 68 61 neral, the empha
12a0: 73 69 73 20 6f 66 20 74 68 69 73 20 69 6d 70 6c sis of this impl
12b0: 65 6d 65 6e 74 61 74 69 6f 6e 20 69 73 20 6f 6e ementation is on
12c0: 20 63 6f 72 72 65 63 74 6e 65 73 73 0a 3b 20 20 correctness.;
12d0: 20 20 20 61 6e 64 20 70 6f 72 74 61 62 69 6c 69 and portabili
12e0: 74 79 2c 20 6e 6f 74 20 6f 6e 20 65 66 66 69 63 ty, not on effic
12f0: 69 65 6e 63 79 2e 0a 3b 20 20 20 2a 20 56 61 72 iency..; * Var
1300: 69 61 62 6c 65 20 61 72 69 74 79 20 70 72 6f 63 iable arity proc
1310: 65 64 75 72 65 73 20 61 72 65 20 65 78 70 72 65 edures are expre
1320: 73 73 65 64 20 69 6e 20 74 65 72 6d 73 20 6f 66 ssed in terms of
1330: 20 63 61 73 65 2d 6c 61 6d 62 64 61 0a 3b 20 20 case-lambda.;
1340: 20 20 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 in the hope t
1350: 68 61 74 20 74 68 69 73 20 77 69 6c 6c 20 70 72 hat this will pr
1360: 6f 64 75 63 65 20 65 66 66 69 63 69 65 6e 74 20 oduce efficient
1370: 63 6f 64 65 20 66 6f 72 20 74 68 65 20 63 61 73 code for the cas
1380: 65 0a 3b 20 20 20 20 20 77 68 65 72 65 20 74 68 e.; where th
1390: 65 20 61 72 69 74 79 20 69 73 20 73 74 61 74 69 e arity is stati
13a0: 63 61 6c 6c 79 20 6b 6e 6f 77 6e 20 61 74 20 74 cally known at t
13b0: 68 65 20 63 61 6c 6c 20 73 69 74 65 2e 0a 3b 20 he call site..;
13c0: 20 20 2a 20 49 6e 20 70 72 6f 63 65 64 75 72 65 * In procedure
13d0: 73 20 74 68 61 74 20 61 72 65 20 72 65 71 75 69 s that are requi
13e0: 72 65 64 20 74 6f 20 74 79 70 65 2d 63 68 65 63 red to type-chec
13f0: 6b 20 74 68 65 69 72 20 61 72 67 75 6d 65 6e 74 k their argument
1400: 73 2c 0a 3b 20 20 20 20 20 77 65 20 75 73 65 20 s,.; we use
1410: 28 63 6f 6d 70 61 72 65 20 78 20 78 29 20 66 6f (compare x x) fo
1420: 72 20 65 78 65 63 75 74 69 6e 67 20 65 78 74 72 r executing extr
1430: 61 20 63 68 65 63 6b 73 2e 20 54 68 69 73 20 72 a checks. This r
1440: 65 6c 69 65 73 20 6f 6e 0a 3b 20 20 20 20 20 74 elies on.; t
1450: 68 65 20 61 73 73 75 6d 70 74 69 6f 6e 20 74 68 he assumption th
1460: 61 74 20 65 71 3f 20 69 73 20 75 73 65 64 20 74 at eq? is used t
1470: 6f 20 63 61 74 63 68 20 74 68 69 73 20 63 61 73 o catch this cas
1480: 65 20 71 75 69 63 6b 6c 79 2e 0a 3b 20 20 20 2a e quickly..; *
1490: 20 43 61 72 65 20 68 61 73 20 62 65 65 6e 20 74 Care has been t
14a0: 61 6b 65 6e 20 74 6f 20 72 65 66 65 72 65 6e 63 aken to referenc
14b0: 65 20 63 6f 6d 70 61 72 69 73 6f 6e 20 70 72 6f e comparison pro
14c0: 63 65 64 75 72 65 73 20 6f 66 20 52 35 52 53 0a cedures of R5RS.
14d0: 3b 20 20 20 20 20 6f 6e 6c 79 20 61 74 20 74 68 ; only at th
14e0: 65 20 74 69 6d 65 20 74 68 65 20 6f 70 65 72 61 e time the opera
14f0: 74 69 6f 6e 73 20 68 65 72 65 20 61 72 65 20 62 tions here are b
1500: 65 69 6e 67 20 64 65 66 69 6e 65 64 2e 20 54 68 eing defined. Th
1510: 69 73 0a 3b 20 20 20 20 20 6d 61 6b 65 73 20 69 is.; makes i
1520: 74 20 70 6f 73 73 69 62 6c 65 20 74 6f 20 72 65 t possible to re
1530: 64 65 66 69 6e 65 20 74 68 65 73 65 20 6f 70 65 define these ope
1540: 72 61 74 69 6f 6e 73 2c 20 69 66 20 6e 65 65 64 rations, if need
1550: 20 62 65 2e 0a 3b 20 20 20 2a 20 46 6f 72 20 74 be..; * For t
1560: 68 65 20 73 61 6b 65 20 6f 66 20 65 66 66 69 63 he sake of effic
1570: 69 65 6e 63 79 2c 20 73 6f 6d 65 20 69 6e 6c 69 iency, some inli
1580: 6e 69 6e 67 20 68 61 73 20 62 65 65 6e 20 64 6f ning has been do
1590: 6e 65 20 62 79 20 68 61 6e 64 2e 0a 3b 20 20 20 ne by hand..;
15a0: 20 20 54 68 69 73 20 69 73 20 6d 61 69 6e 6c 79 This is mainly
15b0: 20 65 78 70 72 65 73 73 65 64 20 62 79 20 6d 61 expressed by ma
15c0: 63 72 6f 73 20 70 72 6f 64 75 63 69 6e 67 20 64 cros producing d
15d0: 65 66 69 6e 65 73 2e 0a 3b 20 20 20 2a 20 49 64 efines..; * Id
15e0: 65 6e 74 69 66 69 65 72 73 20 6f 66 20 74 68 65 entifiers of the
15f0: 20 66 6f 72 6d 20 63 6f 6d 70 61 72 65 3a 3c 73 form compare:<s
1600: 6f 6d 65 74 68 69 6e 67 3e 20 61 72 65 20 70 72 omething> are pr
1610: 69 76 61 74 65 2e 0a 3b 0a 3b 20 48 69 6e 74 73 ivate..;.; Hints
1620: 20 66 6f 72 20 6c 6f 77 2d 6c 65 76 65 6c 20 69 for low-level i
1630: 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 3a 0a 3b mplementation:.;
1640: 20 20 20 2a 20 54 68 65 20 62 61 73 69 73 20 6f * The basis o
1650: 66 20 74 68 69 73 20 53 52 46 49 20 61 72 65 20 f this SRFI are
1660: 74 68 65 20 61 74 6f 6d 69 63 20 63 6f 6d 70 61 the atomic compa
1670: 72 65 20 70 72 6f 63 65 64 75 72 65 73 2c 20 0a re procedures, .
1680: 3b 20 20 20 20 20 69 2e 65 2e 20 62 6f 6f 6c 65 ; i.e. boole
1690: 61 6e 2d 63 6f 6d 70 61 72 65 2c 20 63 68 61 72 an-compare, char
16a0: 2d 63 6f 6d 70 61 72 65 2c 20 65 74 63 2e 20 61 -compare, etc. a
16b0: 6e 64 20 74 68 65 20 63 6f 6e 64 69 74 69 6f 6e nd the condition
16c0: 61 6c 73 0a 3b 20 20 20 20 20 69 66 33 2c 20 69 als.; if3, i
16d0: 66 3d 3f 2c 20 69 66 3c 3f 20 65 74 63 2e 2c 20 f=?, if<? etc.,
16e0: 61 6e 64 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 and default-comp
16f0: 61 72 65 2e 20 54 68 65 73 65 20 73 68 6f 75 6c are. These shoul
1700: 64 20 6d 61 6b 65 0a 3b 20 20 20 20 20 6f 70 74 d make.; opt
1710: 69 6d 61 6c 20 75 73 65 20 6f 66 20 74 68 65 20 imal use of the
1720: 61 76 61 69 6c 61 62 6c 65 20 74 79 70 65 20 69 available type i
1730: 6e 66 6f 72 6d 61 74 69 6f 6e 2e 0a 3b 20 20 20 nformation..;
1740: 2a 20 46 6f 72 20 74 68 65 20 73 61 6b 65 20 6f * For the sake o
1750: 66 20 73 70 65 65 64 2c 20 74 68 65 20 72 65 66 f speed, the ref
1760: 65 72 65 6e 63 65 20 69 6d 70 6c 65 6d 65 6e 74 erence implement
1770: 61 74 69 6f 6e 20 64 6f 65 73 20 6e 6f 74 0a 3b ation does not.;
1780: 20 20 20 20 20 75 73 65 20 61 20 4c 45 54 20 74 use a LET t
1790: 6f 20 73 61 76 65 20 74 68 65 20 63 6f 6d 70 61 o save the compa
17a0: 72 69 73 6f 6e 20 76 61 6c 75 65 20 63 20 66 6f rison value c fo
17b0: 72 20 74 68 65 20 45 52 52 4f 52 20 63 61 6c 6c r the ERROR call
17c0: 2e 0a 3b 20 20 20 20 20 54 68 69 73 20 63 61 6e ..; This can
17d0: 20 62 65 20 66 69 78 65 64 20 69 6e 20 61 20 6c be fixed in a l
17e0: 6f 77 2d 6c 65 76 65 6c 20 69 6d 70 6c 65 6d 65 ow-level impleme
17f0: 6e 74 61 74 69 6f 6e 20 61 74 20 6e 6f 20 63 6f ntation at no co
1800: 73 74 2e 0a 3b 20 20 20 2a 20 54 79 70 65 2d 63 st..; * Type-c
1810: 68 65 63 6b 73 20 62 61 73 65 64 20 6f 6e 20 28 hecks based on (
1820: 63 6f 6d 70 61 72 65 20 78 20 78 29 20 61 72 65 compare x x) are
1830: 20 6d 61 64 65 20 65 78 70 6c 69 63 69 74 20 62 made explicit b
1840: 79 20 74 68 65 0a 3b 20 20 20 20 20 65 78 70 72 y the.; expr
1850: 65 73 73 69 6f 6e 20 28 63 6f 6d 70 61 72 65 3a ession (compare:
1860: 63 68 65 63 6b 20 72 65 73 75 6c 74 20 63 6f 6d check result com
1870: 70 61 72 65 20 78 20 2e 2e 2e 29 2e 0a 3b 20 20 pare x ...)..;
1880: 20 2a 20 45 71 3f 20 73 68 6f 75 6c 64 20 20 63 * Eq? should c
1890: 61 6e 20 75 73 65 64 20 74 6f 20 73 70 65 65 64 an used to speed
18a0: 20 75 70 20 62 75 69 6c 74 2d 69 6e 20 63 6f 6d up built-in com
18b0: 70 61 72 65 20 70 72 6f 63 65 64 75 72 65 73 2c pare procedures,
18c0: 0a 3b 20 20 20 20 20 62 75 74 20 69 74 20 63 61 .; but it ca
18d0: 6e 20 6f 6e 6c 79 20 62 65 20 75 73 65 64 20 61 n only be used a
18e0: 66 74 65 72 20 74 79 70 65 2d 63 68 65 63 6b 69 fter type-checki
18f0: 6e 67 20 61 74 20 6c 65 61 73 74 20 6f 6e 65 20 ng at least one
1900: 6f 66 0a 3b 20 20 20 20 20 74 68 65 20 61 72 67 of.; the arg
1910: 75 6d 65 6e 74 73 2e 0a 0a 28 64 65 66 69 6e 65 uments...(define
1920: 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 (compare:checke
1930: 64 20 72 65 73 75 6c 74 20 63 6f 6d 70 61 72 65 d result compare
1940: 20 2e 20 61 72 67 73 29 0a 20 20 28 66 6f 72 2d . args). (for-
1950: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 78 29 each (lambda (x)
1960: 20 28 63 6f 6d 70 61 72 65 20 78 20 78 29 29 20 (compare x x))
1970: 61 72 67 73 29 0a 20 20 72 65 73 75 6c 74 29 0a args). result).
1980: 0a 0a 3b 20 33 2d 73 69 64 65 64 20 63 6f 6e 64 ..; 3-sided cond
1990: 69 74 69 6f 6e 61 6c 0a 0a 28 64 65 66 69 6e 65 itional..(define
19a0: 2d 73 79 6e 74 61 78 20 69 66 33 0a 20 20 28 73 -syntax if3. (s
19b0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
19c0: 20 20 20 28 28 69 66 33 20 63 20 6c 65 73 73 20 ((if3 c less
19d0: 65 71 75 61 6c 20 67 72 65 61 74 65 72 29 0a 20 equal greater).
19e0: 20 20 20 20 28 63 61 73 65 20 63 0a 20 20 20 20 (case c.
19f0: 20 20 20 28 28 2d 31 29 20 6c 65 73 73 29 0a 20 ((-1) less).
1a00: 20 20 20 20 20 20 28 28 20 30 29 20 65 71 75 61 (( 0) equa
1a10: 6c 29 0a 20 20 20 20 20 20 20 28 28 20 31 29 20 l). (( 1)
1a20: 67 72 65 61 74 65 72 29 0a 20 20 20 20 20 20 20 greater).
1a30: 28 65 6c 73 65 20 28 65 72 72 6f 72 20 22 63 6f (else (error "co
1a40: 6d 70 61 72 69 73 6f 6e 20 76 61 6c 75 65 20 6e mparison value n
1a50: 6f 74 20 69 6e 20 7b 2d 31 2c 30 2c 31 7d 22 29 ot in {-1,0,1}")
1a60: 29 29 29 29 29 0a 0a 0a 3b 20 32 2d 73 69 64 65 )))))...; 2-side
1a70: 64 20 63 6f 6e 64 69 74 69 6f 6e 61 6c 73 20 66 d conditionals f
1a80: 6f 72 20 63 6f 6d 70 61 72 69 73 6f 6e 73 0a 0a or comparisons..
1a90: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 63 (define-syntax c
1aa0: 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f 0a 20 ompare:if-rel?.
1ab0: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
1ac0: 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a ). ((compare:
1ad0: 69 66 2d 72 65 6c 3f 20 63 2d 63 61 73 65 73 20 if-rel? c-cases
1ae0: 61 2d 63 61 73 65 73 20 63 20 63 6f 6e 73 65 71 a-cases c conseq
1af0: 75 65 6e 63 65 29 0a 20 20 20 20 20 28 63 6f 6d uence). (com
1b00: 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 63 2d 63 pare:if-rel? c-c
1b10: 61 73 65 73 20 61 2d 63 61 73 65 73 20 63 20 63 ases a-cases c c
1b20: 6f 6e 73 65 71 75 65 6e 63 65 20 28 69 66 20 23 onsequence (if #
1b30: 66 20 23 66 29 29 29 0a 20 20 20 20 28 28 63 6f f #f))). ((co
1b40: 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 63 2d mpare:if-rel? c-
1b50: 63 61 73 65 73 20 61 2d 63 61 73 65 73 20 63 20 cases a-cases c
1b60: 63 6f 6e 73 65 71 75 65 6e 63 65 20 61 6c 74 65 consequence alte
1b70: 72 6e 61 74 65 29 0a 20 20 20 20 20 28 63 61 73 rnate). (cas
1b80: 65 20 63 0a 20 20 20 20 20 20 20 28 63 2d 63 61 e c. (c-ca
1b90: 73 65 73 20 63 6f 6e 73 65 71 75 65 6e 63 65 29 ses consequence)
1ba0: 0a 20 20 20 20 20 20 20 28 61 2d 63 61 73 65 73 . (a-cases
1bb0: 20 61 6c 74 65 72 6e 61 74 65 29 0a 20 20 20 20 alternate).
1bc0: 20 20 20 28 65 6c 73 65 20 20 20 20 28 65 72 72 (else (err
1bd0: 6f 72 20 22 63 6f 6d 70 61 72 69 73 6f 6e 20 76 or "comparison v
1be0: 61 6c 75 65 20 6e 6f 74 20 69 6e 20 7b 2d 31 2c alue not in {-1,
1bf0: 30 2c 31 7d 22 29 29 29 29 29 29 0a 0a 28 64 65 0,1}"))))))..(de
1c00: 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 3d 3f fine-syntax if=?
1c10: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
1c20: 20 28 29 0a 20 20 20 20 28 28 69 66 3d 3f 20 61 (). ((if=? a
1c30: 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f rg ...). (co
1c40: 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 28 30 mpare:if-rel? (0
1c50: 29 20 28 2d 31 20 31 29 20 61 72 67 20 2e 2e 2e ) (-1 1) arg ...
1c60: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ))))..(define-sy
1c70: 6e 74 61 78 20 69 66 3c 3f 0a 20 20 28 73 79 6e ntax if<?. (syn
1c80: 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 tax-rules ().
1c90: 20 28 28 69 66 3c 3f 20 61 72 67 20 2e 2e 2e 29 ((if<? arg ...)
1ca0: 0a 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 69 . (compare:i
1cb0: 66 2d 72 65 6c 3f 20 28 2d 31 29 20 28 30 20 31 f-rel? (-1) (0 1
1cc0: 29 20 61 72 67 20 2e 2e 2e 29 29 29 29 0a 0a 28 ) arg ...))))..(
1cd0: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 define-syntax if
1ce0: 3e 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c >?. (syntax-rul
1cf0: 65 73 20 28 29 0a 20 20 20 20 28 28 69 66 3e 3f es (). ((if>?
1d00: 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 arg ...). (
1d10: 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 compare:if-rel?
1d20: 28 31 29 20 28 2d 31 20 30 29 20 61 72 67 20 2e (1) (-1 0) arg .
1d30: 2e 2e 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d ..))))..(define-
1d40: 73 79 6e 74 61 78 20 69 66 3c 3d 3f 0a 20 20 28 syntax if<=?. (
1d50: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules ().
1d60: 20 20 20 20 28 28 69 66 3c 3d 3f 20 61 72 67 20 ((if<=? arg
1d70: 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 ...). (compa
1d80: 72 65 3a 69 66 2d 72 65 6c 3f 20 28 2d 31 20 30 re:if-rel? (-1 0
1d90: 29 20 28 31 29 20 61 72 67 20 2e 2e 2e 29 29 29 ) (1) arg ...)))
1da0: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta
1db0: 78 20 69 66 3e 3d 3f 0a 20 20 28 73 79 6e 74 61 x if>=?. (synta
1dc0: 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 x-rules (). (
1dd0: 28 69 66 3e 3d 3f 20 61 72 67 20 2e 2e 2e 29 0a (if>=? arg ...).
1de0: 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 69 66 (compare:if
1df0: 2d 72 65 6c 3f 20 28 30 20 31 29 20 28 2d 31 29 -rel? (0 1) (-1)
1e00: 20 61 72 67 20 2e 2e 2e 29 29 29 29 0a 0a 28 64 arg ...))))..(d
1e10: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 2d efine-syntax if-
1e20: 6e 6f 74 3d 3f 0a 20 20 28 73 79 6e 74 61 78 2d not=?. (syntax-
1e30: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 69 rules (). ((i
1e40: 66 2d 6e 6f 74 3d 3f 20 61 72 67 20 2e 2e 2e 29 f-not=? arg ...)
1e50: 0a 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 69 . (compare:i
1e60: 66 2d 72 65 6c 3f 20 28 2d 31 20 31 29 20 28 30 f-rel? (-1 1) (0
1e70: 29 20 61 72 67 20 2e 2e 2e 29 29 29 29 0a 0a 0a ) arg ...))))...
1e80: 3b 20 70 72 65 64 69 63 61 74 65 73 20 66 72 6f ; predicates fro
1e90: 6d 20 63 6f 6d 70 61 72 65 20 70 72 6f 63 65 64 m compare proced
1ea0: 75 72 65 73 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ures..(define-sy
1eb0: 6e 74 61 78 20 63 6f 6d 70 61 72 65 3a 64 65 66 ntax compare:def
1ec0: 69 6e 65 2d 72 65 6c 3f 0a 20 20 28 73 79 6e 74 ine-rel?. (synt
1ed0: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
1ee0: 28 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 ((compare:define
1ef0: 2d 72 65 6c 3f 20 72 65 6c 3f 20 69 66 2d 72 65 -rel? rel? if-re
1f00: 6c 3f 29 0a 20 20 20 20 20 28 64 65 66 69 6e 65 l?). (define
1f10: 20 72 65 6c 3f 0a 20 20 20 20 20 20 20 28 63 61 rel?. (ca
1f20: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 20 se-lambda.
1f30: 20 20 20 28 28 29 20 20 20 20 20 20 20 20 28 6c (() (l
1f40: 61 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 2d ambda (x y) (if-
1f50: 72 65 6c 3f 20 28 64 65 66 61 75 6c 74 2d 63 6f rel? (default-co
1f60: 6d 70 61 72 65 20 78 20 79 29 20 23 74 20 23 66 mpare x y) #t #f
1f70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 63 ))). ((c
1f80: 6f 6d 70 61 72 65 29 20 28 6c 61 6d 62 64 61 20 ompare) (lambda
1f90: 28 78 20 79 29 20 28 69 66 2d 72 65 6c 3f 20 28 (x y) (if-rel? (
1fa0: 63 6f 6d 70 61 72 65 20 20 20 20 20 20 20 20 20 compare
1fb0: 78 20 79 29 20 23 74 20 23 66 29 29 29 0a 20 20 x y) #t #f))).
1fc0: 20 20 20 20 20 20 20 28 28 78 20 79 29 20 20 20 ((x y)
1fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fe0: 28 69 66 2d 72 65 6c 3f 20 28 64 65 66 61 75 6c (if-rel? (defaul
1ff0: 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 20 23 t-compare x y) #
2000: 74 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 t #f)).
2010: 28 28 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 ((compare x y).
2020: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 72 (if (pr
2030: 6f 63 65 64 75 72 65 3f 20 63 6f 6d 70 61 72 65 ocedure? compare
2040: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2050: 28 69 66 2d 72 65 6c 3f 20 28 63 6f 6d 70 61 72 (if-rel? (compar
2060: 65 20 78 20 79 29 20 23 74 20 23 66 29 0a 20 20 e x y) #t #f).
2070: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
2080: 6f 72 20 22 6e 6f 74 20 61 20 70 72 6f 63 65 64 or "not a proced
2090: 75 72 65 20 28 44 69 64 20 79 6f 75 20 6d 65 61 ure (Did you mea
20a0: 6e 20 72 65 6c 2f 72 65 6c 3f 3f 29 3a 20 22 20 n rel/rel??): "
20b0: 63 6f 6d 70 61 72 65 29 29 29 29 29 29 29 29 0a compare)))))))).
20c0: 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 .(compare:define
20d0: 2d 72 65 6c 3f 20 3d 3f 20 20 20 20 69 66 3d 3f -rel? =? if=?
20e0: 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e ).(compare:defin
20f0: 65 2d 72 65 6c 3f 20 3c 3f 20 20 20 20 69 66 3c e-rel? <? if<
2100: 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 ?).(compare:defi
2110: 6e 65 2d 72 65 6c 3f 20 3e 3f 20 20 20 20 69 66 ne-rel? >? if
2120: 3e 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 >?).(compare:def
2130: 69 6e 65 2d 72 65 6c 3f 20 3c 3d 3f 20 20 20 69 ine-rel? <=? i
2140: 66 3c 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 f<=?).(compare:d
2150: 65 66 69 6e 65 2d 72 65 6c 3f 20 3e 3d 3f 20 20 efine-rel? >=?
2160: 20 69 66 3e 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 if>=?).(compare
2170: 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 20 6e 6f 74 :define-rel? not
2180: 3d 3f 20 69 66 2d 6e 6f 74 3d 3f 29 0a 0a 0a 3b =? if-not=?)...;
2190: 20 63 68 61 69 6e 73 20 6f 66 20 6c 65 6e 67 74 chains of lengt
21a0: 68 20 33 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e h 3..(define-syn
21b0: 74 61 78 20 63 6f 6d 70 61 72 65 3a 64 65 66 69 tax compare:defi
21c0: 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 0a 20 20 ne-rel1/rel2?.
21d0: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 (syntax-rules ()
21e0: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a 64 . ((compare:d
21f0: 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f efine-rel1/rel2?
2200: 20 72 65 6c 31 2f 72 65 6c 32 3f 20 69 66 2d 72 rel1/rel2? if-r
2210: 65 6c 31 3f 20 69 66 2d 72 65 6c 32 3f 29 0a 20 el1? if-rel2?).
2220: 20 20 20 20 28 64 65 66 69 6e 65 20 72 65 6c 31 (define rel1
2230: 2f 72 65 6c 32 3f 0a 20 20 20 20 20 20 20 28 63 /rel2?. (c
2240: 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 ase-lambda.
2250: 20 20 20 20 28 28 29 0a 20 20 20 20 20 20 20 20 (().
2260: 20 20 28 6c 61 6d 62 64 61 20 28 78 20 79 20 7a (lambda (x y z
2270: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
2280: 66 2d 72 65 6c 31 3f 20 28 64 65 66 61 75 6c 74 f-rel1? (default
2290: 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 -compare x y).
22a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22b0: 20 20 20 20 28 69 66 2d 72 65 6c 32 3f 20 28 64 (if-rel2? (d
22c0: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 79 efault-compare y
22d0: 20 7a 29 20 23 74 20 23 66 29 0a 20 20 20 20 20 z) #t #f).
22e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22f0: 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 (compare:checke
2300: 64 20 23 66 20 64 65 66 61 75 6c 74 2d 63 6f 6d d #f default-com
2310: 70 61 72 65 20 7a 29 29 29 29 0a 20 20 20 20 20 pare z)))).
2320: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 29 0a 20 ((compare).
2330: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
2340: 20 28 78 20 79 20 7a 29 0a 20 20 20 20 20 20 20 (x y z).
2350: 20 20 20 20 20 28 69 66 2d 72 65 6c 31 3f 20 28 (if-rel1? (
2360: 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 20 compare x y).
2370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2380: 20 20 20 28 69 66 2d 72 65 6c 32 3f 20 28 63 6f (if-rel2? (co
2390: 6d 70 61 72 65 20 79 20 7a 29 20 23 74 20 23 66 mpare y z) #t #f
23a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
23b0: 20 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 (compare
23c0: 3a 63 68 65 63 6b 65 64 20 23 66 20 63 6f 6d 70 :checked #f comp
23d0: 61 72 65 20 7a 29 29 29 29 0a 20 20 20 20 20 20 are z)))).
23e0: 20 20 20 28 28 78 20 79 20 7a 29 0a 20 20 20 20 ((x y z).
23f0: 20 20 20 20 20 20 28 69 66 2d 72 65 6c 31 3f 20 (if-rel1?
2400: 28 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 (default-compare
2410: 20 78 20 79 29 0a 20 20 20 20 20 20 20 20 20 20 x y).
2420: 20 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 (if-re
2430: 6c 32 3f 20 28 64 65 66 61 75 6c 74 2d 63 6f 6d l2? (default-com
2440: 70 61 72 65 20 79 20 7a 29 20 23 74 20 23 66 29 pare y z) #t #f)
2450: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2460: 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 (compare:ch
2470: 65 63 6b 65 64 20 23 66 20 64 65 66 61 75 6c 74 ecked #f default
2480: 2d 63 6f 6d 70 61 72 65 20 7a 29 29 29 0a 20 20 -compare z))).
2490: 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 ((compare
24a0: 20 78 20 79 20 7a 29 0a 20 20 20 20 20 20 20 20 x y z).
24b0: 20 20 28 69 66 2d 72 65 6c 31 3f 20 28 63 6f 6d (if-rel1? (com
24c0: 70 61 72 65 20 78 20 79 29 0a 20 20 20 20 20 20 pare x y).
24d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
24e0: 66 2d 72 65 6c 32 3f 20 28 63 6f 6d 70 61 72 65 f-rel2? (compare
24f0: 20 79 20 7a 29 20 23 74 20 23 66 29 0a 20 20 20 y z) #t #f).
2500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2510: 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 (compare:checke
2520: 64 20 23 66 20 63 6f 6d 70 61 72 65 20 7a 29 29 d #f compare z))
2530: 29 29 29 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 ))))))..(compare
2540: 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c :define-rel1/rel
2550: 32 3f 20 3c 2f 3c 3f 20 20 20 69 66 3c 3f 20 20 2? </<? if<?
2560: 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 if<?).(compare:d
2570: 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f efine-rel1/rel2?
2580: 20 3c 2f 3c 3d 3f 20 20 69 66 3c 3f 20 20 69 66 </<=? if<? if
2590: 3c 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 <=?).(compare:de
25a0: 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 fine-rel1/rel2?
25b0: 3c 3d 2f 3c 3f 20 20 69 66 3c 3d 3f 20 69 66 3c <=/<? if<=? if<
25c0: 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 ?).(compare:defi
25d0: 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 3c 3d ne-rel1/rel2? <=
25e0: 2f 3c 3d 3f 20 69 66 3c 3d 3f 20 69 66 3c 3d 3f /<=? if<=? if<=?
25f0: 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e ).(compare:defin
2600: 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 3e 2f 3e e-rel1/rel2? >/>
2610: 3f 20 20 20 69 66 3e 3f 20 20 69 66 3e 3f 29 0a ? if>? if>?).
2620: 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d (compare:define-
2630: 72 65 6c 31 2f 72 65 6c 32 3f 20 3e 2f 3e 3d 3f rel1/rel2? >/>=?
2640: 20 20 69 66 3e 3f 20 20 69 66 3e 3d 3f 29 0a 28 if>? if>=?).(
2650: 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 compare:define-r
2660: 65 6c 31 2f 72 65 6c 32 3f 20 3e 3d 2f 3e 3f 20 el1/rel2? >=/>?
2670: 20 69 66 3e 3d 3f 20 69 66 3e 3f 29 0a 28 63 6f if>=? if>?).(co
2680: 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c mpare:define-rel
2690: 31 2f 72 65 6c 32 3f 20 3e 3d 2f 3e 3d 3f 20 69 1/rel2? >=/>=? i
26a0: 66 3e 3d 3f 20 69 66 3e 3d 3f 29 0a 0a 0a 3b 20 f>=? if>=?)...;
26b0: 63 68 61 69 6e 73 20 6f 66 20 61 72 62 69 74 72 chains of arbitr
26c0: 61 72 79 20 6c 65 6e 67 74 68 0a 0a 28 64 65 66 ary length..(def
26d0: 69 6e 65 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 ine-syntax compa
26e0: 72 65 3a 64 65 66 69 6e 65 2d 63 68 61 69 6e 2d re:define-chain-
26f0: 72 65 6c 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 rel?. (syntax-r
2700: 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 63 6f ules (). ((co
2710: 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 63 68 61 mpare:define-cha
2720: 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e 2d 72 65 in-rel? chain-re
2730: 6c 3f 20 69 66 2d 72 65 6c 3f 29 0a 20 20 20 20 l? if-rel?).
2740: 20 28 64 65 66 69 6e 65 20 63 68 61 69 6e 2d 72 (define chain-r
2750: 65 6c 3f 0a 20 20 20 20 20 20 20 28 63 61 73 65 el?. (case
2760: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 20 20 20 -lambda.
2770: 20 28 28 63 6f 6d 70 61 72 65 29 0a 20 20 20 20 ((compare).
2780: 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 #t).
2790: 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 29 ((compare x1)
27a0: 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 . (comp
27b0: 61 72 65 3a 63 68 65 63 6b 65 64 20 23 74 20 63 are:checked #t c
27c0: 6f 6d 70 61 72 65 20 78 31 29 29 0a 20 20 20 20 ompare x1)).
27d0: 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 ((compare x
27e0: 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 1 x2).
27f0: 28 69 66 2d 72 65 6c 3f 20 28 63 6f 6d 70 61 72 (if-rel? (compar
2800: 65 20 78 31 20 78 32 29 20 23 74 20 23 66 29 29 e x1 x2) #t #f))
2810: 0a 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 . ((comp
2820: 61 72 65 20 78 31 20 78 32 20 78 33 29 0a 20 20 are x1 x2 x3).
2830: 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c 3f (if-rel?
2840: 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 (compare x1 x2)
2850: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2860: 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 63 6f (if-rel? (co
2870: 6d 70 61 72 65 20 78 32 20 78 33 29 20 23 74 20 mpare x2 x3) #t
2880: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f).
2890: 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a (compare:
28a0: 63 68 65 63 6b 65 64 20 23 66 20 63 6f 6d 70 61 checked #f compa
28b0: 72 65 20 78 33 29 29 29 0a 20 20 20 20 20 20 20 re x3))).
28c0: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 ((compare x1 x
28d0: 32 20 2e 20 78 33 2b 29 0a 20 20 20 20 20 20 20 2 . x3+).
28e0: 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 63 6f 6d (if-rel? (com
28f0: 70 61 72 65 20 78 31 20 78 32 29 0a 20 20 20 20 pare x1 x2).
2900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2910: 6c 65 74 20 63 68 61 69 6e 3f 20 28 28 68 65 61 let chain? ((hea
2920: 64 20 78 32 29 20 28 74 61 69 6c 20 78 33 2b 29 d x2) (tail x3+)
2930: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2940: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
2950: 3f 20 74 61 69 6c 29 0a 20 20 20 20 20 20 20 20 ? tail).
2960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2970: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t.
2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
2990: 2d 72 65 6c 3f 20 28 63 6f 6d 70 61 72 65 20 68 -rel? (compare h
29a0: 65 61 64 20 28 63 61 72 20 74 61 69 6c 29 29 0a ead (car tail)).
29b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29d0: 20 20 28 63 68 61 69 6e 3f 20 28 63 61 72 20 74 (chain? (car t
29e0: 61 69 6c 29 20 28 63 64 72 20 74 61 69 6c 29 29 ail) (cdr tail))
29f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a10: 20 20 20 28 61 70 70 6c 79 20 63 6f 6d 70 61 72 (apply compar
2a20: 65 3a 63 68 65 63 6b 65 64 20 23 66 20 0a 20 20 e:checked #f .
2a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a50: 20 20 20 20 20 20 20 63 6f 6d 70 61 72 65 20 28 compare (
2a60: 63 64 72 20 74 61 69 6c 29 29 29 29 29 0a 20 20 cdr tail))))).
2a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a80: 20 28 61 70 70 6c 79 20 63 6f 6d 70 61 72 65 3a (apply compare:
2a90: 63 68 65 63 6b 65 64 20 23 66 20 63 6f 6d 70 61 checked #f compa
2aa0: 72 65 20 78 33 2b 29 29 29 29 29 29 29 29 0a 0a re x3+))))))))..
2ab0: 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d (compare:define-
2ac0: 63 68 61 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e chain-rel? chain
2ad0: 3d 3f 20 20 69 66 3d 3f 29 0a 28 63 6f 6d 70 61 =? if=?).(compa
2ae0: 72 65 3a 64 65 66 69 6e 65 2d 63 68 61 69 6e 2d re:define-chain-
2af0: 72 65 6c 3f 20 63 68 61 69 6e 3c 3f 20 20 69 66 rel? chain<? if
2b00: 3c 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 <?).(compare:def
2b10: 69 6e 65 2d 63 68 61 69 6e 2d 72 65 6c 3f 20 63 ine-chain-rel? c
2b20: 68 61 69 6e 3e 3f 20 20 69 66 3e 3f 29 0a 28 63 hain>? if>?).(c
2b30: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 63 68 ompare:define-ch
2b40: 61 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e 3c 3d ain-rel? chain<=
2b50: 3f 20 69 66 3c 3d 3f 29 0a 28 63 6f 6d 70 61 72 ? if<=?).(compar
2b60: 65 3a 64 65 66 69 6e 65 2d 63 68 61 69 6e 2d 72 e:define-chain-r
2b70: 65 6c 3f 20 63 68 61 69 6e 3e 3d 3f 20 69 66 3e el? chain>=? if>
2b80: 3d 3f 29 0a 0a 0a 3b 20 70 61 69 72 77 69 73 65 =?)...; pairwise
2b90: 20 69 6e 65 71 75 61 6c 69 74 79 0a 0a 28 64 65 inequality..(de
2ba0: 66 69 6e 65 20 70 61 69 72 77 69 73 65 2d 6e 6f fine pairwise-no
2bb0: 74 3d 3f 0a 20 20 28 6c 65 74 20 28 28 3d 20 3d t=?. (let ((= =
2bc0: 29 20 28 3c 3d 20 3c 3d 29 29 0a 20 20 20 20 28 ) (<= <=)). (
2bd0: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda.
2be0: 20 20 28 28 63 6f 6d 70 61 72 65 29 0a 20 20 20 ((compare).
2bf0: 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 28 28 #t). ((
2c00: 63 6f 6d 70 61 72 65 20 78 31 29 0a 20 20 20 20 compare x1).
2c10: 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 (compare:chec
2c20: 6b 65 64 20 23 74 20 63 6f 6d 70 61 72 65 20 78 ked #t compare x
2c30: 31 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 1)). ((comp
2c40: 61 72 65 20 78 31 20 78 32 29 0a 20 20 20 20 20 are x1 x2).
2c50: 20 20 28 69 66 2d 6e 6f 74 3d 3f 20 28 63 6f 6d (if-not=? (com
2c60: 70 61 72 65 20 78 31 20 78 32 29 20 23 74 20 23 pare x1 x2) #t #
2c70: 66 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 f)). ((comp
2c80: 61 72 65 20 78 31 20 78 32 20 78 33 29 0a 20 20 are x1 x2 x3).
2c90: 20 20 20 20 20 28 69 66 2d 6e 6f 74 3d 3f 20 28 (if-not=? (
2ca0: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a 20 compare x1 x2).
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 28 69 66 2d 6e 6f 74 3d 3f 20 28 63 6f 6d 70 61 (if-not=? (compa
2cd0: 72 65 20 78 32 20 78 33 29 0a 20 20 20 20 20 20 re x2 x3).
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cf0: 20 20 20 20 20 28 69 66 2d 6e 6f 74 3d 3f 20 28 (if-not=? (
2d00: 63 6f 6d 70 61 72 65 20 78 31 20 78 33 29 20 23 compare x1 x3) #
2d10: 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 t #f).
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d30: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
2d40: 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 (compare:c
2d50: 68 65 63 6b 65 64 20 23 66 20 63 6f 6d 70 61 72 hecked #f compar
2d60: 65 20 78 33 29 29 29 0a 20 20 20 20 20 20 28 28 e x3))). ((
2d70: 63 6f 6d 70 61 72 65 20 2e 20 78 31 2b 29 0a 20 compare . x1+).
2d80: 20 20 20 20 20 20 28 6c 65 74 20 75 6e 65 71 75 (let unequ
2d90: 61 6c 3f 20 28 28 78 20 78 31 2b 29 20 28 6e 20 al? ((x x1+) (n
2da0: 28 6c 65 6e 67 74 68 20 78 31 2b 29 29 20 28 75 (length x1+)) (u
2db0: 6e 63 68 65 63 6b 65 64 3f 20 23 74 29 29 0a 20 nchecked? #t)).
2dc0: 20 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 6e (if (< n
2dd0: 20 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2).
2de0: 20 28 69 66 20 28 61 6e 64 20 75 6e 63 68 65 63 (if (and unchec
2df0: 6b 65 64 3f 20 28 3d 20 6e 20 31 29 29 0a 20 20 ked? (= n 1)).
2e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2e10: 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 compare:checked
2e20: 23 74 20 63 6f 6d 70 61 72 65 20 28 63 61 72 20 #t compare (car
2e30: 78 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x)).
2e40: 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 20 #t).
2e50: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 2d (let* ((i-
2e60: 70 69 76 6f 74 20 28 72 61 6e 64 6f 6d 2d 69 6e pivot (random-in
2e70: 74 65 67 65 72 20 6e 29 29 0a 20 20 20 20 20 20 teger n)).
2e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 78 (x
2e90: 2d 70 69 76 6f 74 20 28 6c 69 73 74 2d 72 65 66 -pivot (list-ref
2ea0: 20 78 20 69 2d 70 69 76 6f 74 29 29 29 0a 20 20 x i-pivot))).
2eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
2ec0: 74 20 73 70 6c 69 74 20 28 28 69 20 30 29 20 28 t split ((i 0) (
2ed0: 78 20 78 29 20 28 78 3c 20 27 28 29 29 20 28 78 x x) (x< '()) (x
2ee0: 3e 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 > '())).
2ef0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
2f00: 6c 6c 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 ll? x).
2f10: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 (and
2f20: 20 28 75 6e 65 71 75 61 6c 3f 20 78 3c 20 28 6c (unequal? x< (l
2f30: 65 6e 67 74 68 20 78 3c 29 20 23 66 29 0a 20 20 ength x<) #f).
2f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f50: 20 20 20 20 20 20 20 20 28 75 6e 65 71 75 61 6c (unequal
2f60: 3f 20 78 3e 20 28 6c 65 6e 67 74 68 20 78 3e 29 ? x> (length x>)
2f70: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
2f80: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
2f90: 3d 20 69 20 69 2d 70 69 76 6f 74 29 0a 20 20 20 = i i-pivot).
2fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fb0: 20 20 20 20 20 20 28 73 70 6c 69 74 20 28 2b 20 (split (+
2fc0: 69 20 31 29 20 28 63 64 72 20 78 29 20 78 3c 20 i 1) (cdr x) x<
2fd0: 78 3e 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x>).
2fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
2ff0: 33 20 28 63 6f 6d 70 61 72 65 20 28 63 61 72 20 3 (compare (car
3000: 78 29 20 78 2d 70 69 76 6f 74 29 0a 20 20 20 20 x) x-pivot).
3010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3020: 20 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 74 (split
3030: 20 28 2b 20 69 20 31 29 20 28 63 64 72 20 78 29 (+ i 1) (cdr x)
3040: 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 20 78 (cons (car x) x
3050: 3c 29 20 78 3e 29 0a 20 20 20 20 20 20 20 20 20 <) x>).
3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3070: 20 20 20 20 20 28 69 66 20 75 6e 63 68 65 63 6b (if uncheck
3080: 65 64 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 ed?.
3090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30a0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 63 6f 6d (apply com
30b0: 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 pare:checked #f
30c0: 63 6f 6d 70 61 72 65 20 28 63 64 72 20 78 29 29 compare (cdr x))
30d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
30e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30f0: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
3100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3110: 20 20 20 20 20 28 73 70 6c 69 74 20 28 2b 20 69 (split (+ i
3120: 20 31 29 20 28 63 64 72 20 78 29 20 78 3c 20 28 1) (cdr x) x< (
3130: 63 6f 6e 73 20 28 63 61 72 20 78 29 20 78 3e 29 cons (car x) x>)
3140: 29 29 29 29 29 29 29 29 29 29 29 29 0a 0a 0a 3b ))))))))))))...;
3150: 20 6d 69 6e 2f 6d 61 78 0a 0a 28 64 65 66 69 6e min/max..(defin
3160: 65 20 6d 69 6e 2d 63 6f 6d 70 61 72 65 0a 20 20 e min-compare.
3170: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda.
3180: 20 28 28 63 6f 6d 70 61 72 65 20 78 31 29 0a 20 ((compare x1).
3190: 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 (compare:che
31a0: 63 6b 65 64 20 78 31 20 63 6f 6d 70 61 72 65 20 cked x1 compare
31b0: 78 31 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 x1)). ((compa
31c0: 72 65 20 78 31 20 78 32 29 0a 20 20 20 20 20 28 re x1 x2). (
31d0: 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if<=? (compare x
31e0: 31 20 78 32 29 20 78 31 20 78 32 29 29 0a 20 20 1 x2) x1 x2)).
31f0: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 ((compare x1 x
3200: 32 20 78 33 29 0a 20 20 20 20 20 28 69 66 3c 3d 2 x3). (if<=
3210: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 ? (compare x1 x2
3220: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
3230: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 f<=? (compare x1
3240: 20 78 33 29 20 78 31 20 78 33 29 0a 20 20 20 20 x3) x1 x3).
3250: 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 (if<=? (
3260: 63 6f 6d 70 61 72 65 20 78 32 20 78 33 29 20 78 compare x2 x3) x
3270: 32 20 78 33 29 29 29 0a 20 20 20 20 28 28 63 6f 2 x3))). ((co
3280: 6d 70 61 72 65 20 78 31 20 78 32 20 78 33 20 78 mpare x1 x2 x3 x
3290: 34 29 0a 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 4). (if<=? (
32a0: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a 20 compare x1 x2).
32b0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d (if<=
32c0: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 33 ? (compare x1 x3
32d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
32e0: 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d (if<=? (com
32f0: 70 61 72 65 20 78 31 20 78 34 29 20 78 31 20 78 pare x1 x4) x1 x
3300: 34 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 4).
3310: 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f (if<=? (co
3320: 6d 70 61 72 65 20 78 33 20 78 34 29 20 78 33 20 mpare x3 x4) x3
3330: 78 34 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x4)).
3340: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
3350: 20 78 32 20 78 33 29 0a 20 20 20 20 20 20 20 20 x2 x3).
3360: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d (if<=
3370: 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 20 78 34 ? (compare x2 x4
3380: 29 20 78 32 20 78 34 29 0a 20 20 20 20 20 20 20 ) x2 x4).
3390: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c (if<
33a0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 33 20 78 =? (compare x3 x
33b0: 34 29 20 78 33 20 78 34 29 29 29 29 0a 20 20 20 4) x3 x4)))).
33c0: 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 ((compare x1 x2
33d0: 20 2e 20 78 33 2b 29 0a 20 20 20 20 20 28 6c 65 . x3+). (le
33e0: 74 20 6d 69 6e 20 28 28 78 6d 69 6e 20 28 69 66 t min ((xmin (if
33f0: 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 <=? (compare x1
3400: 78 32 29 20 78 31 20 78 32 29 29 20 28 78 73 20 x2) x1 x2)) (xs
3410: 78 33 2b 29 29 0a 20 20 20 20 20 20 20 28 69 66 x3+)). (if
3420: 20 28 6e 75 6c 6c 3f 20 78 73 29 0a 20 20 20 20 (null? xs).
3430: 20 20 20 20 20 20 20 78 6d 69 6e 0a 20 20 20 20 xmin.
3440: 20 20 20 20 20 20 20 28 6d 69 6e 20 28 69 66 3c (min (if<
3450: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 6d 69 6e =? (compare xmin
3460: 20 28 63 61 72 20 78 73 29 29 20 78 6d 69 6e 20 (car xs)) xmin
3470: 28 63 61 72 20 78 73 29 29 0a 20 20 20 20 20 20 (car xs)).
3480: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 78 (cdr x
3490: 73 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e s)))))))..(defin
34a0: 65 20 6d 61 78 2d 63 6f 6d 70 61 72 65 0a 20 20 e max-compare.
34b0: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda.
34c0: 20 28 28 63 6f 6d 70 61 72 65 20 78 31 29 0a 20 ((compare x1).
34d0: 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 (compare:che
34e0: 63 6b 65 64 20 78 31 20 63 6f 6d 70 61 72 65 20 cked x1 compare
34f0: 78 31 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 x1)). ((compa
3500: 72 65 20 78 31 20 78 32 29 0a 20 20 20 20 20 28 re x1 x2). (
3510: 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if>=? (compare x
3520: 31 20 78 32 29 20 78 31 20 78 32 29 29 0a 20 20 1 x2) x1 x2)).
3530: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 ((compare x1 x
3540: 32 20 78 33 29 0a 20 20 20 20 20 28 69 66 3e 3d 2 x3). (if>=
3550: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 ? (compare x1 x2
3560: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
3570: 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 f>=? (compare x1
3580: 20 78 33 29 20 78 31 20 78 33 29 0a 20 20 20 20 x3) x1 x3).
3590: 20 20 20 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 (if>=? (
35a0: 63 6f 6d 70 61 72 65 20 78 32 20 78 33 29 20 78 compare x2 x3) x
35b0: 32 20 78 33 29 29 29 0a 20 20 20 20 28 28 63 6f 2 x3))). ((co
35c0: 6d 70 61 72 65 20 78 31 20 78 32 20 78 33 20 78 mpare x1 x2 x3 x
35d0: 34 29 0a 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 4). (if>=? (
35e0: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a 20 compare x1 x2).
35f0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3e 3d (if>=
3600: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 33 ? (compare x1 x3
3610: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3620: 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d (if>=? (com
3630: 70 61 72 65 20 78 31 20 78 34 29 20 78 31 20 78 pare x1 x4) x1 x
3640: 34 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 4).
3650: 20 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 63 6f (if>=? (co
3660: 6d 70 61 72 65 20 78 33 20 78 34 29 20 78 33 20 mpare x3 x4) x3
3670: 78 34 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x4)).
3680: 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 (if>=? (compare
3690: 20 78 32 20 78 33 29 0a 20 20 20 20 20 20 20 20 x2 x3).
36a0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3e 3d (if>=
36b0: 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 20 78 34 ? (compare x2 x4
36c0: 29 20 78 32 20 78 34 29 0a 20 20 20 20 20 20 20 ) x2 x4).
36d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3e (if>
36e0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 33 20 78 =? (compare x3 x
36f0: 34 29 20 78 33 20 78 34 29 29 29 29 0a 20 20 20 4) x3 x4)))).
3700: 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 ((compare x1 x2
3710: 20 2e 20 78 33 2b 29 0a 20 20 20 20 20 28 6c 65 . x3+). (le
3720: 74 20 6d 61 78 20 28 28 78 6d 61 78 20 28 69 66 t max ((xmax (if
3730: 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 >=? (compare x1
3740: 78 32 29 20 78 31 20 78 32 29 29 20 28 78 73 20 x2) x1 x2)) (xs
3750: 78 33 2b 29 29 0a 20 20 20 20 20 20 20 28 69 66 x3+)). (if
3760: 20 28 6e 75 6c 6c 3f 20 78 73 29 0a 20 20 20 20 (null? xs).
3770: 20 20 20 20 20 20 20 78 6d 61 78 0a 20 20 20 20 xmax.
3780: 20 20 20 20 20 20 20 28 6d 61 78 20 28 69 66 3e (max (if>
3790: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 6d 61 78 =? (compare xmax
37a0: 20 28 63 61 72 20 78 73 29 29 20 78 6d 61 78 20 (car xs)) xmax
37b0: 28 63 61 72 20 78 73 29 29 0a 20 20 20 20 20 20 (car xs)).
37c0: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 78 (cdr x
37d0: 73 29 29 29 29 29 29 29 0a 0a 0a 3b 20 6b 74 68 s)))))))...; kth
37e0: 2d 6c 61 72 67 65 73 74 0a 0a 28 64 65 66 69 6e -largest..(defin
37f0: 65 20 6b 74 68 2d 6c 61 72 67 65 73 74 0a 20 20 e kth-largest.
3800: 28 6c 65 74 20 28 28 3d 20 3d 29 20 28 3c 20 3c (let ((= =) (< <
3810: 29 29 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d )). (case-lam
3820: 62 64 61 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 bda. ((comp
3830: 61 72 65 20 6b 20 78 30 29 0a 20 20 20 20 20 20 are k x0).
3840: 20 28 63 61 73 65 20 28 6d 6f 64 75 6c 6f 20 6b (case (modulo k
3850: 20 31 29 0a 20 20 20 20 20 20 20 20 20 28 28 30 1). ((0
3860: 29 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 ) (compare:chec
3870: 6b 65 64 20 78 30 20 63 6f 6d 70 61 72 65 20 78 ked x0 compare x
3880: 30 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 6c 0)). (el
3890: 73 65 20 28 65 72 72 6f 72 20 22 62 61 64 20 69 se (error "bad i
38a0: 6e 64 65 78 22 20 6b 29 29 29 29 0a 20 20 20 20 ndex" k)))).
38b0: 20 20 28 28 63 6f 6d 70 61 72 65 20 6b 20 78 30 ((compare k x0
38c0: 20 78 31 29 0a 20 20 20 20 20 20 20 28 63 61 73 x1). (cas
38d0: 65 20 28 6d 6f 64 75 6c 6f 20 6b 20 32 29 0a 20 e (modulo k 2).
38e0: 20 20 20 20 20 20 20 20 28 28 30 29 20 28 69 66 ((0) (if
38f0: 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 <=? (compare x0
3900: 78 31 29 20 78 30 20 78 31 29 29 0a 20 20 20 20 x1) x0 x1)).
3910: 20 20 20 20 20 28 28 31 29 20 28 69 66 3c 3d 3f ((1) (if<=?
3920: 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 31 29 (compare x0 x1)
3930: 20 78 31 20 78 30 29 29 0a 20 20 20 20 20 20 20 x1 x0)).
3940: 20 20 28 65 6c 73 65 20 28 65 72 72 6f 72 20 22 (else (error "
3950: 62 61 64 20 69 6e 64 65 78 22 20 6b 29 29 29 29 bad index" k))))
3960: 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 . ((compare
3970: 20 6b 20 78 30 20 78 31 20 78 32 29 0a 20 20 20 k x0 x1 x2).
3980: 20 20 20 20 28 63 61 73 65 20 28 6d 6f 64 75 6c (case (modul
3990: 6f 20 6b 20 33 29 0a 20 20 20 20 20 20 20 20 20 o k 3).
39a0: 28 28 30 29 20 28 69 66 3c 3d 3f 20 28 63 6f 6d ((0) (if<=? (com
39b0: 70 61 72 65 20 78 30 20 78 31 29 0a 20 20 20 20 pare x0 x1).
39c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
39d0: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
39e0: 20 78 30 20 78 32 29 20 78 30 20 78 32 29 0a 20 x0 x2) x0 x2).
39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a00: 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 (if<=? (comp
3a10: 61 72 65 20 78 31 20 78 32 29 20 78 31 20 78 32 are x1 x2) x1 x2
3a20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 31 ))). ((1
3a30: 29 20 28 69 66 33 20 28 63 6f 6d 70 61 72 65 20 ) (if3 (compare
3a40: 78 30 20 78 31 29 0a 20 20 20 20 20 20 20 20 20 x0 x1).
3a50: 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f (if<=?
3a60: 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 (compare x1 x2)
3a70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3a80: 20 20 20 20 20 20 20 20 20 20 20 78 31 0a 20 20 x1.
3a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3aa0: 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 (if<=? (
3ab0: 63 6f 6d 70 61 72 65 20 78 30 20 78 32 29 20 78 compare x0 x2) x
3ac0: 32 20 78 30 29 29 0a 20 20 20 20 20 20 20 20 20 2 x0)).
3ad0: 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f (if<=?
3ae0: 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 32 29 (compare x0 x2)
3af0: 20 78 31 20 78 30 29 0a 20 20 20 20 20 20 20 20 x1 x0).
3b00: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d (if<=
3b10: 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 32 ? (compare x0 x2
3b20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3b30: 20 20 20 20 20 20 20 20 20 20 20 20 78 30 0a 20 x0.
3b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b50: 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 (if<=?
3b60: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 20 (compare x1 x2)
3b70: 78 32 20 78 31 29 29 29 29 0a 20 20 20 20 20 20 x2 x1)))).
3b80: 20 20 20 28 28 32 29 20 28 69 66 3c 3d 3f 20 28 ((2) (if<=? (
3b90: 63 6f 6d 70 61 72 65 20 78 30 20 78 31 29 0a 20 compare x0 x1).
3ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bb0: 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 (if<=? (comp
3bc0: 61 72 65 20 78 31 20 78 32 29 20 78 32 20 78 31 are x1 x2) x2 x1
3bd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3be0: 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 (if<=? (c
3bf0: 6f 6d 70 61 72 65 20 78 30 20 78 32 29 20 78 32 ompare x0 x2) x2
3c00: 20 78 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 x0))).
3c10: 28 65 6c 73 65 20 28 65 72 72 6f 72 20 22 62 61 (else (error "ba
3c20: 64 20 69 6e 64 65 78 22 20 6b 29 29 29 29 0a 20 d index" k)))).
3c30: 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 6b ((compare k
3c40: 20 78 30 20 2e 20 78 31 2b 29 20 3b 20 7c 78 31 x0 . x1+) ; |x1
3c50: 2b 7c 20 3e 3d 20 31 0a 20 20 20 20 20 20 20 28 +| >= 1. (
3c60: 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 28 69 6e if (not (and (in
3c70: 74 65 67 65 72 3f 20 6b 29 20 28 65 78 61 63 74 teger? k) (exact
3c80: 3f 20 6b 29 29 29 0a 20 20 20 20 20 20 20 20 20 ? k))).
3c90: 20 20 28 65 72 72 6f 72 20 22 62 61 64 20 69 6e (error "bad in
3ca0: 64 65 78 22 20 6b 29 29 0a 20 20 20 20 20 20 20 dex" k)).
3cb0: 28 6c 65 74 20 28 28 6e 20 28 2b 20 31 20 28 6c (let ((n (+ 1 (l
3cc0: 65 6e 67 74 68 20 78 31 2b 29 29 29 29 0a 20 20 ength x1+)))).
3cd0: 20 20 20 20 20 20 20 28 6c 65 74 20 6b 74 68 20 (let kth
3ce0: 28 28 6b 20 20 20 28 6d 6f 64 75 6c 6f 20 6b 20 ((k (modulo k
3cf0: 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 n)).
3d00: 20 20 20 20 20 20 20 28 6e 20 20 20 6e 29 20 20 (n n)
3d10: 3b 20 3d 20 7c 78 7c 0a 20 20 20 20 20 20 20 20 ; = |x|.
3d20: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 76 20 (rev
3d30: 23 74 29 20 3b 20 61 72 65 20 78 3c 2c 20 78 3d #t) ; are x<, x=
3d40: 2c 20 78 3e 20 72 65 76 65 72 73 65 64 3f 0a 20 , x> reversed?.
3d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d60: 20 20 28 78 20 20 20 28 63 6f 6e 73 20 78 30 20 (x (cons x0
3d70: 78 31 2b 29 29 29 0a 20 20 20 20 20 20 20 20 20 x1+))).
3d80: 20 20 28 6c 65 74 20 28 28 70 69 76 6f 74 20 28 (let ((pivot (
3d90: 6c 69 73 74 2d 72 65 66 20 78 20 28 72 61 6e 64 list-ref x (rand
3da0: 6f 6d 2d 69 6e 74 65 67 65 72 20 6e 29 29 29 29 om-integer n))))
3db0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c . (l
3dc0: 65 74 20 73 70 6c 69 74 20 28 28 78 20 78 29 20 et split ((x x)
3dd0: 28 78 3c 20 27 28 29 29 20 28 6e 3c 20 30 29 20 (x< '()) (n< 0)
3de0: 28 78 3d 20 27 28 29 29 20 28 6e 3d 20 30 29 20 (x= '()) (n= 0)
3df0: 28 78 3e 20 27 28 29 29 20 28 6e 3e 20 30 29 29 (x> '()) (n> 0))
3e00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3e10: 28 69 66 20 28 6e 75 6c 6c 3f 20 78 29 0a 20 20 (if (null? x).
3e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e30: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
3e40: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 ((<
3e50: 6b 20 6e 3c 29 0a 20 20 20 20 20 20 20 20 20 20 k n<).
3e60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6b 74 68 (kth
3e70: 20 6b 20 6e 3c 20 28 6e 6f 74 20 72 65 76 29 20 k n< (not rev)
3e80: 78 3c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x<)).
3e90: 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 6b 20 ((< k
3ea0: 28 2b 20 6e 3c 20 6e 3d 29 29 0a 20 20 20 20 20 (+ n< n=)).
3eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ec0: 20 28 69 66 20 72 65 76 0a 20 20 20 20 20 20 20 (if rev.
3ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ee0: 20 20 20 28 6c 69 73 74 2d 72 65 66 20 78 3d 20 (list-ref x=
3ef0: 28 2d 20 28 2d 20 6e 3d 20 31 29 20 28 2d 20 6b (- (- n= 1) (- k
3f00: 20 6e 3c 29 29 29 0a 20 20 20 20 20 20 20 20 20 n<))).
3f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f20: 20 28 6c 69 73 74 2d 72 65 66 20 78 3d 20 28 2d (list-ref x= (-
3f30: 20 6b 20 6e 3c 29 29 29 29 0a 20 20 20 20 20 20 k n<)))).
3f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3f50: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
3f60: 20 20 20 20 20 20 20 20 20 20 20 28 6b 74 68 20 (kth
3f70: 28 2d 20 6b 20 28 2b 20 6e 3c 20 6e 3d 29 29 20 (- k (+ n< n=))
3f80: 6e 3e 20 28 6e 6f 74 20 72 65 76 29 20 78 3e 29 n> (not rev) x>)
3f90: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3fa0: 20 20 20 20 20 20 28 69 66 33 20 28 63 6f 6d 70 (if3 (comp
3fb0: 61 72 65 20 28 63 61 72 20 78 29 20 70 69 76 6f are (car x) pivo
3fc0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
3fd0: 20 20 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 (spli
3fe0: 74 20 28 63 64 72 20 78 29 20 28 63 6f 6e 73 20 t (cdr x) (cons
3ff0: 28 63 61 72 20 78 29 20 78 3c 29 20 28 2b 20 6e (car x) x<) (+ n
4000: 3c 20 31 29 20 78 3d 20 6e 3d 20 78 3e 20 6e 3e < 1) x= n= x> n>
4010: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4020: 20 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 74 (split
4030: 20 28 63 64 72 20 78 29 20 78 3c 20 6e 3c 20 28 (cdr x) x< n< (
4040: 63 6f 6e 73 20 28 63 61 72 20 78 29 20 78 3d 29 cons (car x) x=)
4050: 20 28 2b 20 6e 3d 20 31 29 20 78 3e 20 6e 3e 29 (+ n= 1) x> n>)
4060: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4070: 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 74 20 (split
4080: 28 63 64 72 20 78 29 20 78 3c 20 6e 3c 20 78 3d (cdr x) x< n< x=
4090: 20 6e 3d 20 28 63 6f 6e 73 20 28 63 61 72 20 78 n= (cons (car x
40a0: 29 20 78 3e 29 20 28 2b 20 6e 3e 20 31 29 29 29 ) x>) (+ n> 1)))
40b0: 29 29 29 29 29 29 29 29 29 0a 0a 0a 3b 20 63 6f )))))))))...; co
40c0: 6d 70 61 72 65 20 66 75 6e 63 74 69 6f 6e 73 20 mpare functions
40d0: 66 72 6f 6d 20 70 72 65 64 69 63 61 74 65 73 0a from predicates.
40e0: 0a 28 64 65 66 69 6e 65 20 63 6f 6d 70 61 72 65 .(define compare
40f0: 2d 62 79 3c 0a 20 20 28 63 61 73 65 2d 6c 61 6d -by<. (case-lam
4100: 62 64 61 0a 20 20 20 20 28 28 6c 74 29 20 20 20 bda. ((lt)
4110: 20 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 20 (lambda (x y)
4120: 28 69 66 20 28 6c 74 20 78 20 79 29 20 2d 31 20 (if (lt x y) -1
4130: 28 69 66 20 28 6c 74 20 79 20 78 29 20 20 31 20 (if (lt y x) 1
4140: 30 29 29 29 29 0a 20 20 20 20 28 28 6c 74 20 78 0)))). ((lt x
4150: 20 79 29 20 20 20 20 20 20 20 20 20 20 20 20 20 y)
4160: 20 20 28 69 66 20 28 6c 74 20 78 20 79 29 20 2d (if (lt x y) -
4170: 31 20 28 69 66 20 28 6c 74 20 79 20 78 29 20 20 1 (if (lt y x)
4180: 31 20 30 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 1 0)))))..(defin
4190: 65 20 63 6f 6d 70 61 72 65 2d 62 79 3e 0a 20 20 e compare-by>.
41a0: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda.
41b0: 20 28 28 67 74 29 20 20 20 20 20 28 6c 61 6d 62 ((gt) (lamb
41c0: 64 61 20 28 78 20 79 29 20 28 69 66 20 28 67 74 da (x y) (if (gt
41d0: 20 78 20 79 29 20 31 20 28 69 66 20 28 67 74 20 x y) 1 (if (gt
41e0: 79 20 78 29 20 20 2d 31 20 30 29 29 29 29 0a 20 y x) -1 0)))).
41f0: 20 20 20 28 28 67 74 20 78 20 79 29 20 20 20 20 ((gt x y)
4200: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4210: 67 74 20 78 20 79 29 20 31 20 28 69 66 20 28 67 gt x y) 1 (if (g
4220: 74 20 79 20 78 29 20 20 2d 31 20 30 29 29 29 29 t y x) -1 0))))
4230: 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d 70 61 )..(define compa
4240: 72 65 2d 62 79 3c 3d 0a 20 20 28 63 61 73 65 2d re-by<=. (case-
4250: 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 6c 65 29 lambda. ((le)
4260: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 (lambda (x
4270: 79 29 20 28 69 66 20 28 6c 65 20 78 20 79 29 20 y) (if (le x y)
4280: 28 69 66 20 28 6c 65 20 79 20 78 29 20 30 20 2d (if (le y x) 0 -
4290: 31 29 20 31 29 29 29 0a 20 20 20 20 28 28 6c 65 1) 1))). ((le
42a0: 20 78 20 79 29 20 20 20 20 20 20 20 20 20 20 20 x y)
42b0: 20 20 20 20 28 69 66 20 28 6c 65 20 78 20 79 29 (if (le x y)
42c0: 20 28 69 66 20 28 6c 65 20 79 20 78 29 20 30 20 (if (le y x) 0
42d0: 2d 31 29 20 31 29 29 29 29 0a 0a 28 64 65 66 69 -1) 1))))..(defi
42e0: 6e 65 20 63 6f 6d 70 61 72 65 2d 62 79 3e 3d 0a ne compare-by>=.
42f0: 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 (case-lambda.
4300: 20 20 20 28 28 67 65 29 20 20 20 20 20 28 6c 61 ((ge) (la
4310: 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 20 28 mbda (x y) (if (
4320: 67 65 20 78 20 79 29 20 28 69 66 20 28 67 65 20 ge x y) (if (ge
4330: 79 20 78 29 20 30 20 31 29 20 2d 31 29 29 29 0a y x) 0 1) -1))).
4340: 20 20 20 20 28 28 67 65 20 78 20 79 29 20 20 20 ((ge x y)
4350: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
4360: 28 67 65 20 78 20 79 29 20 28 69 66 20 28 67 65 (ge x y) (if (ge
4370: 20 79 20 78 29 20 30 20 31 29 20 2d 31 29 29 29 y x) 0 1) -1)))
4380: 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d 70 61 )..(define compa
4390: 72 65 2d 62 79 3d 2f 3c 0a 20 20 28 63 61 73 65 re-by=/<. (case
43a0: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 65 71 -lambda. ((eq
43b0: 20 6c 74 29 20 20 20 20 20 28 6c 61 6d 62 64 61 lt) (lambda
43c0: 20 28 78 20 79 29 20 28 69 66 20 28 65 71 20 78 (x y) (if (eq x
43d0: 20 79 29 20 30 20 28 69 66 20 28 6c 74 20 78 20 y) 0 (if (lt x
43e0: 79 29 20 2d 31 20 31 29 29 29 29 0a 20 20 20 20 y) -1 1)))).
43f0: 28 28 65 71 20 6c 74 20 78 20 79 29 20 20 20 20 ((eq lt x y)
4400: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4410: 65 71 20 78 20 79 29 20 30 20 28 69 66 20 28 6c eq x y) 0 (if (l
4420: 74 20 78 20 79 29 20 2d 31 20 31 29 29 29 29 29 t x y) -1 1)))))
4430: 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d 70 61 72 ..(define compar
4440: 65 2d 62 79 3d 2f 3e 0a 20 20 28 63 61 73 65 2d e-by=/>. (case-
4450: 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 65 71 20 lambda. ((eq
4460: 67 74 29 20 20 20 20 20 28 6c 61 6d 62 64 61 20 gt) (lambda
4470: 28 78 20 79 29 20 28 69 66 20 28 65 71 20 78 20 (x y) (if (eq x
4480: 79 29 20 30 20 28 69 66 20 28 67 74 20 78 20 79 y) 0 (if (gt x y
4490: 29 20 31 20 2d 31 29 29 29 29 0a 20 20 20 20 28 ) 1 -1)))). (
44a0: 28 65 71 20 67 74 20 78 20 79 29 20 20 20 20 20 (eq gt x y)
44b0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 (if (e
44c0: 71 20 78 20 79 29 20 30 20 28 69 66 20 28 67 74 q x y) 0 (if (gt
44d0: 20 78 20 79 29 20 31 20 2d 31 29 29 29 29 29 0a x y) 1 -1))))).
44e0: 0a 3b 20 72 65 66 69 6e 65 20 61 6e 64 20 65 78 .; refine and ex
44f0: 74 65 6e 64 20 63 6f 6e 73 74 72 75 63 74 69 6f tend constructio
4500: 6e 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 n..(define-synta
4510: 78 20 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 x refine-compare
4520: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
4530: 20 28 29 0a 20 20 20 20 28 28 72 65 66 69 6e 65 (). ((refine
4540: 2d 63 6f 6d 70 61 72 65 29 0a 20 20 20 20 20 30 -compare). 0
4550: 29 0a 20 20 20 20 28 28 72 65 66 69 6e 65 2d 63 ). ((refine-c
4560: 6f 6d 70 61 72 65 20 63 31 29 0a 20 20 20 20 20 ompare c1).
4570: 63 31 29 0a 20 20 20 20 28 28 72 65 66 69 6e 65 c1). ((refine
4580: 2d 63 6f 6d 70 61 72 65 20 63 31 20 63 32 20 63 -compare c1 c2 c
4590: 73 20 2e 2e 2e 29 0a 20 20 20 20 20 28 69 66 33 s ...). (if3
45a0: 20 63 31 20 2d 31 20 28 72 65 66 69 6e 65 2d 63 c1 -1 (refine-c
45b0: 6f 6d 70 61 72 65 20 63 32 20 63 73 20 2e 2e 2e ompare c2 cs ...
45c0: 29 20 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ) 1))))..(define
45d0: 2d 73 79 6e 74 61 78 20 73 65 6c 65 63 74 2d 63 -syntax select-c
45e0: 6f 6d 70 61 72 65 0a 20 20 28 73 79 6e 74 61 78 ompare. (syntax
45f0: 2d 72 75 6c 65 73 20 28 65 6c 73 65 29 0a 20 20 -rules (else).
4600: 20 20 28 28 73 65 6c 65 63 74 2d 63 6f 6d 70 61 ((select-compa
4610: 72 65 20 78 20 79 20 63 6c 61 75 73 65 20 2e 2e re x y clause ..
4620: 2e 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 78 .). (let ((x
4630: 2d 76 61 6c 20 78 29 20 28 79 2d 76 61 6c 20 79 -val x) (y-val y
4640: 29 29 0a 20 20 20 20 20 20 20 28 73 65 6c 65 63 )). (selec
4650: 74 2d 63 6f 6d 70 61 72 65 20 28 78 2d 76 61 6c t-compare (x-val
4660: 20 79 2d 76 61 6c 20 63 6c 61 75 73 65 20 2e 2e y-val clause ..
4670: 2e 29 29 29 29 0a 20 20 20 20 3b 20 75 73 65 64 .)))). ; used
4680: 20 69 6e 74 65 72 6e 61 6c 6c 79 3a 20 28 73 65 internally: (se
4690: 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 28 78 20 lect-compare (x
46a0: 79 20 63 6c 61 75 73 65 20 2e 2e 2e 29 29 0a 20 y clause ...)).
46b0: 20 20 20 28 28 73 65 6c 65 63 74 2d 63 6f 6d 70 ((select-comp
46c0: 61 72 65 20 28 78 20 79 29 29 0a 20 20 20 20 20 are (x y)).
46d0: 30 29 0a 20 20 20 20 28 28 73 65 6c 65 63 74 2d 0). ((select-
46e0: 63 6f 6d 70 61 72 65 20 28 78 20 79 20 28 65 6c compare (x y (el
46f0: 73 65 20 63 20 2e 2e 2e 29 29 29 0a 20 20 20 20 se c ...))).
4700: 20 28 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 (refine-compare
4710: 20 63 20 2e 2e 2e 29 29 0a 20 20 20 20 28 28 73 c ...)). ((s
4720: 65 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 28 78 elect-compare (x
4730: 20 79 20 28 74 3f 20 63 20 2e 2e 2e 29 20 63 6c y (t? c ...) cl
4740: 61 75 73 65 20 2e 2e 2e 29 29 0a 20 20 20 20 20 ause ...)).
4750: 28 6c 65 74 20 28 28 74 3f 2d 76 61 6c 20 74 3f (let ((t?-val t?
4760: 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 )). (let (
4770: 28 74 78 20 28 74 3f 2d 76 61 6c 20 78 29 29 20 (tx (t?-val x))
4780: 28 74 79 20 28 74 3f 2d 76 61 6c 20 79 29 29 29 (ty (t?-val y)))
4790: 0a 20 20 20 20 20 20 20 20 20 28 69 66 20 74 78 . (if tx
47a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 . (i
47b0: 66 20 74 79 20 28 72 65 66 69 6e 65 2d 63 6f 6d f ty (refine-com
47c0: 70 61 72 65 20 63 20 2e 2e 2e 29 20 2d 31 29 0a pare c ...) -1).
47d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
47e0: 20 74 79 20 31 20 28 73 65 6c 65 63 74 2d 63 6f ty 1 (select-co
47f0: 6d 70 61 72 65 20 28 78 20 79 20 63 6c 61 75 73 mpare (x y claus
4800: 65 20 2e 2e 2e 29 29 29 29 29 29 29 29 29 0a 0a e ...)))))))))..
4810: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 63 (define-syntax c
4820: 6f 6e 64 2d 63 6f 6d 70 61 72 65 0a 20 20 28 73 ond-compare. (s
4830: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 65 6c 73 yntax-rules (els
4840: 65 29 0a 20 20 20 20 28 28 63 6f 6e 64 2d 63 6f e). ((cond-co
4850: 6d 70 61 72 65 29 0a 20 20 20 20 20 30 29 0a 20 mpare). 0).
4860: 20 20 20 28 28 63 6f 6e 64 2d 63 6f 6d 70 61 72 ((cond-compar
4870: 65 20 28 65 6c 73 65 20 63 73 20 2e 2e 2e 29 29 e (else cs ...))
4880: 0a 20 20 20 20 20 28 72 65 66 69 6e 65 2d 63 6f . (refine-co
4890: 6d 70 61 72 65 20 63 73 20 2e 2e 2e 29 29 0a 20 mpare cs ...)).
48a0: 20 20 20 28 28 63 6f 6e 64 2d 63 6f 6d 70 61 72 ((cond-compar
48b0: 65 20 28 28 74 78 20 74 79 29 20 63 73 20 2e 2e e ((tx ty) cs ..
48c0: 2e 29 20 63 6c 61 75 73 65 20 2e 2e 2e 29 0a 20 .) clause ...).
48d0: 20 20 20 20 28 6c 65 74 20 28 28 74 78 2d 76 61 (let ((tx-va
48e0: 6c 20 74 78 29 20 28 74 79 2d 76 61 6c 20 74 79 l tx) (ty-val ty
48f0: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 74 78 )). (if tx
4900: 2d 76 61 6c 0a 20 20 20 20 20 20 20 20 20 20 20 -val.
4910: 28 69 66 20 74 79 2d 76 61 6c 20 28 72 65 66 69 (if ty-val (refi
4920: 6e 65 2d 63 6f 6d 70 61 72 65 20 63 73 20 2e 2e ne-compare cs ..
4930: 2e 29 20 2d 31 29 0a 20 20 20 20 20 20 20 20 20 .) -1).
4940: 20 20 28 69 66 20 74 79 2d 76 61 6c 20 31 20 28 (if ty-val 1 (
4950: 63 6f 6e 64 2d 63 6f 6d 70 61 72 65 20 63 6c 61 cond-compare cla
4960: 75 73 65 20 2e 2e 2e 29 29 29 29 29 29 29 0a 0a use ...)))))))..
4970: 0a 3b 20 52 35 52 53 20 61 74 6f 6d 69 63 20 74 .; R5RS atomic t
4980: 79 70 65 73 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ypes..(define-sy
4990: 6e 74 61 78 20 63 6f 6d 70 61 72 65 3a 74 79 70 ntax compare:typ
49a0: 65 2d 63 68 65 63 6b 0a 20 20 28 73 79 6e 74 61 e-check. (synta
49b0: 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 x-rules (). (
49c0: 28 63 6f 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 (compare:type-ch
49d0: 65 63 6b 20 74 79 70 65 3f 20 74 79 70 65 2d 6e eck type? type-n
49e0: 61 6d 65 20 78 29 0a 20 20 20 20 20 28 69 66 20 ame x). (if
49f0: 28 6e 6f 74 20 28 74 79 70 65 3f 20 78 29 29 0a (not (type? x)).
4a00: 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 (error
4a10: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
4a20: 6e 6f 74 20 22 20 74 79 70 65 2d 6e 61 6d 65 20 not " type-name
4a30: 22 3a 22 29 20 78 29 29 29 0a 20 20 20 20 28 28 ":") x))). ((
4a40: 63 6f 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 65 compare:type-che
4a50: 63 6b 20 74 79 70 65 3f 20 74 79 70 65 2d 6e 61 ck type? type-na
4a60: 6d 65 20 78 20 79 29 0a 20 20 20 20 20 28 62 65 me x y). (be
4a70: 67 69 6e 20 28 63 6f 6d 70 61 72 65 3a 74 79 70 gin (compare:typ
4a80: 65 2d 63 68 65 63 6b 20 74 79 70 65 3f 20 74 79 e-check type? ty
4a90: 70 65 2d 6e 61 6d 65 20 78 29 0a 20 20 20 20 20 pe-name x).
4aa0: 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a (compare:
4ab0: 74 79 70 65 2d 63 68 65 63 6b 20 74 79 70 65 3f type-check type?
4ac0: 20 74 79 70 65 2d 6e 61 6d 65 20 79 29 29 29 29 type-name y))))
4ad0: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta
4ae0: 78 20 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 x compare:define
4af0: 2d 62 79 3d 2f 3c 0a 20 20 28 73 79 6e 74 61 78 -by=/<. (syntax
4b00: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). ((
4b10: 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 62 compare:define-b
4b20: 79 3d 2f 3c 20 63 6f 6d 70 61 72 65 20 3d 20 3c y=/< compare = <
4b30: 20 74 79 70 65 3f 20 74 79 70 65 2d 6e 61 6d 65 type? type-name
4b40: 29 0a 20 20 20 20 20 28 64 65 66 69 6e 65 20 63 ). (define c
4b50: 6f 6d 70 61 72 65 0a 20 20 20 20 20 20 20 28 6c ompare. (l
4b60: 65 74 20 28 28 3d 20 3d 29 20 28 3c 20 3c 29 29 et ((= =) (< <))
4b70: 0a 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 . (lambd
4b80: 61 20 28 78 20 79 29 0a 20 20 20 20 20 20 20 20 a (x y).
4b90: 20 20 20 28 69 66 20 28 74 79 70 65 3f 20 78 29 (if (type? x)
4ba0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4bb0: 28 69 66 20 28 65 71 3f 20 78 20 79 29 0a 20 20 (if (eq? x y).
4bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bd0: 20 30 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 0.
4be0: 20 20 20 20 20 20 28 69 66 20 28 74 79 70 65 3f (if (type?
4bf0: 20 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y).
4c00: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
4c10: 3d 20 78 20 79 29 20 30 20 28 69 66 20 28 3c 20 = x y) 0 (if (<
4c20: 78 20 79 29 20 2d 31 20 31 29 29 0a 20 20 20 20 x y) -1 1)).
4c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c40: 20 20 20 28 65 72 72 6f 72 20 28 73 74 72 69 6e (error (strin
4c50: 67 2d 61 70 70 65 6e 64 20 22 6e 6f 74 20 22 20 g-append "not "
4c60: 74 79 70 65 2d 6e 61 6d 65 20 22 3a 22 29 20 79 type-name ":") y
4c70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
4c80: 20 20 20 28 65 72 72 6f 72 20 28 73 74 72 69 6e (error (strin
4c90: 67 2d 61 70 70 65 6e 64 20 22 6e 6f 74 20 22 20 g-append "not "
4ca0: 74 79 70 65 2d 6e 61 6d 65 20 22 3a 22 29 20 78 type-name ":") x
4cb0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
4cc0: 65 20 28 62 6f 6f 6c 65 61 6e 2d 63 6f 6d 70 61 e (boolean-compa
4cd0: 72 65 20 78 20 79 29 0a 20 20 28 63 6f 6d 70 61 re x y). (compa
4ce0: 72 65 3a 74 79 70 65 2d 63 68 65 63 6b 20 62 6f re:type-check bo
4cf0: 6f 6c 65 61 6e 3f 20 22 62 6f 6f 6c 65 61 6e 22 olean? "boolean"
4d00: 20 78 20 79 29 0a 20 20 28 69 66 20 78 20 28 69 x y). (if x (i
4d10: 66 20 79 20 30 20 31 29 20 28 69 66 20 79 20 2d f y 0 1) (if y -
4d20: 31 20 30 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 1 0)))..(compare
4d30: 3a 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 63 68 :define-by=/< ch
4d40: 61 72 2d 63 6f 6d 70 61 72 65 20 63 68 61 72 3d ar-compare char=
4d50: 3f 20 63 68 61 72 3c 3f 20 63 68 61 72 3f 20 22 ? char<? char? "
4d60: 63 68 61 72 22 29 0a 0a 28 63 6f 6d 70 61 72 65 char")..(compare
4d70: 3a 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 63 68 :define-by=/< ch
4d80: 61 72 2d 63 6f 6d 70 61 72 65 2d 63 69 20 63 68 ar-compare-ci ch
4d90: 61 72 2d 63 69 3d 3f 20 63 68 61 72 2d 63 69 3c ar-ci=? char-ci<
4da0: 3f 20 63 68 61 72 3f 20 22 63 68 61 72 22 29 0a ? char? "char").
4db0: 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 .(compare:define
4dc0: 2d 62 79 3d 2f 3c 20 73 74 72 69 6e 67 2d 63 6f -by=/< string-co
4dd0: 6d 70 61 72 65 20 73 74 72 69 6e 67 3d 3f 20 73 mpare string=? s
4de0: 74 72 69 6e 67 3c 3f 20 73 74 72 69 6e 67 3f 20 tring<? string?
4df0: 22 73 74 72 69 6e 67 22 29 0a 0a 28 63 6f 6d 70 "string")..(comp
4e00: 61 72 65 3a 64 65 66 69 6e 65 2d 62 79 3d 2f 3c are:define-by=/<
4e10: 20 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d string-compare-
4e20: 63 69 20 73 74 72 69 6e 67 2d 63 69 3d 3f 20 73 ci string-ci=? s
4e30: 74 72 69 6e 67 2d 63 69 3c 3f 20 73 74 72 69 6e tring-ci<? strin
4e40: 67 3f 20 22 73 74 72 69 6e 67 22 29 0a 0a 28 64 g? "string")..(d
4e50: 65 66 69 6e 65 20 28 73 79 6d 62 6f 6c 2d 63 6f efine (symbol-co
4e60: 6d 70 61 72 65 20 78 20 79 29 0a 20 20 28 63 6f mpare x y). (co
4e70: 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 65 63 6b mpare:type-check
4e80: 20 73 79 6d 62 6f 6c 3f 20 22 73 79 6d 62 6f 6c symbol? "symbol
4e90: 22 20 78 20 79 29 0a 20 20 28 73 74 72 69 6e 67 " x y). (string
4ea0: 2d 63 6f 6d 70 61 72 65 20 28 73 79 6d 62 6f 6c -compare (symbol
4eb0: 2d 3e 73 74 72 69 6e 67 20 78 29 20 28 73 79 6d ->string x) (sym
4ec0: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 79 29 29 29 bol->string y)))
4ed0: 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e ..(compare:defin
4ee0: 65 2d 62 79 3d 2f 3c 20 69 6e 74 65 67 65 72 2d e-by=/< integer-
4ef0: 63 6f 6d 70 61 72 65 20 3d 20 3c 20 69 6e 74 65 compare = < inte
4f00: 67 65 72 3f 20 22 69 6e 74 65 67 65 72 22 29 0a ger? "integer").
4f10: 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 .(compare:define
4f20: 2d 62 79 3d 2f 3c 20 72 61 74 69 6f 6e 61 6c 2d -by=/< rational-
4f30: 63 6f 6d 70 61 72 65 20 3d 20 3c 20 72 61 74 69 compare = < rati
4f40: 6f 6e 61 6c 3f 20 22 72 61 74 69 6f 6e 61 6c 22 onal? "rational"
4f50: 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 )..(compare:defi
4f60: 6e 65 2d 62 79 3d 2f 3c 20 72 65 61 6c 2d 63 6f ne-by=/< real-co
4f70: 6d 70 61 72 65 20 3d 20 3c 20 72 65 61 6c 3f 20 mpare = < real?
4f80: 22 72 65 61 6c 22 29 0a 0a 28 64 65 66 69 6e 65 "real")..(define
4f90: 20 28 63 6f 6d 70 6c 65 78 2d 63 6f 6d 70 61 72 (complex-compar
4fa0: 65 20 78 20 79 29 0a 20 20 28 63 6f 6d 70 61 72 e x y). (compar
4fb0: 65 3a 74 79 70 65 2d 63 68 65 63 6b 20 63 6f 6d e:type-check com
4fc0: 70 6c 65 78 3f 20 22 63 6f 6d 70 6c 65 78 22 20 plex? "complex"
4fd0: 78 20 79 29 0a 20 20 28 69 66 20 28 61 6e 64 20 x y). (if (and
4fe0: 28 72 65 61 6c 3f 20 78 29 20 28 72 65 61 6c 3f (real? x) (real?
4ff0: 20 79 29 29 0a 20 20 20 20 20 20 28 72 65 61 6c y)). (real
5000: 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 -compare x y).
5010: 20 20 20 20 28 72 65 66 69 6e 65 2d 63 6f 6d 70 (refine-comp
5020: 61 72 65 20 28 72 65 61 6c 2d 63 6f 6d 70 61 72 are (real-compar
5030: 65 20 28 72 65 61 6c 2d 70 61 72 74 20 78 29 20 e (real-part x)
5040: 28 72 65 61 6c 2d 70 61 72 74 20 79 29 29 0a 20 (real-part y)).
5050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5060: 20 20 20 20 20 28 72 65 61 6c 2d 63 6f 6d 70 61 (real-compa
5070: 72 65 20 28 69 6d 61 67 2d 70 61 72 74 20 78 29 re (imag-part x)
5080: 20 28 69 6d 61 67 2d 70 61 72 74 20 79 29 29 29 (imag-part y)))
5090: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6e 75 6d ))..(define (num
50a0: 62 65 72 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 ber-compare x y)
50b0: 0a 20 20 28 63 6f 6d 70 61 72 65 3a 74 79 70 65 . (compare:type
50c0: 2d 63 68 65 63 6b 20 6e 75 6d 62 65 72 3f 20 22 -check number? "
50d0: 6e 75 6d 62 65 72 22 20 78 20 79 29 0a 20 20 28 number" x y). (
50e0: 63 6f 6d 70 6c 65 78 2d 63 6f 6d 70 61 72 65 20 complex-compare
50f0: 78 20 79 29 29 0a 0a 0a 3b 20 52 35 52 53 20 63 x y))...; R5RS c
5100: 6f 6d 70 6f 75 6e 64 20 64 61 74 61 20 73 74 72 ompound data str
5110: 75 63 74 75 72 65 73 3a 20 64 6f 74 74 65 64 20 uctures: dotted
5120: 70 61 69 72 2c 20 6c 69 73 74 2c 20 76 65 63 74 pair, list, vect
5130: 6f 72 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 69 or..(define (pai
5140: 72 2d 63 6f 6d 70 61 72 65 2d 63 61 72 20 63 6f r-compare-car co
5150: 6d 70 61 72 65 29 0a 20 20 28 6c 61 6d 62 64 61 mpare). (lambda
5160: 20 28 78 20 79 29 0a 20 20 20 20 28 63 6f 6d 70 (x y). (comp
5170: 61 72 65 20 28 63 61 72 20 78 29 20 28 63 61 72 are (car x) (car
5180: 20 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y))))..(define
5190: 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 64 (pair-compare-cd
51a0: 72 20 63 6f 6d 70 61 72 65 29 0a 20 20 28 6c 61 r compare). (la
51b0: 6d 62 64 61 20 28 78 20 79 29 0a 20 20 20 20 28 mbda (x y). (
51c0: 63 6f 6d 70 61 72 65 20 28 63 64 72 20 78 29 20 compare (cdr x)
51d0: 28 63 64 72 20 79 29 29 29 29 0a 0a 28 64 65 66 (cdr y))))..(def
51e0: 69 6e 65 20 70 61 69 72 2d 63 6f 6d 70 61 72 65 ine pair-compare
51f0: 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a . (case-lambda.
5200: 20 20 20 20 0a 20 20 20 20 3b 20 64 6f 74 74 65 . ; dotte
5210: 64 20 70 61 69 72 0a 20 20 20 20 28 28 70 61 69 d pair. ((pai
5220: 72 2d 63 6f 6d 70 61 72 65 2d 63 61 72 20 70 61 r-compare-car pa
5230: 69 72 2d 63 6f 6d 70 61 72 65 2d 63 64 72 20 78 ir-compare-cdr x
5240: 20 79 29 0a 20 20 20 20 20 28 72 65 66 69 6e 65 y). (refine
5250: 2d 63 6f 6d 70 61 72 65 20 28 70 61 69 72 2d 63 -compare (pair-c
5260: 6f 6d 70 61 72 65 2d 63 61 72 20 28 63 61 72 20 ompare-car (car
5270: 78 29 20 28 63 61 72 20 79 29 29 0a 20 20 20 20 x) (car y)).
5280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5290: 20 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 (pair-compare-c
52a0: 64 72 20 28 63 64 72 20 78 29 20 28 63 64 72 20 dr (cdr x) (cdr
52b0: 79 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b y)))). . ;
52c0: 20 70 6f 73 73 69 62 6c 79 20 69 6d 70 72 6f 70 possibly improp
52d0: 65 72 20 6c 69 73 74 73 0a 20 20 20 20 28 28 63 er lists. ((c
52e0: 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 20 20 ompare x y).
52f0: 20 28 63 6f 6e 64 2d 63 6f 6d 70 61 72 65 20 0a (cond-compare .
5300: 20 20 20 20 20 20 28 28 28 6e 75 6c 6c 3f 20 78 (((null? x
5310: 29 20 28 6e 75 6c 6c 3f 20 79 29 29 20 30 29 0a ) (null? y)) 0).
5320: 20 20 20 20 20 20 28 28 28 70 61 69 72 3f 20 78 (((pair? x
5330: 29 20 28 70 61 69 72 3f 20 79 29 29 20 28 63 6f ) (pair? y)) (co
5340: 6d 70 61 72 65 20 20 20 20 20 20 20 20 20 20 20 mpare
5350: 20 20 20 28 63 61 72 20 78 29 20 28 63 61 72 20 (car x) (car
5360: 79 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y)).
5370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5380: 20 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 20 63 (pair-compare c
5390: 6f 6d 70 61 72 65 20 28 63 64 72 20 78 29 20 28 ompare (cdr x) (
53a0: 63 64 72 20 79 29 29 29 0a 20 20 20 20 20 20 28 cdr y))). (
53b0: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
53c0: 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 20 78 (compare x
53d0: 20 79 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 y)))). .
53e0: 3b 20 66 6f 72 20 63 6f 6e 76 65 6e 69 65 6e 63 ; for convenienc
53f0: 65 0a 20 20 20 20 28 28 78 20 79 29 0a 20 20 20 e. ((x y).
5400: 20 20 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 20 (pair-compare
5410: 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 default-compare
5420: 78 20 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 x y))))..(define
5430: 20 6c 69 73 74 2d 63 6f 6d 70 61 72 65 0a 20 20 list-compare.
5440: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda.
5450: 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 20 65 ((compare x y e
5460: 6d 70 74 79 3f 20 68 65 61 64 20 74 61 69 6c 29 mpty? head tail)
5470: 0a 20 20 20 20 20 28 63 6f 6e 64 2d 63 6f 6d 70 . (cond-comp
5480: 61 72 65 0a 20 20 20 20 20 20 28 28 28 65 6d 70 are. (((emp
5490: 74 79 3f 20 78 29 20 28 65 6d 70 74 79 3f 20 79 ty? x) (empty? y
54a0: 29 29 20 30 29 0a 20 20 20 20 20 20 28 65 6c 73 )) 0). (els
54b0: 65 20 28 63 6f 6d 70 61 72 65 20 20 20 20 20 20 e (compare
54c0: 20 20 20 20 20 20 20 20 28 68 65 61 64 20 78 29 (head x)
54d0: 20 28 68 65 61 64 20 79 29 29 0a 20 20 20 20 20 (head y)).
54e0: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 63 6f 6d (list-com
54f0: 70 61 72 65 20 63 6f 6d 70 61 72 65 20 28 74 61 pare compare (ta
5500: 69 6c 20 78 29 20 28 74 61 69 6c 20 79 29 20 65 il x) (tail y) e
5510: 6d 70 74 79 3f 20 68 65 61 64 20 74 61 69 6c 29 mpty? head tail)
5520: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 20 66 ))). . ; f
5530: 6f 72 20 63 6f 6e 76 65 6e 69 65 6e 63 65 0a 20 or convenience.
5540: 20 20 20 28 28 20 20 20 20 20 20 20 20 78 20 79 (( x y
5550: 20 65 6d 70 74 79 3f 20 68 65 61 64 20 74 61 69 empty? head tai
5560: 6c 29 0a 20 20 20 20 20 28 6c 69 73 74 2d 63 6f l). (list-co
5570: 6d 70 61 72 65 20 64 65 66 61 75 6c 74 2d 63 6f mpare default-co
5580: 6d 70 61 72 65 20 78 20 79 20 65 6d 70 74 79 3f mpare x y empty?
5590: 20 68 65 61 64 20 74 61 69 6c 29 29 0a 20 20 20 head tail)).
55a0: 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 20 20 ((compare x y
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 ).
55c0: 20 20 20 28 6c 69 73 74 2d 63 6f 6d 70 61 72 65 (list-compare
55d0: 20 63 6f 6d 70 61 72 65 20 20 20 20 20 20 20 20 compare
55e0: 20 78 20 79 20 6e 75 6c 6c 3f 20 63 61 72 20 20 x y null? car
55f0: 20 63 64 72 29 29 0a 20 20 20 20 28 28 20 20 20 cdr)). ((
5600: 20 20 20 20 20 78 20 79 20 20 20 20 20 20 20 20 x y
5610: 20 20 20 20 20 20 29 0a 20 20 20 20 20 28 6c 69 ). (li
5620: 73 74 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 75 st-compare defau
5630: 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 6e lt-compare x y n
5640: 75 6c 6c 3f 20 63 61 72 20 20 20 63 64 72 29 29 ull? car cdr))
5650: 29 29 0a 0a 28 64 65 66 69 6e 65 20 6c 69 73 74 ))..(define list
5660: 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 76 65 63 74 -compare-as-vect
5670: 6f 72 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 or. (case-lambd
5680: 61 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 a. ((compare
5690: 78 20 79 20 65 6d 70 74 79 3f 20 68 65 61 64 20 x y empty? head
56a0: 74 61 69 6c 29 0a 20 20 20 20 20 28 72 65 66 69 tail). (refi
56b0: 6e 65 2d 63 6f 6d 70 61 72 65 0a 20 20 20 20 20 ne-compare.
56c0: 20 28 6c 65 74 20 63 6f 6d 70 61 72 65 2d 6c 65 (let compare-le
56d0: 6e 67 74 68 20 28 28 78 20 78 29 20 28 79 20 79 ngth ((x x) (y y
56e0: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 64 )). (cond
56f0: 2d 63 6f 6d 70 61 72 65 0a 20 20 20 20 20 20 20 -compare.
5700: 20 20 28 28 28 65 6d 70 74 79 3f 20 78 29 20 28 (((empty? x) (
5710: 65 6d 70 74 79 3f 20 79 29 29 20 30 29 0a 20 20 empty? y)) 0).
5720: 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 63 6f (else (co
5730: 6d 70 61 72 65 2d 6c 65 6e 67 74 68 20 28 74 61 mpare-length (ta
5740: 69 6c 20 78 29 20 28 74 61 69 6c 20 79 29 29 29 il x) (tail y)))
5750: 29 29 0a 20 20 20 20 20 20 28 6c 69 73 74 2d 63 )). (list-c
5760: 6f 6d 70 61 72 65 20 63 6f 6d 70 61 72 65 20 78 ompare compare x
5770: 20 79 20 65 6d 70 74 79 3f 20 68 65 61 64 20 74 y empty? head t
5780: 61 69 6c 29 29 29 0a 20 20 20 20 0a 20 20 20 20 ail))). .
5790: 3b 20 66 6f 72 20 63 6f 6e 76 65 6e 69 65 6e 63 ; for convenienc
57a0: 65 0a 20 20 20 20 28 28 20 20 20 20 20 20 20 20 e. ((
57b0: 78 20 79 20 65 6d 70 74 79 3f 20 68 65 61 64 20 x y empty? head
57c0: 74 61 69 6c 29 0a 20 20 20 20 20 28 6c 69 73 74 tail). (list
57d0: 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 76 65 63 74 -compare-as-vect
57e0: 6f 72 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 or default-compa
57f0: 72 65 20 78 20 79 20 65 6d 70 74 79 3f 20 68 65 re x y empty? he
5800: 61 64 20 74 61 69 6c 29 29 0a 20 20 20 20 28 28 ad tail)). ((
5810: 63 6f 6d 70 61 72 65 20 78 20 79 20 20 20 20 20 compare x y
5820: 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 ).
5830: 28 6c 69 73 74 2d 63 6f 6d 70 61 72 65 2d 61 73 (list-compare-as
5840: 2d 76 65 63 74 6f 72 20 63 6f 6d 70 61 72 65 20 -vector compare
5850: 20 20 20 20 20 20 20 20 78 20 79 20 6e 75 6c 6c x y null
5860: 3f 20 20 63 61 72 20 20 63 64 72 29 29 0a 20 20 ? car cdr)).
5870: 20 20 28 28 20 20 20 20 20 20 20 20 78 20 79 20 (( x y
5880: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 ).
5890: 20 20 20 20 28 6c 69 73 74 2d 63 6f 6d 70 61 72 (list-compar
58a0: 65 2d 61 73 2d 76 65 63 74 6f 72 20 64 65 66 61 e-as-vector defa
58b0: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 ult-compare x y
58c0: 6e 75 6c 6c 3f 20 20 63 61 72 20 20 63 64 72 29 null? car cdr)
58d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 76 65 63 )))..(define vec
58e0: 74 6f 72 2d 63 6f 6d 70 61 72 65 0a 20 20 28 6c tor-compare. (l
58f0: 65 74 20 28 28 3d 20 3d 29 29 0a 20 20 20 20 28 et ((= =)). (
5900: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda.
5910: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 20 ((compare x y
5920: 73 69 7a 65 20 72 65 66 29 0a 20 20 20 20 20 20 size ref).
5930: 20 28 6c 65 74 20 28 28 6e 20 28 73 69 7a 65 20 (let ((n (size
5940: 78 29 29 20 28 6d 20 28 73 69 7a 65 20 79 29 29 x)) (m (size y))
5950: 29 0a 20 20 20 20 20 20 20 20 20 28 72 65 66 69 ). (refi
5960: 6e 65 2d 63 6f 6d 70 61 72 65 20 0a 20 20 20 20 ne-compare .
5970: 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d 63 (integer-c
5980: 6f 6d 70 61 72 65 20 6e 20 6d 29 0a 20 20 20 20 ompare n m).
5990: 20 20 20 20 20 20 28 6c 65 74 20 63 6f 6d 70 61 (let compa
59a0: 72 65 2d 72 65 73 74 20 28 28 69 20 30 29 29 20 re-rest ((i 0))
59b0: 3b 20 63 6f 6d 70 61 72 65 20 78 5b 69 2e 2e 6e ; compare x[i..n
59c0: 2d 31 5d 20 79 5b 69 2e 2e 6e 2d 31 5d 0a 20 20 -1] y[i..n-1].
59d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3d (if (=
59e0: 20 69 20 6e 29 0a 20 20 20 20 20 20 20 20 20 20 i n).
59f0: 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 20 20 0.
5a00: 20 20 20 20 20 20 20 20 28 72 65 66 69 6e 65 2d (refine-
5a10: 63 6f 6d 70 61 72 65 20 28 63 6f 6d 70 61 72 65 compare (compare
5a20: 20 28 72 65 66 20 78 20 69 29 20 28 72 65 66 20 (ref x i) (ref
5a30: 79 20 69 29 29 0a 20 20 20 20 20 20 20 20 20 20 y i)).
5a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a50: 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 2d 72 (compare-r
5a60: 65 73 74 20 28 2b 20 69 20 31 29 29 29 29 29 29 est (+ i 1))))))
5a70: 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 )). .
5a80: 3b 20 66 6f 72 20 63 6f 6e 76 65 6e 69 65 6e 63 ; for convenienc
5a90: 65 0a 20 20 20 20 20 20 28 28 20 20 20 20 20 20 e. ((
5aa0: 20 20 78 20 79 20 73 69 7a 65 20 72 65 66 29 0a x y size ref).
5ab0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 63 (vector-c
5ac0: 6f 6d 70 61 72 65 20 64 65 66 61 75 6c 74 2d 63 ompare default-c
5ad0: 6f 6d 70 61 72 65 20 78 20 79 20 73 69 7a 65 20 ompare x y size
5ae0: 20 20 20 20 20 20 20 20 20 72 65 66 29 29 0a 20 ref)).
5af0: 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 ((compare x
5b00: 20 79 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 y ).
5b10: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 63 6f (vector-co
5b20: 6d 70 61 72 65 20 63 6f 6d 70 61 72 65 20 20 20 mpare compare
5b30: 20 20 20 20 20 20 78 20 79 20 76 65 63 74 6f 72 x y vector
5b40: 2d 6c 65 6e 67 74 68 20 76 65 63 74 6f 72 2d 72 -length vector-r
5b50: 65 66 29 29 0a 20 20 20 20 20 20 28 28 20 20 20 ef)). ((
5b60: 20 20 20 20 20 78 20 79 20 20 20 20 20 20 20 20 x y
5b70: 20 20 20 29 0a 20 20 20 20 20 20 20 28 76 65 63 ). (vec
5b80: 74 6f 72 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 tor-compare defa
5b90: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 ult-compare x y
5ba0: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 vector-length ve
5bb0: 63 74 6f 72 2d 72 65 66 29 29 29 29 29 0a 0a 28 ctor-ref)))))..(
5bc0: 64 65 66 69 6e 65 20 76 65 63 74 6f 72 2d 63 6f define vector-co
5bd0: 6d 70 61 72 65 2d 61 73 2d 6c 69 73 74 0a 20 20 mpare-as-list.
5be0: 28 6c 65 74 20 28 28 3d 20 3d 29 29 0a 20 20 20 (let ((= =)).
5bf0: 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 (case-lambda.
5c00: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 ((compare x
5c10: 79 20 73 69 7a 65 20 72 65 66 29 0a 20 20 20 20 y size ref).
5c20: 20 20 20 28 6c 65 74 20 28 28 6e 78 20 28 73 69 (let ((nx (si
5c30: 7a 65 20 78 29 29 20 28 6e 79 20 28 73 69 7a 65 ze x)) (ny (size
5c40: 20 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 y))). (
5c50: 6c 65 74 20 28 28 6e 20 28 6d 69 6e 20 6e 78 20 let ((n (min nx
5c60: 6e 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ny))).
5c70: 20 28 6c 65 74 20 63 6f 6d 70 61 72 65 2d 72 65 (let compare-re
5c80: 73 74 20 28 28 69 20 30 29 29 20 3b 20 63 6f 6d st ((i 0)) ; com
5c90: 70 61 72 65 20 78 5b 69 2e 2e 6e 2d 31 5d 20 79 pare x[i..n-1] y
5ca0: 5b 69 2e 2e 6e 2d 31 5d 0a 20 20 20 20 20 20 20 [i..n-1].
5cb0: 20 20 20 20 20 20 28 69 66 20 28 3d 20 69 20 6e (if (= i n
5cc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5cd0: 20 20 20 28 69 6e 74 65 67 65 72 2d 63 6f 6d 70 (integer-comp
5ce0: 61 72 65 20 6e 78 20 6e 79 29 0a 20 20 20 20 20 are nx ny).
5cf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 66 (ref
5d00: 69 6e 65 2d 63 6f 6d 70 61 72 65 20 28 63 6f 6d ine-compare (com
5d10: 70 61 72 65 20 28 72 65 66 20 78 20 69 29 20 28 pare (ref x i) (
5d20: 72 65 66 20 79 20 69 29 29 0a 20 20 20 20 20 20 ref y i)).
5d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d40: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 (comp
5d50: 61 72 65 2d 72 65 73 74 20 28 2b 20 69 20 31 29 are-rest (+ i 1)
5d60: 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a 20 ))))))). .
5d70: 20 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 65 ; for conve
5d80: 6e 69 65 6e 63 65 0a 20 20 20 20 20 20 28 28 20 nience. ((
5d90: 20 20 20 20 20 20 20 78 20 79 20 73 69 7a 65 20 x y size
5da0: 72 65 66 29 0a 20 20 20 20 20 20 20 28 76 65 63 ref). (vec
5db0: 74 6f 72 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 6c tor-compare-as-l
5dc0: 69 73 74 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 ist default-comp
5dd0: 61 72 65 20 78 20 79 20 73 69 7a 65 20 20 20 20 are x y size
5de0: 20 20 20 20 20 20 72 65 66 29 29 0a 20 20 20 20 ref)).
5df0: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 20 ((compare x y
5e00: 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 ).
5e10: 20 20 20 28 76 65 63 74 6f 72 2d 63 6f 6d 70 61 (vector-compa
5e20: 72 65 2d 61 73 2d 6c 69 73 74 20 63 6f 6d 70 61 re-as-list compa
5e30: 72 65 20 20 20 20 20 20 20 20 20 78 20 79 20 76 re x y v
5e40: 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 63 ector-length vec
5e50: 74 6f 72 2d 72 65 66 29 29 0a 20 20 20 20 20 20 tor-ref)).
5e60: 28 28 20 20 20 20 20 20 20 20 78 20 79 20 20 20 (( x y
5e70: 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
5e80: 20 28 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 65 (vector-compare
5e90: 2d 61 73 2d 6c 69 73 74 20 64 65 66 61 75 6c 74 -as-list default
5ea0: 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 76 65 63 -compare x y vec
5eb0: 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 63 74 6f tor-length vecto
5ec0: 72 2d 72 65 66 29 29 29 29 29 0a 0a 0a 3b 20 64 r-ref)))))...; d
5ed0: 65 66 61 75 6c 74 20 63 6f 6d 70 61 72 65 0a 0a efault compare..
5ee0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 65 66 61 ;; (define (defa
5ef0: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 ult-compare x y)
5f00: 0a 3b 3b 20 20 20 28 73 65 6c 65 63 74 2d 63 6f .;; (select-co
5f10: 6d 70 61 72 65 20 0a 3b 3b 20 20 20 20 78 20 79 mpare .;; x y
5f20: 0a 3b 3b 20 20 20 20 28 6e 75 6c 6c 3f 20 20 20 .;; (null?
5f30: 20 30 29 0a 3b 3b 20 20 20 20 28 70 61 69 72 3f 0).;; (pair?
5f40: 20 20 20 20 28 64 65 66 61 75 6c 74 2d 63 6f 6d (default-com
5f50: 70 61 72 65 20 28 63 61 72 20 78 29 20 28 63 61 pare (car x) (ca
5f60: 72 20 79 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 r y)).;;
5f70: 20 20 20 20 20 20 28 64 65 66 61 75 6c 74 2d 63 (default-c
5f80: 6f 6d 70 61 72 65 20 28 63 64 72 20 78 29 20 28 ompare (cdr x) (
5f90: 63 64 72 20 79 29 29 29 0a 3b 3b 20 20 20 20 28 cdr y))).;; (
5fa0: 62 6f 6f 6c 65 61 6e 3f 20 28 62 6f 6f 6c 65 61 boolean? (boolea
5fb0: 6e 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 29 0a n-compare x y)).
5fc0: 3b 3b 20 20 20 20 28 63 68 61 72 3f 20 20 20 20 ;; (char?
5fd0: 28 63 68 61 72 2d 63 6f 6d 70 61 72 65 20 20 20 (char-compare
5fe0: 20 78 20 79 29 29 0a 3b 3b 20 20 20 20 28 73 74 x y)).;; (st
5ff0: 72 69 6e 67 3f 20 20 28 73 74 72 69 6e 67 2d 63 ring? (string-c
6000: 6f 6d 70 61 72 65 20 20 78 20 79 29 29 0a 3b 3b ompare x y)).;;
6010: 20 20 20 20 28 73 79 6d 62 6f 6c 3f 20 20 28 73 (symbol? (s
6020: 79 6d 62 6f 6c 2d 63 6f 6d 70 61 72 65 20 20 78 ymbol-compare x
6030: 20 79 29 29 0a 3b 3b 20 20 20 20 28 6e 75 6d 62 y)).;; (numb
6040: 65 72 3f 20 20 28 6e 75 6d 62 65 72 2d 63 6f 6d er? (number-com
6050: 70 61 72 65 20 20 78 20 79 29 29 0a 3b 3b 20 20 pare x y)).;;
6060: 20 20 28 76 65 63 74 6f 72 3f 20 20 28 76 65 63 (vector? (vec
6070: 74 6f 72 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 tor-compare defa
6080: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 ult-compare x y)
6090: 29 0a 3b 3b 20 20 20 20 28 65 6c 73 65 20 28 65 ).;; (else (e
60a0: 72 72 6f 72 20 22 75 6e 72 65 63 6f 67 6e 69 7a rror "unrecogniz
60b0: 65 64 20 74 79 70 65 20 69 6e 20 64 65 66 61 75 ed type in defau
60c0: 6c 74 2d 63 6f 6d 70 61 72 65 22 20 78 20 79 29 lt-compare" x y)
60d0: 29 29 29 0a 0a 3b 20 4e 6f 74 65 20 74 68 61 74 )))..; Note that
60e0: 20 77 65 20 70 61 73 73 20 64 65 66 61 75 6c 74 we pass default
60f0: 2d 63 6f 6d 70 61 72 65 20 74 6f 20 63 6f 6d 70 -compare to comp
6100: 61 72 65 2d 7b 70 61 69 72 2c 76 65 63 74 6f 72 are-{pair,vector
6110: 7d 20 65 78 70 6c 69 63 74 6c 79 2e 0a 3b 20 54 } explictly..; T
6120: 68 69 73 20 6d 61 6b 65 73 20 73 75 72 65 20 72 his makes sure r
6130: 65 63 75 72 73 69 6f 6e 20 70 72 6f 63 65 65 64 ecursion proceed
6140: 73 20 77 69 74 68 20 74 68 69 73 20 64 65 66 61 s with this defa
6150: 75 6c 74 2d 63 6f 6d 70 61 72 65 2c 20 77 68 69 ult-compare, whi
6160: 63 68 20 0a 3b 20 6e 65 65 64 20 6e 6f 74 20 62 ch .; need not b
6170: 65 20 74 68 65 20 6f 6e 65 20 69 6e 20 74 68 65 e the one in the
6180: 20 6c 65 78 69 63 61 6c 20 73 63 6f 70 65 20 6f lexical scope o
6190: 66 20 63 6f 6d 70 61 72 65 2d 7b 70 61 69 72 2c f compare-{pair,
61a0: 76 65 63 74 6f 72 7d 2e 0a 0a 0a 3b 20 64 65 62 vector}....; deb
61b0: 75 67 20 63 6f 6d 70 61 72 65 0a 0a 28 64 65 66 ug compare..(def
61c0: 69 6e 65 20 28 64 65 62 75 67 2d 63 6f 6d 70 61 ine (debug-compa
61d0: 72 65 20 63 29 0a 20 20 0a 20 20 28 64 65 66 69 re c). . (defi
61e0: 6e 65 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 ne (checked-valu
61f0: 65 20 63 20 78 20 79 29 0a 20 20 20 20 28 6c 65 e c x y). (le
6200: 74 20 28 28 63 2d 78 79 20 28 63 20 78 20 79 29 t ((c-xy (c x y)
6210: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 )). (if (or
6220: 20 28 65 71 76 3f 20 63 2d 78 79 20 2d 31 29 20 (eqv? c-xy -1)
6230: 28 65 71 76 3f 20 63 2d 78 79 20 30 29 20 28 65 (eqv? c-xy 0) (e
6240: 71 76 3f 20 63 2d 78 79 20 31 29 29 0a 20 20 20 qv? c-xy 1)).
6250: 20 20 20 20 20 20 20 63 2d 78 79 0a 20 20 20 20 c-xy.
6260: 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 63 6f (error "co
6270: 6d 70 61 72 65 20 76 61 6c 75 65 20 6e 6f 74 20 mpare value not
6280: 69 6e 20 7b 2d 31 2c 30 2c 31 7d 22 20 63 2d 78 in {-1,0,1}" c-x
6290: 79 20 28 6c 69 73 74 20 63 20 78 20 79 29 29 29 y (list c x y)))
62a0: 29 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 )). . (define
62b0: 28 72 61 6e 64 6f 6d 2d 62 6f 6f 6c 65 61 6e 29 (random-boolean)
62c0: 0a 20 20 20 20 28 7a 65 72 6f 3f 20 28 72 61 6e . (zero? (ran
62d0: 64 6f 6d 2d 69 6e 74 65 67 65 72 20 32 29 29 29 dom-integer 2)))
62e0: 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 71 20 . . (define q
62f0: 3b 20 28 75 20 76 20 77 29 20 73 75 63 68 20 74 ; (u v w) such t
6300: 68 61 74 20 75 20 3c 3d 20 76 2c 20 76 20 3c 3d hat u <= v, v <=
6310: 20 77 2c 20 61 6e 64 20 6e 6f 74 20 75 20 3c 3d w, and not u <=
6320: 20 77 0a 20 20 20 20 27 23 28 0a 20 20 20 20 20 w. '#(.
6330: 20 20 3b 78 20 3c 20 79 20 20 20 78 20 3d 20 79 ;x < y x = y
6340: 20 20 20 78 20 3e 20 79 20 20 20 5b 78 20 3c 20 x > y [x <
6350: 7a 5d 0a 20 20 20 20 20 20 20 30 20 20 20 20 20 z]. 0
6360: 20 20 30 20 20 20 20 20 20 20 30 20 20 20 20 3b 0 0 ;
6370: 20 79 20 3c 20 7a 0a 20 20 20 20 20 20 20 20 20 y < z.
6380: 20 20 20 20 20 20 30 20 20 20 20 28 7a 20 79 20 0 (z y
6390: 78 29 20 28 7a 20 79 20 78 29 20 3b 20 79 20 3d x) (z y x) ; y =
63a0: 20 7a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 z.
63b0: 20 20 30 20 20 20 20 28 7a 20 79 20 78 29 20 28 0 (z y x) (
63c0: 7a 20 79 20 78 29 20 3b 20 79 20 3e 20 7a 0a 20 z y x) ; y > z.
63d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
63e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 78 ;x
63f0: 20 3c 20 79 20 20 20 78 20 3d 20 79 20 20 20 78 < y x = y x
6400: 20 3e 20 79 20 20 20 5b 78 20 3d 20 7a 5d 0a 20 > y [x = z].
6410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 79 (y
6420: 20 7a 20 78 29 20 28 7a 20 78 20 79 29 20 20 20 z x) (z x y)
6430: 20 30 20 20 20 20 3b 20 79 20 3c 20 7a 0a 20 20 0 ; y < z.
6440: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 79 20 (y
6450: 7a 20 78 29 20 20 20 20 30 20 20 20 20 28 78 20 z x) 0 (x
6460: 7a 20 79 29 20 3b 20 79 20 3d 20 7a 0a 20 20 20 z y) ; y = z.
6470: 20 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 0
6480: 20 28 79 20 78 20 7a 29 20 28 78 20 7a 20 79 29 (y x z) (x z y)
6490: 20 3b 20 79 20 3e 20 7a 0a 20 20 20 20 20 20 20 ; y > z.
64a0: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
64b0: 20 20 20 20 20 20 20 20 3b 78 20 3c 20 79 20 20 ;x < y
64c0: 20 78 20 3d 20 79 20 20 20 78 20 3e 20 79 20 20 x = y x > y
64d0: 20 5b 78 20 3e 20 7a 5d 0a 20 20 20 20 20 20 20 [x > z].
64e0: 20 20 20 20 20 20 20 20 28 78 20 79 20 7a 29 20 (x y z)
64f0: 28 78 20 79 20 7a 29 20 20 20 20 30 20 20 20 20 (x y z) 0
6500: 3b 20 79 20 3c 20 7a 0a 20 20 20 20 20 20 20 20 ; y < z.
6510: 20 20 20 20 20 20 20 28 78 20 79 20 7a 29 20 28 (x y z) (
6520: 78 20 79 20 7a 29 20 20 20 20 30 20 20 20 20 3b x y z) 0 ;
6530: 20 79 20 3d 20 7a 0a 20 20 20 20 20 20 20 20 20 y = z.
6540: 20 20 20 20 20 20 30 20 20 20 20 20 20 20 30 20 0 0
6550: 20 20 20 20 20 20 30 20 20 20 20 3b 20 79 20 3e 0 ; y >
6560: 20 7a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 z.
6570: 20 20 29 29 0a 20 20 0a 20 20 28 6c 65 74 20 28 )). . (let (
6580: 28 7a 3f 20 23 66 29 20 28 7a 20 23 66 29 29 20 (z? #f) (z #f))
6590: 3b 20 73 74 6f 72 65 64 20 65 6c 65 6d 65 6e 74 ; stored element
65a0: 20 66 72 6f 6d 20 70 72 65 76 69 6f 75 73 20 63 from previous c
65b0: 61 6c 6c 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 all. (lambda
65c0: 28 78 20 79 29 0a 20 20 20 20 20 20 28 6c 65 74 (x y). (let
65d0: 20 28 28 63 2d 78 78 20 28 63 68 65 63 6b 65 64 ((c-xx (checked
65e0: 2d 76 61 6c 75 65 20 63 20 78 20 78 29 29 0a 20 -value c x x)).
65f0: 20 20 20 20 20 20 20 20 20 20 20 28 63 2d 79 79 (c-yy
6600: 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 20 (checked-value
6610: 63 20 79 20 79 29 29 0a 20 20 20 20 20 20 20 20 c y y)).
6620: 20 20 20 20 28 63 2d 78 79 20 28 63 68 65 63 6b (c-xy (check
6630: 65 64 2d 76 61 6c 75 65 20 63 20 78 20 79 29 29 ed-value c x y))
6640: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 2d . (c-
6650: 79 78 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 yx (checked-valu
6660: 65 20 63 20 79 20 78 29 29 29 0a 20 20 20 20 20 e c y x))).
6670: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 7a 65 72 (if (not (zer
6680: 6f 3f 20 63 2d 78 78 29 29 0a 20 20 20 20 20 20 o? c-xx)).
6690: 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 63 6f (error "co
66a0: 6d 70 61 72 65 20 65 72 72 6f 72 3a 20 6e 6f 74 mpare error: not
66b0: 20 72 65 66 6c 65 78 69 76 65 22 20 63 20 78 29 reflexive" c x)
66c0: 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e ). (if (n
66d0: 6f 74 20 28 7a 65 72 6f 3f 20 63 2d 79 79 29 29 ot (zero? c-yy))
66e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 . (er
66f0: 72 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 ror "compare err
6700: 6f 72 3a 20 6e 6f 74 20 72 65 66 6c 65 78 69 76 or: not reflexiv
6710: 65 22 20 63 20 79 29 29 0a 20 20 20 20 20 20 20 e" c y)).
6720: 20 28 69 66 20 28 6e 6f 74 20 28 7a 65 72 6f 3f (if (not (zero?
6730: 20 28 2b 20 63 2d 78 79 20 63 2d 79 78 29 29 29 (+ c-xy c-yx)))
6740: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 . (er
6750: 72 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 ror "compare err
6760: 6f 72 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 79 6d or: not anti-sym
6770: 6d 65 74 72 69 63 22 20 63 20 78 20 79 29 29 0a metric" c x y)).
6780: 20 20 20 20 20 20 20 20 28 69 66 20 7a 3f 0a 20 (if z?.
6790: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
67a0: 28 28 63 2d 78 7a 20 28 63 68 65 63 6b 65 64 2d ((c-xz (checked-
67b0: 76 61 6c 75 65 20 63 20 78 20 7a 29 29 0a 20 20 value c x z)).
67c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67d0: 28 63 2d 7a 78 20 28 63 68 65 63 6b 65 64 2d 76 (c-zx (checked-v
67e0: 61 6c 75 65 20 63 20 7a 20 78 29 29 0a 20 20 20 alue c z x)).
67f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6800: 63 2d 79 7a 20 28 63 68 65 63 6b 65 64 2d 76 61 c-yz (checked-va
6810: 6c 75 65 20 63 20 79 20 7a 29 29 0a 20 20 20 20 lue c y z)).
6820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
6830: 2d 7a 79 20 28 63 68 65 63 6b 65 64 2d 76 61 6c -zy (checked-val
6840: 75 65 20 63 20 7a 20 79 29 29 29 0a 20 20 20 20 ue c z y))).
6850: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
6860: 6f 74 20 28 7a 65 72 6f 3f 20 28 2b 20 63 2d 78 ot (zero? (+ c-x
6870: 7a 20 63 2d 7a 78 29 29 29 0a 20 20 20 20 20 20 z c-zx))).
6880: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
6890: 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f or "compare erro
68a0: 72 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 79 6d 6d r: not anti-symm
68b0: 65 74 72 69 63 22 20 63 20 78 20 7a 29 29 0a 20 etric" c x z)).
68c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
68d0: 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 28 2b 20 (not (zero? (+
68e0: 63 2d 79 7a 20 63 2d 7a 79 29 29 29 0a 20 20 20 c-yz c-zy))).
68f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6900: 65 72 72 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 error "compare e
6910: 72 72 6f 72 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 rror: not anti-s
6920: 79 6d 6d 65 74 72 69 63 22 20 63 20 79 20 7a 29 ymmetric" c y z)
6930: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6940: 28 6c 65 74 20 28 28 69 6a 6b 20 28 76 65 63 74 (let ((ijk (vect
6950: 6f 72 2d 72 65 66 20 71 20 28 2b 20 63 2d 78 79 or-ref q (+ c-xy
6960: 20 28 2a 20 33 20 63 2d 79 7a 29 20 28 2a 20 39 (* 3 c-yz) (* 9
6970: 20 63 2d 78 7a 29 20 31 33 29 29 29 29 0a 20 20 c-xz) 13)))).
6980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
6990: 66 20 28 6c 69 73 74 3f 20 69 6a 6b 29 0a 20 20 f (list? ijk).
69a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69b0: 20 20 28 61 70 70 6c 79 20 65 72 72 6f 72 0a 20 (apply error.
69c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69d0: 20 20 20 20 20 20 20 20 20 20 22 63 6f 6d 70 61 "compa
69e0: 72 65 20 65 72 72 6f 72 3a 20 6e 6f 74 20 74 72 re error: not tr
69f0: 61 6e 73 69 74 69 76 65 22 0a 20 20 20 20 20 20 ansitive".
6a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a10: 20 20 20 20 20 63 20 0a 20 20 20 20 20 20 20 20 c .
6a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a30: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
6a40: 28 69 29 20 28 63 61 73 65 20 69 20 28 28 78 29 (i) (case i ((x)
6a50: 20 78 29 20 28 28 79 29 20 79 29 20 28 28 7a 29 x) ((y) y) ((z)
6a60: 20 7a 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 z))).
6a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a80: 20 20 20 20 20 20 69 6a 6b 29 29 29 29 29 0a 20 ijk))))).
6a90: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
6aa0: 20 7a 3f 20 23 74 29 29 0a 20 20 20 20 20 20 20 z? #t)).
6ab0: 20 28 73 65 74 21 20 7a 20 28 69 66 20 28 72 61 (set! z (if (ra
6ac0: 6e 64 6f 6d 2d 62 6f 6f 6c 65 61 6e 29 20 78 20 ndom-boolean) x
6ad0: 79 29 29 20 3b 20 72 61 6e 64 6f 6d 69 7a 65 64 y)) ; randomized
6ae0: 20 74 65 73 74 69 6e 67 0a 20 20 20 20 20 20 20 testing.
6af0: 20 63 2d 78 79 29 29 29 29 0a 20 20 0a 20 20 29 c-xy)))). . )
6b00: 0a .