Artifact f7c291fd2193e0e88bf28ef5a66ea4a7bf134fa1:
- File srfi/s128/128.body1.scm — part of check-in [07be5132aa] at 2017-01-11 16:37:00 on branch trunk — added srfi 113 sets&bags, srfi 128 comparators (user: aldo size: 12156)
0000: 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 43 ;;; Copyright (C 0010: 29 20 4a 6f 68 6e 20 43 6f 77 61 6e 20 28 32 30 ) John Cowan (20 0020: 31 35 29 2e 20 41 6c 6c 20 52 69 67 68 74 73 20 15). All Rights 0030: 52 65 73 65 72 76 65 64 2e 0a 3b 3b 3b 20 0a 3b Reserved..;;; .; 0040: 3b 3b 20 50 65 72 6d 69 73 73 69 6f 6e 20 69 73 ;; Permission is 0050: 20 68 65 72 65 62 79 20 67 72 61 6e 74 65 64 2c hereby granted, 0060: 20 66 72 65 65 20 6f 66 20 63 68 61 72 67 65 2c free of charge, 0070: 20 74 6f 20 61 6e 79 20 70 65 72 73 6f 6e 0a 3b to any person.; 0080: 3b 3b 20 6f 62 74 61 69 6e 69 6e 67 20 61 20 63 ;; obtaining a c 0090: 6f 70 79 20 6f 66 20 74 68 69 73 20 73 6f 66 74 opy of this soft 00a0: 77 61 72 65 20 61 6e 64 20 61 73 73 6f 63 69 61 ware and associa 00b0: 74 65 64 20 64 6f 63 75 6d 65 6e 74 61 74 69 6f ted documentatio 00c0: 6e 0a 3b 3b 3b 20 66 69 6c 65 73 20 28 74 68 65 n.;;; files (the 00d0: 20 22 53 6f 66 74 77 61 72 65 22 29 2c 20 74 6f "Software"), to 00e0: 20 64 65 61 6c 20 69 6e 20 74 68 65 20 53 6f 66 deal in the Sof 00f0: 74 77 61 72 65 20 77 69 74 68 6f 75 74 0a 3b 3b tware without.;; 0100: 3b 20 72 65 73 74 72 69 63 74 69 6f 6e 2c 20 69 ; restriction, i 0110: 6e 63 6c 75 64 69 6e 67 20 77 69 74 68 6f 75 74 ncluding without 0120: 20 6c 69 6d 69 74 61 74 69 6f 6e 20 74 68 65 20 limitation the 0130: 72 69 67 68 74 73 20 74 6f 20 75 73 65 2c 0a 3b rights to use,.; 0140: 3b 3b 20 63 6f 70 79 2c 20 6d 6f 64 69 66 79 2c ;; copy, modify, 0150: 20 6d 65 72 67 65 2c 20 70 75 62 6c 69 73 68 2c merge, publish, 0160: 20 64 69 73 74 72 69 62 75 74 65 2c 20 73 75 62 distribute, sub 0170: 6c 69 63 65 6e 73 65 2c 20 61 6e 64 2f 6f 72 0a license, and/or. 0180: 3b 3b 3b 20 73 65 6c 6c 20 63 6f 70 69 65 73 20 ;;; sell copies 0190: 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 65 2c of the Software, 01a0: 20 61 6e 64 20 74 6f 20 70 65 72 6d 69 74 20 70 and to permit p 01b0: 65 72 73 6f 6e 73 20 74 6f 20 77 68 6f 6d 20 74 ersons to whom t 01c0: 68 65 0a 3b 3b 3b 20 53 6f 66 74 77 61 72 65 20 he.;;; Software 01d0: 69 73 20 66 75 72 6e 69 73 68 65 64 20 74 6f 20 is furnished to 01e0: 64 6f 20 73 6f 2c 20 73 75 62 6a 65 63 74 20 74 do so, subject t 01f0: 6f 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 0a o the following. 0200: 3b 3b 3b 20 63 6f 6e 64 69 74 69 6f 6e 73 3a 0a ;;; conditions:. 0210: 3b 3b 3b 20 0a 3b 3b 3b 20 54 68 65 20 61 62 6f ;;; .;;; The abo 0220: 76 65 20 63 6f 70 79 72 69 67 68 74 20 6e 6f 74 ve copyright not 0230: 69 63 65 20 61 6e 64 20 74 68 69 73 20 70 65 72 ice and this per 0240: 6d 69 73 73 69 6f 6e 20 6e 6f 74 69 63 65 20 73 mission notice s 0250: 68 61 6c 6c 20 62 65 0a 3b 3b 3b 20 69 6e 63 6c hall be.;;; incl 0260: 75 64 65 64 20 69 6e 20 61 6c 6c 20 63 6f 70 69 uded in all copi 0270: 65 73 20 6f 72 20 73 75 62 73 74 61 6e 74 69 61 es or substantia 0280: 6c 20 70 6f 72 74 69 6f 6e 73 20 6f 66 20 74 68 l portions of th 0290: 65 20 53 6f 66 74 77 61 72 65 2e 0a 3b 3b 3b 20 e Software..;;; 02a0: 0a 3b 3b 3b 20 54 48 45 20 53 4f 46 54 57 41 52 .;;; THE SOFTWAR 02b0: 45 20 49 53 20 50 52 4f 56 49 44 45 44 20 22 41 E IS PROVIDED "A 02c0: 53 20 49 53 22 2c 20 57 49 54 48 4f 55 54 20 57 S IS", WITHOUT W 02d0: 41 52 52 41 4e 54 59 20 4f 46 20 41 4e 59 20 4b ARRANTY OF ANY K 02e0: 49 4e 44 2c 0a 3b 3b 3b 20 45 58 50 52 45 53 53 IND,.;;; EXPRESS 02f0: 20 4f 52 20 49 4d 50 4c 49 45 44 2c 20 49 4e 43 OR IMPLIED, INC 0300: 4c 55 44 49 4e 47 20 42 55 54 20 4e 4f 54 20 4c LUDING BUT NOT L 0310: 49 4d 49 54 45 44 20 54 4f 20 54 48 45 20 57 41 IMITED TO THE WA 0320: 52 52 41 4e 54 49 45 53 0a 3b 3b 3b 20 4f 46 20 RRANTIES.;;; OF 0330: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 2c MERCHANTABILITY, 0340: 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 50 FITNESS FOR A P 0350: 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f 53 ARTICULAR PURPOS 0360: 45 20 41 4e 44 0a 3b 3b 3b 20 4e 4f 4e 49 4e 46 E AND.;;; NONINF 0370: 52 49 4e 47 45 4d 45 4e 54 2e 20 49 4e 20 4e 4f RINGEMENT. IN NO 0380: 20 45 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 EVENT SHALL THE 0390: 20 41 55 54 48 4f 52 53 20 4f 52 20 43 4f 50 59 AUTHORS OR COPY 03a0: 52 49 47 48 54 0a 3b 3b 3b 20 48 4f 4c 44 45 52 RIGHT.;;; HOLDER 03b0: 53 20 42 45 20 4c 49 41 42 4c 45 20 46 4f 52 20 S BE LIABLE FOR 03c0: 41 4e 59 20 43 4c 41 49 4d 2c 20 44 41 4d 41 47 ANY CLAIM, DAMAG 03d0: 45 53 20 4f 52 20 4f 54 48 45 52 20 4c 49 41 42 ES OR OTHER LIAB 03e0: 49 4c 49 54 59 2c 0a 3b 3b 3b 20 57 48 45 54 48 ILITY,.;;; WHETH 03f0: 45 52 20 49 4e 20 41 4e 20 41 43 54 49 4f 4e 20 ER IN AN ACTION 0400: 4f 46 20 43 4f 4e 54 52 41 43 54 2c 20 54 4f 52 OF CONTRACT, TOR 0410: 54 20 4f 52 20 4f 54 48 45 52 57 49 53 45 2c 20 T OR OTHERWISE, 0420: 41 52 49 53 49 4e 47 0a 3b 3b 3b 20 46 52 4f 4d ARISING.;;; FROM 0430: 2c 20 4f 55 54 20 4f 46 20 4f 52 20 49 4e 20 43 , OUT OF OR IN C 0440: 4f 4e 4e 45 43 54 49 4f 4e 20 57 49 54 48 20 54 ONNECTION WITH T 0450: 48 45 20 53 4f 46 54 57 41 52 45 20 4f 52 20 54 HE SOFTWARE OR T 0460: 48 45 20 55 53 45 20 4f 52 0a 3b 3b 3b 20 4f 54 HE USE OR.;;; OT 0470: 48 45 52 20 44 45 41 4c 49 4e 47 53 20 49 4e 20 HER DEALINGS IN 0480: 54 48 45 20 53 4f 46 54 57 41 52 45 2e 20 0a 0a THE SOFTWARE. .. 0490: 3b 3b 3b 3b 20 4d 61 69 6e 20 70 61 72 74 20 6f ;;;; Main part o 04a0: 66 20 74 68 65 20 53 52 46 49 20 31 31 34 20 72 f the SRFI 114 r 04b0: 65 66 65 72 65 6e 63 65 20 69 6d 70 6c 65 6d 65 eference impleme 04c0: 6e 74 61 74 69 6f 6e 0a 0a 3b 3b 3b 20 22 54 68 ntation..;;; "Th 04d0: 65 72 65 20 61 72 65 20 74 77 6f 20 77 61 79 73 ere are two ways 04e0: 20 6f 66 20 63 6f 6e 73 74 72 75 63 74 69 6e 67 of constructing 04f0: 20 61 20 73 6f 66 74 77 61 72 65 20 64 65 73 69 a software desi 0500: 67 6e 3a 20 4f 6e 65 20 77 61 79 20 69 73 20 74 gn: One way is t 0510: 6f 0a 3b 3b 3b 20 6d 61 6b 65 20 69 74 20 73 6f o.;;; make it so 0520: 20 73 69 6d 70 6c 65 20 74 68 61 74 20 74 68 65 simple that the 0530: 72 65 20 61 72 65 20 6f 62 76 69 6f 75 73 6c 79 re are obviously 0540: 20 6e 6f 20 64 65 66 69 63 69 65 6e 63 69 65 73 no deficiencies 0550: 2c 20 61 6e 64 20 74 68 65 0a 3b 3b 3b 20 6f 74 , and the.;;; ot 0560: 68 65 72 20 77 61 79 20 69 73 20 74 6f 20 6d 61 her way is to ma 0570: 6b 65 20 69 74 20 73 6f 20 63 6f 6d 70 6c 69 63 ke it so complic 0580: 61 74 65 64 20 74 68 61 74 20 74 68 65 72 65 20 ated that there 0590: 61 72 65 20 6e 6f 20 2a 6f 62 76 69 6f 75 73 2a are no *obvious* 05a0: 0a 3b 3b 3b 20 64 65 66 69 63 69 65 6e 63 69 65 .;;; deficiencie 05b0: 73 2e 22 20 2d 2d 54 6f 6e 79 20 48 6f 61 72 65 s." --Tony Hoare 05c0: 0a 0a 3b 3b 3b 20 53 79 6e 74 61 78 20 28 62 65 ..;;; Syntax (be 05d0: 63 61 75 73 65 20 73 79 6e 74 61 78 20 6d 75 73 cause syntax mus 05e0: 74 20 62 65 20 64 65 66 69 6e 65 64 20 62 65 66 t be defined bef 05f0: 6f 72 65 20 69 74 20 69 73 20 75 73 65 64 2c 20 ore it is used, 0600: 63 6f 6e 74 72 61 20 44 72 2e 20 48 61 72 64 63 contra Dr. Hardc 0610: 61 73 65 29 0a 0a 3b 3b 20 41 72 69 74 68 6d 65 ase)..;; Arithme 0620: 74 69 63 20 69 66 0a 28 64 65 66 69 6e 65 2d 73 tic if.(define-s 0630: 79 6e 74 61 78 20 63 6f 6d 70 61 72 61 74 6f 72 yntax comparator 0640: 2d 69 66 3c 3d 3e 0a 20 20 28 73 79 6e 74 61 78 -if<=>. (syntax 0650: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). (( 0660: 69 66 3c 3d 3e 20 61 20 62 20 6c 65 73 73 20 65 if<=> a b less e 0670: 71 75 61 6c 20 67 72 65 61 74 65 72 29 0a 20 20 qual greater). 0680: 20 20 20 28 63 6f 6d 70 61 72 61 74 6f 72 2d 69 (comparator-i 0690: 66 3c 3d 3e 20 28 6d 61 6b 65 2d 64 65 66 61 75 f<=> (make-defau 06a0: 6c 74 2d 63 6f 6d 70 61 72 61 74 6f 72 29 20 61 lt-comparator) a 06b0: 20 62 20 6c 65 73 73 20 65 71 75 61 6c 20 67 72 b less equal gr 06c0: 65 61 74 65 72 29 29 0a 20 20 20 20 28 28 63 6f eater)). ((co 06d0: 6d 70 61 72 61 74 6f 72 2d 69 66 3c 3d 3e 20 63 mparator-if<=> c 06e0: 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 20 6c 65 omparator a b le 06f0: 73 73 20 65 71 75 61 6c 20 67 72 65 61 74 65 72 ss equal greater 0700: 29 0a 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 ). (cond. 0710: 20 20 20 20 28 28 3d 3f 20 63 6f 6d 70 61 72 61 ((=? compara 0720: 74 6f 72 20 61 20 62 29 20 65 71 75 61 6c 29 0a tor a b) equal). 0730: 20 20 20 20 20 20 20 28 28 3c 3f 20 63 6f 6d 70 ((<? comp 0740: 61 72 61 74 6f 72 20 61 20 62 29 20 6c 65 73 73 arator a b) less 0750: 29 0a 20 20 20 20 20 20 20 28 65 6c 73 65 20 67 ). (else g 0760: 72 65 61 74 65 72 29 29 29 29 29 0a 0a 3b 3b 20 reater)))))..;; 0770: 55 70 70 65 72 20 62 6f 75 6e 64 20 6f 66 20 68 Upper bound of h 0780: 61 73 68 20 66 75 6e 63 74 69 6f 6e 73 20 69 73 ash functions is 0790: 20 32 5e 32 35 2d 31 0a 28 64 65 66 69 6e 65 2d 2^25-1.(define- 07a0: 73 79 6e 74 61 78 20 68 61 73 68 2d 62 6f 75 6e syntax hash-boun 07b0: 64 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 d. (syntax-rule 07c0: 73 20 28 29 0a 20 20 20 20 28 28 68 61 73 68 2d s (). ((hash- 07d0: 62 6f 75 6e 64 29 20 33 33 35 35 34 34 33 32 29 bound) 33554432) 07e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 25 73 61 6c ))..(define %sal 07f0: 74 25 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 t% (make-paramet 0800: 65 72 20 31 36 30 36 34 30 34 37 29 29 0a 0a 28 er 16064047))..( 0810: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 68 61 define-syntax ha 0820: 73 68 2d 73 61 6c 74 0a 20 20 20 28 73 79 6e 74 sh-salt. (synt 0830: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules (). 0840: 20 28 28 68 61 73 68 2d 73 61 6c 74 29 20 28 25 ((hash-salt) (% 0850: 73 61 6c 74 25 29 29 29 29 0a 0a 28 64 65 66 69 salt%))))..(defi 0860: 6e 65 2d 73 79 6e 74 61 78 20 77 69 74 68 2d 68 ne-syntax with-h 0870: 61 73 68 2d 73 61 6c 74 0a 20 20 28 73 79 6e 74 ash-salt. (synt 0880: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules (). 0890: 28 28 77 69 74 68 2d 68 61 73 68 2d 73 61 6c 74 ((with-hash-salt 08a0: 20 6e 65 77 2d 73 61 6c 74 20 68 61 73 68 2d 66 new-salt hash-f 08b0: 75 6e 63 20 6f 62 6a 29 0a 20 20 20 20 20 28 70 unc obj). (p 08c0: 61 72 61 6d 65 74 65 72 69 7a 65 20 28 28 25 73 arameterize ((%s 08d0: 61 6c 74 25 20 6e 65 77 2d 73 61 6c 74 29 29 20 alt% new-salt)) 08e0: 28 68 61 73 68 2d 66 75 6e 63 20 6f 62 6a 29 29 (hash-func obj)) 08f0: 29 29 29 0a 0a 3b 3b 3b 20 44 65 66 69 6e 69 74 )))..;;; Definit 0900: 69 6f 6e 20 6f 66 20 63 6f 6d 70 61 72 61 74 6f ion of comparato 0910: 72 20 72 65 63 6f 72 64 73 20 77 69 74 68 20 61 r records with a 0920: 63 63 65 73 73 6f 72 73 20 61 6e 64 20 62 61 73 ccessors and bas 0930: 69 63 20 63 6f 6d 70 61 72 61 74 6f 72 0a 0a 28 ic comparator..( 0940: 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 79 define-record-ty 0950: 70 65 20 63 6f 6d 70 61 72 61 74 6f 72 0a 20 20 pe comparator. 0960: 28 6d 61 6b 65 2d 72 61 77 2d 63 6f 6d 70 61 72 (make-raw-compar 0970: 61 74 6f 72 20 74 79 70 65 2d 74 65 73 74 20 65 ator type-test e 0980: 71 75 61 6c 69 74 79 20 6f 72 64 65 72 69 6e 67 quality ordering 0990: 20 68 61 73 68 20 6f 72 64 65 72 69 6e 67 3f 20 hash ordering? 09a0: 68 61 73 68 3f 29 0a 20 20 63 6f 6d 70 61 72 61 hash?). compara 09b0: 74 6f 72 3f 0a 20 20 28 74 79 70 65 2d 74 65 73 tor?. (type-tes 09c0: 74 20 63 6f 6d 70 61 72 61 74 6f 72 2d 74 79 70 t comparator-typ 09d0: 65 2d 74 65 73 74 2d 70 72 65 64 69 63 61 74 65 e-test-predicate 09e0: 29 0a 20 20 28 65 71 75 61 6c 69 74 79 20 63 6f ). (equality co 09f0: 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 6c 69 74 mparator-equalit 0a00: 79 2d 70 72 65 64 69 63 61 74 65 29 0a 20 20 28 y-predicate). ( 0a10: 6f 72 64 65 72 69 6e 67 20 63 6f 6d 70 61 72 61 ordering compara 0a20: 74 6f 72 2d 6f 72 64 65 72 69 6e 67 2d 70 72 65 tor-ordering-pre 0a30: 64 69 63 61 74 65 29 0a 20 20 28 68 61 73 68 20 dicate). (hash 0a40: 63 6f 6d 70 61 72 61 74 6f 72 2d 68 61 73 68 2d comparator-hash- 0a50: 66 75 6e 63 74 69 6f 6e 29 0a 20 20 28 6f 72 64 function). (ord 0a60: 65 72 69 6e 67 3f 20 63 6f 6d 70 61 72 61 74 6f ering? comparato 0a70: 72 2d 6f 72 64 65 72 65 64 3f 29 0a 20 20 28 68 r-ordered?). (h 0a80: 61 73 68 3f 20 63 6f 6d 70 61 72 61 74 6f 72 2d ash? comparator- 0a90: 68 61 73 68 61 62 6c 65 3f 29 29 0a 0a 3b 3b 20 hashable?))..;; 0aa0: 50 75 62 6c 69 63 20 63 6f 6e 73 74 72 75 63 74 Public construct 0ab0: 6f 72 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 or.(define (make 0ac0: 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 -comparator type 0ad0: 2d 74 65 73 74 20 65 71 75 61 6c 69 74 79 20 6f -test equality o 0ae0: 72 64 65 72 69 6e 67 20 68 61 73 68 29 0a 20 20 rdering hash). 0af0: 28 6d 61 6b 65 2d 72 61 77 2d 63 6f 6d 70 61 72 (make-raw-compar 0b00: 61 74 6f 72 0a 20 20 20 20 28 69 66 20 28 65 71 ator. (if (eq 0b10: 3f 20 74 79 70 65 2d 74 65 73 74 20 23 74 29 20 ? type-test #t) 0b20: 28 6c 61 6d 62 64 61 20 28 78 29 20 23 74 29 20 (lambda (x) #t) 0b30: 74 79 70 65 2d 74 65 73 74 29 0a 20 20 20 20 28 type-test). ( 0b40: 69 66 20 28 65 71 3f 20 65 71 75 61 6c 69 74 79 if (eq? equality 0b50: 20 23 74 29 20 28 6c 61 6d 62 64 61 20 28 78 20 #t) (lambda (x 0b60: 79 29 20 28 65 71 76 3f 20 28 6f 72 64 65 72 69 y) (eqv? (orderi 0b70: 6e 67 20 78 20 79 29 20 30 29 29 20 65 71 75 61 ng x y) 0)) equa 0b80: 6c 69 74 79 29 0a 20 20 20 20 28 69 66 20 6f 72 lity). (if or 0b90: 64 65 72 69 6e 67 20 6f 72 64 65 72 69 6e 67 20 dering ordering 0ba0: 28 6c 61 6d 62 64 61 20 28 78 20 79 29 20 28 65 (lambda (x y) (e 0bb0: 72 72 6f 72 20 22 6f 72 64 65 72 69 6e 67 20 6e rror "ordering n 0bc0: 6f 74 20 73 75 70 70 6f 72 74 65 64 22 29 29 29 ot supported"))) 0bd0: 0a 20 20 20 20 28 69 66 20 68 61 73 68 20 68 61 . (if hash ha 0be0: 73 68 20 28 6c 61 6d 62 64 61 20 28 78 20 79 29 sh (lambda (x y) 0bf0: 20 28 65 72 72 6f 72 20 22 68 61 73 68 69 6e 67 (error "hashing 0c00: 20 6e 6f 74 20 73 75 70 70 6f 72 74 65 64 22 29 not supported") 0c10: 29 29 0a 20 20 20 20 28 69 66 20 6f 72 64 65 72 )). (if order 0c20: 69 6e 67 20 23 74 20 23 66 29 0a 20 20 20 20 28 ing #t #f). ( 0c30: 69 66 20 68 61 73 68 20 23 74 20 23 66 29 29 29 if hash #t #f))) 0c40: 0a 0a 3b 3b 3b 20 49 6e 76 6f 6b 65 72 73 0a 0a ..;;; Invokers.. 0c50: 3b 3b 20 49 6e 76 6f 6b 65 20 74 68 65 20 74 65 ;; Invoke the te 0c60: 73 74 20 74 79 70 65 0a 28 64 65 66 69 6e 65 20 st type.(define 0c70: 28 63 6f 6d 70 61 72 61 74 6f 72 2d 74 65 73 74 (comparator-test 0c80: 2d 74 79 70 65 20 63 6f 6d 70 61 72 61 74 6f 72 -type comparator 0c90: 20 6f 62 6a 29 0a 20 20 28 28 63 6f 6d 70 61 72 obj). ((compar 0ca0: 61 74 6f 72 2d 74 79 70 65 2d 74 65 73 74 2d 70 ator-type-test-p 0cb0: 72 65 64 69 63 61 74 65 20 63 6f 6d 70 61 72 61 redicate compara 0cc0: 74 6f 72 29 20 6f 62 6a 29 29 0a 0a 3b 3b 20 49 tor) obj))..;; I 0cd0: 6e 76 6f 6b 65 20 74 68 65 20 74 65 73 74 20 74 nvoke the test t 0ce0: 79 70 65 20 61 6e 64 20 74 68 72 6f 77 20 61 6e ype and throw an 0cf0: 20 65 72 72 6f 72 20 69 66 20 69 74 20 66 61 69 error if it fai 0d00: 6c 73 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 70 ls.(define (comp 0d10: 61 72 61 74 6f 72 2d 63 68 65 63 6b 2d 74 79 70 arator-check-typ 0d20: 65 20 63 6f 6d 70 61 72 61 74 6f 72 20 6f 62 6a e comparator obj 0d30: 29 0a 20 20 28 69 66 20 28 63 6f 6d 70 61 72 61 ). (if (compara 0d40: 74 6f 72 2d 74 65 73 74 2d 74 79 70 65 20 63 6f tor-test-type co 0d50: 6d 70 61 72 61 74 6f 72 20 6f 62 6a 29 0a 20 20 mparator obj). 0d60: 20 20 23 74 0a 20 20 20 20 28 65 72 72 6f 72 20 #t. (error 0d70: 22 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 "comparator type 0d80: 20 63 68 65 63 6b 20 66 61 69 6c 65 64 22 20 63 check failed" c 0d90: 6f 6d 70 61 72 61 74 6f 72 20 6f 62 6a 29 29 29 omparator obj))) 0da0: 0a 0a 3b 3b 20 49 6e 76 6f 6b 65 20 74 68 65 20 ..;; Invoke the 0db0: 68 61 73 68 20 66 75 6e 63 74 69 6f 6e 0a 28 64 hash function.(d 0dc0: 65 66 69 6e 65 20 28 63 6f 6d 70 61 72 61 74 6f efine (comparato 0dd0: 72 2d 68 61 73 68 20 63 6f 6d 70 61 72 61 74 6f r-hash comparato 0de0: 72 20 6f 62 6a 29 0a 20 20 28 28 63 6f 6d 70 61 r obj). ((compa 0df0: 72 61 74 6f 72 2d 68 61 73 68 2d 66 75 6e 63 74 rator-hash-funct 0e00: 69 6f 6e 20 63 6f 6d 70 61 72 61 74 6f 72 29 20 ion comparator) 0e10: 6f 62 6a 29 29 0a 0a 3b 3b 3b 20 43 6f 6d 70 61 obj))..;;; Compa 0e20: 72 69 73 6f 6e 20 70 72 65 64 69 63 61 74 65 73 rison predicates 0e30: 0a 0a 3b 3b 20 42 69 6e 61 72 79 20 76 65 72 73 ..;; Binary vers 0e40: 69 6f 6e 73 20 66 6f 72 20 69 6e 74 65 72 6e 61 ions for interna 0e50: 6c 20 75 73 65 0a 0a 28 64 65 66 69 6e 65 20 28 l use..(define ( 0e60: 62 69 6e 61 72 79 3d 3f 20 63 6f 6d 70 61 72 61 binary=? compara 0e70: 74 6f 72 20 61 20 62 29 0a 20 20 28 28 63 6f 6d tor a b). ((com 0e80: 70 61 72 61 74 6f 72 2d 65 71 75 61 6c 69 74 79 parator-equality 0e90: 2d 70 72 65 64 69 63 61 74 65 20 63 6f 6d 70 61 -predicate compa 0ea0: 72 61 74 6f 72 29 20 61 20 62 29 29 0a 0a 28 64 rator) a b))..(d 0eb0: 65 66 69 6e 65 20 28 62 69 6e 61 72 79 3c 3f 20 efine (binary<? 0ec0: 63 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 29 0a comparator a b). 0ed0: 20 20 28 28 63 6f 6d 70 61 72 61 74 6f 72 2d 6f ((comparator-o 0ee0: 72 64 65 72 69 6e 67 2d 70 72 65 64 69 63 61 74 rdering-predicat 0ef0: 65 20 63 6f 6d 70 61 72 61 74 6f 72 29 20 61 20 e comparator) a 0f00: 62 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 69 b))..(define (bi 0f10: 6e 61 72 79 3e 3f 20 63 6f 6d 70 61 72 61 74 6f nary>? comparato 0f20: 72 20 61 20 62 29 0a 20 20 28 62 69 6e 61 72 79 r a b). (binary 0f30: 3c 3f 20 63 6f 6d 70 61 72 61 74 6f 72 20 62 20 <? comparator b 0f40: 61 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 69 a))..(define (bi 0f50: 6e 61 72 79 3c 3d 3f 20 63 6f 6d 70 61 72 61 74 nary<=? comparat 0f60: 6f 72 20 61 20 62 29 0a 20 20 28 6e 6f 74 20 28 or a b). (not ( 0f70: 62 69 6e 61 72 79 3e 3f 20 63 6f 6d 70 61 72 61 binary>? compara 0f80: 74 6f 72 20 61 20 62 29 29 29 0a 0a 28 64 65 66 tor a b)))..(def 0f90: 69 6e 65 20 28 62 69 6e 61 72 79 3e 3d 3f 20 63 ine (binary>=? c 0fa0: 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 29 0a 20 omparator a b). 0fb0: 20 28 6e 6f 74 20 28 62 69 6e 61 72 79 3c 3f 20 (not (binary<? 0fc0: 63 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 29 29 comparator a b)) 0fd0: 29 0a 0a 3b 3b 20 47 65 6e 65 72 61 6c 20 76 65 )..;; General ve 0fe0: 72 73 69 6f 6e 73 20 66 6f 72 20 65 78 70 6f 72 rsions for expor 0ff0: 74 0a 0a 28 64 65 66 69 6e 65 20 28 3d 3f 20 63 t..(define (=? c 1000: 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 20 2e 20 omparator a b . 1010: 6f 62 6a 73 29 0a 20 20 28 6c 65 74 20 6c 6f 6f objs). (let loo 1020: 70 20 28 28 61 20 61 29 20 28 62 20 62 29 20 28 p ((a a) (b b) ( 1030: 6f 62 6a 73 20 6f 62 6a 73 29 29 0a 20 20 20 20 objs objs)). 1040: 28 61 6e 64 20 28 62 69 6e 61 72 79 3d 3f 20 63 (and (binary=? c 1050: 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 29 0a 09 omparator a b).. 1060: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6f 62 6a 73 (if (null? objs 1070: 29 20 23 74 20 28 6c 6f 6f 70 20 62 20 28 63 61 ) #t (loop b (ca 1080: 72 20 6f 62 6a 73 29 20 28 63 64 72 20 6f 62 6a r objs) (cdr obj 1090: 73 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 s))))))..(define 10a0: 20 28 3c 3f 20 63 6f 6d 70 61 72 61 74 6f 72 20 (<? comparator 10b0: 61 20 62 20 2e 20 6f 62 6a 73 29 0a 20 20 28 6c a b . objs). (l 10c0: 65 74 20 6c 6f 6f 70 20 28 28 61 20 61 29 20 28 et loop ((a a) ( 10d0: 62 20 62 29 20 28 6f 62 6a 73 20 6f 62 6a 73 29 b b) (objs objs) 10e0: 29 0a 20 20 20 20 28 61 6e 64 20 28 62 69 6e 61 ). (and (bina 10f0: 72 79 3c 3f 20 63 6f 6d 70 61 72 61 74 6f 72 20 ry<? comparator 1100: 61 20 62 29 0a 09 20 28 69 66 20 28 6e 75 6c 6c a b).. (if (null 1110: 3f 20 6f 62 6a 73 29 20 23 74 20 28 6c 6f 6f 70 ? objs) #t (loop 1120: 20 62 20 28 63 61 72 20 6f 62 6a 73 29 20 28 63 b (car objs) (c 1130: 64 72 20 6f 62 6a 73 29 29 29 29 29 29 0a 0a 28 dr objs))))))..( 1140: 64 65 66 69 6e 65 20 28 3e 3f 20 63 6f 6d 70 61 define (>? compa 1150: 72 61 74 6f 72 20 61 20 62 20 2e 20 6f 62 6a 73 rator a b . objs 1160: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop (( 1170: 61 20 61 29 20 28 62 20 62 29 20 28 6f 62 6a 73 a a) (b b) (objs 1180: 20 6f 62 6a 73 29 29 0a 20 20 20 20 28 61 6e 64 objs)). (and 1190: 20 28 62 69 6e 61 72 79 3e 3f 20 63 6f 6d 70 61 (binary>? compa 11a0: 72 61 74 6f 72 20 61 20 62 29 0a 09 20 28 69 66 rator a b).. (if 11b0: 20 28 6e 75 6c 6c 3f 20 6f 62 6a 73 29 20 23 74 (null? objs) #t 11c0: 20 28 6c 6f 6f 70 20 62 20 28 63 61 72 20 6f 62 (loop b (car ob 11d0: 6a 73 29 20 28 63 64 72 20 6f 62 6a 73 29 29 29 js) (cdr objs))) 11e0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 3c 3d )))..(define (<= 11f0: 3f 20 63 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 ? comparator a b 1200: 20 2e 20 6f 62 6a 73 29 0a 20 20 28 6c 65 74 20 . objs). (let 1210: 6c 6f 6f 70 20 28 28 61 20 61 29 20 28 62 20 62 loop ((a a) (b b 1220: 29 20 28 6f 62 6a 73 20 6f 62 6a 73 29 29 0a 20 ) (objs objs)). 1230: 20 20 20 28 61 6e 64 20 28 62 69 6e 61 72 79 3c (and (binary< 1240: 3d 3f 20 63 6f 6d 70 61 72 61 74 6f 72 20 61 20 =? comparator a 1250: 62 29 0a 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 b).. (if (null? 1260: 6f 62 6a 73 29 20 23 74 20 28 6c 6f 6f 70 20 62 objs) #t (loop b 1270: 20 28 63 61 72 20 6f 62 6a 73 29 20 28 63 64 72 (car objs) (cdr 1280: 20 6f 62 6a 73 29 29 29 29 29 29 0a 0a 28 64 65 objs))))))..(de 1290: 66 69 6e 65 20 28 3e 3d 3f 20 63 6f 6d 70 61 72 fine (>=? compar 12a0: 61 74 6f 72 20 61 20 62 20 2e 20 6f 62 6a 73 29 ator a b . objs) 12b0: 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 61 . (let loop ((a 12c0: 20 61 29 20 28 62 20 62 29 20 28 6f 62 6a 73 20 a) (b b) (objs 12d0: 6f 62 6a 73 29 29 0a 20 20 20 20 28 61 6e 64 20 objs)). (and 12e0: 28 62 69 6e 61 72 79 3e 3d 3f 20 63 6f 6d 70 61 (binary>=? compa 12f0: 72 61 74 6f 72 20 61 20 62 29 0a 09 20 28 69 66 rator a b).. (if 1300: 20 28 6e 75 6c 6c 3f 20 6f 62 6a 73 29 20 23 74 (null? objs) #t 1310: 20 28 6c 6f 6f 70 20 62 20 28 63 61 72 20 6f 62 (loop b (car ob 1320: 6a 73 29 20 28 63 64 72 20 6f 62 6a 73 29 29 29 js) (cdr objs))) 1330: 29 29 29 0a 0a 0a 3b 3b 3b 20 53 69 6d 70 6c 65 )))...;;; Simple 1340: 20 6f 72 64 65 72 69 6e 67 20 61 6e 64 20 68 61 ordering and ha 1350: 73 68 20 66 75 6e 63 74 69 6f 6e 73 0a 0a 28 64 sh functions..(d 1360: 65 66 69 6e 65 20 28 62 6f 6f 6c 65 61 6e 3c 3f efine (boolean<? 1370: 20 61 20 62 29 0a 20 20 3b 3b 20 23 66 20 3c 20 a b). ;; #f < 1380: 23 74 20 62 75 74 20 6e 6f 74 20 6f 74 68 65 72 #t but not other 1390: 77 69 73 65 0a 20 20 28 61 6e 64 20 28 6e 6f 74 wise. (and (not 13a0: 20 61 29 20 62 29 29 0a 0a 0a 28 64 65 66 69 6e a) b))...(defin 13b0: 65 20 28 62 6f 6f 6c 65 61 6e 2d 68 61 73 68 20 e (boolean-hash 13c0: 6f 62 6a 29 0a 20 20 28 69 66 20 6f 62 6a 20 28 obj). (if obj ( 13d0: 25 73 61 6c 74 25 29 20 30 29 29 0a 0a 28 64 65 %salt%) 0))..(de 13e0: 66 69 6e 65 20 28 63 68 61 72 2d 68 61 73 68 20 fine (char-hash 13f0: 6f 62 6a 29 0a 20 20 28 6d 6f 64 75 6c 6f 20 28 obj). (modulo ( 1400: 2a 20 28 25 73 61 6c 74 25 29 20 28 63 68 61 72 * (%salt%) (char 1410: 2d 3e 69 6e 74 65 67 65 72 20 6f 62 6a 29 29 20 ->integer obj)) 1420: 28 68 61 73 68 2d 62 6f 75 6e 64 29 29 29 0a 0a (hash-bound))).. 1430: 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 63 69 (define (char-ci 1440: 2d 68 61 73 68 20 6f 62 6a 29 0a 20 20 28 6d 6f -hash obj). (mo 1450: 64 75 6c 6f 20 28 2a 20 28 25 73 61 6c 74 25 29 dulo (* (%salt%) 1460: 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 (char->integer 1470: 28 63 68 61 72 2d 66 6f 6c 64 63 61 73 65 20 6f (char-foldcase o 1480: 62 6a 29 29 29 20 28 68 61 73 68 2d 62 6f 75 6e bj))) (hash-boun 1490: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6e d)))..(define (n 14a0: 75 6d 62 65 72 2d 68 61 73 68 20 6f 62 6a 29 0a umber-hash obj). 14b0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 28 28 6e 61 (cond. ((na 14c0: 6e 3f 20 6f 62 6a 29 20 28 25 73 61 6c 74 25 29 n? obj) (%salt%) 14d0: 29 0a 20 20 20 20 28 28 61 6e 64 20 28 69 6e 66 ). ((and (inf 14e0: 69 6e 69 74 65 3f 20 6f 62 6a 29 20 28 70 6f 73 inite? obj) (pos 14f0: 69 74 69 76 65 3f 20 6f 62 6a 29 29 20 28 2a 20 itive? obj)) (* 1500: 32 20 28 25 73 61 6c 74 25 29 29 29 0a 20 20 20 2 (%salt%))). 1510: 20 28 28 69 6e 66 69 6e 69 74 65 3f 20 6f 62 6a ((infinite? obj 1520: 29 20 28 2a 20 28 25 73 61 6c 74 25 29 20 33 29 ) (* (%salt%) 3) 1530: 29 0a 20 20 20 20 28 28 72 65 61 6c 3f 20 6f 62 ). ((real? ob 1540: 6a 29 20 28 61 62 73 20 28 65 78 61 63 74 20 28 j) (abs (exact ( 1550: 72 6f 75 6e 64 20 6f 62 6a 29 29 29 29 0a 20 20 round obj)))). 1560: 20 20 28 65 6c 73 65 20 28 2b 20 28 6e 75 6d 62 (else (+ (numb 1570: 65 72 2d 68 61 73 68 20 28 72 65 61 6c 2d 70 61 er-hash (real-pa 1580: 72 74 20 6f 62 6a 29 29 20 28 6e 75 6d 62 65 72 rt obj)) (number 1590: 2d 68 61 73 68 20 28 69 6d 61 67 2d 70 61 72 74 -hash (imag-part 15a0: 20 6f 62 6a 29 29 29 29 29 29 0a 0a 3b 3b 20 4c obj))))))..;; L 15b0: 65 78 69 63 6f 67 72 61 70 68 69 63 20 6f 72 64 exicographic ord 15c0: 65 72 69 6e 67 20 6f 66 20 63 6f 6d 70 6c 65 78 ering of complex 15d0: 20 6e 75 6d 62 65 72 73 0a 28 64 65 66 69 6e 65 numbers.(define 15e0: 20 28 63 6f 6d 70 6c 65 78 3c 3f 20 61 20 62 29 (complex<? a b) 15f0: 0a 20 20 28 69 66 20 28 3d 20 28 72 65 61 6c 2d . (if (= (real- 1600: 70 61 72 74 20 61 29 20 28 72 65 61 6c 2d 70 61 part a) (real-pa 1610: 72 74 20 62 29 29 0a 20 20 20 20 28 3c 20 28 69 rt b)). (< (i 1620: 6d 61 67 2d 70 61 72 74 20 61 29 20 28 69 6d 61 mag-part a) (ima 1630: 67 2d 70 61 72 74 20 62 29 29 0a 20 20 20 20 28 g-part b)). ( 1640: 3c 20 28 72 65 61 6c 2d 70 61 72 74 20 61 29 20 < (real-part a) 1650: 28 72 65 61 6c 2d 70 61 72 74 20 62 29 29 29 29 (real-part b)))) 1660: 0a 0a 3b 28 64 65 66 69 6e 65 20 28 73 74 72 69 ..;(define (stri 1670: 6e 67 2d 63 69 2d 68 61 73 68 20 6f 62 6a 29 0a ng-ci-hash obj). 1680: 3b 20 20 20 20 28 73 74 72 69 6e 67 2d 68 61 73 ; (string-has 1690: 68 20 28 73 74 72 69 6e 67 2d 66 6f 6c 64 63 61 h (string-foldca 16a0: 73 65 20 6f 62 6a 29 29 29 0a 0a 28 64 65 66 69 se obj)))..(defi 16b0: 6e 65 20 28 73 79 6d 62 6f 6c 3c 3f 20 61 20 62 ne (symbol<? a b 16c0: 29 20 28 73 74 72 69 6e 67 3c 3f 20 28 73 79 6d ) (string<? (sym 16d0: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 61 29 20 28 bol->string a) ( 16e0: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 62 symbol->string b 16f0: 29 29 29 0a 0a 3b 28 64 65 66 69 6e 65 20 28 73 )))..;(define (s 1700: 79 6d 62 6f 6c 2d 68 61 73 68 20 6f 62 6a 29 0a ymbol-hash obj). 1710: 3b 20 20 28 73 74 72 69 6e 67 2d 68 61 73 68 20 ; (string-hash 1720: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string 1730: 6f 62 6a 29 29 29 0a 0a 3b 3b 3b 20 57 72 61 70 obj)))..;;; Wrap 1740: 70 65 64 20 65 71 75 61 6c 69 74 79 20 70 72 65 ped equality pre 1750: 64 69 63 61 74 65 73 0a 3b 3b 3b 20 54 68 65 73 dicates.;;; Thes 1760: 65 20 63 6f 6d 70 61 72 61 74 6f 72 73 20 64 6f e comparators do 1770: 6e 27 74 20 68 61 76 65 20 6f 72 64 65 72 69 6e n't have orderin 1780: 67 20 66 75 6e 63 74 69 6f 6e 73 2e 0a 0a 28 64 g functions...(d 1790: 65 66 69 6e 65 20 28 6d 61 6b 65 2d 65 71 2d 63 efine (make-eq-c 17a0: 6f 6d 70 61 72 61 74 6f 72 29 0a 20 20 28 6d 61 omparator). (ma 17b0: 6b 65 2d 63 6f 6d 70 61 72 61 74 6f 72 20 23 74 ke-comparator #t 17c0: 20 65 71 3f 20 23 66 20 64 65 66 61 75 6c 74 2d eq? #f default- 17d0: 68 61 73 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 hash))..(define 17e0: 28 6d 61 6b 65 2d 65 71 76 2d 63 6f 6d 70 61 72 (make-eqv-compar 17f0: 61 74 6f 72 29 0a 20 20 28 6d 61 6b 65 2d 63 6f ator). (make-co 1800: 6d 70 61 72 61 74 6f 72 20 23 74 20 65 71 76 3f mparator #t eqv? 1810: 20 23 66 20 64 65 66 61 75 6c 74 2d 68 61 73 68 #f default-hash 1820: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ))..(define (mak 1830: 65 2d 65 71 75 61 6c 2d 63 6f 6d 70 61 72 61 74 e-equal-comparat 1840: 6f 72 29 0a 20 20 28 6d 61 6b 65 2d 63 6f 6d 70 or). (make-comp 1850: 61 72 61 74 6f 72 20 23 74 20 65 71 75 61 6c 3f arator #t equal? 1860: 20 23 66 20 64 65 66 61 75 6c 74 2d 68 61 73 68 #f default-hash 1870: 29 29 0a 0a 3b 3b 3b 20 53 65 71 75 65 6e 63 65 ))..;;; Sequence 1880: 20 6f 72 64 65 72 69 6e 67 20 61 6e 64 20 68 61 ordering and ha 1890: 73 68 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b 20 sh functions.;; 18a0: 54 68 65 20 68 61 73 68 20 66 75 6e 63 74 69 6f The hash functio 18b0: 6e 73 20 61 72 65 20 62 61 73 65 64 20 6f 6e 20 ns are based on 18c0: 64 6a 62 32 2c 20 62 75 74 0a 3b 3b 20 6d 6f 64 djb2, but.;; mod 18d0: 75 6c 6f 20 32 5e 32 35 20 69 6e 73 74 65 61 64 ulo 2^25 instead 18e0: 20 6f 66 20 32 5e 33 32 20 69 6e 20 68 6f 70 65 of 2^32 in hope 18f0: 73 20 6f 66 20 73 74 69 63 6b 69 6e 67 20 74 6f s of sticking to 1900: 20 66 69 78 6e 75 6d 73 2e 0a 0a 28 64 65 66 69 fixnums...(defi 1910: 6e 65 20 28 6d 61 6b 65 2d 68 61 73 68 65 72 29 ne (make-hasher) 1920: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 . (let ((result 1930: 20 28 25 73 61 6c 74 25 29 29 29 0a 20 20 20 20 (%salt%))). 1940: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda. 1950: 20 20 28 28 29 20 72 65 73 75 6c 74 29 0a 20 20 (() result). 1960: 20 20 20 28 28 6e 29 20 28 73 65 74 21 20 72 65 ((n) (set! re 1970: 73 75 6c 74 20 28 2b 20 28 6d 6f 64 75 6c 6f 20 sult (+ (modulo 1980: 28 2a 20 72 65 73 75 6c 74 20 33 33 29 20 28 68 (* result 33) (h 1990: 61 73 68 2d 62 6f 75 6e 64 29 29 20 6e 29 29 0a ash-bound)) n)). 19a0: 20 20 20 20 20 20 20 20 20 20 72 65 73 75 6c 74 result 19b0: 29 29 29 29 0a 0a 3b 3b 3b 20 50 61 69 72 20 63 ))))..;;; Pair c 19c0: 6f 6d 70 61 72 61 74 6f 72 0a 28 64 65 66 69 6e omparator.(defin 19d0: 65 20 28 6d 61 6b 65 2d 70 61 69 72 2d 63 6f 6d e (make-pair-com 19e0: 70 61 72 61 74 6f 72 20 63 61 72 2d 63 6f 6d 70 parator car-comp 19f0: 61 72 61 74 6f 72 20 63 64 72 2d 63 6f 6d 70 61 arator cdr-compa 1a00: 72 61 74 6f 72 29 0a 20 20 20 28 6d 61 6b 65 2d rator). (make- 1a10: 63 6f 6d 70 61 72 61 74 6f 72 0a 20 20 20 20 20 comparator. 1a20: 28 6d 61 6b 65 2d 70 61 69 72 2d 74 79 70 65 2d (make-pair-type- 1a30: 74 65 73 74 20 63 61 72 2d 63 6f 6d 70 61 72 61 test car-compara 1a40: 74 6f 72 20 63 64 72 2d 63 6f 6d 70 61 72 61 74 tor cdr-comparat 1a50: 6f 72 29 0a 20 20 20 20 20 28 6d 61 6b 65 2d 70 or). (make-p 1a60: 61 69 72 3d 3f 20 63 61 72 2d 63 6f 6d 70 61 72 air=? car-compar 1a70: 61 74 6f 72 20 63 64 72 2d 63 6f 6d 70 61 72 61 ator cdr-compara 1a80: 74 6f 72 29 0a 20 20 20 20 20 28 6d 61 6b 65 2d tor). (make- 1a90: 70 61 69 72 3c 3f 20 63 61 72 2d 63 6f 6d 70 61 pair<? car-compa 1aa0: 72 61 74 6f 72 20 63 64 72 2d 63 6f 6d 70 61 72 rator cdr-compar 1ab0: 61 74 6f 72 29 0a 20 20 20 20 20 28 6d 61 6b 65 ator). (make 1ac0: 2d 70 61 69 72 2d 68 61 73 68 20 63 61 72 2d 63 -pair-hash car-c 1ad0: 6f 6d 70 61 72 61 74 6f 72 20 63 64 72 2d 63 6f omparator cdr-co 1ae0: 6d 70 61 72 61 74 6f 72 29 29 29 0a 0a 28 64 65 mparator)))..(de 1af0: 66 69 6e 65 20 28 6d 61 6b 65 2d 70 61 69 72 2d fine (make-pair- 1b00: 74 79 70 65 2d 74 65 73 74 20 63 61 72 2d 63 6f type-test car-co 1b10: 6d 70 61 72 61 74 6f 72 20 63 64 72 2d 63 6f 6d mparator cdr-com 1b20: 70 61 72 61 74 6f 72 29 0a 20 20 28 6c 61 6d 62 parator). (lamb 1b30: 64 61 20 28 6f 62 6a 29 0a 20 20 20 20 28 61 6e da (obj). (an 1b40: 64 20 28 70 61 69 72 3f 20 6f 62 6a 29 0a 20 20 d (pair? obj). 1b50: 20 20 20 20 20 20 20 28 63 6f 6d 70 61 72 61 74 (comparat 1b60: 6f 72 2d 74 65 73 74 2d 74 79 70 65 20 63 61 72 or-test-type car 1b70: 2d 63 6f 6d 70 61 72 61 74 6f 72 20 28 63 61 72 -comparator (car 1b80: 20 6f 62 6a 29 29 0a 20 20 20 20 20 20 20 20 20 obj)). 1b90: 28 63 6f 6d 70 61 72 61 74 6f 72 2d 74 65 73 74 (comparator-test 1ba0: 2d 74 79 70 65 20 63 64 72 2d 63 6f 6d 70 61 72 -type cdr-compar 1bb0: 61 74 6f 72 20 28 63 64 72 20 6f 62 6a 29 29 29 ator (cdr obj))) 1bc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ))..(define (mak 1bd0: 65 2d 70 61 69 72 3d 3f 20 63 61 72 2d 63 6f 6d e-pair=? car-com 1be0: 70 61 72 61 74 6f 72 20 63 64 72 2d 63 6f 6d 70 parator cdr-comp 1bf0: 61 72 61 74 6f 72 29 0a 20 20 20 28 6c 61 6d 62 arator). (lamb 1c00: 64 61 20 28 61 20 62 29 0a 20 20 20 20 20 28 61 da (a b). (a 1c10: 6e 64 20 28 28 63 6f 6d 70 61 72 61 74 6f 72 2d nd ((comparator- 1c20: 65 71 75 61 6c 69 74 79 2d 70 72 65 64 69 63 61 equality-predica 1c30: 74 65 20 63 61 72 2d 63 6f 6d 70 61 72 61 74 6f te car-comparato 1c40: 72 29 20 28 63 61 72 20 61 29 20 28 63 61 72 20 r) (car a) (car 1c50: 62 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 b)). (( 1c60: 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 6c comparator-equal 1c70: 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 63 64 ity-predicate cd 1c80: 72 2d 63 6f 6d 70 61 72 61 74 6f 72 29 20 28 63 r-comparator) (c 1c90: 64 72 20 61 29 20 28 63 64 72 20 62 29 29 29 29 dr a) (cdr b)))) 1ca0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 )..(define (make 1cb0: 2d 70 61 69 72 3c 3f 20 63 61 72 2d 63 6f 6d 70 -pair<? car-comp 1cc0: 61 72 61 74 6f 72 20 63 64 72 2d 63 6f 6d 70 61 arator cdr-compa 1cd0: 72 61 74 6f 72 29 0a 20 20 20 28 6c 61 6d 62 64 rator). (lambd 1ce0: 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 28 69 a (a b). (i 1cf0: 66 20 28 3d 3f 20 63 61 72 2d 63 6f 6d 70 61 72 f (=? car-compar 1d00: 61 74 6f 72 20 28 63 61 72 20 61 29 20 28 63 61 ator (car a) (ca 1d10: 72 20 62 29 29 0a 20 20 20 20 20 20 20 20 28 3c r b)). (< 1d20: 3f 20 63 64 72 2d 63 6f 6d 70 61 72 61 74 6f 72 ? cdr-comparator 1d30: 20 28 63 64 72 20 61 29 20 28 63 64 72 20 62 29 (cdr a) (cdr b) 1d40: 29 0a 20 20 20 20 20 20 20 20 28 3c 3f 20 63 61 ). (<? ca 1d50: 72 2d 63 6f 6d 70 61 72 61 74 6f 72 20 28 63 61 r-comparator (ca 1d60: 72 20 61 29 20 28 63 61 72 20 62 29 29 29 29 29 r a) (car b))))) 1d70: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ..(define (make- 1d80: 70 61 69 72 2d 68 61 73 68 20 63 61 72 2d 63 6f pair-hash car-co 1d90: 6d 70 61 72 61 74 6f 72 20 63 64 72 2d 63 6f 6d mparator cdr-com 1da0: 70 61 72 61 74 6f 72 29 0a 20 20 20 28 6c 61 6d parator). (lam 1db0: 62 64 61 20 28 6f 62 6a 29 0a 20 20 20 20 20 28 bda (obj). ( 1dc0: 6c 65 74 20 28 28 61 63 63 20 28 6d 61 6b 65 2d let ((acc (make- 1dd0: 68 61 73 68 65 72 29 29 29 0a 20 20 20 20 20 20 hasher))). 1de0: 20 28 61 63 63 20 28 63 6f 6d 70 61 72 61 74 6f (acc (comparato 1df0: 72 2d 68 61 73 68 20 63 61 72 2d 63 6f 6d 70 61 r-hash car-compa 1e00: 72 61 74 6f 72 20 28 63 61 72 20 6f 62 6a 29 29 rator (car obj)) 1e10: 29 0a 20 20 20 20 20 20 20 28 61 63 63 20 28 63 ). (acc (c 1e20: 6f 6d 70 61 72 61 74 6f 72 2d 68 61 73 68 20 63 omparator-hash c 1e30: 64 72 2d 63 6f 6d 70 61 72 61 74 6f 72 20 28 63 dr-comparator (c 1e40: 64 72 20 6f 62 6a 29 29 29 0a 20 20 20 20 20 20 dr obj))). 1e50: 20 28 61 63 63 29 29 29 29 0a 0a 3b 3b 3b 20 4c (acc))))..;;; L 1e60: 69 73 74 20 63 6f 6d 70 61 72 61 74 6f 72 0a 0a ist comparator.. 1e70: 3b 3b 20 43 68 65 61 70 20 74 65 73 74 20 66 6f ;; Cheap test fo 1e80: 72 20 6c 69 73 74 6e 65 73 73 0a 28 64 65 66 69 r listness.(defi 1e90: 6e 65 20 28 6e 6f 72 70 3f 20 6f 62 6a 29 20 28 ne (norp? obj) ( 1ea0: 6f 72 20 28 6e 75 6c 6c 3f 20 6f 62 6a 29 20 28 or (null? obj) ( 1eb0: 70 61 69 72 3f 20 6f 62 6a 29 29 29 0a 0a 28 64 pair? obj)))..(d 1ec0: 65 66 69 6e 65 20 28 6d 61 6b 65 2d 6c 69 73 74 efine (make-list 1ed0: 2d 63 6f 6d 70 61 72 61 74 6f 72 20 65 6c 65 6d -comparator elem 1ee0: 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 ent-comparator t 1ef0: 79 70 65 2d 74 65 73 74 20 65 6d 70 74 79 3f 20 ype-test empty? 1f00: 68 65 61 64 20 74 61 69 6c 29 0a 20 20 20 28 6d head tail). (m 1f10: 61 6b 65 2d 63 6f 6d 70 61 72 61 74 6f 72 0a 20 ake-comparator. 1f20: 20 20 20 20 28 6d 61 6b 65 2d 6c 69 73 74 2d 74 (make-list-t 1f30: 79 70 65 2d 74 65 73 74 20 65 6c 65 6d 65 6e 74 ype-test element 1f40: 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 -comparator type 1f50: 2d 74 65 73 74 20 65 6d 70 74 79 3f 20 68 65 61 -test empty? hea 1f60: 64 20 74 61 69 6c 29 0a 20 20 20 20 20 28 6d 61 d tail). (ma 1f70: 6b 65 2d 6c 69 73 74 3d 3f 20 65 6c 65 6d 65 6e ke-list=? elemen 1f80: 74 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 t-comparator typ 1f90: 65 2d 74 65 73 74 20 65 6d 70 74 79 3f 20 68 65 e-test empty? he 1fa0: 61 64 20 74 61 69 6c 29 0a 20 20 20 20 20 28 6d ad tail). (m 1fb0: 61 6b 65 2d 6c 69 73 74 3c 3f 20 65 6c 65 6d 65 ake-list<? eleme 1fc0: 6e 74 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 nt-comparator ty 1fd0: 70 65 2d 74 65 73 74 20 65 6d 70 74 79 3f 20 68 pe-test empty? h 1fe0: 65 61 64 20 74 61 69 6c 29 0a 20 20 20 20 20 28 ead tail). ( 1ff0: 6d 61 6b 65 2d 6c 69 73 74 2d 68 61 73 68 20 65 make-list-hash e 2000: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 2010: 72 20 74 79 70 65 2d 74 65 73 74 20 65 6d 70 74 r type-test empt 2020: 79 3f 20 68 65 61 64 20 74 61 69 6c 29 29 29 0a y? head tail))). 2030: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ..(define (make- 2040: 6c 69 73 74 2d 74 79 70 65 2d 74 65 73 74 20 65 list-type-test e 2050: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 2060: 72 20 74 79 70 65 2d 74 65 73 74 20 65 6d 70 74 r type-test empt 2070: 79 3f 20 68 65 61 64 20 74 61 69 6c 29 0a 20 20 y? head tail). 2080: 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 0a 20 20 (lambda (obj). 2090: 20 20 28 61 6e 64 0a 20 20 20 20 20 20 28 74 79 (and. (ty 20a0: 70 65 2d 74 65 73 74 20 6f 62 6a 29 0a 20 20 20 pe-test obj). 20b0: 20 20 20 28 6c 65 74 20 28 28 65 6c 65 6d 2d 74 (let ((elem-t 20c0: 79 70 65 2d 74 65 73 74 20 28 63 6f 6d 70 61 72 ype-test (compar 20d0: 61 74 6f 72 2d 74 79 70 65 2d 74 65 73 74 2d 70 ator-type-test-p 20e0: 72 65 64 69 63 61 74 65 20 65 6c 65 6d 65 6e 74 redicate element 20f0: 2d 63 6f 6d 70 61 72 61 74 6f 72 29 29 29 0a 20 -comparator))). 2100: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop 2110: 20 28 28 6f 62 6a 20 6f 62 6a 29 29 0a 20 20 20 ((obj obj)). 2120: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond. 2130: 20 20 20 20 20 20 20 20 20 28 28 65 6d 70 74 79 ((empty 2140: 3f 20 6f 62 6a 29 20 23 74 29 0a 20 20 20 20 20 ? obj) #t). 2150: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 65 6c ((not (el 2160: 65 6d 2d 74 79 70 65 2d 74 65 73 74 20 28 68 65 em-type-test (he 2170: 61 64 20 6f 62 6a 29 29 29 20 23 66 29 0a 20 20 ad obj))) #f). 2180: 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 (else 2190: 28 6c 6f 6f 70 20 28 74 61 69 6c 20 6f 62 6a 29 (loop (tail obj) 21a0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin 21b0: 65 20 28 6d 61 6b 65 2d 6c 69 73 74 3d 3f 20 65 e (make-list=? e 21c0: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 21d0: 72 20 74 79 70 65 2d 74 65 73 74 20 65 6d 70 74 r type-test empt 21e0: 79 3f 20 68 65 61 64 20 74 61 69 6c 29 0a 20 20 y? head tail). 21f0: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 (lambda (a b). 2200: 20 20 28 6c 65 74 20 28 28 65 6c 65 6d 3d 3f 20 (let ((elem=? 2210: 28 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 (comparator-equa 2220: 6c 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 65 lity-predicate e 2230: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 2240: 72 29 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 r))). (let 2250: 6c 6f 6f 70 20 28 28 61 20 61 29 20 28 62 20 62 loop ((a a) (b b 2260: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 64 )). (cond 2270: 0a 20 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 . ((and 2280: 20 28 65 6d 70 74 79 3f 20 61 29 20 28 65 6d 70 (empty? a) (emp 2290: 74 79 3f 20 62 29 20 23 74 29 29 0a 20 20 20 20 ty? b) #t)). 22a0: 20 20 20 20 20 20 28 28 65 6d 70 74 79 3f 20 61 ((empty? a 22b0: 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 ) #f). 22c0: 28 28 65 6d 70 74 79 3f 20 62 29 20 23 66 29 0a ((empty? b) #f). 22d0: 20 20 20 20 20 20 20 20 20 20 28 28 65 6c 65 6d ((elem 22e0: 3d 3f 20 28 68 65 61 64 20 61 29 20 28 68 65 61 =? (head a) (hea 22f0: 64 20 62 29 29 20 28 6c 6f 6f 70 20 28 74 61 69 d b)) (loop (tai 2300: 6c 20 61 29 20 28 74 61 69 6c 20 62 29 29 29 0a l a) (tail b))). 2310: 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 (else 2320: 23 66 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))))..(defin 2330: 65 20 28 6d 61 6b 65 2d 6c 69 73 74 3c 3f 20 65 e (make-list<? e 2340: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 2350: 72 20 74 79 70 65 2d 74 65 73 74 20 65 6d 70 74 r type-test empt 2360: 79 3f 20 68 65 61 64 20 74 61 69 6c 29 0a 20 20 y? head tail). 2370: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 (lambda (a b). 2380: 20 20 28 6c 65 74 20 28 28 65 6c 65 6d 3d 3f 20 (let ((elem=? 2390: 28 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 (comparator-equa 23a0: 6c 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 65 lity-predicate e 23b0: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 23c0: 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 r)). (e 23d0: 6c 65 6d 3c 3f 20 28 63 6f 6d 70 61 72 61 74 6f lem<? (comparato 23e0: 72 2d 6f 72 64 65 72 69 6e 67 2d 70 72 65 64 69 r-ordering-predi 23f0: 63 61 74 65 20 65 6c 65 6d 65 6e 74 2d 63 6f 6d cate element-com 2400: 70 61 72 61 74 6f 72 29 29 29 0a 20 20 20 20 20 parator))). 2410: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 61 20 61 (let loop ((a a 2420: 29 20 28 62 20 62 29 29 0a 20 20 20 20 20 20 20 ) (b b)). 2430: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond. 2440: 20 28 28 61 6e 64 20 28 65 6d 70 74 79 3f 20 61 ((and (empty? a 2450: 29 20 28 65 6d 70 74 79 3f 20 62 29 20 23 66 29 ) (empty? b) #f) 2460: 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 65 6d ). ((em 2470: 70 74 79 3f 20 61 29 20 23 74 29 0a 20 20 20 20 pty? a) #t). 2480: 20 20 20 20 20 20 28 28 65 6d 70 74 79 3f 20 62 ((empty? b 2490: 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 ) #f). 24a0: 28 28 65 6c 65 6d 3d 3f 20 28 68 65 61 64 20 61 ((elem=? (head a 24b0: 29 20 28 68 65 61 64 20 62 29 29 20 28 6c 6f 6f ) (head b)) (loo 24c0: 70 20 28 74 61 69 6c 20 61 29 20 28 74 61 69 6c p (tail a) (tail 24d0: 20 62 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 b))). 24e0: 28 28 65 6c 65 6d 3c 3f 20 28 68 65 61 64 20 61 ((elem<? (head a 24f0: 29 20 28 68 65 61 64 20 62 29 29 20 23 74 29 0a ) (head b)) #t). 2500: 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 (else 2510: 23 66 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))))..(defin 2520: 65 20 28 6d 61 6b 65 2d 6c 69 73 74 2d 68 61 73 e (make-list-has 2530: 68 20 65 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 h element-compar 2540: 61 74 6f 72 20 74 79 70 65 2d 74 65 73 74 20 65 ator type-test e 2550: 6d 70 74 79 3f 20 68 65 61 64 20 74 61 69 6c 29 mpty? head tail) 2560: 0a 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 . (lambda (obj) 2570: 0a 20 20 20 20 28 6c 65 74 20 28 28 65 6c 65 6d . (let ((elem 2580: 2d 68 61 73 68 20 28 63 6f 6d 70 61 72 61 74 6f -hash (comparato 2590: 72 2d 68 61 73 68 2d 66 75 6e 63 74 69 6f 6e 20 r-hash-function 25a0: 65 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 element-comparat 25b0: 6f 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 or)). ( 25c0: 61 63 63 20 28 6d 61 6b 65 2d 68 61 73 68 65 72 acc (make-hasher 25d0: 29 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c ))). (let l 25e0: 6f 6f 70 20 28 28 6f 62 6a 20 6f 62 6a 29 29 0a oop ((obj obj)). 25f0: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond. 2600: 20 20 20 20 20 20 20 20 28 28 65 6d 70 74 79 3f ((empty? 2610: 20 6f 62 6a 29 20 28 61 63 63 29 29 0a 20 20 20 obj) (acc)). 2620: 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 61 63 (else (ac 2630: 63 20 28 65 6c 65 6d 2d 68 61 73 68 20 28 68 65 c (elem-hash (he 2640: 61 64 20 6f 62 6a 29 29 29 20 28 6c 6f 6f 70 20 ad obj))) (loop 2650: 28 74 61 69 6c 20 6f 62 6a 29 29 29 29 29 29 29 (tail obj))))))) 2660: 29 0a 0a 0a 3b 3b 3b 20 56 65 63 74 6f 72 20 63 )...;;; Vector c 2670: 6f 6d 70 61 72 61 74 6f 72 0a 0a 28 64 65 66 69 omparator..(defi 2680: 6e 65 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 2d ne (make-vector- 2690: 63 6f 6d 70 61 72 61 74 6f 72 20 65 6c 65 6d 65 comparator eleme 26a0: 6e 74 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 nt-comparator ty 26b0: 70 65 2d 74 65 73 74 20 6c 65 6e 67 74 68 20 72 pe-test length r 26c0: 65 66 29 0a 20 20 20 20 20 28 6d 61 6b 65 2d 63 ef). (make-c 26d0: 6f 6d 70 61 72 61 74 6f 72 0a 20 20 20 20 20 20 omparator. 26e0: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 2d 74 79 (make-vector-ty 26f0: 70 65 2d 74 65 73 74 20 65 6c 65 6d 65 6e 74 2d pe-test element- 2700: 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 2d comparator type- 2710: 74 65 73 74 20 6c 65 6e 67 74 68 20 72 65 66 29 test length ref) 2720: 0a 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 76 65 . (make-ve 2730: 63 74 6f 72 3d 3f 20 65 6c 65 6d 65 6e 74 2d 63 ctor=? element-c 2740: 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 2d 74 omparator type-t 2750: 65 73 74 20 6c 65 6e 67 74 68 20 72 65 66 29 0a est length ref). 2760: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 76 65 63 (make-vec 2770: 74 6f 72 3c 3f 20 65 6c 65 6d 65 6e 74 2d 63 6f tor<? element-co 2780: 6d 70 61 72 61 74 6f 72 20 74 79 70 65 2d 74 65 mparator type-te 2790: 73 74 20 6c 65 6e 67 74 68 20 72 65 66 29 0a 20 st length ref). 27a0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 76 65 63 74 (make-vect 27b0: 6f 72 2d 68 61 73 68 20 65 6c 65 6d 65 6e 74 2d or-hash element- 27c0: 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 2d comparator type- 27d0: 74 65 73 74 20 6c 65 6e 67 74 68 20 72 65 66 29 test length ref) 27e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ))..(define (mak 27f0: 65 2d 76 65 63 74 6f 72 2d 74 79 70 65 2d 74 65 e-vector-type-te 2800: 73 74 20 65 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 st element-compa 2810: 72 61 74 6f 72 20 74 79 70 65 2d 74 65 73 74 20 rator type-test 2820: 6c 65 6e 67 74 68 20 72 65 66 29 0a 20 20 28 6c length ref). (l 2830: 61 6d 62 64 61 20 28 6f 62 6a 29 0a 20 20 20 20 ambda (obj). 2840: 28 61 6e 64 0a 20 20 20 20 20 20 28 74 79 70 65 (and. (type 2850: 2d 74 65 73 74 20 6f 62 6a 29 0a 20 20 20 20 20 -test obj). 2860: 20 28 6c 65 74 20 28 28 65 6c 65 6d 2d 74 79 70 (let ((elem-typ 2870: 65 2d 74 65 73 74 20 28 63 6f 6d 70 61 72 61 74 e-test (comparat 2880: 6f 72 2d 74 79 70 65 2d 74 65 73 74 2d 70 72 65 or-type-test-pre 2890: 64 69 63 61 74 65 20 65 6c 65 6d 65 6e 74 2d 63 dicate element-c 28a0: 6f 6d 70 61 72 61 74 6f 72 29 29 0a 20 20 20 20 omparator)). 28b0: 20 20 20 20 20 20 20 20 28 6c 65 6e 20 28 6c 65 (len (le 28c0: 6e 67 74 68 20 6f 62 6a 29 29 29 0a 20 20 20 20 ngth obj))). 28d0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop (( 28e0: 6e 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 n 0)). 28f0: 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 (cond. 2900: 20 20 28 28 3d 20 6e 20 6c 65 6e 29 20 23 74 29 ((= n len) #t) 2910: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e . ((n 2920: 6f 74 20 28 65 6c 65 6d 2d 74 79 70 65 2d 74 65 ot (elem-type-te 2930: 73 74 20 28 72 65 66 20 6f 62 6a 20 6e 29 29 29 st (ref obj n))) 2940: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f). 2950: 20 28 65 6c 73 65 20 28 6c 6f 6f 70 20 28 2b 20 (else (loop (+ 2960: 6e 20 31 29 29 29 29 29 29 29 29 29 0a 0a 28 64 n 1)))))))))..(d 2970: 65 66 69 6e 65 20 28 6d 61 6b 65 2d 76 65 63 74 efine (make-vect 2980: 6f 72 3d 3f 20 65 6c 65 6d 65 6e 74 2d 63 6f 6d or=? element-com 2990: 70 61 72 61 74 6f 72 20 74 79 70 65 2d 74 65 73 parator type-tes 29a0: 74 20 6c 65 6e 67 74 68 20 72 65 66 29 0a 20 20 t length ref). 29b0: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 (lambda (a b). 29c0: 20 20 20 20 28 61 6e 64 0a 20 20 20 20 20 20 20 (and. 29d0: 28 3d 20 28 6c 65 6e 67 74 68 20 61 29 20 28 6c (= (length a) (l 29e0: 65 6e 67 74 68 20 62 29 29 0a 20 20 20 20 20 20 ength b)). 29f0: 20 28 6c 65 74 20 28 28 65 6c 65 6d 3d 3f 20 28 (let ((elem=? ( 2a00: 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 6c comparator-equal 2a10: 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 65 6c ity-predicate el 2a20: 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f 72 ement-comparator 2a30: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 2a40: 28 6c 65 6e 20 28 6c 65 6e 67 74 68 20 62 29 29 (len (length b)) 2a50: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 ). (let 2a60: 6c 6f 6f 70 20 28 28 6e 20 30 29 29 0a 20 20 20 loop ((n 0)). 2a70: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond. 2a80: 20 20 20 20 20 20 20 20 20 20 20 28 28 3d 20 6e ((= n 2a90: 20 6c 65 6e 29 20 23 74 29 0a 20 20 20 20 20 20 len) #t). 2aa0: 20 20 20 20 20 20 20 28 28 65 6c 65 6d 3d 3f 20 ((elem=? 2ab0: 28 72 65 66 20 61 20 6e 29 20 28 72 65 66 20 62 (ref a n) (ref b 2ac0: 20 6e 29 29 20 28 6c 6f 6f 70 20 28 2b 20 6e 20 n)) (loop (+ n 2ad0: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1))). 2ae0: 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 29 29 (else #f)))))) 2af0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 )..(define (make 2b00: 2d 76 65 63 74 6f 72 3c 3f 20 65 6c 65 6d 65 6e -vector<? elemen 2b10: 74 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 t-comparator typ 2b20: 65 2d 74 65 73 74 20 6c 65 6e 67 74 68 20 72 65 e-test length re 2b30: 66 29 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 61 f). (lambda (a 2b40: 20 62 29 0a 20 20 20 20 20 28 63 6f 6e 64 0a 20 b). (cond. 2b50: 20 20 20 20 20 20 28 28 3c 20 28 6c 65 6e 67 74 ((< (lengt 2b60: 68 20 61 29 20 28 6c 65 6e 67 74 68 20 62 29 29 h a) (length b)) 2b70: 20 23 74 29 0a 20 20 20 20 20 20 20 28 28 3e 20 #t). ((> 2b80: 28 6c 65 6e 67 74 68 20 61 29 20 28 6c 65 6e 67 (length a) (leng 2b90: 74 68 20 62 29 29 20 23 66 29 0a 20 20 20 20 20 th b)) #f). 2ba0: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 (else. 2bb0: 20 20 28 6c 65 74 20 28 28 65 6c 65 6d 3d 3f 20 (let ((elem=? 2bc0: 28 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 (comparator-equa 2bd0: 6c 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 65 lity-predicate e 2be0: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 2bf0: 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 r)). 2c00: 20 28 65 6c 65 6d 3c 3f 20 28 63 6f 6d 70 61 72 (elem<? (compar 2c10: 61 74 6f 72 2d 6f 72 64 65 72 69 6e 67 2d 70 72 ator-ordering-pr 2c20: 65 64 69 63 61 74 65 20 65 6c 65 6d 65 6e 74 2d edicate element- 2c30: 63 6f 6d 70 61 72 61 74 6f 72 29 29 0a 20 20 20 comparator)). 2c40: 20 20 20 20 20 20 20 20 20 20 28 6c 65 6e 20 28 (len ( 2c50: 6c 65 6e 67 74 68 20 61 29 29 29 0a 20 20 20 20 length a))). 2c60: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop ( 2c70: 28 6e 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 (n 0)). 2c80: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond. 2c90: 20 20 20 20 20 28 28 3d 20 6e 20 6c 65 6e 29 20 ((= n len) 2ca0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f). 2cb0: 20 28 28 65 6c 65 6d 3d 3f 20 28 72 65 66 20 61 ((elem=? (ref a 2cc0: 20 6e 29 20 28 72 65 66 20 62 20 6e 29 29 20 28 n) (ref b n)) ( 2cd0: 6c 6f 6f 70 20 28 2b 20 6e 20 31 29 29 29 0a 20 loop (+ n 1))). 2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 6c ((el 2cf0: 65 6d 3c 3f 20 28 72 65 66 20 61 20 6e 29 20 28 em<? (ref a n) ( 2d00: 72 65 66 20 62 20 6e 29 29 20 23 74 29 0a 20 20 ref b n)) #t). 2d10: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else 2d20: 20 23 66 29 29 29 29 29 29 29 29 0a 0a 28 64 65 #f))))))))..(de 2d30: 66 69 6e 65 20 28 6d 61 6b 65 2d 76 65 63 74 6f fine (make-vecto 2d40: 72 2d 68 61 73 68 20 65 6c 65 6d 65 6e 74 2d 63 r-hash element-c 2d50: 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 65 2d 74 omparator type-t 2d60: 65 73 74 20 6c 65 6e 67 74 68 20 72 65 66 29 0a est length ref). 2d70: 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 0a (lambda (obj). 2d80: 20 20 20 20 28 6c 65 74 20 28 28 65 6c 65 6d 2d (let ((elem- 2d90: 68 61 73 68 20 28 63 6f 6d 70 61 72 61 74 6f 72 hash (comparator 2da0: 2d 68 61 73 68 2d 66 75 6e 63 74 69 6f 6e 20 65 -hash-function e 2db0: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato 2dc0: 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 61 r)). (a 2dd0: 63 63 20 28 6d 61 6b 65 2d 68 61 73 68 65 72 29 cc (make-hasher) 2de0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 6e ). (len 2df0: 20 28 6c 65 6e 67 74 68 20 6f 62 6a 29 29 29 0a (length obj))). 2e00: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop 2e10: 28 28 6e 20 30 29 29 0a 20 20 20 20 20 20 20 20 ((n 0)). 2e20: 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 (cond. 2e30: 28 28 3d 20 6e 20 6c 65 6e 29 20 28 61 63 63 29 ((= n len) (acc) 2e40: 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 ). (els 2e50: 65 20 28 61 63 63 20 28 65 6c 65 6d 2d 68 61 73 e (acc (elem-has 2e60: 68 20 28 72 65 66 20 6f 62 6a 20 6e 29 29 29 20 h (ref obj n))) 2e70: 28 6c 6f 6f 70 20 28 2b 20 6e 20 31 29 29 29 29 (loop (+ n 1)))) 2e80: 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 ))))..;; (define 2e90: 20 28 73 74 72 69 6e 67 2d 68 61 73 68 20 6f 62 (string-hash ob 2ea0: 6a 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 61 j).;; (let ((a 2eb0: 63 63 20 28 6d 61 6b 65 2d 68 61 73 68 65 72 29 cc (make-hasher) 2ec0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 6c 65 ).;; (le 2ed0: 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 n (string-length 2ee0: 20 6f 62 6a 29 29 29 0a 3b 3b 20 20 20 20 20 28 obj))).;; ( 2ef0: 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 20 30 29 29 let loop ((n 0)) 2f00: 0a 3b 3b 20 20 20 20 20 20 20 28 63 6f 6e 64 0a .;; (cond. 2f10: 3b 3b 20 20 20 20 20 20 20 20 20 28 28 3d 20 6e ;; ((= n 2f20: 20 6c 65 6e 29 20 28 61 63 63 29 29 0a 3b 3b 20 len) (acc)).;; 2f30: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 61 (else (a 2f40: 63 63 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 cc (char->intege 2f50: 72 20 28 73 74 72 69 6e 67 2d 72 65 66 20 6f 62 r (string-ref ob 2f60: 6a 20 6e 29 29 29 20 28 6c 6f 6f 70 20 28 2b 20 j n))) (loop (+ 2f70: 6e 20 31 29 29 29 29 29 29 29 0a 0a n 1)))))))..