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 20 20 0a 20 20 3b 3b 20 28 53 52 de)). . ;; (SR
0570: 46 49 2d 32 33 2d 65 72 72 6f 72 2d 3e 52 36 52 FI-23-error->R6R
0580: 53 20 22 28 6c 69 62 72 61 72 79 20 28 73 72 66 S "(library (srf
0590: 69 20 73 36 37 20 63 6f 6d 70 61 72 65 2d 70 72 i s67 compare-pr
05a0: 6f 63 65 64 75 72 65 73 29 29 22 0a 20 20 3b 3b ocedures))". ;;
05b0: 20 20 28 69 6e 63 6c 75 64 65 2f 72 65 73 6f 6c (include/resol
05c0: 76 65 20 28 22 73 72 66 69 22 20 22 73 36 37 22 ve ("srfi" "s67"
05d0: 29 20 22 63 6f 6d 70 61 72 65 2e 73 73 22 29 29 ) "compare.ss"))
05e0: 0a 0a 3b 20 28 64 65 66 69 6e 65 20 63 75 72 72 ..; (define curr
05f0: 65 6e 74 2d 63 6f 6d 70 61 72 65 20 28 6d 61 6b ent-compare (mak
0600: 65 2d 70 61 72 61 6d 65 74 65 72 20 64 65 66 61 e-parameter defa
0610: 75 6c 74 2d 63 6f 6d 70 61 72 65 29 29 0a 3b 20 ult-compare)).;
0620: 28 70 72 6f 76 69 64 65 20 63 75 72 72 65 6e 74 (provide current
0630: 2d 63 6f 6d 70 61 72 65 29 0a 0a 3b 20 43 6f 70 -compare)..; Cop
0640: 79 72 69 67 68 74 20 28 63 29 20 32 30 30 35 20 yright (c) 2005
0650: 53 65 62 61 73 74 69 61 6e 20 45 67 6e 65 72 20 Sebastian Egner
0660: 61 6e 64 20 4a 65 6e 73 20 41 78 65 6c 20 53 7b and Jens Axel S{
0670: 5c 6f 7d 67 61 61 72 64 2e 0a 3b 20 0a 3b 20 50 \o}gaard..; .; P
0680: 65 72 6d 69 73 73 69 6f 6e 20 69 73 20 68 65 72 ermission is her
0690: 65 62 79 20 67 72 61 6e 74 65 64 2c 20 66 72 65 eby granted, fre
06a0: 65 20 6f 66 20 63 68 61 72 67 65 2c 20 74 6f 20 e of charge, to
06b0: 61 6e 79 20 70 65 72 73 6f 6e 20 6f 62 74 61 69 any person obtai
06c0: 6e 69 6e 67 0a 3b 20 61 20 63 6f 70 79 20 6f 66 ning.; a copy of
06d0: 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 20 61 this software a
06e0: 6e 64 20 61 73 73 6f 63 69 61 74 65 64 20 64 6f nd associated do
06f0: 63 75 6d 65 6e 74 61 74 69 6f 6e 20 66 69 6c 65 cumentation file
0700: 73 20 28 74 68 65 0a 3b 20 60 60 53 6f 66 74 77 s (the.; ``Softw
0710: 61 72 65 27 27 29 2c 20 74 6f 20 64 65 61 6c 20 are''), to deal
0720: 69 6e 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 in the Software
0730: 77 69 74 68 6f 75 74 20 72 65 73 74 72 69 63 74 without restrict
0740: 69 6f 6e 2c 20 69 6e 63 6c 75 64 69 6e 67 0a 3b ion, including.;
0750: 20 77 69 74 68 6f 75 74 20 6c 69 6d 69 74 61 74 without limitat
0760: 69 6f 6e 20 74 68 65 20 72 69 67 68 74 73 20 74 ion the rights t
0770: 6f 20 75 73 65 2c 20 63 6f 70 79 2c 20 6d 6f 64 o use, copy, mod
0780: 69 66 79 2c 20 6d 65 72 67 65 2c 20 70 75 62 6c ify, merge, publ
0790: 69 73 68 2c 0a 3b 20 64 69 73 74 72 69 62 75 74 ish,.; distribut
07a0: 65 2c 20 73 75 62 6c 69 63 65 6e 73 65 2c 20 61 e, sublicense, a
07b0: 6e 64 2f 6f 72 20 73 65 6c 6c 20 63 6f 70 69 65 nd/or sell copie
07c0: 73 20 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 s of the Softwar
07d0: 65 2c 20 61 6e 64 20 74 6f 0a 3b 20 70 65 72 6d e, and to.; perm
07e0: 69 74 20 70 65 72 73 6f 6e 73 20 74 6f 20 77 68 it persons to wh
07f0: 6f 6d 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 om the Software
0800: 69 73 20 66 75 72 6e 69 73 68 65 64 20 74 6f 20 is furnished to
0810: 64 6f 20 73 6f 2c 20 73 75 62 6a 65 63 74 20 74 do so, subject t
0820: 6f 0a 3b 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e o.; the followin
0830: 67 20 63 6f 6e 64 69 74 69 6f 6e 73 3a 0a 3b 20 g conditions:.;
0840: 0a 3b 20 54 68 65 20 61 62 6f 76 65 20 63 6f 70 .; The above cop
0850: 79 72 69 67 68 74 20 6e 6f 74 69 63 65 20 61 6e yright notice an
0860: 64 20 74 68 69 73 20 70 65 72 6d 69 73 73 69 6f d this permissio
0870: 6e 20 6e 6f 74 69 63 65 20 73 68 61 6c 6c 20 62 n notice shall b
0880: 65 0a 3b 20 69 6e 63 6c 75 64 65 64 20 69 6e 20 e.; included in
0890: 61 6c 6c 20 63 6f 70 69 65 73 20 6f 72 20 73 75 all copies or su
08a0: 62 73 74 61 6e 74 69 61 6c 20 70 6f 72 74 69 6f bstantial portio
08b0: 6e 73 20 6f 66 20 74 68 65 20 53 6f 66 74 77 61 ns of the Softwa
08c0: 72 65 2e 0a 3b 20 0a 3b 20 54 48 45 20 53 4f 46 re..; .; THE SOF
08d0: 54 57 41 52 45 20 49 53 20 50 52 4f 56 49 44 45 TWARE IS PROVIDE
08e0: 44 20 60 60 41 53 20 49 53 27 27 2c 20 57 49 54 D ``AS IS'', WIT
08f0: 48 4f 55 54 20 57 41 52 52 41 4e 54 59 20 4f 46 HOUT WARRANTY OF
0900: 20 41 4e 59 20 4b 49 4e 44 2c 0a 3b 20 45 58 50 ANY KIND,.; EXP
0910: 52 45 53 53 20 4f 52 20 49 4d 50 4c 49 45 44 2c RESS OR IMPLIED,
0920: 20 49 4e 43 4c 55 44 49 4e 47 20 42 55 54 20 4e INCLUDING BUT N
0930: 4f 54 20 4c 49 4d 49 54 45 44 20 54 4f 20 54 48 OT LIMITED TO TH
0940: 45 20 57 41 52 52 41 4e 54 49 45 53 20 4f 46 0a E WARRANTIES OF.
0950: 3b 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 ; MERCHANTABILIT
0960: 59 2c 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 Y, FITNESS FOR A
0970: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0980: 4f 53 45 20 41 4e 44 0a 3b 20 4e 4f 4e 49 4e 46 OSE AND.; NONINF
0990: 52 49 4e 47 45 4d 45 4e 54 2e 20 49 4e 20 4e 4f RINGEMENT. IN NO
09a0: 20 45 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 EVENT SHALL THE
09b0: 20 41 55 54 48 4f 52 53 20 4f 52 20 43 4f 50 59 AUTHORS OR COPY
09c0: 52 49 47 48 54 20 48 4f 4c 44 45 52 53 20 42 45 RIGHT HOLDERS BE
09d0: 0a 3b 20 4c 49 41 42 4c 45 20 46 4f 52 20 41 4e .; LIABLE FOR AN
09e0: 59 20 43 4c 41 49 4d 2c 20 44 41 4d 41 47 45 53 Y CLAIM, DAMAGES
09f0: 20 4f 52 20 4f 54 48 45 52 20 4c 49 41 42 49 4c OR OTHER LIABIL
0a00: 49 54 59 2c 20 57 48 45 54 48 45 52 20 49 4e 20 ITY, WHETHER IN
0a10: 41 4e 20 41 43 54 49 4f 4e 0a 3b 20 4f 46 20 43 AN ACTION.; OF C
0a20: 4f 4e 54 52 41 43 54 2c 20 54 4f 52 54 20 4f 52 ONTRACT, TORT OR
0a30: 20 4f 54 48 45 52 57 49 53 45 2c 20 41 52 49 53 OTHERWISE, ARIS
0a40: 49 4e 47 20 46 52 4f 4d 2c 20 4f 55 54 20 4f 46 ING FROM, OUT OF
0a50: 20 4f 52 20 49 4e 20 43 4f 4e 4e 45 43 54 49 4f OR IN CONNECTIO
0a60: 4e 0a 3b 20 57 49 54 48 20 54 48 45 20 53 4f 46 N.; WITH THE SOF
0a70: 54 57 41 52 45 20 4f 52 20 54 48 45 20 55 53 45 TWARE OR THE USE
0a80: 20 4f 52 20 4f 54 48 45 52 20 44 45 41 4c 49 4e OR OTHER DEALIN
0a90: 47 53 20 49 4e 20 54 48 45 20 53 4f 46 54 57 41 GS IN THE SOFTWA
0aa0: 52 45 2e 0a 3b 20 0a 3b 20 2d 2d 2d 2d 2d 2d 2d RE..; .; -------
0ab0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0ac0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0ad0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0ae0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0af0: 0a 3b 20 0a 3b 20 43 6f 6d 70 61 72 65 20 70 72 .; .; Compare pr
0b00: 6f 63 65 64 75 72 65 73 20 53 52 46 49 20 28 72 ocedures SRFI (r
0b10: 65 66 65 72 65 6e 63 65 20 69 6d 70 6c 65 6d 65 eference impleme
0b20: 6e 74 61 74 69 6f 6e 29 0a 3b 20 53 65 62 61 73 ntation).; Sebas
0b30: 74 69 61 6e 2e 45 67 6e 65 72 40 70 68 69 6c 69 tian.Egner@phili
0b40: 70 73 2e 63 6f 6d 2c 20 4a 65 6e 73 61 78 65 6c ps.com, Jensaxel
0b50: 40 73 6f 65 67 61 61 72 64 2e 6e 65 74 0a 3b 20 @soegaard.net.;
0b60: 68 69 73 74 6f 72 79 20 6f 66 20 74 68 69 73 20 history of this
0b70: 66 69 6c 65 3a 0a 3b 20 20 20 53 45 2c 20 31 34 file:.; SE, 14
0b80: 2d 4f 63 74 2d 32 30 30 34 3a 20 66 69 72 73 74 -Oct-2004: first
0b90: 20 76 65 72 73 69 6f 6e 0a 3b 20 20 20 53 45 2c version.; SE,
0ba0: 20 31 38 2d 4f 63 74 2d 32 30 30 34 3a 20 31 73 18-Oct-2004: 1s
0bb0: 74 20 72 65 64 65 73 69 67 6e 3a 20 61 78 69 6f t redesign: axio
0bc0: 6d 73 20 66 6f 72 20 27 63 6f 6d 70 61 72 65 20 ms for 'compare
0bd0: 66 75 6e 63 74 69 6f 6e 27 0a 3b 20 20 20 53 45 function'.; SE
0be0: 2c 20 32 39 2d 4f 63 74 2d 32 30 30 34 3a 20 32 , 29-Oct-2004: 2
0bf0: 6e 64 20 72 65 64 65 73 69 67 6e 3a 20 68 69 67 nd redesign: hig
0c00: 68 65 72 20 6f 72 64 65 72 20 72 65 76 65 72 73 her order revers
0c10: 65 2f 6d 61 70 2f 72 65 66 69 6e 65 2f 75 6e 69 e/map/refine/uni
0c20: 74 65 0a 3b 20 20 20 53 45 2c 20 20 32 2d 4e 6f te.; SE, 2-No
0c30: 76 2d 32 30 30 34 3a 20 33 72 64 20 72 65 64 65 v-2004: 3rd rede
0c40: 73 69 67 6e 3a 20 6d 61 63 72 6f 73 20 63 6f 6e sign: macros con
0c50: 64 2f 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 d/refine-compare
0c60: 20 72 65 70 6c 61 63 65 20 68 2e 6f 2e 66 27 73 replace h.o.f's
0c70: 0a 3b 20 20 20 53 45 2c 20 31 30 2d 4e 6f 76 2d .; SE, 10-Nov-
0c80: 32 30 30 34 3a 20 28 69 6d 2c 72 65 29 20 72 65 2004: (im,re) re
0c90: 70 6c 61 63 65 64 20 62 79 20 28 72 65 2c 69 6d placed by (re,im
0ca0: 29 20 69 6e 20 63 6f 6d 70 6c 65 78 2d 63 6f 6d ) in complex-com
0cb0: 70 61 72 65 0a 3b 20 20 20 53 45 2c 20 31 31 2d pare.; SE, 11-
0cc0: 4e 6f 76 2d 32 30 30 34 3a 20 63 61 73 65 2d 63 Nov-2004: case-c
0cd0: 6f 6d 70 61 72 65 20 62 79 20 63 61 73 65 20 28 ompare by case (
0ce0: 6e 6f 74 20 62 79 20 63 6f 6e 64 29 3b 20 73 65 not by cond); se
0cf0: 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 61 64 64 lect-compare add
0d00: 65 64 0a 3b 20 20 20 53 45 2c 20 31 32 2d 4a 61 ed.; SE, 12-Ja
0d10: 6e 2d 32 30 30 35 3a 20 70 61 69 72 2d 63 6f 6d n-2005: pair-com
0d20: 70 61 72 65 2d 63 64 72 0a 3b 20 20 20 53 45 2c pare-cdr.; SE,
0d30: 20 31 35 2d 46 65 62 2d 32 30 30 35 3a 20 73 74 15-Feb-2005: st
0d40: 72 69 63 74 65 72 20 74 79 70 69 6e 67 20 66 6f ricter typing fo
0d50: 72 20 63 6f 6d 70 61 72 65 2d 3c 74 79 70 65 3e r compare-<type>
0d60: 3b 20 70 61 69 72 77 69 73 65 2d 6e 6f 74 3d 3f ; pairwise-not=?
0d70: 0a 3b 20 20 20 53 45 2c 20 31 36 2d 46 65 62 2d .; SE, 16-Feb-
0d80: 32 30 30 35 3a 20 63 61 73 65 2d 63 6f 6d 70 61 2005: case-compa
0d90: 72 65 20 2d 3e 20 69 66 2d 63 6f 6d 70 61 72 65 re -> if-compare
0da0: 20 2d 3e 20 69 66 33 3b 20 3c 3f 20 3c 2f 3c 3f -> if3; <? </<?
0db0: 20 63 68 61 69 6e 3c 3f 20 65 74 63 2e 0a 3b 20 chain<? etc..;
0dc0: 20 20 4a 53 2c 20 32 34 2d 46 65 62 2d 32 30 30 JS, 24-Feb-200
0dd0: 35 3a 20 73 65 6c 65 63 74 69 6f 6e 2d 63 6f 6d 5: selection-com
0de0: 70 61 72 65 20 61 64 64 65 64 0a 3b 20 20 20 53 pare added.; S
0df0: 45 2c 20 32 35 2d 46 65 62 2d 32 30 30 35 3a 20 E, 25-Feb-2005:
0e00: 73 65 6c 65 63 74 69 6f 6e 2d 63 6f 6d 70 61 72 selection-compar
0e10: 65 20 2d 3e 20 6b 74 68 2d 6c 61 72 67 65 73 74 e -> kth-largest
0e20: 20 6d 6f 64 69 66 69 65 64 3b 20 69 66 3c 3f 20 modified; if<?
0e30: 65 74 63 2e 0a 3b 20 20 20 4a 53 2c 20 32 38 2d etc..; JS, 28-
0e40: 46 65 62 2d 32 30 30 35 3a 20 6b 74 68 2d 6c 61 Feb-2005: kth-la
0e50: 72 67 65 73 74 20 6d 6f 64 69 66 69 65 64 20 2d rgest modified -
0e60: 20 69 73 20 22 73 74 61 62 6c 65 22 20 6e 6f 77 is "stable" now
0e70: 0a 3b 20 20 20 53 45 2c 20 32 38 2d 46 65 62 2d .; SE, 28-Feb-
0e80: 32 30 30 35 3a 20 73 69 6d 70 6c 69 66 69 65 64 2005: simplified
0e90: 20 70 61 69 72 77 69 73 65 2d 6e 6f 74 3d 3f 2f pairwise-not=?/
0ea0: 6b 74 68 2d 6c 61 72 67 65 73 74 3b 20 6d 69 6e kth-largest; min
0eb0: 2f 6d 61 78 20 64 65 62 75 67 67 65 64 0a 3b 20 /max debugged.;
0ec0: 20 20 53 45 2c 20 30 37 2d 41 70 72 2d 32 30 30 SE, 07-Apr-200
0ed0: 35 3a 20 63 6f 6d 70 61 72 65 2d 62 61 73 65 64 5: compare-based
0ee0: 20 74 79 70 65 20 63 68 65 63 6b 73 20 6d 61 64 type checks mad
0ef0: 65 20 65 78 70 6c 69 63 69 74 0a 3b 20 20 20 53 e explicit.; S
0f00: 45 2c 20 31 38 2d 41 70 72 2d 32 30 30 35 3a 20 E, 18-Apr-2005:
0f10: 61 64 64 65 64 20 28 72 65 6c 3f 20 63 6f 6d 70 added (rel? comp
0f20: 61 72 65 29 20 61 6e 64 20 65 71 3f 2d 74 65 73 are) and eq?-tes
0f30: 74 0a 3b 20 20 20 53 45 2c 20 31 36 2d 4d 61 79 t.; SE, 16-May
0f40: 2d 32 30 30 35 3a 20 6e 61 6d 69 6e 67 20 63 6f -2005: naming co
0f50: 6e 76 65 6e 74 69 6f 6e 20 63 68 61 6e 67 65 64 nvention changed
0f60: 3b 20 63 6f 6d 70 61 72 65 2d 62 79 3c 20 65 74 ; compare-by< et
0f70: 63 2e 20 6f 70 74 69 6f 6e 61 6c 20 78 20 79 0a c. optional x y.
0f80: 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .; =============
0f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fd0: 0a 0a 3b 20 52 65 66 65 72 65 6e 63 65 20 49 6d ..; Reference Im
0fe0: 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 0a 3b 20 3d plementation.; =
0ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1000: 3d 3d 3d 3d 3d 3d 3d 0a 3b 0a 3b 20 69 6e 20 52 =======.;.; in R
1010: 35 52 53 20 28 69 6e 63 6c 75 64 69 6e 67 20 68 5RS (including h
1020: 79 67 69 65 6e 69 63 20 6d 61 63 72 6f 73 29 0a ygienic macros).
1030: 3b 20 20 2b 20 53 52 46 49 2d 31 36 20 28 63 61 ; + SRFI-16 (ca
1040: 73 65 2d 6c 61 6d 62 64 61 29 20 0a 3b 20 20 2b se-lambda) .; +
1050: 20 53 52 46 49 2d 32 33 20 28 65 72 72 6f 72 29 SRFI-23 (error)
1060: 20 0a 3b 20 20 2b 20 53 52 46 49 2d 32 37 20 28 .; + SRFI-27 (
1070: 72 61 6e 64 6f 6d 2d 69 6e 74 65 67 65 72 29 0a random-integer).
1080: 0a 3b 20 49 6d 70 6c 65 6d 65 6e 74 61 74 69 6f .; Implementatio
1090: 6e 20 72 65 6d 61 72 6b 73 3a 0a 3b 20 20 20 2a n remarks:.; *
10a0: 20 49 6e 20 67 65 6e 65 72 61 6c 2c 20 74 68 65 In general, the
10b0: 20 65 6d 70 68 61 73 69 73 20 6f 66 20 74 68 69 emphasis of thi
10c0: 73 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e s implementation
10d0: 20 69 73 20 6f 6e 20 63 6f 72 72 65 63 74 6e 65 is on correctne
10e0: 73 73 0a 3b 20 20 20 20 20 61 6e 64 20 70 6f 72 ss.; and por
10f0: 74 61 62 69 6c 69 74 79 2c 20 6e 6f 74 20 6f 6e tability, not on
1100: 20 65 66 66 69 63 69 65 6e 63 79 2e 0a 3b 20 20 efficiency..;
1110: 20 2a 20 56 61 72 69 61 62 6c 65 20 61 72 69 74 * Variable arit
1120: 79 20 70 72 6f 63 65 64 75 72 65 73 20 61 72 65 y procedures are
1130: 20 65 78 70 72 65 73 73 65 64 20 69 6e 20 74 65 expressed in te
1140: 72 6d 73 20 6f 66 20 63 61 73 65 2d 6c 61 6d 62 rms of case-lamb
1150: 64 61 0a 3b 20 20 20 20 20 69 6e 20 74 68 65 20 da.; in the
1160: 68 6f 70 65 20 74 68 61 74 20 74 68 69 73 20 77 hope that this w
1170: 69 6c 6c 20 70 72 6f 64 75 63 65 20 65 66 66 69 ill produce effi
1180: 63 69 65 6e 74 20 63 6f 64 65 20 66 6f 72 20 74 cient code for t
1190: 68 65 20 63 61 73 65 0a 3b 20 20 20 20 20 77 68 he case.; wh
11a0: 65 72 65 20 74 68 65 20 61 72 69 74 79 20 69 73 ere the arity is
11b0: 20 73 74 61 74 69 63 61 6c 6c 79 20 6b 6e 6f 77 statically know
11c0: 6e 20 61 74 20 74 68 65 20 63 61 6c 6c 20 73 69 n at the call si
11d0: 74 65 2e 0a 3b 20 20 20 2a 20 49 6e 20 70 72 6f te..; * In pro
11e0: 63 65 64 75 72 65 73 20 74 68 61 74 20 61 72 65 cedures that are
11f0: 20 72 65 71 75 69 72 65 64 20 74 6f 20 74 79 70 required to typ
1200: 65 2d 63 68 65 63 6b 20 74 68 65 69 72 20 61 72 e-check their ar
1210: 67 75 6d 65 6e 74 73 2c 0a 3b 20 20 20 20 20 77 guments,.; w
1220: 65 20 75 73 65 20 28 63 6f 6d 70 61 72 65 20 78 e use (compare x
1230: 20 78 29 20 66 6f 72 20 65 78 65 63 75 74 69 6e x) for executin
1240: 67 20 65 78 74 72 61 20 63 68 65 63 6b 73 2e 20 g extra checks.
1250: 54 68 69 73 20 72 65 6c 69 65 73 20 6f 6e 0a 3b This relies on.;
1260: 20 20 20 20 20 74 68 65 20 61 73 73 75 6d 70 74 the assumpt
1270: 69 6f 6e 20 74 68 61 74 20 65 71 3f 20 69 73 20 ion that eq? is
1280: 75 73 65 64 20 74 6f 20 63 61 74 63 68 20 74 68 used to catch th
1290: 69 73 20 63 61 73 65 20 71 75 69 63 6b 6c 79 2e is case quickly.
12a0: 0a 3b 20 20 20 2a 20 43 61 72 65 20 68 61 73 20 .; * Care has
12b0: 62 65 65 6e 20 74 61 6b 65 6e 20 74 6f 20 72 65 been taken to re
12c0: 66 65 72 65 6e 63 65 20 63 6f 6d 70 61 72 69 73 ference comparis
12d0: 6f 6e 20 70 72 6f 63 65 64 75 72 65 73 20 6f 66 on procedures of
12e0: 20 52 35 52 53 0a 3b 20 20 20 20 20 6f 6e 6c 79 R5RS.; only
12f0: 20 61 74 20 74 68 65 20 74 69 6d 65 20 74 68 65 at the time the
1300: 20 6f 70 65 72 61 74 69 6f 6e 73 20 68 65 72 65 operations here
1310: 20 61 72 65 20 62 65 69 6e 67 20 64 65 66 69 6e are being defin
1320: 65 64 2e 20 54 68 69 73 0a 3b 20 20 20 20 20 6d ed. This.; m
1330: 61 6b 65 73 20 69 74 20 70 6f 73 73 69 62 6c 65 akes it possible
1340: 20 74 6f 20 72 65 64 65 66 69 6e 65 20 74 68 65 to redefine the
1350: 73 65 20 6f 70 65 72 61 74 69 6f 6e 73 2c 20 69 se operations, i
1360: 66 20 6e 65 65 64 20 62 65 2e 0a 3b 20 20 20 2a f need be..; *
1370: 20 46 6f 72 20 74 68 65 20 73 61 6b 65 20 6f 66 For the sake of
1380: 20 65 66 66 69 63 69 65 6e 63 79 2c 20 73 6f 6d efficiency, som
1390: 65 20 69 6e 6c 69 6e 69 6e 67 20 68 61 73 20 62 e inlining has b
13a0: 65 65 6e 20 64 6f 6e 65 20 62 79 20 68 61 6e 64 een done by hand
13b0: 2e 0a 3b 20 20 20 20 20 54 68 69 73 20 69 73 20 ..; This is
13c0: 6d 61 69 6e 6c 79 20 65 78 70 72 65 73 73 65 64 mainly expressed
13d0: 20 62 79 20 6d 61 63 72 6f 73 20 70 72 6f 64 75 by macros produ
13e0: 63 69 6e 67 20 64 65 66 69 6e 65 73 2e 0a 3b 20 cing defines..;
13f0: 20 20 2a 20 49 64 65 6e 74 69 66 69 65 72 73 20 * Identifiers
1400: 6f 66 20 74 68 65 20 66 6f 72 6d 20 63 6f 6d 70 of the form comp
1410: 61 72 65 3a 3c 73 6f 6d 65 74 68 69 6e 67 3e 20 are:<something>
1420: 61 72 65 20 70 72 69 76 61 74 65 2e 0a 3b 0a 3b are private..;.;
1430: 20 48 69 6e 74 73 20 66 6f 72 20 6c 6f 77 2d 6c Hints for low-l
1440: 65 76 65 6c 20 69 6d 70 6c 65 6d 65 6e 74 61 74 evel implementat
1450: 69 6f 6e 3a 0a 3b 20 20 20 2a 20 54 68 65 20 62 ion:.; * The b
1460: 61 73 69 73 20 6f 66 20 74 68 69 73 20 53 52 46 asis of this SRF
1470: 49 20 61 72 65 20 74 68 65 20 61 74 6f 6d 69 63 I are the atomic
1480: 20 63 6f 6d 70 61 72 65 20 70 72 6f 63 65 64 75 compare procedu
1490: 72 65 73 2c 20 0a 3b 20 20 20 20 20 69 2e 65 2e res, .; i.e.
14a0: 20 62 6f 6f 6c 65 61 6e 2d 63 6f 6d 70 61 72 65 boolean-compare
14b0: 2c 20 63 68 61 72 2d 63 6f 6d 70 61 72 65 2c 20 , char-compare,
14c0: 65 74 63 2e 20 61 6e 64 20 74 68 65 20 63 6f 6e etc. and the con
14d0: 64 69 74 69 6f 6e 61 6c 73 0a 3b 20 20 20 20 20 ditionals.;
14e0: 69 66 33 2c 20 69 66 3d 3f 2c 20 69 66 3c 3f 20 if3, if=?, if<?
14f0: 65 74 63 2e 2c 20 61 6e 64 20 64 65 66 61 75 6c etc., and defaul
1500: 74 2d 63 6f 6d 70 61 72 65 2e 20 54 68 65 73 65 t-compare. These
1510: 20 73 68 6f 75 6c 64 20 6d 61 6b 65 0a 3b 20 20 should make.;
1520: 20 20 20 6f 70 74 69 6d 61 6c 20 75 73 65 20 6f optimal use o
1530: 66 20 74 68 65 20 61 76 61 69 6c 61 62 6c 65 20 f the available
1540: 74 79 70 65 20 69 6e 66 6f 72 6d 61 74 69 6f 6e type information
1550: 2e 0a 3b 20 20 20 2a 20 46 6f 72 20 74 68 65 20 ..; * For the
1560: 73 61 6b 65 20 6f 66 20 73 70 65 65 64 2c 20 74 sake of speed, t
1570: 68 65 20 72 65 66 65 72 65 6e 63 65 20 69 6d 70 he reference imp
1580: 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 64 6f 65 73 lementation does
1590: 20 6e 6f 74 0a 3b 20 20 20 20 20 75 73 65 20 61 not.; use a
15a0: 20 4c 45 54 20 74 6f 20 73 61 76 65 20 74 68 65 LET to save the
15b0: 20 63 6f 6d 70 61 72 69 73 6f 6e 20 76 61 6c 75 comparison valu
15c0: 65 20 63 20 66 6f 72 20 74 68 65 20 45 52 52 4f e c for the ERRO
15d0: 52 20 63 61 6c 6c 2e 0a 3b 20 20 20 20 20 54 68 R call..; Th
15e0: 69 73 20 63 61 6e 20 62 65 20 66 69 78 65 64 20 is can be fixed
15f0: 69 6e 20 61 20 6c 6f 77 2d 6c 65 76 65 6c 20 69 in a low-level i
1600: 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 61 74 mplementation at
1610: 20 6e 6f 20 63 6f 73 74 2e 0a 3b 20 20 20 2a 20 no cost..; *
1620: 54 79 70 65 2d 63 68 65 63 6b 73 20 62 61 73 65 Type-checks base
1630: 64 20 6f 6e 20 28 63 6f 6d 70 61 72 65 20 78 20 d on (compare x
1640: 78 29 20 61 72 65 20 6d 61 64 65 20 65 78 70 6c x) are made expl
1650: 69 63 69 74 20 62 79 20 74 68 65 0a 3b 20 20 20 icit by the.;
1660: 20 20 65 78 70 72 65 73 73 69 6f 6e 20 28 63 6f expression (co
1670: 6d 70 61 72 65 3a 63 68 65 63 6b 20 72 65 73 75 mpare:check resu
1680: 6c 74 20 63 6f 6d 70 61 72 65 20 78 20 2e 2e 2e lt compare x ...
1690: 29 2e 0a 3b 20 20 20 2a 20 45 71 3f 20 73 68 6f )..; * Eq? sho
16a0: 75 6c 64 20 20 63 61 6e 20 75 73 65 64 20 74 6f uld can used to
16b0: 20 73 70 65 65 64 20 75 70 20 62 75 69 6c 74 2d speed up built-
16c0: 69 6e 20 63 6f 6d 70 61 72 65 20 70 72 6f 63 65 in compare proce
16d0: 64 75 72 65 73 2c 0a 3b 20 20 20 20 20 62 75 74 dures,.; but
16e0: 20 69 74 20 63 61 6e 20 6f 6e 6c 79 20 62 65 20 it can only be
16f0: 75 73 65 64 20 61 66 74 65 72 20 74 79 70 65 2d used after type-
1700: 63 68 65 63 6b 69 6e 67 20 61 74 20 6c 65 61 73 checking at leas
1710: 74 20 6f 6e 65 20 6f 66 0a 3b 20 20 20 20 20 74 t one of.; t
1720: 68 65 20 61 72 67 75 6d 65 6e 74 73 2e 0a 0a 28 he arguments...(
1730: 64 65 66 69 6e 65 20 28 63 6f 6d 70 61 72 65 3a define (compare:
1740: 63 68 65 63 6b 65 64 20 72 65 73 75 6c 74 20 63 checked result c
1750: 6f 6d 70 61 72 65 20 2e 20 61 72 67 73 29 0a 20 ompare . args).
1760: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
1770: 64 61 20 28 78 29 20 28 63 6f 6d 70 61 72 65 20 da (x) (compare
1780: 78 20 78 29 29 20 61 72 67 73 29 0a 20 20 72 65 x x)) args). re
1790: 73 75 6c 74 29 0a 0a 0a 3b 20 33 2d 73 69 64 65 sult)...; 3-side
17a0: 64 20 63 6f 6e 64 69 74 69 6f 6e 61 6c 0a 0a 28 d conditional..(
17b0: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 define-syntax if
17c0: 33 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 3. (syntax-rule
17d0: 73 20 28 29 0a 20 20 20 20 28 28 69 66 33 20 63 s (). ((if3 c
17e0: 20 6c 65 73 73 20 65 71 75 61 6c 20 67 72 65 61 less equal grea
17f0: 74 65 72 29 0a 20 20 20 20 20 28 63 61 73 65 20 ter). (case
1800: 63 0a 20 20 20 20 20 20 20 28 28 2d 31 29 20 6c c. ((-1) l
1810: 65 73 73 29 0a 20 20 20 20 20 20 20 28 28 20 30 ess). (( 0
1820: 29 20 65 71 75 61 6c 29 0a 20 20 20 20 20 20 20 ) equal).
1830: 28 28 20 31 29 20 67 72 65 61 74 65 72 29 0a 20 (( 1) greater).
1840: 20 20 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 (else (err
1850: 6f 72 20 22 63 6f 6d 70 61 72 69 73 6f 6e 20 76 or "comparison v
1860: 61 6c 75 65 20 6e 6f 74 20 69 6e 20 7b 2d 31 2c alue not in {-1,
1870: 30 2c 31 7d 22 29 29 29 29 29 29 0a 0a 0a 3b 20 0,1}"))))))...;
1880: 32 2d 73 69 64 65 64 20 63 6f 6e 64 69 74 69 6f 2-sided conditio
1890: 6e 61 6c 73 20 66 6f 72 20 63 6f 6d 70 61 72 69 nals for compari
18a0: 73 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 2d 73 79 sons..(define-sy
18b0: 6e 74 61 78 20 63 6f 6d 70 61 72 65 3a 69 66 2d ntax compare:if-
18c0: 72 65 6c 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 rel?. (syntax-r
18d0: 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 63 6f ules (). ((co
18e0: 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 63 2d mpare:if-rel? c-
18f0: 63 61 73 65 73 20 61 2d 63 61 73 65 73 20 63 20 cases a-cases c
1900: 63 6f 6e 73 65 71 75 65 6e 63 65 29 0a 20 20 20 consequence).
1910: 20 20 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 (compare:if-re
1920: 6c 3f 20 63 2d 63 61 73 65 73 20 61 2d 63 61 73 l? c-cases a-cas
1930: 65 73 20 63 20 63 6f 6e 73 65 71 75 65 6e 63 65 es c consequence
1940: 20 28 69 66 20 23 66 20 23 66 29 29 29 0a 20 20 (if #f #f))).
1950: 20 20 28 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 ((compare:if-r
1960: 65 6c 3f 20 63 2d 63 61 73 65 73 20 61 2d 63 61 el? c-cases a-ca
1970: 73 65 73 20 63 20 63 6f 6e 73 65 71 75 65 6e 63 ses c consequenc
1980: 65 20 61 6c 74 65 72 6e 61 74 65 29 0a 20 20 20 e alternate).
1990: 20 20 28 63 61 73 65 20 63 0a 20 20 20 20 20 20 (case c.
19a0: 20 28 63 2d 63 61 73 65 73 20 63 6f 6e 73 65 71 (c-cases conseq
19b0: 75 65 6e 63 65 29 0a 20 20 20 20 20 20 20 28 61 uence). (a
19c0: 2d 63 61 73 65 73 20 61 6c 74 65 72 6e 61 74 65 -cases alternate
19d0: 29 0a 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 ). (else
19e0: 20 20 28 65 72 72 6f 72 20 22 63 6f 6d 70 61 72 (error "compar
19f0: 69 73 6f 6e 20 76 61 6c 75 65 20 6e 6f 74 20 69 ison value not i
1a00: 6e 20 7b 2d 31 2c 30 2c 31 7d 22 29 29 29 29 29 n {-1,0,1}")))))
1a10: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta
1a20: 78 20 69 66 3d 3f 0a 20 20 28 73 79 6e 74 61 78 x if=?. (syntax
1a30: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). ((
1a40: 69 66 3d 3f 20 61 72 67 20 2e 2e 2e 29 0a 20 20 if=? arg ...).
1a50: 20 20 20 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 (compare:if-r
1a60: 65 6c 3f 20 28 30 29 20 28 2d 31 20 31 29 20 61 el? (0) (-1 1) a
1a70: 72 67 20 2e 2e 2e 29 29 29 29 0a 0a 28 64 65 66 rg ...))))..(def
1a80: 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 3c 3f 0a ine-syntax if<?.
1a90: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
1aa0: 28 29 0a 20 20 20 20 28 28 69 66 3c 3f 20 61 72 (). ((if<? ar
1ab0: 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d g ...). (com
1ac0: 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 28 2d 31 pare:if-rel? (-1
1ad0: 29 20 28 30 20 31 29 20 61 72 67 20 2e 2e 2e 29 ) (0 1) arg ...)
1ae0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e )))..(define-syn
1af0: 74 61 78 20 69 66 3e 3f 0a 20 20 28 73 79 6e 74 tax if>?. (synt
1b00: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
1b10: 28 28 69 66 3e 3f 20 61 72 67 20 2e 2e 2e 29 0a ((if>? arg ...).
1b20: 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 69 66 (compare:if
1b30: 2d 72 65 6c 3f 20 28 31 29 20 28 2d 31 20 30 29 -rel? (1) (-1 0)
1b40: 20 61 72 67 20 2e 2e 2e 29 29 29 29 0a 0a 28 64 arg ...))))..(d
1b50: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 3c efine-syntax if<
1b60: 3d 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c =?. (syntax-rul
1b70: 65 73 20 28 29 0a 20 20 20 20 28 28 69 66 3c 3d es (). ((if<=
1b80: 3f 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 ? arg ...).
1b90: 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f (compare:if-rel?
1ba0: 20 28 2d 31 20 30 29 20 28 31 29 20 61 72 67 20 (-1 0) (1) arg
1bb0: 2e 2e 2e 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ...))))..(define
1bc0: 2d 73 79 6e 74 61 78 20 69 66 3e 3d 3f 0a 20 20 -syntax if>=?.
1bd0: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 (syntax-rules ()
1be0: 0a 20 20 20 20 28 28 69 66 3e 3d 3f 20 61 72 67 . ((if>=? arg
1bf0: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d 70 ...). (comp
1c00: 61 72 65 3a 69 66 2d 72 65 6c 3f 20 28 30 20 31 are:if-rel? (0 1
1c10: 29 20 28 2d 31 29 20 61 72 67 20 2e 2e 2e 29 29 ) (-1) arg ...))
1c20: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ))..(define-synt
1c30: 61 78 20 69 66 2d 6e 6f 74 3d 3f 0a 20 20 28 73 ax if-not=?. (s
1c40: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
1c50: 20 20 20 28 28 69 66 2d 6e 6f 74 3d 3f 20 61 72 ((if-not=? ar
1c60: 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d g ...). (com
1c70: 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 28 2d 31 pare:if-rel? (-1
1c80: 20 31 29 20 28 30 29 20 61 72 67 20 2e 2e 2e 29 1) (0) arg ...)
1c90: 29 29 29 0a 0a 0a 3b 20 70 72 65 64 69 63 61 74 )))...; predicat
1ca0: 65 73 20 66 72 6f 6d 20 63 6f 6d 70 61 72 65 20 es from compare
1cb0: 70 72 6f 63 65 64 75 72 65 73 0a 0a 28 64 65 66 procedures..(def
1cc0: 69 6e 65 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 ine-syntax compa
1cd0: 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 0a 20 re:define-rel?.
1ce0: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
1cf0: 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a ). ((compare:
1d00: 64 65 66 69 6e 65 2d 72 65 6c 3f 20 72 65 6c 3f define-rel? rel?
1d10: 20 69 66 2d 72 65 6c 3f 29 0a 20 20 20 20 20 28 if-rel?). (
1d20: 64 65 66 69 6e 65 20 72 65 6c 3f 0a 20 20 20 20 define rel?.
1d30: 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a (case-lambda.
1d40: 20 20 20 20 20 20 20 20 20 28 28 29 20 20 20 20 (()
1d50: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 79 (lambda (x y
1d60: 29 20 28 69 66 2d 72 65 6c 3f 20 28 64 65 66 61 ) (if-rel? (defa
1d70: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 ult-compare x y)
1d80: 20 23 74 20 23 66 29 29 29 0a 20 20 20 20 20 20 #t #f))).
1d90: 20 20 20 28 28 63 6f 6d 70 61 72 65 29 20 28 6c ((compare) (l
1da0: 61 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 2d ambda (x y) (if-
1db0: 72 65 6c 3f 20 28 63 6f 6d 70 61 72 65 20 20 20 rel? (compare
1dc0: 20 20 20 20 20 20 78 20 79 29 20 23 74 20 23 66 x y) #t #f
1dd0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 78 ))). ((x
1de0: 20 79 29 20 20 20 20 20 20 20 20 20 20 20 20 20 y)
1df0: 20 20 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 (if-rel? (
1e00: 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 default-compare
1e10: 78 20 79 29 20 23 74 20 23 66 29 29 0a 20 20 20 x y) #t #f)).
1e20: 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ((compare
1e30: 78 20 79 29 0a 20 20 20 20 20 20 20 20 20 20 28 x y). (
1e40: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 63 if (procedure? c
1e50: 6f 6d 70 61 72 65 29 0a 20 20 20 20 20 20 20 20 ompare).
1e60: 20 20 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 (if-rel? (
1e70: 63 6f 6d 70 61 72 65 20 78 20 79 29 20 23 74 20 compare x y) #t
1e80: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f).
1e90: 20 20 28 65 72 72 6f 72 20 22 6e 6f 74 20 61 20 (error "not a
1ea0: 70 72 6f 63 65 64 75 72 65 20 28 44 69 64 20 79 procedure (Did y
1eb0: 6f 75 20 6d 65 61 6e 20 72 65 6c 2f 72 65 6c 3f ou mean rel/rel?
1ec0: 3f 29 3a 20 22 20 63 6f 6d 70 61 72 65 29 29 29 ?): " compare)))
1ed0: 29 29 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 3a )))))..(compare:
1ee0: 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3d 3f 20 20 define-rel? =?
1ef0: 20 20 69 66 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 if=?).(compare
1f00: 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3c 3f 20 :define-rel? <?
1f10: 20 20 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 72 if<?).(compar
1f20: 65 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3e 3f e:define-rel? >?
1f30: 20 20 20 20 69 66 3e 3f 29 0a 28 63 6f 6d 70 61 if>?).(compa
1f40: 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3c re:define-rel? <
1f50: 3d 3f 20 20 20 69 66 3c 3d 3f 29 0a 28 63 6f 6d =? if<=?).(com
1f60: 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 3f pare:define-rel?
1f70: 20 3e 3d 3f 20 20 20 69 66 3e 3d 3f 29 0a 28 63 >=? if>=?).(c
1f80: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 ompare:define-re
1f90: 6c 3f 20 6e 6f 74 3d 3f 20 69 66 2d 6e 6f 74 3d l? not=? if-not=
1fa0: 3f 29 0a 0a 0a 3b 20 63 68 61 69 6e 73 20 6f 66 ?)...; chains of
1fb0: 20 6c 65 6e 67 74 68 20 33 0a 0a 28 64 65 66 69 length 3..(defi
1fc0: 6e 65 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 72 ne-syntax compar
1fd0: 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 e:define-rel1/re
1fe0: 6c 32 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 l2?. (syntax-ru
1ff0: 6c 65 73 20 28 29 0a 20 20 20 20 28 28 63 6f 6d les (). ((com
2000: 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 pare:define-rel1
2010: 2f 72 65 6c 32 3f 20 72 65 6c 31 2f 72 65 6c 32 /rel2? rel1/rel2
2020: 3f 20 69 66 2d 72 65 6c 31 3f 20 69 66 2d 72 65 ? if-rel1? if-re
2030: 6c 32 3f 29 0a 20 20 20 20 20 28 64 65 66 69 6e l2?). (defin
2040: 65 20 72 65 6c 31 2f 72 65 6c 32 3f 0a 20 20 20 e rel1/rel2?.
2050: 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 (case-lambda
2060: 0a 20 20 20 20 20 20 20 20 20 28 28 29 0a 20 20 . (().
2070: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
2080: 28 78 20 79 20 7a 29 0a 20 20 20 20 20 20 20 20 (x y z).
2090: 20 20 20 20 28 69 66 2d 72 65 6c 31 3f 20 28 64 (if-rel1? (d
20a0: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 efault-compare x
20b0: 20 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y).
20c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 (if-re
20d0: 6c 32 3f 20 28 64 65 66 61 75 6c 74 2d 63 6f 6d l2? (default-com
20e0: 70 61 72 65 20 79 20 7a 29 20 23 74 20 23 66 29 pare y z) #t #f)
20f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2100: 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a (compare:
2110: 63 68 65 63 6b 65 64 20 23 66 20 64 65 66 61 75 checked #f defau
2120: 6c 74 2d 63 6f 6d 70 61 72 65 20 7a 29 29 29 29 lt-compare z))))
2130: 0a 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 . ((comp
2140: 61 72 65 29 0a 20 20 20 20 20 20 20 20 20 20 28 are). (
2150: 6c 61 6d 62 64 61 20 28 78 20 79 20 7a 29 0a 20 lambda (x y z).
2160: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 (if-r
2170: 65 6c 31 3f 20 28 63 6f 6d 70 61 72 65 20 78 20 el1? (compare x
2180: 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 y).
2190: 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c (if-rel
21a0: 32 3f 20 28 63 6f 6d 70 61 72 65 20 79 20 7a 29 2? (compare y z)
21b0: 20 23 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 #t #f).
21c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
21d0: 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 ompare:checked #
21e0: 66 20 63 6f 6d 70 61 72 65 20 7a 29 29 29 29 0a f compare z)))).
21f0: 20 20 20 20 20 20 20 20 20 28 28 78 20 79 20 7a ((x y z
2200: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 2d ). (if-
2210: 72 65 6c 31 3f 20 28 64 65 66 61 75 6c 74 2d 63 rel1? (default-c
2220: 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 20 20 ompare x y).
2230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2240: 28 69 66 2d 72 65 6c 32 3f 20 28 64 65 66 61 75 (if-rel2? (defau
2250: 6c 74 2d 63 6f 6d 70 61 72 65 20 79 20 7a 29 20 lt-compare y z)
2260: 23 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #t #f).
2270: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 (comp
2280: 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 64 are:checked #f d
2290: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 7a efault-compare z
22a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 63 ))). ((c
22b0: 6f 6d 70 61 72 65 20 78 20 79 20 7a 29 0a 20 20 ompare x y z).
22c0: 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c 31 (if-rel1
22d0: 3f 20 28 63 6f 6d 70 61 72 65 20 78 20 79 29 0a ? (compare x y).
22e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22f0: 20 20 20 20 28 69 66 2d 72 65 6c 32 3f 20 28 63 (if-rel2? (c
2300: 6f 6d 70 61 72 65 20 79 20 7a 29 20 23 74 20 23 ompare y z) #t #
2310: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
2320: 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a (compare:
2330: 63 68 65 63 6b 65 64 20 23 66 20 63 6f 6d 70 61 checked #f compa
2340: 72 65 20 7a 29 29 29 29 29 29 29 29 0a 0a 28 63 re z))))))))..(c
2350: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 ompare:define-re
2360: 6c 31 2f 72 65 6c 32 3f 20 3c 2f 3c 3f 20 20 20 l1/rel2? </<?
2370: 69 66 3c 3f 20 20 69 66 3c 3f 29 0a 28 63 6f 6d if<? if<?).(com
2380: 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 pare:define-rel1
2390: 2f 72 65 6c 32 3f 20 3c 2f 3c 3d 3f 20 20 69 66 /rel2? </<=? if
23a0: 3c 3f 20 20 69 66 3c 3d 3f 29 0a 28 63 6f 6d 70 <? if<=?).(comp
23b0: 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f are:define-rel1/
23c0: 72 65 6c 32 3f 20 3c 3d 2f 3c 3f 20 20 69 66 3c rel2? <=/<? if<
23d0: 3d 3f 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 72 =? if<?).(compar
23e0: 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 e:define-rel1/re
23f0: 6c 32 3f 20 3c 3d 2f 3c 3d 3f 20 69 66 3c 3d 3f l2? <=/<=? if<=?
2400: 20 69 66 3c 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 if<=?).(compare
2410: 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c :define-rel1/rel
2420: 32 3f 20 3e 2f 3e 3f 20 20 20 69 66 3e 3f 20 20 2? >/>? if>?
2430: 69 66 3e 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 if>?).(compare:d
2440: 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f efine-rel1/rel2?
2450: 20 3e 2f 3e 3d 3f 20 20 69 66 3e 3f 20 20 69 66 >/>=? if>? if
2460: 3e 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 >=?).(compare:de
2470: 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 fine-rel1/rel2?
2480: 3e 3d 2f 3e 3f 20 20 69 66 3e 3d 3f 20 69 66 3e >=/>? if>=? if>
2490: 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 ?).(compare:defi
24a0: 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 3e 3d ne-rel1/rel2? >=
24b0: 2f 3e 3d 3f 20 69 66 3e 3d 3f 20 69 66 3e 3d 3f />=? if>=? if>=?
24c0: 29 0a 0a 0a 3b 20 63 68 61 69 6e 73 20 6f 66 20 )...; chains of
24d0: 61 72 62 69 74 72 61 72 79 20 6c 65 6e 67 74 68 arbitrary length
24e0: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
24f0: 20 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d compare:define-
2500: 63 68 61 69 6e 2d 72 65 6c 3f 0a 20 20 28 73 79 chain-rel?. (sy
2510: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 ntax-rules ().
2520: 20 20 28 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 ((compare:defi
2530: 6e 65 2d 63 68 61 69 6e 2d 72 65 6c 3f 20 63 68 ne-chain-rel? ch
2540: 61 69 6e 2d 72 65 6c 3f 20 69 66 2d 72 65 6c 3f ain-rel? if-rel?
2550: 29 0a 20 20 20 20 20 28 64 65 66 69 6e 65 20 63 ). (define c
2560: 68 61 69 6e 2d 72 65 6c 3f 0a 20 20 20 20 20 20 hain-rel?.
2570: 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 (case-lambda.
2580: 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 ((compare
2590: 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 29 0a ). #t).
25a0: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 ((compa
25b0: 72 65 20 78 31 29 0a 20 20 20 20 20 20 20 20 20 re x1).
25c0: 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 (compare:checke
25d0: 64 20 23 74 20 63 6f 6d 70 61 72 65 20 78 31 29 d #t compare x1)
25e0: 29 0a 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d ). ((com
25f0: 70 61 72 65 20 78 31 20 78 32 29 0a 20 20 20 20 pare x1 x2).
2600: 20 20 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 (if-rel? (
2610: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 20 23 compare x1 x2) #
2620: 74 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 t #f)).
2630: 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 20 ((compare x1 x2
2640: 78 33 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 x3). (i
2650: 66 2d 72 65 6c 3f 20 28 63 6f 6d 70 61 72 65 20 f-rel? (compare
2660: 78 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 x1 x2).
2670: 20 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 (if-re
2680: 6c 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 20 78 l? (compare x2 x
2690: 33 29 20 23 74 20 23 66 29 0a 20 20 20 20 20 20 3) #t #f).
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
26b0: 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 mpare:checked #f
26c0: 20 63 6f 6d 70 61 72 65 20 78 33 29 29 29 0a 20 compare x3))).
26d0: 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 ((compar
26e0: 65 20 78 31 20 78 32 20 2e 20 78 33 2b 29 0a 20 e x1 x2 . x3+).
26f0: 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c (if-rel
2700: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 ? (compare x1 x2
2710: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2720: 20 20 20 20 20 28 6c 65 74 20 63 68 61 69 6e 3f (let chain?
2730: 20 28 28 68 65 61 64 20 78 32 29 20 28 74 61 69 ((head x2) (tai
2740: 6c 20 78 33 2b 29 29 0a 20 20 20 20 20 20 20 20 l x3+)).
2750: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
2760: 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 (null? tail).
2770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2780: 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 #t.
2790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27a0: 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 63 6f 6d (if-rel? (com
27b0: 70 61 72 65 20 68 65 61 64 20 28 63 61 72 20 74 pare head (car t
27c0: 61 69 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 ail)).
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 20 20 20 20 20 20 20 28 63 68 61 69 6e 3f 20 (chain?
27f0: 28 63 61 72 20 74 61 69 6c 29 20 28 63 64 72 20 (car tail) (cdr
2800: 74 61 69 6c 29 29 0a 20 20 20 20 20 20 20 20 20 tail)).
2810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2820: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
2830: 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 compare:checked
2840: 23 66 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f .
2850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2860: 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6d com
2870: 70 61 72 65 20 28 63 64 72 20 74 61 69 6c 29 29 pare (cdr tail))
2880: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2890: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 63 6f (apply co
28a0: 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 mpare:checked #f
28b0: 20 63 6f 6d 70 61 72 65 20 78 33 2b 29 29 29 29 compare x3+))))
28c0: 29 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 ))))..(compare:d
28d0: 65 66 69 6e 65 2d 63 68 61 69 6e 2d 72 65 6c 3f efine-chain-rel?
28e0: 20 63 68 61 69 6e 3d 3f 20 20 69 66 3d 3f 29 0a chain=? if=?).
28f0: 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d (compare:define-
2900: 63 68 61 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e chain-rel? chain
2910: 3c 3f 20 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 <? if<?).(compa
2920: 72 65 3a 64 65 66 69 6e 65 2d 63 68 61 69 6e 2d re:define-chain-
2930: 72 65 6c 3f 20 63 68 61 69 6e 3e 3f 20 20 69 66 rel? chain>? if
2940: 3e 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 >?).(compare:def
2950: 69 6e 65 2d 63 68 61 69 6e 2d 72 65 6c 3f 20 63 ine-chain-rel? c
2960: 68 61 69 6e 3c 3d 3f 20 69 66 3c 3d 3f 29 0a 28 hain<=? if<=?).(
2970: 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 63 compare:define-c
2980: 68 61 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e 3e hain-rel? chain>
2990: 3d 3f 20 69 66 3e 3d 3f 29 0a 0a 0a 3b 20 70 61 =? if>=?)...; pa
29a0: 69 72 77 69 73 65 20 69 6e 65 71 75 61 6c 69 74 irwise inequalit
29b0: 79 0a 0a 28 64 65 66 69 6e 65 20 70 61 69 72 77 y..(define pairw
29c0: 69 73 65 2d 6e 6f 74 3d 3f 0a 20 20 28 6c 65 74 ise-not=?. (let
29d0: 20 28 28 3d 20 3d 29 20 28 3c 3d 20 3c 3d 29 29 ((= =) (<= <=))
29e0: 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 . (case-lambd
29f0: 61 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 a. ((compar
2a00: 65 29 0a 20 20 20 20 20 20 20 23 74 29 0a 20 20 e). #t).
2a10: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 ((compare x1
2a20: 29 0a 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 ). (compar
2a30: 65 3a 63 68 65 63 6b 65 64 20 23 74 20 63 6f 6d e:checked #t com
2a40: 70 61 72 65 20 78 31 29 29 0a 20 20 20 20 20 20 pare x1)).
2a50: 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 ((compare x1 x2)
2a60: 0a 20 20 20 20 20 20 20 28 69 66 2d 6e 6f 74 3d . (if-not=
2a70: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 ? (compare x1 x2
2a80: 29 20 23 74 20 23 66 29 29 0a 20 20 20 20 20 20 ) #t #f)).
2a90: 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 20 ((compare x1 x2
2aa0: 78 33 29 0a 20 20 20 20 20 20 20 28 69 66 2d 6e x3). (if-n
2ab0: 6f 74 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 ot=? (compare x1
2ac0: 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 x2).
2ad0: 20 20 20 20 20 20 28 69 66 2d 6e 6f 74 3d 3f 20 (if-not=?
2ae0: 28 63 6f 6d 70 61 72 65 20 78 32 20 78 33 29 0a (compare x2 x3).
2af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b00: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 2d 6e (if-n
2b10: 6f 74 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 ot=? (compare x1
2b20: 20 78 33 29 20 23 74 20 23 66 29 0a 20 20 20 20 x3) #t #f).
2b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b40: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
2b60: 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 pare:checked #f
2b70: 63 6f 6d 70 61 72 65 20 78 33 29 29 29 0a 20 20 compare x3))).
2b80: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 2e 20 ((compare .
2b90: 78 31 2b 29 0a 20 20 20 20 20 20 20 28 6c 65 74 x1+). (let
2ba0: 20 75 6e 65 71 75 61 6c 3f 20 28 28 78 20 78 31 unequal? ((x x1
2bb0: 2b 29 20 28 6e 20 28 6c 65 6e 67 74 68 20 78 31 +) (n (length x1
2bc0: 2b 29 29 20 28 75 6e 63 68 65 63 6b 65 64 3f 20 +)) (unchecked?
2bd0: 23 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 #t)). (i
2be0: 66 20 28 3c 20 6e 20 32 29 0a 20 20 20 20 20 20 f (< n 2).
2bf0: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
2c00: 75 6e 63 68 65 63 6b 65 64 3f 20 28 3d 20 6e 20 unchecked? (= n
2c10: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
2c20: 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 (compare:ch
2c30: 65 63 6b 65 64 20 23 74 20 63 6f 6d 70 61 72 65 ecked #t compare
2c40: 20 28 63 61 72 20 78 29 29 0a 20 20 20 20 20 20 (car x)).
2c50: 20 20 20 20 20 20 20 20 20 20 20 23 74 29 0a 20 #t).
2c60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
2c70: 2a 20 28 28 69 2d 70 69 76 6f 74 20 28 72 61 6e * ((i-pivot (ran
2c80: 64 6f 6d 2d 69 6e 74 65 67 65 72 20 6e 29 29 0a dom-integer n)).
2c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ca0: 20 20 20 20 28 78 2d 70 69 76 6f 74 20 28 6c 69 (x-pivot (li
2cb0: 73 74 2d 72 65 66 20 78 20 69 2d 70 69 76 6f 74 st-ref x i-pivot
2cc0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2cd0: 20 20 20 28 6c 65 74 20 73 70 6c 69 74 20 28 28 (let split ((
2ce0: 69 20 30 29 20 28 78 20 78 29 20 28 78 3c 20 27 i 0) (x x) (x< '
2cf0: 28 29 29 20 28 78 3e 20 27 28 29 29 29 0a 20 20 ()) (x> '())).
2d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2d10: 69 66 20 28 6e 75 6c 6c 3f 20 78 29 0a 20 20 20 if (null? x).
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d30: 20 20 28 61 6e 64 20 28 75 6e 65 71 75 61 6c 3f (and (unequal?
2d40: 20 78 3c 20 28 6c 65 6e 67 74 68 20 78 3c 29 20 x< (length x<)
2d50: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f).
2d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 75 (u
2d70: 6e 65 71 75 61 6c 3f 20 78 3e 20 28 6c 65 6e 67 nequal? x> (leng
2d80: 74 68 20 78 3e 29 20 23 66 29 29 0a 20 20 20 20 th x>) #f)).
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2da0: 20 28 69 66 20 28 3d 20 69 20 69 2d 70 69 76 6f (if (= i i-pivo
2db0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 6c (spl
2dd0: 69 74 20 28 2b 20 69 20 31 29 20 28 63 64 72 20 it (+ i 1) (cdr
2de0: 78 29 20 78 3c 20 78 3e 29 0a 20 20 20 20 20 20 x) x< x>).
2df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e00: 20 20 20 28 69 66 33 20 28 63 6f 6d 70 61 72 65 (if3 (compare
2e10: 20 28 63 61 72 20 78 29 20 78 2d 70 69 76 6f 74 (car x) x-pivot
2e20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e40: 28 73 70 6c 69 74 20 28 2b 20 69 20 31 29 20 28 (split (+ i 1) (
2e50: 63 64 72 20 78 29 20 28 63 6f 6e 73 20 28 63 61 cdr x) (cons (ca
2e60: 72 20 78 29 20 78 3c 29 20 78 3e 29 0a 20 20 20 r x) x<) x>).
2e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e80: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 75 (if u
2e90: 6e 63 68 65 63 6b 65 64 3f 0a 20 20 20 20 20 20 nchecked?.
2ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2eb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
2ec0: 6c 79 20 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b ly compare:check
2ed0: 65 64 20 23 66 20 63 6f 6d 70 61 72 65 20 28 63 ed #f compare (c
2ee0: 64 72 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 dr x)).
2ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f00: 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 #f).
2f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f20: 20 20 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 (spli
2f30: 74 20 28 2b 20 69 20 31 29 20 28 63 64 72 20 78 t (+ i 1) (cdr x
2f40: 29 20 78 3c 20 28 63 6f 6e 73 20 28 63 61 72 20 ) x< (cons (car
2f50: 78 29 20 78 3e 29 29 29 29 29 29 29 29 29 29 29 x) x>)))))))))))
2f60: 29 29 0a 0a 0a 3b 20 6d 69 6e 2f 6d 61 78 0a 0a ))...; min/max..
2f70: 28 64 65 66 69 6e 65 20 6d 69 6e 2d 63 6f 6d 70 (define min-comp
2f80: 61 72 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 are. (case-lamb
2f90: 64 61 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 da. ((compare
2fa0: 20 78 31 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 x1). (compa
2fb0: 72 65 3a 63 68 65 63 6b 65 64 20 78 31 20 63 6f re:checked x1 co
2fc0: 6d 70 61 72 65 20 78 31 29 29 0a 20 20 20 20 28 mpare x1)). (
2fd0: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a (compare x1 x2).
2fe0: 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d (if<=? (com
2ff0: 70 61 72 65 20 78 31 20 78 32 29 20 78 31 20 78 pare x1 x2) x1 x
3000: 32 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 2)). ((compar
3010: 65 20 78 31 20 78 32 20 78 33 29 0a 20 20 20 20 e x1 x2 x3).
3020: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
3030: 20 78 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 x1 x2).
3040: 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 (if<=? (comp
3050: 61 72 65 20 78 31 20 78 33 29 20 78 31 20 78 33 are x1 x3) x1 x3
3060: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
3070: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 f<=? (compare x2
3080: 20 78 33 29 20 78 32 20 78 33 29 29 29 0a 20 20 x3) x2 x3))).
3090: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 ((compare x1 x
30a0: 32 20 78 33 20 78 34 29 0a 20 20 20 20 20 28 69 2 x3 x4). (i
30b0: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 f<=? (compare x1
30c0: 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 x2).
30d0: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
30e0: 20 78 31 20 78 33 29 0a 20 20 20 20 20 20 20 20 x1 x3).
30f0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d (if<=
3100: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 34 ? (compare x1 x4
3110: 29 20 78 31 20 78 34 29 0a 20 20 20 20 20 20 20 ) x1 x4).
3120: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c (if<
3130: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 33 20 78 =? (compare x3 x
3140: 34 29 20 78 33 20 78 34 29 29 0a 20 20 20 20 20 4) x3 x4)).
3150: 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 (if<=? (c
3160: 6f 6d 70 61 72 65 20 78 32 20 78 33 29 0a 20 20 ompare x2 x3).
3170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3180: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
3190: 20 78 32 20 78 34 29 20 78 32 20 78 34 29 0a 20 x2 x4) x2 x4).
31a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31b0: 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 (if<=? (compar
31c0: 65 20 78 33 20 78 34 29 20 78 33 20 78 34 29 29 e x3 x4) x3 x4))
31d0: 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 )). ((compare
31e0: 20 78 31 20 78 32 20 2e 20 78 33 2b 29 0a 20 20 x1 x2 . x3+).
31f0: 20 20 20 28 6c 65 74 20 6d 69 6e 20 28 28 78 6d (let min ((xm
3200: 69 6e 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 in (if<=? (compa
3210: 72 65 20 78 31 20 78 32 29 20 78 31 20 78 32 29 re x1 x2) x1 x2)
3220: 29 20 28 78 73 20 78 33 2b 29 29 0a 20 20 20 20 ) (xs x3+)).
3230: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 78 73 (if (null? xs
3240: 29 0a 20 20 20 20 20 20 20 20 20 20 20 78 6d 69 ). xmi
3250: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 69 n. (mi
3260: 6e 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 n (if<=? (compar
3270: 65 20 78 6d 69 6e 20 28 63 61 72 20 78 73 29 29 e xmin (car xs))
3280: 20 78 6d 69 6e 20 28 63 61 72 20 78 73 29 29 0a xmin (car xs)).
3290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32a0: 28 63 64 72 20 78 73 29 29 29 29 29 29 29 0a 0a (cdr xs)))))))..
32b0: 28 64 65 66 69 6e 65 20 6d 61 78 2d 63 6f 6d 70 (define max-comp
32c0: 61 72 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 are. (case-lamb
32d0: 64 61 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 da. ((compare
32e0: 20 78 31 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 x1). (compa
32f0: 72 65 3a 63 68 65 63 6b 65 64 20 78 31 20 63 6f re:checked x1 co
3300: 6d 70 61 72 65 20 78 31 29 29 0a 20 20 20 20 28 mpare x1)). (
3310: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a (compare x1 x2).
3320: 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d (if>=? (com
3330: 70 61 72 65 20 78 31 20 78 32 29 20 78 31 20 78 pare x1 x2) x1 x
3340: 32 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 2)). ((compar
3350: 65 20 78 31 20 78 32 20 78 33 29 0a 20 20 20 20 e x1 x2 x3).
3360: 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 (if>=? (compare
3370: 20 78 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 x1 x2).
3380: 20 20 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 (if>=? (comp
3390: 61 72 65 20 78 31 20 78 33 29 20 78 31 20 78 33 are x1 x3) x1 x3
33a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
33b0: 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 f>=? (compare x2
33c0: 20 78 33 29 20 78 32 20 78 33 29 29 29 0a 20 20 x3) x2 x3))).
33d0: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 ((compare x1 x
33e0: 32 20 78 33 20 78 34 29 0a 20 20 20 20 20 28 69 2 x3 x4). (i
33f0: 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 f>=? (compare x1
3400: 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 x2).
3410: 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 (if>=? (compare
3420: 20 78 31 20 78 33 29 0a 20 20 20 20 20 20 20 20 x1 x3).
3430: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3e 3d (if>=
3440: 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 34 ? (compare x1 x4
3450: 29 20 78 31 20 78 34 29 0a 20 20 20 20 20 20 20 ) x1 x4).
3460: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3e (if>
3470: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 33 20 78 =? (compare x3 x
3480: 34 29 20 78 33 20 78 34 29 29 0a 20 20 20 20 20 4) x3 x4)).
3490: 20 20 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 63 (if>=? (c
34a0: 6f 6d 70 61 72 65 20 78 32 20 78 33 29 0a 20 20 ompare x2 x3).
34b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
34c0: 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 (if>=? (compare
34d0: 20 78 32 20 78 34 29 20 78 32 20 78 34 29 0a 20 x2 x4) x2 x4).
34e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
34f0: 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 (if>=? (compar
3500: 65 20 78 33 20 78 34 29 20 78 33 20 78 34 29 29 e x3 x4) x3 x4))
3510: 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 )). ((compare
3520: 20 78 31 20 78 32 20 2e 20 78 33 2b 29 0a 20 20 x1 x2 . x3+).
3530: 20 20 20 28 6c 65 74 20 6d 61 78 20 28 28 78 6d (let max ((xm
3540: 61 78 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 ax (if>=? (compa
3550: 72 65 20 78 31 20 78 32 29 20 78 31 20 78 32 29 re x1 x2) x1 x2)
3560: 29 20 28 78 73 20 78 33 2b 29 29 0a 20 20 20 20 ) (xs x3+)).
3570: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 78 73 (if (null? xs
3580: 29 0a 20 20 20 20 20 20 20 20 20 20 20 78 6d 61 ). xma
3590: 78 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 x. (ma
35a0: 78 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 x (if>=? (compar
35b0: 65 20 78 6d 61 78 20 28 63 61 72 20 78 73 29 29 e xmax (car xs))
35c0: 20 78 6d 61 78 20 28 63 61 72 20 78 73 29 29 0a xmax (car xs)).
35d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35e0: 28 63 64 72 20 78 73 29 29 29 29 29 29 29 0a 0a (cdr xs)))))))..
35f0: 0a 3b 20 6b 74 68 2d 6c 61 72 67 65 73 74 0a 0a .; kth-largest..
3600: 28 64 65 66 69 6e 65 20 6b 74 68 2d 6c 61 72 67 (define kth-larg
3610: 65 73 74 0a 20 20 28 6c 65 74 20 28 28 3d 20 3d est. (let ((= =
3620: 29 20 28 3c 20 3c 29 29 0a 20 20 20 20 28 63 61 ) (< <)). (ca
3630: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 20 se-lambda.
3640: 28 28 63 6f 6d 70 61 72 65 20 6b 20 78 30 29 0a ((compare k x0).
3650: 20 20 20 20 20 20 20 28 63 61 73 65 20 28 6d 6f (case (mo
3660: 64 75 6c 6f 20 6b 20 31 29 0a 20 20 20 20 20 20 dulo k 1).
3670: 20 20 20 28 28 30 29 20 20 28 63 6f 6d 70 61 72 ((0) (compar
3680: 65 3a 63 68 65 63 6b 65 64 20 78 30 20 63 6f 6d e:checked x0 com
3690: 70 61 72 65 20 78 30 29 29 0a 20 20 20 20 20 20 pare x0)).
36a0: 20 20 20 28 65 6c 73 65 20 28 65 72 72 6f 72 20 (else (error
36b0: 22 62 61 64 20 69 6e 64 65 78 22 20 6b 29 29 29 "bad index" k)))
36c0: 29 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 ). ((compar
36d0: 65 20 6b 20 78 30 20 78 31 29 0a 20 20 20 20 20 e k x0 x1).
36e0: 20 20 28 63 61 73 65 20 28 6d 6f 64 75 6c 6f 20 (case (modulo
36f0: 6b 20 32 29 0a 20 20 20 20 20 20 20 20 20 28 28 k 2). ((
3700: 30 29 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 0) (if<=? (compa
3710: 72 65 20 78 30 20 78 31 29 20 78 30 20 78 31 29 re x0 x1) x0 x1)
3720: 29 0a 20 20 20 20 20 20 20 20 20 28 28 31 29 20 ). ((1)
3730: 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if<=? (compare
3740: 78 30 20 78 31 29 20 78 31 20 78 30 29 29 0a 20 x0 x1) x1 x0)).
3750: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 65 (else (e
3760: 72 72 6f 72 20 22 62 61 64 20 69 6e 64 65 78 22 rror "bad index"
3770: 20 6b 29 29 29 29 0a 20 20 20 20 20 20 28 28 63 k)))). ((c
3780: 6f 6d 70 61 72 65 20 6b 20 78 30 20 78 31 20 78 ompare k x0 x1 x
3790: 32 29 0a 20 20 20 20 20 20 20 28 63 61 73 65 20 2). (case
37a0: 28 6d 6f 64 75 6c 6f 20 6b 20 33 29 0a 20 20 20 (modulo k 3).
37b0: 20 20 20 20 20 20 28 28 30 29 20 28 69 66 3c 3d ((0) (if<=
37c0: 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 31 ? (compare x0 x1
37d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
37e0: 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 (if<=? (c
37f0: 6f 6d 70 61 72 65 20 78 30 20 78 32 29 20 78 30 ompare x0 x2) x0
3800: 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 x2).
3810: 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f (if<=?
3820: 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 (compare x1 x2)
3830: 20 78 31 20 78 32 29 29 29 0a 20 20 20 20 20 20 x1 x2))).
3840: 20 20 20 28 28 31 29 20 28 69 66 33 20 28 63 6f ((1) (if3 (co
3850: 6d 70 61 72 65 20 78 30 20 78 31 29 0a 20 20 20 mpare x0 x1).
3860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3870: 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if<=? (compare
3880: 78 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 x1 x2).
3890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38a0: 20 78 31 0a 20 20 20 20 20 20 20 20 20 20 20 20 x1.
38b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
38c0: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 f<=? (compare x0
38d0: 20 78 32 29 20 78 32 20 78 30 29 29 0a 20 20 20 x2) x2 x0)).
38e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38f0: 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if<=? (compare
3900: 78 30 20 78 32 29 20 78 31 20 78 30 29 0a 20 20 x0 x2) x1 x0).
3910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3920: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
3930: 20 78 30 20 78 32 29 0a 20 20 20 20 20 20 20 20 x0 x2).
3940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3950: 20 20 78 30 0a 20 20 20 20 20 20 20 20 20 20 20 x0.
3960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3970: 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if<=? (compare x
3980: 31 20 78 32 29 20 78 32 20 78 31 29 29 29 29 0a 1 x2) x2 x1)))).
3990: 20 20 20 20 20 20 20 20 20 28 28 32 29 20 28 69 ((2) (i
39a0: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 f<=? (compare x0
39b0: 20 78 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 x1).
39c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f (if<=?
39d0: 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 (compare x1 x2)
39e0: 20 78 32 20 78 31 29 0a 20 20 20 20 20 20 20 20 x2 x1).
39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
3a00: 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 <=? (compare x0
3a10: 78 32 29 20 78 32 20 78 30 29 29 29 0a 20 20 20 x2) x2 x0))).
3a20: 20 20 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 (else (err
3a30: 6f 72 20 22 62 61 64 20 69 6e 64 65 78 22 20 6b or "bad index" k
3a40: 29 29 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d )))). ((com
3a50: 70 61 72 65 20 6b 20 78 30 20 2e 20 78 31 2b 29 pare k x0 . x1+)
3a60: 20 3b 20 7c 78 31 2b 7c 20 3e 3d 20 31 0a 20 20 ; |x1+| >= 1.
3a70: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 (if (not (a
3a80: 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 6b 29 20 nd (integer? k)
3a90: 28 65 78 61 63 74 3f 20 6b 29 29 29 0a 20 20 20 (exact? k))).
3aa0: 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 (error "
3ab0: 62 61 64 20 69 6e 64 65 78 22 20 6b 29 29 0a 20 bad index" k)).
3ac0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 20 28 (let ((n (
3ad0: 2b 20 31 20 28 6c 65 6e 67 74 68 20 78 31 2b 29 + 1 (length x1+)
3ae0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 65 ))). (le
3af0: 74 20 6b 74 68 20 28 28 6b 20 20 20 28 6d 6f 64 t kth ((k (mod
3b00: 75 6c 6f 20 6b 20 6e 29 29 0a 20 20 20 20 20 20 ulo k n)).
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 20 (n
3b20: 20 20 6e 29 20 20 3b 20 3d 20 7c 78 7c 0a 20 20 n) ; = |x|.
3b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b40: 20 28 72 65 76 20 23 74 29 20 3b 20 61 72 65 20 (rev #t) ; are
3b50: 78 3c 2c 20 78 3d 2c 20 78 3e 20 72 65 76 65 72 x<, x=, x> rever
3b60: 73 65 64 3f 0a 20 20 20 20 20 20 20 20 20 20 20 sed?.
3b70: 20 20 20 20 20 20 20 20 28 78 20 20 20 28 63 6f (x (co
3b80: 6e 73 20 78 30 20 78 31 2b 29 29 29 0a 20 20 20 ns x0 x1+))).
3b90: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 70 (let ((p
3ba0: 69 76 6f 74 20 28 6c 69 73 74 2d 72 65 66 20 78 ivot (list-ref x
3bb0: 20 28 72 61 6e 64 6f 6d 2d 69 6e 74 65 67 65 72 (random-integer
3bc0: 20 6e 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 n)))).
3bd0: 20 20 20 20 28 6c 65 74 20 73 70 6c 69 74 20 28 (let split (
3be0: 28 78 20 78 29 20 28 78 3c 20 27 28 29 29 20 28 (x x) (x< '()) (
3bf0: 6e 3c 20 30 29 20 28 78 3d 20 27 28 29 29 20 28 n< 0) (x= '()) (
3c00: 6e 3d 20 30 29 20 28 78 3e 20 27 28 29 29 20 28 n= 0) (x> '()) (
3c10: 6e 3e 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 n> 0)).
3c20: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
3c30: 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x).
3c40: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
3c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c60: 20 20 28 28 3c 20 6b 20 6e 3c 29 0a 20 20 20 20 ((< k n<).
3c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c80: 20 20 28 6b 74 68 20 6b 20 6e 3c 20 28 6e 6f 74 (kth k n< (not
3c90: 20 72 65 76 29 20 78 3c 29 29 0a 20 20 20 20 20 rev) x<)).
3ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3cb0: 28 28 3c 20 6b 20 28 2b 20 6e 3c 20 6e 3d 29 29 ((< k (+ n< n=))
3cc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3cd0: 20 20 20 20 20 20 20 28 69 66 20 72 65 76 0a 20 (if rev.
3ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3cf0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
3d00: 65 66 20 78 3d 20 28 2d 20 28 2d 20 6e 3d 20 31 ef x= (- (- n= 1
3d10: 29 20 28 2d 20 6b 20 6e 3c 29 29 29 0a 20 20 20 ) (- k n<))).
3d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d30: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 (list-ref
3d40: 20 78 3d 20 28 2d 20 6b 20 6e 3c 29 29 29 29 0a x= (- k n<)))).
3d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d60: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
3d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d80: 20 28 6b 74 68 20 28 2d 20 6b 20 28 2b 20 6e 3c (kth (- k (+ n<
3d90: 20 6e 3d 29 29 20 6e 3e 20 28 6e 6f 74 20 72 65 n=)) n> (not re
3da0: 76 29 20 78 3e 29 29 29 0a 20 20 20 20 20 20 20 v) x>))).
3db0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 33 (if3
3dc0: 20 28 63 6f 6d 70 61 72 65 20 28 63 61 72 20 78 (compare (car x
3dd0: 29 20 70 69 76 6f 74 29 0a 20 20 20 20 20 20 20 ) pivot).
3de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3df0: 20 28 73 70 6c 69 74 20 28 63 64 72 20 78 29 20 (split (cdr x)
3e00: 28 63 6f 6e 73 20 28 63 61 72 20 78 29 20 78 3c (cons (car x) x<
3e10: 29 20 28 2b 20 6e 3c 20 31 29 20 78 3d 20 6e 3d ) (+ n< 1) x= n=
3e20: 20 78 3e 20 6e 3e 29 0a 20 20 20 20 20 20 20 20 x> n>).
3e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e40: 28 73 70 6c 69 74 20 28 63 64 72 20 78 29 20 78 (split (cdr x) x
3e50: 3c 20 6e 3c 20 28 63 6f 6e 73 20 28 63 61 72 20 < n< (cons (car
3e60: 78 29 20 78 3d 29 20 28 2b 20 6e 3d 20 31 29 20 x) x=) (+ n= 1)
3e70: 78 3e 20 6e 3e 29 0a 20 20 20 20 20 20 20 20 20 x> n>).
3e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3e90: 73 70 6c 69 74 20 28 63 64 72 20 78 29 20 78 3c split (cdr x) x<
3ea0: 20 6e 3c 20 78 3d 20 6e 3d 20 28 63 6f 6e 73 20 n< x= n= (cons
3eb0: 28 63 61 72 20 78 29 20 78 3e 29 20 28 2b 20 6e (car x) x>) (+ n
3ec0: 3e 20 31 29 29 29 29 29 29 29 29 29 29 29 29 0a > 1)))))))))))).
3ed0: 0a 0a 3b 20 63 6f 6d 70 61 72 65 20 66 75 6e 63 ..; compare func
3ee0: 74 69 6f 6e 73 20 66 72 6f 6d 20 70 72 65 64 69 tions from predi
3ef0: 63 61 74 65 73 0a 0a 28 64 65 66 69 6e 65 20 63 cates..(define c
3f00: 6f 6d 70 61 72 65 2d 62 79 3c 0a 20 20 28 63 61 ompare-by<. (ca
3f10: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 se-lambda. ((
3f20: 6c 74 29 20 20 20 20 20 28 6c 61 6d 62 64 61 20 lt) (lambda
3f30: 28 78 20 79 29 20 28 69 66 20 28 6c 74 20 78 20 (x y) (if (lt x
3f40: 79 29 20 2d 31 20 28 69 66 20 28 6c 74 20 79 20 y) -1 (if (lt y
3f50: 78 29 20 20 31 20 30 29 29 29 29 0a 20 20 20 20 x) 1 0)))).
3f60: 28 28 6c 74 20 78 20 79 29 20 20 20 20 20 20 20 ((lt x y)
3f70: 20 20 20 20 20 20 20 20 28 69 66 20 28 6c 74 20 (if (lt
3f80: 78 20 79 29 20 2d 31 20 28 69 66 20 28 6c 74 20 x y) -1 (if (lt
3f90: 79 20 78 29 20 20 31 20 30 29 29 29 29 29 0a 0a y x) 1 0)))))..
3fa0: 28 64 65 66 69 6e 65 20 63 6f 6d 70 61 72 65 2d (define compare-
3fb0: 62 79 3e 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 by>. (case-lamb
3fc0: 64 61 0a 20 20 20 20 28 28 67 74 29 20 20 20 20 da. ((gt)
3fd0: 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 20 28 (lambda (x y) (
3fe0: 69 66 20 28 67 74 20 78 20 79 29 20 31 20 28 69 if (gt x y) 1 (i
3ff0: 66 20 28 67 74 20 79 20 78 29 20 20 2d 31 20 30 f (gt y x) -1 0
4000: 29 29 29 29 0a 20 20 20 20 28 28 67 74 20 78 20 )))). ((gt x
4010: 79 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 y)
4020: 20 28 69 66 20 28 67 74 20 78 20 79 29 20 31 20 (if (gt x y) 1
4030: 28 69 66 20 28 67 74 20 79 20 78 29 20 20 2d 31 (if (gt y x) -1
4040: 20 30 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 0)))))..(define
4050: 20 63 6f 6d 70 61 72 65 2d 62 79 3c 3d 0a 20 20 compare-by<=.
4060: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda.
4070: 20 28 28 6c 65 29 20 20 20 20 20 28 6c 61 6d 62 ((le) (lamb
4080: 64 61 20 28 78 20 79 29 20 28 69 66 20 28 6c 65 da (x y) (if (le
4090: 20 78 20 79 29 20 28 69 66 20 28 6c 65 20 79 20 x y) (if (le y
40a0: 78 29 20 30 20 2d 31 29 20 31 29 29 29 0a 20 20 x) 0 -1) 1))).
40b0: 20 20 28 28 6c 65 20 78 20 79 29 20 20 20 20 20 ((le x y)
40c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6c (if (l
40d0: 65 20 78 20 79 29 20 28 69 66 20 28 6c 65 20 79 e x y) (if (le y
40e0: 20 78 29 20 30 20 2d 31 29 20 31 29 29 29 29 0a x) 0 -1) 1)))).
40f0: 0a 28 64 65 66 69 6e 65 20 63 6f 6d 70 61 72 65 .(define compare
4100: 2d 62 79 3e 3d 0a 20 20 28 63 61 73 65 2d 6c 61 -by>=. (case-la
4110: 6d 62 64 61 0a 20 20 20 20 28 28 67 65 29 20 20 mbda. ((ge)
4120: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 (lambda (x y)
4130: 20 28 69 66 20 28 67 65 20 78 20 79 29 20 28 69 (if (ge x y) (i
4140: 66 20 28 67 65 20 79 20 78 29 20 30 20 31 29 20 f (ge y x) 0 1)
4150: 2d 31 29 29 29 0a 20 20 20 20 28 28 67 65 20 78 -1))). ((ge x
4160: 20 79 29 20 20 20 20 20 20 20 20 20 20 20 20 20 y)
4170: 20 20 28 69 66 20 28 67 65 20 78 20 79 29 20 28 (if (ge x y) (
4180: 69 66 20 28 67 65 20 79 20 78 29 20 30 20 31 29 if (ge y x) 0 1)
4190: 20 2d 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 -1))))..(define
41a0: 20 63 6f 6d 70 61 72 65 2d 62 79 3d 2f 3c 0a 20 compare-by=/<.
41b0: 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 (case-lambda.
41c0: 20 20 28 28 65 71 20 6c 74 29 20 20 20 20 20 28 ((eq lt) (
41d0: 6c 61 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 lambda (x y) (if
41e0: 20 28 65 71 20 78 20 79 29 20 30 20 28 69 66 20 (eq x y) 0 (if
41f0: 28 6c 74 20 78 20 79 29 20 2d 31 20 31 29 29 29 (lt x y) -1 1)))
4200: 29 0a 20 20 20 20 28 28 65 71 20 6c 74 20 78 20 ). ((eq lt x
4210: 79 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 y)
4220: 20 28 69 66 20 28 65 71 20 78 20 79 29 20 30 20 (if (eq x y) 0
4230: 28 69 66 20 28 6c 74 20 78 20 79 29 20 2d 31 20 (if (lt x y) -1
4240: 31 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 1)))))..(define
4250: 63 6f 6d 70 61 72 65 2d 62 79 3d 2f 3e 0a 20 20 compare-by=/>.
4260: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda.
4270: 20 28 28 65 71 20 67 74 29 20 20 20 20 20 28 6c ((eq gt) (l
4280: 61 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 20 ambda (x y) (if
4290: 28 65 71 20 78 20 79 29 20 30 20 28 69 66 20 28 (eq x y) 0 (if (
42a0: 67 74 20 78 20 79 29 20 31 20 2d 31 29 29 29 29 gt x y) 1 -1))))
42b0: 0a 20 20 20 20 28 28 65 71 20 67 74 20 78 20 79 . ((eq gt x y
42c0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
42d0: 28 69 66 20 28 65 71 20 78 20 79 29 20 30 20 28 (if (eq x y) 0 (
42e0: 69 66 20 28 67 74 20 78 20 79 29 20 31 20 2d 31 if (gt x y) 1 -1
42f0: 29 29 29 29 29 0a 0a 3b 20 72 65 66 69 6e 65 20 )))))..; refine
4300: 61 6e 64 20 65 78 74 65 6e 64 20 63 6f 6e 73 74 and extend const
4310: 72 75 63 74 69 6f 6e 0a 0a 28 64 65 66 69 6e 65 ruction..(define
4320: 2d 73 79 6e 74 61 78 20 72 65 66 69 6e 65 2d 63 -syntax refine-c
4330: 6f 6d 70 61 72 65 0a 20 20 28 73 79 6e 74 61 78 ompare. (syntax
4340: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). ((
4350: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 29 0a refine-compare).
4360: 20 20 20 20 20 30 29 0a 20 20 20 20 28 28 72 65 0). ((re
4370: 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 63 31 29 fine-compare c1)
4380: 0a 20 20 20 20 20 63 31 29 0a 20 20 20 20 28 28 . c1). ((
4390: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 63 refine-compare c
43a0: 31 20 63 32 20 63 73 20 2e 2e 2e 29 0a 20 20 20 1 c2 cs ...).
43b0: 20 20 28 69 66 33 20 63 31 20 2d 31 20 28 72 65 (if3 c1 -1 (re
43c0: 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 63 32 20 fine-compare c2
43d0: 63 73 20 2e 2e 2e 29 20 31 29 29 29 29 0a 0a 28 cs ...) 1))))..(
43e0: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 73 65 define-syntax se
43f0: 6c 65 63 74 2d 63 6f 6d 70 61 72 65 0a 20 20 28 lect-compare. (
4400: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 65 6c syntax-rules (el
4410: 73 65 29 0a 20 20 20 20 28 28 73 65 6c 65 63 74 se). ((select
4420: 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 63 6c 61 -compare x y cla
4430: 75 73 65 20 2e 2e 2e 29 0a 20 20 20 20 20 28 6c use ...). (l
4440: 65 74 20 28 28 78 2d 76 61 6c 20 78 29 20 28 79 et ((x-val x) (y
4450: 2d 76 61 6c 20 79 29 29 0a 20 20 20 20 20 20 20 -val y)).
4460: 28 73 65 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 (select-compare
4470: 28 78 2d 76 61 6c 20 79 2d 76 61 6c 20 63 6c 61 (x-val y-val cla
4480: 75 73 65 20 2e 2e 2e 29 29 29 29 0a 20 20 20 20 use ...)))).
4490: 3b 20 75 73 65 64 20 69 6e 74 65 72 6e 61 6c 6c ; used internall
44a0: 79 3a 20 28 73 65 6c 65 63 74 2d 63 6f 6d 70 61 y: (select-compa
44b0: 72 65 20 28 78 20 79 20 63 6c 61 75 73 65 20 2e re (x y clause .
44c0: 2e 2e 29 29 0a 20 20 20 20 28 28 73 65 6c 65 63 ..)). ((selec
44d0: 74 2d 63 6f 6d 70 61 72 65 20 28 78 20 79 29 29 t-compare (x y))
44e0: 0a 20 20 20 20 20 30 29 0a 20 20 20 20 28 28 73 . 0). ((s
44f0: 65 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 28 78 elect-compare (x
4500: 20 79 20 28 65 6c 73 65 20 63 20 2e 2e 2e 29 29 y (else c ...))
4510: 29 0a 20 20 20 20 20 28 72 65 66 69 6e 65 2d 63 ). (refine-c
4520: 6f 6d 70 61 72 65 20 63 20 2e 2e 2e 29 29 0a 20 ompare c ...)).
4530: 20 20 20 28 28 73 65 6c 65 63 74 2d 63 6f 6d 70 ((select-comp
4540: 61 72 65 20 28 78 20 79 20 28 74 3f 20 63 20 2e are (x y (t? c .
4550: 2e 2e 29 20 63 6c 61 75 73 65 20 2e 2e 2e 29 29 ..) clause ...))
4560: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 74 3f 2d . (let ((t?-
4570: 76 61 6c 20 74 3f 29 29 0a 20 20 20 20 20 20 20 val t?)).
4580: 28 6c 65 74 20 28 28 74 78 20 28 74 3f 2d 76 61 (let ((tx (t?-va
4590: 6c 20 78 29 29 20 28 74 79 20 28 74 3f 2d 76 61 l x)) (ty (t?-va
45a0: 6c 20 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 l y))).
45b0: 28 69 66 20 74 78 0a 20 20 20 20 20 20 20 20 20 (if tx.
45c0: 20 20 20 20 28 69 66 20 74 79 20 28 72 65 66 69 (if ty (refi
45d0: 6e 65 2d 63 6f 6d 70 61 72 65 20 63 20 2e 2e 2e ne-compare c ...
45e0: 29 20 2d 31 29 0a 20 20 20 20 20 20 20 20 20 20 ) -1).
45f0: 20 20 20 28 69 66 20 74 79 20 31 20 28 73 65 6c (if ty 1 (sel
4600: 65 63 74 2d 63 6f 6d 70 61 72 65 20 28 78 20 79 ect-compare (x y
4610: 20 63 6c 61 75 73 65 20 2e 2e 2e 29 29 29 29 29 clause ...)))))
4620: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ))))..(define-sy
4630: 6e 74 61 78 20 63 6f 6e 64 2d 63 6f 6d 70 61 72 ntax cond-compar
4640: 65 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 e. (syntax-rule
4650: 73 20 28 65 6c 73 65 29 0a 20 20 20 20 28 28 63 s (else). ((c
4660: 6f 6e 64 2d 63 6f 6d 70 61 72 65 29 0a 20 20 20 ond-compare).
4670: 20 20 30 29 0a 20 20 20 20 28 28 63 6f 6e 64 2d 0). ((cond-
4680: 63 6f 6d 70 61 72 65 20 28 65 6c 73 65 20 63 73 compare (else cs
4690: 20 2e 2e 2e 29 29 0a 20 20 20 20 20 28 72 65 66 ...)). (ref
46a0: 69 6e 65 2d 63 6f 6d 70 61 72 65 20 63 73 20 2e ine-compare cs .
46b0: 2e 2e 29 29 0a 20 20 20 20 28 28 63 6f 6e 64 2d ..)). ((cond-
46c0: 63 6f 6d 70 61 72 65 20 28 28 74 78 20 74 79 29 compare ((tx ty)
46d0: 20 63 73 20 2e 2e 2e 29 20 63 6c 61 75 73 65 20 cs ...) clause
46e0: 2e 2e 2e 29 0a 20 20 20 20 20 28 6c 65 74 20 28 ...). (let (
46f0: 28 74 78 2d 76 61 6c 20 74 78 29 20 28 74 79 2d (tx-val tx) (ty-
4700: 76 61 6c 20 74 79 29 29 0a 20 20 20 20 20 20 20 val ty)).
4710: 28 69 66 20 74 78 2d 76 61 6c 0a 20 20 20 20 20 (if tx-val.
4720: 20 20 20 20 20 20 28 69 66 20 74 79 2d 76 61 6c (if ty-val
4730: 20 28 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 (refine-compare
4740: 20 63 73 20 2e 2e 2e 29 20 2d 31 29 0a 20 20 20 cs ...) -1).
4750: 20 20 20 20 20 20 20 20 28 69 66 20 74 79 2d 76 (if ty-v
4760: 61 6c 20 31 20 28 63 6f 6e 64 2d 63 6f 6d 70 61 al 1 (cond-compa
4770: 72 65 20 63 6c 61 75 73 65 20 2e 2e 2e 29 29 29 re clause ...)))
4780: 29 29 29 29 0a 0a 0a 3b 20 52 35 52 53 20 61 74 ))))...; R5RS at
4790: 6f 6d 69 63 20 74 79 70 65 73 0a 0a 28 64 65 66 omic types..(def
47a0: 69 6e 65 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 ine-syntax compa
47b0: 72 65 3a 74 79 70 65 2d 63 68 65 63 6b 0a 20 20 re:type-check.
47c0: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 (syntax-rules ()
47d0: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a 74 . ((compare:t
47e0: 79 70 65 2d 63 68 65 63 6b 20 74 79 70 65 3f 20 ype-check type?
47f0: 74 79 70 65 2d 6e 61 6d 65 20 78 29 0a 20 20 20 type-name x).
4800: 20 20 28 69 66 20 28 6e 6f 74 20 28 74 79 70 65 (if (not (type
4810: 3f 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 28 ? x)). (
4820: 65 72 72 6f 72 20 28 73 74 72 69 6e 67 2d 61 70 error (string-ap
4830: 70 65 6e 64 20 22 6e 6f 74 20 22 20 74 79 70 65 pend "not " type
4840: 2d 6e 61 6d 65 20 22 3a 22 29 20 78 29 29 29 0a -name ":") x))).
4850: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a 74 79 ((compare:ty
4860: 70 65 2d 63 68 65 63 6b 20 74 79 70 65 3f 20 74 pe-check type? t
4870: 79 70 65 2d 6e 61 6d 65 20 78 20 79 29 0a 20 20 ype-name x y).
4880: 20 20 20 28 62 65 67 69 6e 20 28 63 6f 6d 70 61 (begin (compa
4890: 72 65 3a 74 79 70 65 2d 63 68 65 63 6b 20 74 79 re:type-check ty
48a0: 70 65 3f 20 74 79 70 65 2d 6e 61 6d 65 20 78 29 pe? type-name x)
48b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f . (co
48c0: 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 65 63 6b mpare:type-check
48d0: 20 74 79 70 65 3f 20 74 79 70 65 2d 6e 61 6d 65 type? type-name
48e0: 20 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 y)))))..(define
48f0: 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 72 65 3a -syntax compare:
4900: 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 0a 20 20 28 define-by=/<. (
4910: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules ().
4920: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a 64 65 ((compare:de
4930: 66 69 6e 65 2d 62 79 3d 2f 3c 20 63 6f 6d 70 61 fine-by=/< compa
4940: 72 65 20 3d 20 3c 20 74 79 70 65 3f 20 74 79 70 re = < type? typ
4950: 65 2d 6e 61 6d 65 29 0a 20 20 20 20 20 28 64 65 e-name). (de
4960: 66 69 6e 65 20 63 6f 6d 70 61 72 65 0a 20 20 20 fine compare.
4970: 20 20 20 20 28 6c 65 74 20 28 28 3d 20 3d 29 20 (let ((= =)
4980: 28 3c 20 3c 29 29 0a 20 20 20 20 20 20 20 20 20 (< <)).
4990: 28 6c 61 6d 62 64 61 20 28 78 20 79 29 0a 20 20 (lambda (x y).
49a0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 74 79 (if (ty
49b0: 70 65 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 pe? x).
49c0: 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 78 (if (eq? x
49d0: 20 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y).
49e0: 20 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 20 0.
49f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
4a00: 28 74 79 70 65 3f 20 79 29 0a 20 20 20 20 20 20 (type? y).
4a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a20: 20 28 69 66 20 28 3d 20 78 20 79 29 20 30 20 28 (if (= x y) 0 (
4a30: 69 66 20 28 3c 20 78 20 79 29 20 2d 31 20 31 29 if (< x y) -1 1)
4a40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4a50: 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 (error
4a60: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
4a70: 6e 6f 74 20 22 20 74 79 70 65 2d 6e 61 6d 65 20 not " type-name
4a80: 22 3a 22 29 20 79 29 29 29 0a 20 20 20 20 20 20 ":") y))).
4a90: 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 (error
4aa0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
4ab0: 6e 6f 74 20 22 20 74 79 70 65 2d 6e 61 6d 65 20 not " type-name
4ac0: 22 3a 22 29 20 78 29 29 29 29 29 29 29 29 0a 0a ":") x))))))))..
4ad0: 28 64 65 66 69 6e 65 20 28 62 6f 6f 6c 65 61 6e (define (boolean
4ae0: 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 -compare x y).
4af0: 28 63 6f 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 (compare:type-ch
4b00: 65 63 6b 20 62 6f 6f 6c 65 61 6e 3f 20 22 62 6f eck boolean? "bo
4b10: 6f 6c 65 61 6e 22 20 78 20 79 29 0a 20 20 28 69 olean" x y). (i
4b20: 66 20 78 20 28 69 66 20 79 20 30 20 31 29 20 28 f x (if y 0 1) (
4b30: 69 66 20 79 20 2d 31 20 30 29 29 29 0a 0a 28 63 if y -1 0)))..(c
4b40: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 62 79 ompare:define-by
4b50: 3d 2f 3c 20 63 68 61 72 2d 63 6f 6d 70 61 72 65 =/< char-compare
4b60: 20 63 68 61 72 3d 3f 20 63 68 61 72 3c 3f 20 63 char=? char<? c
4b70: 68 61 72 3f 20 22 63 68 61 72 22 29 0a 0a 28 63 har? "char")..(c
4b80: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 62 79 ompare:define-by
4b90: 3d 2f 3c 20 63 68 61 72 2d 63 6f 6d 70 61 72 65 =/< char-compare
4ba0: 2d 63 69 20 63 68 61 72 2d 63 69 3d 3f 20 63 68 -ci char-ci=? ch
4bb0: 61 72 2d 63 69 3c 3f 20 63 68 61 72 3f 20 22 63 ar-ci<? char? "c
4bc0: 68 61 72 22 29 0a 0a 28 63 6f 6d 70 61 72 65 3a har")..(compare:
4bd0: 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 73 74 72 define-by=/< str
4be0: 69 6e 67 2d 63 6f 6d 70 61 72 65 20 73 74 72 69 ing-compare stri
4bf0: 6e 67 3d 3f 20 73 74 72 69 6e 67 3c 3f 20 73 74 ng=? string<? st
4c00: 72 69 6e 67 3f 20 22 73 74 72 69 6e 67 22 29 0a ring? "string").
4c10: 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 .(compare:define
4c20: 2d 62 79 3d 2f 3c 20 73 74 72 69 6e 67 2d 63 6f -by=/< string-co
4c30: 6d 70 61 72 65 2d 63 69 20 73 74 72 69 6e 67 2d mpare-ci string-
4c40: 63 69 3d 3f 20 73 74 72 69 6e 67 2d 63 69 3c 3f ci=? string-ci<?
4c50: 20 73 74 72 69 6e 67 3f 20 22 73 74 72 69 6e 67 string? "string
4c60: 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 79 6d ")..(define (sym
4c70: 62 6f 6c 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 bol-compare x y)
4c80: 0a 20 20 28 63 6f 6d 70 61 72 65 3a 74 79 70 65 . (compare:type
4c90: 2d 63 68 65 63 6b 20 73 79 6d 62 6f 6c 3f 20 22 -check symbol? "
4ca0: 73 79 6d 62 6f 6c 22 20 78 20 79 29 0a 20 20 28 symbol" x y). (
4cb0: 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 28 string-compare (
4cc0: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 78 symbol->string x
4cd0: 29 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e ) (symbol->strin
4ce0: 67 20 79 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 g y)))..(compare
4cf0: 3a 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 69 6e :define-by=/< in
4d00: 74 65 67 65 72 2d 63 6f 6d 70 61 72 65 20 3d 20 teger-compare =
4d10: 3c 20 69 6e 74 65 67 65 72 3f 20 22 69 6e 74 65 < integer? "inte
4d20: 67 65 72 22 29 0a 0a 28 63 6f 6d 70 61 72 65 3a ger")..(compare:
4d30: 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 72 61 74 define-by=/< rat
4d40: 69 6f 6e 61 6c 2d 63 6f 6d 70 61 72 65 20 3d 20 ional-compare =
4d50: 3c 20 72 61 74 69 6f 6e 61 6c 3f 20 22 72 61 74 < rational? "rat
4d60: 69 6f 6e 61 6c 22 29 0a 0a 28 63 6f 6d 70 61 72 ional")..(compar
4d70: 65 3a 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 72 e:define-by=/< r
4d80: 65 61 6c 2d 63 6f 6d 70 61 72 65 20 3d 20 3c 20 eal-compare = <
4d90: 72 65 61 6c 3f 20 22 72 65 61 6c 22 29 0a 0a 28 real? "real")..(
4da0: 64 65 66 69 6e 65 20 28 63 6f 6d 70 6c 65 78 2d define (complex-
4db0: 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 28 compare x y). (
4dc0: 63 6f 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 65 compare:type-che
4dd0: 63 6b 20 63 6f 6d 70 6c 65 78 3f 20 22 63 6f 6d ck complex? "com
4de0: 70 6c 65 78 22 20 78 20 79 29 0a 20 20 28 69 66 plex" x y). (if
4df0: 20 28 61 6e 64 20 28 72 65 61 6c 3f 20 78 29 20 (and (real? x)
4e00: 28 72 65 61 6c 3f 20 79 29 29 0a 20 20 20 20 20 (real? y)).
4e10: 20 28 72 65 61 6c 2d 63 6f 6d 70 61 72 65 20 78 (real-compare x
4e20: 20 79 29 0a 20 20 20 20 20 20 28 72 65 66 69 6e y). (refin
4e30: 65 2d 63 6f 6d 70 61 72 65 20 28 72 65 61 6c 2d e-compare (real-
4e40: 63 6f 6d 70 61 72 65 20 28 72 65 61 6c 2d 70 61 compare (real-pa
4e50: 72 74 20 78 29 20 28 72 65 61 6c 2d 70 61 72 74 rt x) (real-part
4e60: 20 79 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 y)).
4e70: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 61 6c (real
4e80: 2d 63 6f 6d 70 61 72 65 20 28 69 6d 61 67 2d 70 -compare (imag-p
4e90: 61 72 74 20 78 29 20 28 69 6d 61 67 2d 70 61 72 art x) (imag-par
4ea0: 74 20 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e t y)))))..(defin
4eb0: 65 20 28 6e 75 6d 62 65 72 2d 63 6f 6d 70 61 72 e (number-compar
4ec0: 65 20 78 20 79 29 0a 20 20 28 63 6f 6d 70 61 72 e x y). (compar
4ed0: 65 3a 74 79 70 65 2d 63 68 65 63 6b 20 6e 75 6d e:type-check num
4ee0: 62 65 72 3f 20 22 6e 75 6d 62 65 72 22 20 78 20 ber? "number" x
4ef0: 79 29 0a 20 20 28 63 6f 6d 70 6c 65 78 2d 63 6f y). (complex-co
4f00: 6d 70 61 72 65 20 78 20 79 29 29 0a 0a 0a 3b 20 mpare x y))...;
4f10: 52 35 52 53 20 63 6f 6d 70 6f 75 6e 64 20 64 61 R5RS compound da
4f20: 74 61 20 73 74 72 75 63 74 75 72 65 73 3a 20 64 ta structures: d
4f30: 6f 74 74 65 64 20 70 61 69 72 2c 20 6c 69 73 74 otted pair, list
4f40: 2c 20 76 65 63 74 6f 72 0a 0a 28 64 65 66 69 6e , vector..(defin
4f50: 65 20 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d e (pair-compare-
4f60: 63 61 72 20 63 6f 6d 70 61 72 65 29 0a 20 20 28 car compare). (
4f70: 6c 61 6d 62 64 61 20 28 78 20 79 29 0a 20 20 20 lambda (x y).
4f80: 20 28 63 6f 6d 70 61 72 65 20 28 63 61 72 20 78 (compare (car x
4f90: 29 20 28 63 61 72 20 79 29 29 29 29 0a 0a 28 64 ) (car y))))..(d
4fa0: 65 66 69 6e 65 20 28 70 61 69 72 2d 63 6f 6d 70 efine (pair-comp
4fb0: 61 72 65 2d 63 64 72 20 63 6f 6d 70 61 72 65 29 are-cdr compare)
4fc0: 0a 20 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 . (lambda (x y)
4fd0: 0a 20 20 20 20 28 63 6f 6d 70 61 72 65 20 28 63 . (compare (c
4fe0: 64 72 20 78 29 20 28 63 64 72 20 79 29 29 29 29 dr x) (cdr y))))
4ff0: 0a 0a 28 64 65 66 69 6e 65 20 70 61 69 72 2d 63 ..(define pair-c
5000: 6f 6d 70 61 72 65 0a 20 20 28 63 61 73 65 2d 6c ompare. (case-l
5010: 61 6d 62 64 61 0a 20 20 20 20 0a 20 20 20 20 3b ambda. . ;
5020: 20 64 6f 74 74 65 64 20 70 61 69 72 0a 20 20 20 dotted pair.
5030: 20 28 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d ((pair-compare-
5040: 63 61 72 20 70 61 69 72 2d 63 6f 6d 70 61 72 65 car pair-compare
5050: 2d 63 64 72 20 78 20 79 29 0a 20 20 20 20 20 28 -cdr x y). (
5060: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 28 refine-compare (
5070: 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 61 72 pair-compare-car
5080: 20 28 63 61 72 20 78 29 20 28 63 61 72 20 79 29 (car x) (car y)
5090: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
50a0: 20 20 20 20 20 20 20 28 70 61 69 72 2d 63 6f 6d (pair-com
50b0: 70 61 72 65 2d 63 64 72 20 28 63 64 72 20 78 29 pare-cdr (cdr x)
50c0: 20 28 63 64 72 20 79 29 29 29 29 0a 20 20 20 20 (cdr y)))).
50d0: 0a 20 20 20 20 3b 20 70 6f 73 73 69 62 6c 79 20 . ; possibly
50e0: 69 6d 70 72 6f 70 65 72 20 6c 69 73 74 73 0a 20 improper lists.
50f0: 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 ((compare x y
5100: 29 0a 20 20 20 20 20 28 63 6f 6e 64 2d 63 6f 6d ). (cond-com
5110: 70 61 72 65 20 0a 20 20 20 20 20 20 28 28 28 6e pare . (((n
5120: 75 6c 6c 3f 20 78 29 20 28 6e 75 6c 6c 3f 20 79 ull? x) (null? y
5130: 29 29 20 30 29 0a 20 20 20 20 20 20 28 28 28 70 )) 0). (((p
5140: 61 69 72 3f 20 78 29 20 28 70 61 69 72 3f 20 79 air? x) (pair? y
5150: 29 29 20 28 63 6f 6d 70 61 72 65 20 20 20 20 20 )) (compare
5160: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 78 29 (car x)
5170: 20 28 63 61 72 20 79 29 29 0a 20 20 20 20 20 20 (car y)).
5180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5190: 20 20 20 20 20 20 20 28 70 61 69 72 2d 63 6f 6d (pair-com
51a0: 70 61 72 65 20 63 6f 6d 70 61 72 65 20 28 63 64 pare compare (cd
51b0: 72 20 78 29 20 28 63 64 72 20 79 29 29 29 0a 20 r x) (cdr y))).
51c0: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
51d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
51e0: 70 61 72 65 20 78 20 79 29 29 29 29 0a 20 20 20 pare x y)))).
51f0: 20 0a 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 . ; for conv
5200: 65 6e 69 65 6e 63 65 0a 20 20 20 20 28 28 78 20 enience. ((x
5210: 79 29 0a 20 20 20 20 20 28 70 61 69 72 2d 63 6f y). (pair-co
5220: 6d 70 61 72 65 20 64 65 66 61 75 6c 74 2d 63 6f mpare default-co
5230: 6d 70 61 72 65 20 78 20 79 29 29 29 29 0a 0a 28 mpare x y))))..(
5240: 64 65 66 69 6e 65 20 6c 69 73 74 2d 63 6f 6d 70 define list-comp
5250: 61 72 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 are. (case-lamb
5260: 64 61 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 da. ((compare
5270: 20 78 20 79 20 65 6d 70 74 79 3f 20 68 65 61 64 x y empty? head
5280: 20 74 61 69 6c 29 0a 20 20 20 20 20 28 63 6f 6e tail). (con
5290: 64 2d 63 6f 6d 70 61 72 65 0a 20 20 20 20 20 20 d-compare.
52a0: 28 28 28 65 6d 70 74 79 3f 20 78 29 20 28 65 6d (((empty? x) (em
52b0: 70 74 79 3f 20 79 29 29 20 30 29 0a 20 20 20 20 pty? y)) 0).
52c0: 20 20 28 65 6c 73 65 20 28 63 6f 6d 70 61 72 65 (else (compare
52d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
52e0: 65 61 64 20 78 29 20 28 68 65 61 64 20 79 29 29 ead x) (head y))
52f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 . (li
5300: 73 74 2d 63 6f 6d 70 61 72 65 20 63 6f 6d 70 61 st-compare compa
5310: 72 65 20 28 74 61 69 6c 20 78 29 20 28 74 61 69 re (tail x) (tai
5320: 6c 20 79 29 20 65 6d 70 74 79 3f 20 68 65 61 64 l y) empty? head
5330: 20 74 61 69 6c 29 29 29 29 0a 20 20 20 20 0a 20 tail)))). .
5340: 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 65 6e 69 ; for conveni
5350: 65 6e 63 65 0a 20 20 20 20 28 28 20 20 20 20 20 ence. ((
5360: 20 20 20 78 20 79 20 65 6d 70 74 79 3f 20 68 65 x y empty? he
5370: 61 64 20 74 61 69 6c 29 0a 20 20 20 20 20 28 6c ad tail). (l
5380: 69 73 74 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 ist-compare defa
5390: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 ult-compare x y
53a0: 65 6d 70 74 79 3f 20 68 65 61 64 20 74 61 69 6c empty? head tail
53b0: 29 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 )). ((compare
53c0: 20 78 20 79 20 20 20 20 20 20 20 20 20 20 20 20 x y
53d0: 20 20 29 0a 20 20 20 20 20 28 6c 69 73 74 2d 63 ). (list-c
53e0: 6f 6d 70 61 72 65 20 63 6f 6d 70 61 72 65 20 20 ompare compare
53f0: 20 20 20 20 20 20 20 78 20 79 20 6e 75 6c 6c 3f x y null?
5400: 20 63 61 72 20 20 20 63 64 72 29 29 0a 20 20 20 car cdr)).
5410: 20 28 28 20 20 20 20 20 20 20 20 78 20 79 20 20 (( x y
5420: 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 ).
5430: 20 20 20 28 6c 69 73 74 2d 63 6f 6d 70 61 72 65 (list-compare
5440: 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 default-compare
5450: 20 78 20 79 20 6e 75 6c 6c 3f 20 63 61 72 20 20 x y null? car
5460: 20 63 64 72 29 29 29 29 0a 0a 28 64 65 66 69 6e cdr))))..(defin
5470: 65 20 6c 69 73 74 2d 63 6f 6d 70 61 72 65 2d 61 e list-compare-a
5480: 73 2d 76 65 63 74 6f 72 0a 20 20 28 63 61 73 65 s-vector. (case
5490: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 63 6f -lambda. ((co
54a0: 6d 70 61 72 65 20 78 20 79 20 65 6d 70 74 79 3f mpare x y empty?
54b0: 20 68 65 61 64 20 74 61 69 6c 29 0a 20 20 20 20 head tail).
54c0: 20 28 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 (refine-compare
54d0: 0a 20 20 20 20 20 20 28 6c 65 74 20 63 6f 6d 70 . (let comp
54e0: 61 72 65 2d 6c 65 6e 67 74 68 20 28 28 78 20 78 are-length ((x x
54f0: 29 20 28 79 20 79 29 29 0a 20 20 20 20 20 20 20 ) (y y)).
5500: 20 28 63 6f 6e 64 2d 63 6f 6d 70 61 72 65 0a 20 (cond-compare.
5510: 20 20 20 20 20 20 20 20 28 28 28 65 6d 70 74 79 (((empty
5520: 3f 20 78 29 20 28 65 6d 70 74 79 3f 20 79 29 29 ? x) (empty? y))
5530: 20 30 29 0a 20 20 20 20 20 20 20 20 20 28 65 6c 0). (el
5540: 73 65 20 28 63 6f 6d 70 61 72 65 2d 6c 65 6e 67 se (compare-leng
5550: 74 68 20 28 74 61 69 6c 20 78 29 20 28 74 61 69 th (tail x) (tai
5560: 6c 20 79 29 29 29 29 29 0a 20 20 20 20 20 20 28 l y))))). (
5570: 6c 69 73 74 2d 63 6f 6d 70 61 72 65 20 63 6f 6d list-compare com
5580: 70 61 72 65 20 78 20 79 20 65 6d 70 74 79 3f 20 pare x y empty?
5590: 68 65 61 64 20 74 61 69 6c 29 29 29 0a 20 20 20 head tail))).
55a0: 20 0a 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 . ; for conv
55b0: 65 6e 69 65 6e 63 65 0a 20 20 20 20 28 28 20 20 enience. ((
55c0: 20 20 20 20 20 20 78 20 79 20 65 6d 70 74 79 3f x y empty?
55d0: 20 68 65 61 64 20 74 61 69 6c 29 0a 20 20 20 20 head tail).
55e0: 20 28 6c 69 73 74 2d 63 6f 6d 70 61 72 65 2d 61 (list-compare-a
55f0: 73 2d 76 65 63 74 6f 72 20 64 65 66 61 75 6c 74 s-vector default
5600: 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 65 6d 70 -compare x y emp
5610: 74 79 3f 20 68 65 61 64 20 74 61 69 6c 29 29 0a ty? head tail)).
5620: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 ((compare x
5630: 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 y )
5640: 0a 20 20 20 20 20 28 6c 69 73 74 2d 63 6f 6d 70 . (list-comp
5650: 61 72 65 2d 61 73 2d 76 65 63 74 6f 72 20 63 6f are-as-vector co
5660: 6d 70 61 72 65 20 20 20 20 20 20 20 20 20 78 20 mpare x
5670: 79 20 6e 75 6c 6c 3f 20 20 63 61 72 20 20 63 64 y null? car cd
5680: 72 29 29 0a 20 20 20 20 28 28 20 20 20 20 20 20 r)). ((
5690: 20 20 78 20 79 20 20 20 20 20 20 20 20 20 20 20 x y
56a0: 20 20 20 29 0a 20 20 20 20 20 28 6c 69 73 74 2d ). (list-
56b0: 63 6f 6d 70 61 72 65 2d 61 73 2d 76 65 63 74 6f compare-as-vecto
56c0: 72 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 r default-compar
56d0: 65 20 78 20 79 20 6e 75 6c 6c 3f 20 20 63 61 72 e x y null? car
56e0: 20 20 63 64 72 29 29 29 29 0a 0a 28 64 65 66 69 cdr))))..(defi
56f0: 6e 65 20 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 ne vector-compar
5700: 65 0a 20 20 28 6c 65 74 20 28 28 3d 20 3d 29 29 e. (let ((= =))
5710: 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 . (case-lambd
5720: 61 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 a. ((compar
5730: 65 20 78 20 79 20 73 69 7a 65 20 72 65 66 29 0a e x y size ref).
5740: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 20 (let ((n
5750: 28 73 69 7a 65 20 78 29 29 20 28 6d 20 28 73 69 (size x)) (m (si
5760: 7a 65 20 79 29 29 29 0a 20 20 20 20 20 20 20 20 ze y))).
5770: 20 28 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 (refine-compare
5780: 20 0a 20 20 20 20 20 20 20 20 20 20 28 69 6e 74 . (int
5790: 65 67 65 72 2d 63 6f 6d 70 61 72 65 20 6e 20 6d eger-compare n m
57a0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 ). (let
57b0: 20 63 6f 6d 70 61 72 65 2d 72 65 73 74 20 28 28 compare-rest ((
57c0: 69 20 30 29 29 20 3b 20 63 6f 6d 70 61 72 65 20 i 0)) ; compare
57d0: 78 5b 69 2e 2e 6e 2d 31 5d 20 79 5b 69 2e 2e 6e x[i..n-1] y[i..n
57e0: 2d 31 5d 0a 20 20 20 20 20 20 20 20 20 20 20 20 -1].
57f0: 28 69 66 20 28 3d 20 69 20 6e 29 0a 20 20 20 20 (if (= i n).
5800: 20 20 20 20 20 20 20 20 20 20 20 20 30 0a 20 20 0.
5810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
5820: 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 28 63 efine-compare (c
5830: 6f 6d 70 61 72 65 20 28 72 65 66 20 78 20 69 29 ompare (ref x i)
5840: 20 28 72 65 66 20 79 20 69 29 29 0a 20 20 20 20 (ref y i)).
5850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5860: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
5870: 70 61 72 65 2d 72 65 73 74 20 28 2b 20 69 20 31 pare-rest (+ i 1
5880: 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a )))))))). .
5890: 20 20 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 ; for conv
58a0: 65 6e 69 65 6e 63 65 0a 20 20 20 20 20 20 28 28 enience. ((
58b0: 20 20 20 20 20 20 20 20 78 20 79 20 73 69 7a 65 x y size
58c0: 20 72 65 66 29 0a 20 20 20 20 20 20 20 28 76 65 ref). (ve
58d0: 63 74 6f 72 2d 63 6f 6d 70 61 72 65 20 64 65 66 ctor-compare def
58e0: 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 ault-compare x y
58f0: 20 73 69 7a 65 20 20 20 20 20 20 20 20 20 20 72 size r
5900: 65 66 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d ef)). ((com
5910: 70 61 72 65 20 78 20 79 20 20 20 20 20 20 20 20 pare x y
5920: 20 20 20 29 0a 20 20 20 20 20 20 20 28 76 65 63 ). (vec
5930: 74 6f 72 2d 63 6f 6d 70 61 72 65 20 63 6f 6d 70 tor-compare comp
5940: 61 72 65 20 20 20 20 20 20 20 20 20 78 20 79 20 are x y
5950: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 vector-length ve
5960: 63 74 6f 72 2d 72 65 66 29 29 0a 20 20 20 20 20 ctor-ref)).
5970: 20 28 28 20 20 20 20 20 20 20 20 78 20 79 20 20 (( x y
5980: 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 ).
5990: 20 20 28 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 (vector-compar
59a0: 65 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 e default-compar
59b0: 65 20 78 20 79 20 76 65 63 74 6f 72 2d 6c 65 6e e x y vector-len
59c0: 67 74 68 20 76 65 63 74 6f 72 2d 72 65 66 29 29 gth vector-ref))
59d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 76 65 63 )))..(define vec
59e0: 74 6f 72 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 6c tor-compare-as-l
59f0: 69 73 74 0a 20 20 28 6c 65 74 20 28 28 3d 20 3d ist. (let ((= =
5a00: 29 29 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d )). (case-lam
5a10: 62 64 61 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 bda. ((comp
5a20: 61 72 65 20 78 20 79 20 73 69 7a 65 20 72 65 66 are x y size ref
5a30: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ). (let ((
5a40: 6e 78 20 28 73 69 7a 65 20 78 29 29 20 28 6e 79 nx (size x)) (ny
5a50: 20 28 73 69 7a 65 20 79 29 29 29 0a 20 20 20 20 (size y))).
5a60: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 20 28 6d (let ((n (m
5a70: 69 6e 20 6e 78 20 6e 79 29 29 29 0a 20 20 20 20 in nx ny))).
5a80: 20 20 20 20 20 20 20 28 6c 65 74 20 63 6f 6d 70 (let comp
5a90: 61 72 65 2d 72 65 73 74 20 28 28 69 20 30 29 29 are-rest ((i 0))
5aa0: 20 3b 20 63 6f 6d 70 61 72 65 20 78 5b 69 2e 2e ; compare x[i..
5ab0: 6e 2d 31 5d 20 79 5b 69 2e 2e 6e 2d 31 5d 0a 20 n-1] y[i..n-1].
5ac0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5ad0: 28 3d 20 69 20 6e 29 0a 20 20 20 20 20 20 20 20 (= i n).
5ae0: 20 20 20 20 20 20 20 20 20 28 69 6e 74 65 67 65 (intege
5af0: 72 2d 63 6f 6d 70 61 72 65 20 6e 78 20 6e 79 29 r-compare nx ny)
5b00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5b10: 20 20 28 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 (refine-compar
5b20: 65 20 28 63 6f 6d 70 61 72 65 20 28 72 65 66 20 e (compare (ref
5b30: 78 20 69 29 20 28 72 65 66 20 79 20 69 29 29 0a x i) (ref y i)).
5b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b60: 20 28 63 6f 6d 70 61 72 65 2d 72 65 73 74 20 28 (compare-rest (
5b70: 2b 20 69 20 31 29 29 29 29 29 29 29 29 0a 20 20 + i 1)))))))).
5b80: 20 20 20 20 0a 20 20 20 20 20 20 3b 20 66 6f 72 . ; for
5b90: 20 63 6f 6e 76 65 6e 69 65 6e 63 65 0a 20 20 20 convenience.
5ba0: 20 20 20 28 28 20 20 20 20 20 20 20 20 78 20 79 (( x y
5bb0: 20 73 69 7a 65 20 72 65 66 29 0a 20 20 20 20 20 size ref).
5bc0: 20 20 28 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 (vector-compar
5bd0: 65 2d 61 73 2d 6c 69 73 74 20 64 65 66 61 75 6c e-as-list defaul
5be0: 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 73 69 t-compare x y si
5bf0: 7a 65 20 20 20 20 20 20 20 20 20 20 72 65 66 29 ze ref)
5c00: 29 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 ). ((compar
5c10: 65 20 78 20 79 20 20 20 20 20 20 20 20 20 20 20 e x y
5c20: 29 0a 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 ). (vector
5c30: 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 6c 69 73 74 -compare-as-list
5c40: 20 63 6f 6d 70 61 72 65 20 20 20 20 20 20 20 20 compare
5c50: 20 78 20 79 20 76 65 63 74 6f 72 2d 6c 65 6e 67 x y vector-leng
5c60: 74 68 20 76 65 63 74 6f 72 2d 72 65 66 29 29 0a th vector-ref)).
5c70: 20 20 20 20 20 20 28 28 20 20 20 20 20 20 20 20 ((
5c80: 78 20 79 20 20 20 20 20 20 20 20 20 20 20 29 0a x y ).
5c90: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 63 (vector-c
5ca0: 6f 6d 70 61 72 65 2d 61 73 2d 6c 69 73 74 20 64 ompare-as-list d
5cb0: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 efault-compare x
5cc0: 20 79 20 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 y vector-length
5cd0: 20 76 65 63 74 6f 72 2d 72 65 66 29 29 29 29 29 vector-ref)))))
5ce0: 0a 0a 0a 3b 20 64 65 66 61 75 6c 74 20 63 6f 6d ...; default com
5cf0: 70 61 72 65 0a 0a 28 64 65 66 69 6e 65 20 28 64 pare..(define (d
5d00: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 efault-compare x
5d10: 20 79 29 0a 20 20 28 73 65 6c 65 63 74 2d 63 6f y). (select-co
5d20: 6d 70 61 72 65 20 0a 20 20 20 78 20 79 0a 20 20 mpare . x y.
5d30: 20 28 6e 75 6c 6c 3f 20 20 20 20 30 29 0a 20 20 (null? 0).
5d40: 20 28 70 61 69 72 3f 20 20 20 20 28 64 65 66 61 (pair? (defa
5d50: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 28 63 61 72 ult-compare (car
5d60: 20 78 29 20 28 63 61 72 20 79 29 29 0a 20 20 20 x) (car y)).
5d70: 20 20 20 20 20 20 20 20 20 20 28 64 65 66 61 75 (defau
5d80: 6c 74 2d 63 6f 6d 70 61 72 65 20 28 63 64 72 20 lt-compare (cdr
5d90: 78 29 20 28 63 64 72 20 79 29 29 29 0a 20 20 20 x) (cdr y))).
5da0: 28 62 6f 6f 6c 65 61 6e 3f 20 28 62 6f 6f 6c 65 (boolean? (boole
5db0: 61 6e 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 29 an-compare x y))
5dc0: 0a 20 20 20 28 63 68 61 72 3f 20 20 20 20 28 63 . (char? (c
5dd0: 68 61 72 2d 63 6f 6d 70 61 72 65 20 20 20 20 78 har-compare x
5de0: 20 79 29 29 0a 20 20 20 28 73 74 72 69 6e 67 3f y)). (string?
5df0: 20 20 28 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 (string-compar
5e00: 65 20 20 78 20 79 29 29 0a 20 20 20 28 73 79 6d e x y)). (sym
5e10: 62 6f 6c 3f 20 20 28 73 79 6d 62 6f 6c 2d 63 6f bol? (symbol-co
5e20: 6d 70 61 72 65 20 20 78 20 79 29 29 0a 20 20 20 mpare x y)).
5e30: 28 6e 75 6d 62 65 72 3f 20 20 28 6e 75 6d 62 65 (number? (numbe
5e40: 72 2d 63 6f 6d 70 61 72 65 20 20 78 20 79 29 29 r-compare x y))
5e50: 0a 20 20 20 28 76 65 63 74 6f 72 3f 20 20 28 76 . (vector? (v
5e60: 65 63 74 6f 72 2d 63 6f 6d 70 61 72 65 20 64 65 ector-compare de
5e70: 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 fault-compare x
5e80: 79 29 29 0a 20 20 20 28 65 6c 73 65 20 28 65 72 y)). (else (er
5e90: 72 6f 72 20 22 75 6e 72 65 63 6f 67 6e 69 7a 65 ror "unrecognize
5ea0: 64 20 74 79 70 65 20 69 6e 20 64 65 66 61 75 6c d type in defaul
5eb0: 74 2d 63 6f 6d 70 61 72 65 22 20 78 20 79 29 29 t-compare" x y))
5ec0: 29 29 0a 0a 3b 20 4e 6f 74 65 20 74 68 61 74 20 ))..; Note that
5ed0: 77 65 20 70 61 73 73 20 64 65 66 61 75 6c 74 2d we pass default-
5ee0: 63 6f 6d 70 61 72 65 20 74 6f 20 63 6f 6d 70 61 compare to compa
5ef0: 72 65 2d 7b 70 61 69 72 2c 76 65 63 74 6f 72 7d re-{pair,vector}
5f00: 20 65 78 70 6c 69 63 74 6c 79 2e 0a 3b 20 54 68 explictly..; Th
5f10: 69 73 20 6d 61 6b 65 73 20 73 75 72 65 20 72 65 is makes sure re
5f20: 63 75 72 73 69 6f 6e 20 70 72 6f 63 65 65 64 73 cursion proceeds
5f30: 20 77 69 74 68 20 74 68 69 73 20 64 65 66 61 75 with this defau
5f40: 6c 74 2d 63 6f 6d 70 61 72 65 2c 20 77 68 69 63 lt-compare, whic
5f50: 68 20 0a 3b 20 6e 65 65 64 20 6e 6f 74 20 62 65 h .; need not be
5f60: 20 74 68 65 20 6f 6e 65 20 69 6e 20 74 68 65 20 the one in the
5f70: 6c 65 78 69 63 61 6c 20 73 63 6f 70 65 20 6f 66 lexical scope of
5f80: 20 63 6f 6d 70 61 72 65 2d 7b 70 61 69 72 2c 76 compare-{pair,v
5f90: 65 63 74 6f 72 7d 2e 0a 0a 0a 3b 20 64 65 62 75 ector}....; debu
5fa0: 67 20 63 6f 6d 70 61 72 65 0a 0a 28 64 65 66 69 g compare..(defi
5fb0: 6e 65 20 28 64 65 62 75 67 2d 63 6f 6d 70 61 72 ne (debug-compar
5fc0: 65 20 63 29 0a 20 20 0a 20 20 28 64 65 66 69 6e e c). . (defin
5fd0: 65 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 e (checked-value
5fe0: 20 63 20 78 20 79 29 0a 20 20 20 20 28 6c 65 74 c x y). (let
5ff0: 20 28 28 63 2d 78 79 20 28 63 20 78 20 79 29 29 ((c-xy (c x y))
6000: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 ). (if (or
6010: 28 65 71 76 3f 20 63 2d 78 79 20 2d 31 29 20 28 (eqv? c-xy -1) (
6020: 65 71 76 3f 20 63 2d 78 79 20 30 29 20 28 65 71 eqv? c-xy 0) (eq
6030: 76 3f 20 63 2d 78 79 20 31 29 29 0a 20 20 20 20 v? c-xy 1)).
6040: 20 20 20 20 20 20 63 2d 78 79 0a 20 20 20 20 20 c-xy.
6050: 20 20 20 20 20 28 65 72 72 6f 72 20 22 63 6f 6d (error "com
6060: 70 61 72 65 20 76 61 6c 75 65 20 6e 6f 74 20 69 pare value not i
6070: 6e 20 7b 2d 31 2c 30 2c 31 7d 22 20 63 2d 78 79 n {-1,0,1}" c-xy
6080: 20 28 6c 69 73 74 20 63 20 78 20 79 29 29 29 29 (list c x y))))
6090: 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 ). . (define (
60a0: 72 61 6e 64 6f 6d 2d 62 6f 6f 6c 65 61 6e 29 0a random-boolean).
60b0: 20 20 20 20 28 7a 65 72 6f 3f 20 28 72 61 6e 64 (zero? (rand
60c0: 6f 6d 2d 69 6e 74 65 67 65 72 20 32 29 29 29 0a om-integer 2))).
60d0: 20 20 0a 20 20 28 64 65 66 69 6e 65 20 71 20 3b . (define q ;
60e0: 20 28 75 20 76 20 77 29 20 73 75 63 68 20 74 68 (u v w) such th
60f0: 61 74 20 75 20 3c 3d 20 76 2c 20 76 20 3c 3d 20 at u <= v, v <=
6100: 77 2c 20 61 6e 64 20 6e 6f 74 20 75 20 3c 3d 20 w, and not u <=
6110: 77 0a 20 20 20 20 27 23 28 0a 20 20 20 20 20 20 w. '#(.
6120: 20 3b 78 20 3c 20 79 20 20 20 78 20 3d 20 79 20 ;x < y x = y
6130: 20 20 78 20 3e 20 79 20 20 20 5b 78 20 3c 20 7a x > y [x < z
6140: 5d 0a 20 20 20 20 20 20 20 30 20 20 20 20 20 20 ]. 0
6150: 20 30 20 20 20 20 20 20 20 30 20 20 20 20 3b 20 0 0 ;
6160: 79 20 3c 20 7a 0a 20 20 20 20 20 20 20 20 20 20 y < z.
6170: 20 20 20 20 20 30 20 20 20 20 28 7a 20 79 20 78 0 (z y x
6180: 29 20 28 7a 20 79 20 78 29 20 3b 20 79 20 3d 20 ) (z y x) ; y =
6190: 7a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 z.
61a0: 20 30 20 20 20 20 28 7a 20 79 20 78 29 20 28 7a 0 (z y x) (z
61b0: 20 79 20 78 29 20 3b 20 79 20 3e 20 7a 0a 20 20 y x) ; y > z.
61c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 .
61d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 78 20 ;x
61e0: 3c 20 79 20 20 20 78 20 3d 20 79 20 20 20 78 20 < y x = y x
61f0: 3e 20 79 20 20 20 5b 78 20 3d 20 7a 5d 0a 20 20 > y [x = z].
6200: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 79 20 (y
6210: 7a 20 78 29 20 28 7a 20 78 20 79 29 20 20 20 20 z x) (z x y)
6220: 30 20 20 20 20 3b 20 79 20 3c 20 7a 0a 20 20 20 0 ; y < z.
6230: 20 20 20 20 20 20 20 20 20 20 20 20 28 79 20 7a (y z
6240: 20 78 29 20 20 20 20 30 20 20 20 20 28 78 20 7a x) 0 (x z
6250: 20 79 29 20 3b 20 79 20 3d 20 7a 0a 20 20 20 20 y) ; y = z.
6260: 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 0
6270: 28 79 20 78 20 7a 29 20 28 78 20 7a 20 79 29 20 (y x z) (x z y)
6280: 3b 20 79 20 3e 20 7a 0a 20 20 20 20 20 20 20 20 ; y > z.
6290: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
62a0: 20 20 20 20 20 20 20 3b 78 20 3c 20 79 20 20 20 ;x < y
62b0: 78 20 3d 20 79 20 20 20 78 20 3e 20 79 20 20 20 x = y x > y
62c0: 5b 78 20 3e 20 7a 5d 0a 20 20 20 20 20 20 20 20 [x > z].
62d0: 20 20 20 20 20 20 20 28 78 20 79 20 7a 29 20 28 (x y z) (
62e0: 78 20 79 20 7a 29 20 20 20 20 30 20 20 20 20 3b x y z) 0 ;
62f0: 20 79 20 3c 20 7a 0a 20 20 20 20 20 20 20 20 20 y < z.
6300: 20 20 20 20 20 20 28 78 20 79 20 7a 29 20 28 78 (x y z) (x
6310: 20 79 20 7a 29 20 20 20 20 30 20 20 20 20 3b 20 y z) 0 ;
6320: 79 20 3d 20 7a 0a 20 20 20 20 20 20 20 20 20 20 y = z.
6330: 20 20 20 20 20 30 20 20 20 20 20 20 20 30 20 20 0 0
6340: 20 20 20 20 20 30 20 20 20 20 3b 20 79 20 3e 20 0 ; y >
6350: 7a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 z.
6360: 20 29 29 0a 20 20 0a 20 20 28 6c 65 74 20 28 28 )). . (let ((
6370: 7a 3f 20 23 66 29 20 28 7a 20 23 66 29 29 20 3b z? #f) (z #f)) ;
6380: 20 73 74 6f 72 65 64 20 65 6c 65 6d 65 6e 74 20 stored element
6390: 66 72 6f 6d 20 70 72 65 76 69 6f 75 73 20 63 61 from previous ca
63a0: 6c 6c 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ll. (lambda (
63b0: 78 20 79 29 0a 20 20 20 20 20 20 28 6c 65 74 20 x y). (let
63c0: 28 28 63 2d 78 78 20 28 63 68 65 63 6b 65 64 2d ((c-xx (checked-
63d0: 76 61 6c 75 65 20 63 20 78 20 78 29 29 0a 20 20 value c x x)).
63e0: 20 20 20 20 20 20 20 20 20 20 28 63 2d 79 79 20 (c-yy
63f0: 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 20 63 (checked-value c
6400: 20 79 20 79 29 29 0a 20 20 20 20 20 20 20 20 20 y y)).
6410: 20 20 20 28 63 2d 78 79 20 28 63 68 65 63 6b 65 (c-xy (checke
6420: 64 2d 76 61 6c 75 65 20 63 20 78 20 79 29 29 0a d-value c x y)).
6430: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 2d 79 (c-y
6440: 78 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 x (checked-value
6450: 20 63 20 79 20 78 29 29 29 0a 20 20 20 20 20 20 c y x))).
6460: 20 20 28 69 66 20 28 6e 6f 74 20 28 7a 65 72 6f (if (not (zero
6470: 3f 20 63 2d 78 78 29 29 0a 20 20 20 20 20 20 20 ? c-xx)).
6480: 20 20 20 20 20 28 65 72 72 6f 72 20 22 63 6f 6d (error "com
6490: 70 61 72 65 20 65 72 72 6f 72 3a 20 6e 6f 74 20 pare error: not
64a0: 72 65 66 6c 65 78 69 76 65 22 20 63 20 78 29 29 reflexive" c x))
64b0: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f . (if (no
64c0: 74 20 28 7a 65 72 6f 3f 20 63 2d 79 79 29 29 0a t (zero? c-yy)).
64d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
64e0: 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f or "compare erro
64f0: 72 3a 20 6e 6f 74 20 72 65 66 6c 65 78 69 76 65 r: not reflexive
6500: 22 20 63 20 79 29 29 0a 20 20 20 20 20 20 20 20 " c y)).
6510: 28 69 66 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 (if (not (zero?
6520: 28 2b 20 63 2d 78 79 20 63 2d 79 78 29 29 29 0a (+ c-xy c-yx))).
6530: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
6540: 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f or "compare erro
6550: 72 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 79 6d 6d r: not anti-symm
6560: 65 74 72 69 63 22 20 63 20 78 20 79 29 29 0a 20 etric" c x y)).
6570: 20 20 20 20 20 20 20 28 69 66 20 7a 3f 0a 20 20 (if z?.
6580: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
6590: 28 63 2d 78 7a 20 28 63 68 65 63 6b 65 64 2d 76 (c-xz (checked-v
65a0: 61 6c 75 65 20 63 20 78 20 7a 29 29 0a 20 20 20 alue c x z)).
65b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
65c0: 63 2d 7a 78 20 28 63 68 65 63 6b 65 64 2d 76 61 c-zx (checked-va
65d0: 6c 75 65 20 63 20 7a 20 78 29 29 0a 20 20 20 20 lue c z x)).
65e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
65f0: 2d 79 7a 20 28 63 68 65 63 6b 65 64 2d 76 61 6c -yz (checked-val
6600: 75 65 20 63 20 79 20 7a 29 29 0a 20 20 20 20 20 ue c y z)).
6610: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 2d (c-
6620: 7a 79 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 zy (checked-valu
6630: 65 20 63 20 7a 20 79 29 29 29 0a 20 20 20 20 20 e c z y))).
6640: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
6650: 74 20 28 7a 65 72 6f 3f 20 28 2b 20 63 2d 78 7a t (zero? (+ c-xz
6660: 20 63 2d 7a 78 29 29 29 0a 20 20 20 20 20 20 20 c-zx))).
6670: 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f (erro
6680: 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f 72 r "compare error
6690: 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 79 6d 6d 65 : not anti-symme
66a0: 74 72 69 63 22 20 63 20 78 20 7a 29 29 0a 20 20 tric" c x z)).
66b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
66c0: 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 28 2b 20 63 (not (zero? (+ c
66d0: 2d 79 7a 20 63 2d 7a 79 29 29 29 0a 20 20 20 20 -yz c-zy))).
66e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
66f0: 72 72 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 rror "compare er
6700: 72 6f 72 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 79 ror: not anti-sy
6710: 6d 6d 65 74 72 69 63 22 20 63 20 79 20 7a 29 29 mmetric" c y z))
6720: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
6730: 6c 65 74 20 28 28 69 6a 6b 20 28 76 65 63 74 6f let ((ijk (vecto
6740: 72 2d 72 65 66 20 71 20 28 2b 20 63 2d 78 79 20 r-ref q (+ c-xy
6750: 28 2a 20 33 20 63 2d 79 7a 29 20 28 2a 20 39 20 (* 3 c-yz) (* 9
6760: 63 2d 78 7a 29 20 31 33 29 29 29 29 0a 20 20 20 c-xz) 13)))).
6770: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6780: 20 28 6c 69 73 74 3f 20 69 6a 6b 29 0a 20 20 20 (list? ijk).
6790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67a0: 20 28 61 70 70 6c 79 20 65 72 72 6f 72 0a 20 20 (apply error.
67b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67c0: 20 20 20 20 20 20 20 20 20 22 63 6f 6d 70 61 72 "compar
67d0: 65 20 65 72 72 6f 72 3a 20 6e 6f 74 20 74 72 61 e error: not tra
67e0: 6e 73 69 74 69 76 65 22 0a 20 20 20 20 20 20 20 nsitive".
67f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6800: 20 20 20 20 63 20 0a 20 20 20 20 20 20 20 20 20 c .
6810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6820: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
6830: 69 29 20 28 63 61 73 65 20 69 20 28 28 78 29 20 i) (case i ((x)
6840: 78 29 20 28 28 79 29 20 79 29 20 28 28 7a 29 20 x) ((y) y) ((z)
6850: 7a 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 z))).
6860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6870: 20 20 20 20 20 69 6a 6b 29 29 29 29 29 0a 20 20 ijk))))).
6880: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
6890: 7a 3f 20 23 74 29 29 0a 20 20 20 20 20 20 20 20 z? #t)).
68a0: 28 73 65 74 21 20 7a 20 28 69 66 20 28 72 61 6e (set! z (if (ran
68b0: 64 6f 6d 2d 62 6f 6f 6c 65 61 6e 29 20 78 20 79 dom-boolean) x y
68c0: 29 29 20 3b 20 72 61 6e 64 6f 6d 69 7a 65 64 20 )) ; randomized
68d0: 74 65 73 74 69 6e 67 0a 20 20 20 20 20 20 20 20 testing.
68e0: 63 2d 78 79 29 29 29 29 0a 20 20 0a 20 20 29 0a c-xy)))). . ).