0000: 3b 3b 3b 3b 20 49 6d 70 6c 65 6d 65 6e 74 61 74 ;;;; Implementat
0010: 69 6f 6e 20 6f 66 20 67 65 6e 65 72 61 6c 20 73 ion of general s
0020: 65 74 73 20 61 6e 64 20 62 61 67 73 20 66 6f 72 ets and bags for
0030: 20 53 52 46 49 20 31 31 33 0a 0a 3b 3b 3b 20 41 SRFI 113..;;; A
0040: 20 22 73 6f 62 22 20 6f 62 6a 65 63 74 20 69 73 "sob" object is
0050: 20 74 68 65 20 72 65 70 72 65 73 65 6e 74 61 74 the representat
0060: 69 6f 6e 20 6f 66 20 62 6f 74 68 20 73 65 74 73 ion of both sets
0070: 20 61 6e 64 20 62 61 67 73 2e 0a 3b 3b 3b 20 54 and bags..;;; T
0080: 68 69 73 20 61 6c 6c 6f 77 73 20 65 61 63 68 20 his allows each
0090: 73 65 74 2d 2a 20 61 6e 64 20 62 61 67 2d 2a 20 set-* and bag-*
00a0: 70 72 6f 63 65 64 75 72 65 20 74 6f 20 62 65 20 procedure to be
00b0: 69 6d 70 6c 65 6d 65 6e 74 65 64 0a 3b 3b 3b 20 implemented.;;;
00c0: 75 73 69 6e 67 20 74 68 65 20 73 61 6d 65 20 63 using the same c
00d0: 6f 64 65 2c 20 77 69 74 68 6f 75 74 20 68 61 76 ode, without hav
00e0: 69 6e 67 20 74 6f 20 64 65 61 6c 20 69 6e 20 75 ing to deal in u
00f0: 67 6c 79 20 69 6e 64 69 72 65 63 74 69 6f 6e 73 gly indirections
0100: 0a 3b 3b 3b 20 6f 76 65 72 20 74 68 65 20 66 69 .;;; over the fi
0110: 65 6c 64 20 61 63 63 65 73 73 6f 72 73 2e 20 20 eld accessors.
0120: 54 68 65 72 65 20 61 72 65 20 74 68 72 65 65 20 There are three
0130: 66 69 65 6c 64 73 2c 20 22 73 6f 62 2d 6d 75 6c fields, "sob-mul
0140: 74 69 3f 22 2c 0a 3b 3b 3b 20 22 73 6f 62 2d 68 ti?",.;;; "sob-h
0150: 61 73 68 2d 74 61 62 6c 65 22 2c 20 61 6e 64 20 ash-table", and
0160: 22 73 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 2e "sob-comparator.
0170: 22 0a 0a 3b 3b 3b 20 54 68 65 20 76 61 6c 75 65 "..;;; The value
0180: 20 6f 66 20 22 73 6f 62 2d 6d 75 6c 74 69 3f 22 of "sob-multi?"
0190: 20 69 73 20 23 74 20 66 6f 72 20 62 61 67 73 20 is #t for bags
01a0: 61 6e 64 20 23 66 20 66 6f 72 20 73 65 74 73 2e and #f for sets.
01b0: 0a 3b 3b 3b 20 22 53 6f 62 2d 68 61 73 68 2d 74 .;;; "Sob-hash-t
01c0: 61 62 6c 65 22 20 6d 61 70 73 20 74 68 65 20 65 able" maps the e
01d0: 6c 65 6d 65 6e 74 73 20 6f 66 20 74 68 65 20 73 lements of the s
01e0: 6f 62 20 74 6f 20 74 68 65 20 6e 75 6d 62 65 72 ob to the number
01f0: 20 6f 66 20 74 69 6d 65 73 0a 3b 3b 3b 20 74 68 of times.;;; th
0200: 65 20 65 6c 65 6d 65 6e 74 20 61 70 70 65 61 72 e element appear
0210: 73 2c 20 77 68 69 63 68 20 69 73 20 61 6c 77 61 s, which is alwa
0220: 79 73 20 31 20 66 6f 72 20 61 20 73 65 74 2c 20 ys 1 for a set,
0230: 61 6e 79 20 70 6f 73 69 74 69 76 65 20 76 61 6c any positive val
0240: 75 65 0a 3b 3b 3b 20 66 6f 72 20 61 20 62 61 67 ue.;;; for a bag
0250: 2e 20 20 22 53 6f 62 2d 63 6f 6d 70 61 72 61 74 . "Sob-comparat
0260: 6f 72 22 20 69 73 20 74 68 65 20 63 6f 6d 70 61 or" is the compa
0270: 72 61 74 6f 72 20 66 6f 72 20 74 68 65 20 65 6c rator for the el
0280: 65 6d 65 6e 74 73 20 6f 66 0a 3b 3b 3b 20 74 68 ements of.;;; th
0290: 65 20 73 65 74 2e 0a 0a 3b 3b 3b 20 4e 6f 74 65 e set...;;; Note
02a0: 20 74 68 61 74 20 73 6f 62 2d 2a 20 70 72 6f 63 that sob-* proc
02b0: 65 64 75 72 65 73 20 64 6f 20 6e 6f 74 20 64 6f edures do not do
02c0: 20 74 79 70 65 20 63 68 65 63 6b 69 6e 67 20 6f type checking o
02d0: 72 20 28 74 79 70 69 63 61 6c 6c 79 29 20 74 68 r (typically) th
02e0: 65 0a 3b 3b 3b 20 63 6f 70 79 69 6e 67 20 72 65 e.;;; copying re
02f0: 71 75 69 72 65 64 20 66 6f 72 20 73 75 70 70 6f quired for suppo
0300: 72 74 69 6e 67 20 70 75 72 65 20 66 75 6e 63 74 rting pure funct
0310: 69 6f 6e 61 6c 20 75 70 64 61 74 65 2e 20 20 54 ional update. T
0320: 68 65 73 65 20 74 68 69 6e 67 73 0a 3b 3b 3b 20 hese things.;;;
0330: 61 72 65 20 64 6f 6e 65 20 62 79 20 74 68 65 20 are done by the
0340: 73 65 74 2d 2a 20 61 6e 64 20 62 61 67 2d 2a 20 set-* and bag-*
0350: 70 72 6f 63 65 64 75 72 65 73 2c 20 77 68 69 63 procedures, whic
0360: 68 20 61 72 65 20 65 78 74 65 72 6e 61 6c 6c 79 h are externally
0370: 0a 3b 3b 3b 20 65 78 70 6f 73 65 64 20 28 62 75 .;;; exposed (bu
0380: 74 20 74 72 69 76 69 61 6c 20 61 6e 64 20 6d 6f t trivial and mo
0390: 73 74 6c 79 20 75 6e 63 6f 6d 6d 65 6e 74 65 64 stly uncommented
03a0: 20 62 65 6c 6f 77 29 2e 0a 0a 0a 3b 3b 3b 20 53 below)....;;; S
03b0: 68 69 6d 20 74 6f 20 63 6f 6e 76 65 72 74 20 66 him to convert f
03c0: 72 6f 6d 20 53 52 46 49 20 36 39 20 74 6f 20 74 rom SRFI 69 to t
03d0: 68 65 20 66 75 74 75 72 65 20 22 69 6e 74 65 72 he future "inter
03e0: 6d 65 64 69 61 74 65 20 68 61 73 68 20 74 61 62 mediate hash tab
03f0: 6c 65 73 22 0a 3b 3b 3b 20 53 52 46 49 2e 20 20 les".;;; SRFI.
0400: 55 6e 66 6f 72 74 75 6e 61 74 65 6c 79 2c 20 68 Unfortunately, h
0410: 61 73 68 2d 74 61 62 6c 65 2d 66 6f 6c 64 20 69 ash-table-fold i
0420: 73 20 69 6e 63 6f 6d 70 61 74 69 62 6c 65 20 62 s incompatible b
0430: 65 74 77 65 65 6e 20 74 68 65 20 74 77 6f 0a 3b etween the two.;
0440: 3b 3b 20 61 6e 64 20 73 6f 20 69 73 20 6e 6f 74 ;; and so is not
0450: 20 75 73 61 62 6c 65 2e 0a 0a 3b 3b 20 54 68 69 usable...;; Thi
0460: 73 20 77 69 6c 6c 20 62 65 20 6a 75 73 74 20 22 s will be just "
0470: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 22 make-hash-table"
0480: 20 69 6e 20 66 75 74 75 72 65 2e 0a 0a 28 64 65 in future...(de
0490: 66 69 6e 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d fine (make-hash-
04a0: 74 61 62 6c 65 2f 63 6f 6d 70 61 72 61 74 6f 72 table/comparator
04b0: 20 63 6f 6d 70 61 72 61 74 6f 72 29 0a 20 20 28 comparator). (
04c0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 20 make-hash-table
04d0: 28 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 (comparator-equa
04e0: 6c 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 63 lity-predicate c
04f0: 6f 6d 70 61 72 61 74 6f 72 29 0a 20 20 20 20 20 omparator).
0500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
0510: 6f 64 75 6c 69 7a 65 72 20 28 63 6f 6d 70 61 72 odulizer (compar
0520: 61 74 6f 72 2d 68 61 73 68 2d 66 75 6e 63 74 69 ator-hash-functi
0530: 6f 6e 20 63 6f 6d 70 61 72 61 74 6f 72 29 29 29 on comparator)))
0540: 29 0a 0a 3b 3b 20 54 68 65 73 65 20 74 77 6f 20 )..;; These two
0550: 70 72 6f 63 65 64 75 72 65 73 20 61 64 6a 75 73 procedures adjus
0560: 74 20 66 6f 72 20 74 68 65 20 6d 69 73 6d 61 74 t for the mismat
0570: 63 68 20 62 65 74 77 65 65 6e 20 74 68 65 20 68 ch between the h
0580: 61 73 68 20 66 75 6e 63 74 69 6f 6e 73 0a 3b 3b ash functions.;;
0590: 20 6f 66 20 53 52 46 49 20 31 31 34 2c 20 77 68 of SRFI 114, wh
05a0: 69 63 68 20 72 65 74 75 72 6e 20 61 20 70 6f 74 ich return a pot
05b0: 65 6e 74 69 61 6c 6c 79 20 75 6e 62 6f 75 6e 64 entially unbound
05c0: 65 64 20 6e 6f 6e 2d 6e 65 67 61 74 69 76 65 20 ed non-negative
05d0: 69 6e 74 65 67 65 72 2c 0a 3b 3b 20 61 6e 64 20 integer,.;; and
05e0: 74 68 65 20 68 61 73 68 20 66 75 6e 63 74 69 6f the hash functio
05f0: 6e 73 20 6f 66 20 53 52 46 49 20 36 39 2c 20 77 ns of SRFI 69, w
0600: 68 69 63 68 20 65 78 70 65 63 74 20 74 6f 20 62 hich expect to b
0610: 65 20 61 62 6c 65 20 74 6f 20 70 61 73 73 0a 3b e able to pass.;
0620: 3b 20 61 20 73 65 63 6f 6e 64 20 61 72 67 75 6d ; a second argum
0630: 65 6e 74 20 77 68 69 63 68 20 69 73 20 61 6e 20 ent which is an
0640: 75 70 70 65 72 20 62 6f 75 6e 64 2e 0a 0a 28 64 upper bound...(d
0650: 65 66 69 6e 65 20 28 6d 6f 64 75 6c 69 7a 65 72 efine (modulizer
0660: 20 68 61 73 68 2d 66 75 6e 63 74 69 6f 6e 29 0a hash-function).
0670: 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 (case-lambda.
0680: 20 20 20 28 28 6f 62 6a 29 20 28 68 61 73 68 2d ((obj) (hash-
0690: 66 75 6e 63 74 69 6f 6e 20 6f 62 6a 29 29 0a 20 function obj)).
06a0: 20 20 20 28 28 6f 62 6a 20 6c 69 6d 69 74 29 20 ((obj limit)
06b0: 28 6d 6f 64 75 6c 6f 20 28 68 61 73 68 2d 66 75 (modulo (hash-fu
06c0: 6e 63 74 69 6f 6e 20 6f 62 6a 29 20 6c 69 6d 69 nction obj) limi
06d0: 74 29 29 29 29 0a 0a 3b 3b 20 53 69 6d 70 6c 65 t))))..;; Simple
06e0: 20 72 65 6e 61 6d 69 6e 67 2e 20 20 43 68 69 63 renaming. Chic
06f0: 6b 65 6e 27 73 20 69 6d 70 6c 65 6d 65 6e 74 61 ken's implementa
0700: 74 69 6f 6e 20 6f 66 20 53 52 46 49 20 36 39 20 tion of SRFI 69
0710: 70 72 6f 76 69 64 65 73 0a 3b 3b 20 68 61 73 68 provides.;; hash
0720: 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 20 -table-for-each
0730: 61 73 20 61 20 6e 6f 6e 2d 73 74 61 6e 64 61 72 as a non-standar
0740: 64 20 65 78 74 65 6e 73 69 6f 6e 2c 20 77 69 74 d extension, wit
0750: 68 20 74 68 65 20 6f 70 70 6f 73 69 74 65 0a 3b h the opposite.;
0760: 3b 20 6f 72 64 65 72 2c 20 73 6f 20 69 6e 20 74 ; order, so in t
0770: 68 65 20 43 68 69 63 6b 65 6e 20 6d 6f 64 75 6c he Chicken modul
0780: 65 20 77 65 20 73 75 70 70 72 65 73 73 20 69 6d e we suppress im
0790: 70 6f 72 74 69 6e 67 20 69 74 20 74 6f 20 6d 75 porting it to mu
07a0: 66 66 6c 65 0a 3b 3b 20 74 68 65 20 63 6f 6e 66 ffle.;; the conf
07b0: 6c 69 63 74 20 77 61 72 6e 69 6e 67 2e 0a 0a 28 lict warning...(
07c0: 64 65 66 69 6e 65 20 68 61 73 68 2d 74 61 62 6c define hash-tabl
07d0: 65 2d 63 6f 6e 74 61 69 6e 73 3f 20 68 61 73 68 e-contains? hash
07e0: 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 3f 29 0a -table-exists?).
07f0: 0a 28 64 65 66 69 6e 65 20 28 68 61 73 68 2d 74 .(define (hash-t
0800: 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 20 70 72 able-for-each pr
0810: 6f 63 20 68 61 73 68 2d 74 61 62 6c 65 29 0a 20 oc hash-table).
0820: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 77 61 6c (hash-table-wal
0830: 6b 20 68 61 73 68 2d 74 61 62 6c 65 20 70 72 6f k hash-table pro
0840: 63 29 29 0a 0a 0a 3b 3b 3b 20 52 65 63 6f 72 64 c))...;;; Record
0850: 20 64 65 66 69 6e 69 74 69 6f 6e 20 61 6e 64 20 definition and
0860: 63 6f 72 65 20 74 79 70 69 6e 67 2f 63 68 65 63 core typing/chec
0870: 6b 69 6e 67 20 70 72 6f 63 65 64 75 72 65 73 0a king procedures.
0880: 0a 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d .(define-record-
0890: 74 79 70 65 20 73 6f 62 0a 20 20 28 72 61 77 2d type sob. (raw-
08a0: 6d 61 6b 65 2d 73 6f 62 20 68 61 73 68 2d 74 61 make-sob hash-ta
08b0: 62 6c 65 20 63 6f 6d 70 61 72 61 74 6f 72 20 6d ble comparator m
08c0: 75 6c 74 69 3f 29 0a 20 20 73 6f 62 3f 0a 20 20 ulti?). sob?.
08d0: 28 68 61 73 68 2d 74 61 62 6c 65 20 73 6f 62 2d (hash-table sob-
08e0: 68 61 73 68 2d 74 61 62 6c 65 29 0a 20 20 28 63 hash-table). (c
08f0: 6f 6d 70 61 72 61 74 6f 72 20 73 6f 62 2d 63 6f omparator sob-co
0900: 6d 70 61 72 61 74 6f 72 29 0a 20 20 28 6d 75 6c mparator). (mul
0910: 74 69 3f 20 73 6f 62 2d 6d 75 6c 74 69 3f 29 29 ti? sob-multi?))
0920: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 3f 20 ..(define (set?
0930: 6f 62 6a 29 20 28 61 6e 64 20 28 73 6f 62 3f 20 obj) (and (sob?
0940: 6f 62 6a 29 20 28 6e 6f 74 20 28 73 6f 62 2d 6d obj) (not (sob-m
0950: 75 6c 74 69 3f 20 6f 62 6a 29 29 29 29 0a 0a 28 ulti? obj))))..(
0960: 64 65 66 69 6e 65 20 28 62 61 67 3f 20 6f 62 6a define (bag? obj
0970: 29 20 28 61 6e 64 20 28 73 6f 62 3f 20 6f 62 6a ) (and (sob? obj
0980: 29 20 28 73 6f 62 2d 6d 75 6c 74 69 3f 20 6f 62 ) (sob-multi? ob
0990: 6a 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 j)))..(define (c
09a0: 68 65 63 6b 2d 73 65 74 20 6f 62 6a 29 20 28 69 heck-set obj) (i
09b0: 66 20 28 6e 6f 74 20 28 73 65 74 3f 20 6f 62 6a f (not (set? obj
09c0: 29 29 20 28 65 72 72 6f 72 20 22 6e 6f 74 20 61 )) (error "not a
09d0: 20 73 65 74 22 20 6f 62 6a 29 29 29 0a 0a 28 64 set" obj)))..(d
09e0: 65 66 69 6e 65 20 28 63 68 65 63 6b 2d 62 61 67 efine (check-bag
09f0: 20 6f 62 6a 29 20 28 69 66 20 28 6e 6f 74 20 28 obj) (if (not (
0a00: 62 61 67 3f 20 6f 62 6a 29 29 20 28 65 72 72 6f bag? obj)) (erro
0a10: 72 20 22 6e 6f 74 20 61 20 62 61 67 22 20 6f 62 r "not a bag" ob
0a20: 6a 29 29 29 0a 0a 3b 3b 20 54 68 65 73 65 20 70 j)))..;; These p
0a30: 72 6f 63 65 64 75 72 65 73 20 76 65 72 69 66 79 rocedures verify
0a40: 20 74 68 61 74 20 6e 6f 74 20 6f 6e 6c 79 20 61 that not only a
0a50: 72 65 20 74 68 65 69 72 20 61 72 67 75 6d 65 6e re their argumen
0a60: 74 73 20 61 6c 6c 20 73 65 74 73 0a 3b 3b 20 6f ts all sets.;; o
0a70: 72 20 61 6c 6c 20 62 61 67 73 20 61 73 20 74 68 r all bags as th
0a80: 65 20 63 61 73 65 20 6d 61 79 20 62 65 2c 20 62 e case may be, b
0a90: 75 74 20 61 6c 73 6f 20 73 68 61 72 65 20 74 68 ut also share th
0aa0: 65 20 73 61 6d 65 20 63 6f 6d 70 61 72 61 74 6f e same comparato
0ab0: 72 2e 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 65 r...(define (che
0ac0: 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 6c 69 73 74 ck-all-sets list
0ad0: 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c ). (for-each (l
0ae0: 61 6d 62 64 61 20 28 6f 62 6a 29 20 28 63 68 65 ambda (obj) (che
0af0: 63 6b 2d 73 65 74 20 6f 62 6a 29 29 20 6c 69 73 ck-set obj)) lis
0b00: 74 29 0a 20 20 28 73 6f 62 2d 63 68 65 63 6b 2d t). (sob-check-
0b10: 63 6f 6d 70 61 72 61 74 6f 72 73 20 6c 69 73 74 comparators list
0b20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 65 ))..(define (che
0b30: 63 6b 2d 61 6c 6c 2d 62 61 67 73 20 6c 69 73 74 ck-all-bags list
0b40: 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c ). (for-each (l
0b50: 61 6d 62 64 61 20 28 6f 62 6a 29 20 28 63 68 65 ambda (obj) (che
0b60: 63 6b 2d 62 61 67 20 6f 62 6a 29 29 20 6c 69 73 ck-bag obj)) lis
0b70: 74 29 0a 20 20 28 73 6f 62 2d 63 68 65 63 6b 2d t). (sob-check-
0b80: 63 6f 6d 70 61 72 61 74 6f 72 73 20 6c 69 73 74 comparators list
0b90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 ))..(define (sob
0ba0: 2d 63 68 65 63 6b 2d 63 6f 6d 70 61 72 61 74 6f -check-comparato
0bb0: 72 73 20 6c 69 73 74 29 0a 20 20 28 69 66 20 28 rs list). (if (
0bc0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6c 69 73 74 29 not (null? list)
0bd0: 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 ). (for-eac
0be0: 68 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 h. (lambd
0bf0: 61 20 28 73 6f 62 29 0a 20 20 20 20 20 20 20 20 a (sob).
0c00: 20 20 28 63 68 65 63 6b 2d 73 61 6d 65 2d 63 6f (check-same-co
0c10: 6d 70 61 72 61 74 6f 72 20 28 63 61 72 20 6c 69 mparator (car li
0c20: 73 74 29 20 73 6f 62 29 29 0a 20 20 20 20 20 20 st) sob)).
0c30: 20 20 28 63 64 72 20 6c 69 73 74 29 29 29 29 0a (cdr list)))).
0c40: 0a 3b 3b 20 54 68 69 73 20 70 72 6f 63 65 64 75 .;; This procedu
0c50: 72 65 20 69 73 20 75 73 65 64 20 64 69 72 65 63 re is used direc
0c60: 74 6c 79 20 77 68 65 6e 20 74 68 65 72 65 20 61 tly when there a
0c70: 72 65 20 65 78 61 63 74 6c 79 20 74 77 6f 20 61 re exactly two a
0c80: 72 67 75 6d 65 6e 74 73 2e 0a 0a 28 64 65 66 69 rguments...(defi
0c90: 6e 65 20 28 63 68 65 63 6b 2d 73 61 6d 65 2d 63 ne (check-same-c
0ca0: 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 29 0a 20 omparator a b).
0cb0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
0cc0: 73 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 20 61 sob-comparator a
0cd0: 29 20 28 73 6f 62 2d 63 6f 6d 70 61 72 61 74 6f ) (sob-comparato
0ce0: 72 20 62 29 29 29 0a 20 20 20 20 28 65 72 72 6f r b))). (erro
0cf0: 72 20 22 64 69 66 66 65 72 65 6e 74 20 63 6f 6d r "different com
0d00: 70 61 72 61 74 6f 72 73 22 20 61 20 62 29 29 29 parators" a b)))
0d10: 0a 0a 3b 3b 20 54 68 69 73 20 70 72 6f 63 65 64 ..;; This proced
0d20: 75 72 65 20 64 65 66 65 6e 64 73 20 61 67 61 69 ure defends agai
0d30: 6e 73 74 20 69 6e 73 65 72 74 69 6e 67 20 61 6e nst inserting an
0d40: 20 65 6c 65 6d 65 6e 74 0a 3b 3b 20 69 6e 74 6f element.;; into
0d50: 20 61 20 73 6f 62 20 74 68 61 74 20 76 69 6f 6c a sob that viol
0d60: 61 74 65 73 20 69 74 73 20 63 6f 6e 73 74 72 75 ates its constru
0d70: 63 74 6f 72 2c 20 73 69 6e 63 65 0a 3b 3b 20 74 ctor, since.;; t
0d80: 79 70 69 63 61 6c 20 68 61 73 68 2d 74 61 62 6c ypical hash-tabl
0d90: 65 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e e implementation
0da0: 73 20 64 6f 6e 27 74 20 63 68 65 63 6b 20 66 6f s don't check fo
0db0: 72 20 75 73 2e 0a 0a 28 64 65 66 69 6e 65 20 28 r us...(define (
0dc0: 63 68 65 63 6b 2d 65 6c 65 6d 65 6e 74 20 73 6f check-element so
0dd0: 62 20 65 6c 65 6d 65 6e 74 29 0a 20 20 28 63 6f b element). (co
0de0: 6d 70 61 72 61 74 6f 72 2d 63 68 65 63 6b 2d 74 mparator-check-t
0df0: 79 70 65 20 28 73 6f 62 2d 63 6f 6d 70 61 72 61 ype (sob-compara
0e00: 74 6f 72 20 73 6f 62 29 20 65 6c 65 6d 65 6e 74 tor sob) element
0e10: 29 29 0a 0a 3b 3b 3b 20 43 6f 6e 73 74 72 75 63 ))..;;; Construc
0e20: 74 6f 72 73 0a 0a 3b 3b 20 43 6f 6e 73 74 72 75 tors..;; Constru
0e30: 63 74 20 61 6e 20 61 72 62 69 74 72 61 72 79 20 ct an arbitrary
0e40: 65 6d 70 74 79 20 73 6f 62 20 6f 75 74 20 6f 66 empty sob out of
0e50: 20 6e 6f 74 68 69 6e 67 2e 0a 0a 28 64 65 66 69 nothing...(defi
0e60: 6e 65 20 28 6d 61 6b 65 2d 73 6f 62 20 63 6f 6d ne (make-sob com
0e70: 70 61 72 61 74 6f 72 20 6d 75 6c 74 69 3f 29 0a parator multi?).
0e80: 20 20 28 72 61 77 2d 6d 61 6b 65 2d 73 6f 62 20 (raw-make-sob
0e90: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0ea0: 2f 63 6f 6d 70 61 72 61 74 6f 72 20 63 6f 6d 70 /comparator comp
0eb0: 61 72 61 74 6f 72 29 20 63 6f 6d 70 61 72 61 74 arator) comparat
0ec0: 6f 72 20 6d 75 6c 74 69 3f 29 29 0a 0a 3b 3b 20 or multi?))..;;
0ed0: 43 6f 70 79 20 61 20 73 6f 62 2c 20 73 68 61 72 Copy a sob, shar
0ee0: 69 6e 67 20 74 68 65 20 63 6f 6e 73 74 72 75 63 ing the construc
0ef0: 74 6f 72 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 tor...(define (s
0f00: 6f 62 2d 63 6f 70 79 20 73 6f 62 29 0a 20 20 28 ob-copy sob). (
0f10: 72 61 77 2d 6d 61 6b 65 2d 73 6f 62 20 28 68 61 raw-make-sob (ha
0f20: 73 68 2d 74 61 62 6c 65 2d 63 6f 70 79 20 28 73 sh-table-copy (s
0f30: 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 6f ob-hash-table so
0f40: 62 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 b)).
0f50: 28 73 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 20 (sob-comparator
0f60: 73 6f 62 29 0a 20 20 20 20 20 20 20 20 20 20 20 sob).
0f70: 20 28 73 6f 62 2d 6d 75 6c 74 69 3f 20 73 6f 62 (sob-multi? sob
0f80: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
0f90: 74 2d 63 6f 70 79 20 73 65 74 29 0a 20 20 28 63 t-copy set). (c
0fa0: 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 heck-set set).
0fb0: 28 73 6f 62 2d 63 6f 70 79 20 73 65 74 29 29 0a (sob-copy set)).
0fc0: 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 63 6f .(define (bag-co
0fd0: 70 79 20 62 61 67 29 0a 20 20 28 63 68 65 63 6b py bag). (check
0fe0: 2d 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 -bag bag). (sob
0ff0: 2d 63 6f 70 79 20 62 61 67 29 29 0a 0a 3b 3b 20 -copy bag))..;;
1000: 43 6f 6e 73 74 72 75 63 74 20 61 6e 20 65 6d 70 Construct an emp
1010: 74 79 20 73 6f 62 20 74 68 61 74 20 73 68 61 72 ty sob that shar
1020: 65 73 20 74 68 65 20 63 6f 6e 73 74 72 75 63 74 es the construct
1030: 6f 72 20 6f 66 20 61 6e 20 65 78 69 73 74 69 6e or of an existin
1040: 67 20 73 6f 62 2e 0a 0a 28 64 65 66 69 6e 65 20 g sob...(define
1050: 28 73 6f 62 2d 65 6d 70 74 79 2d 63 6f 70 79 20 (sob-empty-copy
1060: 73 6f 62 29 0a 20 20 28 6d 61 6b 65 2d 73 6f 62 sob). (make-sob
1070: 20 28 73 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 (sob-comparator
1080: 20 73 6f 62 29 20 28 73 6f 62 2d 6d 75 6c 74 69 sob) (sob-multi
1090: 3f 20 73 6f 62 29 29 29 0a 0a 3b 3b 20 43 6f 6e ? sob)))..;; Con
10a0: 73 74 72 75 63 74 20 61 20 73 65 74 20 6f 72 20 struct a set or
10b0: 61 20 62 61 67 20 61 6e 64 20 69 6e 73 65 72 74 a bag and insert
10c0: 20 65 6c 65 6d 65 6e 74 73 20 69 6e 74 6f 20 69 elements into i
10d0: 74 2e 20 20 54 68 65 73 65 20 61 72 65 20 74 68 t. These are th
10e0: 65 0a 3b 3b 20 73 69 6d 70 6c 65 73 74 20 65 78 e.;; simplest ex
10f0: 74 65 72 6e 61 6c 20 63 6f 6e 73 74 72 75 63 74 ternal construct
1100: 6f 72 73 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 ors...(define (s
1110: 65 74 20 63 6f 6d 70 61 72 61 74 6f 72 20 2e 20 et comparator .
1120: 65 6c 65 6d 65 6e 74 73 29 0a 20 20 28 6c 65 74 elements). (let
1130: 20 28 28 72 65 73 75 6c 74 20 28 6d 61 6b 65 2d ((result (make-
1140: 73 6f 62 20 63 6f 6d 70 61 72 61 74 6f 72 20 23 sob comparator #
1150: 66 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 f))). (for-ea
1160: 63 68 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 ch (lambda (x) (
1170: 73 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 20 72 sob-increment! r
1180: 65 73 75 6c 74 20 78 20 31 29 29 20 65 6c 65 6d esult x 1)) elem
1190: 65 6e 74 73 29 0a 20 20 20 20 72 65 73 75 6c 74 ents). result
11a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 ))..(define (bag
11b0: 20 63 6f 6d 70 61 72 61 74 6f 72 20 2e 20 65 6c comparator . el
11c0: 65 6d 65 6e 74 73 29 0a 20 20 28 6c 65 74 20 28 ements). (let (
11d0: 28 72 65 73 75 6c 74 20 28 6d 61 6b 65 2d 73 6f (result (make-so
11e0: 62 20 63 6f 6d 70 61 72 61 74 6f 72 20 23 74 29 b comparator #t)
11f0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
1200: 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 73 6f (lambda (x) (so
1210: 62 2d 69 6e 63 72 65 6d 65 6e 74 21 20 72 65 73 b-increment! res
1220: 75 6c 74 20 78 20 31 29 29 20 65 6c 65 6d 65 6e ult x 1)) elemen
1230: 74 73 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 ts). result))
1240: 0a 0a 3b 3b 20 54 68 65 20 66 75 6e 64 61 6d 65 ..;; The fundame
1250: 6e 74 61 6c 20 28 61 73 20 6f 70 70 6f 73 65 64 ntal (as opposed
1260: 20 74 6f 20 73 69 6d 70 6c 65 73 74 29 20 63 6f to simplest) co
1270: 6e 73 74 72 75 63 74 6f 72 3a 20 75 6e 66 6f 6c nstructor: unfol
1280: 64 20 74 68 65 0a 3b 3b 20 72 65 73 75 6c 74 73 d the.;; results
1290: 20 6f 66 20 69 74 65 72 61 74 69 6e 67 20 61 20 of iterating a
12a0: 66 75 6e 63 74 69 6f 6e 20 61 73 20 61 20 73 65 function as a se
12b0: 74 2e 20 20 49 6e 20 6c 69 6e 65 20 77 69 74 68 t. In line with
12c0: 20 53 52 46 49 20 31 2c 0a 3b 3b 20 77 65 20 70 SRFI 1,.;; we p
12d0: 72 6f 76 69 64 65 20 61 6e 20 6f 70 70 6f 72 74 rovide an opport
12e0: 75 6e 69 74 79 20 74 6f 20 6d 61 70 20 74 68 65 unity to map the
12f0: 20 73 65 71 75 65 6e 63 65 20 6f 66 20 73 65 65 sequence of see
1300: 64 73 20 74 68 72 6f 75 67 68 20 61 0a 3b 3b 20 ds through a.;;
1310: 6d 61 70 70 65 72 20 66 75 6e 63 74 69 6f 6e 2e mapper function.
1320: 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 75 ..(define (sob-u
1330: 6e 66 6f 6c 64 20 73 74 6f 70 3f 20 6d 61 70 70 nfold stop? mapp
1340: 65 72 20 73 75 63 63 65 73 73 6f 72 20 73 65 65 er successor see
1350: 64 20 63 6f 6d 70 61 72 61 74 6f 72 20 6d 75 6c d comparator mul
1360: 74 69 3f 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ti?). (let ((re
1370: 73 75 6c 74 20 28 6d 61 6b 65 2d 73 6f 62 20 63 sult (make-sob c
1380: 6f 6d 70 61 72 61 74 6f 72 20 6d 75 6c 74 69 3f omparator multi?
1390: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f ))). (let loo
13a0: 70 20 28 28 73 65 65 64 20 73 65 65 64 29 29 0a p ((seed seed)).
13b0: 20 20 20 20 20 20 28 69 66 20 28 73 74 6f 70 3f (if (stop?
13c0: 20 73 65 65 64 29 0a 20 20 20 20 20 20 20 20 20 seed).
13d0: 20 72 65 73 75 6c 74 0a 20 20 20 20 20 20 20 20 result.
13e0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
13f0: 20 20 20 20 20 28 73 6f 62 2d 69 6e 63 72 65 6d (sob-increm
1400: 65 6e 74 21 20 72 65 73 75 6c 74 20 28 6d 61 70 ent! result (map
1410: 70 65 72 20 73 65 65 64 29 20 31 29 0a 20 20 20 per seed) 1).
1420: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
1430: 73 75 63 63 65 73 73 6f 72 20 73 65 65 64 29 29 successor seed))
1440: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
1450: 73 65 74 2d 75 6e 66 6f 6c 64 20 63 6f 6e 74 69 set-unfold conti
1460: 6e 75 65 3f 20 6d 61 70 70 65 72 20 73 75 63 63 nue? mapper succ
1470: 65 73 73 6f 72 20 73 65 65 64 20 63 6f 6d 70 61 essor seed compa
1480: 72 61 74 6f 72 29 0a 20 20 28 73 6f 62 2d 75 6e rator). (sob-un
1490: 66 6f 6c 64 20 63 6f 6e 74 69 6e 75 65 3f 20 6d fold continue? m
14a0: 61 70 70 65 72 20 73 75 63 63 65 73 73 6f 72 20 apper successor
14b0: 73 65 65 64 20 63 6f 6d 70 61 72 61 74 6f 72 20 seed comparator
14c0: 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 #f))..(define (b
14d0: 61 67 2d 75 6e 66 6f 6c 64 20 63 6f 6e 74 69 6e ag-unfold contin
14e0: 75 65 3f 20 6d 61 70 70 65 72 20 73 75 63 63 65 ue? mapper succe
14f0: 73 73 6f 72 20 73 65 65 64 20 63 6f 6d 70 61 72 ssor seed compar
1500: 61 74 6f 72 29 0a 20 20 28 73 6f 62 2d 75 6e 66 ator). (sob-unf
1510: 6f 6c 64 20 63 6f 6e 74 69 6e 75 65 3f 20 6d 61 old continue? ma
1520: 70 70 65 72 20 73 75 63 63 65 73 73 6f 72 20 73 pper successor s
1530: 65 65 64 20 63 6f 6d 70 61 72 61 74 6f 72 20 23 eed comparator #
1540: 74 29 29 0a 0a 3b 3b 3b 20 50 72 65 64 69 63 61 t))..;;; Predica
1550: 74 65 73 0a 0a 3b 3b 20 4a 75 73 74 20 61 20 77 tes..;; Just a w
1560: 72 61 70 70 65 72 20 6f 66 20 68 61 73 68 2d 74 rapper of hash-t
1570: 61 62 6c 65 2d 63 6f 6e 74 61 69 6e 73 3f 2e 0a able-contains?..
1580: 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 63 6f .(define (sob-co
1590: 6e 74 61 69 6e 73 3f 20 73 6f 62 20 6d 65 6d 62 ntains? sob memb
15a0: 65 72 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c er). (hash-tabl
15b0: 65 2d 63 6f 6e 74 61 69 6e 73 3f 20 28 73 6f 62 e-contains? (sob
15c0: 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 -hash-table sob)
15d0: 20 6d 65 6d 62 65 72 29 29 0a 0a 28 64 65 66 69 member))..(defi
15e0: 6e 65 20 28 73 65 74 2d 63 6f 6e 74 61 69 6e 73 ne (set-contains
15f0: 3f 20 73 65 74 20 6d 65 6d 62 65 72 29 0a 20 20 ? set member).
1600: 28 63 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a (check-set set).
1610: 20 20 28 73 6f 62 2d 63 6f 6e 74 61 69 6e 73 3f (sob-contains?
1620: 20 73 65 74 20 6d 65 6d 62 65 72 29 29 0a 0a 28 set member))..(
1630: 64 65 66 69 6e 65 20 28 62 61 67 2d 63 6f 6e 74 define (bag-cont
1640: 61 69 6e 73 3f 20 62 61 67 20 6d 65 6d 62 65 72 ains? bag member
1650: 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 ). (check-bag b
1660: 61 67 29 0a 20 20 28 73 6f 62 2d 63 6f 6e 74 61 ag). (sob-conta
1670: 69 6e 73 3f 20 62 61 67 20 6d 65 6d 62 65 72 29 ins? bag member)
1680: 29 0a 0a 3b 3b 20 41 20 73 6f 62 20 69 73 20 65 )..;; A sob is e
1690: 6d 70 74 79 20 69 66 20 69 74 73 20 73 69 7a 65 mpty if its size
16a0: 20 69 73 20 30 2e 0a 0a 28 64 65 66 69 6e 65 20 is 0...(define
16b0: 28 73 6f 62 2d 65 6d 70 74 79 3f 20 73 6f 62 29 (sob-empty? sob)
16c0: 0a 20 20 28 3d 20 30 20 28 68 61 73 68 2d 74 61 . (= 0 (hash-ta
16d0: 62 6c 65 2d 73 69 7a 65 20 28 73 6f 62 2d 68 61 ble-size (sob-ha
16e0: 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 29 29 sh-table sob))))
16f0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 65 ..(define (set-e
1700: 6d 70 74 79 3f 20 73 65 74 29 0a 20 20 28 63 68 mpty? set). (ch
1710: 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 eck-set set). (
1720: 73 6f 62 2d 65 6d 70 74 79 3f 20 73 65 74 29 29 sob-empty? set))
1730: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 65 ..(define (bag-e
1740: 6d 70 74 79 3f 20 62 61 67 29 0a 20 20 28 63 68 mpty? bag). (ch
1750: 65 63 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 28 eck-bag bag). (
1760: 73 6f 62 2d 65 6d 70 74 79 3f 20 62 61 67 29 29 sob-empty? bag))
1770: 0a 0a 3b 3b 20 54 77 6f 20 73 6f 62 73 20 61 72 ..;; Two sobs ar
1780: 65 20 64 69 73 6a 6f 69 6e 74 20 69 66 2c 20 77 e disjoint if, w
1790: 68 65 6e 20 6c 6f 6f 70 69 6e 67 20 74 68 72 6f hen looping thro
17a0: 75 67 68 20 6f 6e 65 2c 20 77 65 20 63 61 6e 27 ugh one, we can'
17b0: 74 20 66 69 6e 64 0a 3b 3b 20 61 6e 79 20 6f 66 t find.;; any of
17c0: 20 69 74 73 20 65 6c 65 6d 65 6e 74 73 20 69 6e its elements in
17d0: 20 74 68 65 20 6f 74 68 65 72 2e 20 20 57 65 20 the other. We
17e0: 68 61 76 65 20 74 6f 20 74 72 79 20 62 6f 74 68 have to try both
17f0: 20 77 61 79 73 3a 0a 3b 3b 20 73 6f 62 2d 68 61 ways:.;; sob-ha
1800: 6c 66 2d 64 69 73 6a 6f 69 6e 74 20 63 68 65 63 lf-disjoint chec
1810: 6b 73 20 6a 75 73 74 20 6f 6e 65 20 64 69 72 65 ks just one dire
1820: 63 74 69 6f 6e 20 66 6f 72 20 73 69 6d 70 6c 69 ction for simpli
1830: 63 69 74 79 2e 0a 0a 28 64 65 66 69 6e 65 20 28 city...(define (
1840: 73 6f 62 2d 68 61 6c 66 2d 64 69 73 6a 6f 69 6e sob-half-disjoin
1850: 74 3f 20 61 20 62 29 0a 20 20 28 6c 65 74 20 28 t? a b). (let (
1860: 28 68 61 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 (ha (sob-hash-ta
1870: 62 6c 65 20 61 29 29 0a 20 20 20 20 20 20 20 20 ble a)).
1880: 28 68 62 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 (hb (sob-hash-ta
1890: 62 6c 65 20 62 29 29 29 0a 20 20 20 20 28 63 61 ble b))). (ca
18a0: 6c 6c 2f 63 63 0a 20 20 20 20 20 20 28 6c 61 6d ll/cc. (lam
18b0: 62 64 61 20 28 72 65 74 75 72 6e 29 0a 20 20 20 bda (return).
18c0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
18d0: 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 -for-each.
18e0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 (lambda (key
18f0: 20 76 61 6c 29 20 28 69 66 20 28 68 61 73 68 2d val) (if (hash-
1900: 74 61 62 6c 65 2d 63 6f 6e 74 61 69 6e 73 3f 20 table-contains?
1910: 68 62 20 6b 65 79 29 20 28 72 65 74 75 72 6e 20 hb key) (return
1920: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
1930: 68 61 29 0a 20 20 20 20 20 20 23 74 29 29 29 29 ha). #t))))
1940: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 64 ..(define (set-d
1950: 69 73 6a 6f 69 6e 74 3f 20 61 20 62 29 0a 20 20 isjoint? a b).
1960: 28 63 68 65 63 6b 2d 73 65 74 20 61 29 0a 20 20 (check-set a).
1970: 28 63 68 65 63 6b 2d 73 65 74 20 62 29 0a 20 20 (check-set b).
1980: 28 63 68 65 63 6b 2d 73 61 6d 65 2d 63 6f 6d 70 (check-same-comp
1990: 61 72 61 74 6f 72 20 61 20 62 29 0a 20 20 28 61 arator a b). (a
19a0: 6e 64 20 28 73 6f 62 2d 68 61 6c 66 2d 64 69 73 nd (sob-half-dis
19b0: 6a 6f 69 6e 74 3f 20 61 20 62 29 20 28 73 6f 62 joint? a b) (sob
19c0: 2d 68 61 6c 66 2d 64 69 73 6a 6f 69 6e 74 3f 20 -half-disjoint?
19d0: 62 20 61 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 b a)))..(define
19e0: 28 62 61 67 2d 64 69 73 6a 6f 69 6e 74 3f 20 61 (bag-disjoint? a
19f0: 20 62 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 b). (check-bag
1a00: 20 61 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 a). (check-bag
1a10: 20 62 29 0a 20 20 28 63 68 65 63 6b 2d 73 61 6d b). (check-sam
1a20: 65 2d 63 6f 6d 70 61 72 61 74 6f 72 20 61 20 62 e-comparator a b
1a30: 29 0a 20 20 28 61 6e 64 20 28 73 6f 62 2d 68 61 ). (and (sob-ha
1a40: 6c 66 2d 64 69 73 6a 6f 69 6e 74 3f 20 61 20 62 lf-disjoint? a b
1a50: 29 20 28 73 6f 62 2d 68 61 6c 66 2d 64 69 73 6a ) (sob-half-disj
1a60: 6f 69 6e 74 3f 20 62 20 61 29 29 29 0a 0a 3b 3b oint? b a)))..;;
1a70: 20 41 63 63 65 73 73 6f 72 73 0a 0a 3b 3b 20 49 Accessors..;; I
1a80: 66 20 74 77 6f 20 6f 62 6a 65 63 74 73 20 61 72 f two objects ar
1a90: 65 20 69 6e 64 69 73 74 69 6e 67 75 69 73 68 61 e indistinguisha
1aa0: 62 6c 65 20 62 79 20 74 68 65 20 63 6f 6d 70 61 ble by the compa
1ab0: 72 61 74 6f 72 27 73 0a 3b 3b 20 65 71 75 61 6c rator's.;; equal
1ac0: 69 74 79 20 70 72 6f 63 65 64 75 72 65 2c 20 6f ity procedure, o
1ad0: 6e 6c 79 20 6f 6e 65 20 6f 66 20 74 68 65 6d 20 nly one of them
1ae0: 77 69 6c 6c 20 62 65 20 72 65 70 72 65 73 65 6e will be represen
1af0: 74 65 64 20 69 6e 20 74 68 65 20 73 6f 62 2e 0a ted in the sob..
1b00: 3b 3b 20 54 68 69 73 20 70 72 6f 63 65 64 75 72 ;; This procedur
1b10: 65 20 6c 65 74 73 20 75 73 20 66 69 6e 64 20 6f e lets us find o
1b20: 75 74 20 77 68 69 63 68 20 6f 6e 65 20 69 74 20 ut which one it
1b30: 69 73 3b 20 69 74 20 77 69 6c 6c 20 72 65 74 75 is; it will retu
1b40: 72 6e 0a 3b 3b 20 74 68 65 20 76 61 6c 75 65 20 rn.;; the value
1b50: 73 74 6f 72 65 64 20 69 6e 20 74 68 65 20 73 6f stored in the so
1b60: 62 20 74 68 61 74 20 69 73 20 65 71 75 61 6c 20 b that is equal
1b70: 74 6f 20 74 68 65 20 65 6c 65 6d 65 6e 74 2e 0a to the element..
1b80: 3b 3b 20 4e 6f 74 65 20 74 68 61 74 20 77 65 20 ;; Note that we
1b90: 68 61 76 65 20 74 6f 20 73 65 61 72 63 68 20 74 have to search t
1ba0: 68 65 20 77 68 6f 6c 65 20 68 61 73 68 20 74 61 he whole hash ta
1bb0: 62 6c 65 20 69 74 65 6d 20 62 79 20 69 74 65 6d ble item by item
1bc0: 2e 0a 3b 3b 20 54 68 65 20 64 65 66 61 75 6c 74 ..;; The default
1bd0: 20 69 73 20 72 65 74 75 72 6e 65 64 20 69 66 20 is returned if
1be0: 74 68 65 72 65 20 69 73 20 6e 6f 20 73 75 63 68 there is no such
1bf0: 20 65 6c 65 6d 65 6e 74 2e 0a 0a 28 64 65 66 69 element...(defi
1c00: 6e 65 20 28 73 6f 62 2d 6d 65 6d 62 65 72 20 73 ne (sob-member s
1c10: 6f 62 20 65 6c 65 6d 65 6e 74 20 64 65 66 61 75 ob element defau
1c20: 6c 74 29 0a 20 20 28 64 65 66 69 6e 65 20 28 73 lt). (define (s
1c30: 61 6d 65 3f 20 61 20 62 29 20 28 3d 3f 20 28 73 ame? a b) (=? (s
1c40: 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 20 73 6f ob-comparator so
1c50: 62 29 20 61 20 62 29 29 0a 20 20 28 63 61 6c 6c b) a b)). (call
1c60: 2f 63 63 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 /cc. (lambda
1c70: 28 72 65 74 75 72 6e 29 0a 20 20 20 20 20 20 28 (return). (
1c80: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
1c90: 61 63 68 0a 20 20 20 20 20 20 20 20 28 6c 61 6d ach. (lam
1ca0: 62 64 61 20 28 6b 65 79 20 76 61 6c 29 20 28 69 bda (key val) (i
1cb0: 66 20 28 73 61 6d 65 3f 20 6b 65 79 20 65 6c 65 f (same? key ele
1cc0: 6d 65 6e 74 29 20 28 72 65 74 75 72 6e 20 6b 65 ment) (return ke
1cd0: 79 29 29 29 0a 20 20 20 20 20 20 20 20 28 73 6f y))). (so
1ce0: 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 6f 62 b-hash-table sob
1cf0: 29 29 0a 20 20 20 20 20 20 64 65 66 61 75 6c 74 )). default
1d00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
1d10: 74 2d 6d 65 6d 62 65 72 20 73 65 74 20 65 6c 65 t-member set ele
1d20: 6d 65 6e 74 20 64 65 66 61 75 6c 74 29 0a 20 20 ment default).
1d30: 28 63 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a (check-set set).
1d40: 20 20 28 73 6f 62 2d 6d 65 6d 62 65 72 20 73 65 (sob-member se
1d50: 74 20 65 6c 65 6d 65 6e 74 20 64 65 66 61 75 6c t element defaul
1d60: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 t))..(define (ba
1d70: 67 2d 6d 65 6d 62 65 72 20 62 61 67 20 65 6c 65 g-member bag ele
1d80: 6d 65 6e 74 20 64 65 66 61 75 6c 74 29 0a 20 20 ment default).
1d90: 28 63 68 65 63 6b 2d 62 61 67 20 62 61 67 29 0a (check-bag bag).
1da0: 20 20 28 73 6f 62 2d 6d 65 6d 62 65 72 20 62 61 (sob-member ba
1db0: 67 20 65 6c 65 6d 65 6e 74 20 64 65 66 61 75 6c g element defaul
1dc0: 74 29 29 0a 0a 3b 3b 20 52 65 74 72 69 65 76 65 t))..;; Retrieve
1dd0: 20 74 68 65 20 63 6f 6d 70 61 72 61 74 6f 72 2e the comparator.
1de0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 65 ..(define (set-e
1df0: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato
1e00: 72 20 73 65 74 29 0a 20 20 28 63 68 65 63 6b 2d r set). (check-
1e10: 73 65 74 20 73 65 74 29 0a 20 20 28 73 6f 62 2d set set). (sob-
1e20: 63 6f 6d 70 61 72 61 74 6f 72 20 73 65 74 29 29 comparator set))
1e30: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 65 ..(define (bag-e
1e40: 6c 65 6d 65 6e 74 2d 63 6f 6d 70 61 72 61 74 6f lement-comparato
1e50: 72 20 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d r bag). (check-
1e60: 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 2d bag bag). (sob-
1e70: 63 6f 6d 70 61 72 61 74 6f 72 20 62 61 67 29 29 comparator bag))
1e80: 0a 0a 0a 3b 3b 20 55 70 64 61 74 65 72 73 20 28 ...;; Updaters (
1e90: 70 75 72 65 20 66 75 6e 63 74 69 6f 6e 61 6c 20 pure functional
1ea0: 61 6e 64 20 6c 69 6e 65 61 72 20 75 70 64 61 74 and linear updat
1eb0: 65 29 0a 0a 3b 3b 20 54 68 65 20 70 72 69 6d 69 e)..;; The primi
1ec0: 74 69 76 65 20 6f 70 65 72 61 74 69 6f 6e 20 66 tive operation f
1ed0: 6f 72 20 61 64 64 69 6e 67 20 61 6e 20 65 6c 65 or adding an ele
1ee0: 6d 65 6e 74 20 74 6f 20 61 20 73 6f 62 2e 0a 3b ment to a sob..;
1ef0: 3b 20 54 68 65 72 65 20 61 72 65 20 61 20 66 65 ; There are a fe
1f00: 77 20 63 61 73 65 73 20 77 68 65 72 65 20 77 65 w cases where we
1f10: 20 62 79 70 61 73 73 20 74 68 69 73 20 66 6f 72 bypass this for
1f20: 20 65 66 66 69 63 69 65 6e 63 79 2e 0a 0a 28 64 efficiency...(d
1f30: 65 66 69 6e 65 20 28 73 6f 62 2d 69 6e 63 72 65 efine (sob-incre
1f40: 6d 65 6e 74 21 20 73 6f 62 20 65 6c 65 6d 65 6e ment! sob elemen
1f50: 74 20 63 6f 75 6e 74 29 0a 20 20 28 63 68 65 63 t count). (chec
1f60: 6b 2d 65 6c 65 6d 65 6e 74 20 73 6f 62 20 65 6c k-element sob el
1f70: 65 6d 65 6e 74 29 0a 20 20 28 68 61 73 68 2d 74 ement). (hash-t
1f80: 61 62 6c 65 2d 75 70 64 61 74 65 21 2f 64 65 66 able-update!/def
1f90: 61 75 6c 74 0a 20 20 20 20 28 73 6f 62 2d 68 61 ault. (sob-ha
1fa0: 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 0a 20 20 sh-table sob).
1fb0: 20 20 65 6c 65 6d 65 6e 74 0a 20 20 20 20 28 69 element. (i
1fc0: 66 20 28 73 6f 62 2d 6d 75 6c 74 69 3f 20 73 6f f (sob-multi? so
1fd0: 62 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 b). (lambda
1fe0: 20 28 76 61 6c 75 65 29 20 28 2b 20 76 61 6c 75 (value) (+ valu
1ff0: 65 20 63 6f 75 6e 74 29 29 0a 20 20 20 20 20 20 e count)).
2000: 28 6c 61 6d 62 64 61 20 28 76 61 6c 75 65 29 20 (lambda (value)
2010: 31 29 29 0a 20 20 20 20 30 29 29 0a 0a 3b 3b 20 1)). 0))..;;
2020: 54 68 65 20 70 72 69 6d 69 74 69 76 65 20 6f 70 The primitive op
2030: 65 72 61 74 69 6f 6e 20 66 6f 72 20 72 65 6d 6f eration for remo
2040: 76 69 6e 67 20 61 6e 20 65 6c 65 6d 65 6e 74 20 ving an element
2050: 66 72 6f 6d 20 61 20 73 6f 62 2e 20 20 4e 6f 74 from a sob. Not
2060: 65 20 74 68 69 73 0a 3b 3b 20 70 72 6f 63 65 64 e this.;; proced
2070: 75 72 65 20 69 73 20 69 6e 63 6f 6d 70 6c 65 74 ure is incomplet
2080: 65 3a 20 69 74 20 61 6c 6c 6f 77 73 20 74 68 65 e: it allows the
2090: 20 63 6f 75 6e 74 20 6f 66 20 61 6e 20 65 6c 65 count of an ele
20a0: 6d 65 6e 74 20 74 6f 20 64 72 6f 70 20 62 65 6c ment to drop bel
20b0: 6f 77 20 31 2e 0a 3b 3b 20 54 68 65 72 65 66 6f ow 1..;; Therefo
20c0: 72 65 2c 20 77 68 65 6e 65 76 65 72 20 69 74 20 re, whenever it
20d0: 69 73 20 75 73 65 64 20 69 74 20 69 73 20 6e 65 is used it is ne
20e0: 63 65 73 73 61 72 79 20 74 6f 20 63 61 6c 6c 20 cessary to call
20f0: 73 6f 62 2d 63 6c 65 61 6e 75 70 21 0a 3b 3b 20 sob-cleanup!.;;
2100: 74 6f 20 66 69 78 20 74 68 69 6e 67 73 20 75 70 to fix things up
2110: 2e 20 20 54 68 69 73 20 69 73 20 64 6f 6e 65 20 . This is done
2120: 62 65 63 61 75 73 65 20 69 74 20 69 73 20 75 6e because it is un
2130: 73 61 66 65 20 74 6f 20 72 65 6d 6f 76 65 20 61 safe to remove a
2140: 6e 0a 3b 3b 20 6f 62 6a 65 63 74 20 66 72 6f 6d n.;; object from
2150: 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 77 68 a hash table wh
2160: 69 6c 65 20 69 74 65 72 61 74 69 6e 67 20 74 68 ile iterating th
2170: 72 6f 75 67 68 20 69 74 2e 0a 0a 28 64 65 66 69 rough it...(defi
2180: 6e 65 20 28 73 6f 62 2d 64 65 63 72 65 6d 65 6e ne (sob-decremen
2190: 74 21 20 73 6f 62 20 65 6c 65 6d 65 6e 74 20 63 t! sob element c
21a0: 6f 75 6e 74 29 0a 20 20 28 68 61 73 68 2d 74 61 ount). (hash-ta
21b0: 62 6c 65 2d 75 70 64 61 74 65 21 2f 64 65 66 61 ble-update!/defa
21c0: 75 6c 74 0a 20 20 20 20 28 73 6f 62 2d 68 61 73 ult. (sob-has
21d0: 68 2d 74 61 62 6c 65 20 73 6f 62 29 0a 20 20 20 h-table sob).
21e0: 20 65 6c 65 6d 65 6e 74 0a 20 20 20 20 28 6c 61 element. (la
21f0: 6d 62 64 61 20 28 76 61 6c 75 65 29 20 28 2d 20 mbda (value) (-
2200: 76 61 6c 75 65 20 63 6f 75 6e 74 29 29 0a 20 20 value count)).
2210: 20 20 30 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 0))..;; This i
2220: 73 20 74 68 65 20 63 6c 65 61 6e 75 70 20 70 72 s the cleanup pr
2230: 6f 63 65 64 75 72 65 2c 20 77 68 69 63 68 20 68 ocedure, which h
2240: 61 70 70 65 6e 73 20 69 6e 20 74 77 6f 20 70 61 appens in two pa
2250: 73 73 65 73 3a 20 69 74 0a 3b 3b 20 69 74 65 72 sses: it.;; iter
2260: 61 74 65 73 20 74 68 72 6f 75 67 68 20 74 68 65 ates through the
2270: 20 73 6f 62 2c 20 64 65 63 69 64 69 6e 67 20 77 sob, deciding w
2280: 68 69 63 68 20 65 6c 65 6d 65 6e 74 73 20 74 6f hich elements to
2290: 20 72 65 6d 6f 76 65 20 28 74 68 6f 73 65 0a 3b remove (those.;
22a0: 3b 20 77 69 74 68 20 6e 6f 6e 2d 70 6f 73 69 74 ; with non-posit
22b0: 69 76 65 20 63 6f 75 6e 74 73 29 2c 20 61 6e 64 ive counts), and
22c0: 20 63 6f 6c 6c 65 63 74 69 6e 67 20 74 68 65 6d collecting them
22d0: 20 69 6e 20 61 20 6c 69 73 74 2e 20 20 57 68 65 in a list. Whe
22e0: 6e 20 74 68 65 0a 3b 3b 20 69 74 65 72 61 74 69 n the.;; iterati
22f0: 6f 6e 20 69 73 20 64 6f 6e 65 2c 20 69 74 20 69 on is done, it i
2300: 73 20 73 61 66 65 20 74 6f 20 72 65 6d 6f 76 65 s safe to remove
2310: 20 74 68 65 20 65 6c 65 6d 65 6e 74 73 20 75 73 the elements us
2320: 69 6e 67 20 74 68 65 20 6c 69 73 74 2c 0a 3b 3b ing the list,.;;
2330: 20 62 65 63 61 75 73 65 20 77 65 20 61 72 65 20 because we are
2340: 6e 6f 20 6c 6f 6e 67 65 72 20 69 74 65 72 61 74 no longer iterat
2350: 69 6e 67 20 6f 76 65 72 20 74 68 65 20 68 61 73 ing over the has
2360: 68 20 74 61 62 6c 65 2e 20 20 49 74 20 72 65 74 h table. It ret
2370: 75 72 6e 73 0a 3b 3b 20 69 74 73 20 61 72 67 75 urns.;; its argu
2380: 6d 65 6e 74 2c 20 62 65 63 61 75 73 65 20 69 74 ment, because it
2390: 20 69 73 20 6f 66 74 65 6e 20 74 61 69 6c 2d 63 is often tail-c
23a0: 61 6c 6c 65 64 20 61 74 20 74 68 65 20 65 6e 64 alled at the end
23b0: 20 6f 66 20 73 6f 6d 65 0a 3b 3b 20 70 72 6f 63 of some.;; proc
23c0: 65 64 75 72 65 20 74 68 61 74 20 77 61 6e 74 73 edure that wants
23d0: 20 74 6f 20 72 65 74 75 72 6e 20 74 68 65 20 63 to return the c
23e0: 6c 65 61 6e 20 73 6f 62 2e 0a 0a 28 64 65 66 69 lean sob...(defi
23f0: 6e 65 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 21 ne (sob-cleanup!
2400: 20 73 6f 62 29 0a 20 20 28 6c 65 74 20 28 28 68 sob). (let ((h
2410: 74 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c t (sob-hash-tabl
2420: 65 20 73 6f 62 29 29 29 0a 20 20 20 20 28 66 6f e sob))). (fo
2430: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
2440: 6b 65 79 29 20 28 68 61 73 68 2d 74 61 62 6c 65 key) (hash-table
2450: 2d 64 65 6c 65 74 65 21 20 68 74 20 6b 65 79 29 -delete! ht key)
2460: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2470: 28 6e 6f 6e 70 6f 73 69 74 69 76 65 2d 6b 65 79 (nonpositive-key
2480: 73 20 68 74 29 29 0a 20 20 20 20 73 6f 62 29 29 s ht)). sob))
2490: 0a 0a 28 64 65 66 69 6e 65 20 28 6e 6f 6e 70 6f ..(define (nonpo
24a0: 73 69 74 69 76 65 2d 6b 65 79 73 20 68 74 29 0a sitive-keys ht).
24b0: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 (let ((result
24c0: 27 28 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d '())). (hash-
24d0: 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 table-for-each.
24e0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 (lambda (ke
24f0: 79 20 76 61 6c 75 65 29 0a 20 20 20 20 20 20 20 y value).
2500: 20 28 77 68 65 6e 20 28 3c 3d 20 76 61 6c 75 65 (when (<= value
2510: 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 0). (s
2520: 65 74 21 20 72 65 73 75 6c 74 20 28 63 6f 6e 73 et! result (cons
2530: 20 6b 65 79 20 72 65 73 75 6c 74 29 29 29 29 0a key result)))).
2540: 20 20 20 20 20 20 68 74 29 0a 20 20 20 20 72 65 ht). re
2550: 73 75 6c 74 29 29 0a 0a 3b 3b 20 57 65 20 65 78 sult))..;; We ex
2560: 70 6f 73 65 20 74 68 65 73 65 20 66 6f 72 20 62 pose these for b
2570: 61 67 73 20 62 75 74 20 6e 6f 74 20 73 65 74 73 ags but not sets
2580: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d ...(define (bag-
2590: 69 6e 63 72 65 6d 65 6e 74 21 20 62 61 67 20 65 increment! bag e
25a0: 6c 65 6d 65 6e 74 20 63 6f 75 6e 74 29 0a 20 20 lement count).
25b0: 28 63 68 65 63 6b 2d 62 61 67 20 62 61 67 29 0a (check-bag bag).
25c0: 20 20 28 73 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 (sob-increment
25d0: 21 20 62 61 67 20 65 6c 65 6d 65 6e 74 20 63 6f ! bag element co
25e0: 75 6e 74 29 0a 20 20 62 61 67 29 0a 0a 28 64 65 unt). bag)..(de
25f0: 66 69 6e 65 20 28 62 61 67 2d 64 65 63 72 65 6d fine (bag-decrem
2600: 65 6e 74 21 20 62 61 67 20 65 6c 65 6d 65 6e 74 ent! bag element
2610: 20 63 6f 75 6e 74 29 0a 20 20 28 63 68 65 63 6b count). (check
2620: 2d 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 -bag bag). (sob
2630: 2d 64 65 63 72 65 6d 65 6e 74 21 20 62 61 67 20 -decrement! bag
2640: 65 6c 65 6d 65 6e 74 20 63 6f 75 6e 74 29 0a 20 element count).
2650: 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 21 20 62 (sob-cleanup! b
2660: 61 67 29 0a 20 20 62 61 67 29 0a 0a 3b 3b 20 54 ag). bag)..;; T
2670: 68 65 20 70 72 69 6d 69 74 69 76 65 20 6f 70 65 he primitive ope
2680: 72 61 74 69 6f 6e 20 74 6f 20 61 64 64 20 65 6c ration to add el
2690: 65 6d 65 6e 74 73 20 66 72 6f 6d 20 61 20 6c 69 ements from a li
26a0: 73 74 2e 20 20 57 65 20 65 78 70 6f 73 65 0a 3b st. We expose.;
26b0: 3b 20 74 68 69 73 20 74 77 6f 20 77 61 79 73 3a ; this two ways:
26c0: 20 77 69 74 68 20 61 20 6c 69 73 74 20 61 72 67 with a list arg
26d0: 75 6d 65 6e 74 20 61 6e 64 20 77 69 74 68 20 6d ument and with m
26e0: 75 6c 74 69 70 6c 65 20 61 72 67 75 6d 65 6e 74 ultiple argument
26f0: 73 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 s...(define (sob
2700: 2d 61 64 6a 6f 69 6e 2d 61 6c 6c 21 20 73 6f 62 -adjoin-all! sob
2710: 20 65 6c 65 6d 65 6e 74 73 29 0a 20 20 28 66 6f elements). (fo
2720: 72 2d 65 61 63 68 0a 20 20 20 20 28 6c 61 6d 62 r-each. (lamb
2730: 64 61 20 28 65 6c 65 6d 29 0a 20 20 20 20 20 20 da (elem).
2740: 28 73 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 20 (sob-increment!
2750: 73 6f 62 20 65 6c 65 6d 20 31 29 29 0a 20 20 20 sob elem 1)).
2760: 20 65 6c 65 6d 65 6e 74 73 29 29 0a 0a 28 64 65 elements))..(de
2770: 66 69 6e 65 20 28 73 65 74 2d 61 64 6a 6f 69 6e fine (set-adjoin
2780: 21 20 73 65 74 20 2e 20 65 6c 65 6d 65 6e 74 73 ! set . elements
2790: 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 ). (check-set s
27a0: 65 74 29 0a 20 20 28 73 6f 62 2d 61 64 6a 6f 69 et). (sob-adjoi
27b0: 6e 2d 61 6c 6c 21 20 73 65 74 20 65 6c 65 6d 65 n-all! set eleme
27c0: 6e 74 73 29 0a 20 20 73 65 74 29 0a 0a 28 64 65 nts). set)..(de
27d0: 66 69 6e 65 20 28 62 61 67 2d 61 64 6a 6f 69 6e fine (bag-adjoin
27e0: 21 20 62 61 67 20 2e 20 65 6c 65 6d 65 6e 74 73 ! bag . elements
27f0: 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 ). (check-bag b
2800: 61 67 29 0a 20 20 28 73 6f 62 2d 61 64 6a 6f 69 ag). (sob-adjoi
2810: 6e 2d 61 6c 6c 21 20 62 61 67 20 65 6c 65 6d 65 n-all! bag eleme
2820: 6e 74 73 29 0a 20 20 62 61 67 29 0a 0a 0a 3b 3b nts). bag)...;;
2830: 20 54 68 65 73 65 20 76 65 72 73 69 6f 6e 73 20 These versions
2840: 63 6f 70 79 20 74 68 65 20 73 65 74 20 6f 72 20 copy the set or
2850: 62 61 67 20 62 65 66 6f 72 65 20 61 64 6a 6f 69 bag before adjoi
2860: 6e 69 6e 67 2e 0a 0a 28 64 65 66 69 6e 65 20 28 ning...(define (
2870: 73 65 74 2d 61 64 6a 6f 69 6e 20 73 65 74 20 2e set-adjoin set .
2880: 20 65 6c 65 6d 65 6e 74 73 29 0a 20 20 28 63 68 elements). (ch
2890: 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 eck-set set). (
28a0: 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 73 6f let ((result (so
28b0: 62 2d 63 6f 70 79 20 73 65 74 29 29 29 0a 20 20 b-copy set))).
28c0: 20 20 28 73 6f 62 2d 61 64 6a 6f 69 6e 2d 61 6c (sob-adjoin-al
28d0: 6c 21 20 72 65 73 75 6c 74 20 65 6c 65 6d 65 6e l! result elemen
28e0: 74 73 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 ts). result))
28f0: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 61 ..(define (bag-a
2900: 64 6a 6f 69 6e 20 62 61 67 20 2e 20 65 6c 65 6d djoin bag . elem
2910: 65 6e 74 73 29 0a 20 20 28 63 68 65 63 6b 2d 62 ents). (check-b
2920: 61 67 20 62 61 67 29 0a 20 20 28 6c 65 74 20 28 ag bag). (let (
2930: 28 72 65 73 75 6c 74 20 28 73 6f 62 2d 63 6f 70 (result (sob-cop
2940: 79 20 62 61 67 29 29 29 0a 20 20 20 20 28 73 6f y bag))). (so
2950: 62 2d 61 64 6a 6f 69 6e 2d 61 6c 6c 21 20 72 65 b-adjoin-all! re
2960: 73 75 6c 74 20 65 6c 65 6d 65 6e 74 73 29 0a 20 sult elements).
2970: 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 result))..;;
2980: 47 69 76 65 6e 20 61 6e 20 65 6c 65 6d 65 6e 74 Given an element
2990: 20 77 68 69 63 68 20 72 65 73 69 64 65 73 20 69 which resides i
29a0: 6e 20 61 20 73 65 74 2c 20 74 68 69 73 20 6d 61 n a set, this ma
29b0: 6b 65 73 20 73 75 72 65 20 74 68 61 74 20 74 68 kes sure that th
29c0: 65 0a 3b 3b 20 73 70 65 63 69 66 69 65 64 20 65 e.;; specified e
29d0: 6c 65 6d 65 6e 74 20 69 73 20 72 65 70 72 65 73 lement is repres
29e0: 65 6e 74 65 64 20 62 79 20 74 68 65 20 66 6f 72 ented by the for
29f0: 6d 20 67 69 76 65 6e 2e 20 20 54 68 75 73 20 69 m given. Thus i
2a00: 66 20 61 0a 3b 3b 20 73 6f 62 20 63 6f 6e 74 61 f a.;; sob conta
2a10: 69 6e 73 20 32 20 61 6e 64 20 74 68 65 20 65 71 ins 2 and the eq
2a20: 75 61 6c 69 74 79 20 70 72 65 64 69 63 61 74 65 uality predicate
2a30: 20 69 73 20 3d 2c 20 74 68 65 6e 20 63 61 6c 6c is =, then call
2a40: 69 6e 67 0a 3b 3b 20 28 73 6f 62 2d 72 65 70 6c ing.;; (sob-repl
2a50: 61 63 65 21 20 73 6f 62 20 32 2e 30 29 20 77 69 ace! sob 2.0) wi
2a60: 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 65 20 32 ll replace the 2
2a70: 20 77 69 74 68 20 32 2e 30 2e 20 20 44 6f 65 73 with 2.0. Does
2a80: 20 6e 6f 74 68 69 6e 67 0a 3b 3b 20 69 66 20 74 nothing.;; if t
2a90: 68 65 72 65 20 69 73 20 6e 6f 20 73 75 63 68 20 here is no such
2aa0: 65 6c 65 6d 65 6e 74 20 69 6e 20 74 68 65 20 73 element in the s
2ab0: 6f 62 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f ob...(define (so
2ac0: 62 2d 72 65 70 6c 61 63 65 21 20 73 6f 62 20 65 b-replace! sob e
2ad0: 6c 65 6d 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 lement). (let*
2ae0: 28 28 63 6f 6d 70 61 72 61 74 6f 72 20 28 73 6f ((comparator (so
2af0: 62 2d 63 6f 6d 70 61 72 61 74 6f 72 20 73 6f 62 b-comparator sob
2b00: 29 29 0a 20 20 20 20 20 20 20 20 20 28 3d 20 28 )). (= (
2b10: 63 6f 6d 70 61 72 61 74 6f 72 2d 65 71 75 61 6c comparator-equal
2b20: 69 74 79 2d 70 72 65 64 69 63 61 74 65 20 63 6f ity-predicate co
2b30: 6d 70 61 72 61 74 6f 72 29 29 0a 20 20 20 20 20 mparator)).
2b40: 20 20 20 20 28 68 74 20 28 73 6f 62 2d 68 61 73 (ht (sob-has
2b50: 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 29 0a 20 h-table sob))).
2b60: 20 20 20 28 63 6f 6d 70 61 72 61 74 6f 72 2d 63 (comparator-c
2b70: 68 65 63 6b 2d 74 79 70 65 20 63 6f 6d 70 61 72 heck-type compar
2b80: 61 74 6f 72 20 65 6c 65 6d 65 6e 74 29 0a 20 20 ator element).
2b90: 20 20 28 63 61 6c 6c 2f 63 63 0a 20 20 20 20 20 (call/cc.
2ba0: 20 28 6c 61 6d 62 64 61 20 28 72 65 74 75 72 6e (lambda (return
2bb0: 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ). (hash-
2bc0: 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 table-for-each.
2bd0: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
2be0: 20 28 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 20 (key value).
2bf0: 20 20 20 20 20 20 20 20 20 28 77 68 65 6e 20 28 (when (
2c00: 3d 20 6b 65 79 20 65 6c 65 6d 65 6e 74 29 0a 20 = key element).
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
2c20: 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 sh-table-delete!
2c30: 20 68 74 20 6b 65 79 29 0a 20 20 20 20 20 20 20 ht key).
2c40: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
2c50: 6c 65 2d 73 65 74 21 20 68 74 20 65 6c 65 6d 65 le-set! ht eleme
2c60: 6e 74 20 76 61 6c 75 65 29 0a 20 20 20 20 20 20 nt value).
2c70: 20 20 20 20 20 20 20 20 28 72 65 74 75 72 6e 20 (return
2c80: 73 6f 62 29 29 29 0a 20 20 20 20 20 20 20 20 20 sob))).
2c90: 20 68 74 29 0a 20 20 20 20 20 20 20 20 73 6f 62 ht). sob
2ca0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
2cb0: 65 74 2d 72 65 70 6c 61 63 65 21 20 73 65 74 20 et-replace! set
2cc0: 65 6c 65 6d 65 6e 74 29 0a 20 20 28 63 68 65 63 element). (chec
2cd0: 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 73 6f k-set set). (so
2ce0: 62 2d 72 65 70 6c 61 63 65 21 20 73 65 74 20 65 b-replace! set e
2cf0: 6c 65 6d 65 6e 74 29 0a 20 20 73 65 74 29 0a 0a lement). set)..
2d00: 28 64 65 66 69 6e 65 20 28 62 61 67 2d 72 65 70 (define (bag-rep
2d10: 6c 61 63 65 21 20 62 61 67 20 65 6c 65 6d 65 6e lace! bag elemen
2d20: 74 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 t). (check-bag
2d30: 62 61 67 29 0a 20 20 28 73 6f 62 2d 72 65 70 6c bag). (sob-repl
2d40: 61 63 65 21 20 62 61 67 20 65 6c 65 6d 65 6e 74 ace! bag element
2d50: 29 0a 20 20 62 61 67 29 0a 0a 3b 3b 20 4e 6f 6e ). bag)..;; Non
2d60: 2d 64 65 73 74 72 75 63 74 69 76 65 20 76 65 72 -destructive ver
2d70: 73 69 6f 6e 73 20 74 68 61 74 20 63 6f 70 79 20 sions that copy
2d80: 74 68 65 20 73 65 74 20 66 69 72 73 74 2e 20 20 the set first.
2d90: 59 65 73 2c 20 61 20 6c 69 74 74 6c 65 0a 3b 3b Yes, a little.;;
2da0: 20 62 69 74 20 69 6e 65 66 66 69 63 69 65 6e 74 bit inefficient
2db0: 20 62 65 63 61 75 73 65 20 69 74 20 63 6f 70 69 because it copi
2dc0: 65 73 20 74 68 65 20 65 6c 65 6d 65 6e 74 20 74 es the element t
2dd0: 6f 20 62 65 20 72 65 70 6c 61 63 65 64 20 62 65 o be replaced be
2de0: 66 6f 72 65 0a 3b 3b 20 61 63 74 75 61 6c 6c 79 fore.;; actually
2df0: 20 72 65 70 6c 61 63 69 6e 67 20 69 74 2e 0a 0a replacing it...
2e00: 28 64 65 66 69 6e 65 20 28 73 65 74 2d 72 65 70 (define (set-rep
2e10: 6c 61 63 65 20 73 65 74 20 65 6c 65 6d 65 6e 74 lace set element
2e20: 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 ). (check-set s
2e30: 65 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 et). (let ((res
2e40: 75 6c 74 20 28 73 6f 62 2d 63 6f 70 79 20 73 65 ult (sob-copy se
2e50: 74 29 29 29 0a 20 20 20 20 28 73 6f 62 2d 72 65 t))). (sob-re
2e60: 70 6c 61 63 65 21 20 72 65 73 75 6c 74 20 65 6c place! result el
2e70: 65 6d 65 6e 74 29 0a 20 20 20 20 72 65 73 75 6c ement). resul
2e80: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 t))..(define (ba
2e90: 67 2d 72 65 70 6c 61 63 65 20 62 61 67 20 65 6c g-replace bag el
2ea0: 65 6d 65 6e 74 29 0a 20 20 28 63 68 65 63 6b 2d ement). (check-
2eb0: 62 61 67 20 62 61 67 29 0a 20 20 28 6c 65 74 20 bag bag). (let
2ec0: 28 28 72 65 73 75 6c 74 20 28 73 6f 62 2d 63 6f ((result (sob-co
2ed0: 70 79 20 62 61 67 29 29 29 0a 20 20 20 20 28 73 py bag))). (s
2ee0: 6f 62 2d 72 65 70 6c 61 63 65 21 20 72 65 73 75 ob-replace! resu
2ef0: 6c 74 20 65 6c 65 6d 65 6e 74 29 0a 20 20 20 20 lt element).
2f00: 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 54 68 65 result))..;; The
2f10: 20 70 72 69 6d 69 74 69 76 65 20 6f 70 65 72 61 primitive opera
2f20: 74 69 6f 6e 20 74 6f 20 64 65 6c 65 74 65 20 65 tion to delete e
2f30: 6c 65 6d 6e 65 74 73 20 66 72 6f 6d 20 61 20 6c lemnets from a l
2f40: 69 73 74 2e 0a 3b 3b 20 4c 69 6b 65 20 73 6f 62 ist..;; Like sob
2f50: 2d 61 64 6a 6f 69 6e 2d 61 6c 6c 21 2c 20 74 68 -adjoin-all!, th
2f60: 69 73 20 69 73 20 65 78 70 6f 73 65 64 20 74 77 is is exposed tw
2f70: 6f 20 77 61 79 73 2e 20 20 49 74 20 63 61 6c 6c o ways. It call
2f80: 73 0a 3b 3b 20 73 6f 62 2d 63 6c 65 61 6e 75 70 s.;; sob-cleanup
2f90: 21 20 69 74 73 65 6c 66 2c 20 73 6f 20 69 74 73 ! itself, so its
2fa0: 20 63 61 6c 6c 65 72 73 20 64 6f 6e 27 74 20 6e callers don't n
2fb0: 65 65 64 20 74 6f 20 28 74 68 6f 75 67 68 20 69 eed to (though i
2fc0: 74 20 69 73 20 73 61 66 65 0a 3b 3b 20 74 6f 20 t is safe.;; to
2fd0: 64 6f 20 73 6f 2e 29 0a 0a 28 64 65 66 69 6e 65 do so.)..(define
2fe0: 20 28 73 6f 62 2d 64 65 6c 65 74 65 2d 61 6c 6c (sob-delete-all
2ff0: 21 20 73 6f 62 20 65 6c 65 6d 65 6e 74 73 29 0a ! sob elements).
3000: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
3010: 62 64 61 20 28 65 6c 65 6d 65 6e 74 29 20 28 73 bda (element) (s
3020: 6f 62 2d 64 65 63 72 65 6d 65 6e 74 21 20 73 6f ob-decrement! so
3030: 62 20 65 6c 65 6d 65 6e 74 20 31 29 29 20 65 6c b element 1)) el
3040: 65 6d 65 6e 74 73 29 0a 20 20 28 73 6f 62 2d 63 ements). (sob-c
3050: 6c 65 61 6e 75 70 21 20 73 6f 62 29 0a 20 20 73 leanup! sob). s
3060: 6f 62 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 ob)..(define (se
3070: 74 2d 64 65 6c 65 74 65 21 20 73 65 74 20 2e 20 t-delete! set .
3080: 65 6c 65 6d 65 6e 74 73 29 0a 20 20 28 63 68 65 elements). (che
3090: 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 73 ck-set set). (s
30a0: 6f 62 2d 64 65 6c 65 74 65 2d 61 6c 6c 21 20 73 ob-delete-all! s
30b0: 65 74 20 65 6c 65 6d 65 6e 74 73 29 29 0a 0a 28 et elements))..(
30c0: 64 65 66 69 6e 65 20 28 62 61 67 2d 64 65 6c 65 define (bag-dele
30d0: 74 65 21 20 62 61 67 20 2e 20 65 6c 65 6d 65 6e te! bag . elemen
30e0: 74 73 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 ts). (check-bag
30f0: 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 64 65 6c bag). (sob-del
3100: 65 74 65 2d 61 6c 6c 21 20 62 61 67 20 65 6c 65 ete-all! bag ele
3110: 6d 65 6e 74 73 29 29 0a 0a 28 64 65 66 69 6e 65 ments))..(define
3120: 20 28 73 65 74 2d 64 65 6c 65 74 65 2d 61 6c 6c (set-delete-all
3130: 21 20 73 65 74 20 65 6c 65 6d 65 6e 74 73 29 0a ! set elements).
3140: 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 65 74 (check-set set
3150: 29 0a 20 20 28 73 6f 62 2d 64 65 6c 65 74 65 2d ). (sob-delete-
3160: 61 6c 6c 21 20 73 65 74 20 65 6c 65 6d 65 6e 74 all! set element
3170: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 s))..(define (ba
3180: 67 2d 64 65 6c 65 74 65 2d 61 6c 6c 21 20 62 61 g-delete-all! ba
3190: 67 20 65 6c 65 6d 65 6e 74 73 29 0a 20 20 28 63 g elements). (c
31a0: 68 65 63 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 heck-bag bag).
31b0: 28 73 6f 62 2d 64 65 6c 65 74 65 2d 61 6c 6c 21 (sob-delete-all!
31c0: 20 62 61 67 20 65 6c 65 6d 65 6e 74 73 29 29 0a bag elements)).
31d0: 0a 3b 3b 20 4e 6f 6e 2d 64 65 73 74 72 75 63 74 .;; Non-destruct
31e0: 69 76 65 20 76 65 72 73 69 6f 6e 20 63 6f 70 79 ive version copy
31f0: 20 66 69 72 73 74 3b 20 74 68 69 73 20 69 73 20 first; this is
3200: 69 6e 65 66 66 69 63 69 65 6e 74 2e 0a 0a 28 64 inefficient...(d
3210: 65 66 69 6e 65 20 28 73 65 74 2d 64 65 6c 65 74 efine (set-delet
3220: 65 20 73 65 74 20 2e 20 65 6c 65 6d 65 6e 74 73 e set . elements
3230: 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 ). (check-set s
3240: 65 74 29 0a 20 20 28 73 6f 62 2d 64 65 6c 65 74 et). (sob-delet
3250: 65 2d 61 6c 6c 21 20 28 73 6f 62 2d 63 6f 70 79 e-all! (sob-copy
3260: 20 73 65 74 29 20 65 6c 65 6d 65 6e 74 73 29 29 set) elements))
3270: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 64 ..(define (bag-d
3280: 65 6c 65 74 65 20 62 61 67 20 2e 20 65 6c 65 6d elete bag . elem
3290: 65 6e 74 73 29 0a 20 20 28 63 68 65 63 6b 2d 62 ents). (check-b
32a0: 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 64 ag bag). (sob-d
32b0: 65 6c 65 74 65 2d 61 6c 6c 21 20 28 73 6f 62 2d elete-all! (sob-
32c0: 63 6f 70 79 20 62 61 67 29 20 65 6c 65 6d 65 6e copy bag) elemen
32d0: 74 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ts))..(define (s
32e0: 65 74 2d 64 65 6c 65 74 65 2d 61 6c 6c 20 73 65 et-delete-all se
32f0: 74 20 65 6c 65 6d 65 6e 74 73 29 0a 20 20 28 63 t elements). (c
3300: 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 heck-set set).
3310: 28 73 6f 62 2d 64 65 6c 65 74 65 2d 61 6c 6c 21 (sob-delete-all!
3320: 20 28 73 6f 62 2d 63 6f 70 79 20 73 65 74 29 20 (sob-copy set)
3330: 65 6c 65 6d 65 6e 74 73 29 29 0a 0a 28 64 65 66 elements))..(def
3340: 69 6e 65 20 28 62 61 67 2d 64 65 6c 65 74 65 2d ine (bag-delete-
3350: 61 6c 6c 20 62 61 67 20 65 6c 65 6d 65 6e 74 73 all bag elements
3360: 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 ). (check-bag b
3370: 61 67 29 0a 20 20 28 73 6f 62 2d 64 65 6c 65 74 ag). (sob-delet
3380: 65 2d 61 6c 6c 21 20 28 73 6f 62 2d 63 6f 70 79 e-all! (sob-copy
3390: 20 62 61 67 29 20 65 6c 65 6d 65 6e 74 73 29 29 bag) elements))
33a0: 0a 0a 3b 3b 20 46 6c 61 67 20 75 73 65 64 20 62 ..;; Flag used b
33b0: 79 20 73 6f 62 2d 73 65 61 72 63 68 21 20 74 6f y sob-search! to
33c0: 20 72 65 70 72 65 73 65 6e 74 20 61 20 6d 69 73 represent a mis
33d0: 73 69 6e 67 20 6f 62 6a 65 63 74 2e 0a 0a 28 64 sing object...(d
33e0: 65 66 69 6e 65 20 6d 69 73 73 69 6e 67 20 28 73 efine missing (s
33f0: 74 72 69 6e 67 2d 63 6f 70 79 20 22 6d 69 73 73 tring-copy "miss
3400: 69 6e 67 22 29 29 0a 0a 3b 3b 20 53 65 61 72 63 ing"))..;; Searc
3410: 68 65 73 20 61 6e 64 20 74 68 65 6e 20 64 69 73 hes and then dis
3420: 70 61 74 63 68 65 73 20 74 6f 20 75 73 65 72 2d patches to user-
3430: 64 65 66 69 6e 65 64 20 70 72 6f 63 65 64 75 72 defined procedur
3440: 65 73 20 6f 6e 20 66 61 69 6c 75 72 65 0a 3b 3b es on failure.;;
3450: 20 61 6e 64 20 73 75 63 63 65 73 73 2c 20 77 68 and success, wh
3460: 69 63 68 20 69 6e 20 74 75 72 6e 20 73 68 6f 75 ich in turn shou
3470: 6c 64 20 72 65 69 6e 76 6f 6b 65 20 61 20 70 72 ld reinvoke a pr
3480: 6f 63 65 64 75 72 65 20 74 6f 20 74 61 6b 65 20 ocedure to take
3490: 73 6f 6d 65 0a 3b 3b 20 61 63 74 69 6f 6e 20 6f some.;; action o
34a0: 6e 20 74 68 65 20 73 65 74 20 28 69 6e 73 65 72 n the set (inser
34b0: 74 2c 20 69 67 6e 6f 72 65 2c 20 72 65 70 6c 61 t, ignore, repla
34c0: 63 65 2c 20 6f 72 20 72 65 6d 6f 76 65 29 2e 0a ce, or remove)..
34d0: 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 73 65 .(define (sob-se
34e0: 61 72 63 68 21 20 73 6f 62 20 65 6c 65 6d 65 6e arch! sob elemen
34f0: 74 20 66 61 69 6c 75 72 65 20 73 75 63 63 65 73 t failure succes
3500: 73 29 0a 20 20 28 64 65 66 69 6e 65 20 28 69 6e s). (define (in
3510: 73 65 72 74 20 6f 62 6a 29 0a 20 20 20 20 28 73 sert obj). (s
3520: 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 20 73 6f ob-increment! so
3530: 62 20 65 6c 65 6d 65 6e 74 20 31 29 0a 20 20 20 b element 1).
3540: 20 28 76 61 6c 75 65 73 20 73 6f 62 20 6f 62 6a (values sob obj
3550: 29 29 0a 20 20 28 64 65 66 69 6e 65 20 28 69 67 )). (define (ig
3560: 6e 6f 72 65 20 6f 62 6a 29 0a 20 20 20 20 28 76 nore obj). (v
3570: 61 6c 75 65 73 20 73 6f 62 20 6f 62 6a 29 29 0a alues sob obj)).
3580: 20 20 28 64 65 66 69 6e 65 20 28 75 70 64 61 74 (define (updat
3590: 65 20 6e 65 77 2d 65 6c 65 6d 20 6f 62 6a 29 0a e new-elem obj).
35a0: 20 20 20 20 28 73 6f 62 2d 64 65 63 72 65 6d 65 (sob-decreme
35b0: 6e 74 21 20 73 6f 62 20 65 6c 65 6d 65 6e 74 20 nt! sob element
35c0: 31 29 0a 20 20 20 20 28 73 6f 62 2d 69 6e 63 72 1). (sob-incr
35d0: 65 6d 65 6e 74 21 20 73 6f 62 20 6e 65 77 2d 65 ement! sob new-e
35e0: 6c 65 6d 20 31 29 0a 20 20 20 20 28 76 61 6c 75 lem 1). (valu
35f0: 65 73 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 21 es (sob-cleanup!
3600: 20 73 6f 62 29 20 6f 62 6a 29 29 0a 20 20 28 64 sob) obj)). (d
3610: 65 66 69 6e 65 20 28 72 65 6d 6f 76 65 20 6f 62 efine (remove ob
3620: 6a 29 0a 20 20 20 20 28 73 6f 62 2d 64 65 63 72 j). (sob-decr
3630: 65 6d 65 6e 74 21 20 73 6f 62 20 65 6c 65 6d 65 ement! sob eleme
3640: 6e 74 20 31 29 0a 20 20 20 20 28 76 61 6c 75 65 nt 1). (value
3650: 73 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 21 20 s (sob-cleanup!
3660: 73 6f 62 29 20 6f 62 6a 29 29 0a 20 20 28 6c 65 sob) obj)). (le
3670: 74 20 28 28 74 72 75 65 2d 65 6c 65 6d 65 6e 74 t ((true-element
3680: 20 28 73 6f 62 2d 6d 65 6d 62 65 72 20 73 6f 62 (sob-member sob
3690: 20 65 6c 65 6d 65 6e 74 20 6d 69 73 73 69 6e 67 element missing
36a0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 65 71 3f ))). (if (eq?
36b0: 20 74 72 75 65 2d 65 6c 65 6d 65 6e 74 20 6d 69 true-element mi
36c0: 73 73 69 6e 67 29 0a 20 20 20 20 20 20 28 66 61 ssing). (fa
36d0: 69 6c 75 72 65 20 69 6e 73 65 72 74 20 69 67 6e ilure insert ign
36e0: 6f 72 65 29 0a 20 20 20 20 20 20 28 73 75 63 63 ore). (succ
36f0: 65 73 73 20 74 72 75 65 2d 65 6c 65 6d 65 6e 74 ess true-element
3700: 20 75 70 64 61 74 65 20 72 65 6d 6f 76 65 29 29 update remove))
3710: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 ))..(define (set
3720: 2d 73 65 61 72 63 68 21 20 73 65 74 20 65 6c 65 -search! set ele
3730: 6d 65 6e 74 20 66 61 69 6c 75 72 65 20 73 75 63 ment failure suc
3740: 63 65 73 73 29 0a 20 20 28 63 68 65 63 6b 2d 73 cess). (check-s
3750: 65 74 20 73 65 74 29 0a 20 20 28 73 6f 62 2d 73 et set). (sob-s
3760: 65 61 72 63 68 21 20 73 65 74 20 65 6c 65 6d 65 earch! set eleme
3770: 6e 74 20 66 61 69 6c 75 72 65 20 73 75 63 63 65 nt failure succe
3780: 73 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 ss))..(define (b
3790: 61 67 2d 73 65 61 72 63 68 21 20 62 61 67 20 65 ag-search! bag e
37a0: 6c 65 6d 65 6e 74 20 66 61 69 6c 75 72 65 20 73 lement failure s
37b0: 75 63 63 65 73 73 29 0a 20 20 28 63 68 65 63 6b uccess). (check
37c0: 2d 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 -bag bag). (sob
37d0: 2d 73 65 61 72 63 68 21 20 62 61 67 20 65 6c 65 -search! bag ele
37e0: 6d 65 6e 74 20 66 61 69 6c 75 72 65 20 73 75 63 ment failure suc
37f0: 63 65 73 73 29 29 0a 0a 3b 3b 20 52 65 74 75 72 cess))..;; Retur
3800: 6e 20 74 68 65 20 73 69 7a 65 20 6f 66 20 61 20 n the size of a
3810: 73 6f 62 2e 20 20 49 66 20 69 74 27 73 20 61 20 sob. If it's a
3820: 73 65 74 2c 20 77 65 20 63 61 6e 20 6a 75 73 74 set, we can just
3830: 20 75 73 65 20 74 68 65 0a 3b 3b 20 6e 75 6d 62 use the.;; numb
3840: 65 72 20 6f 66 20 61 73 73 6f 63 69 61 74 69 6f er of associatio
3850: 6e 73 20 69 6e 20 74 68 65 20 68 61 73 68 20 74 ns in the hash t
3860: 61 62 6c 65 2c 20 62 75 74 20 69 66 20 69 74 27 able, but if it'
3870: 73 20 61 20 62 61 67 2c 20 77 65 0a 3b 3b 20 68 s a bag, we.;; h
3880: 61 76 65 20 74 6f 20 61 64 64 20 75 70 20 74 68 ave to add up th
3890: 65 20 63 6f 75 6e 74 73 2e 0a 0a 28 64 65 66 69 e counts...(defi
38a0: 6e 65 20 28 73 6f 62 2d 73 69 7a 65 20 73 6f 62 ne (sob-size sob
38b0: 29 0a 20 20 28 69 66 20 28 73 6f 62 2d 6d 75 6c ). (if (sob-mul
38c0: 74 69 3f 20 73 6f 62 29 0a 20 20 20 20 28 6c 65 ti? sob). (le
38d0: 74 20 28 28 72 65 73 75 6c 74 20 30 29 29 0a 20 t ((result 0)).
38e0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
38f0: 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 -for-each.
3900: 20 20 28 6c 61 6d 62 64 61 20 28 65 6c 65 6d 20 (lambda (elem
3910: 63 6f 75 6e 74 29 20 28 73 65 74 21 20 72 65 73 count) (set! res
3920: 75 6c 74 20 28 2b 20 63 6f 75 6e 74 20 72 65 73 ult (+ count res
3930: 75 6c 74 29 29 29 0a 20 20 20 20 20 20 20 20 28 ult))). (
3940: 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 sob-hash-table s
3950: 6f 62 29 29 0a 20 20 20 20 20 20 72 65 73 75 6c ob)). resul
3960: 74 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 t). (hash-tab
3970: 6c 65 2d 73 69 7a 65 20 28 73 6f 62 2d 68 61 73 le-size (sob-has
3980: 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 29 29 0a h-table sob)))).
3990: 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 73 69 .(define (set-si
39a0: 7a 65 20 73 65 74 29 0a 20 20 28 63 68 65 63 6b ze set). (check
39b0: 2d 73 65 74 20 73 65 74 29 0a 20 20 28 73 6f 62 -set set). (sob
39c0: 2d 73 69 7a 65 20 73 65 74 29 29 0a 0a 28 64 65 -size set))..(de
39d0: 66 69 6e 65 20 28 62 61 67 2d 73 69 7a 65 20 62 fine (bag-size b
39e0: 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 ag). (check-bag
39f0: 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 73 69 7a bag). (sob-siz
3a00: 65 20 62 61 67 29 29 0a 0a 3b 3b 20 53 65 61 72 e bag))..;; Sear
3a10: 63 68 20 61 20 73 6f 62 20 74 6f 20 66 69 6e 64 ch a sob to find
3a20: 20 73 6f 6d 65 74 68 69 6e 67 20 74 68 61 74 20 something that
3a30: 6d 61 74 63 68 65 73 20 61 20 70 72 65 64 69 63 matches a predic
3a40: 61 74 65 2e 20 20 59 6f 75 20 64 6f 6e 27 74 0a ate. You don't.
3a50: 3b 3b 20 6b 6e 6f 77 20 77 68 69 63 68 20 65 6c ;; know which el
3a60: 65 6d 65 6e 74 20 79 6f 75 20 77 69 6c 6c 20 67 ement you will g
3a70: 65 74 2c 20 73 6f 20 74 68 69 73 20 69 73 20 6e et, so this is n
3a80: 6f 74 20 61 73 20 75 73 65 66 75 6c 20 61 73 20 ot as useful as
3a90: 66 69 6e 64 69 6e 67 0a 3b 3b 20 61 6e 20 65 6c finding.;; an el
3aa0: 65 6d 65 6e 74 20 69 6e 20 61 20 6c 69 73 74 20 ement in a list
3ab0: 6f 72 20 6f 74 68 65 72 20 6f 72 64 65 72 65 64 or other ordered
3ac0: 20 63 6f 6e 74 61 69 6e 65 72 2e 20 20 49 66 20 container. If
3ad0: 69 74 27 73 20 6e 6f 74 20 74 68 65 72 65 2c 0a it's not there,.
3ae0: 3b 3b 20 63 61 6c 6c 20 74 68 65 20 66 61 69 6c ;; call the fail
3af0: 75 72 65 20 74 68 75 6e 6b 2e 0a 0a 28 64 65 66 ure thunk...(def
3b00: 69 6e 65 20 28 73 6f 62 2d 66 69 6e 64 20 70 72 ine (sob-find pr
3b10: 65 64 20 73 6f 62 20 66 61 69 6c 75 72 65 29 0a ed sob failure).
3b20: 20 20 28 63 61 6c 6c 2f 63 63 0a 20 20 20 20 28 (call/cc. (
3b30: 6c 61 6d 62 64 61 20 28 72 65 74 75 72 6e 29 0a lambda (return).
3b40: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
3b50: 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 e-for-each.
3b60: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 (lambda (key
3b70: 76 61 6c 75 65 29 0a 20 20 20 20 20 20 20 20 20 value).
3b80: 20 28 69 66 20 28 70 72 65 64 20 6b 65 79 29 20 (if (pred key)
3b90: 28 72 65 74 75 72 6e 20 6b 65 79 29 29 29 0a 20 (return key))).
3ba0: 20 20 20 20 20 20 20 28 73 6f 62 2d 68 61 73 68 (sob-hash
3bb0: 2d 74 61 62 6c 65 20 73 6f 62 29 29 0a 20 20 20 -table sob)).
3bc0: 20 28 66 61 69 6c 75 72 65 29 29 29 29 0a 0a 28 (failure))))..(
3bd0: 64 65 66 69 6e 65 20 28 73 65 74 2d 66 69 6e 64 define (set-find
3be0: 20 70 72 65 64 20 73 65 74 20 66 61 69 6c 75 72 pred set failur
3bf0: 65 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 e). (check-set
3c00: 73 65 74 29 0a 20 20 28 73 6f 62 2d 66 69 6e 64 set). (sob-find
3c10: 20 70 72 65 64 20 73 65 74 20 66 61 69 6c 75 72 pred set failur
3c20: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 e))..(define (ba
3c30: 67 2d 66 69 6e 64 20 70 72 65 64 20 62 61 67 20 g-find pred bag
3c40: 66 61 69 6c 75 72 65 29 0a 20 20 28 63 68 65 63 failure). (chec
3c50: 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f k-bag bag). (so
3c60: 62 2d 66 69 6e 64 20 70 72 65 64 20 62 61 67 20 b-find pred bag
3c70: 66 61 69 6c 75 72 65 29 29 0a 0a 3b 3b 20 43 6f failure))..;; Co
3c80: 75 6e 74 20 74 68 65 20 6e 75 6d 62 65 72 20 6f unt the number o
3c90: 66 20 65 6c 65 6d 65 6e 74 73 20 69 6e 20 74 68 f elements in th
3ca0: 65 20 73 6f 62 20 74 68 61 74 20 73 61 74 69 73 e sob that satis
3cb0: 66 79 20 74 68 65 20 70 72 65 64 69 63 61 74 65 fy the predicate
3cc0: 2e 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 73 ..;; This is a s
3cd0: 70 65 63 69 61 6c 20 63 61 73 65 20 6f 66 20 66 pecial case of f
3ce0: 6f 6c 64 69 6e 67 2e 0a 0a 28 64 65 66 69 6e 65 olding...(define
3cf0: 20 28 73 6f 62 2d 63 6f 75 6e 74 20 70 72 65 64 (sob-count pred
3d00: 20 73 6f 62 29 0a 20 20 28 73 6f 62 2d 66 6f 6c sob). (sob-fol
3d10: 64 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 65 d. (lambda (e
3d20: 6c 65 6d 20 74 6f 74 61 6c 29 20 28 69 66 20 28 lem total) (if (
3d30: 70 72 65 64 20 65 6c 65 6d 29 20 28 2b 20 74 6f pred elem) (+ to
3d40: 74 61 6c 20 31 29 20 74 6f 74 61 6c 29 29 0a 20 tal 1) total)).
3d50: 20 20 20 30 0a 20 20 20 20 73 6f 62 29 29 0a 0a 0. sob))..
3d60: 28 64 65 66 69 6e 65 20 28 73 65 74 2d 63 6f 75 (define (set-cou
3d70: 6e 74 20 70 72 65 64 20 73 65 74 29 0a 20 20 28 nt pred set). (
3d80: 63 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 check-set set).
3d90: 20 28 73 6f 62 2d 63 6f 75 6e 74 20 70 72 65 64 (sob-count pred
3da0: 20 73 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 set))..(define
3db0: 28 62 61 67 2d 63 6f 75 6e 74 20 70 72 65 64 20 (bag-count pred
3dc0: 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 bag). (check-ba
3dd0: 67 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 63 6f g bag). (sob-co
3de0: 75 6e 74 20 70 72 65 64 20 62 61 67 29 29 0a 0a unt pred bag))..
3df0: 3b 3b 20 43 68 65 63 6b 20 69 66 20 61 6e 79 20 ;; Check if any
3e00: 6f 66 20 74 68 65 20 65 6c 65 6d 65 6e 74 73 20 of the elements
3e10: 69 6e 20 61 20 73 6f 62 20 73 61 74 69 73 66 79 in a sob satisfy
3e20: 20 61 20 70 72 65 64 69 63 61 74 65 2e 20 20 42 a predicate. B
3e30: 72 65 61 6b 73 20 6f 75 74 0a 3b 3b 20 65 61 72 reaks out.;; ear
3e40: 6c 79 20 28 77 69 74 68 20 63 61 6c 6c 2f 63 63 ly (with call/cc
3e50: 29 20 69 66 20 61 20 73 75 63 63 65 73 73 20 69 ) if a success i
3e60: 73 20 66 6f 75 6e 64 2e 0a 0a 28 64 65 66 69 6e s found...(defin
3e70: 65 20 28 73 6f 62 2d 61 6e 79 3f 20 70 72 65 64 e (sob-any? pred
3e80: 20 73 6f 62 29 0a 20 20 28 63 61 6c 6c 2f 63 63 sob). (call/cc
3e90: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 . (lambda (re
3ea0: 74 75 72 6e 29 0a 20 20 20 20 20 20 28 68 61 73 turn). (has
3eb0: 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 h-table-for-each
3ec0: 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 . (lambda
3ed0: 20 28 65 6c 65 6d 20 76 61 6c 75 65 29 20 28 69 (elem value) (i
3ee0: 66 20 28 70 72 65 64 20 65 6c 65 6d 29 20 28 72 f (pred elem) (r
3ef0: 65 74 75 72 6e 20 23 74 29 29 29 0a 20 20 20 20 eturn #t))).
3f00: 20 20 20 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 (sob-hash-ta
3f10: 62 6c 65 20 73 6f 62 29 29 0a 20 20 20 20 20 20 ble sob)).
3f20: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
3f30: 73 65 74 2d 61 6e 79 3f 20 70 72 65 64 20 73 65 set-any? pred se
3f40: 74 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 t). (check-set
3f50: 73 65 74 29 0a 20 20 28 73 6f 62 2d 61 6e 79 3f set). (sob-any?
3f60: 20 70 72 65 64 20 73 65 74 29 29 0a 0a 28 64 65 pred set))..(de
3f70: 66 69 6e 65 20 28 62 61 67 2d 61 6e 79 3f 20 70 fine (bag-any? p
3f80: 72 65 64 20 62 61 67 29 0a 20 20 28 63 68 65 63 red bag). (chec
3f90: 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f k-bag bag). (so
3fa0: 62 2d 61 6e 79 3f 20 70 72 65 64 20 62 61 67 29 b-any? pred bag)
3fb0: 29 0a 0a 3b 3b 20 41 6e 61 6c 6f 67 6f 75 73 20 )..;; Analogous
3fc0: 74 6f 20 73 65 74 2d 61 6e 79 3f 2e 20 20 42 72 to set-any?. Br
3fd0: 65 61 6b 73 20 6f 75 74 20 65 61 72 6c 79 20 69 eaks out early i
3fe0: 66 20 61 20 66 61 69 6c 75 72 65 20 69 73 20 66 f a failure is f
3ff0: 6f 75 6e 64 2e 0a 0a 28 64 65 66 69 6e 65 20 28 ound...(define (
4000: 73 6f 62 2d 65 76 65 72 79 3f 20 70 72 65 64 20 sob-every? pred
4010: 73 6f 62 29 0a 20 20 28 63 61 6c 6c 2f 63 63 0a sob). (call/cc.
4020: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 74 (lambda (ret
4030: 75 72 6e 29 0a 20 20 20 20 20 20 28 68 61 73 68 urn). (hash
4040: 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a -table-for-each.
4050: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
4060: 28 65 6c 65 6d 20 76 61 6c 75 65 29 20 28 69 66 (elem value) (if
4070: 20 28 6e 6f 74 20 28 70 72 65 64 20 65 6c 65 6d (not (pred elem
4080: 29 29 20 28 72 65 74 75 72 6e 20 23 66 29 29 29 )) (return #f)))
4090: 0a 20 20 20 20 20 20 20 20 28 73 6f 62 2d 68 61 . (sob-ha
40a0: 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 0a 20 sh-table sob)).
40b0: 20 20 20 20 20 23 74 29 29 29 0a 0a 28 64 65 66 #t)))..(def
40c0: 69 6e 65 20 28 73 65 74 2d 65 76 65 72 79 3f 20 ine (set-every?
40d0: 70 72 65 64 20 73 65 74 29 0a 20 20 28 63 68 65 pred set). (che
40e0: 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 73 ck-set set). (s
40f0: 6f 62 2d 65 76 65 72 79 3f 20 70 72 65 64 20 73 ob-every? pred s
4100: 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 et))..(define (b
4110: 61 67 2d 65 76 65 72 79 3f 20 70 72 65 64 20 62 ag-every? pred b
4120: 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 ag). (check-bag
4130: 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 65 76 65 bag). (sob-eve
4140: 72 79 3f 20 70 72 65 64 20 62 61 67 29 29 0a 0a ry? pred bag))..
4150: 0a 3b 3b 3b 20 4d 61 70 70 69 6e 67 20 61 6e 64 .;;; Mapping and
4160: 20 66 6f 6c 64 69 6e 67 0a 0a 3b 3b 20 41 20 75 folding..;; A u
4170: 74 69 6c 69 74 79 20 66 6f 72 20 69 74 65 72 61 tility for itera
4180: 74 69 6e 67 20 61 20 63 6f 6d 6d 61 6e 64 20 6e ting a command n
4190: 20 74 69 6d 65 73 2e 20 20 54 68 69 73 20 69 73 times. This is
41a0: 20 75 73 65 64 20 62 79 20 73 6f 62 2d 66 6f 72 used by sob-for
41b0: 2d 65 61 63 68 0a 3b 3b 20 74 6f 20 65 78 65 63 -each.;; to exec
41c0: 75 74 65 20 61 20 70 72 6f 63 65 64 75 72 65 20 ute a procedure
41d0: 6f 76 65 72 20 74 68 65 20 72 65 70 65 61 74 65 over the repeate
41e0: 64 20 65 6c 65 6d 65 6e 74 73 20 69 6e 20 61 20 d elements in a
41f0: 62 61 67 2e 20 20 42 65 63 61 75 73 65 0a 3b 3b bag. Because.;;
4200: 20 6f 66 20 74 68 65 20 72 65 70 72 65 73 65 6e of the represen
4210: 74 61 74 69 6f 6e 20 6f 66 20 73 65 74 73 2c 20 tation of sets,
4220: 69 74 20 77 6f 72 6b 73 20 66 6f 72 20 74 68 65 it works for the
4230: 6d 20 74 6f 6f 2e 0a 0a 28 64 65 66 69 6e 65 20 m too...(define
4240: 28 64 6f 2d 6e 2d 74 69 6d 65 73 20 63 6d 64 20 (do-n-times cmd
4250: 6e 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 n). (let loop (
4260: 28 6e 20 6e 29 29 0a 20 20 20 20 28 77 68 65 6e (n n)). (when
4270: 20 28 3e 20 6e 20 30 29 0a 20 20 20 20 20 20 28 (> n 0). (
4280: 63 6d 64 29 0a 20 20 20 20 20 20 28 6c 6f 6f 70 cmd). (loop
4290: 20 28 2d 20 6e 20 31 29 29 29 29 29 0a 0a 3b 3b (- n 1)))))..;;
42a0: 20 42 61 73 69 63 20 69 74 65 72 61 74 6f 72 20 Basic iterator
42b0: 6f 76 65 72 20 61 20 73 6f 62 2e 0a 0a 28 64 65 over a sob...(de
42c0: 66 69 6e 65 20 28 73 6f 62 2d 66 6f 72 2d 65 61 fine (sob-for-ea
42d0: 63 68 20 70 72 6f 63 20 73 6f 62 29 0a 20 20 28 ch proc sob). (
42e0: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
42f0: 61 63 68 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 ach. (lambda
4300: 28 6b 65 79 20 76 61 6c 75 65 29 20 28 64 6f 2d (key value) (do-
4310: 6e 2d 74 69 6d 65 73 20 28 6c 61 6d 62 64 61 20 n-times (lambda
4320: 28 29 20 28 70 72 6f 63 20 6b 65 79 29 29 20 76 () (proc key)) v
4330: 61 6c 75 65 29 29 0a 20 20 20 20 28 73 6f 62 2d alue)). (sob-
4340: 68 61 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 hash-table sob))
4350: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d )..(define (set-
4360: 66 6f 72 2d 65 61 63 68 20 70 72 6f 63 20 73 65 for-each proc se
4370: 74 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 t). (check-set
4380: 73 65 74 29 0a 20 20 28 73 6f 62 2d 66 6f 72 2d set). (sob-for-
4390: 65 61 63 68 20 70 72 6f 63 20 73 65 74 29 29 0a each proc set)).
43a0: 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 66 6f .(define (bag-fo
43b0: 72 2d 65 61 63 68 20 70 72 6f 63 20 62 61 67 29 r-each proc bag)
43c0: 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 61 . (check-bag ba
43d0: 67 29 0a 20 20 28 73 6f 62 2d 66 6f 72 2d 65 61 g). (sob-for-ea
43e0: 63 68 20 70 72 6f 63 20 62 61 67 29 29 0a 0a 3b ch proc bag))..;
43f0: 3b 20 46 75 6e 64 61 6d 65 6e 74 61 6c 20 6d 61 ; Fundamental ma
4400: 70 70 69 6e 67 20 6f 70 65 72 61 74 6f 72 2e 20 pping operator.
4410: 20 57 65 20 6d 61 70 20 6f 76 65 72 20 74 68 65 We map over the
4420: 20 61 73 73 6f 63 69 61 74 69 6f 6e 73 20 64 69 associations di
4430: 72 65 63 74 6c 79 2c 0a 3b 3b 20 62 65 63 61 75 rectly,.;; becau
4440: 73 65 20 65 61 63 68 20 69 6e 73 74 61 6e 63 65 se each instance
4450: 20 6f 66 20 61 6e 20 65 6c 65 6d 65 6e 74 20 69 of an element i
4460: 6e 20 61 20 62 61 67 20 77 69 6c 6c 20 62 65 20 n a bag will be
4470: 74 72 65 61 74 65 64 20 69 64 65 6e 74 69 63 61 treated identica
4480: 6c 6c 79 0a 3b 3b 20 61 6e 79 77 61 79 3b 20 77 lly.;; anyway; w
4490: 65 20 69 6e 73 65 72 74 20 74 68 65 6d 20 61 6c e insert them al
44a0: 6c 20 61 74 20 6f 6e 63 65 20 77 69 74 68 20 73 l at once with s
44b0: 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 2e 0a 0a ob-increment!...
44c0: 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 6d 61 70 (define (sob-map
44d0: 20 63 6f 6d 70 61 72 61 74 6f 72 20 70 72 6f 63 comparator proc
44e0: 20 73 6f 62 29 0a 20 20 28 6c 65 74 20 28 28 72 sob). (let ((r
44f0: 65 73 75 6c 74 20 28 6d 61 6b 65 2d 73 6f 62 20 esult (make-sob
4500: 63 6f 6d 70 61 72 61 74 6f 72 20 28 73 6f 62 2d comparator (sob-
4510: 6d 75 6c 74 69 3f 20 73 6f 62 29 29 29 29 0a 20 multi? sob)))).
4520: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 (hash-table-f
4530: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 28 6c or-each. (l
4540: 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c 75 65 ambda (key value
4550: 29 20 28 73 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 ) (sob-increment
4560: 21 20 72 65 73 75 6c 74 20 28 70 72 6f 63 20 6b ! result (proc k
4570: 65 79 29 20 76 61 6c 75 65 29 29 0a 20 20 20 20 ey) value)).
4580: 20 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c (sob-hash-tabl
4590: 65 20 73 6f 62 29 29 0a 20 20 20 20 72 65 73 75 e sob)). resu
45a0: 6c 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 lt))..(define (s
45b0: 65 74 2d 6d 61 70 20 63 6f 6d 70 61 72 61 74 6f et-map comparato
45c0: 72 20 70 72 6f 63 20 73 65 74 29 0a 20 20 28 63 r proc set). (c
45d0: 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 heck-set set).
45e0: 28 73 6f 62 2d 6d 61 70 20 63 6f 6d 70 61 72 61 (sob-map compara
45f0: 74 6f 72 20 70 72 6f 63 20 73 65 74 29 29 0a 0a tor proc set))..
4600: 28 64 65 66 69 6e 65 20 28 62 61 67 2d 6d 61 70 (define (bag-map
4610: 20 63 6f 6d 70 61 72 61 74 6f 72 20 70 72 6f 63 comparator proc
4620: 20 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 bag). (check-b
4630: 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 6d ag bag). (sob-m
4640: 61 70 20 63 6f 6d 70 61 72 61 74 6f 72 20 70 72 ap comparator pr
4650: 6f 63 20 62 61 67 29 29 0a 0a 3b 3b 20 54 68 65 oc bag))..;; The
4660: 20 66 75 6e 64 61 6d 65 6e 74 61 6c 20 64 65 63 fundamental dec
4670: 6f 6e 73 74 72 75 63 74 6f 72 2e 20 20 4e 6f 74 onstructor. Not
4680: 65 20 74 68 61 74 20 74 68 65 72 65 20 61 72 65 e that there are
4690: 20 6e 6f 20 6c 65 66 74 20 76 73 2e 20 72 69 67 no left vs. rig
46a0: 68 74 0a 3b 3b 20 66 6f 6c 64 73 20 62 65 63 61 ht.;; folds beca
46b0: 75 73 65 20 74 68 65 72 65 20 69 73 20 6e 6f 20 use there is no
46c0: 6f 72 64 65 72 2e 20 20 45 61 63 68 20 65 6c 65 order. Each ele
46d0: 6d 65 6e 74 20 69 6e 20 61 20 62 61 67 20 69 73 ment in a bag is
46e0: 20 66 65 64 20 69 6e 74 6f 0a 3b 3b 20 74 68 65 fed into.;; the
46f0: 20 66 6f 6c 64 20 73 65 70 61 72 61 74 65 6c 79 fold separately
4700: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 2d ...(define (sob-
4710: 66 6f 6c 64 20 70 72 6f 63 20 6e 69 6c 20 73 6f fold proc nil so
4720: 62 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 75 b). (let ((resu
4730: 6c 74 20 6e 69 6c 29 29 0a 20 20 20 20 28 73 6f lt nil)). (so
4740: 62 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 b-for-each.
4750: 20 28 6c 61 6d 62 64 61 20 28 65 6c 65 6d 29 20 (lambda (elem)
4760: 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 70 72 (set! result (pr
4770: 6f 63 20 65 6c 65 6d 20 72 65 73 75 6c 74 29 29 oc elem result))
4780: 29 0a 20 20 20 20 20 20 73 6f 62 29 0a 20 20 20 ). sob).
4790: 20 72 65 73 75 6c 74 29 29 0a 0a 28 64 65 66 69 result))..(defi
47a0: 6e 65 20 28 73 65 74 2d 66 6f 6c 64 20 70 72 6f ne (set-fold pro
47b0: 63 20 6e 69 6c 20 73 65 74 29 0a 20 20 28 63 68 c nil set). (ch
47c0: 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 eck-set set). (
47d0: 73 6f 62 2d 66 6f 6c 64 20 70 72 6f 63 20 6e 69 sob-fold proc ni
47e0: 6c 20 73 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 l set))..(define
47f0: 20 28 62 61 67 2d 66 6f 6c 64 20 70 72 6f 63 20 (bag-fold proc
4800: 6e 69 6c 20 62 61 67 29 0a 20 20 28 63 68 65 63 nil bag). (chec
4810: 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f k-bag bag). (so
4820: 62 2d 66 6f 6c 64 20 70 72 6f 63 20 6e 69 6c 20 b-fold proc nil
4830: 62 61 67 29 29 0a 0a 3b 3b 20 50 72 6f 63 65 73 bag))..;; Proces
4840: 73 20 65 76 65 72 79 20 65 6c 65 6d 65 6e 74 20 s every element
4850: 61 6e 64 20 63 6f 70 79 20 74 68 65 20 6f 6e 65 and copy the one
4860: 73 20 74 68 61 74 20 73 61 74 69 73 66 79 20 74 s that satisfy t
4870: 68 65 20 70 72 65 64 69 63 61 74 65 2e 0a 3b 3b he predicate..;;
4880: 20 49 64 65 6e 74 69 63 61 6c 20 65 6c 65 6d 65 Identical eleme
4890: 6e 74 73 20 61 72 65 20 70 72 6f 63 65 73 73 65 nts are processe
48a0: 64 20 61 6c 6c 20 61 74 20 6f 6e 63 65 2e 20 20 d all at once.
48b0: 54 68 69 73 20 69 73 20 75 73 65 64 20 66 6f 72 This is used for
48c0: 20 62 6f 74 68 0a 3b 3b 20 66 69 6c 74 65 72 20 both.;; filter
48d0: 61 6e 64 20 72 65 6d 6f 76 65 2e 0a 0a 28 64 65 and remove...(de
48e0: 66 69 6e 65 20 28 73 6f 62 2d 66 69 6c 74 65 72 fine (sob-filter
48f0: 20 70 72 65 64 20 73 6f 62 29 0a 20 20 28 6c 65 pred sob). (le
4900: 74 20 28 28 72 65 73 75 6c 74 20 28 73 6f 62 2d t ((result (sob-
4910: 65 6d 70 74 79 2d 63 6f 70 79 20 73 6f 62 29 29 empty-copy sob))
4920: 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ). (hash-tabl
4930: 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 e-for-each.
4940: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 (lambda (key va
4950: 6c 75 65 29 0a 20 20 20 20 20 20 20 20 28 69 66 lue). (if
4960: 20 28 70 72 65 64 20 6b 65 79 29 20 28 73 6f 62 (pred key) (sob
4970: 2d 69 6e 63 72 65 6d 65 6e 74 21 20 72 65 73 75 -increment! resu
4980: 6c 74 20 6b 65 79 20 76 61 6c 75 65 29 29 29 0a lt key value))).
4990: 20 20 20 20 20 20 28 73 6f 62 2d 68 61 73 68 2d (sob-hash-
49a0: 74 61 62 6c 65 20 73 6f 62 29 29 0a 20 20 20 20 table sob)).
49b0: 72 65 73 75 6c 74 29 29 0a 0a 28 64 65 66 69 6e result))..(defin
49c0: 65 20 28 73 65 74 2d 66 69 6c 74 65 72 20 70 72 e (set-filter pr
49d0: 65 64 20 73 65 74 29 0a 20 20 28 63 68 65 63 6b ed set). (check
49e0: 2d 73 65 74 20 73 65 74 29 0a 20 20 28 73 6f 62 -set set). (sob
49f0: 2d 66 69 6c 74 65 72 20 70 72 65 64 20 73 65 74 -filter pred set
4a00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 ))..(define (bag
4a10: 2d 66 69 6c 74 65 72 20 70 72 65 64 20 62 61 67 -filter pred bag
4a20: 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 ). (check-bag b
4a30: 61 67 29 0a 20 20 28 73 6f 62 2d 66 69 6c 74 65 ag). (sob-filte
4a40: 72 20 70 72 65 64 20 62 61 67 29 29 0a 0a 28 64 r pred bag))..(d
4a50: 65 66 69 6e 65 20 28 73 65 74 2d 72 65 6d 6f 76 efine (set-remov
4a60: 65 20 70 72 65 64 20 73 65 74 29 0a 20 20 28 63 e pred set). (c
4a70: 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 heck-set set).
4a80: 28 73 6f 62 2d 66 69 6c 74 65 72 20 28 6c 61 6d (sob-filter (lam
4a90: 62 64 61 20 28 78 29 20 28 6e 6f 74 20 28 70 72 bda (x) (not (pr
4aa0: 65 64 20 78 29 29 29 20 73 65 74 29 29 0a 0a 28 ed x))) set))..(
4ab0: 64 65 66 69 6e 65 20 28 62 61 67 2d 72 65 6d 6f define (bag-remo
4ac0: 76 65 20 70 72 65 64 20 62 61 67 29 0a 20 20 28 ve pred bag). (
4ad0: 63 68 65 63 6b 2d 62 61 67 20 62 61 67 29 0a 20 check-bag bag).
4ae0: 20 28 73 6f 62 2d 66 69 6c 74 65 72 20 28 6c 61 (sob-filter (la
4af0: 6d 62 64 61 20 28 78 29 20 28 6e 6f 74 20 28 70 mbda (x) (not (p
4b00: 72 65 64 20 78 29 29 29 20 62 61 67 29 29 0a 0a red x))) bag))..
4b10: 3b 3b 20 50 72 6f 63 65 73 73 20 65 61 63 68 20 ;; Process each
4b20: 65 6c 65 6d 65 6e 74 20 61 6e 64 20 72 65 6d 6f element and remo
4b30: 76 65 20 74 68 6f 73 65 20 74 68 61 74 20 64 6f ve those that do
4b40: 6e 27 74 20 73 61 74 69 73 66 79 20 74 68 65 20 n't satisfy the
4b50: 66 69 6c 74 65 72 2e 0a 3b 3b 20 54 68 69 73 20 filter..;; This
4b60: 64 6f 65 73 20 69 74 73 20 6f 77 6e 20 63 6c 65 does its own cle
4b70: 61 6e 75 70 2c 20 61 6e 64 20 69 73 20 75 73 65 anup, and is use
4b80: 64 20 66 6f 72 20 62 6f 74 68 20 66 69 6c 74 65 d for both filte
4b90: 72 21 20 61 6e 64 20 72 65 6d 6f 76 65 21 2e 0a r! and remove!..
4ba0: 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 66 69 .(define (sob-fi
4bb0: 6c 74 65 72 21 20 70 72 65 64 20 73 6f 62 29 0a lter! pred sob).
4bc0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f (hash-table-fo
4bd0: 72 2d 65 61 63 68 0a 20 20 20 20 28 6c 61 6d 62 r-each. (lamb
4be0: 64 61 20 28 6b 65 79 20 76 61 6c 75 65 29 0a 20 da (key value).
4bf0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 70 (if (not (p
4c00: 72 65 64 20 6b 65 79 29 29 20 28 73 6f 62 2d 64 red key)) (sob-d
4c10: 65 63 72 65 6d 65 6e 74 21 20 73 6f 62 20 6b 65 ecrement! sob ke
4c20: 79 20 76 61 6c 75 65 29 29 29 0a 20 20 20 20 28 y value))). (
4c30: 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 sob-hash-table s
4c40: 6f 62 29 29 0a 20 20 28 73 6f 62 2d 63 6c 65 61 ob)). (sob-clea
4c50: 6e 75 70 21 20 73 6f 62 29 29 0a 0a 28 64 65 66 nup! sob))..(def
4c60: 69 6e 65 20 28 73 65 74 2d 66 69 6c 74 65 72 21 ine (set-filter!
4c70: 20 70 72 65 64 20 73 65 74 29 0a 20 20 28 63 68 pred set). (ch
4c80: 65 63 6b 2d 73 65 74 20 73 65 74 29 0a 20 20 28 eck-set set). (
4c90: 73 6f 62 2d 66 69 6c 74 65 72 21 20 70 72 65 64 sob-filter! pred
4ca0: 20 73 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 set))..(define
4cb0: 28 62 61 67 2d 66 69 6c 74 65 72 21 20 70 72 65 (bag-filter! pre
4cc0: 64 20 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d d bag). (check-
4cd0: 62 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 2d bag bag). (sob-
4ce0: 66 69 6c 74 65 72 21 20 70 72 65 64 20 62 61 67 filter! pred bag
4cf0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 ))..(define (set
4d00: 2d 72 65 6d 6f 76 65 21 20 70 72 65 64 20 73 65 -remove! pred se
4d10: 74 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 t). (check-set
4d20: 73 65 74 29 0a 20 20 28 73 6f 62 2d 66 69 6c 74 set). (sob-filt
4d30: 65 72 21 20 28 6c 61 6d 62 64 61 20 28 78 29 20 er! (lambda (x)
4d40: 28 6e 6f 74 20 28 70 72 65 64 20 78 29 29 29 20 (not (pred x)))
4d50: 73 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 set))..(define (
4d60: 62 61 67 2d 72 65 6d 6f 76 65 21 20 70 72 65 64 bag-remove! pred
4d70: 20 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 bag). (check-b
4d80: 61 67 20 62 61 67 29 0a 20 20 28 73 6f 62 2d 66 ag bag). (sob-f
4d90: 69 6c 74 65 72 21 20 28 6c 61 6d 62 64 61 20 28 ilter! (lambda (
4da0: 78 29 20 28 6e 6f 74 20 28 70 72 65 64 20 78 29 x) (not (pred x)
4db0: 29 29 20 62 61 67 29 29 0a 0a 3b 3b 20 43 72 65 )) bag))..;; Cre
4dc0: 61 74 65 20 74 77 6f 20 73 6f 62 73 20 61 6e 64 ate two sobs and
4dd0: 20 63 6f 70 79 20 74 68 65 20 65 6c 65 6d 65 6e copy the elemen
4de0: 74 73 20 74 68 61 74 20 73 61 74 69 73 66 79 20 ts that satisfy
4df0: 74 68 65 20 70 72 65 64 69 63 61 74 65 20 69 6e the predicate in
4e00: 74 6f 0a 3b 3b 20 6f 6e 65 20 6f 66 20 74 68 65 to.;; one of the
4e10: 6d 2c 20 61 6c 6c 20 6f 74 68 65 72 73 20 69 6e m, all others in
4e20: 74 6f 20 74 68 65 20 6f 74 68 65 72 2e 20 20 54 to the other. T
4e30: 68 69 73 20 69 73 20 6d 6f 72 65 20 65 66 66 69 his is more effi
4e40: 63 69 65 6e 74 20 74 68 61 6e 0a 3b 3b 20 66 69 cient than.;; fi
4e50: 6c 74 65 72 69 6e 67 20 61 6e 64 20 72 65 6d 6f ltering and remo
4e60: 76 69 6e 67 20 73 65 70 61 72 61 74 65 6c 79 2e ving separately.
4e70: 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 70 ..(define (sob-p
4e80: 61 72 74 69 74 69 6f 6e 20 70 72 65 64 20 73 6f artition pred so
4e90: 62 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 31 b). (let ((res1
4ea0: 20 28 73 6f 62 2d 65 6d 70 74 79 2d 63 6f 70 79 (sob-empty-copy
4eb0: 20 73 6f 62 29 29 0a 20 20 20 20 20 20 20 20 28 sob)). (
4ec0: 72 65 73 32 20 28 73 6f 62 2d 65 6d 70 74 79 2d res2 (sob-empty-
4ed0: 63 6f 70 79 20 73 6f 62 29 29 29 0a 20 20 20 20 copy sob))).
4ee0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d (hash-table-for-
4ef0: 65 61 63 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 each. (lamb
4f00: 64 61 20 28 6b 65 79 20 76 61 6c 75 65 29 0a 20 da (key value).
4f10: 20 20 20 20 20 20 20 28 69 66 20 28 70 72 65 64 (if (pred
4f20: 20 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 key).
4f30: 28 73 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 20 (sob-increment!
4f40: 72 65 73 31 20 6b 65 79 20 76 61 6c 75 65 29 0a res1 key value).
4f50: 20 20 20 20 20 20 20 20 20 20 28 73 6f 62 2d 69 (sob-i
4f60: 6e 63 72 65 6d 65 6e 74 21 20 72 65 73 32 20 6b ncrement! res2 k
4f70: 65 79 20 76 61 6c 75 65 29 29 29 0a 20 20 20 20 ey value))).
4f80: 20 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c (sob-hash-tabl
4f90: 65 20 73 6f 62 29 29 0a 20 20 20 20 28 76 61 6c e sob)). (val
4fa0: 75 65 73 20 72 65 73 31 20 72 65 73 32 29 29 29 ues res1 res2)))
4fb0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 70 ..(define (set-p
4fc0: 61 72 74 69 74 69 6f 6e 20 70 72 65 64 20 73 65 artition pred se
4fd0: 74 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 t). (check-set
4fe0: 73 65 74 29 0a 20 20 28 73 6f 62 2d 70 61 72 74 set). (sob-part
4ff0: 69 74 69 6f 6e 20 70 72 65 64 20 73 65 74 29 29 ition pred set))
5000: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 70 ..(define (bag-p
5010: 61 72 74 69 74 69 6f 6e 20 70 72 65 64 20 62 61 artition pred ba
5020: 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 g). (check-bag
5030: 62 61 67 29 0a 20 20 28 73 6f 62 2d 70 61 72 74 bag). (sob-part
5040: 69 74 69 6f 6e 20 70 72 65 64 20 62 61 67 29 29 ition pred bag))
5050: 0a 0a 3b 3b 20 43 72 65 61 74 65 20 61 20 73 6f ..;; Create a so
5060: 62 20 61 6e 64 20 69 74 65 72 61 74 65 20 74 68 b and iterate th
5070: 72 6f 75 67 68 20 74 68 65 20 67 69 76 65 6e 20 rough the given
5080: 73 6f 62 2e 20 20 41 6e 79 74 68 69 6e 67 20 74 sob. Anything t
5090: 68 61 74 20 73 61 74 69 73 66 69 65 73 0a 3b 3b hat satisfies.;;
50a0: 20 74 68 65 20 70 72 65 64 69 63 61 74 65 20 69 the predicate i
50b0: 73 20 6c 65 66 74 20 61 6c 6f 6e 65 3b 20 61 6e s left alone; an
50c0: 79 74 68 69 6e 67 20 74 68 61 74 20 64 6f 65 73 ything that does
50d0: 6e 27 74 20 69 73 20 72 65 6d 6f 76 65 64 20 66 n't is removed f
50e0: 72 6f 6d 20 74 68 65 0a 3b 3b 20 67 69 76 65 6e rom the.;; given
50f0: 20 73 6f 62 20 61 6e 64 20 61 64 64 65 64 20 74 sob and added t
5100: 6f 20 74 68 65 20 6e 65 77 20 73 6f 62 2e 0a 0a o the new sob...
5110: 28 64 65 66 69 6e 65 20 28 73 6f 62 2d 70 61 72 (define (sob-par
5120: 74 69 74 69 6f 6e 21 20 70 72 65 64 20 73 6f 62 tition! pred sob
5130: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c ). (let ((resul
5140: 74 20 28 73 6f 62 2d 65 6d 70 74 79 2d 63 6f 70 t (sob-empty-cop
5150: 79 20 73 6f 62 29 29 29 0a 20 20 20 20 28 68 61 y sob))). (ha
5160: 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 sh-table-for-eac
5170: 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h. (lambda
5180: 28 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 20 20 (key value).
5190: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 70 72 (if (not (pr
51a0: 65 64 20 6b 65 79 29 29 0a 20 20 20 20 20 20 20 ed key)).
51b0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
51c0: 20 20 20 20 20 20 28 73 6f 62 2d 64 65 63 72 65 (sob-decre
51d0: 6d 65 6e 74 21 20 73 6f 62 20 6b 65 79 20 76 61 ment! sob key va
51e0: 6c 75 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 lue).
51f0: 20 28 73 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 (sob-increment!
5200: 20 72 65 73 75 6c 74 20 6b 65 79 20 76 61 6c 75 result key valu
5210: 65 29 29 29 29 0a 20 20 20 20 20 20 28 73 6f 62 e)))). (sob
5220: 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 -hash-table sob)
5230: 29 0a 20 20 20 20 28 76 61 6c 75 65 73 20 28 73 ). (values (s
5240: 6f 62 2d 63 6c 65 61 6e 75 70 21 20 73 6f 62 29 ob-cleanup! sob)
5250: 20 72 65 73 75 6c 74 29 29 29 0a 0a 28 64 65 66 result)))..(def
5260: 69 6e 65 20 28 73 65 74 2d 70 61 72 74 69 74 69 ine (set-partiti
5270: 6f 6e 21 20 70 72 65 64 20 73 65 74 29 0a 20 20 on! pred set).
5280: 28 63 68 65 63 6b 2d 73 65 74 20 73 65 74 29 0a (check-set set).
5290: 20 20 28 73 6f 62 2d 70 61 72 74 69 74 69 6f 6e (sob-partition
52a0: 21 20 70 72 65 64 20 73 65 74 29 29 0a 0a 28 64 ! pred set))..(d
52b0: 65 66 69 6e 65 20 28 62 61 67 2d 70 61 72 74 69 efine (bag-parti
52c0: 74 69 6f 6e 21 20 70 72 65 64 20 62 61 67 29 0a tion! pred bag).
52d0: 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 61 67 (check-bag bag
52e0: 29 0a 20 20 28 73 6f 62 2d 70 61 72 74 69 74 69 ). (sob-partiti
52f0: 6f 6e 21 20 70 72 65 64 20 62 61 67 29 29 0a 0a on! pred bag))..
5300: 0a 3b 3b 3b 20 43 6f 70 79 69 6e 67 20 61 6e 64 .;;; Copying and
5310: 20 63 6f 6e 76 65 72 73 69 6f 6e 0a 0a 3b 3b 3b conversion..;;;
5320: 20 43 6f 6e 76 65 72 74 20 61 20 73 6f 62 20 74 Convert a sob t
5330: 6f 20 61 20 6c 69 73 74 3b 20 61 20 73 70 65 63 o a list; a spec
5340: 69 61 6c 20 63 61 73 65 20 6f 66 20 73 6f 62 2d ial case of sob-
5350: 66 6f 6c 64 2e 0a 0a 28 64 65 66 69 6e 65 20 28 fold...(define (
5360: 73 6f 62 2d 3e 6c 69 73 74 20 73 6f 62 29 0a 20 sob->list sob).
5370: 20 28 73 6f 62 2d 66 6f 6c 64 20 28 6c 61 6d 62 (sob-fold (lamb
5380: 64 61 20 28 65 6c 65 6d 20 6c 69 73 74 29 20 28 da (elem list) (
5390: 63 6f 6e 73 20 65 6c 65 6d 20 6c 69 73 74 29 29 cons elem list))
53a0: 20 27 28 29 20 73 6f 62 29 29 0a 0a 28 64 65 66 '() sob))..(def
53b0: 69 6e 65 20 28 73 65 74 2d 3e 6c 69 73 74 20 73 ine (set->list s
53c0: 65 74 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 et). (check-set
53d0: 20 73 65 74 29 0a 20 20 28 73 6f 62 2d 3e 6c 69 set). (sob->li
53e0: 73 74 20 73 65 74 29 29 0a 0a 28 64 65 66 69 6e st set))..(defin
53f0: 65 20 28 62 61 67 2d 3e 6c 69 73 74 20 62 61 67 e (bag->list bag
5400: 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 ). (check-bag b
5410: 61 67 29 0a 20 20 28 73 6f 62 2d 3e 6c 69 73 74 ag). (sob->list
5420: 20 62 61 67 29 29 0a 0a 3b 3b 20 43 6f 6e 76 65 bag))..;; Conve
5430: 72 74 20 61 20 6c 69 73 74 20 74 6f 20 61 20 73 rt a list to a s
5440: 6f 62 2e 20 20 50 72 6f 62 61 62 6c 79 20 63 6f ob. Probably co
5450: 75 6c 64 20 62 65 20 64 6f 6e 65 20 75 73 69 6e uld be done usin
5460: 67 20 75 6e 66 6f 6c 64 2c 20 62 75 74 0a 3b 3b g unfold, but.;;
5470: 20 73 69 6e 63 65 20 73 6f 62 73 20 61 72 65 20 since sobs are
5480: 6d 75 74 61 62 6c 65 20 61 6e 79 77 61 79 2c 20 mutable anyway,
5490: 69 74 27 73 20 6a 75 73 74 20 61 73 20 65 61 73 it's just as eas
54a0: 79 20 74 6f 20 61 64 64 20 74 68 65 20 65 6c 65 y to add the ele
54b0: 6d 65 6e 74 73 0a 3b 3b 20 62 79 20 73 69 64 65 ments.;; by side
54c0: 20 65 66 66 65 63 74 2e 0a 0a 28 64 65 66 69 6e effect...(defin
54d0: 65 20 28 6c 69 73 74 2d 3e 73 6f 62 21 20 73 6f e (list->sob! so
54e0: 62 20 6c 69 73 74 29 0a 20 20 28 66 6f 72 2d 65 b list). (for-e
54f0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 65 6c 65 ach (lambda (ele
5500: 6d 29 20 28 73 6f 62 2d 69 6e 63 72 65 6d 65 6e m) (sob-incremen
5510: 74 21 20 73 6f 62 20 65 6c 65 6d 20 31 29 29 20 t! sob elem 1))
5520: 6c 69 73 74 29 0a 20 20 73 6f 62 29 0a 0a 28 64 list). sob)..(d
5530: 65 66 69 6e 65 20 28 6c 69 73 74 2d 3e 73 65 74 efine (list->set
5540: 20 63 6f 6d 70 61 72 61 74 6f 72 20 6c 69 73 74 comparator list
5550: 29 0a 20 20 28 6c 69 73 74 2d 3e 73 6f 62 21 20 ). (list->sob!
5560: 28 6d 61 6b 65 2d 73 6f 62 20 63 6f 6d 70 61 72 (make-sob compar
5570: 61 74 6f 72 20 23 66 29 20 6c 69 73 74 29 29 0a ator #f) list)).
5580: 0a 28 64 65 66 69 6e 65 20 28 6c 69 73 74 2d 3e .(define (list->
5590: 62 61 67 20 63 6f 6d 70 61 72 61 74 6f 72 20 6c bag comparator l
55a0: 69 73 74 29 0a 20 20 28 6c 69 73 74 2d 3e 73 6f ist). (list->so
55b0: 62 21 20 28 6d 61 6b 65 2d 73 6f 62 20 63 6f 6d b! (make-sob com
55c0: 70 61 72 61 74 6f 72 20 23 74 29 20 6c 69 73 74 parator #t) list
55d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6c 69 73 ))..(define (lis
55e0: 74 2d 3e 73 65 74 21 20 73 65 74 20 6c 69 73 74 t->set! set list
55f0: 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 ). (check-set s
5600: 65 74 29 0a 20 20 28 6c 69 73 74 2d 3e 73 6f 62 et). (list->sob
5610: 21 20 73 65 74 20 6c 69 73 74 29 29 0a 0a 28 64 ! set list))..(d
5620: 65 66 69 6e 65 20 28 6c 69 73 74 2d 3e 62 61 67 efine (list->bag
5630: 21 20 62 61 67 20 6c 69 73 74 29 0a 20 20 28 63 ! bag list). (c
5640: 68 65 63 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 heck-bag bag).
5650: 28 6c 69 73 74 2d 3e 73 6f 62 21 20 62 61 67 20 (list->sob! bag
5660: 6c 69 73 74 29 29 0a 0a 0a 3b 3b 3b 20 53 75 62 list))...;;; Sub
5670: 73 65 74 73 0a 0a 3b 3b 20 41 6c 6c 20 6f 66 20 sets..;; All of
5680: 74 68 65 73 65 20 70 72 6f 63 65 64 75 72 65 73 these procedures
5690: 20 66 6f 6c 6c 6f 77 20 74 68 65 20 73 61 6d 65 follow the same
56a0: 20 70 61 74 74 65 72 6e 2e 20 20 54 68 65 0a 3b pattern. The.;
56b0: 3b 20 73 6f 62 3c 6f 70 3e 3f 20 70 72 6f 63 65 ; sob<op>? proce
56c0: 64 75 72 65 73 20 61 72 65 20 63 61 73 65 2d 6c dures are case-l
56d0: 61 6d 62 64 61 73 20 74 68 61 74 20 72 65 64 75 ambdas that redu
56e0: 63 65 20 74 68 65 20 6d 75 6c 74 69 2d 61 72 67 ce the multi-arg
56f0: 75 6d 65 6e 74 0a 3b 3b 20 63 61 73 65 20 74 6f ument.;; case to
5700: 20 74 68 65 20 74 77 6f 2d 61 72 67 75 6d 65 6e the two-argumen
5710: 74 20 63 61 73 65 2e 20 20 41 73 20 75 73 75 61 t case. As usua
5720: 6c 2c 20 74 68 65 20 73 65 74 3c 6f 70 3e 3f 20 l, the set<op>?
5730: 61 6e 64 0a 3b 3b 20 62 61 67 3c 6f 70 3e 3f 20 and.;; bag<op>?
5740: 70 72 6f 63 65 64 75 72 65 73 20 61 72 65 20 74 procedures are t
5750: 72 69 76 69 61 6c 20 6c 61 79 65 72 73 20 6f 76 rivial layers ov
5760: 65 72 20 74 68 65 20 73 6f 62 3c 6f 70 3e 3f 20 er the sob<op>?
5770: 70 72 6f 63 65 64 75 72 65 2e 0a 3b 3b 20 54 68 procedure..;; Th
5780: 65 20 64 79 61 64 69 63 2d 73 6f 62 3c 6f 70 3e e dyadic-sob<op>
5790: 3f 20 70 72 6f 63 65 64 75 72 65 73 20 61 72 65 ? procedures are
57a0: 20 77 68 65 72 65 20 69 74 20 67 65 74 73 20 69 where it gets i
57b0: 6e 74 65 72 65 73 74 69 6e 67 2c 20 73 6f 20 73 nteresting, so s
57c0: 65 65 0a 3b 3b 20 74 68 65 20 63 6f 6d 6d 65 6e ee.;; the commen
57d0: 74 73 20 6f 6e 20 74 68 65 6d 2e 0a 0a 28 64 65 ts on them...(de
57e0: 66 69 6e 65 20 73 6f 62 3d 3f 0a 20 20 28 63 61 fine sob=?. (ca
57f0: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 se-lambda. ((
5800: 73 6f 62 29 20 23 74 29 0a 20 20 20 20 28 28 73 sob) #t). ((s
5810: 6f 62 31 20 73 6f 62 32 29 20 28 64 79 61 64 69 ob1 sob2) (dyadi
5820: 63 2d 73 6f 62 3d 3f 20 73 6f 62 31 20 73 6f 62 c-sob=? sob1 sob
5830: 32 29 29 0a 20 20 20 20 28 28 73 6f 62 31 20 73 2)). ((sob1 s
5840: 6f 62 32 20 2e 20 73 6f 62 73 29 0a 20 20 20 20 ob2 . sobs).
5850: 20 28 61 6e 64 20 28 64 79 61 64 69 63 2d 73 6f (and (dyadic-so
5860: 62 3d 3f 20 73 6f 62 31 20 73 6f 62 32 29 0a 20 b=? sob1 sob2).
5870: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
5880: 73 6f 62 3d 3f 20 73 6f 62 32 20 73 6f 62 73 29 sob=? sob2 sobs)
5890: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
58a0: 65 74 3d 3f 20 2e 20 73 65 74 73 29 0a 20 20 28 et=? . sets). (
58b0: 63 68 65 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 check-all-sets s
58c0: 65 74 73 29 0a 20 20 28 61 70 70 6c 79 20 73 6f ets). (apply so
58d0: 62 3d 3f 20 73 65 74 73 29 29 0a 0a 28 64 65 66 b=? sets))..(def
58e0: 69 6e 65 20 28 62 61 67 3d 3f 20 2e 20 62 61 67 ine (bag=? . bag
58f0: 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c 6c 2d s). (check-all-
5900: 62 61 67 73 20 62 61 67 73 29 0a 20 20 28 61 70 bags bags). (ap
5910: 70 6c 79 20 73 6f 62 3d 3f 20 62 61 67 73 29 29 ply sob=? bags))
5920: 0a 0a 3b 3b 20 46 69 72 73 74 20 77 65 20 63 68 ..;; First we ch
5930: 65 63 6b 20 74 68 61 74 20 74 68 65 72 65 20 61 eck that there a
5940: 72 65 20 74 68 65 20 73 61 6d 65 20 6e 75 6d 62 re the same numb
5950: 65 72 20 6f 66 20 65 6e 74 72 69 65 73 20 69 6e er of entries in
5960: 20 74 68 65 0a 3b 3b 20 68 61 73 68 74 61 62 6c the.;; hashtabl
5970: 65 73 20 6f 66 20 74 68 65 20 74 77 6f 20 73 6f es of the two so
5980: 62 73 3b 20 69 66 20 74 68 61 74 27 73 20 6e 6f bs; if that's no
5990: 74 20 74 72 75 65 2c 20 74 68 65 79 20 63 61 6e t true, they can
59a0: 27 74 20 62 65 20 65 71 75 61 6c 2e 0a 3b 3b 20 't be equal..;;
59b0: 54 68 65 6e 20 77 65 20 63 68 65 63 6b 20 74 68 Then we check th
59c0: 61 74 20 66 6f 72 20 65 61 63 68 20 6b 65 79 2c at for each key,
59d0: 20 74 68 65 20 76 61 6c 75 65 73 20 61 72 65 20 the values are
59e0: 74 68 65 20 73 61 6d 65 20 28 77 68 65 72 65 0a the same (where.
59f0: 3b 3b 20 62 65 69 6e 67 20 61 62 73 65 6e 74 20 ;; being absent
5a00: 63 6f 75 6e 74 73 20 61 73 20 61 20 76 61 6c 75 counts as a valu
5a10: 65 20 6f 66 20 30 29 2e 20 20 49 66 20 61 6e 79 e of 0). If any
5a20: 20 76 61 6c 75 65 73 20 61 72 65 6e 27 74 20 65 values aren't e
5a30: 71 75 61 6c 2c 0a 3b 3b 20 61 67 61 69 6e 20 74 qual,.;; again t
5a40: 68 65 79 20 63 61 6e 27 74 20 62 65 20 65 71 75 hey can't be equ
5a50: 61 6c 2e 0a 0a 28 64 65 66 69 6e 65 20 28 64 79 al...(define (dy
5a60: 61 64 69 63 2d 73 6f 62 3d 3f 20 73 6f 62 31 20 adic-sob=? sob1
5a70: 73 6f 62 32 29 0a 20 20 28 63 61 6c 6c 2f 63 63 sob2). (call/cc
5a80: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 . (lambda (re
5a90: 74 75 72 6e 29 0a 20 20 20 20 20 20 28 6c 65 74 turn). (let
5aa0: 20 28 28 68 74 31 20 28 73 6f 62 2d 68 61 73 68 ((ht1 (sob-hash
5ab0: 2d 74 61 62 6c 65 20 73 6f 62 31 29 29 0a 20 20 -table sob1)).
5ac0: 20 20 20 20 20 20 20 20 20 20 28 68 74 32 20 28 (ht2 (
5ad0: 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 sob-hash-table s
5ae0: 6f 62 32 29 29 29 0a 20 20 20 20 20 20 20 20 28 ob2))). (
5af0: 69 66 20 28 6e 6f 74 20 28 3d 20 28 68 61 73 68 if (not (= (hash
5b00: 2d 74 61 62 6c 65 2d 73 69 7a 65 20 68 74 31 29 -table-size ht1)
5b10: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 69 7a (hash-table-siz
5b20: 65 20 68 74 32 29 29 29 0a 20 20 20 20 20 20 20 e ht2))).
5b30: 20 20 20 28 72 65 74 75 72 6e 20 23 66 29 29 0a (return #f)).
5b40: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
5b50: 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 ble-for-each.
5b60: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
5b70: 6b 65 79 20 76 61 6c 75 65 29 0a 20 20 20 20 20 key value).
5b80: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
5b90: 28 3d 20 76 61 6c 75 65 20 28 68 61 73 68 2d 74 (= value (hash-t
5ba0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5bb0: 20 68 74 32 20 6b 65 79 20 30 29 29 29 0a 20 20 ht2 key 0))).
5bc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 74 (ret
5bd0: 75 72 6e 20 23 66 29 29 29 0a 20 20 20 20 20 20 urn #f))).
5be0: 20 20 20 20 68 74 31 29 29 0a 20 20 20 20 20 23 ht1)). #
5bf0: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 6f t)))..(define so
5c00: 62 3c 3d 3f 0a 20 20 28 63 61 73 65 2d 6c 61 6d b<=?. (case-lam
5c10: 62 64 61 0a 20 20 20 20 28 28 73 6f 62 29 20 23 bda. ((sob) #
5c20: 74 29 0a 20 20 20 20 28 28 73 6f 62 31 20 73 6f t). ((sob1 so
5c30: 62 32 29 20 28 64 79 61 64 69 63 2d 73 6f 62 3c b2) (dyadic-sob<
5c40: 3d 3f 20 73 6f 62 31 20 73 6f 62 32 29 29 0a 20 =? sob1 sob2)).
5c50: 20 20 20 28 28 73 6f 62 31 20 73 6f 62 32 20 2e ((sob1 sob2 .
5c60: 20 73 6f 62 73 29 0a 20 20 20 20 20 28 61 6e 64 sobs). (and
5c70: 20 28 64 79 61 64 69 63 2d 73 6f 62 3c 3d 3f 20 (dyadic-sob<=?
5c80: 73 6f 62 31 20 73 6f 62 32 29 0a 20 20 20 20 20 sob1 sob2).
5c90: 20 20 20 20 20 28 61 70 70 6c 79 20 73 6f 62 3c (apply sob<
5ca0: 3d 3f 20 73 6f 62 32 20 73 6f 62 73 29 29 29 29 =? sob2 sobs))))
5cb0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 3c )..(define (set<
5cc0: 3d 3f 20 2e 20 73 65 74 73 29 0a 20 20 28 63 68 =? . sets). (ch
5cd0: 65 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 65 74 eck-all-sets set
5ce0: 73 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 3c s). (apply sob<
5cf0: 3d 3f 20 73 65 74 73 29 29 0a 0a 28 64 65 66 69 =? sets))..(defi
5d00: 6e 65 20 28 62 61 67 3c 3d 3f 20 2e 20 62 61 67 ne (bag<=? . bag
5d10: 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c 6c 2d s). (check-all-
5d20: 62 61 67 73 20 62 61 67 73 29 0a 20 20 28 61 70 bags bags). (ap
5d30: 70 6c 79 20 73 6f 62 3c 3d 3f 20 62 61 67 73 29 ply sob<=? bags)
5d40: 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 6e )..;; This is an
5d50: 61 6c 6f 67 6f 75 73 20 74 6f 20 64 79 61 64 69 alogous to dyadi
5d60: 63 2d 73 6f 62 3d 3f 2c 20 65 78 63 65 70 74 20 c-sob=?, except
5d70: 74 68 61 74 20 77 65 20 68 61 76 65 20 74 6f 20 that we have to
5d80: 63 68 65 63 6b 0a 3b 3b 20 62 6f 74 68 20 73 6f check.;; both so
5d90: 62 73 20 74 6f 20 6d 61 6b 65 20 73 75 72 65 20 bs to make sure
5da0: 65 61 63 68 20 76 61 6c 75 65 20 69 73 20 3c 3d each value is <=
5db0: 20 69 6e 20 6f 72 64 65 72 20 74 6f 20 62 65 20 in order to be
5dc0: 73 75 72 65 0a 3b 3b 20 74 68 61 74 20 77 65 27 sure.;; that we'
5dd0: 76 65 20 74 72 61 76 65 72 73 65 64 20 61 6c 6c ve traversed all
5de0: 20 74 68 65 20 65 6c 65 6d 65 6e 74 73 20 69 6e the elements in
5df0: 20 65 69 74 68 65 72 20 73 6f 62 2e 0a 0a 28 64 either sob...(d
5e00: 65 66 69 6e 65 20 28 64 79 61 64 69 63 2d 73 6f efine (dyadic-so
5e10: 62 3c 3d 3f 20 73 6f 62 31 20 73 6f 62 32 29 0a b<=? sob1 sob2).
5e20: 20 20 28 63 61 6c 6c 2f 63 63 0a 20 20 20 20 28 (call/cc. (
5e30: 6c 61 6d 62 64 61 20 28 72 65 74 75 72 6e 29 0a lambda (return).
5e40: 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 74 31 (let ((ht1
5e50: 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 (sob-hash-table
5e60: 20 73 6f 62 31 29 29 0a 20 20 20 20 20 20 20 20 sob1)).
5e70: 20 20 20 20 28 68 74 32 20 28 73 6f 62 2d 68 61 (ht2 (sob-ha
5e80: 73 68 2d 74 61 62 6c 65 20 73 6f 62 32 29 29 29 sh-table sob2)))
5e90: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f . (if (no
5ea0: 74 20 28 3c 3d 20 28 68 61 73 68 2d 74 61 62 6c t (<= (hash-tabl
5eb0: 65 2d 73 69 7a 65 20 68 74 31 29 20 28 68 61 73 e-size ht1) (has
5ec0: 68 2d 74 61 62 6c 65 2d 73 69 7a 65 20 68 74 32 h-table-size ht2
5ed0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 72 ))). (r
5ee0: 65 74 75 72 6e 20 23 66 29 29 0a 20 20 20 20 20 eturn #f)).
5ef0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 (hash-table-f
5f00: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 20 or-each.
5f10: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 (lambda (key v
5f20: 61 6c 75 65 29 0a 20 20 20 20 20 20 20 20 20 20 alue).
5f30: 20 20 28 69 66 20 28 6e 6f 74 20 28 3c 3d 20 76 (if (not (<= v
5f40: 61 6c 75 65 20 28 68 61 73 68 2d 74 61 62 6c 65 alue (hash-table
5f50: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 32 -ref/default ht2
5f60: 20 6b 65 79 20 30 29 29 29 0a 20 20 20 20 20 20 key 0))).
5f70: 20 20 20 20 20 20 20 20 28 72 65 74 75 72 6e 20 (return
5f80: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
5f90: 68 74 31 29 29 0a 20 20 20 20 20 20 23 74 29 29 ht1)). #t))
5fa0: 29 0a 0a 28 64 65 66 69 6e 65 20 73 6f 62 3e 3f )..(define sob>?
5fb0: 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a . (case-lambda.
5fc0: 20 20 20 20 28 28 73 6f 62 29 20 23 74 29 0a 20 ((sob) #t).
5fd0: 20 20 20 28 28 73 6f 62 31 20 73 6f 62 32 29 20 ((sob1 sob2)
5fe0: 28 64 79 61 64 69 63 2d 73 6f 62 3e 3f 20 73 6f (dyadic-sob>? so
5ff0: 62 31 20 73 6f 62 32 29 29 0a 20 20 20 20 28 28 b1 sob2)). ((
6000: 73 6f 62 31 20 73 6f 62 32 20 2e 20 73 6f 62 73 sob1 sob2 . sobs
6010: 29 0a 20 20 20 20 20 28 61 6e 64 20 28 64 79 61 ). (and (dya
6020: 64 69 63 2d 73 6f 62 3e 3f 20 73 6f 62 31 20 73 dic-sob>? sob1 s
6030: 6f 62 32 29 0a 20 20 20 20 20 20 20 20 20 20 28 ob2). (
6040: 61 70 70 6c 79 20 73 6f 62 3e 3f 20 73 6f 62 32 apply sob>? sob2
6050: 20 73 6f 62 73 29 29 29 29 29 0a 0a 28 64 65 66 sobs)))))..(def
6060: 69 6e 65 20 28 73 65 74 3e 3f 20 2e 20 73 65 74 ine (set>? . set
6070: 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c 6c 2d s). (check-all-
6080: 73 65 74 73 20 73 65 74 73 29 0a 20 20 28 61 70 sets sets). (ap
6090: 70 6c 79 20 73 6f 62 3e 3f 20 73 65 74 73 29 29 ply sob>? sets))
60a0: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 3e 3f ..(define (bag>?
60b0: 20 2e 20 62 61 67 73 29 0a 20 20 28 63 68 65 63 . bags). (chec
60c0: 6b 2d 61 6c 6c 2d 62 61 67 73 20 62 61 67 73 29 k-all-bags bags)
60d0: 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 3e 3f 20 . (apply sob>?
60e0: 62 61 67 73 29 29 0a 0a 3b 3b 20 3e 20 69 73 20 bags))..;; > is
60f0: 74 68 65 20 6e 65 67 61 74 69 6f 6e 20 6f 66 20 the negation of
6100: 3c 3d 2e 20 20 4e 6f 74 65 20 74 68 61 74 20 74 <=. Note that t
6110: 68 69 73 20 69 73 20 6f 6e 6c 79 20 74 72 75 65 his is only true
6120: 20 61 74 20 74 68 65 20 64 79 61 64 69 63 0a 3b at the dyadic.;
6130: 3b 20 6c 65 76 65 6c 3b 20 77 65 20 63 61 6e 27 ; level; we can'
6140: 74 20 6a 75 73 74 20 72 65 70 6c 61 63 65 20 73 t just replace s
6150: 6f 62 3e 3f 20 77 69 74 68 20 61 20 6e 65 67 61 ob>? with a nega
6160: 74 69 6f 6e 20 6f 66 20 73 6f 62 3c 3d 3f 2e 0a tion of sob<=?..
6170: 0a 28 64 65 66 69 6e 65 20 28 64 79 61 64 69 63 .(define (dyadic
6180: 2d 73 6f 62 3e 3f 20 73 6f 62 31 20 73 6f 62 32 -sob>? sob1 sob2
6190: 29 0a 20 20 28 6e 6f 74 20 28 64 79 61 64 69 63 ). (not (dyadic
61a0: 2d 73 6f 62 3c 3d 3f 20 73 6f 62 31 20 73 6f 62 -sob<=? sob1 sob
61b0: 32 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 6f 2)))..(define so
61c0: 62 3c 3f 0a 20 20 28 63 61 73 65 2d 6c 61 6d 62 b<?. (case-lamb
61d0: 64 61 0a 20 20 20 20 28 28 73 6f 62 29 20 23 74 da. ((sob) #t
61e0: 29 0a 20 20 20 20 28 28 73 6f 62 31 20 73 6f 62 ). ((sob1 sob
61f0: 32 29 20 28 64 79 61 64 69 63 2d 73 6f 62 3c 3f 2) (dyadic-sob<?
6200: 20 73 6f 62 31 20 73 6f 62 32 29 29 0a 20 20 20 sob1 sob2)).
6210: 20 28 28 73 6f 62 31 20 73 6f 62 32 20 2e 20 73 ((sob1 sob2 . s
6220: 6f 62 73 29 0a 20 20 20 20 20 28 61 6e 64 20 28 obs). (and (
6230: 64 79 61 64 69 63 2d 73 6f 62 3c 3f 20 73 6f 62 dyadic-sob<? sob
6240: 31 20 73 6f 62 32 29 0a 20 20 20 20 20 20 20 20 1 sob2).
6250: 20 20 28 61 70 70 6c 79 20 73 6f 62 3c 3f 20 73 (apply sob<? s
6260: 6f 62 32 20 73 6f 62 73 29 29 29 29 29 0a 0a 28 ob2 sobs)))))..(
6270: 64 65 66 69 6e 65 20 28 73 65 74 3c 3f 20 2e 20 define (set<? .
6280: 73 65 74 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 sets). (check-a
6290: 6c 6c 2d 73 65 74 73 20 73 65 74 73 29 0a 20 20 ll-sets sets).
62a0: 28 61 70 70 6c 79 20 73 6f 62 3c 3f 20 73 65 74 (apply sob<? set
62b0: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 s))..(define (ba
62c0: 67 3c 3f 20 2e 20 62 61 67 73 29 0a 20 20 28 63 g<? . bags). (c
62d0: 68 65 63 6b 2d 61 6c 6c 2d 62 61 67 73 20 62 61 heck-all-bags ba
62e0: 67 73 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 gs). (apply sob
62f0: 3c 3f 20 62 61 67 73 29 29 0a 0a 3b 3b 20 3c 20 <? bags))..;; <
6300: 69 73 20 74 68 65 20 69 6e 76 65 72 73 65 20 6f is the inverse o
6310: 66 20 3e 2e 20 20 41 67 61 69 6e 2c 20 74 68 69 f >. Again, thi
6320: 73 20 69 73 20 6f 6e 6c 79 20 74 72 75 65 20 64 s is only true d
6330: 79 61 64 69 63 61 6c 6c 79 2e 0a 0a 28 64 65 66 yadically...(def
6340: 69 6e 65 20 28 64 79 61 64 69 63 2d 73 6f 62 3c ine (dyadic-sob<
6350: 3f 20 73 6f 62 31 20 73 6f 62 32 29 0a 20 20 28 ? sob1 sob2). (
6360: 64 79 61 64 69 63 2d 73 6f 62 3e 3f 20 73 6f 62 dyadic-sob>? sob
6370: 32 20 73 6f 62 31 29 29 0a 0a 28 64 65 66 69 6e 2 sob1))..(defin
6380: 65 20 73 6f 62 3e 3d 3f 0a 20 20 28 63 61 73 65 e sob>=?. (case
6390: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 28 28 73 6f -lambda. ((so
63a0: 62 29 20 23 74 29 0a 20 20 20 20 28 28 73 6f 62 b) #t). ((sob
63b0: 31 20 73 6f 62 32 29 20 28 64 79 61 64 69 63 2d 1 sob2) (dyadic-
63c0: 73 6f 62 3e 3d 3f 20 73 6f 62 31 20 73 6f 62 32 sob>=? sob1 sob2
63d0: 29 29 0a 20 20 20 20 28 28 73 6f 62 31 20 73 6f )). ((sob1 so
63e0: 62 32 20 2e 20 73 6f 62 73 29 0a 20 20 20 20 20 b2 . sobs).
63f0: 28 61 6e 64 20 28 64 79 61 64 69 63 2d 73 6f 62 (and (dyadic-sob
6400: 3e 3d 3f 20 73 6f 62 31 20 73 6f 62 32 29 0a 20 >=? sob1 sob2).
6410: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
6420: 73 6f 62 3e 3d 3f 20 73 6f 62 32 20 73 6f 62 73 sob>=? sob2 sobs
6430: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
6440: 73 65 74 3e 3d 3f 20 2e 20 73 65 74 73 29 0a 20 set>=? . sets).
6450: 20 28 63 68 65 63 6b 2d 61 6c 6c 2d 73 65 74 73 (check-all-sets
6460: 20 73 65 74 73 29 0a 20 20 28 61 70 70 6c 79 20 sets). (apply
6470: 73 6f 62 3e 3d 3f 20 73 65 74 73 29 29 0a 0a 28 sob>=? sets))..(
6480: 64 65 66 69 6e 65 20 28 62 61 67 3e 3d 3f 20 2e define (bag>=? .
6490: 20 62 61 67 73 29 0a 20 20 28 63 68 65 63 6b 2d bags). (check-
64a0: 61 6c 6c 2d 62 61 67 73 20 62 61 67 73 29 0a 20 all-bags bags).
64b0: 20 28 61 70 70 6c 79 20 73 6f 62 3e 3d 3f 20 62 (apply sob>=? b
64c0: 61 67 73 29 29 0a 0a 3b 3b 20 46 69 6e 61 6c 6c ags))..;; Finall
64d0: 79 2c 20 3e 3d 20 69 73 20 74 68 65 20 6e 65 67 y, >= is the neg
64e0: 61 74 69 6f 6e 20 6f 66 20 3c 2e 20 20 47 6f 6f ation of <. Goo
64f0: 64 20 74 68 69 6e 67 20 77 65 20 68 61 76 65 20 d thing we have
6500: 74 61 69 6c 20 72 65 63 75 72 73 69 6f 6e 2e 0a tail recursion..
6510: 0a 28 64 65 66 69 6e 65 20 28 64 79 61 64 69 63 .(define (dyadic
6520: 2d 73 6f 62 3e 3d 3f 20 73 6f 62 31 20 73 6f 62 -sob>=? sob1 sob
6530: 32 29 0a 20 20 28 6e 6f 74 20 28 64 79 61 64 69 2). (not (dyadi
6540: 63 2d 73 6f 62 3c 3f 20 73 6f 62 31 20 73 6f 62 c-sob<? sob1 sob
6550: 32 29 29 29 0a 0a 0a 3b 3b 3b 20 53 65 74 20 74 2)))...;;; Set t
6560: 68 65 6f 72 79 20 6f 70 65 72 61 74 69 6f 6e 73 heory operations
6570: 0a 0a 3b 3b 20 41 20 74 72 69 76 69 61 6c 20 68 ..;; A trivial h
6580: 65 6c 70 65 72 20 66 75 6e 63 74 69 6f 6e 20 77 elper function w
6590: 68 69 63 68 20 75 70 70 65 72 2d 62 6f 75 6e 64 hich upper-bound
65a0: 73 20 6e 20 62 79 20 6f 6e 65 20 69 66 20 6d 75 s n by one if mu
65b0: 6c 74 69 3f 20 69 73 20 66 61 6c 73 65 2e 0a 0a lti? is false...
65c0: 28 64 65 66 69 6e 65 20 28 6d 61 78 2d 6f 6e 65 (define (max-one
65d0: 20 6e 20 6d 75 6c 74 69 3f 29 0a 20 20 20 20 28 n multi?). (
65e0: 69 66 20 6d 75 6c 74 69 3f 20 6e 20 28 69 66 20 if multi? n (if
65f0: 28 3e 20 6e 20 31 29 20 31 20 6e 29 29 29 0a 0a (> n 1) 1 n)))..
6600: 3b 3b 20 54 68 65 20 6c 6f 67 69 63 20 6f 66 20 ;; The logic of
6610: 75 6e 69 6f 6e 2c 20 69 6e 74 65 72 73 65 63 74 union, intersect
6620: 69 6f 6e 2c 20 64 69 66 66 65 72 65 6e 63 65 2c ion, difference,
6630: 20 61 6e 64 20 73 75 6d 20 69 73 20 74 68 65 20 and sum is the
6640: 73 61 6d 65 3a 20 74 68 65 0a 3b 3b 20 73 6f 62 same: the.;; sob
6650: 2d 2a 20 61 6e 64 20 73 6f 62 2d 2a 21 20 70 72 -* and sob-*! pr
6660: 6f 63 65 64 75 72 65 73 20 64 6f 20 74 68 65 20 ocedures do the
6670: 72 65 64 75 63 74 69 6f 6e 20 74 6f 20 74 68 65 reduction to the
6680: 20 64 79 61 64 69 63 2d 73 6f 62 2d 2a 21 0a 3b dyadic-sob-*!.;
6690: 3b 20 70 72 6f 63 65 64 75 72 65 73 2e 20 20 54 ; procedures. T
66a0: 68 65 20 64 69 66 66 65 72 65 6e 63 65 20 69 73 he difference is
66b0: 20 74 68 61 74 20 74 68 65 20 73 6f 62 2d 2a 20 that the sob-*
66c0: 70 72 6f 63 65 64 75 72 65 73 20 61 6c 6c 6f 63 procedures alloc
66d0: 61 74 65 0a 3b 3b 20 61 6e 20 65 6d 70 74 79 20 ate.;; an empty
66e0: 63 6f 70 79 20 6f 66 20 74 68 65 20 66 69 72 73 copy of the firs
66f0: 74 20 73 6f 62 20 74 6f 20 61 63 63 75 6d 75 6c t sob to accumul
6700: 61 74 65 20 74 68 65 20 72 65 73 75 6c 74 73 20 ate the results
6710: 69 6e 2c 20 77 68 65 72 65 61 73 0a 3b 3b 20 74 in, whereas.;; t
6720: 68 65 20 73 6f 62 2d 2a 21 20 20 70 72 6f 63 65 he sob-*! proce
6730: 64 75 72 65 73 20 77 6f 72 6b 20 64 69 72 65 63 dures work direc
6740: 74 6c 79 20 69 6e 20 74 68 65 20 66 69 72 73 74 tly in the first
6750: 20 73 6f 62 2e 0a 0a 3b 3b 20 4e 6f 74 65 20 74 sob...;; Note t
6760: 68 61 74 20 74 68 65 72 65 20 69 73 20 6e 6f 20 hat there is no
6770: 73 65 74 2d 73 75 6d 2c 20 61 73 20 69 74 20 69 set-sum, as it i
6780: 73 20 74 68 65 20 73 61 6d 65 20 61 73 20 73 65 s the same as se
6790: 74 2d 75 6e 69 6f 6e 2e 0a 0a 28 64 65 66 69 6e t-union...(defin
67a0: 65 20 28 73 6f 62 2d 75 6e 69 6f 6e 20 73 6f 62 e (sob-union sob
67b0: 31 20 2e 20 73 6f 62 73 29 0a 20 20 28 69 66 20 1 . sobs). (if
67c0: 28 6e 75 6c 6c 3f 20 73 6f 62 73 29 0a 20 20 20 (null? sobs).
67d0: 20 73 6f 62 31 0a 20 20 20 20 28 6c 65 74 20 28 sob1. (let (
67e0: 28 72 65 73 75 6c 74 20 28 73 6f 62 2d 65 6d 70 (result (sob-emp
67f0: 74 79 2d 63 6f 70 79 20 73 6f 62 31 29 29 29 0a ty-copy sob1))).
6800: 20 20 20 20 20 20 28 64 79 61 64 69 63 2d 73 6f (dyadic-so
6810: 62 2d 75 6e 69 6f 6e 21 20 72 65 73 75 6c 74 20 b-union! result
6820: 73 6f 62 31 20 28 63 61 72 20 73 6f 62 73 29 29 sob1 (car sobs))
6830: 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
6840: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
6850: 28 73 6f 62 29 20 28 64 79 61 64 69 63 2d 73 6f (sob) (dyadic-so
6860: 62 2d 75 6e 69 6f 6e 21 20 72 65 73 75 6c 74 20 b-union! result
6870: 72 65 73 75 6c 74 20 73 6f 62 29 29 0a 20 20 20 result sob)).
6880: 20 20 20 20 28 63 64 72 20 73 6f 62 73 29 29 0a (cdr sobs)).
6890: 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a result))).
68a0: 0a 3b 3b 20 46 6f 72 20 75 6e 69 6f 6e 2c 20 77 .;; For union, w
68b0: 65 20 74 61 6b 65 20 74 68 65 20 6d 61 78 20 6f e take the max o
68c0: 66 20 74 68 65 20 63 6f 75 6e 74 73 20 6f 66 20 f the counts of
68d0: 65 61 63 68 20 65 6c 65 6d 65 6e 74 20 66 6f 75 each element fou
68e0: 6e 64 0a 3b 3b 20 69 6e 20 65 69 74 68 65 72 20 nd.;; in either
68f0: 73 6f 62 20 61 6e 64 20 70 75 74 20 74 68 61 74 sob and put that
6900: 20 69 6e 20 74 68 65 20 72 65 73 75 6c 74 2e 20 in the result.
6910: 20 4f 6e 20 74 68 65 20 70 61 73 73 20 74 68 72 On the pass thr
6920: 6f 75 67 68 0a 3b 3b 20 73 6f 62 32 2c 20 77 65 ough.;; sob2, we
6930: 20 6b 6e 6f 77 20 74 68 61 74 20 74 68 65 20 69 know that the i
6940: 6e 74 65 72 73 65 63 74 69 6f 6e 20 69 73 20 61 ntersection is a
6950: 6c 72 65 61 64 79 20 61 63 63 6f 75 6e 74 65 64 lready accounted
6960: 20 66 6f 72 2c 0a 3b 3b 20 73 6f 20 77 65 20 6a for,.;; so we j
6970: 75 73 74 20 63 6f 70 79 20 6f 76 65 72 20 74 68 ust copy over th
6980: 69 6e 67 73 20 74 68 61 74 20 61 72 65 6e 27 74 ings that aren't
6990: 20 69 6e 20 73 6f 62 31 2e 0a 0a 28 64 65 66 69 in sob1...(defi
69a0: 6e 65 20 28 64 79 61 64 69 63 2d 73 6f 62 2d 75 ne (dyadic-sob-u
69b0: 6e 69 6f 6e 21 20 72 65 73 75 6c 74 20 73 6f 62 nion! result sob
69c0: 31 20 73 6f 62 32 29 0a 20 20 28 6c 65 74 20 28 1 sob2). (let (
69d0: 28 73 6f 62 31 2d 68 74 20 28 73 6f 62 2d 68 61 (sob1-ht (sob-ha
69e0: 73 68 2d 74 61 62 6c 65 20 73 6f 62 31 29 29 0a sh-table sob1)).
69f0: 20 20 20 20 20 20 20 20 28 73 6f 62 32 2d 68 74 (sob2-ht
6a00: 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 (sob-hash-table
6a10: 20 73 6f 62 32 29 29 0a 20 20 20 20 20 20 20 20 sob2)).
6a20: 28 72 65 73 75 6c 74 2d 68 74 20 28 73 6f 62 2d (result-ht (sob-
6a30: 68 61 73 68 2d 74 61 62 6c 65 20 72 65 73 75 6c hash-table resul
6a40: 74 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 t))). (hash-t
6a50: 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 able-for-each.
6a60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 (lambda (key
6a70: 20 76 61 6c 75 65 31 29 0a 20 20 20 20 20 20 20 value1).
6a80: 20 28 6c 65 74 20 28 28 76 61 6c 75 65 32 20 28 (let ((value2 (
6a90: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
6aa0: 65 66 61 75 6c 74 20 73 6f 62 32 2d 68 74 20 6b efault sob2-ht k
6ab0: 65 79 20 30 29 29 29 0a 20 20 20 20 20 20 20 20 ey 0))).
6ac0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
6ad0: 74 21 20 72 65 73 75 6c 74 2d 68 74 20 6b 65 79 t! result-ht key
6ae0: 20 28 6d 61 78 20 76 61 6c 75 65 31 20 76 61 6c (max value1 val
6af0: 75 65 32 29 29 29 29 0a 20 20 20 20 20 20 73 6f ue2)))). so
6b00: 62 31 2d 68 74 29 0a 20 20 20 20 28 68 61 73 68 b1-ht). (hash
6b10: 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a -table-for-each.
6b20: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b (lambda (k
6b30: 65 79 20 76 61 6c 75 65 32 29 0a 20 20 20 20 20 ey value2).
6b40: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 75 65 31 (let ((value1
6b50: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6b60: 2f 64 65 66 61 75 6c 74 20 73 6f 62 31 2d 68 74 /default sob1-ht
6b70: 20 6b 65 79 20 30 29 29 29 0a 20 20 20 20 20 20 key 0))).
6b80: 20 20 20 20 28 69 66 20 28 3d 20 76 61 6c 75 65 (if (= value
6b90: 31 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 1 0).
6ba0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
6bb0: 65 74 21 20 72 65 73 75 6c 74 2d 68 74 20 6b 65 et! result-ht ke
6bc0: 79 20 76 61 6c 75 65 32 29 29 29 29 0a 20 20 20 y value2)))).
6bd0: 20 20 20 73 6f 62 32 2d 68 74 29 29 29 0a 0a 28 sob2-ht)))..(
6be0: 64 65 66 69 6e 65 20 28 73 65 74 2d 75 6e 69 6f define (set-unio
6bf0: 6e 20 2e 20 73 65 74 73 29 0a 20 20 28 63 68 65 n . sets). (che
6c00: 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 65 74 73 ck-all-sets sets
6c10: 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 2d 75 ). (apply sob-u
6c20: 6e 69 6f 6e 20 73 65 74 73 29 29 0a 0a 28 64 65 nion sets))..(de
6c30: 66 69 6e 65 20 28 62 61 67 2d 75 6e 69 6f 6e 20 fine (bag-union
6c40: 2e 20 62 61 67 73 29 0a 20 20 28 63 68 65 63 6b . bags). (check
6c50: 2d 61 6c 6c 2d 62 61 67 73 20 62 61 67 73 29 0a -all-bags bags).
6c60: 20 20 28 61 70 70 6c 79 20 73 6f 62 2d 75 6e 69 (apply sob-uni
6c70: 6f 6e 20 62 61 67 73 29 29 0a 0a 28 64 65 66 69 on bags))..(defi
6c80: 6e 65 20 28 73 6f 62 2d 75 6e 69 6f 6e 21 20 73 ne (sob-union! s
6c90: 6f 62 31 20 2e 20 73 6f 62 73 29 0a 20 20 28 66 ob1 . sobs). (f
6ca0: 6f 72 2d 65 61 63 68 0a 20 20 20 28 6c 61 6d 62 or-each. (lamb
6cb0: 64 61 20 28 73 6f 62 29 20 28 64 79 61 64 69 63 da (sob) (dyadic
6cc0: 2d 73 6f 62 2d 75 6e 69 6f 6e 21 20 73 6f 62 31 -sob-union! sob1
6cd0: 20 73 6f 62 31 20 73 6f 62 29 29 0a 20 20 20 73 sob1 sob)). s
6ce0: 6f 62 73 29 0a 20 20 73 6f 62 31 29 0a 0a 28 64 obs). sob1)..(d
6cf0: 65 66 69 6e 65 20 28 73 65 74 2d 75 6e 69 6f 6e efine (set-union
6d00: 21 20 2e 20 73 65 74 73 29 0a 20 20 28 63 68 65 ! . sets). (che
6d10: 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 65 74 73 ck-all-sets sets
6d20: 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 2d 75 ). (apply sob-u
6d30: 6e 69 6f 6e 21 20 73 65 74 73 29 29 0a 0a 28 64 nion! sets))..(d
6d40: 65 66 69 6e 65 20 28 62 61 67 2d 75 6e 69 6f 6e efine (bag-union
6d50: 21 20 2e 20 62 61 67 73 29 0a 20 20 28 63 68 65 ! . bags). (che
6d60: 63 6b 2d 61 6c 6c 2d 62 61 67 73 20 62 61 67 73 ck-all-bags bags
6d70: 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 2d 75 ). (apply sob-u
6d80: 6e 69 6f 6e 21 20 62 61 67 73 29 29 0a 0a 28 64 nion! bags))..(d
6d90: 65 66 69 6e 65 20 28 73 6f 62 2d 69 6e 74 65 72 efine (sob-inter
6da0: 73 65 63 74 69 6f 6e 20 73 6f 62 31 20 2e 20 73 section sob1 . s
6db0: 6f 62 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c obs). (if (null
6dc0: 3f 20 73 6f 62 73 29 0a 20 20 20 20 73 6f 62 31 ? sobs). sob1
6dd0: 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 75 . (let ((resu
6de0: 6c 74 20 28 73 6f 62 2d 65 6d 70 74 79 2d 63 6f lt (sob-empty-co
6df0: 70 79 20 73 6f 62 31 29 29 29 0a 20 20 20 20 20 py sob1))).
6e00: 20 28 64 79 61 64 69 63 2d 73 6f 62 2d 69 6e 74 (dyadic-sob-int
6e10: 65 72 73 65 63 74 69 6f 6e 21 20 72 65 73 75 6c ersection! resul
6e20: 74 20 73 6f 62 31 20 28 63 61 72 20 73 6f 62 73 t sob1 (car sobs
6e30: 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 )). (for-ea
6e40: 63 68 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 ch. (lambd
6e50: 61 20 28 73 6f 62 29 20 28 64 79 61 64 69 63 2d a (sob) (dyadic-
6e60: 73 6f 62 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e sob-intersection
6e70: 21 20 72 65 73 75 6c 74 20 72 65 73 75 6c 74 20 ! result result
6e80: 73 6f 62 29 29 0a 20 20 20 20 20 20 20 28 63 64 sob)). (cd
6e90: 72 20 73 6f 62 73 29 29 0a 20 20 20 20 20 20 28 r sobs)). (
6ea0: 73 6f 62 2d 63 6c 65 61 6e 75 70 21 20 72 65 73 sob-cleanup! res
6eb0: 75 6c 74 29 29 29 29 0a 0a 3b 3b 20 46 6f 72 20 ult))))..;; For
6ec0: 69 6e 74 65 72 73 65 63 74 69 6f 6e 2c 20 77 65 intersection, we
6ed0: 20 63 6f 6d 70 75 74 65 20 74 68 65 20 6d 69 6e compute the min
6ee0: 20 6f 66 20 74 68 65 20 63 6f 75 6e 74 73 20 6f of the counts o
6ef0: 66 20 65 61 63 68 20 65 6c 65 6d 65 6e 74 2e 0a f each element..
6f00: 3b 3b 20 57 65 20 6f 6e 6c 79 20 68 61 76 65 20 ;; We only have
6f10: 74 6f 20 73 63 61 6e 20 73 6f 62 31 2e 20 20 57 to scan sob1. W
6f20: 65 20 63 6c 65 61 6e 20 75 70 20 74 68 65 20 72 e clean up the r
6f30: 65 73 75 6c 74 20 77 68 65 6e 20 77 65 20 61 72 esult when we ar
6f40: 65 0a 3b 3b 20 64 6f 6e 65 2c 20 69 6e 20 63 61 e.;; done, in ca
6f50: 73 65 20 69 74 20 69 73 20 74 68 65 20 73 61 6d se it is the sam
6f60: 65 20 61 73 20 73 6f 62 31 2e 0a 0a 28 64 65 66 e as sob1...(def
6f70: 69 6e 65 20 28 64 79 61 64 69 63 2d 73 6f 62 2d ine (dyadic-sob-
6f80: 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 72 65 intersection! re
6f90: 73 75 6c 74 20 73 6f 62 31 20 73 6f 62 32 29 0a sult sob1 sob2).
6fa0: 20 20 28 6c 65 74 20 28 28 73 6f 62 31 2d 68 74 (let ((sob1-ht
6fb0: 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 (sob-hash-table
6fc0: 20 73 6f 62 31 29 29 0a 20 20 20 20 20 20 20 20 sob1)).
6fd0: 28 73 6f 62 32 2d 68 74 20 28 73 6f 62 2d 68 61 (sob2-ht (sob-ha
6fe0: 73 68 2d 74 61 62 6c 65 20 73 6f 62 32 29 29 0a sh-table sob2)).
6ff0: 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 2d (result-
7000: 68 74 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 ht (sob-hash-tab
7010: 6c 65 20 72 65 73 75 6c 74 29 29 29 0a 20 20 20 le result))).
7020: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 (hash-table-for
7030: 2d 65 61 63 68 0a 20 20 20 20 20 20 28 6c 61 6d -each. (lam
7040: 62 64 61 20 28 6b 65 79 20 76 61 6c 75 65 31 29 bda (key value1)
7050: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 . (let ((
7060: 76 61 6c 75 65 32 20 28 68 61 73 68 2d 74 61 62 value2 (hash-tab
7070: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 le-ref/default s
7080: 6f 62 32 2d 68 74 20 6b 65 79 20 30 29 29 29 0a ob2-ht key 0))).
7090: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
70a0: 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 75 6c table-set! resul
70b0: 74 2d 68 74 20 6b 65 79 20 28 6d 69 6e 20 76 61 t-ht key (min va
70c0: 6c 75 65 31 20 76 61 6c 75 65 32 29 29 29 29 0a lue1 value2)))).
70d0: 20 20 20 20 20 20 73 6f 62 31 2d 68 74 29 29 29 sob1-ht)))
70e0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 69 ..(define (set-i
70f0: 6e 74 65 72 73 65 63 74 69 6f 6e 20 2e 20 73 65 ntersection . se
7100: 74 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c 6c ts). (check-all
7110: 2d 73 65 74 73 20 73 65 74 73 29 0a 20 20 28 61 -sets sets). (a
7120: 70 70 6c 79 20 73 6f 62 2d 69 6e 74 65 72 73 65 pply sob-interse
7130: 63 74 69 6f 6e 20 73 65 74 73 29 29 0a 0a 28 64 ction sets))..(d
7140: 65 66 69 6e 65 20 28 62 61 67 2d 69 6e 74 65 72 efine (bag-inter
7150: 73 65 63 74 69 6f 6e 20 2e 20 62 61 67 73 29 0a section . bags).
7160: 20 20 28 63 68 65 63 6b 2d 61 6c 6c 2d 62 61 67 (check-all-bag
7170: 73 20 62 61 67 73 29 0a 20 20 28 61 70 70 6c 79 s bags). (apply
7180: 20 73 6f 62 2d 69 6e 74 65 72 73 65 63 74 69 6f sob-intersectio
7190: 6e 20 62 61 67 73 29 29 0a 0a 28 64 65 66 69 6e n bags))..(defin
71a0: 65 20 28 73 6f 62 2d 69 6e 74 65 72 73 65 63 74 e (sob-intersect
71b0: 69 6f 6e 21 20 73 6f 62 31 20 2e 20 73 6f 62 73 ion! sob1 . sobs
71c0: 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 ). (for-each.
71d0: 20 28 6c 61 6d 62 64 61 20 28 73 6f 62 29 20 28 (lambda (sob) (
71e0: 64 79 61 64 69 63 2d 73 6f 62 2d 69 6e 74 65 72 dyadic-sob-inter
71f0: 73 65 63 74 69 6f 6e 21 20 73 6f 62 31 20 73 6f section! sob1 so
7200: 62 31 20 73 6f 62 29 29 0a 20 20 20 73 6f 62 73 b1 sob)). sobs
7210: 29 0a 20 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 ). (sob-cleanup
7220: 21 20 73 6f 62 31 29 29 0a 0a 28 64 65 66 69 6e ! sob1))..(defin
7230: 65 20 28 73 65 74 2d 69 6e 74 65 72 73 65 63 74 e (set-intersect
7240: 69 6f 6e 21 20 2e 20 73 65 74 73 29 0a 20 20 28 ion! . sets). (
7250: 63 68 65 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 check-all-sets s
7260: 65 74 73 29 0a 20 20 28 61 70 70 6c 79 20 73 6f ets). (apply so
7270: 62 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 b-intersection!
7280: 73 65 74 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 sets))..(define
7290: 28 62 61 67 2d 69 6e 74 65 72 73 65 63 74 69 6f (bag-intersectio
72a0: 6e 21 20 2e 20 62 61 67 73 29 0a 20 20 28 63 68 n! . bags). (ch
72b0: 65 63 6b 2d 61 6c 6c 2d 62 61 67 73 20 62 61 67 eck-all-bags bag
72c0: 73 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 2d s). (apply sob-
72d0: 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 62 61 intersection! ba
72e0: 67 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 gs))..(define (s
72f0: 6f 62 2d 64 69 66 66 65 72 65 6e 63 65 20 73 6f ob-difference so
7300: 62 31 20 2e 20 73 6f 62 73 29 0a 20 20 28 69 66 b1 . sobs). (if
7310: 20 28 6e 75 6c 6c 3f 20 73 6f 62 73 29 0a 20 20 (null? sobs).
7320: 20 20 73 6f 62 31 0a 20 20 20 20 28 6c 65 74 20 sob1. (let
7330: 28 28 72 65 73 75 6c 74 20 28 73 6f 62 2d 65 6d ((result (sob-em
7340: 70 74 79 2d 63 6f 70 79 20 73 6f 62 31 29 29 29 pty-copy sob1)))
7350: 0a 20 20 20 20 20 20 28 64 79 61 64 69 63 2d 73 . (dyadic-s
7360: 6f 62 2d 64 69 66 66 65 72 65 6e 63 65 21 20 72 ob-difference! r
7370: 65 73 75 6c 74 20 73 6f 62 31 20 28 63 61 72 20 esult sob1 (car
7380: 73 6f 62 73 29 29 0a 20 20 20 20 20 20 28 66 6f sobs)). (fo
7390: 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 6c r-each. (l
73a0: 61 6d 62 64 61 20 28 73 6f 62 29 20 28 64 79 61 ambda (sob) (dya
73b0: 64 69 63 2d 73 6f 62 2d 64 69 66 66 65 72 65 6e dic-sob-differen
73c0: 63 65 21 20 72 65 73 75 6c 74 20 72 65 73 75 6c ce! result resul
73d0: 74 20 73 6f 62 29 29 0a 20 20 20 20 20 20 20 28 t sob)). (
73e0: 63 64 72 20 73 6f 62 73 29 29 0a 20 20 20 20 20 cdr sobs)).
73f0: 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 21 20 72 (sob-cleanup! r
7400: 65 73 75 6c 74 29 29 29 29 0a 0a 3b 3b 20 46 6f esult))))..;; Fo
7410: 72 20 64 69 66 66 65 72 65 6e 63 65 2c 20 77 65 r difference, we
7420: 20 75 73 65 20 28 62 69 67 20 73 75 72 70 72 69 use (big surpri
7430: 73 65 29 20 74 68 65 20 6e 75 6d 65 72 69 63 20 se) the numeric
7440: 64 69 66 66 65 72 65 6e 63 65 2c 20 62 6f 75 6e difference, boun
7450: 64 65 64 0a 3b 3b 20 62 79 20 7a 65 72 6f 2e 20 ded.;; by zero.
7460: 20 57 65 20 6f 6e 6c 79 20 6e 65 65 64 20 74 6f We only need to
7470: 20 73 63 61 6e 20 73 6f 62 31 2c 20 62 75 74 20 scan sob1, but
7480: 77 65 20 63 6c 65 61 6e 20 75 70 20 74 68 65 20 we clean up the
7490: 72 65 73 75 6c 74 20 69 6e 0a 3b 3b 20 63 61 73 result in.;; cas
74a0: 65 20 69 74 20 69 73 20 74 68 65 20 73 61 6d 65 e it is the same
74b0: 20 61 73 20 73 6f 62 31 2e 0a 0a 28 64 65 66 69 as sob1...(defi
74c0: 6e 65 20 28 64 79 61 64 69 63 2d 73 6f 62 2d 64 ne (dyadic-sob-d
74d0: 69 66 66 65 72 65 6e 63 65 21 20 72 65 73 75 6c ifference! resul
74e0: 74 20 73 6f 62 31 20 73 6f 62 32 29 0a 20 20 28 t sob1 sob2). (
74f0: 6c 65 74 20 28 28 73 6f 62 31 2d 68 74 20 28 73 let ((sob1-ht (s
7500: 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 6f ob-hash-table so
7510: 62 31 29 29 0a 20 20 20 20 20 20 20 20 28 73 6f b1)). (so
7520: 62 32 2d 68 74 20 28 73 6f 62 2d 68 61 73 68 2d b2-ht (sob-hash-
7530: 74 61 62 6c 65 20 73 6f 62 32 29 29 0a 20 20 20 table sob2)).
7540: 20 20 20 20 20 28 72 65 73 75 6c 74 2d 68 74 20 (result-ht
7550: 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 (sob-hash-table
7560: 72 65 73 75 6c 74 29 29 29 0a 20 20 20 20 28 68 result))). (h
7570: 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 ash-table-for-ea
7580: 63 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ch. (lambda
7590: 20 28 6b 65 79 20 76 61 6c 75 65 31 29 0a 20 20 (key value1).
75a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c (let ((val
75b0: 75 65 32 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ue2 (hash-table-
75c0: 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6f 62 32 ref/default sob2
75d0: 2d 68 74 20 6b 65 79 20 30 29 29 29 0a 20 20 20 -ht key 0))).
75e0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
75f0: 6c 65 2d 73 65 74 21 20 72 65 73 75 6c 74 2d 68 le-set! result-h
7600: 74 20 6b 65 79 20 28 2d 20 76 61 6c 75 65 31 20 t key (- value1
7610: 76 61 6c 75 65 32 29 29 29 29 0a 20 20 20 20 20 value2)))).
7620: 20 73 6f 62 31 2d 68 74 29 29 29 0a 0a 28 64 65 sob1-ht)))..(de
7630: 66 69 6e 65 20 28 73 65 74 2d 64 69 66 66 65 72 fine (set-differ
7640: 65 6e 63 65 20 2e 20 73 65 74 73 29 0a 20 20 28 ence . sets). (
7650: 63 68 65 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 check-all-sets s
7660: 65 74 73 29 0a 20 20 28 61 70 70 6c 79 20 73 6f ets). (apply so
7670: 62 2d 64 69 66 66 65 72 65 6e 63 65 20 73 65 74 b-difference set
7680: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 s))..(define (ba
7690: 67 2d 64 69 66 66 65 72 65 6e 63 65 20 2e 20 62 g-difference . b
76a0: 61 67 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c ags). (check-al
76b0: 6c 2d 62 61 67 73 20 62 61 67 73 29 0a 20 20 28 l-bags bags). (
76c0: 61 70 70 6c 79 20 73 6f 62 2d 64 69 66 66 65 72 apply sob-differ
76d0: 65 6e 63 65 20 62 61 67 73 29 29 0a 0a 28 64 65 ence bags))..(de
76e0: 66 69 6e 65 20 28 73 6f 62 2d 64 69 66 66 65 72 fine (sob-differ
76f0: 65 6e 63 65 21 20 73 6f 62 31 20 2e 20 73 6f 62 ence! sob1 . sob
7700: 73 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 s). (for-each.
7710: 20 20 28 6c 61 6d 62 64 61 20 28 73 6f 62 29 20 (lambda (sob)
7720: 28 64 79 61 64 69 63 2d 73 6f 62 2d 64 69 66 66 (dyadic-sob-diff
7730: 65 72 65 6e 63 65 21 20 73 6f 62 31 20 73 6f 62 erence! sob1 sob
7740: 31 20 73 6f 62 29 29 0a 20 20 20 73 6f 62 73 29 1 sob)). sobs)
7750: 0a 20 20 28 73 6f 62 2d 63 6c 65 61 6e 75 70 21 . (sob-cleanup!
7760: 20 73 6f 62 31 29 29 0a 0a 28 64 65 66 69 6e 65 sob1))..(define
7770: 20 28 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 (set-difference
7780: 21 20 2e 20 73 65 74 73 29 0a 20 20 28 63 68 65 ! . sets). (che
7790: 63 6b 2d 61 6c 6c 2d 73 65 74 73 20 73 65 74 73 ck-all-sets sets
77a0: 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 2d 64 ). (apply sob-d
77b0: 69 66 66 65 72 65 6e 63 65 21 20 73 65 74 73 29 ifference! sets)
77c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d )..(define (bag-
77d0: 64 69 66 66 65 72 65 6e 63 65 21 20 2e 20 62 61 difference! . ba
77e0: 67 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c 6c gs). (check-all
77f0: 2d 62 61 67 73 20 62 61 67 73 29 0a 20 20 28 61 -bags bags). (a
7800: 70 70 6c 79 20 73 6f 62 2d 64 69 66 66 65 72 65 pply sob-differe
7810: 6e 63 65 21 20 62 61 67 73 29 29 0a 0a 28 64 65 nce! bags))..(de
7820: 66 69 6e 65 20 28 73 6f 62 2d 73 75 6d 20 73 6f fine (sob-sum so
7830: 62 31 20 2e 20 73 6f 62 73 29 0a 20 20 28 69 66 b1 . sobs). (if
7840: 20 28 6e 75 6c 6c 3f 20 73 6f 62 73 29 0a 20 20 (null? sobs).
7850: 20 20 73 6f 62 31 0a 20 20 20 20 28 6c 65 74 20 sob1. (let
7860: 28 28 72 65 73 75 6c 74 20 28 73 6f 62 2d 65 6d ((result (sob-em
7870: 70 74 79 2d 63 6f 70 79 20 73 6f 62 31 29 29 29 pty-copy sob1)))
7880: 0a 20 20 20 20 20 20 28 64 79 61 64 69 63 2d 73 . (dyadic-s
7890: 6f 62 2d 73 75 6d 21 20 72 65 73 75 6c 74 20 73 ob-sum! result s
78a0: 6f 62 31 20 28 63 61 72 20 73 6f 62 73 29 29 0a ob1 (car sobs)).
78b0: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a (for-each.
78c0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
78d0: 73 6f 62 29 20 28 64 79 61 64 69 63 2d 73 6f 62 sob) (dyadic-sob
78e0: 2d 73 75 6d 21 20 72 65 73 75 6c 74 20 72 65 73 -sum! result res
78f0: 75 6c 74 20 73 6f 62 29 29 0a 20 20 20 20 20 20 ult sob)).
7900: 20 28 63 64 72 20 73 6f 62 73 29 29 0a 20 20 20 (cdr sobs)).
7910: 20 20 20 72 65 73 75 6c 74 29 29 29 0a 0a 3b 3b result)))..;;
7920: 20 53 75 6d 20 69 73 20 6a 75 73 74 20 6c 69 6b Sum is just lik
7930: 65 20 75 6e 69 6f 6e 2c 20 65 78 63 65 70 74 20 e union, except
7940: 74 68 61 74 20 77 65 20 74 61 6b 65 20 74 68 65 that we take the
7950: 20 73 75 6d 20 72 61 74 68 65 72 20 74 68 61 6e sum rather than
7960: 20 74 68 65 20 6d 61 78 2e 0a 0a 28 64 65 66 69 the max...(defi
7970: 6e 65 20 28 64 79 61 64 69 63 2d 73 6f 62 2d 73 ne (dyadic-sob-s
7980: 75 6d 21 20 72 65 73 75 6c 74 20 73 6f 62 31 20 um! result sob1
7990: 73 6f 62 32 29 0a 20 20 28 6c 65 74 20 28 28 73 sob2). (let ((s
79a0: 6f 62 31 2d 68 74 20 28 73 6f 62 2d 68 61 73 68 ob1-ht (sob-hash
79b0: 2d 74 61 62 6c 65 20 73 6f 62 31 29 29 0a 20 20 -table sob1)).
79c0: 20 20 20 20 20 20 28 73 6f 62 32 2d 68 74 20 28 (sob2-ht (
79d0: 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 sob-hash-table s
79e0: 6f 62 32 29 29 0a 20 20 20 20 20 20 20 20 28 72 ob2)). (r
79f0: 65 73 75 6c 74 2d 68 74 20 28 73 6f 62 2d 68 61 esult-ht (sob-ha
7a00: 73 68 2d 74 61 62 6c 65 20 72 65 73 75 6c 74 29 sh-table result)
7a10: 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 )). (hash-tab
7a20: 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 le-for-each.
7a30: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 (lambda (key v
7a40: 61 6c 75 65 31 29 0a 20 20 20 20 20 20 20 20 28 alue1). (
7a50: 6c 65 74 20 28 28 76 61 6c 75 65 32 20 28 68 61 let ((value2 (ha
7a60: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7a70: 61 75 6c 74 20 73 6f 62 32 2d 68 74 20 6b 65 79 ault sob2-ht key
7a80: 20 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 0))).
7a90: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
7aa0: 20 72 65 73 75 6c 74 2d 68 74 20 6b 65 79 20 28 result-ht key (
7ab0: 2b 20 76 61 6c 75 65 31 20 76 61 6c 75 65 32 29 + value1 value2)
7ac0: 29 29 29 0a 20 20 20 20 20 20 73 6f 62 31 2d 68 ))). sob1-h
7ad0: 74 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 t). (hash-tab
7ae0: 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 le-for-each.
7af0: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 (lambda (key v
7b00: 61 6c 75 65 32 29 0a 20 20 20 20 20 20 20 20 28 alue2). (
7b10: 6c 65 74 20 28 28 76 61 6c 75 65 31 20 28 68 61 let ((value1 (ha
7b20: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7b30: 61 75 6c 74 20 73 6f 62 31 2d 68 74 20 6b 65 79 ault sob1-ht key
7b40: 20 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 0))).
7b50: 28 69 66 20 28 3d 20 76 61 6c 75 65 31 20 30 29 (if (= value1 0)
7b60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
7b70: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
7b80: 72 65 73 75 6c 74 2d 68 74 20 6b 65 79 20 76 61 result-ht key va
7b90: 6c 75 65 32 29 29 29 29 0a 20 20 20 20 20 20 73 lue2)))). s
7ba0: 6f 62 32 2d 68 74 29 29 29 0a 0a 0a 3b 3b 20 53 ob2-ht)))...;; S
7bb0: 75 6d 20 69 73 20 64 65 66 69 6e 65 64 20 66 6f um is defined fo
7bc0: 72 20 62 61 67 73 20 6f 6e 6c 79 3b 20 66 6f 72 r bags only; for
7bd0: 20 73 65 74 73 2c 20 69 74 20 69 73 20 74 68 65 sets, it is the
7be0: 20 73 61 6d 65 20 61 73 20 75 6e 69 6f 6e 2e 0a same as union..
7bf0: 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 73 75 .(define (bag-su
7c00: 6d 20 2e 20 62 61 67 73 29 0a 20 20 28 63 68 65 m . bags). (che
7c10: 63 6b 2d 61 6c 6c 2d 62 61 67 73 20 62 61 67 73 ck-all-bags bags
7c20: 29 0a 20 20 28 61 70 70 6c 79 20 73 6f 62 2d 73 ). (apply sob-s
7c30: 75 6d 20 62 61 67 73 29 29 0a 0a 28 64 65 66 69 um bags))..(defi
7c40: 6e 65 20 28 73 6f 62 2d 73 75 6d 21 20 73 6f 62 ne (sob-sum! sob
7c50: 31 20 2e 20 73 6f 62 73 29 0a 20 20 28 66 6f 72 1 . sobs). (for
7c60: 2d 65 61 63 68 0a 20 20 20 28 6c 61 6d 62 64 61 -each. (lambda
7c70: 20 28 73 6f 62 29 20 28 64 79 61 64 69 63 2d 73 (sob) (dyadic-s
7c80: 6f 62 2d 73 75 6d 21 20 73 6f 62 31 20 73 6f 62 ob-sum! sob1 sob
7c90: 31 20 73 6f 62 29 29 0a 20 20 20 73 6f 62 73 29 1 sob)). sobs)
7ca0: 0a 20 20 73 6f 62 31 29 0a 0a 28 64 65 66 69 6e . sob1)..(defin
7cb0: 65 20 28 62 61 67 2d 73 75 6d 21 20 2e 20 62 61 e (bag-sum! . ba
7cc0: 67 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 6c 6c gs). (check-all
7cd0: 2d 62 61 67 73 20 62 61 67 73 29 0a 20 20 28 61 -bags bags). (a
7ce0: 70 70 6c 79 20 73 6f 62 2d 73 75 6d 21 20 62 61 pply sob-sum! ba
7cf0: 67 73 29 29 0a 0a 3b 3b 20 46 6f 72 20 78 6f 72 gs))..;; For xor
7d00: 20 65 78 61 63 74 6c 79 20 74 77 6f 20 61 72 67 exactly two arg
7d10: 75 6d 65 6e 74 73 20 61 72 65 20 72 65 71 75 69 uments are requi
7d20: 72 65 64 2c 20 73 6f 20 74 68 65 20 61 62 6f 76 red, so the abov
7d30: 65 20 73 74 72 75 63 74 75 72 65 73 20 61 72 65 e structures are
7d40: 0a 3b 3b 20 6e 6f 74 20 6e 65 63 65 73 73 61 72 .;; not necessar
7d50: 79 2e 20 20 54 68 69 73 20 76 65 72 73 69 6f 6e y. This version
7d60: 20 61 63 63 65 70 74 73 20 61 20 72 65 73 75 6c accepts a resul
7d70: 74 20 73 6f 62 20 61 6e 64 20 63 6f 6d 70 75 74 t sob and comput
7d80: 65 73 20 74 68 65 0a 3b 3b 20 61 62 73 6f 6c 75 es the.;; absolu
7d90: 74 65 20 64 69 66 66 65 72 65 6e 63 65 20 62 65 te difference be
7da0: 74 77 65 65 6e 20 74 68 65 20 63 6f 75 6e 74 73 tween the counts
7db0: 20 69 6e 20 74 68 65 20 66 69 72 73 74 20 73 6f in the first so
7dc0: 62 20 61 6e 64 20 74 68 65 0a 3b 3b 20 63 6f 72 b and the.;; cor
7dd0: 72 65 73 70 6f 6e 64 69 6e 67 20 63 6f 75 6e 74 responding count
7de0: 73 20 69 6e 20 74 68 65 20 73 65 63 6f 6e 64 2e s in the second.
7df0: 0a 0a 3b 3b 20 57 65 20 73 74 61 72 74 20 62 79 ..;; We start by
7e00: 20 63 6f 70 79 69 6e 67 20 74 68 65 20 65 6e 74 copying the ent
7e10: 72 69 65 73 20 69 6e 20 74 68 65 20 73 65 63 6f ries in the seco
7e20: 6e 64 20 73 6f 62 20 62 75 74 20 6e 6f 74 20 74 nd sob but not t
7e30: 68 65 20 66 69 72 73 74 0a 3b 3b 20 69 6e 74 6f he first.;; into
7e40: 20 74 68 65 20 66 69 72 73 74 2e 20 20 54 68 65 the first. The
7e50: 6e 20 77 65 20 73 63 61 6e 20 74 68 65 20 66 69 n we scan the fi
7e60: 72 73 74 20 73 6f 62 2c 20 63 6f 6d 70 75 74 69 rst sob, computi
7e70: 6e 67 20 74 68 65 20 61 62 73 6f 6c 75 74 65 0a ng the absolute.
7e80: 3b 3b 20 64 69 66 66 65 72 65 6e 63 65 20 6f 66 ;; difference of
7e90: 20 74 68 65 20 76 61 6c 75 65 73 20 61 6e 64 20 the values and
7ea0: 77 72 69 74 69 6e 67 20 74 68 65 6d 20 62 61 63 writing them bac
7eb0: 6b 20 69 6e 74 6f 20 74 68 65 20 66 69 72 73 74 k into the first
7ec0: 20 73 6f 62 2e 0a 3b 3b 20 49 74 27 73 20 65 73 sob..;; It's es
7ed0: 73 65 6e 74 69 61 6c 20 74 6f 20 73 63 61 6e 20 sential to scan
7ee0: 74 68 65 20 73 65 63 6f 6e 64 20 73 6f 62 20 66 the second sob f
7ef0: 69 72 73 74 2c 20 61 73 20 77 65 20 61 72 65 20 irst, as we are
7f00: 6e 6f 74 20 67 6f 69 6e 67 20 74 6f 0a 3b 3b 20 not going to.;;
7f10: 64 61 6d 61 67 65 20 69 74 20 69 6e 20 74 68 65 damage it in the
7f20: 20 70 72 6f 63 65 73 73 2e 20 20 28 48 61 74 20 process. (Hat
7f30: 74 69 70 3a 20 53 61 6d 20 54 6f 62 69 6e 2d 48 tip: Sam Tobin-H
7f40: 6f 63 68 73 74 61 64 74 2e 29 0a 0a 28 64 65 66 ochstadt.)..(def
7f50: 69 6e 65 20 28 73 6f 62 2d 78 6f 72 21 20 72 65 ine (sob-xor! re
7f60: 73 75 6c 74 20 73 6f 62 31 20 73 6f 62 32 29 0a sult sob1 sob2).
7f70: 20 20 28 6c 65 74 20 28 28 73 6f 62 31 2d 68 74 (let ((sob1-ht
7f80: 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 (sob-hash-table
7f90: 20 73 6f 62 31 29 29 0a 20 20 20 20 20 20 20 20 sob1)).
7fa0: 28 73 6f 62 32 2d 68 74 20 28 73 6f 62 2d 68 61 (sob2-ht (sob-ha
7fb0: 73 68 2d 74 61 62 6c 65 20 73 6f 62 32 29 29 0a sh-table sob2)).
7fc0: 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 2d (result-
7fd0: 68 74 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 ht (sob-hash-tab
7fe0: 6c 65 20 72 65 73 75 6c 74 29 29 29 0a 20 20 20 le result))).
7ff0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 (hash-table-for
8000: 2d 65 61 63 68 0a 20 20 20 20 20 20 28 6c 61 6d -each. (lam
8010: 62 64 61 20 28 6b 65 79 20 76 61 6c 75 65 32 29 bda (key value2)
8020: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 . (let ((
8030: 76 61 6c 75 65 31 20 28 68 61 73 68 2d 74 61 62 value1 (hash-tab
8040: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 le-ref/default s
8050: 6f 62 31 2d 68 74 20 6b 65 79 20 30 29 29 29 0a ob1-ht key 0))).
8060: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3d (if (=
8070: 20 76 61 6c 75 65 31 20 30 29 0a 20 20 20 20 20 value1 0).
8080: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
8090: 61 62 6c 65 2d 73 65 74 21 20 72 65 73 75 6c 74 able-set! result
80a0: 2d 68 74 20 6b 65 79 20 76 61 6c 75 65 32 29 29 -ht key value2))
80b0: 29 29 0a 20 20 20 20 20 20 73 6f 62 32 2d 68 74 )). sob2-ht
80c0: 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ). (hash-tabl
80d0: 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 e-for-each.
80e0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 (lambda (key va
80f0: 6c 75 65 31 29 0a 20 20 20 20 20 20 20 20 28 6c lue1). (l
8100: 65 74 20 28 28 76 61 6c 75 65 32 20 28 68 61 73 et ((value2 (has
8110: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
8120: 75 6c 74 20 73 6f 62 32 2d 68 74 20 6b 65 79 20 ult sob2-ht key
8130: 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 0))). (
8140: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8150: 72 65 73 75 6c 74 2d 68 74 20 6b 65 79 20 28 61 result-ht key (a
8160: 62 73 20 28 2d 20 76 61 6c 75 65 31 20 76 61 6c bs (- value1 val
8170: 75 65 32 29 29 29 29 29 0a 20 20 20 20 20 20 73 ue2))))). s
8180: 6f 62 31 2d 68 74 29 0a 20 20 20 20 28 73 6f 62 ob1-ht). (sob
8190: 2d 63 6c 65 61 6e 75 70 21 20 72 65 73 75 6c 74 -cleanup! result
81a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
81b0: 74 2d 78 6f 72 20 73 65 74 31 20 73 65 74 32 29 t-xor set1 set2)
81c0: 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 65 . (check-set se
81d0: 74 31 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 t1). (check-set
81e0: 20 73 65 74 32 29 0a 20 20 28 63 68 65 63 6b 2d set2). (check-
81f0: 73 61 6d 65 2d 63 6f 6d 70 61 72 61 74 6f 72 20 same-comparator
8200: 73 65 74 31 20 73 65 74 32 29 0a 20 20 28 73 6f set1 set2). (so
8210: 62 2d 78 6f 72 21 20 28 73 6f 62 2d 65 6d 70 74 b-xor! (sob-empt
8220: 79 2d 63 6f 70 79 20 73 65 74 31 29 20 73 65 74 y-copy set1) set
8230: 31 20 73 65 74 32 29 29 0a 0a 28 64 65 66 69 6e 1 set2))..(defin
8240: 65 20 28 62 61 67 2d 78 6f 72 20 62 61 67 31 20 e (bag-xor bag1
8250: 62 61 67 32 29 0a 20 20 28 63 68 65 63 6b 2d 62 bag2). (check-b
8260: 61 67 20 62 61 67 31 29 0a 20 20 28 63 68 65 63 ag bag1). (chec
8270: 6b 2d 62 61 67 20 62 61 67 32 29 0a 20 20 28 63 k-bag bag2). (c
8280: 68 65 63 6b 2d 73 61 6d 65 2d 63 6f 6d 70 61 72 heck-same-compar
8290: 61 74 6f 72 20 62 61 67 31 20 62 61 67 32 29 0a ator bag1 bag2).
82a0: 20 20 28 73 6f 62 2d 78 6f 72 21 20 28 73 6f 62 (sob-xor! (sob
82b0: 2d 65 6d 70 74 79 2d 63 6f 70 79 20 62 61 67 31 -empty-copy bag1
82c0: 29 20 62 61 67 31 20 62 61 67 32 29 29 0a 0a 28 ) bag1 bag2))..(
82d0: 64 65 66 69 6e 65 20 28 73 65 74 2d 78 6f 72 21 define (set-xor!
82e0: 20 73 65 74 31 20 73 65 74 32 29 0a 20 20 28 63 set1 set2). (c
82f0: 68 65 63 6b 2d 73 65 74 20 73 65 74 31 29 0a 20 heck-set set1).
8300: 20 28 63 68 65 63 6b 2d 73 65 74 20 73 65 74 32 (check-set set2
8310: 29 0a 20 20 28 63 68 65 63 6b 2d 73 61 6d 65 2d ). (check-same-
8320: 63 6f 6d 70 61 72 61 74 6f 72 20 73 65 74 31 20 comparator set1
8330: 73 65 74 32 29 0a 20 20 28 73 6f 62 2d 78 6f 72 set2). (sob-xor
8340: 21 20 73 65 74 31 20 73 65 74 31 20 73 65 74 32 ! set1 set1 set2
8350: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 ))..(define (bag
8360: 2d 78 6f 72 21 20 62 61 67 31 20 62 61 67 32 29 -xor! bag1 bag2)
8370: 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 20 62 61 . (check-bag ba
8380: 67 31 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 g1). (check-bag
8390: 20 62 61 67 32 29 0a 20 20 28 63 68 65 63 6b 2d bag2). (check-
83a0: 73 61 6d 65 2d 63 6f 6d 70 61 72 61 74 6f 72 20 same-comparator
83b0: 62 61 67 31 20 62 61 67 32 29 0a 20 20 28 73 6f bag1 bag2). (so
83c0: 62 2d 78 6f 72 21 20 62 61 67 31 20 62 61 67 31 b-xor! bag1 bag1
83d0: 20 62 61 67 32 29 29 0a 0a 0a 3b 3b 3b 20 41 20 bag2))...;;; A
83e0: 66 65 77 20 62 61 67 2d 73 70 65 63 69 66 69 63 few bag-specific
83f0: 20 70 72 6f 63 65 64 75 72 65 73 0a 0a 28 64 65 procedures..(de
8400: 66 69 6e 65 20 28 73 6f 62 2d 70 72 6f 64 75 63 fine (sob-produc
8410: 74 21 20 6e 20 72 65 73 75 6c 74 20 73 6f 62 29 t! n result sob)
8420: 0a 20 20 28 6c 65 74 20 28 28 72 68 74 20 28 73 . (let ((rht (s
8430: 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 72 65 ob-hash-table re
8440: 73 75 6c 74 29 29 29 0a 20 20 20 20 28 68 61 73 sult))). (has
8450: 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 h-table-for-each
8460: 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
8470: 65 6c 65 6d 20 63 6f 75 6e 74 29 20 28 68 61 73 elem count) (has
8480: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 68 74 h-table-set! rht
8490: 20 65 6c 65 6d 20 28 2a 20 63 6f 75 6e 74 20 6e elem (* count n
84a0: 29 29 29 0a 20 20 20 20 20 20 28 73 6f 62 2d 68 ))). (sob-h
84b0: 61 73 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 0a ash-table sob)).
84c0: 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 28 64 result))..(d
84d0: 65 66 69 6e 65 20 28 76 61 6c 69 64 2d 6e 20 6e efine (valid-n n
84e0: 29 0a 20 20 20 28 61 6e 64 20 28 69 6e 74 65 67 ). (and (integ
84f0: 65 72 3f 20 6e 29 20 28 65 78 61 63 74 3f 20 6e er? n) (exact? n
8500: 29 20 28 70 6f 73 69 74 69 76 65 3f 20 6e 29 29 ) (positive? n))
8510: 29 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d )..(define (bag-
8520: 70 72 6f 64 75 63 74 20 6e 20 62 61 67 29 0a 20 product n bag).
8530: 20 28 63 68 65 63 6b 2d 62 61 67 20 62 61 67 29 (check-bag bag)
8540: 0a 20 20 28 76 61 6c 69 64 2d 6e 20 6e 29 0a 20 . (valid-n n).
8550: 20 28 73 6f 62 2d 70 72 6f 64 75 63 74 21 20 6e (sob-product! n
8560: 20 28 73 6f 62 2d 65 6d 70 74 79 2d 63 6f 70 79 (sob-empty-copy
8570: 20 62 61 67 29 20 62 61 67 29 29 0a 0a 28 64 65 bag) bag))..(de
8580: 66 69 6e 65 20 28 62 61 67 2d 70 72 6f 64 75 63 fine (bag-produc
8590: 74 21 20 6e 20 62 61 67 29 0a 20 20 28 63 68 65 t! n bag). (che
85a0: 63 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 28 76 ck-bag bag). (v
85b0: 61 6c 69 64 2d 6e 20 6e 29 0a 20 20 28 73 6f 62 alid-n n). (sob
85c0: 2d 70 72 6f 64 75 63 74 21 20 6e 20 62 61 67 20 -product! n bag
85d0: 62 61 67 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 bag))..(define (
85e0: 62 61 67 2d 75 6e 69 71 75 65 2d 73 69 7a 65 20 bag-unique-size
85f0: 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 bag). (check-ba
8600: 67 20 62 61 67 29 0a 20 20 28 68 61 73 68 2d 74 g bag). (hash-t
8610: 61 62 6c 65 2d 73 69 7a 65 20 28 73 6f 62 2d 68 able-size (sob-h
8620: 61 73 68 2d 74 61 62 6c 65 20 62 61 67 29 29 29 ash-table bag)))
8630: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 65 ..(define (bag-e
8640: 6c 65 6d 65 6e 74 2d 63 6f 75 6e 74 20 62 61 67 lement-count bag
8650: 20 65 6c 65 6d 29 0a 20 20 28 63 68 65 63 6b 2d elem). (check-
8660: 62 61 67 20 62 61 67 29 0a 20 20 28 68 61 73 68 bag bag). (hash
8670: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
8680: 6c 74 20 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 lt (sob-hash-tab
8690: 6c 65 20 62 61 67 29 20 65 6c 65 6d 20 30 29 29 le bag) elem 0))
86a0: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 67 2d 66 ..(define (bag-f
86b0: 6f 72 2d 65 61 63 68 2d 75 6e 69 71 75 65 20 70 or-each-unique p
86c0: 72 6f 63 20 62 61 67 29 0a 20 20 28 63 68 65 63 roc bag). (chec
86d0: 6b 2d 62 61 67 20 62 61 67 29 0a 20 20 28 68 61 k-bag bag). (ha
86e0: 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 sh-table-for-eac
86f0: 68 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b h. (lambda (k
8700: 65 79 20 76 61 6c 75 65 29 20 28 70 72 6f 63 20 ey value) (proc
8710: 6b 65 79 20 76 61 6c 75 65 29 29 0a 20 20 20 20 key value)).
8720: 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 (sob-hash-table
8730: 62 61 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 bag)))..(define
8740: 28 62 61 67 2d 66 6f 6c 64 2d 75 6e 69 71 75 65 (bag-fold-unique
8750: 20 70 72 6f 63 20 6e 69 6c 20 62 61 67 29 0a 20 proc nil bag).
8760: 20 28 63 68 65 63 6b 2d 62 61 67 20 62 61 67 29 (check-bag bag)
8770: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 . (let ((result
8780: 20 6e 69 6c 29 29 0a 20 20 20 20 28 68 61 73 68 nil)). (hash
8790: 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a -table-for-each.
87a0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 65 (lambda (e
87b0: 6c 65 6d 20 63 6f 75 6e 74 29 20 28 73 65 74 21 lem count) (set!
87c0: 20 72 65 73 75 6c 74 20 28 70 72 6f 63 20 65 6c result (proc el
87d0: 65 6d 20 63 6f 75 6e 74 20 72 65 73 75 6c 74 29 em count result)
87e0: 29 29 0a 20 20 20 20 20 20 28 73 6f 62 2d 68 61 )). (sob-ha
87f0: 73 68 2d 74 61 62 6c 65 20 62 61 67 29 29 0a 20 sh-table bag)).
8800: 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 28 64 65 result))..(de
8810: 66 69 6e 65 20 28 62 61 67 2d 3e 73 65 74 20 62 fine (bag->set b
8820: 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 67 ag). (check-bag
8830: 20 62 61 67 29 0a 20 20 28 6c 65 74 20 28 28 72 bag). (let ((r
8840: 65 73 75 6c 74 20 28 6d 61 6b 65 2d 73 6f 62 20 esult (make-sob
8850: 28 73 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 20 (sob-comparator
8860: 62 61 67 29 20 23 66 29 29 29 0a 20 20 20 20 28 bag) #f))). (
8870: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
8880: 61 63 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 ach. (lambd
8890: 61 20 28 6b 65 79 20 76 61 6c 75 65 29 20 28 73 a (key value) (s
88a0: 6f 62 2d 69 6e 63 72 65 6d 65 6e 74 21 20 72 65 ob-increment! re
88b0: 73 75 6c 74 20 6b 65 79 20 76 61 6c 75 65 29 29 sult key value))
88c0: 0a 20 20 20 20 20 20 28 73 6f 62 2d 68 61 73 68 . (sob-hash
88d0: 2d 74 61 62 6c 65 20 62 61 67 29 29 0a 20 20 20 -table bag)).
88e0: 20 72 65 73 75 6c 74 29 29 0a 0a 28 64 65 66 69 result))..(defi
88f0: 6e 65 20 28 73 65 74 2d 3e 62 61 67 20 73 65 74 ne (set->bag set
8900: 29 0a 20 20 28 63 68 65 63 6b 2d 73 65 74 20 73 ). (check-set s
8910: 65 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 et). (let ((res
8920: 75 6c 74 20 28 6d 61 6b 65 2d 73 6f 62 20 28 73 ult (make-sob (s
8930: 6f 62 2d 63 6f 6d 70 61 72 61 74 6f 72 20 73 65 ob-comparator se
8940: 74 29 20 23 74 29 29 29 0a 20 20 20 20 28 68 61 t) #t))). (ha
8950: 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 sh-table-for-eac
8960: 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h. (lambda
8970: 28 6b 65 79 20 76 61 6c 75 65 29 20 28 73 6f 62 (key value) (sob
8980: 2d 69 6e 63 72 65 6d 65 6e 74 21 20 72 65 73 75 -increment! resu
8990: 6c 74 20 6b 65 79 20 76 61 6c 75 65 29 29 0a 20 lt key value)).
89a0: 20 20 20 20 20 28 73 6f 62 2d 68 61 73 68 2d 74 (sob-hash-t
89b0: 61 62 6c 65 20 73 65 74 29 29 0a 20 20 20 20 72 able set)). r
89c0: 65 73 75 6c 74 29 29 0a 0a 28 64 65 66 69 6e 65 esult))..(define
89d0: 20 28 73 65 74 2d 3e 62 61 67 21 20 62 61 67 20 (set->bag! bag
89e0: 73 65 74 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 set). (check-ba
89f0: 67 20 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d g bag). (check-
8a00: 73 65 74 20 73 65 74 29 0a 20 20 28 63 68 65 63 set set). (chec
8a10: 6b 2d 73 61 6d 65 2d 63 6f 6d 70 61 72 61 74 6f k-same-comparato
8a20: 72 20 73 65 74 20 62 61 67 29 0a 20 20 28 68 61 r set bag). (ha
8a30: 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 sh-table-for-eac
8a40: 68 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b h. (lambda (k
8a50: 65 79 20 76 61 6c 75 65 29 20 28 73 6f 62 2d 69 ey value) (sob-i
8a60: 6e 63 72 65 6d 65 6e 74 21 20 62 61 67 20 6b 65 ncrement! bag ke
8a70: 79 20 76 61 6c 75 65 29 29 0a 20 20 20 20 28 73 y value)). (s
8a80: 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 73 65 ob-hash-table se
8a90: 74 29 29 0a 20 20 62 61 67 29 0a 0a 28 64 65 66 t)). bag)..(def
8aa0: 69 6e 65 20 28 62 61 67 2d 3e 61 6c 69 73 74 20 ine (bag->alist
8ab0: 62 61 67 29 0a 20 20 28 63 68 65 63 6b 2d 62 61 bag). (check-ba
8ac0: 67 20 62 61 67 29 0a 20 20 28 62 61 67 2d 66 6f g bag). (bag-fo
8ad0: 6c 64 2d 75 6e 69 71 75 65 0a 20 20 20 20 28 6c ld-unique. (l
8ae0: 61 6d 62 64 61 20 28 65 6c 65 6d 20 63 6f 75 6e ambda (elem coun
8af0: 74 20 6c 69 73 74 29 20 28 63 6f 6e 73 20 28 63 t list) (cons (c
8b00: 6f 6e 73 20 65 6c 65 6d 20 63 6f 75 6e 74 29 20 ons elem count)
8b10: 6c 69 73 74 29 29 0a 20 20 20 20 27 28 29 0a 20 list)). '().
8b20: 20 20 20 62 61 67 29 29 0a 0a 28 64 65 66 69 6e bag))..(defin
8b30: 65 20 28 61 6c 69 73 74 2d 3e 62 61 67 20 63 6f e (alist->bag co
8b40: 6d 70 61 72 61 74 6f 72 20 61 6c 69 73 74 29 0a mparator alist).
8b50: 20 20 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 (let* ((result
8b60: 20 28 62 61 67 20 63 6f 6d 70 61 72 61 74 6f 72 (bag comparator
8b70: 29 29 0a 20 20 20 20 20 20 20 20 20 28 68 74 20 )). (ht
8b80: 28 73 6f 62 2d 68 61 73 68 2d 74 61 62 6c 65 20 (sob-hash-table
8b90: 72 65 73 75 6c 74 29 29 29 0a 20 20 20 20 28 66 result))). (f
8ba0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 28 6c or-each. (l
8bb0: 61 6d 62 64 61 20 28 61 73 73 6f 63 29 0a 20 20 ambda (assoc).
8bc0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 65 6c 65 (let ((ele
8bd0: 6d 65 6e 74 20 28 63 61 72 20 61 73 73 6f 63 29 ment (car assoc)
8be0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
8bf0: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
8c00: 65 2d 63 6f 6e 74 61 69 6e 73 3f 20 68 74 20 65 e-contains? ht e
8c10: 6c 65 6d 65 6e 74 29 29 0a 20 20 20 20 20 20 20 lement)).
8c20: 20 20 20 20 20 20 20 28 73 6f 62 2d 69 6e 63 72 (sob-incr
8c30: 65 6d 65 6e 74 21 20 72 65 73 75 6c 74 20 65 6c ement! result el
8c40: 65 6d 65 6e 74 20 28 63 64 72 20 61 73 73 6f 63 ement (cdr assoc
8c50: 29 29 29 29 29 0a 20 20 20 20 20 20 61 6c 69 73 ))))). alis
8c60: 74 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a t). result)).
8c70: 0a 3b 3b 3b 20 43 6f 6d 70 61 72 61 74 6f 72 73 .;;; Comparators
8c80: 0a 0a 3b 3b 20 48 61 73 68 20 6f 76 65 72 20 73 ..;; Hash over s
8c90: 6f 62 73 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 obs.(define (sob
8ca0: 2d 68 61 73 68 20 73 6f 62 29 0a 20 20 28 6c 65 -hash sob). (le
8cb0: 74 2a 20 28 28 68 74 20 28 73 6f 62 2d 68 61 73 t* ((ht (sob-has
8cc0: 68 2d 74 61 62 6c 65 20 73 6f 62 29 29 0a 20 20 h-table sob)).
8cd0: 20 20 20 20 20 20 20 28 68 61 73 68 20 28 63 6f (hash (co
8ce0: 6d 70 61 72 61 74 6f 72 2d 68 61 73 68 2d 66 75 mparator-hash-fu
8cf0: 6e 63 74 69 6f 6e 20 28 73 6f 62 2d 63 6f 6d 70 nction (sob-comp
8d00: 61 72 61 74 6f 72 20 73 6f 62 29 29 29 29 0a 20 arator sob)))).
8d10: 20 20 20 28 73 6f 62 2d 66 6f 6c 64 0a 20 20 20 (sob-fold.
8d20: 20 20 20 28 6c 61 6d 62 64 61 20 28 65 6c 65 6d (lambda (elem
8d30: 65 6e 74 20 72 65 73 75 6c 74 29 20 28 2b 20 28 ent result) (+ (
8d40: 68 61 73 68 20 65 6c 65 6d 65 6e 74 29 20 72 65 hash element) re
8d50: 73 75 6c 74 29 29 0a 20 20 20 20 20 20 35 33 38 sult)). 538
8d60: 31 0a 20 20 20 20 20 20 73 6f 62 29 29 29 0a 0a 1. sob)))..
8d70: 3b 3b 20 53 65 74 20 61 6e 64 20 62 61 67 20 63 ;; Set and bag c
8d80: 6f 6d 70 61 72 61 74 6f 72 0a 0a 28 64 65 66 69 omparator..(defi
8d90: 6e 65 20 73 65 74 2d 63 6f 6d 70 61 72 61 74 6f ne set-comparato
8da0: 72 20 28 6d 61 6b 65 2d 63 6f 6d 70 61 72 61 74 r (make-comparat
8db0: 6f 72 20 73 65 74 3f 20 73 65 74 3d 3f 20 23 66 or set? set=? #f
8dc0: 20 73 6f 62 2d 68 61 73 68 29 29 0a 0a 28 64 65 sob-hash))..(de
8dd0: 66 69 6e 65 20 62 61 67 2d 63 6f 6d 70 61 72 61 fine bag-compara
8de0: 74 6f 72 20 28 6d 61 6b 65 2d 63 6f 6d 70 61 72 tor (make-compar
8df0: 61 74 6f 72 20 62 61 67 3f 20 62 61 67 3d 3f 20 ator bag? bag=?
8e00: 23 66 20 73 6f 62 2d 68 61 73 68 29 29 0a 0a 3b #f sob-hash))..;
8e10: 3b 3b 20 52 65 67 69 73 74 65 72 20 61 62 6f 76 ;; Register abov
8e20: 65 20 63 6f 6d 70 61 72 61 74 6f 72 73 20 66 6f e comparators fo
8e30: 72 20 75 73 65 20 62 79 20 64 65 66 61 75 6c 74 r use by default
8e40: 2d 63 6f 6d 70 61 72 61 74 6f 72 0a 28 64 65 66 -comparator.(def
8e50: 69 6e 65 20 69 6e 69 74 2d 63 6f 6d 70 61 72 61 ine init-compara
8e60: 74 6f 72 73 0a 20 20 28 62 65 67 69 6e 20 28 63 tors. (begin (c
8e70: 6f 6d 70 61 72 61 74 6f 72 2d 72 65 67 69 73 74 omparator-regist
8e80: 65 72 2d 64 65 66 61 75 6c 74 21 20 73 65 74 2d er-default! set-
8e90: 63 6f 6d 70 61 72 61 74 6f 72 29 0a 09 20 28 63 comparator).. (c
8ea0: 6f 6d 70 61 72 61 74 6f 72 2d 72 65 67 69 73 74 omparator-regist
8eb0: 65 72 2d 64 65 66 61 75 6c 74 21 20 62 61 67 2d er-default! bag-
8ec0: 63 6f 6d 70 61 72 61 74 6f 72 29 29 29 0a 0a 3b comparator)))..;
8ed0: 3b 3b 20 53 65 74 2f 62 61 67 20 70 72 69 6e 74 ;; Set/bag print
8ee0: 65 72 20 28 66 6f 72 20 64 65 62 75 67 67 69 6e er (for debuggin
8ef0: 67 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 6f 62 g)..(define (sob
8f00: 2d 70 72 69 6e 74 20 73 6f 62 20 70 6f 72 74 29 -print sob port)
8f10: 0a 20 20 28 64 69 73 70 6c 61 79 20 28 69 66 20 . (display (if
8f20: 28 73 6f 62 2d 6d 75 6c 74 69 3f 20 73 6f 62 29 (sob-multi? sob)
8f30: 20 22 26 62 61 67 5b 22 20 22 26 73 65 74 5b 22 "&bag[" "&set["
8f40: 29 20 70 6f 72 74 29 0a 20 20 28 73 6f 62 2d 66 ) port). (sob-f
8f50: 6f 72 2d 65 61 63 68 0a 20 20 20 20 28 6c 61 6d or-each. (lam
8f60: 62 64 61 20 28 65 6c 65 6d 29 20 28 64 69 73 70 bda (elem) (disp
8f70: 6c 61 79 20 22 20 22 20 70 6f 72 74 29 20 28 77 lay " " port) (w
8f80: 72 69 74 65 20 65 6c 65 6d 20 70 6f 72 74 29 29 rite elem port))
8f90: 0a 20 20 20 20 73 6f 62 29 0a 20 20 28 64 69 73 . sob). (dis
8fa0: 70 6c 61 79 20 22 20 5d 22 20 70 6f 72 74 29 29 play " ]" port))
8fb0: 0a 0a 3b 3b 20 43 68 69 63 6b 65 6e 2d 73 70 65 ..;; Chicken-spe
8fc0: 63 69 66 69 63 0a 28 63 6f 6e 64 2d 65 78 70 61 cific.(cond-expa
8fd0: 6e 64 0a 20 20 28 63 68 69 63 6b 65 6e 0a 20 20 nd. (chicken.
8fe0: 20 20 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 (define-record
8ff0: 2d 70 72 69 6e 74 65 72 20 73 6f 62 20 73 6f 62 -printer sob sob
9000: 2d 70 72 69 6e 74 29 29 0a 20 20 28 65 6c 73 65 -print)). (else
9010: 29 29 0a )).