0000: 3b 20 28 64 65 66 69 6e 65 20 63 75 72 72 65 6e ; (define curren
0010: 74 2d 63 6f 6d 70 61 72 65 20 28 6d 61 6b 65 2d t-compare (make-
0020: 70 61 72 61 6d 65 74 65 72 20 64 65 66 61 75 6c parameter defaul
0030: 74 2d 63 6f 6d 70 61 72 65 29 29 0a 3b 20 28 70 t-compare)).; (p
0040: 72 6f 76 69 64 65 20 63 75 72 72 65 6e 74 2d 63 rovide current-c
0050: 6f 6d 70 61 72 65 29 0a 0a 3b 20 43 6f 70 79 72 ompare)..; Copyr
0060: 69 67 68 74 20 28 63 29 20 32 30 30 35 20 53 65 ight (c) 2005 Se
0070: 62 61 73 74 69 61 6e 20 45 67 6e 65 72 20 61 6e bastian Egner an
0080: 64 20 4a 65 6e 73 20 41 78 65 6c 20 53 7b 5c 6f d Jens Axel S{\o
0090: 7d 67 61 61 72 64 2e 0a 3b 20 0a 3b 20 50 65 72 }gaard..; .; Per
00a0: 6d 69 73 73 69 6f 6e 20 69 73 20 68 65 72 65 62 mission is hereb
00b0: 79 20 67 72 61 6e 74 65 64 2c 20 66 72 65 65 20 y granted, free
00c0: 6f 66 20 63 68 61 72 67 65 2c 20 74 6f 20 61 6e of charge, to an
00d0: 79 20 70 65 72 73 6f 6e 20 6f 62 74 61 69 6e 69 y person obtaini
00e0: 6e 67 0a 3b 20 61 20 63 6f 70 79 20 6f 66 20 74 ng.; a copy of t
00f0: 68 69 73 20 73 6f 66 74 77 61 72 65 20 61 6e 64 his software and
0100: 20 61 73 73 6f 63 69 61 74 65 64 20 64 6f 63 75 associated docu
0110: 6d 65 6e 74 61 74 69 6f 6e 20 66 69 6c 65 73 20 mentation files
0120: 28 74 68 65 0a 3b 20 60 60 53 6f 66 74 77 61 72 (the.; ``Softwar
0130: 65 27 27 29 2c 20 74 6f 20 64 65 61 6c 20 69 6e e''), to deal in
0140: 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 77 69 the Software wi
0150: 74 68 6f 75 74 20 72 65 73 74 72 69 63 74 69 6f thout restrictio
0160: 6e 2c 20 69 6e 63 6c 75 64 69 6e 67 0a 3b 20 77 n, including.; w
0170: 69 74 68 6f 75 74 20 6c 69 6d 69 74 61 74 69 6f ithout limitatio
0180: 6e 20 74 68 65 20 72 69 67 68 74 73 20 74 6f 20 n the rights to
0190: 75 73 65 2c 20 63 6f 70 79 2c 20 6d 6f 64 69 66 use, copy, modif
01a0: 79 2c 20 6d 65 72 67 65 2c 20 70 75 62 6c 69 73 y, merge, publis
01b0: 68 2c 0a 3b 20 64 69 73 74 72 69 62 75 74 65 2c h,.; distribute,
01c0: 20 73 75 62 6c 69 63 65 6e 73 65 2c 20 61 6e 64 sublicense, and
01d0: 2f 6f 72 20 73 65 6c 6c 20 63 6f 70 69 65 73 20 /or sell copies
01e0: 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 65 2c of the Software,
01f0: 20 61 6e 64 20 74 6f 0a 3b 20 70 65 72 6d 69 74 and to.; permit
0200: 20 70 65 72 73 6f 6e 73 20 74 6f 20 77 68 6f 6d persons to whom
0210: 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 69 73 the Software is
0220: 20 66 75 72 6e 69 73 68 65 64 20 74 6f 20 64 6f furnished to do
0230: 20 73 6f 2c 20 73 75 62 6a 65 63 74 20 74 6f 0a so, subject to.
0240: 3b 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 ; the following
0250: 63 6f 6e 64 69 74 69 6f 6e 73 3a 0a 3b 20 0a 3b conditions:.; .;
0260: 20 54 68 65 20 61 62 6f 76 65 20 63 6f 70 79 72 The above copyr
0270: 69 67 68 74 20 6e 6f 74 69 63 65 20 61 6e 64 20 ight notice and
0280: 74 68 69 73 20 70 65 72 6d 69 73 73 69 6f 6e 20 this permission
0290: 6e 6f 74 69 63 65 20 73 68 61 6c 6c 20 62 65 0a notice shall be.
02a0: 3b 20 69 6e 63 6c 75 64 65 64 20 69 6e 20 61 6c ; included in al
02b0: 6c 20 63 6f 70 69 65 73 20 6f 72 20 73 75 62 73 l copies or subs
02c0: 74 61 6e 74 69 61 6c 20 70 6f 72 74 69 6f 6e 73 tantial portions
02d0: 20 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 65 of the Software
02e0: 2e 0a 3b 20 0a 3b 20 54 48 45 20 53 4f 46 54 57 ..; .; THE SOFTW
02f0: 41 52 45 20 49 53 20 50 52 4f 56 49 44 45 44 20 ARE IS PROVIDED
0300: 60 60 41 53 20 49 53 27 27 2c 20 57 49 54 48 4f ``AS IS'', WITHO
0310: 55 54 20 57 41 52 52 41 4e 54 59 20 4f 46 20 41 UT WARRANTY OF A
0320: 4e 59 20 4b 49 4e 44 2c 0a 3b 20 45 58 50 52 45 NY KIND,.; EXPRE
0330: 53 53 20 4f 52 20 49 4d 50 4c 49 45 44 2c 20 49 SS OR IMPLIED, I
0340: 4e 43 4c 55 44 49 4e 47 20 42 55 54 20 4e 4f 54 NCLUDING BUT NOT
0350: 20 4c 49 4d 49 54 45 44 20 54 4f 20 54 48 45 20 LIMITED TO THE
0360: 57 41 52 52 41 4e 54 49 45 53 20 4f 46 0a 3b 20 WARRANTIES OF.;
0370: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 2c MERCHANTABILITY,
0380: 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 50 FITNESS FOR A P
0390: 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f 53 ARTICULAR PURPOS
03a0: 45 20 41 4e 44 0a 3b 20 4e 4f 4e 49 4e 46 52 49 E AND.; NONINFRI
03b0: 4e 47 45 4d 45 4e 54 2e 20 49 4e 20 4e 4f 20 45 NGEMENT. IN NO E
03c0: 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 20 41 VENT SHALL THE A
03d0: 55 54 48 4f 52 53 20 4f 52 20 43 4f 50 59 52 49 UTHORS OR COPYRI
03e0: 47 48 54 20 48 4f 4c 44 45 52 53 20 42 45 0a 3b GHT HOLDERS BE.;
03f0: 20 4c 49 41 42 4c 45 20 46 4f 52 20 41 4e 59 20 LIABLE FOR ANY
0400: 43 4c 41 49 4d 2c 20 44 41 4d 41 47 45 53 20 4f CLAIM, DAMAGES O
0410: 52 20 4f 54 48 45 52 20 4c 49 41 42 49 4c 49 54 R OTHER LIABILIT
0420: 59 2c 20 57 48 45 54 48 45 52 20 49 4e 20 41 4e Y, WHETHER IN AN
0430: 20 41 43 54 49 4f 4e 0a 3b 20 4f 46 20 43 4f 4e ACTION.; OF CON
0440: 54 52 41 43 54 2c 20 54 4f 52 54 20 4f 52 20 4f TRACT, TORT OR O
0450: 54 48 45 52 57 49 53 45 2c 20 41 52 49 53 49 4e THERWISE, ARISIN
0460: 47 20 46 52 4f 4d 2c 20 4f 55 54 20 4f 46 20 4f G FROM, OUT OF O
0470: 52 20 49 4e 20 43 4f 4e 4e 45 43 54 49 4f 4e 0a R IN CONNECTION.
0480: 3b 20 57 49 54 48 20 54 48 45 20 53 4f 46 54 57 ; WITH THE SOFTW
0490: 41 52 45 20 4f 52 20 54 48 45 20 55 53 45 20 4f ARE OR THE USE O
04a0: 52 20 4f 54 48 45 52 20 44 45 41 4c 49 4e 47 53 R OTHER DEALINGS
04b0: 20 49 4e 20 54 48 45 20 53 4f 46 54 57 41 52 45 IN THE SOFTWARE
04c0: 2e 0a 3b 20 0a 3b 20 2d 2d 2d 2d 2d 2d 2d 2d 2d ..; .; ---------
04d0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
04e0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
04f0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0500: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 0a 3b --------------.;
0510: 20 0a 3b 20 43 6f 6d 70 61 72 65 20 70 72 6f 63 .; Compare proc
0520: 65 64 75 72 65 73 20 53 52 46 49 20 28 72 65 66 edures SRFI (ref
0530: 65 72 65 6e 63 65 20 69 6d 70 6c 65 6d 65 6e 74 erence implement
0540: 61 74 69 6f 6e 29 0a 3b 20 53 65 62 61 73 74 69 ation).; Sebasti
0550: 61 6e 2e 45 67 6e 65 72 40 70 68 69 6c 69 70 73 an.Egner@philips
0560: 2e 63 6f 6d 2c 20 4a 65 6e 73 61 78 65 6c 40 73 .com, Jensaxel@s
0570: 6f 65 67 61 61 72 64 2e 6e 65 74 0a 3b 20 68 69 oegaard.net.; hi
0580: 73 74 6f 72 79 20 6f 66 20 74 68 69 73 20 66 69 story of this fi
0590: 6c 65 3a 0a 3b 20 20 20 53 45 2c 20 31 34 2d 4f le:.; SE, 14-O
05a0: 63 74 2d 32 30 30 34 3a 20 66 69 72 73 74 20 76 ct-2004: first v
05b0: 65 72 73 69 6f 6e 0a 3b 20 20 20 53 45 2c 20 31 ersion.; SE, 1
05c0: 38 2d 4f 63 74 2d 32 30 30 34 3a 20 31 73 74 20 8-Oct-2004: 1st
05d0: 72 65 64 65 73 69 67 6e 3a 20 61 78 69 6f 6d 73 redesign: axioms
05e0: 20 66 6f 72 20 27 63 6f 6d 70 61 72 65 20 66 75 for 'compare fu
05f0: 6e 63 74 69 6f 6e 27 0a 3b 20 20 20 53 45 2c 20 nction'.; SE,
0600: 32 39 2d 4f 63 74 2d 32 30 30 34 3a 20 32 6e 64 29-Oct-2004: 2nd
0610: 20 72 65 64 65 73 69 67 6e 3a 20 68 69 67 68 65 redesign: highe
0620: 72 20 6f 72 64 65 72 20 72 65 76 65 72 73 65 2f r order reverse/
0630: 6d 61 70 2f 72 65 66 69 6e 65 2f 75 6e 69 74 65 map/refine/unite
0640: 0a 3b 20 20 20 53 45 2c 20 20 32 2d 4e 6f 76 2d .; SE, 2-Nov-
0650: 32 30 30 34 3a 20 33 72 64 20 72 65 64 65 73 69 2004: 3rd redesi
0660: 67 6e 3a 20 6d 61 63 72 6f 73 20 63 6f 6e 64 2f gn: macros cond/
0670: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 72 refine-compare r
0680: 65 70 6c 61 63 65 20 68 2e 6f 2e 66 27 73 0a 3b eplace h.o.f's.;
0690: 20 20 20 53 45 2c 20 31 30 2d 4e 6f 76 2d 32 30 SE, 10-Nov-20
06a0: 30 34 3a 20 28 69 6d 2c 72 65 29 20 72 65 70 6c 04: (im,re) repl
06b0: 61 63 65 64 20 62 79 20 28 72 65 2c 69 6d 29 20 aced by (re,im)
06c0: 69 6e 20 63 6f 6d 70 6c 65 78 2d 63 6f 6d 70 61 in complex-compa
06d0: 72 65 0a 3b 20 20 20 53 45 2c 20 31 31 2d 4e 6f re.; SE, 11-No
06e0: 76 2d 32 30 30 34 3a 20 63 61 73 65 2d 63 6f 6d v-2004: case-com
06f0: 70 61 72 65 20 62 79 20 63 61 73 65 20 28 6e 6f pare by case (no
0700: 74 20 62 79 20 63 6f 6e 64 29 3b 20 73 65 6c 65 t by cond); sele
0710: 63 74 2d 63 6f 6d 70 61 72 65 20 61 64 64 65 64 ct-compare added
0720: 0a 3b 20 20 20 53 45 2c 20 31 32 2d 4a 61 6e 2d .; SE, 12-Jan-
0730: 32 30 30 35 3a 20 70 61 69 72 2d 63 6f 6d 70 61 2005: pair-compa
0740: 72 65 2d 63 64 72 0a 3b 20 20 20 53 45 2c 20 31 re-cdr.; SE, 1
0750: 35 2d 46 65 62 2d 32 30 30 35 3a 20 73 74 72 69 5-Feb-2005: stri
0760: 63 74 65 72 20 74 79 70 69 6e 67 20 66 6f 72 20 cter typing for
0770: 63 6f 6d 70 61 72 65 2d 3c 74 79 70 65 3e 3b 20 compare-<type>;
0780: 70 61 69 72 77 69 73 65 2d 6e 6f 74 3d 3f 0a 3b pairwise-not=?.;
0790: 20 20 20 53 45 2c 20 31 36 2d 46 65 62 2d 32 30 SE, 16-Feb-20
07a0: 30 35 3a 20 63 61 73 65 2d 63 6f 6d 70 61 72 65 05: case-compare
07b0: 20 2d 3e 20 69 66 2d 63 6f 6d 70 61 72 65 20 2d -> if-compare -
07c0: 3e 20 69 66 33 3b 20 3c 3f 20 3c 2f 3c 3f 20 63 > if3; <? </<? c
07d0: 68 61 69 6e 3c 3f 20 65 74 63 2e 0a 3b 20 20 20 hain<? etc..;
07e0: 4a 53 2c 20 32 34 2d 46 65 62 2d 32 30 30 35 3a JS, 24-Feb-2005:
07f0: 20 73 65 6c 65 63 74 69 6f 6e 2d 63 6f 6d 70 61 selection-compa
0800: 72 65 20 61 64 64 65 64 0a 3b 20 20 20 53 45 2c re added.; SE,
0810: 20 32 35 2d 46 65 62 2d 32 30 30 35 3a 20 73 65 25-Feb-2005: se
0820: 6c 65 63 74 69 6f 6e 2d 63 6f 6d 70 61 72 65 20 lection-compare
0830: 2d 3e 20 6b 74 68 2d 6c 61 72 67 65 73 74 20 6d -> kth-largest m
0840: 6f 64 69 66 69 65 64 3b 20 69 66 3c 3f 20 65 74 odified; if<? et
0850: 63 2e 0a 3b 20 20 20 4a 53 2c 20 32 38 2d 46 65 c..; JS, 28-Fe
0860: 62 2d 32 30 30 35 3a 20 6b 74 68 2d 6c 61 72 67 b-2005: kth-larg
0870: 65 73 74 20 6d 6f 64 69 66 69 65 64 20 2d 20 69 est modified - i
0880: 73 20 22 73 74 61 62 6c 65 22 20 6e 6f 77 0a 3b s "stable" now.;
0890: 20 20 20 53 45 2c 20 32 38 2d 46 65 62 2d 32 30 SE, 28-Feb-20
08a0: 30 35 3a 20 73 69 6d 70 6c 69 66 69 65 64 20 70 05: simplified p
08b0: 61 69 72 77 69 73 65 2d 6e 6f 74 3d 3f 2f 6b 74 airwise-not=?/kt
08c0: 68 2d 6c 61 72 67 65 73 74 3b 20 6d 69 6e 2f 6d h-largest; min/m
08d0: 61 78 20 64 65 62 75 67 67 65 64 0a 3b 20 20 20 ax debugged.;
08e0: 53 45 2c 20 30 37 2d 41 70 72 2d 32 30 30 35 3a SE, 07-Apr-2005:
08f0: 20 63 6f 6d 70 61 72 65 2d 62 61 73 65 64 20 74 compare-based t
0900: 79 70 65 20 63 68 65 63 6b 73 20 6d 61 64 65 20 ype checks made
0910: 65 78 70 6c 69 63 69 74 0a 3b 20 20 20 53 45 2c explicit.; SE,
0920: 20 31 38 2d 41 70 72 2d 32 30 30 35 3a 20 61 64 18-Apr-2005: ad
0930: 64 65 64 20 28 72 65 6c 3f 20 63 6f 6d 70 61 72 ded (rel? compar
0940: 65 29 20 61 6e 64 20 65 71 3f 2d 74 65 73 74 0a e) and eq?-test.
0950: 3b 20 20 20 53 45 2c 20 31 36 2d 4d 61 79 2d 32 ; SE, 16-May-2
0960: 30 30 35 3a 20 6e 61 6d 69 6e 67 20 63 6f 6e 76 005: naming conv
0970: 65 6e 74 69 6f 6e 20 63 68 61 6e 67 65 64 3b 20 ention changed;
0980: 63 6f 6d 70 61 72 65 2d 62 79 3c 20 65 74 63 2e compare-by< etc.
0990: 20 6f 70 74 69 6f 6e 61 6c 20 78 20 79 0a 0a 3b optional x y..;
09a0: 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ===============
09b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
09f0: 3b 20 52 65 66 65 72 65 6e 63 65 20 49 6d 70 6c ; Reference Impl
0a00: 65 6d 65 6e 74 61 74 69 6f 6e 0a 3b 20 3d 3d 3d ementation.; ===
0a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a20: 3d 3d 3d 3d 3d 0a 3b 0a 3b 20 69 6e 20 52 35 52 =====.;.; in R5R
0a30: 53 20 28 69 6e 63 6c 75 64 69 6e 67 20 68 79 67 S (including hyg
0a40: 69 65 6e 69 63 20 6d 61 63 72 6f 73 29 0a 3b 20 ienic macros).;
0a50: 20 2b 20 53 52 46 49 2d 31 36 20 28 63 61 73 65 + SRFI-16 (case
0a60: 2d 6c 61 6d 62 64 61 29 20 0a 3b 20 20 2b 20 53 -lambda) .; + S
0a70: 52 46 49 2d 32 33 20 28 65 72 72 6f 72 29 20 0a RFI-23 (error) .
0a80: 3b 20 20 2b 20 53 52 46 49 2d 32 37 20 28 72 61 ; + SRFI-27 (ra
0a90: 6e 64 6f 6d 2d 69 6e 74 65 67 65 72 29 0a 0a 3b ndom-integer)..;
0aa0: 20 49 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 Implementation
0ab0: 72 65 6d 61 72 6b 73 3a 0a 3b 20 20 20 2a 20 49 remarks:.; * I
0ac0: 6e 20 67 65 6e 65 72 61 6c 2c 20 74 68 65 20 65 n general, the e
0ad0: 6d 70 68 61 73 69 73 20 6f 66 20 74 68 69 73 20 mphasis of this
0ae0: 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 69 implementation i
0af0: 73 20 6f 6e 20 63 6f 72 72 65 63 74 6e 65 73 73 s on correctness
0b00: 0a 3b 20 20 20 20 20 61 6e 64 20 70 6f 72 74 61 .; and porta
0b10: 62 69 6c 69 74 79 2c 20 6e 6f 74 20 6f 6e 20 65 bility, not on e
0b20: 66 66 69 63 69 65 6e 63 79 2e 0a 3b 20 20 20 2a fficiency..; *
0b30: 20 56 61 72 69 61 62 6c 65 20 61 72 69 74 79 20 Variable arity
0b40: 70 72 6f 63 65 64 75 72 65 73 20 61 72 65 20 65 procedures are e
0b50: 78 70 72 65 73 73 65 64 20 69 6e 20 74 65 72 6d xpressed in term
0b60: 73 20 6f 66 20 63 61 73 65 2d 6c 61 6d 62 64 61 s of case-lambda
0b70: 0a 3b 20 20 20 20 20 69 6e 20 74 68 65 20 68 6f .; in the ho
0b80: 70 65 20 74 68 61 74 20 74 68 69 73 20 77 69 6c pe that this wil
0b90: 6c 20 70 72 6f 64 75 63 65 20 65 66 66 69 63 69 l produce effici
0ba0: 65 6e 74 20 63 6f 64 65 20 66 6f 72 20 74 68 65 ent code for the
0bb0: 20 63 61 73 65 0a 3b 20 20 20 20 20 77 68 65 72 case.; wher
0bc0: 65 20 74 68 65 20 61 72 69 74 79 20 69 73 20 73 e the arity is s
0bd0: 74 61 74 69 63 61 6c 6c 79 20 6b 6e 6f 77 6e 20 tatically known
0be0: 61 74 20 74 68 65 20 63 61 6c 6c 20 73 69 74 65 at the call site
0bf0: 2e 0a 3b 20 20 20 2a 20 49 6e 20 70 72 6f 63 65 ..; * In proce
0c00: 64 75 72 65 73 20 74 68 61 74 20 61 72 65 20 72 dures that are r
0c10: 65 71 75 69 72 65 64 20 74 6f 20 74 79 70 65 2d equired to type-
0c20: 63 68 65 63 6b 20 74 68 65 69 72 20 61 72 67 75 check their argu
0c30: 6d 65 6e 74 73 2c 0a 3b 20 20 20 20 20 77 65 20 ments,.; we
0c40: 75 73 65 20 28 63 6f 6d 70 61 72 65 20 78 20 78 use (compare x x
0c50: 29 20 66 6f 72 20 65 78 65 63 75 74 69 6e 67 20 ) for executing
0c60: 65 78 74 72 61 20 63 68 65 63 6b 73 2e 20 54 68 extra checks. Th
0c70: 69 73 20 72 65 6c 69 65 73 20 6f 6e 0a 3b 20 20 is relies on.;
0c80: 20 20 20 74 68 65 20 61 73 73 75 6d 70 74 69 6f the assumptio
0c90: 6e 20 74 68 61 74 20 65 71 3f 20 69 73 20 75 73 n that eq? is us
0ca0: 65 64 20 74 6f 20 63 61 74 63 68 20 74 68 69 73 ed to catch this
0cb0: 20 63 61 73 65 20 71 75 69 63 6b 6c 79 2e 0a 3b case quickly..;
0cc0: 20 20 20 2a 20 43 61 72 65 20 68 61 73 20 62 65 * Care has be
0cd0: 65 6e 20 74 61 6b 65 6e 20 74 6f 20 72 65 66 65 en taken to refe
0ce0: 72 65 6e 63 65 20 63 6f 6d 70 61 72 69 73 6f 6e rence comparison
0cf0: 20 70 72 6f 63 65 64 75 72 65 73 20 6f 66 20 52 procedures of R
0d00: 35 52 53 0a 3b 20 20 20 20 20 6f 6e 6c 79 20 61 5RS.; only a
0d10: 74 20 74 68 65 20 74 69 6d 65 20 74 68 65 20 6f t the time the o
0d20: 70 65 72 61 74 69 6f 6e 73 20 68 65 72 65 20 61 perations here a
0d30: 72 65 20 62 65 69 6e 67 20 64 65 66 69 6e 65 64 re being defined
0d40: 2e 20 54 68 69 73 0a 3b 20 20 20 20 20 6d 61 6b . This.; mak
0d50: 65 73 20 69 74 20 70 6f 73 73 69 62 6c 65 20 74 es it possible t
0d60: 6f 20 72 65 64 65 66 69 6e 65 20 74 68 65 73 65 o redefine these
0d70: 20 6f 70 65 72 61 74 69 6f 6e 73 2c 20 69 66 20 operations, if
0d80: 6e 65 65 64 20 62 65 2e 0a 3b 20 20 20 2a 20 46 need be..; * F
0d90: 6f 72 20 74 68 65 20 73 61 6b 65 20 6f 66 20 65 or the sake of e
0da0: 66 66 69 63 69 65 6e 63 79 2c 20 73 6f 6d 65 20 fficiency, some
0db0: 69 6e 6c 69 6e 69 6e 67 20 68 61 73 20 62 65 65 inlining has bee
0dc0: 6e 20 64 6f 6e 65 20 62 79 20 68 61 6e 64 2e 0a n done by hand..
0dd0: 3b 20 20 20 20 20 54 68 69 73 20 69 73 20 6d 61 ; This is ma
0de0: 69 6e 6c 79 20 65 78 70 72 65 73 73 65 64 20 62 inly expressed b
0df0: 79 20 6d 61 63 72 6f 73 20 70 72 6f 64 75 63 69 y macros produci
0e00: 6e 67 20 64 65 66 69 6e 65 73 2e 0a 3b 20 20 20 ng defines..;
0e10: 2a 20 49 64 65 6e 74 69 66 69 65 72 73 20 6f 66 * Identifiers of
0e20: 20 74 68 65 20 66 6f 72 6d 20 63 6f 6d 70 61 72 the form compar
0e30: 65 3a 3c 73 6f 6d 65 74 68 69 6e 67 3e 20 61 72 e:<something> ar
0e40: 65 20 70 72 69 76 61 74 65 2e 0a 3b 0a 3b 20 48 e private..;.; H
0e50: 69 6e 74 73 20 66 6f 72 20 6c 6f 77 2d 6c 65 76 ints for low-lev
0e60: 65 6c 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f el implementatio
0e70: 6e 3a 0a 3b 20 20 20 2a 20 54 68 65 20 62 61 73 n:.; * The bas
0e80: 69 73 20 6f 66 20 74 68 69 73 20 53 52 46 49 20 is of this SRFI
0e90: 61 72 65 20 74 68 65 20 61 74 6f 6d 69 63 20 63 are the atomic c
0ea0: 6f 6d 70 61 72 65 20 70 72 6f 63 65 64 75 72 65 ompare procedure
0eb0: 73 2c 20 0a 3b 20 20 20 20 20 69 2e 65 2e 20 62 s, .; i.e. b
0ec0: 6f 6f 6c 65 61 6e 2d 63 6f 6d 70 61 72 65 2c 20 oolean-compare,
0ed0: 63 68 61 72 2d 63 6f 6d 70 61 72 65 2c 20 65 74 char-compare, et
0ee0: 63 2e 20 61 6e 64 20 74 68 65 20 63 6f 6e 64 69 c. and the condi
0ef0: 74 69 6f 6e 61 6c 73 0a 3b 20 20 20 20 20 69 66 tionals.; if
0f00: 33 2c 20 69 66 3d 3f 2c 20 69 66 3c 3f 20 65 74 3, if=?, if<? et
0f10: 63 2e 2c 20 61 6e 64 20 64 65 66 61 75 6c 74 2d c., and default-
0f20: 63 6f 6d 70 61 72 65 2e 20 54 68 65 73 65 20 73 compare. These s
0f30: 68 6f 75 6c 64 20 6d 61 6b 65 0a 3b 20 20 20 20 hould make.;
0f40: 20 6f 70 74 69 6d 61 6c 20 75 73 65 20 6f 66 20 optimal use of
0f50: 74 68 65 20 61 76 61 69 6c 61 62 6c 65 20 74 79 the available ty
0f60: 70 65 20 69 6e 66 6f 72 6d 61 74 69 6f 6e 2e 0a pe information..
0f70: 3b 20 20 20 2a 20 46 6f 72 20 74 68 65 20 73 61 ; * For the sa
0f80: 6b 65 20 6f 66 20 73 70 65 65 64 2c 20 74 68 65 ke of speed, the
0f90: 20 72 65 66 65 72 65 6e 63 65 20 69 6d 70 6c 65 reference imple
0fa0: 6d 65 6e 74 61 74 69 6f 6e 20 64 6f 65 73 20 6e mentation does n
0fb0: 6f 74 0a 3b 20 20 20 20 20 75 73 65 20 61 20 4c ot.; use a L
0fc0: 45 54 20 74 6f 20 73 61 76 65 20 74 68 65 20 63 ET to save the c
0fd0: 6f 6d 70 61 72 69 73 6f 6e 20 76 61 6c 75 65 20 omparison value
0fe0: 63 20 66 6f 72 20 74 68 65 20 45 52 52 4f 52 20 c for the ERROR
0ff0: 63 61 6c 6c 2e 0a 3b 20 20 20 20 20 54 68 69 73 call..; This
1000: 20 63 61 6e 20 62 65 20 66 69 78 65 64 20 69 6e can be fixed in
1010: 20 61 20 6c 6f 77 2d 6c 65 76 65 6c 20 69 6d 70 a low-level imp
1020: 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 61 74 20 6e lementation at n
1030: 6f 20 63 6f 73 74 2e 0a 3b 20 20 20 2a 20 54 79 o cost..; * Ty
1040: 70 65 2d 63 68 65 63 6b 73 20 62 61 73 65 64 20 pe-checks based
1050: 6f 6e 20 28 63 6f 6d 70 61 72 65 20 78 20 78 29 on (compare x x)
1060: 20 61 72 65 20 6d 61 64 65 20 65 78 70 6c 69 63 are made explic
1070: 69 74 20 62 79 20 74 68 65 0a 3b 20 20 20 20 20 it by the.;
1080: 65 78 70 72 65 73 73 69 6f 6e 20 28 63 6f 6d 70 expression (comp
1090: 61 72 65 3a 63 68 65 63 6b 20 72 65 73 75 6c 74 are:check result
10a0: 20 63 6f 6d 70 61 72 65 20 78 20 2e 2e 2e 29 2e compare x ...).
10b0: 0a 3b 20 20 20 2a 20 45 71 3f 20 73 68 6f 75 6c .; * Eq? shoul
10c0: 64 20 20 63 61 6e 20 75 73 65 64 20 74 6f 20 73 d can used to s
10d0: 70 65 65 64 20 75 70 20 62 75 69 6c 74 2d 69 6e peed up built-in
10e0: 20 63 6f 6d 70 61 72 65 20 70 72 6f 63 65 64 75 compare procedu
10f0: 72 65 73 2c 0a 3b 20 20 20 20 20 62 75 74 20 69 res,.; but i
1100: 74 20 63 61 6e 20 6f 6e 6c 79 20 62 65 20 75 73 t can only be us
1110: 65 64 20 61 66 74 65 72 20 74 79 70 65 2d 63 68 ed after type-ch
1120: 65 63 6b 69 6e 67 20 61 74 20 6c 65 61 73 74 20 ecking at least
1130: 6f 6e 65 20 6f 66 0a 3b 20 20 20 20 20 74 68 65 one of.; the
1140: 20 61 72 67 75 6d 65 6e 74 73 2e 0a 0a 28 64 65 arguments...(de
1150: 66 69 6e 65 20 28 63 6f 6d 70 61 72 65 3a 63 68 fine (compare:ch
1160: 65 63 6b 65 64 20 72 65 73 75 6c 74 20 63 6f 6d ecked result com
1170: 70 61 72 65 20 2e 20 61 72 67 73 29 0a 20 20 28 pare . args). (
1180: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
1190: 20 28 78 29 20 28 63 6f 6d 70 61 72 65 20 78 20 (x) (compare x
11a0: 78 29 29 20 61 72 67 73 29 0a 20 20 72 65 73 75 x)) args). resu
11b0: 6c 74 29 0a 0a 0a 3b 20 33 2d 73 69 64 65 64 20 lt)...; 3-sided
11c0: 63 6f 6e 64 69 74 69 6f 6e 61 6c 0a 0a 28 64 65 conditional..(de
11d0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 33 0a fine-syntax if3.
11e0: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
11f0: 28 29 0a 20 20 20 20 28 28 69 66 33 20 63 20 6c (). ((if3 c l
1200: 65 73 73 20 65 71 75 61 6c 20 67 72 65 61 74 65 ess equal greate
1210: 72 29 0a 20 20 20 20 20 28 63 61 73 65 20 63 0a r). (case c.
1220: 20 20 20 20 20 20 20 28 28 2d 31 29 20 6c 65 73 ((-1) les
1230: 73 29 0a 20 20 20 20 20 20 20 28 28 20 30 29 20 s). (( 0)
1240: 65 71 75 61 6c 29 0a 20 20 20 20 20 20 20 28 28 equal). ((
1250: 20 31 29 20 67 72 65 61 74 65 72 29 0a 20 20 20 1) greater).
1260: 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 6f 72 (else (error
1270: 20 22 63 6f 6d 70 61 72 69 73 6f 6e 20 76 61 6c "comparison val
1280: 75 65 20 6e 6f 74 20 69 6e 20 7b 2d 31 2c 30 2c ue not in {-1,0,
1290: 31 7d 22 29 29 29 29 29 29 0a 0a 0a 3b 20 32 2d 1}"))))))...; 2-
12a0: 73 69 64 65 64 20 63 6f 6e 64 69 74 69 6f 6e 61 sided conditiona
12b0: 6c 73 20 66 6f 72 20 63 6f 6d 70 61 72 69 73 6f ls for compariso
12c0: 6e 73 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ns..(define-synt
12d0: 61 78 20 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 ax compare:if-re
12e0: 6c 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c l?. (syntax-rul
12f0: 65 73 20 28 29 0a 20 20 20 20 28 28 63 6f 6d 70 es (). ((comp
1300: 61 72 65 3a 69 66 2d 72 65 6c 3f 20 63 2d 63 61 are:if-rel? c-ca
1310: 73 65 73 20 61 2d 63 61 73 65 73 20 63 20 63 6f ses a-cases c co
1320: 6e 73 65 71 75 65 6e 63 65 29 0a 20 20 20 20 20 nsequence).
1330: 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f (compare:if-rel?
1340: 20 63 2d 63 61 73 65 73 20 61 2d 63 61 73 65 73 c-cases a-cases
1350: 20 63 20 63 6f 6e 73 65 71 75 65 6e 63 65 20 28 c consequence (
1360: 69 66 20 23 66 20 23 66 29 29 29 0a 20 20 20 20 if #f #f))).
1370: 28 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c ((compare:if-rel
1380: 3f 20 63 2d 63 61 73 65 73 20 61 2d 63 61 73 65 ? c-cases a-case
1390: 73 20 63 20 63 6f 6e 73 65 71 75 65 6e 63 65 20 s c consequence
13a0: 61 6c 74 65 72 6e 61 74 65 29 0a 20 20 20 20 20 alternate).
13b0: 28 63 61 73 65 20 63 0a 20 20 20 20 20 20 20 28 (case c. (
13c0: 63 2d 63 61 73 65 73 20 63 6f 6e 73 65 71 75 65 c-cases conseque
13d0: 6e 63 65 29 0a 20 20 20 20 20 20 20 28 61 2d 63 nce). (a-c
13e0: 61 73 65 73 20 61 6c 74 65 72 6e 61 74 65 29 0a ases alternate).
13f0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
1400: 28 65 72 72 6f 72 20 22 63 6f 6d 70 61 72 69 73 (error "comparis
1410: 6f 6e 20 76 61 6c 75 65 20 6e 6f 74 20 69 6e 20 on value not in
1420: 7b 2d 31 2c 30 2c 31 7d 22 29 29 29 29 29 29 0a {-1,0,1}")))))).
1430: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax
1440: 69 66 3d 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 if=?. (syntax-r
1450: 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 69 66 ules (). ((if
1460: 3d 3f 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 =? arg ...).
1470: 20 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c (compare:if-rel
1480: 3f 20 28 30 29 20 28 2d 31 20 31 29 20 61 72 67 ? (0) (-1 1) arg
1490: 20 2e 2e 2e 29 29 29 29 0a 0a 28 64 65 66 69 6e ...))))..(defin
14a0: 65 2d 73 79 6e 74 61 78 20 69 66 3c 3f 0a 20 20 e-syntax if<?.
14b0: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 (syntax-rules ()
14c0: 0a 20 20 20 20 28 28 69 66 3c 3f 20 61 72 67 20 . ((if<? arg
14d0: 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 ...). (compa
14e0: 72 65 3a 69 66 2d 72 65 6c 3f 20 28 2d 31 29 20 re:if-rel? (-1)
14f0: 28 30 20 31 29 20 61 72 67 20 2e 2e 2e 29 29 29 (0 1) arg ...)))
1500: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta
1510: 78 20 69 66 3e 3f 0a 20 20 28 73 79 6e 74 61 78 x if>?. (syntax
1520: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). ((
1530: 69 66 3e 3f 20 61 72 67 20 2e 2e 2e 29 0a 20 20 if>? arg ...).
1540: 20 20 20 28 63 6f 6d 70 61 72 65 3a 69 66 2d 72 (compare:if-r
1550: 65 6c 3f 20 28 31 29 20 28 2d 31 20 30 29 20 61 el? (1) (-1 0) a
1560: 72 67 20 2e 2e 2e 29 29 29 29 0a 0a 28 64 65 66 rg ...))))..(def
1570: 69 6e 65 2d 73 79 6e 74 61 78 20 69 66 3c 3d 3f ine-syntax if<=?
1580: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
1590: 20 28 29 0a 20 20 20 20 28 28 69 66 3c 3d 3f 20 (). ((if<=?
15a0: 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 arg ...). (c
15b0: 6f 6d 70 61 72 65 3a 69 66 2d 72 65 6c 3f 20 28 ompare:if-rel? (
15c0: 2d 31 20 30 29 20 28 31 29 20 61 72 67 20 2e 2e -1 0) (1) arg ..
15d0: 2e 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 .))))..(define-s
15e0: 79 6e 74 61 78 20 69 66 3e 3d 3f 0a 20 20 28 73 yntax if>=?. (s
15f0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
1600: 20 20 20 28 28 69 66 3e 3d 3f 20 61 72 67 20 2e ((if>=? arg .
1610: 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 72 ..). (compar
1620: 65 3a 69 66 2d 72 65 6c 3f 20 28 30 20 31 29 20 e:if-rel? (0 1)
1630: 28 2d 31 29 20 61 72 67 20 2e 2e 2e 29 29 29 29 (-1) arg ...))))
1640: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
1650: 20 69 66 2d 6e 6f 74 3d 3f 0a 20 20 28 73 79 6e if-not=?. (syn
1660: 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 tax-rules ().
1670: 20 28 28 69 66 2d 6e 6f 74 3d 3f 20 61 72 67 20 ((if-not=? arg
1680: 2e 2e 2e 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 ...). (compa
1690: 72 65 3a 69 66 2d 72 65 6c 3f 20 28 2d 31 20 31 re:if-rel? (-1 1
16a0: 29 20 28 30 29 20 61 72 67 20 2e 2e 2e 29 29 29 ) (0) arg ...)))
16b0: 29 0a 0a 0a 3b 20 70 72 65 64 69 63 61 74 65 73 )...; predicates
16c0: 20 66 72 6f 6d 20 63 6f 6d 70 61 72 65 20 70 72 from compare pr
16d0: 6f 63 65 64 75 72 65 73 0a 0a 28 64 65 66 69 6e ocedures..(defin
16e0: 65 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 72 65 e-syntax compare
16f0: 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 0a 20 20 28 :define-rel?. (
1700: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules ().
1710: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 3a 64 65 ((compare:de
1720: 66 69 6e 65 2d 72 65 6c 3f 20 72 65 6c 3f 20 69 fine-rel? rel? i
1730: 66 2d 72 65 6c 3f 29 0a 20 20 20 20 20 28 64 65 f-rel?). (de
1740: 66 69 6e 65 20 72 65 6c 3f 0a 20 20 20 20 20 20 fine rel?.
1750: 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 (case-lambda.
1760: 20 20 20 20 20 20 20 28 28 29 20 20 20 20 20 20 (()
1770: 20 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 20 (lambda (x y)
1780: 28 69 66 2d 72 65 6c 3f 20 28 64 65 66 61 75 6c (if-rel? (defaul
1790: 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 20 23 t-compare x y) #
17a0: 74 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 t #f))).
17b0: 20 28 28 63 6f 6d 70 61 72 65 29 20 28 6c 61 6d ((compare) (lam
17c0: 62 64 61 20 28 78 20 79 29 20 28 69 66 2d 72 65 bda (x y) (if-re
17d0: 6c 3f 20 28 63 6f 6d 70 61 72 65 20 20 20 20 20 l? (compare
17e0: 20 20 20 20 78 20 79 29 20 23 74 20 23 66 29 29 x y) #t #f))
17f0: 29 0a 20 20 20 20 20 20 20 20 20 28 28 78 20 79 ). ((x y
1800: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
1810: 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 64 65 (if-rel? (de
1820: 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 fault-compare x
1830: 79 29 20 23 74 20 23 66 29 29 0a 20 20 20 20 20 y) #t #f)).
1840: 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 ((compare x
1850: 79 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 y). (if
1860: 20 28 70 72 6f 63 65 64 75 72 65 3f 20 63 6f 6d (procedure? com
1870: 70 61 72 65 29 0a 20 20 20 20 20 20 20 20 20 20 pare).
1880: 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 63 6f (if-rel? (co
1890: 6d 70 61 72 65 20 78 20 79 29 20 23 74 20 23 66 mpare x y) #t #f
18a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
18b0: 28 65 72 72 6f 72 20 22 6e 6f 74 20 61 20 70 72 (error "not a pr
18c0: 6f 63 65 64 75 72 65 20 28 44 69 64 20 79 6f 75 ocedure (Did you
18d0: 20 6d 65 61 6e 20 72 65 6c 2f 72 65 6c 3f 3f 29 mean rel/rel??)
18e0: 3a 20 22 20 63 6f 6d 70 61 72 65 29 29 29 29 29 : " compare)))))
18f0: 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 65 )))..(compare:de
1900: 66 69 6e 65 2d 72 65 6c 3f 20 3d 3f 20 20 20 20 fine-rel? =?
1910: 69 66 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 if=?).(compare:d
1920: 65 66 69 6e 65 2d 72 65 6c 3f 20 3c 3f 20 20 20 efine-rel? <?
1930: 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 72 65 3a if<?).(compare:
1940: 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3e 3f 20 20 define-rel? >?
1950: 20 20 69 66 3e 3f 29 0a 28 63 6f 6d 70 61 72 65 if>?).(compare
1960: 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3c 3d 3f :define-rel? <=?
1970: 20 20 20 69 66 3c 3d 3f 29 0a 28 63 6f 6d 70 61 if<=?).(compa
1980: 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 3f 20 3e re:define-rel? >
1990: 3d 3f 20 20 20 69 66 3e 3d 3f 29 0a 28 63 6f 6d =? if>=?).(com
19a0: 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 3f pare:define-rel?
19b0: 20 6e 6f 74 3d 3f 20 69 66 2d 6e 6f 74 3d 3f 29 not=? if-not=?)
19c0: 0a 0a 0a 3b 20 63 68 61 69 6e 73 20 6f 66 20 6c ...; chains of l
19d0: 65 6e 67 74 68 20 33 0a 0a 28 64 65 66 69 6e 65 ength 3..(define
19e0: 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 72 65 3a -syntax compare:
19f0: 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 define-rel1/rel2
1a00: 3f 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 ?. (syntax-rule
1a10: 73 20 28 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 s (). ((compa
1a20: 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 re:define-rel1/r
1a30: 65 6c 32 3f 20 72 65 6c 31 2f 72 65 6c 32 3f 20 el2? rel1/rel2?
1a40: 69 66 2d 72 65 6c 31 3f 20 69 66 2d 72 65 6c 32 if-rel1? if-rel2
1a50: 3f 29 0a 20 20 20 20 20 28 64 65 66 69 6e 65 20 ?). (define
1a60: 72 65 6c 31 2f 72 65 6c 32 3f 0a 20 20 20 20 20 rel1/rel2?.
1a70: 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 (case-lambda.
1a80: 20 20 20 20 20 20 20 20 28 28 29 0a 20 20 20 20 (().
1a90: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 (lambda (x
1aa0: 20 79 20 7a 29 0a 20 20 20 20 20 20 20 20 20 20 y z).
1ab0: 20 20 28 69 66 2d 72 65 6c 31 3f 20 28 64 65 66 (if-rel1? (def
1ac0: 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 ault-compare x y
1ad0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1ae0: 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c 32 (if-rel2
1af0: 3f 20 28 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 ? (default-compa
1b00: 72 65 20 79 20 7a 29 20 23 74 20 23 66 29 0a 20 re y z) #t #f).
1b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b20: 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 (compare:ch
1b30: 65 63 6b 65 64 20 23 66 20 64 65 66 61 75 6c 74 ecked #f default
1b40: 2d 63 6f 6d 70 61 72 65 20 7a 29 29 29 29 0a 20 -compare z)))).
1b50: 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 ((compar
1b60: 65 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 61 e). (la
1b70: 6d 62 64 61 20 28 78 20 79 20 7a 29 0a 20 20 20 mbda (x y z).
1b80: 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c (if-rel
1b90: 31 3f 20 28 63 6f 6d 70 61 72 65 20 78 20 79 29 1? (compare x y)
1ba0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1bb0: 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c 32 3f (if-rel2?
1bc0: 20 28 63 6f 6d 70 61 72 65 20 79 20 7a 29 20 23 (compare y z) #
1bd0: 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 t #f).
1be0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
1bf0: 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 pare:checked #f
1c00: 63 6f 6d 70 61 72 65 20 7a 29 29 29 29 0a 20 20 compare z)))).
1c10: 20 20 20 20 20 20 20 28 28 78 20 79 20 7a 29 0a ((x y z).
1c20: 20 20 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 (if-re
1c30: 6c 31 3f 20 28 64 65 66 61 75 6c 74 2d 63 6f 6d l1? (default-com
1c40: 70 61 72 65 20 78 20 79 29 0a 20 20 20 20 20 20 pare x y).
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
1c60: 66 2d 72 65 6c 32 3f 20 28 64 65 66 61 75 6c 74 f-rel2? (default
1c70: 2d 63 6f 6d 70 61 72 65 20 79 20 7a 29 20 23 74 -compare y z) #t
1c80: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
1c90: 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 (compar
1ca0: 65 3a 63 68 65 63 6b 65 64 20 23 66 20 64 65 66 e:checked #f def
1cb0: 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 7a 29 29 ault-compare z))
1cc0: 29 0a 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d ). ((com
1cd0: 70 61 72 65 20 78 20 79 20 7a 29 0a 20 20 20 20 pare x y z).
1ce0: 20 20 20 20 20 20 28 69 66 2d 72 65 6c 31 3f 20 (if-rel1?
1cf0: 28 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 (compare x y).
1d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d10: 20 20 28 69 66 2d 72 65 6c 32 3f 20 28 63 6f 6d (if-rel2? (com
1d20: 70 61 72 65 20 79 20 7a 29 20 23 74 20 23 66 29 pare y z) #t #f)
1d30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1d40: 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 (compare:ch
1d50: 65 63 6b 65 64 20 23 66 20 63 6f 6d 70 61 72 65 ecked #f compare
1d60: 20 7a 29 29 29 29 29 29 29 29 0a 0a 28 63 6f 6d z))))))))..(com
1d70: 70 61 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 pare:define-rel1
1d80: 2f 72 65 6c 32 3f 20 3c 2f 3c 3f 20 20 20 69 66 /rel2? </<? if
1d90: 3c 3f 20 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 <? if<?).(compa
1da0: 72 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 re:define-rel1/r
1db0: 65 6c 32 3f 20 3c 2f 3c 3d 3f 20 20 69 66 3c 3f el2? </<=? if<?
1dc0: 20 20 69 66 3c 3d 3f 29 0a 28 63 6f 6d 70 61 72 if<=?).(compar
1dd0: 65 3a 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 e:define-rel1/re
1de0: 6c 32 3f 20 3c 3d 2f 3c 3f 20 20 69 66 3c 3d 3f l2? <=/<? if<=?
1df0: 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 72 65 3a if<?).(compare:
1e00: 64 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 define-rel1/rel2
1e10: 3f 20 3c 3d 2f 3c 3d 3f 20 69 66 3c 3d 3f 20 69 ? <=/<=? if<=? i
1e20: 66 3c 3d 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 f<=?).(compare:d
1e30: 65 66 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f efine-rel1/rel2?
1e40: 20 3e 2f 3e 3f 20 20 20 69 66 3e 3f 20 20 69 66 >/>? if>? if
1e50: 3e 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 >?).(compare:def
1e60: 69 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 3e ine-rel1/rel2? >
1e70: 2f 3e 3d 3f 20 20 69 66 3e 3f 20 20 69 66 3e 3d />=? if>? if>=
1e80: 3f 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 ?).(compare:defi
1e90: 6e 65 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 3e 3d ne-rel1/rel2? >=
1ea0: 2f 3e 3f 20 20 69 66 3e 3d 3f 20 69 66 3e 3f 29 />? if>=? if>?)
1eb0: 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 .(compare:define
1ec0: 2d 72 65 6c 31 2f 72 65 6c 32 3f 20 3e 3d 2f 3e -rel1/rel2? >=/>
1ed0: 3d 3f 20 69 66 3e 3d 3f 20 69 66 3e 3d 3f 29 0a =? if>=? if>=?).
1ee0: 0a 0a 3b 20 63 68 61 69 6e 73 20 6f 66 20 61 72 ..; chains of ar
1ef0: 62 69 74 72 61 72 79 20 6c 65 6e 67 74 68 0a 0a bitrary length..
1f00: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 63 (define-syntax c
1f10: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 63 68 ompare:define-ch
1f20: 61 69 6e 2d 72 65 6c 3f 0a 20 20 28 73 79 6e 74 ain-rel?. (synt
1f30: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
1f40: 28 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 ((compare:define
1f50: 2d 63 68 61 69 6e 2d 72 65 6c 3f 20 63 68 61 69 -chain-rel? chai
1f60: 6e 2d 72 65 6c 3f 20 69 66 2d 72 65 6c 3f 29 0a n-rel? if-rel?).
1f70: 20 20 20 20 20 28 64 65 66 69 6e 65 20 63 68 61 (define cha
1f80: 69 6e 2d 72 65 6c 3f 0a 20 20 20 20 20 20 20 28 in-rel?. (
1f90: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda.
1fa0: 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 29 0a ((compare).
1fb0: 20 20 20 20 20 20 20 20 20 20 23 74 29 0a 20 20 #t).
1fc0: 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 ((compare
1fd0: 20 78 31 29 0a 20 20 20 20 20 20 20 20 20 20 28 x1). (
1fe0: 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 compare:checked
1ff0: 23 74 20 63 6f 6d 70 61 72 65 20 78 31 29 29 0a #t compare x1)).
2000: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 61 ((compa
2010: 72 65 20 78 31 20 78 32 29 0a 20 20 20 20 20 20 re x1 x2).
2020: 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 28 63 6f (if-rel? (co
2030: 6d 70 61 72 65 20 78 31 20 78 32 29 20 23 74 20 mpare x1 x2) #t
2040: 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 #f)). ((
2050: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 20 78 33 compare x1 x2 x3
2060: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 2d ). (if-
2070: 72 65 6c 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 rel? (compare x1
2080: 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 x2).
2090: 20 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c 3f (if-rel?
20a0: 20 28 63 6f 6d 70 61 72 65 20 78 32 20 78 33 29 (compare x2 x3)
20b0: 20 23 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 #t #f).
20c0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 (comp
20d0: 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 63 are:checked #f c
20e0: 6f 6d 70 61 72 65 20 78 33 29 29 29 0a 20 20 20 ompare x3))).
20f0: 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ((compare
2100: 78 31 20 78 32 20 2e 20 78 33 2b 29 0a 20 20 20 x1 x2 . x3+).
2110: 20 20 20 20 20 20 20 28 69 66 2d 72 65 6c 3f 20 (if-rel?
2120: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a (compare x1 x2).
2130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2140: 20 20 20 28 6c 65 74 20 63 68 61 69 6e 3f 20 28 (let chain? (
2150: 28 68 65 61 64 20 78 32 29 20 28 74 61 69 6c 20 (head x2) (tail
2160: 78 33 2b 29 29 0a 20 20 20 20 20 20 20 20 20 20 x3+)).
2170: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
2180: 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a 20 20 20 20 null? tail).
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21a0: 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 #t.
21b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21c0: 20 28 69 66 2d 72 65 6c 3f 20 28 63 6f 6d 70 61 (if-rel? (compa
21d0: 72 65 20 68 65 61 64 20 28 63 61 72 20 74 61 69 re head (car tai
21e0: 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 l)).
21f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2200: 20 20 20 20 20 20 28 63 68 61 69 6e 3f 20 28 63 (chain? (c
2210: 61 72 20 74 61 69 6c 29 20 28 63 64 72 20 74 61 ar tail) (cdr ta
2220: 69 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 il)).
2230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2240: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 63 6f (apply co
2250: 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 mpare:checked #f
2260: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2280: 20 20 20 20 20 20 20 20 20 20 20 63 6f 6d 70 61 compa
2290: 72 65 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 re (cdr tail))))
22a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
22b0: 20 20 20 20 20 28 61 70 70 6c 79 20 63 6f 6d 70 (apply comp
22c0: 61 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 63 are:checked #f c
22d0: 6f 6d 70 61 72 65 20 78 33 2b 29 29 29 29 29 29 ompare x3+))))))
22e0: 29 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 ))..(compare:def
22f0: 69 6e 65 2d 63 68 61 69 6e 2d 72 65 6c 3f 20 63 ine-chain-rel? c
2300: 68 61 69 6e 3d 3f 20 20 69 66 3d 3f 29 0a 28 63 hain=? if=?).(c
2310: 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 63 68 ompare:define-ch
2320: 61 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e 3c 3f ain-rel? chain<?
2330: 20 20 69 66 3c 3f 29 0a 28 63 6f 6d 70 61 72 65 if<?).(compare
2340: 3a 64 65 66 69 6e 65 2d 63 68 61 69 6e 2d 72 65 :define-chain-re
2350: 6c 3f 20 63 68 61 69 6e 3e 3f 20 20 69 66 3e 3f l? chain>? if>?
2360: 29 0a 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e ).(compare:defin
2370: 65 2d 63 68 61 69 6e 2d 72 65 6c 3f 20 63 68 61 e-chain-rel? cha
2380: 69 6e 3c 3d 3f 20 69 66 3c 3d 3f 29 0a 28 63 6f in<=? if<=?).(co
2390: 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 63 68 61 mpare:define-cha
23a0: 69 6e 2d 72 65 6c 3f 20 63 68 61 69 6e 3e 3d 3f in-rel? chain>=?
23b0: 20 69 66 3e 3d 3f 29 0a 0a 0a 3b 20 70 61 69 72 if>=?)...; pair
23c0: 77 69 73 65 20 69 6e 65 71 75 61 6c 69 74 79 0a wise inequality.
23d0: 0a 28 64 65 66 69 6e 65 20 70 61 69 72 77 69 73 .(define pairwis
23e0: 65 2d 6e 6f 74 3d 3f 0a 20 20 28 6c 65 74 20 28 e-not=?. (let (
23f0: 28 3d 20 3d 29 20 28 3c 3d 20 3c 3d 29 29 0a 20 (= =) (<= <=)).
2400: 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a (case-lambda.
2410: 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 29 ((compare)
2420: 0a 20 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 . #t).
2430: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 31 29 0a ((compare x1).
2440: 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 65 3a (compare:
2450: 63 68 65 63 6b 65 64 20 23 74 20 63 6f 6d 70 61 checked #t compa
2460: 72 65 20 78 31 29 29 0a 20 20 20 20 20 20 28 28 re x1)). ((
2470: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a 20 compare x1 x2).
2480: 20 20 20 20 20 20 28 69 66 2d 6e 6f 74 3d 3f 20 (if-not=?
2490: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 20 (compare x1 x2)
24a0: 23 74 20 23 66 29 29 0a 20 20 20 20 20 20 28 28 #t #f)). ((
24b0: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 20 78 33 compare x1 x2 x3
24c0: 29 0a 20 20 20 20 20 20 20 28 69 66 2d 6e 6f 74 ). (if-not
24d0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 =? (compare x1 x
24e0: 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 2).
24f0: 20 20 20 20 28 69 66 2d 6e 6f 74 3d 3f 20 28 63 (if-not=? (c
2500: 6f 6d 70 61 72 65 20 78 32 20 78 33 29 0a 20 20 ompare x2 x3).
2510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2520: 20 20 20 20 20 20 20 20 20 28 69 66 2d 6e 6f 74 (if-not
2530: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 =? (compare x1 x
2540: 33 29 20 23 74 20 23 66 29 0a 20 20 20 20 20 20 3) #t #f).
2550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2560: 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 #f).
2570: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 61 (compa
2580: 72 65 3a 63 68 65 63 6b 65 64 20 23 66 20 63 6f re:checked #f co
2590: 6d 70 61 72 65 20 78 33 29 29 29 0a 20 20 20 20 mpare x3))).
25a0: 20 20 28 28 63 6f 6d 70 61 72 65 20 2e 20 78 31 ((compare . x1
25b0: 2b 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 75 +). (let u
25c0: 6e 65 71 75 61 6c 3f 20 28 28 78 20 78 31 2b 29 nequal? ((x x1+)
25d0: 20 28 6e 20 28 6c 65 6e 67 74 68 20 78 31 2b 29 (n (length x1+)
25e0: 29 20 28 75 6e 63 68 65 63 6b 65 64 3f 20 23 74 ) (unchecked? #t
25f0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 20 )). (if
2600: 28 3c 20 6e 20 32 29 0a 20 20 20 20 20 20 20 20 (< n 2).
2610: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 75 6e (if (and un
2620: 63 68 65 63 6b 65 64 3f 20 28 3d 20 6e 20 31 29 checked? (= n 1)
2630: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2640: 20 20 20 28 63 6f 6d 70 61 72 65 3a 63 68 65 63 (compare:chec
2650: 6b 65 64 20 23 74 20 63 6f 6d 70 61 72 65 20 28 ked #t compare (
2660: 63 61 72 20 78 29 29 0a 20 20 20 20 20 20 20 20 car x)).
2670: 20 20 20 20 20 20 20 20 20 23 74 29 0a 20 20 20 #t).
2680: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
2690: 28 28 69 2d 70 69 76 6f 74 20 28 72 61 6e 64 6f ((i-pivot (rando
26a0: 6d 2d 69 6e 74 65 67 65 72 20 6e 29 29 0a 20 20 m-integer n)).
26b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26c0: 20 20 28 78 2d 70 69 76 6f 74 20 28 6c 69 73 74 (x-pivot (list
26d0: 2d 72 65 66 20 78 20 69 2d 70 69 76 6f 74 29 29 -ref x i-pivot))
26e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
26f0: 20 28 6c 65 74 20 73 70 6c 69 74 20 28 28 69 20 (let split ((i
2700: 30 29 20 28 78 20 78 29 20 28 78 3c 20 27 28 29 0) (x x) (x< '()
2710: 29 20 28 78 3e 20 27 28 29 29 29 0a 20 20 20 20 ) (x> '())).
2720: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
2730: 20 28 6e 75 6c 6c 3f 20 78 29 0a 20 20 20 20 20 (null? x).
2740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2750: 28 61 6e 64 20 28 75 6e 65 71 75 61 6c 3f 20 78 (and (unequal? x
2760: 3c 20 28 6c 65 6e 67 74 68 20 78 3c 29 20 23 66 < (length x<) #f
2770: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2780: 20 20 20 20 20 20 20 20 20 20 20 20 28 75 6e 65 (une
2790: 71 75 61 6c 3f 20 78 3e 20 28 6c 65 6e 67 74 68 qual? x> (length
27a0: 20 78 3e 29 20 23 66 29 29 0a 20 20 20 20 20 20 x>) #f)).
27b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
27c0: 69 66 20 28 3d 20 69 20 69 2d 70 69 76 6f 74 29 if (= i i-pivot)
27d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
27e0: 20 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 74 (split
27f0: 20 28 2b 20 69 20 31 29 20 28 63 64 72 20 78 29 (+ i 1) (cdr x)
2800: 20 78 3c 20 78 3e 29 0a 20 20 20 20 20 20 20 20 x< x>).
2810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2820: 20 28 69 66 33 20 28 63 6f 6d 70 61 72 65 20 28 (if3 (compare (
2830: 63 61 72 20 78 29 20 78 2d 70 69 76 6f 74 29 0a car x) x-pivot).
2840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
2860: 70 6c 69 74 20 28 2b 20 69 20 31 29 20 28 63 64 plit (+ i 1) (cd
2870: 72 20 78 29 20 28 63 6f 6e 73 20 28 63 61 72 20 r x) (cons (car
2880: 78 29 20 78 3c 29 20 78 3e 29 0a 20 20 20 20 20 x) x<) x>).
2890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28a0: 20 20 20 20 20 20 20 20 20 28 69 66 20 75 6e 63 (if unc
28b0: 68 65 63 6b 65 64 3f 0a 20 20 20 20 20 20 20 20 hecked?.
28c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28d0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
28e0: 20 63 6f 6d 70 61 72 65 3a 63 68 65 63 6b 65 64 compare:checked
28f0: 20 23 66 20 63 6f 6d 70 61 72 65 20 28 63 64 72 #f compare (cdr
2900: 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x)).
2910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2920: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
2930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2940: 20 20 20 20 20 20 20 20 20 28 73 70 6c 69 74 20 (split
2950: 28 2b 20 69 20 31 29 20 28 63 64 72 20 78 29 20 (+ i 1) (cdr x)
2960: 78 3c 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 x< (cons (car x)
2970: 20 78 3e 29 29 29 29 29 29 29 29 29 29 29 29 29 x>)))))))))))))
2980: 0a 0a 0a 3b 20 6d 69 6e 2f 6d 61 78 0a 0a 28 64 ...; min/max..(d
2990: 65 66 69 6e 65 20 6d 69 6e 2d 63 6f 6d 70 61 72 efine min-compar
29a0: 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 e. (case-lambda
29b0: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 . ((compare x
29c0: 31 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 72 65 1). (compare
29d0: 3a 63 68 65 63 6b 65 64 20 78 31 20 63 6f 6d 70 :checked x1 comp
29e0: 61 72 65 20 78 31 29 29 0a 20 20 20 20 28 28 63 are x1)). ((c
29f0: 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a 20 20 ompare x1 x2).
2a00: 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 (if<=? (compa
2a10: 72 65 20 78 31 20 78 32 29 20 78 31 20 78 32 29 re x1 x2) x1 x2)
2a20: 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ). ((compare
2a30: 78 31 20 78 32 20 78 33 29 0a 20 20 20 20 20 28 x1 x2 x3). (
2a40: 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if<=? (compare x
2a50: 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 1 x2).
2a60: 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 (if<=? (compar
2a70: 65 20 78 31 20 78 33 29 20 78 31 20 78 33 29 0a e x1 x3) x1 x3).
2a80: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c (if<
2a90: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 20 78 =? (compare x2 x
2aa0: 33 29 20 78 32 20 78 33 29 29 29 0a 20 20 20 20 3) x2 x3))).
2ab0: 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 20 ((compare x1 x2
2ac0: 78 33 20 78 34 29 0a 20 20 20 20 20 28 69 66 3c x3 x4). (if<
2ad0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 =? (compare x1 x
2ae0: 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 2). (
2af0: 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if<=? (compare x
2b00: 31 20 78 33 29 0a 20 20 20 20 20 20 20 20 20 20 1 x3).
2b10: 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 (if<=?
2b20: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 34 29 20 (compare x1 x4)
2b30: 78 31 20 78 34 29 0a 20 20 20 20 20 20 20 20 20 x1 x4).
2b40: 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f (if<=?
2b50: 20 28 63 6f 6d 70 61 72 65 20 78 33 20 78 34 29 (compare x3 x4)
2b60: 20 78 33 20 78 34 29 29 0a 20 20 20 20 20 20 20 x3 x4)).
2b70: 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d (if<=? (com
2b80: 70 61 72 65 20 78 32 20 78 33 29 0a 20 20 20 20 pare x2 x3).
2b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2ba0: 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if<=? (compare x
2bb0: 32 20 78 34 29 20 78 32 20 78 34 29 0a 20 20 20 2 x4) x2 x4).
2bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bd0: 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if<=? (compare
2be0: 78 33 20 78 34 29 20 78 33 20 78 34 29 29 29 29 x3 x4) x3 x4))))
2bf0: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 . ((compare x
2c00: 31 20 78 32 20 2e 20 78 33 2b 29 0a 20 20 20 20 1 x2 . x3+).
2c10: 20 28 6c 65 74 20 6d 69 6e 20 28 28 78 6d 69 6e (let min ((xmin
2c20: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
2c30: 20 78 31 20 78 32 29 20 78 31 20 78 32 29 29 20 x1 x2) x1 x2))
2c40: 28 78 73 20 78 33 2b 29 29 0a 20 20 20 20 20 20 (xs x3+)).
2c50: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 78 73 29 0a (if (null? xs).
2c60: 20 20 20 20 20 20 20 20 20 20 20 78 6d 69 6e 0a xmin.
2c70: 20 20 20 20 20 20 20 20 20 20 20 28 6d 69 6e 20 (min
2c80: 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if<=? (compare
2c90: 78 6d 69 6e 20 28 63 61 72 20 78 73 29 29 20 78 xmin (car xs)) x
2ca0: 6d 69 6e 20 28 63 61 72 20 78 73 29 29 0a 20 20 min (car xs)).
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2cc0: 64 72 20 78 73 29 29 29 29 29 29 29 0a 0a 28 64 dr xs)))))))..(d
2cd0: 65 66 69 6e 65 20 6d 61 78 2d 63 6f 6d 70 61 72 efine max-compar
2ce0: 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 e. (case-lambda
2cf0: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 . ((compare x
2d00: 31 29 0a 20 20 20 20 20 28 63 6f 6d 70 61 72 65 1). (compare
2d10: 3a 63 68 65 63 6b 65 64 20 78 31 20 63 6f 6d 70 :checked x1 comp
2d20: 61 72 65 20 78 31 29 29 0a 20 20 20 20 28 28 63 are x1)). ((c
2d30: 6f 6d 70 61 72 65 20 78 31 20 78 32 29 0a 20 20 ompare x1 x2).
2d40: 20 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 (if>=? (compa
2d50: 72 65 20 78 31 20 78 32 29 20 78 31 20 78 32 29 re x1 x2) x1 x2)
2d60: 29 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ). ((compare
2d70: 78 31 20 78 32 20 78 33 29 0a 20 20 20 20 20 28 x1 x2 x3). (
2d80: 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if>=? (compare x
2d90: 31 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 1 x2).
2da0: 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 (if>=? (compar
2db0: 65 20 78 31 20 78 33 29 20 78 31 20 78 33 29 0a e x1 x3) x1 x3).
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3e (if>
2dd0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 32 20 78 =? (compare x2 x
2de0: 33 29 20 78 32 20 78 33 29 29 29 0a 20 20 20 20 3) x2 x3))).
2df0: 28 28 63 6f 6d 70 61 72 65 20 78 31 20 78 32 20 ((compare x1 x2
2e00: 78 33 20 78 34 29 0a 20 20 20 20 20 28 69 66 3e x3 x4). (if>
2e10: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 78 =? (compare x1 x
2e20: 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 2). (
2e30: 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if>=? (compare x
2e40: 31 20 78 33 29 0a 20 20 20 20 20 20 20 20 20 20 1 x3).
2e50: 20 20 20 20 20 20 20 20 20 28 69 66 3e 3d 3f 20 (if>=?
2e60: 28 63 6f 6d 70 61 72 65 20 78 31 20 78 34 29 20 (compare x1 x4)
2e70: 78 31 20 78 34 29 0a 20 20 20 20 20 20 20 20 20 x1 x4).
2e80: 20 20 20 20 20 20 20 20 20 20 28 69 66 3e 3d 3f (if>=?
2e90: 20 28 63 6f 6d 70 61 72 65 20 78 33 20 78 34 29 (compare x3 x4)
2ea0: 20 78 33 20 78 34 29 29 0a 20 20 20 20 20 20 20 x3 x4)).
2eb0: 20 20 20 20 20 28 69 66 3e 3d 3f 20 28 63 6f 6d (if>=? (com
2ec0: 70 61 72 65 20 78 32 20 78 33 29 0a 20 20 20 20 pare x2 x3).
2ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2ee0: 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if>=? (compare x
2ef0: 32 20 78 34 29 20 78 32 20 78 34 29 0a 20 20 20 2 x4) x2 x4).
2f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f10: 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if>=? (compare
2f20: 78 33 20 78 34 29 20 78 33 20 78 34 29 29 29 29 x3 x4) x3 x4))))
2f30: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 . ((compare x
2f40: 31 20 78 32 20 2e 20 78 33 2b 29 0a 20 20 20 20 1 x2 . x3+).
2f50: 20 28 6c 65 74 20 6d 61 78 20 28 28 78 6d 61 78 (let max ((xmax
2f60: 20 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 (if>=? (compare
2f70: 20 78 31 20 78 32 29 20 78 31 20 78 32 29 29 20 x1 x2) x1 x2))
2f80: 28 78 73 20 78 33 2b 29 29 0a 20 20 20 20 20 20 (xs x3+)).
2f90: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 78 73 29 0a (if (null? xs).
2fa0: 20 20 20 20 20 20 20 20 20 20 20 78 6d 61 78 0a xmax.
2fb0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 78 20 (max
2fc0: 28 69 66 3e 3d 3f 20 28 63 6f 6d 70 61 72 65 20 (if>=? (compare
2fd0: 78 6d 61 78 20 28 63 61 72 20 78 73 29 29 20 78 xmax (car xs)) x
2fe0: 6d 61 78 20 28 63 61 72 20 78 73 29 29 0a 20 20 max (car xs)).
2ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
3000: 64 72 20 78 73 29 29 29 29 29 29 29 0a 0a 0a 3b dr xs)))))))...;
3010: 20 6b 74 68 2d 6c 61 72 67 65 73 74 0a 0a 28 64 kth-largest..(d
3020: 65 66 69 6e 65 20 6b 74 68 2d 6c 61 72 67 65 73 efine kth-larges
3030: 74 0a 20 20 28 6c 65 74 20 28 28 3d 20 3d 29 20 t. (let ((= =)
3040: 28 3c 20 3c 29 29 0a 20 20 20 20 28 63 61 73 65 (< <)). (case
3050: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 20 28 28 -lambda. ((
3060: 63 6f 6d 70 61 72 65 20 6b 20 78 30 29 0a 20 20 compare k x0).
3070: 20 20 20 20 20 28 63 61 73 65 20 28 6d 6f 64 75 (case (modu
3080: 6c 6f 20 6b 20 31 29 0a 20 20 20 20 20 20 20 20 lo k 1).
3090: 20 28 28 30 29 20 20 28 63 6f 6d 70 61 72 65 3a ((0) (compare:
30a0: 63 68 65 63 6b 65 64 20 78 30 20 63 6f 6d 70 61 checked x0 compa
30b0: 72 65 20 78 30 29 29 0a 20 20 20 20 20 20 20 20 re x0)).
30c0: 20 28 65 6c 73 65 20 28 65 72 72 6f 72 20 22 62 (else (error "b
30d0: 61 64 20 69 6e 64 65 78 22 20 6b 29 29 29 29 0a ad index" k)))).
30e0: 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ((compare
30f0: 6b 20 78 30 20 78 31 29 0a 20 20 20 20 20 20 20 k x0 x1).
3100: 28 63 61 73 65 20 28 6d 6f 64 75 6c 6f 20 6b 20 (case (modulo k
3110: 32 29 0a 20 20 20 20 20 20 20 20 20 28 28 30 29 2). ((0)
3120: 20 28 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 (if<=? (compare
3130: 20 78 30 20 78 31 29 20 78 30 20 78 31 29 29 0a x0 x1) x0 x1)).
3140: 20 20 20 20 20 20 20 20 20 28 28 31 29 20 28 69 ((1) (i
3150: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 f<=? (compare x0
3160: 20 78 31 29 20 78 31 20 78 30 29 29 0a 20 20 20 x1) x1 x0)).
3170: 20 20 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 (else (err
3180: 6f 72 20 22 62 61 64 20 69 6e 64 65 78 22 20 6b or "bad index" k
3190: 29 29 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d )))). ((com
31a0: 70 61 72 65 20 6b 20 78 30 20 78 31 20 78 32 29 pare k x0 x1 x2)
31b0: 0a 20 20 20 20 20 20 20 28 63 61 73 65 20 28 6d . (case (m
31c0: 6f 64 75 6c 6f 20 6b 20 33 29 0a 20 20 20 20 20 odulo k 3).
31d0: 20 20 20 20 28 28 30 29 20 28 69 66 3c 3d 3f 20 ((0) (if<=?
31e0: 28 63 6f 6d 70 61 72 65 20 78 30 20 78 31 29 0a (compare x0 x1).
31f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3200: 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 63 6f 6d (if<=? (com
3210: 70 61 72 65 20 78 30 20 78 32 29 20 78 30 20 78 pare x0 x2) x0 x
3220: 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 2).
3230: 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 (if<=? (
3240: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 20 78 compare x1 x2) x
3250: 31 20 78 32 29 29 29 0a 20 20 20 20 20 20 20 20 1 x2))).
3260: 20 28 28 31 29 20 28 69 66 33 20 28 63 6f 6d 70 ((1) (if3 (comp
3270: 61 72 65 20 78 30 20 78 31 29 0a 20 20 20 20 20 are x0 x1).
3280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3290: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 f<=? (compare x1
32a0: 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 x2).
32b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 78 x
32c0: 31 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1.
32d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c (if<
32e0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 =? (compare x0 x
32f0: 32 29 20 78 32 20 78 30 29 29 0a 20 20 20 20 20 2) x2 x0)).
3300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3310: 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 f<=? (compare x0
3320: 20 78 32 29 20 78 31 20 78 30 29 0a 20 20 20 20 x2) x1 x0).
3330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3340: 69 66 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 if<=? (compare x
3350: 30 20 78 32 29 0a 20 20 20 20 20 20 20 20 20 20 0 x2).
3360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3370: 78 30 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x0.
3380: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
3390: 3c 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 31 20 <=? (compare x1
33a0: 78 32 29 20 78 32 20 78 31 29 29 29 29 0a 20 20 x2) x2 x1)))).
33b0: 20 20 20 20 20 20 20 28 28 32 29 20 28 69 66 3c ((2) (if<
33c0: 3d 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 =? (compare x0 x
33d0: 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1).
33e0: 20 20 20 20 20 20 20 20 28 69 66 3c 3d 3f 20 28 (if<=? (
33f0: 63 6f 6d 70 61 72 65 20 78 31 20 78 32 29 20 78 compare x1 x2) x
3400: 32 20 78 31 29 0a 20 20 20 20 20 20 20 20 20 20 2 x1).
3410: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 3c 3d (if<=
3420: 3f 20 28 63 6f 6d 70 61 72 65 20 78 30 20 78 32 ? (compare x0 x2
3430: 29 20 78 32 20 78 30 29 29 29 0a 20 20 20 20 20 ) x2 x0))).
3440: 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 6f 72 (else (error
3450: 20 22 62 61 64 20 69 6e 64 65 78 22 20 6b 29 29 "bad index" k))
3460: 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 )). ((compa
3470: 72 65 20 6b 20 78 30 20 2e 20 78 31 2b 29 20 3b re k x0 . x1+) ;
3480: 20 7c 78 31 2b 7c 20 3e 3d 20 31 0a 20 20 20 20 |x1+| >= 1.
3490: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 (if (not (and
34a0: 20 28 69 6e 74 65 67 65 72 3f 20 6b 29 20 28 65 (integer? k) (e
34b0: 78 61 63 74 3f 20 6b 29 29 29 0a 20 20 20 20 20 xact? k))).
34c0: 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 62 61 (error "ba
34d0: 64 20 69 6e 64 65 78 22 20 6b 29 29 0a 20 20 20 d index" k)).
34e0: 20 20 20 20 28 6c 65 74 20 28 28 6e 20 28 2b 20 (let ((n (+
34f0: 31 20 28 6c 65 6e 67 74 68 20 78 31 2b 29 29 29 1 (length x1+)))
3500: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 ). (let
3510: 6b 74 68 20 28 28 6b 20 20 20 28 6d 6f 64 75 6c kth ((k (modul
3520: 6f 20 6b 20 6e 29 29 0a 20 20 20 20 20 20 20 20 o k n)).
3530: 20 20 20 20 20 20 20 20 20 20 20 28 6e 20 20 20 (n
3540: 6e 29 20 20 3b 20 3d 20 7c 78 7c 0a 20 20 20 20 n) ; = |x|.
3550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3560: 72 65 76 20 23 74 29 20 3b 20 61 72 65 20 78 3c rev #t) ; are x<
3570: 2c 20 78 3d 2c 20 78 3e 20 72 65 76 65 72 73 65 , x=, x> reverse
3580: 64 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d?.
3590: 20 20 20 20 20 20 28 78 20 20 20 28 63 6f 6e 73 (x (cons
35a0: 20 78 30 20 78 31 2b 29 29 29 0a 20 20 20 20 20 x0 x1+))).
35b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 70 69 76 (let ((piv
35c0: 6f 74 20 28 6c 69 73 74 2d 72 65 66 20 78 20 28 ot (list-ref x (
35d0: 72 61 6e 64 6f 6d 2d 69 6e 74 65 67 65 72 20 6e random-integer n
35e0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
35f0: 20 20 28 6c 65 74 20 73 70 6c 69 74 20 28 28 78 (let split ((x
3600: 20 78 29 20 28 78 3c 20 27 28 29 29 20 28 6e 3c x) (x< '()) (n<
3610: 20 30 29 20 28 78 3d 20 27 28 29 29 20 28 6e 3d 0) (x= '()) (n=
3620: 20 30 29 20 28 78 3e 20 27 28 29 29 20 28 6e 3e 0) (x> '()) (n>
3630: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
3640: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 78 (if (null? x
3650: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3660: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
3670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3680: 28 28 3c 20 6b 20 6e 3c 29 0a 20 20 20 20 20 20 ((< k n<).
3690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36a0: 28 6b 74 68 20 6b 20 6e 3c 20 28 6e 6f 74 20 72 (kth k n< (not r
36b0: 65 76 29 20 78 3c 29 29 0a 20 20 20 20 20 20 20 ev) x<)).
36c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
36d0: 3c 20 6b 20 28 2b 20 6e 3c 20 6e 3d 29 29 0a 20 < k (+ n< n=)).
36e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36f0: 20 20 20 20 20 28 69 66 20 72 65 76 0a 20 20 20 (if rev.
3700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3710: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 (list-ref
3720: 20 78 3d 20 28 2d 20 28 2d 20 6e 3d 20 31 29 20 x= (- (- n= 1)
3730: 28 2d 20 6b 20 6e 3c 29 29 29 0a 20 20 20 20 20 (- k n<))).
3740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3750: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 78 (list-ref x
3760: 3d 20 28 2d 20 6b 20 6e 3c 29 29 29 29 0a 20 20 = (- k n<)))).
3770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3780: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 (else.
3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
37a0: 6b 74 68 20 28 2d 20 6b 20 28 2b 20 6e 3c 20 6e kth (- k (+ n< n
37b0: 3d 29 29 20 6e 3e 20 28 6e 6f 74 20 72 65 76 29 =)) n> (not rev)
37c0: 20 78 3e 29 29 29 0a 20 20 20 20 20 20 20 20 20 x>))).
37d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 33 20 28 (if3 (
37e0: 63 6f 6d 70 61 72 65 20 28 63 61 72 20 78 29 20 compare (car x)
37f0: 70 69 76 6f 74 29 0a 20 20 20 20 20 20 20 20 20 pivot).
3800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3810: 73 70 6c 69 74 20 28 63 64 72 20 78 29 20 28 63 split (cdr x) (c
3820: 6f 6e 73 20 28 63 61 72 20 78 29 20 78 3c 29 20 ons (car x) x<)
3830: 28 2b 20 6e 3c 20 31 29 20 78 3d 20 6e 3d 20 78 (+ n< 1) x= n= x
3840: 3e 20 6e 3e 29 0a 20 20 20 20 20 20 20 20 20 20 > n>).
3850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
3860: 70 6c 69 74 20 28 63 64 72 20 78 29 20 78 3c 20 plit (cdr x) x<
3870: 6e 3c 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 n< (cons (car x)
3880: 20 78 3d 29 20 28 2b 20 6e 3d 20 31 29 20 78 3e x=) (+ n= 1) x>
3890: 20 6e 3e 29 0a 20 20 20 20 20 20 20 20 20 20 20 n>).
38a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 (sp
38b0: 6c 69 74 20 28 63 64 72 20 78 29 20 78 3c 20 6e lit (cdr x) x< n
38c0: 3c 20 78 3d 20 6e 3d 20 28 63 6f 6e 73 20 28 63 < x= n= (cons (c
38d0: 61 72 20 78 29 20 78 3e 29 20 28 2b 20 6e 3e 20 ar x) x>) (+ n>
38e0: 31 29 29 29 29 29 29 29 29 29 29 29 29 0a 0a 0a 1))))))))))))...
38f0: 3b 20 63 6f 6d 70 61 72 65 20 66 75 6e 63 74 69 ; compare functi
3900: 6f 6e 73 20 66 72 6f 6d 20 70 72 65 64 69 63 61 ons from predica
3910: 74 65 73 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d tes..(define com
3920: 70 61 72 65 2d 62 79 3c 0a 20 20 28 63 61 73 65 pare-by<. (case
3930: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 6c 74 -lambda. ((lt
3940: 29 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 ) (lambda (x
3950: 20 79 29 20 28 69 66 20 28 6c 74 20 78 20 79 29 y) (if (lt x y)
3960: 20 2d 31 20 28 69 66 20 28 6c 74 20 79 20 78 29 -1 (if (lt y x)
3970: 20 20 31 20 30 29 29 29 29 0a 20 20 20 20 28 28 1 0)))). ((
3980: 6c 74 20 78 20 79 29 20 20 20 20 20 20 20 20 20 lt x y)
3990: 20 20 20 20 20 20 28 69 66 20 28 6c 74 20 78 20 (if (lt x
39a0: 79 29 20 2d 31 20 28 69 66 20 28 6c 74 20 79 20 y) -1 (if (lt y
39b0: 78 29 20 20 31 20 30 29 29 29 29 29 0a 0a 28 64 x) 1 0)))))..(d
39c0: 65 66 69 6e 65 20 63 6f 6d 70 61 72 65 2d 62 79 efine compare-by
39d0: 3e 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 >. (case-lambda
39e0: 0a 20 20 20 20 28 28 67 74 29 20 20 20 20 20 28 . ((gt) (
39f0: 6c 61 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 lambda (x y) (if
3a00: 20 28 67 74 20 78 20 79 29 20 31 20 28 69 66 20 (gt x y) 1 (if
3a10: 28 67 74 20 79 20 78 29 20 20 2d 31 20 30 29 29 (gt y x) -1 0))
3a20: 29 29 0a 20 20 20 20 28 28 67 74 20 78 20 79 29 )). ((gt x y)
3a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3a40: 69 66 20 28 67 74 20 78 20 79 29 20 31 20 28 69 if (gt x y) 1 (i
3a50: 66 20 28 67 74 20 79 20 78 29 20 20 2d 31 20 30 f (gt y x) -1 0
3a60: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 )))))..(define c
3a70: 6f 6d 70 61 72 65 2d 62 79 3c 3d 0a 20 20 28 63 ompare-by<=. (c
3a80: 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 ase-lambda. (
3a90: 28 6c 65 29 20 20 20 20 20 28 6c 61 6d 62 64 61 (le) (lambda
3aa0: 20 28 78 20 79 29 20 28 69 66 20 28 6c 65 20 78 (x y) (if (le x
3ab0: 20 79 29 20 28 69 66 20 28 6c 65 20 79 20 78 29 y) (if (le y x)
3ac0: 20 30 20 2d 31 29 20 31 29 29 29 0a 20 20 20 20 0 -1) 1))).
3ad0: 28 28 6c 65 20 78 20 79 29 20 20 20 20 20 20 20 ((le x y)
3ae0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6c 65 20 (if (le
3af0: 78 20 79 29 20 28 69 66 20 28 6c 65 20 79 20 78 x y) (if (le y x
3b00: 29 20 30 20 2d 31 29 20 31 29 29 29 29 0a 0a 28 ) 0 -1) 1))))..(
3b10: 64 65 66 69 6e 65 20 63 6f 6d 70 61 72 65 2d 62 define compare-b
3b20: 79 3e 3d 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 y>=. (case-lamb
3b30: 64 61 0a 20 20 20 20 28 28 67 65 29 20 20 20 20 da. ((ge)
3b40: 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 20 28 (lambda (x y) (
3b50: 69 66 20 28 67 65 20 78 20 79 29 20 28 69 66 20 if (ge x y) (if
3b60: 28 67 65 20 79 20 78 29 20 30 20 31 29 20 2d 31 (ge y x) 0 1) -1
3b70: 29 29 29 0a 20 20 20 20 28 28 67 65 20 78 20 79 ))). ((ge x y
3b80: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3b90: 28 69 66 20 28 67 65 20 78 20 79 29 20 28 69 66 (if (ge x y) (if
3ba0: 20 28 67 65 20 79 20 78 29 20 30 20 31 29 20 2d (ge y x) 0 1) -
3bb0: 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 1))))..(define c
3bc0: 6f 6d 70 61 72 65 2d 62 79 3d 2f 3c 0a 20 20 28 ompare-by=/<. (
3bd0: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda.
3be0: 28 28 65 71 20 6c 74 29 20 20 20 20 20 28 6c 61 ((eq lt) (la
3bf0: 6d 62 64 61 20 28 78 20 79 29 20 28 69 66 20 28 mbda (x y) (if (
3c00: 65 71 20 78 20 79 29 20 30 20 28 69 66 20 28 6c eq x y) 0 (if (l
3c10: 74 20 78 20 79 29 20 2d 31 20 31 29 29 29 29 0a t x y) -1 1)))).
3c20: 20 20 20 20 28 28 65 71 20 6c 74 20 78 20 79 29 ((eq lt x y)
3c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3c40: 69 66 20 28 65 71 20 78 20 79 29 20 30 20 28 69 if (eq x y) 0 (i
3c50: 66 20 28 6c 74 20 78 20 79 29 20 2d 31 20 31 29 f (lt x y) -1 1)
3c60: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f ))))..(define co
3c70: 6d 70 61 72 65 2d 62 79 3d 2f 3e 0a 20 20 28 63 mpare-by=/>. (c
3c80: 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 ase-lambda. (
3c90: 28 65 71 20 67 74 29 20 20 20 20 20 28 6c 61 6d (eq gt) (lam
3ca0: 62 64 61 20 28 78 20 79 29 20 28 69 66 20 28 65 bda (x y) (if (e
3cb0: 71 20 78 20 79 29 20 30 20 28 69 66 20 28 67 74 q x y) 0 (if (gt
3cc0: 20 78 20 79 29 20 31 20 2d 31 29 29 29 29 0a 20 x y) 1 -1)))).
3cd0: 20 20 20 28 28 65 71 20 67 74 20 78 20 79 29 20 ((eq gt x y)
3ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3cf0: 66 20 28 65 71 20 78 20 79 29 20 30 20 28 69 66 f (eq x y) 0 (if
3d00: 20 28 67 74 20 78 20 79 29 20 31 20 2d 31 29 29 (gt x y) 1 -1))
3d10: 29 29 29 0a 0a 3b 20 72 65 66 69 6e 65 20 61 6e )))..; refine an
3d20: 64 20 65 78 74 65 6e 64 20 63 6f 6e 73 74 72 75 d extend constru
3d30: 63 74 69 6f 6e 0a 0a 28 64 65 66 69 6e 65 2d 73 ction..(define-s
3d40: 79 6e 74 61 78 20 72 65 66 69 6e 65 2d 63 6f 6d yntax refine-com
3d50: 70 61 72 65 0a 20 20 28 73 79 6e 74 61 78 2d 72 pare. (syntax-r
3d60: 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 72 65 ules (). ((re
3d70: 66 69 6e 65 2d 63 6f 6d 70 61 72 65 29 0a 20 20 fine-compare).
3d80: 20 20 20 30 29 0a 20 20 20 20 28 28 72 65 66 69 0). ((refi
3d90: 6e 65 2d 63 6f 6d 70 61 72 65 20 63 31 29 0a 20 ne-compare c1).
3da0: 20 20 20 20 63 31 29 0a 20 20 20 20 28 28 72 65 c1). ((re
3db0: 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 63 31 20 fine-compare c1
3dc0: 63 32 20 63 73 20 2e 2e 2e 29 0a 20 20 20 20 20 c2 cs ...).
3dd0: 28 69 66 33 20 63 31 20 2d 31 20 28 72 65 66 69 (if3 c1 -1 (refi
3de0: 6e 65 2d 63 6f 6d 70 61 72 65 20 63 32 20 63 73 ne-compare c2 cs
3df0: 20 2e 2e 2e 29 20 31 29 29 29 29 0a 0a 28 64 65 ...) 1))))..(de
3e00: 66 69 6e 65 2d 73 79 6e 74 61 78 20 73 65 6c 65 fine-syntax sele
3e10: 63 74 2d 63 6f 6d 70 61 72 65 0a 20 20 28 73 79 ct-compare. (sy
3e20: 6e 74 61 78 2d 72 75 6c 65 73 20 28 65 6c 73 65 ntax-rules (else
3e30: 29 0a 20 20 20 20 28 28 73 65 6c 65 63 74 2d 63 ). ((select-c
3e40: 6f 6d 70 61 72 65 20 78 20 79 20 63 6c 61 75 73 ompare x y claus
3e50: 65 20 2e 2e 2e 29 0a 20 20 20 20 20 28 6c 65 74 e ...). (let
3e60: 20 28 28 78 2d 76 61 6c 20 78 29 20 28 79 2d 76 ((x-val x) (y-v
3e70: 61 6c 20 79 29 29 0a 20 20 20 20 20 20 20 28 73 al y)). (s
3e80: 65 6c 65 63 74 2d 63 6f 6d 70 61 72 65 20 28 78 elect-compare (x
3e90: 2d 76 61 6c 20 79 2d 76 61 6c 20 63 6c 61 75 73 -val y-val claus
3ea0: 65 20 2e 2e 2e 29 29 29 29 0a 20 20 20 20 3b 20 e ...)))). ;
3eb0: 75 73 65 64 20 69 6e 74 65 72 6e 61 6c 6c 79 3a used internally:
3ec0: 20 28 73 65 6c 65 63 74 2d 63 6f 6d 70 61 72 65 (select-compare
3ed0: 20 28 78 20 79 20 63 6c 61 75 73 65 20 2e 2e 2e (x y clause ...
3ee0: 29 29 0a 20 20 20 20 28 28 73 65 6c 65 63 74 2d )). ((select-
3ef0: 63 6f 6d 70 61 72 65 20 28 78 20 79 29 29 0a 20 compare (x y)).
3f00: 20 20 20 20 30 29 0a 20 20 20 20 28 28 73 65 6c 0). ((sel
3f10: 65 63 74 2d 63 6f 6d 70 61 72 65 20 28 78 20 79 ect-compare (x y
3f20: 20 28 65 6c 73 65 20 63 20 2e 2e 2e 29 29 29 0a (else c ...))).
3f30: 20 20 20 20 20 28 72 65 66 69 6e 65 2d 63 6f 6d (refine-com
3f40: 70 61 72 65 20 63 20 2e 2e 2e 29 29 0a 20 20 20 pare c ...)).
3f50: 20 28 28 73 65 6c 65 63 74 2d 63 6f 6d 70 61 72 ((select-compar
3f60: 65 20 28 78 20 79 20 28 74 3f 20 63 20 2e 2e 2e e (x y (t? c ...
3f70: 29 20 63 6c 61 75 73 65 20 2e 2e 2e 29 29 0a 20 ) clause ...)).
3f80: 20 20 20 20 28 6c 65 74 20 28 28 74 3f 2d 76 61 (let ((t?-va
3f90: 6c 20 74 3f 29 29 0a 20 20 20 20 20 20 20 28 6c l t?)). (l
3fa0: 65 74 20 28 28 74 78 20 28 74 3f 2d 76 61 6c 20 et ((tx (t?-val
3fb0: 78 29 29 20 28 74 79 20 28 74 3f 2d 76 61 6c 20 x)) (ty (t?-val
3fc0: 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 y))). (i
3fd0: 66 20 74 78 0a 20 20 20 20 20 20 20 20 20 20 20 f tx.
3fe0: 20 20 28 69 66 20 74 79 20 28 72 65 66 69 6e 65 (if ty (refine
3ff0: 2d 63 6f 6d 70 61 72 65 20 63 20 2e 2e 2e 29 20 -compare c ...)
4000: 2d 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 -1).
4010: 20 28 69 66 20 74 79 20 31 20 28 73 65 6c 65 63 (if ty 1 (selec
4020: 74 2d 63 6f 6d 70 61 72 65 20 28 78 20 79 20 63 t-compare (x y c
4030: 6c 61 75 73 65 20 2e 2e 2e 29 29 29 29 29 29 29 lause ...)))))))
4040: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ))..(define-synt
4050: 61 78 20 63 6f 6e 64 2d 63 6f 6d 70 61 72 65 0a ax cond-compare.
4060: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
4070: 28 65 6c 73 65 29 0a 20 20 20 20 28 28 63 6f 6e (else). ((con
4080: 64 2d 63 6f 6d 70 61 72 65 29 0a 20 20 20 20 20 d-compare).
4090: 30 29 0a 20 20 20 20 28 28 63 6f 6e 64 2d 63 6f 0). ((cond-co
40a0: 6d 70 61 72 65 20 28 65 6c 73 65 20 63 73 20 2e mpare (else cs .
40b0: 2e 2e 29 29 0a 20 20 20 20 20 28 72 65 66 69 6e ..)). (refin
40c0: 65 2d 63 6f 6d 70 61 72 65 20 63 73 20 2e 2e 2e e-compare cs ...
40d0: 29 29 0a 20 20 20 20 28 28 63 6f 6e 64 2d 63 6f )). ((cond-co
40e0: 6d 70 61 72 65 20 28 28 74 78 20 74 79 29 20 63 mpare ((tx ty) c
40f0: 73 20 2e 2e 2e 29 20 63 6c 61 75 73 65 20 2e 2e s ...) clause ..
4100: 2e 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 74 .). (let ((t
4110: 78 2d 76 61 6c 20 74 78 29 20 28 74 79 2d 76 61 x-val tx) (ty-va
4120: 6c 20 74 79 29 29 0a 20 20 20 20 20 20 20 28 69 l ty)). (i
4130: 66 20 74 78 2d 76 61 6c 0a 20 20 20 20 20 20 20 f tx-val.
4140: 20 20 20 20 28 69 66 20 74 79 2d 76 61 6c 20 28 (if ty-val (
4150: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 63 refine-compare c
4160: 73 20 2e 2e 2e 29 20 2d 31 29 0a 20 20 20 20 20 s ...) -1).
4170: 20 20 20 20 20 20 28 69 66 20 74 79 2d 76 61 6c (if ty-val
4180: 20 31 20 28 63 6f 6e 64 2d 63 6f 6d 70 61 72 65 1 (cond-compare
4190: 20 63 6c 61 75 73 65 20 2e 2e 2e 29 29 29 29 29 clause ...)))))
41a0: 29 29 0a 0a 0a 3b 20 52 35 52 53 20 61 74 6f 6d ))...; R5RS atom
41b0: 69 63 20 74 79 70 65 73 0a 0a 28 64 65 66 69 6e ic types..(defin
41c0: 65 2d 73 79 6e 74 61 78 20 63 6f 6d 70 61 72 65 e-syntax compare
41d0: 3a 74 79 70 65 2d 63 68 65 63 6b 0a 20 20 28 73 :type-check. (s
41e0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
41f0: 20 20 20 28 28 63 6f 6d 70 61 72 65 3a 74 79 70 ((compare:typ
4200: 65 2d 63 68 65 63 6b 20 74 79 70 65 3f 20 74 79 e-check type? ty
4210: 70 65 2d 6e 61 6d 65 20 78 29 0a 20 20 20 20 20 pe-name x).
4220: 28 69 66 20 28 6e 6f 74 20 28 74 79 70 65 3f 20 (if (not (type?
4230: 78 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 72 x)). (er
4240: 72 6f 72 20 28 73 74 72 69 6e 67 2d 61 70 70 65 ror (string-appe
4250: 6e 64 20 22 6e 6f 74 20 22 20 74 79 70 65 2d 6e nd "not " type-n
4260: 61 6d 65 20 22 3a 22 29 20 78 29 29 29 0a 20 20 ame ":") x))).
4270: 20 20 28 28 63 6f 6d 70 61 72 65 3a 74 79 70 65 ((compare:type
4280: 2d 63 68 65 63 6b 20 74 79 70 65 3f 20 74 79 70 -check type? typ
4290: 65 2d 6e 61 6d 65 20 78 20 79 29 0a 20 20 20 20 e-name x y).
42a0: 20 28 62 65 67 69 6e 20 28 63 6f 6d 70 61 72 65 (begin (compare
42b0: 3a 74 79 70 65 2d 63 68 65 63 6b 20 74 79 70 65 :type-check type
42c0: 3f 20 74 79 70 65 2d 6e 61 6d 65 20 78 29 0a 20 ? type-name x).
42d0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 (comp
42e0: 61 72 65 3a 74 79 70 65 2d 63 68 65 63 6b 20 74 are:type-check t
42f0: 79 70 65 3f 20 74 79 70 65 2d 6e 61 6d 65 20 79 ype? type-name y
4300: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 )))))..(define-s
4310: 79 6e 74 61 78 20 63 6f 6d 70 61 72 65 3a 64 65 yntax compare:de
4320: 66 69 6e 65 2d 62 79 3d 2f 3c 0a 20 20 28 73 79 fine-by=/<. (sy
4330: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 ntax-rules ().
4340: 20 20 28 28 63 6f 6d 70 61 72 65 3a 64 65 66 69 ((compare:defi
4350: 6e 65 2d 62 79 3d 2f 3c 20 63 6f 6d 70 61 72 65 ne-by=/< compare
4360: 20 3d 20 3c 20 74 79 70 65 3f 20 74 79 70 65 2d = < type? type-
4370: 6e 61 6d 65 29 0a 20 20 20 20 20 28 64 65 66 69 name). (defi
4380: 6e 65 20 63 6f 6d 70 61 72 65 0a 20 20 20 20 20 ne compare.
4390: 20 20 28 6c 65 74 20 28 28 3d 20 3d 29 20 28 3c (let ((= =) (<
43a0: 20 3c 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c <)). (l
43b0: 61 6d 62 64 61 20 28 78 20 79 29 0a 20 20 20 20 ambda (x y).
43c0: 20 20 20 20 20 20 20 28 69 66 20 28 74 79 70 65 (if (type
43d0: 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 ? x).
43e0: 20 20 20 20 28 69 66 20 28 65 71 3f 20 78 20 79 (if (eq? x y
43f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4400: 20 20 20 20 20 30 0a 20 20 20 20 20 20 20 20 20 0.
4410: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 74 (if (t
4420: 79 70 65 3f 20 79 29 0a 20 20 20 20 20 20 20 20 ype? y).
4430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4440: 69 66 20 28 3d 20 78 20 79 29 20 30 20 28 69 66 if (= x y) 0 (if
4450: 20 28 3c 20 78 20 79 29 20 2d 31 20 31 29 29 0a (< x y) -1 1)).
4460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4470: 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 28 73 (error (s
4480: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 6e 6f tring-append "no
4490: 74 20 22 20 74 79 70 65 2d 6e 61 6d 65 20 22 3a t " type-name ":
44a0: 22 29 20 79 29 29 29 0a 20 20 20 20 20 20 20 20 ") y))).
44b0: 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 28 73 (error (s
44c0: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 6e 6f tring-append "no
44d0: 74 20 22 20 74 79 70 65 2d 6e 61 6d 65 20 22 3a t " type-name ":
44e0: 22 29 20 78 29 29 29 29 29 29 29 29 0a 0a 28 64 ") x))))))))..(d
44f0: 65 66 69 6e 65 20 28 62 6f 6f 6c 65 61 6e 2d 63 efine (boolean-c
4500: 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 20 28 63 ompare x y). (c
4510: 6f 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 65 63 ompare:type-chec
4520: 6b 20 62 6f 6f 6c 65 61 6e 3f 20 22 62 6f 6f 6c k boolean? "bool
4530: 65 61 6e 22 20 78 20 79 29 0a 20 20 28 69 66 20 ean" x y). (if
4540: 78 20 28 69 66 20 79 20 30 20 31 29 20 28 69 66 x (if y 0 1) (if
4550: 20 79 20 2d 31 20 30 29 29 29 0a 0a 28 63 6f 6d y -1 0)))..(com
4560: 70 61 72 65 3a 64 65 66 69 6e 65 2d 62 79 3d 2f pare:define-by=/
4570: 3c 20 63 68 61 72 2d 63 6f 6d 70 61 72 65 20 63 < char-compare c
4580: 68 61 72 3d 3f 20 63 68 61 72 3c 3f 20 63 68 61 har=? char<? cha
4590: 72 3f 20 22 63 68 61 72 22 29 0a 0a 28 63 6f 6d r? "char")..(com
45a0: 70 61 72 65 3a 64 65 66 69 6e 65 2d 62 79 3d 2f pare:define-by=/
45b0: 3c 20 63 68 61 72 2d 63 6f 6d 70 61 72 65 2d 63 < char-compare-c
45c0: 69 20 63 68 61 72 2d 63 69 3d 3f 20 63 68 61 72 i char-ci=? char
45d0: 2d 63 69 3c 3f 20 63 68 61 72 3f 20 22 63 68 61 -ci<? char? "cha
45e0: 72 22 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 65 r")..(compare:de
45f0: 66 69 6e 65 2d 62 79 3d 2f 3c 20 73 74 72 69 6e fine-by=/< strin
4600: 67 2d 63 6f 6d 70 61 72 65 20 73 74 72 69 6e 67 g-compare string
4610: 3d 3f 20 73 74 72 69 6e 67 3c 3f 20 73 74 72 69 =? string<? stri
4620: 6e 67 3f 20 22 73 74 72 69 6e 67 22 29 0a 0a 28 ng? "string")..(
4630: 63 6f 6d 70 61 72 65 3a 64 65 66 69 6e 65 2d 62 compare:define-b
4640: 79 3d 2f 3c 20 73 74 72 69 6e 67 2d 63 6f 6d 70 y=/< string-comp
4650: 61 72 65 2d 63 69 20 73 74 72 69 6e 67 2d 63 69 are-ci string-ci
4660: 3d 3f 20 73 74 72 69 6e 67 2d 63 69 3c 3f 20 73 =? string-ci<? s
4670: 74 72 69 6e 67 3f 20 22 73 74 72 69 6e 67 22 29 tring? "string")
4680: 0a 0a 28 64 65 66 69 6e 65 20 28 73 79 6d 62 6f ..(define (symbo
4690: 6c 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 0a 20 l-compare x y).
46a0: 20 28 63 6f 6d 70 61 72 65 3a 74 79 70 65 2d 63 (compare:type-c
46b0: 68 65 63 6b 20 73 79 6d 62 6f 6c 3f 20 22 73 79 heck symbol? "sy
46c0: 6d 62 6f 6c 22 20 78 20 79 29 0a 20 20 28 73 74 mbol" x y). (st
46d0: 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 28 73 79 ring-compare (sy
46e0: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 78 29 20 mbol->string x)
46f0: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
4700: 79 29 29 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 y)))..(compare:d
4710: 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 69 6e 74 65 efine-by=/< inte
4720: 67 65 72 2d 63 6f 6d 70 61 72 65 20 3d 20 3c 20 ger-compare = <
4730: 69 6e 74 65 67 65 72 3f 20 22 69 6e 74 65 67 65 integer? "intege
4740: 72 22 29 0a 0a 28 63 6f 6d 70 61 72 65 3a 64 65 r")..(compare:de
4750: 66 69 6e 65 2d 62 79 3d 2f 3c 20 72 61 74 69 6f fine-by=/< ratio
4760: 6e 61 6c 2d 63 6f 6d 70 61 72 65 20 3d 20 3c 20 nal-compare = <
4770: 72 61 74 69 6f 6e 61 6c 3f 20 22 72 61 74 69 6f rational? "ratio
4780: 6e 61 6c 22 29 0a 0a 28 63 6f 6d 70 61 72 65 3a nal")..(compare:
4790: 64 65 66 69 6e 65 2d 62 79 3d 2f 3c 20 72 65 61 define-by=/< rea
47a0: 6c 2d 63 6f 6d 70 61 72 65 20 3d 20 3c 20 72 65 l-compare = < re
47b0: 61 6c 3f 20 22 72 65 61 6c 22 29 0a 0a 28 64 65 al? "real")..(de
47c0: 66 69 6e 65 20 28 63 6f 6d 70 6c 65 78 2d 63 6f fine (complex-co
47d0: 6d 70 61 72 65 20 78 20 79 29 0a 20 20 28 63 6f mpare x y). (co
47e0: 6d 70 61 72 65 3a 74 79 70 65 2d 63 68 65 63 6b mpare:type-check
47f0: 20 63 6f 6d 70 6c 65 78 3f 20 22 63 6f 6d 70 6c complex? "compl
4800: 65 78 22 20 78 20 79 29 0a 20 20 28 69 66 20 28 ex" x y). (if (
4810: 61 6e 64 20 28 72 65 61 6c 3f 20 78 29 20 28 72 and (real? x) (r
4820: 65 61 6c 3f 20 79 29 29 0a 20 20 20 20 20 20 28 eal? y)). (
4830: 72 65 61 6c 2d 63 6f 6d 70 61 72 65 20 78 20 79 real-compare x y
4840: 29 0a 20 20 20 20 20 20 28 72 65 66 69 6e 65 2d ). (refine-
4850: 63 6f 6d 70 61 72 65 20 28 72 65 61 6c 2d 63 6f compare (real-co
4860: 6d 70 61 72 65 20 28 72 65 61 6c 2d 70 61 72 74 mpare (real-part
4870: 20 78 29 20 28 72 65 61 6c 2d 70 61 72 74 20 79 x) (real-part y
4880: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
4890: 20 20 20 20 20 20 20 20 20 28 72 65 61 6c 2d 63 (real-c
48a0: 6f 6d 70 61 72 65 20 28 69 6d 61 67 2d 70 61 72 ompare (imag-par
48b0: 74 20 78 29 20 28 69 6d 61 67 2d 70 61 72 74 20 t x) (imag-part
48c0: 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y)))))..(define
48d0: 28 6e 75 6d 62 65 72 2d 63 6f 6d 70 61 72 65 20 (number-compare
48e0: 78 20 79 29 0a 20 20 28 63 6f 6d 70 61 72 65 3a x y). (compare:
48f0: 74 79 70 65 2d 63 68 65 63 6b 20 6e 75 6d 62 65 type-check numbe
4900: 72 3f 20 22 6e 75 6d 62 65 72 22 20 78 20 79 29 r? "number" x y)
4910: 0a 20 20 28 63 6f 6d 70 6c 65 78 2d 63 6f 6d 70 . (complex-comp
4920: 61 72 65 20 78 20 79 29 29 0a 0a 0a 3b 20 52 35 are x y))...; R5
4930: 52 53 20 63 6f 6d 70 6f 75 6e 64 20 64 61 74 61 RS compound data
4940: 20 73 74 72 75 63 74 75 72 65 73 3a 20 64 6f 74 structures: dot
4950: 74 65 64 20 70 61 69 72 2c 20 6c 69 73 74 2c 20 ted pair, list,
4960: 76 65 63 74 6f 72 0a 0a 28 64 65 66 69 6e 65 20 vector..(define
4970: 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 61 (pair-compare-ca
4980: 72 20 63 6f 6d 70 61 72 65 29 0a 20 20 28 6c 61 r compare). (la
4990: 6d 62 64 61 20 28 78 20 79 29 0a 20 20 20 20 28 mbda (x y). (
49a0: 63 6f 6d 70 61 72 65 20 28 63 61 72 20 78 29 20 compare (car x)
49b0: 28 63 61 72 20 79 29 29 29 29 0a 0a 28 64 65 66 (car y))))..(def
49c0: 69 6e 65 20 28 70 61 69 72 2d 63 6f 6d 70 61 72 ine (pair-compar
49d0: 65 2d 63 64 72 20 63 6f 6d 70 61 72 65 29 0a 20 e-cdr compare).
49e0: 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 0a 20 (lambda (x y).
49f0: 20 20 20 28 63 6f 6d 70 61 72 65 20 28 63 64 72 (compare (cdr
4a00: 20 78 29 20 28 63 64 72 20 79 29 29 29 29 0a 0a x) (cdr y))))..
4a10: 28 64 65 66 69 6e 65 20 70 61 69 72 2d 63 6f 6d (define pair-com
4a20: 70 61 72 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d pare. (case-lam
4a30: 62 64 61 0a 20 20 20 20 0a 20 20 20 20 3b 20 64 bda. . ; d
4a40: 6f 74 74 65 64 20 70 61 69 72 0a 20 20 20 20 28 otted pair. (
4a50: 28 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 61 (pair-compare-ca
4a60: 72 20 70 61 69 72 2d 63 6f 6d 70 61 72 65 2d 63 r pair-compare-c
4a70: 64 72 20 78 20 79 29 0a 20 20 20 20 20 28 72 65 dr x y). (re
4a80: 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 28 70 61 fine-compare (pa
4a90: 69 72 2d 63 6f 6d 70 61 72 65 2d 63 61 72 20 28 ir-compare-car (
4aa0: 63 61 72 20 78 29 20 28 63 61 72 20 79 29 29 0a car x) (car y)).
4ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ac0: 20 20 20 20 20 28 70 61 69 72 2d 63 6f 6d 70 61 (pair-compa
4ad0: 72 65 2d 63 64 72 20 28 63 64 72 20 78 29 20 28 re-cdr (cdr x) (
4ae0: 63 64 72 20 79 29 29 29 29 0a 20 20 20 20 0a 20 cdr y)))). .
4af0: 20 20 20 3b 20 70 6f 73 73 69 62 6c 79 20 69 6d ; possibly im
4b00: 70 72 6f 70 65 72 20 6c 69 73 74 73 0a 20 20 20 proper lists.
4b10: 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 29 0a ((compare x y).
4b20: 20 20 20 20 20 28 63 6f 6e 64 2d 63 6f 6d 70 61 (cond-compa
4b30: 72 65 20 0a 20 20 20 20 20 20 28 28 28 6e 75 6c re . (((nul
4b40: 6c 3f 20 78 29 20 28 6e 75 6c 6c 3f 20 79 29 29 l? x) (null? y))
4b50: 20 30 29 0a 20 20 20 20 20 20 28 28 28 70 61 69 0). (((pai
4b60: 72 3f 20 78 29 20 28 70 61 69 72 3f 20 79 29 29 r? x) (pair? y))
4b70: 20 28 63 6f 6d 70 61 72 65 20 20 20 20 20 20 20 (compare
4b80: 20 20 20 20 20 20 20 28 63 61 72 20 78 29 20 28 (car x) (
4b90: 63 61 72 20 79 29 29 0a 20 20 20 20 20 20 20 20 car y)).
4ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bb0: 20 20 20 20 20 28 70 61 69 72 2d 63 6f 6d 70 61 (pair-compa
4bc0: 72 65 20 63 6f 6d 70 61 72 65 20 28 63 64 72 20 re compare (cdr
4bd0: 78 29 20 28 63 64 72 20 79 29 29 29 0a 20 20 20 x) (cdr y))).
4be0: 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 (else
4bf0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 61 (compa
4c00: 72 65 20 78 20 79 29 29 29 29 0a 20 20 20 20 0a re x y)))). .
4c10: 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 65 6e ; for conven
4c20: 69 65 6e 63 65 0a 20 20 20 20 28 28 78 20 79 29 ience. ((x y)
4c30: 0a 20 20 20 20 20 28 70 61 69 72 2d 63 6f 6d 70 . (pair-comp
4c40: 61 72 65 20 64 65 66 61 75 6c 74 2d 63 6f 6d 70 are default-comp
4c50: 61 72 65 20 78 20 79 29 29 29 29 0a 0a 28 64 65 are x y))))..(de
4c60: 66 69 6e 65 20 6c 69 73 74 2d 63 6f 6d 70 61 72 fine list-compar
4c70: 65 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 e. (case-lambda
4c80: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 . ((compare x
4c90: 20 79 20 65 6d 70 74 79 3f 20 68 65 61 64 20 74 y empty? head t
4ca0: 61 69 6c 29 0a 20 20 20 20 20 28 63 6f 6e 64 2d ail). (cond-
4cb0: 63 6f 6d 70 61 72 65 0a 20 20 20 20 20 20 28 28 compare. ((
4cc0: 28 65 6d 70 74 79 3f 20 78 29 20 28 65 6d 70 74 (empty? x) (empt
4cd0: 79 3f 20 79 29 29 20 30 29 0a 20 20 20 20 20 20 y? y)) 0).
4ce0: 28 65 6c 73 65 20 28 63 6f 6d 70 61 72 65 20 20 (else (compare
4cf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 65 61 (hea
4d00: 64 20 78 29 20 28 68 65 61 64 20 79 29 29 0a 20 d x) (head y)).
4d10: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
4d20: 2d 63 6f 6d 70 61 72 65 20 63 6f 6d 70 61 72 65 -compare compare
4d30: 20 28 74 61 69 6c 20 78 29 20 28 74 61 69 6c 20 (tail x) (tail
4d40: 79 29 20 65 6d 70 74 79 3f 20 68 65 61 64 20 74 y) empty? head t
4d50: 61 69 6c 29 29 29 29 0a 20 20 20 20 0a 20 20 20 ail)))). .
4d60: 20 3b 20 66 6f 72 20 63 6f 6e 76 65 6e 69 65 6e ; for convenien
4d70: 63 65 0a 20 20 20 20 28 28 20 20 20 20 20 20 20 ce. ((
4d80: 20 78 20 79 20 65 6d 70 74 79 3f 20 68 65 61 64 x y empty? head
4d90: 20 74 61 69 6c 29 0a 20 20 20 20 20 28 6c 69 73 tail). (lis
4da0: 74 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 75 6c t-compare defaul
4db0: 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 65 6d t-compare x y em
4dc0: 70 74 79 3f 20 68 65 61 64 20 74 61 69 6c 29 29 pty? head tail))
4dd0: 0a 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 78 . ((compare x
4de0: 20 79 20 20 20 20 20 20 20 20 20 20 20 20 20 20 y
4df0: 29 0a 20 20 20 20 20 28 6c 69 73 74 2d 63 6f 6d ). (list-com
4e00: 70 61 72 65 20 63 6f 6d 70 61 72 65 20 20 20 20 pare compare
4e10: 20 20 20 20 20 78 20 79 20 6e 75 6c 6c 3f 20 63 x y null? c
4e20: 61 72 20 20 20 63 64 72 29 29 0a 20 20 20 20 28 ar cdr)). (
4e30: 28 20 20 20 20 20 20 20 20 78 20 79 20 20 20 20 ( x y
4e40: 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 ).
4e50: 20 28 6c 69 73 74 2d 63 6f 6d 70 61 72 65 20 64 (list-compare d
4e60: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 efault-compare x
4e70: 20 79 20 6e 75 6c 6c 3f 20 63 61 72 20 20 20 63 y null? car c
4e80: 64 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 dr))))..(define
4e90: 6c 69 73 74 2d 63 6f 6d 70 61 72 65 2d 61 73 2d list-compare-as-
4ea0: 76 65 63 74 6f 72 0a 20 20 28 63 61 73 65 2d 6c vector. (case-l
4eb0: 61 6d 62 64 61 0a 20 20 20 20 28 28 63 6f 6d 70 ambda. ((comp
4ec0: 61 72 65 20 78 20 79 20 65 6d 70 74 79 3f 20 68 are x y empty? h
4ed0: 65 61 64 20 74 61 69 6c 29 0a 20 20 20 20 20 28 ead tail). (
4ee0: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 0a 20 refine-compare.
4ef0: 20 20 20 20 20 28 6c 65 74 20 63 6f 6d 70 61 72 (let compar
4f00: 65 2d 6c 65 6e 67 74 68 20 28 28 78 20 78 29 20 e-length ((x x)
4f10: 28 79 20 79 29 29 0a 20 20 20 20 20 20 20 20 28 (y y)). (
4f20: 63 6f 6e 64 2d 63 6f 6d 70 61 72 65 0a 20 20 20 cond-compare.
4f30: 20 20 20 20 20 20 28 28 28 65 6d 70 74 79 3f 20 (((empty?
4f40: 78 29 20 28 65 6d 70 74 79 3f 20 79 29 29 20 30 x) (empty? y)) 0
4f50: 29 0a 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 ). (else
4f60: 20 28 63 6f 6d 70 61 72 65 2d 6c 65 6e 67 74 68 (compare-length
4f70: 20 28 74 61 69 6c 20 78 29 20 28 74 61 69 6c 20 (tail x) (tail
4f80: 79 29 29 29 29 29 0a 20 20 20 20 20 20 28 6c 69 y))))). (li
4f90: 73 74 2d 63 6f 6d 70 61 72 65 20 63 6f 6d 70 61 st-compare compa
4fa0: 72 65 20 78 20 79 20 65 6d 70 74 79 3f 20 68 65 re x y empty? he
4fb0: 61 64 20 74 61 69 6c 29 29 29 0a 20 20 20 20 0a ad tail))). .
4fc0: 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 65 6e ; for conven
4fd0: 69 65 6e 63 65 0a 20 20 20 20 28 28 20 20 20 20 ience. ((
4fe0: 20 20 20 20 78 20 79 20 65 6d 70 74 79 3f 20 68 x y empty? h
4ff0: 65 61 64 20 74 61 69 6c 29 0a 20 20 20 20 20 28 ead tail). (
5000: 6c 69 73 74 2d 63 6f 6d 70 61 72 65 2d 61 73 2d list-compare-as-
5010: 76 65 63 74 6f 72 20 64 65 66 61 75 6c 74 2d 63 vector default-c
5020: 6f 6d 70 61 72 65 20 78 20 79 20 65 6d 70 74 79 ompare x y empty
5030: 3f 20 68 65 61 64 20 74 61 69 6c 29 29 0a 20 20 ? head tail)).
5040: 20 20 28 28 63 6f 6d 70 61 72 65 20 78 20 79 20 ((compare x y
5050: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 ).
5060: 20 20 20 20 28 6c 69 73 74 2d 63 6f 6d 70 61 72 (list-compar
5070: 65 2d 61 73 2d 76 65 63 74 6f 72 20 63 6f 6d 70 e-as-vector comp
5080: 61 72 65 20 20 20 20 20 20 20 20 20 78 20 79 20 are x y
5090: 6e 75 6c 6c 3f 20 20 63 61 72 20 20 63 64 72 29 null? car cdr)
50a0: 29 0a 20 20 20 20 28 28 20 20 20 20 20 20 20 20 ). ((
50b0: 78 20 79 20 20 20 20 20 20 20 20 20 20 20 20 20 x y
50c0: 20 29 0a 20 20 20 20 20 28 6c 69 73 74 2d 63 6f ). (list-co
50d0: 6d 70 61 72 65 2d 61 73 2d 76 65 63 74 6f 72 20 mpare-as-vector
50e0: 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 default-compare
50f0: 78 20 79 20 6e 75 6c 6c 3f 20 20 63 61 72 20 20 x y null? car
5100: 63 64 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 cdr))))..(define
5110: 20 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 65 0a vector-compare.
5120: 20 20 28 6c 65 74 20 28 28 3d 20 3d 29 29 0a 20 (let ((= =)).
5130: 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a (case-lambda.
5140: 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ((compare
5150: 78 20 79 20 73 69 7a 65 20 72 65 66 29 0a 20 20 x y size ref).
5160: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 20 28 73 (let ((n (s
5170: 69 7a 65 20 78 29 29 20 28 6d 20 28 73 69 7a 65 ize x)) (m (size
5180: 20 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 y))). (
5190: 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 0a refine-compare .
51a0: 20 20 20 20 20 20 20 20 20 20 28 69 6e 74 65 67 (integ
51b0: 65 72 2d 63 6f 6d 70 61 72 65 20 6e 20 6d 29 0a er-compare n m).
51c0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 63 (let c
51d0: 6f 6d 70 61 72 65 2d 72 65 73 74 20 28 28 69 20 ompare-rest ((i
51e0: 30 29 29 20 3b 20 63 6f 6d 70 61 72 65 20 78 5b 0)) ; compare x[
51f0: 69 2e 2e 6e 2d 31 5d 20 79 5b 69 2e 2e 6e 2d 31 i..n-1] y[i..n-1
5200: 5d 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ]. (i
5210: 66 20 28 3d 20 69 20 6e 29 0a 20 20 20 20 20 20 f (= i n).
5220: 20 20 20 20 20 20 20 20 20 20 30 0a 20 20 20 20 0.
5230: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 66 (ref
5240: 69 6e 65 2d 63 6f 6d 70 61 72 65 20 28 63 6f 6d ine-compare (com
5250: 70 61 72 65 20 28 72 65 66 20 78 20 69 29 20 28 pare (ref x i) (
5260: 72 65 66 20 79 20 69 29 29 0a 20 20 20 20 20 20 ref y i)).
5270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5280: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 70 61 (compa
5290: 72 65 2d 72 65 73 74 20 28 2b 20 69 20 31 29 29 re-rest (+ i 1))
52a0: 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 )))))). .
52b0: 20 20 20 20 3b 20 66 6f 72 20 63 6f 6e 76 65 6e ; for conven
52c0: 69 65 6e 63 65 0a 20 20 20 20 20 20 28 28 20 20 ience. ((
52d0: 20 20 20 20 20 20 78 20 79 20 73 69 7a 65 20 72 x y size r
52e0: 65 66 29 0a 20 20 20 20 20 20 20 28 76 65 63 74 ef). (vect
52f0: 6f 72 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 75 or-compare defau
5300: 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 20 73 lt-compare x y s
5310: 69 7a 65 20 20 20 20 20 20 20 20 20 20 72 65 66 ize ref
5320: 29 29 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 )). ((compa
5330: 72 65 20 78 20 79 20 20 20 20 20 20 20 20 20 20 re x y
5340: 20 29 0a 20 20 20 20 20 20 20 28 76 65 63 74 6f ). (vecto
5350: 72 2d 63 6f 6d 70 61 72 65 20 63 6f 6d 70 61 72 r-compare compar
5360: 65 20 20 20 20 20 20 20 20 20 78 20 79 20 76 65 e x y ve
5370: 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 63 74 ctor-length vect
5380: 6f 72 2d 72 65 66 29 29 0a 20 20 20 20 20 20 28 or-ref)). (
5390: 28 20 20 20 20 20 20 20 20 78 20 79 20 20 20 20 ( x y
53a0: 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
53b0: 28 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 65 20 (vector-compare
53c0: 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 default-compare
53d0: 78 20 79 20 76 65 63 74 6f 72 2d 6c 65 6e 67 74 x y vector-lengt
53e0: 68 20 76 65 63 74 6f 72 2d 72 65 66 29 29 29 29 h vector-ref))))
53f0: 29 0a 0a 28 64 65 66 69 6e 65 20 76 65 63 74 6f )..(define vecto
5400: 72 2d 63 6f 6d 70 61 72 65 2d 61 73 2d 6c 69 73 r-compare-as-lis
5410: 74 0a 20 20 28 6c 65 74 20 28 28 3d 20 3d 29 29 t. (let ((= =))
5420: 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 . (case-lambd
5430: 61 0a 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 a. ((compar
5440: 65 20 78 20 79 20 73 69 7a 65 20 72 65 66 29 0a e x y size ref).
5450: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 78 (let ((nx
5460: 20 28 73 69 7a 65 20 78 29 29 20 28 6e 79 20 28 (size x)) (ny (
5470: 73 69 7a 65 20 79 29 29 29 0a 20 20 20 20 20 20 size y))).
5480: 20 20 20 28 6c 65 74 20 28 28 6e 20 28 6d 69 6e (let ((n (min
5490: 20 6e 78 20 6e 79 29 29 29 0a 20 20 20 20 20 20 nx ny))).
54a0: 20 20 20 20 20 28 6c 65 74 20 63 6f 6d 70 61 72 (let compar
54b0: 65 2d 72 65 73 74 20 28 28 69 20 30 29 29 20 3b e-rest ((i 0)) ;
54c0: 20 63 6f 6d 70 61 72 65 20 78 5b 69 2e 2e 6e 2d compare x[i..n-
54d0: 31 5d 20 79 5b 69 2e 2e 6e 2d 31 5d 0a 20 20 20 1] y[i..n-1].
54e0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3d (if (=
54f0: 20 69 20 6e 29 0a 20 20 20 20 20 20 20 20 20 20 i n).
5500: 20 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d (integer-
5510: 63 6f 6d 70 61 72 65 20 6e 78 20 6e 79 29 0a 20 compare nx ny).
5520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5530: 28 72 65 66 69 6e 65 2d 63 6f 6d 70 61 72 65 20 (refine-compare
5540: 28 63 6f 6d 70 61 72 65 20 28 72 65 66 20 78 20 (compare (ref x
5550: 69 29 20 28 72 65 66 20 79 20 69 29 29 0a 20 20 i) (ref y i)).
5560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5580: 63 6f 6d 70 61 72 65 2d 72 65 73 74 20 28 2b 20 compare-rest (+
5590: 69 20 31 29 29 29 29 29 29 29 29 0a 20 20 20 20 i 1)))))))).
55a0: 20 20 0a 20 20 20 20 20 20 3b 20 66 6f 72 20 63 . ; for c
55b0: 6f 6e 76 65 6e 69 65 6e 63 65 0a 20 20 20 20 20 onvenience.
55c0: 20 28 28 20 20 20 20 20 20 20 20 78 20 79 20 73 (( x y s
55d0: 69 7a 65 20 72 65 66 29 0a 20 20 20 20 20 20 20 ize ref).
55e0: 28 76 65 63 74 6f 72 2d 63 6f 6d 70 61 72 65 2d (vector-compare-
55f0: 61 73 2d 6c 69 73 74 20 64 65 66 61 75 6c 74 2d as-list default-
5600: 63 6f 6d 70 61 72 65 20 78 20 79 20 73 69 7a 65 compare x y size
5610: 20 20 20 20 20 20 20 20 20 20 72 65 66 29 29 0a ref)).
5620: 20 20 20 20 20 20 28 28 63 6f 6d 70 61 72 65 20 ((compare
5630: 78 20 79 20 20 20 20 20 20 20 20 20 20 20 29 0a x y ).
5640: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 63 (vector-c
5650: 6f 6d 70 61 72 65 2d 61 73 2d 6c 69 73 74 20 63 ompare-as-list c
5660: 6f 6d 70 61 72 65 20 20 20 20 20 20 20 20 20 78 ompare x
5670: 20 79 20 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 y vector-length
5680: 20 76 65 63 74 6f 72 2d 72 65 66 29 29 0a 20 20 vector-ref)).
5690: 20 20 20 20 28 28 20 20 20 20 20 20 20 20 78 20 (( x
56a0: 79 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 y ).
56b0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 63 6f 6d (vector-com
56c0: 70 61 72 65 2d 61 73 2d 6c 69 73 74 20 64 65 66 pare-as-list def
56d0: 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 ault-compare x y
56e0: 20 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 vector-length v
56f0: 65 63 74 6f 72 2d 72 65 66 29 29 29 29 29 0a 0a ector-ref)))))..
5700: 0a 3b 20 64 65 66 61 75 6c 74 20 63 6f 6d 70 61 .; default compa
5710: 72 65 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 66 re..(define (def
5720: 61 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 ault-compare x y
5730: 29 0a 20 20 28 73 65 6c 65 63 74 2d 63 6f 6d 70 ). (select-comp
5740: 61 72 65 20 0a 20 20 20 78 20 79 0a 20 20 20 28 are . x y. (
5750: 6e 75 6c 6c 3f 20 20 20 20 30 29 0a 20 20 20 28 null? 0). (
5760: 70 61 69 72 3f 20 20 20 20 28 64 65 66 61 75 6c pair? (defaul
5770: 74 2d 63 6f 6d 70 61 72 65 20 28 63 61 72 20 78 t-compare (car x
5780: 29 20 28 63 61 72 20 79 29 29 0a 20 20 20 20 20 ) (car y)).
5790: 20 20 20 20 20 20 20 20 28 64 65 66 61 75 6c 74 (default
57a0: 2d 63 6f 6d 70 61 72 65 20 28 63 64 72 20 78 29 -compare (cdr x)
57b0: 20 28 63 64 72 20 79 29 29 29 0a 20 20 20 28 62 (cdr y))). (b
57c0: 6f 6f 6c 65 61 6e 3f 20 28 62 6f 6f 6c 65 61 6e oolean? (boolean
57d0: 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 29 0a 20 -compare x y)).
57e0: 20 20 28 63 68 61 72 3f 20 20 20 20 28 63 68 61 (char? (cha
57f0: 72 2d 63 6f 6d 70 61 72 65 20 20 20 20 78 20 79 r-compare x y
5800: 29 29 0a 20 20 20 28 73 74 72 69 6e 67 3f 20 20 )). (string?
5810: 28 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 (string-compare
5820: 20 78 20 79 29 29 0a 20 20 20 28 73 79 6d 62 6f x y)). (symbo
5830: 6c 3f 20 20 28 73 79 6d 62 6f 6c 2d 63 6f 6d 70 l? (symbol-comp
5840: 61 72 65 20 20 78 20 79 29 29 0a 20 20 20 28 6e are x y)). (n
5850: 75 6d 62 65 72 3f 20 20 28 6e 75 6d 62 65 72 2d umber? (number-
5860: 63 6f 6d 70 61 72 65 20 20 78 20 79 29 29 0a 20 compare x y)).
5870: 20 20 28 76 65 63 74 6f 72 3f 20 20 28 76 65 63 (vector? (vec
5880: 74 6f 72 2d 63 6f 6d 70 61 72 65 20 64 65 66 61 tor-compare defa
5890: 75 6c 74 2d 63 6f 6d 70 61 72 65 20 78 20 79 29 ult-compare x y)
58a0: 29 0a 20 20 20 28 65 6c 73 65 20 28 65 72 72 6f ). (else (erro
58b0: 72 20 22 75 6e 72 65 63 6f 67 6e 69 7a 65 64 20 r "unrecognized
58c0: 74 79 70 65 20 69 6e 20 64 65 66 61 75 6c 74 2d type in default-
58d0: 63 6f 6d 70 61 72 65 22 20 78 20 79 29 29 29 29 compare" x y))))
58e0: 0a 0a 3b 20 4e 6f 74 65 20 74 68 61 74 20 77 65 ..; Note that we
58f0: 20 70 61 73 73 20 64 65 66 61 75 6c 74 2d 63 6f pass default-co
5900: 6d 70 61 72 65 20 74 6f 20 63 6f 6d 70 61 72 65 mpare to compare
5910: 2d 7b 70 61 69 72 2c 76 65 63 74 6f 72 7d 20 65 -{pair,vector} e
5920: 78 70 6c 69 63 74 6c 79 2e 0a 3b 20 54 68 69 73 xplictly..; This
5930: 20 6d 61 6b 65 73 20 73 75 72 65 20 72 65 63 75 makes sure recu
5940: 72 73 69 6f 6e 20 70 72 6f 63 65 65 64 73 20 77 rsion proceeds w
5950: 69 74 68 20 74 68 69 73 20 64 65 66 61 75 6c 74 ith this default
5960: 2d 63 6f 6d 70 61 72 65 2c 20 77 68 69 63 68 20 -compare, which
5970: 0a 3b 20 6e 65 65 64 20 6e 6f 74 20 62 65 20 74 .; need not be t
5980: 68 65 20 6f 6e 65 20 69 6e 20 74 68 65 20 6c 65 he one in the le
5990: 78 69 63 61 6c 20 73 63 6f 70 65 20 6f 66 20 63 xical scope of c
59a0: 6f 6d 70 61 72 65 2d 7b 70 61 69 72 2c 76 65 63 ompare-{pair,vec
59b0: 74 6f 72 7d 2e 0a 0a 0a 3b 20 64 65 62 75 67 20 tor}....; debug
59c0: 63 6f 6d 70 61 72 65 0a 0a 28 64 65 66 69 6e 65 compare..(define
59d0: 20 28 64 65 62 75 67 2d 63 6f 6d 70 61 72 65 20 (debug-compare
59e0: 63 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 c). . (define
59f0: 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 20 63 (checked-value c
5a00: 20 78 20 79 29 0a 20 20 20 20 28 6c 65 74 20 28 x y). (let (
5a10: 28 63 2d 78 79 20 28 63 20 78 20 79 29 29 29 0a (c-xy (c x y))).
5a20: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 (if (or (e
5a30: 71 76 3f 20 63 2d 78 79 20 2d 31 29 20 28 65 71 qv? c-xy -1) (eq
5a40: 76 3f 20 63 2d 78 79 20 30 29 20 28 65 71 76 3f v? c-xy 0) (eqv?
5a50: 20 63 2d 78 79 20 31 29 29 0a 20 20 20 20 20 20 c-xy 1)).
5a60: 20 20 20 20 63 2d 78 79 0a 20 20 20 20 20 20 20 c-xy.
5a70: 20 20 20 28 65 72 72 6f 72 20 22 63 6f 6d 70 61 (error "compa
5a80: 72 65 20 76 61 6c 75 65 20 6e 6f 74 20 69 6e 20 re value not in
5a90: 7b 2d 31 2c 30 2c 31 7d 22 20 63 2d 78 79 20 28 {-1,0,1}" c-xy (
5aa0: 6c 69 73 74 20 63 20 78 20 79 29 29 29 29 29 0a list c x y))))).
5ab0: 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 72 61 . (define (ra
5ac0: 6e 64 6f 6d 2d 62 6f 6f 6c 65 61 6e 29 0a 20 20 ndom-boolean).
5ad0: 20 20 28 7a 65 72 6f 3f 20 28 72 61 6e 64 6f 6d (zero? (random
5ae0: 2d 69 6e 74 65 67 65 72 20 32 29 29 29 0a 20 20 -integer 2))).
5af0: 0a 20 20 28 64 65 66 69 6e 65 20 71 20 3b 20 28 . (define q ; (
5b00: 75 20 76 20 77 29 20 73 75 63 68 20 74 68 61 74 u v w) such that
5b10: 20 75 20 3c 3d 20 76 2c 20 76 20 3c 3d 20 77 2c u <= v, v <= w,
5b20: 20 61 6e 64 20 6e 6f 74 20 75 20 3c 3d 20 77 0a and not u <= w.
5b30: 20 20 20 20 27 23 28 0a 20 20 20 20 20 20 20 3b '#(. ;
5b40: 78 20 3c 20 79 20 20 20 78 20 3d 20 79 20 20 20 x < y x = y
5b50: 78 20 3e 20 79 20 20 20 5b 78 20 3c 20 7a 5d 0a x > y [x < z].
5b60: 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 30 0 0
5b70: 20 20 20 20 20 20 20 30 20 20 20 20 3b 20 79 20 0 ; y
5b80: 3c 20 7a 0a 20 20 20 20 20 20 20 20 20 20 20 20 < z.
5b90: 20 20 20 30 20 20 20 20 28 7a 20 79 20 78 29 20 0 (z y x)
5ba0: 28 7a 20 79 20 78 29 20 3b 20 79 20 3d 20 7a 0a (z y x) ; y = z.
5bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 0
5bc0: 20 20 20 20 28 7a 20 79 20 78 29 20 28 7a 20 79 (z y x) (z y
5bd0: 20 78 29 20 3b 20 79 20 3e 20 7a 0a 20 20 20 20 x) ; y > z.
5be0: 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 .
5bf0: 20 20 20 20 20 20 20 20 20 20 20 3b 78 20 3c 20 ;x <
5c00: 79 20 20 20 78 20 3d 20 79 20 20 20 78 20 3e 20 y x = y x >
5c10: 79 20 20 20 5b 78 20 3d 20 7a 5d 0a 20 20 20 20 y [x = z].
5c20: 20 20 20 20 20 20 20 20 20 20 20 28 79 20 7a 20 (y z
5c30: 78 29 20 28 7a 20 78 20 79 29 20 20 20 20 30 20 x) (z x y) 0
5c40: 20 20 20 3b 20 79 20 3c 20 7a 0a 20 20 20 20 20 ; y < z.
5c50: 20 20 20 20 20 20 20 20 20 20 28 79 20 7a 20 78 (y z x
5c60: 29 20 20 20 20 30 20 20 20 20 28 78 20 7a 20 79 ) 0 (x z y
5c70: 29 20 3b 20 79 20 3d 20 7a 0a 20 20 20 20 20 20 ) ; y = z.
5c80: 20 20 20 20 20 20 20 20 20 30 20 20 20 20 28 79 0 (y
5c90: 20 78 20 7a 29 20 28 78 20 7a 20 79 29 20 3b 20 x z) (x z y) ;
5ca0: 79 20 3e 20 7a 0a 20 20 20 20 20 20 20 20 20 20 y > z.
5cb0: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
5cc0: 20 20 20 20 20 3b 78 20 3c 20 79 20 20 20 78 20 ;x < y x
5cd0: 3d 20 79 20 20 20 78 20 3e 20 79 20 20 20 5b 78 = y x > y [x
5ce0: 20 3e 20 7a 5d 0a 20 20 20 20 20 20 20 20 20 20 > z].
5cf0: 20 20 20 20 20 28 78 20 79 20 7a 29 20 28 78 20 (x y z) (x
5d00: 79 20 7a 29 20 20 20 20 30 20 20 20 20 3b 20 79 y z) 0 ; y
5d10: 20 3c 20 7a 0a 20 20 20 20 20 20 20 20 20 20 20 < z.
5d20: 20 20 20 20 28 78 20 79 20 7a 29 20 28 78 20 79 (x y z) (x y
5d30: 20 7a 29 20 20 20 20 30 20 20 20 20 3b 20 79 20 z) 0 ; y
5d40: 3d 20 7a 0a 20 20 20 20 20 20 20 20 20 20 20 20 = z.
5d50: 20 20 20 30 20 20 20 20 20 20 20 30 20 20 20 20 0 0
5d60: 20 20 20 30 20 20 20 20 3b 20 79 20 3e 20 7a 0a 0 ; y > z.
5d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 )
5d80: 29 0a 20 20 0a 20 20 28 6c 65 74 20 28 28 7a 3f ). . (let ((z?
5d90: 20 23 66 29 20 28 7a 20 23 66 29 29 20 3b 20 73 #f) (z #f)) ; s
5da0: 74 6f 72 65 64 20 65 6c 65 6d 65 6e 74 20 66 72 tored element fr
5db0: 6f 6d 20 70 72 65 76 69 6f 75 73 20 63 61 6c 6c om previous call
5dc0: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 . (lambda (x
5dd0: 79 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 y). (let ((
5de0: 63 2d 78 78 20 28 63 68 65 63 6b 65 64 2d 76 61 c-xx (checked-va
5df0: 6c 75 65 20 63 20 78 20 78 29 29 0a 20 20 20 20 lue c x x)).
5e00: 20 20 20 20 20 20 20 20 28 63 2d 79 79 20 28 63 (c-yy (c
5e10: 68 65 63 6b 65 64 2d 76 61 6c 75 65 20 63 20 79 hecked-value c y
5e20: 20 79 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 y)).
5e30: 20 28 63 2d 78 79 20 28 63 68 65 63 6b 65 64 2d (c-xy (checked-
5e40: 76 61 6c 75 65 20 63 20 78 20 79 29 29 0a 20 20 value c x y)).
5e50: 20 20 20 20 20 20 20 20 20 20 28 63 2d 79 78 20 (c-yx
5e60: 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 20 63 (checked-value c
5e70: 20 79 20 78 29 29 29 0a 20 20 20 20 20 20 20 20 y x))).
5e80: 28 69 66 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 (if (not (zero?
5e90: 63 2d 78 78 29 29 0a 20 20 20 20 20 20 20 20 20 c-xx)).
5ea0: 20 20 20 28 65 72 72 6f 72 20 22 63 6f 6d 70 61 (error "compa
5eb0: 72 65 20 65 72 72 6f 72 3a 20 6e 6f 74 20 72 65 re error: not re
5ec0: 66 6c 65 78 69 76 65 22 20 63 20 78 29 29 0a 20 flexive" c x)).
5ed0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
5ee0: 28 7a 65 72 6f 3f 20 63 2d 79 79 29 29 0a 20 20 (zero? c-yy)).
5ef0: 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 (error
5f00: 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f 72 3a "compare error:
5f10: 20 6e 6f 74 20 72 65 66 6c 65 78 69 76 65 22 20 not reflexive"
5f20: 63 20 79 29 29 0a 20 20 20 20 20 20 20 20 28 69 c y)). (i
5f30: 66 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 28 2b f (not (zero? (+
5f40: 20 63 2d 78 79 20 63 2d 79 78 29 29 29 0a 20 20 c-xy c-yx))).
5f50: 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 (error
5f60: 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f 72 3a "compare error:
5f70: 20 6e 6f 74 20 61 6e 74 69 2d 73 79 6d 6d 65 74 not anti-symmet
5f80: 72 69 63 22 20 63 20 78 20 79 29 29 0a 20 20 20 ric" c x y)).
5f90: 20 20 20 20 20 28 69 66 20 7a 3f 0a 20 20 20 20 (if z?.
5fa0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 (let ((c
5fb0: 2d 78 7a 20 28 63 68 65 63 6b 65 64 2d 76 61 6c -xz (checked-val
5fc0: 75 65 20 63 20 78 20 7a 29 29 0a 20 20 20 20 20 ue c x z)).
5fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 2d (c-
5fe0: 7a 78 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 zx (checked-valu
5ff0: 65 20 63 20 7a 20 78 29 29 0a 20 20 20 20 20 20 e c z x)).
6000: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 2d 79 (c-y
6010: 7a 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 z (checked-value
6020: 20 63 20 79 20 7a 29 29 0a 20 20 20 20 20 20 20 c y z)).
6030: 20 20 20 20 20 20 20 20 20 20 20 28 63 2d 7a 79 (c-zy
6040: 20 28 63 68 65 63 6b 65 64 2d 76 61 6c 75 65 20 (checked-value
6050: 63 20 7a 20 79 29 29 29 0a 20 20 20 20 20 20 20 c z y))).
6060: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
6070: 28 7a 65 72 6f 3f 20 28 2b 20 63 2d 78 7a 20 63 (zero? (+ c-xz c
6080: 2d 7a 78 29 29 29 0a 20 20 20 20 20 20 20 20 20 -zx))).
6090: 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 (error
60a0: 22 63 6f 6d 70 61 72 65 20 65 72 72 6f 72 3a 20 "compare error:
60b0: 6e 6f 74 20 61 6e 74 69 2d 73 79 6d 6d 65 74 72 not anti-symmetr
60c0: 69 63 22 20 63 20 78 20 7a 29 29 0a 20 20 20 20 ic" c x z)).
60d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
60e0: 6f 74 20 28 7a 65 72 6f 3f 20 28 2b 20 63 2d 79 ot (zero? (+ c-y
60f0: 7a 20 63 2d 7a 79 29 29 29 0a 20 20 20 20 20 20 z c-zy))).
6100: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
6110: 6f 72 20 22 63 6f 6d 70 61 72 65 20 65 72 72 6f or "compare erro
6120: 72 3a 20 6e 6f 74 20 61 6e 74 69 2d 73 79 6d 6d r: not anti-symm
6130: 65 74 72 69 63 22 20 63 20 79 20 7a 29 29 0a 20 etric" c y z)).
6140: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
6150: 74 20 28 28 69 6a 6b 20 28 76 65 63 74 6f 72 2d t ((ijk (vector-
6160: 72 65 66 20 71 20 28 2b 20 63 2d 78 79 20 28 2a ref q (+ c-xy (*
6170: 20 33 20 63 2d 79 7a 29 20 28 2a 20 39 20 63 2d 3 c-yz) (* 9 c-
6180: 78 7a 29 20 31 33 29 29 29 29 0a 20 20 20 20 20 xz) 13)))).
6190: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
61a0: 6c 69 73 74 3f 20 69 6a 6b 29 0a 20 20 20 20 20 list? ijk).
61b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
61c0: 61 70 70 6c 79 20 65 72 72 6f 72 0a 20 20 20 20 apply error.
61d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61e0: 20 20 20 20 20 20 20 22 63 6f 6d 70 61 72 65 20 "compare
61f0: 65 72 72 6f 72 3a 20 6e 6f 74 20 74 72 61 6e 73 error: not trans
6200: 69 74 69 76 65 22 0a 20 20 20 20 20 20 20 20 20 itive".
6210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6220: 20 20 63 20 0a 20 20 20 20 20 20 20 20 20 20 20 c .
6230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6240: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 69 29 (map (lambda (i)
6250: 20 28 63 61 73 65 20 69 20 28 28 78 29 20 78 29 (case i ((x) x)
6260: 20 28 28 79 29 20 79 29 20 28 28 7a 29 20 7a 29 ((y) y) ((z) z)
6270: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6290: 20 20 20 69 6a 6b 29 29 29 29 29 0a 20 20 20 20 ijk))))).
62a0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 7a 3f (set! z?
62b0: 20 23 74 29 29 0a 20 20 20 20 20 20 20 20 28 73 #t)). (s
62c0: 65 74 21 20 7a 20 28 69 66 20 28 72 61 6e 64 6f et! z (if (rando
62d0: 6d 2d 62 6f 6f 6c 65 61 6e 29 20 78 20 79 29 29 m-boolean) x y))
62e0: 20 3b 20 72 61 6e 64 6f 6d 69 7a 65 64 20 74 65 ; randomized te
62f0: 73 74 69 6e 67 0a 20 20 20 20 20 20 20 20 63 2d sting. c-
6300: 78 79 29 29 29 29 0a xy)))).