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)))))))..